*DECK SNGMRE
      SUBROUTINE SNGMRE (KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,
     1 NSTART,MAXIT,EPSINR,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,TITR)
*
*-----------------------------------------------------------------------
*
*Purpose:
* solve one-group transport equation for fluxes using the discrete
* ordinates (SN) method with a GMRES(m) acceleration.
*
*Copyright:
* Copyright (C) 2007 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): A. Hebert
*
*Parameters: input
* KPSYS   pointer to the assembly matrices.
* IPTRK   pointer to the tracking (L_TRACK signature).
* IFTRAK  not used.
* IMPX    print flag (equal to zero for no print).
* IDIR    not used.
* NREG    total number of regions for which specific values of the
*         neutron flux and reactions rates are required.
* NBMIX   number of mixtures.
* NUN     total number of unknowns in vectors SUNKNO and FUNKNO.
* NSTART  restarts the GMRES method every NSTART iterations.
* MAXIT   maximum number of inner iterations
* EPSINR  convergence criterion
* MAT     index-number of the mixture type assigned to each volume.
* VOL     volumes.
* KEYFLX  position of averaged flux elements in FUNKNO vector.
* FUNKNO  initial estimate of the solution.
* SUNKNO  input source vector.
* TITR    title.
*
*Parameters: input/output
* FUNKNO  unknown vector.
*
*-----------------------------------------------------------------------
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
*----
*  SUBROUTINE ARGUMENTS
*----
      CHARACTER   TITR*72
      INTEGER     KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,NSTART,
     1            MAXIT,MAT(NREG),KEYFLX(NREG)
      REAL        EPSINR,VOL(NREG),FUNKNO(NUN),SUNKNO(NUN)
*----
*  LOCAL VARIABLES
*----
      PARAMETER  (IUNOUT=6)
*----
*  ALLOCATABLE ARRAYS
*----
      REAL, ALLOCATABLE, DIMENSION(:) :: RR,QQ
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: V,H
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: G,C,S,X
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(V(NUN,NSTART+1),G(NSTART+1),H(NSTART,NSTART+1),
     1 C(NSTART+1),S(NSTART+1),X(NUN))
*----
*  GLOBAL GMRES ITERATION.
*----
      ALLOCATE(RR(NUN),QQ(NUN))
      EPS1=EPSINR*SQRT(SDOT(NUN,SUNKNO,1,SUNKNO,1))
      RHO=1.0E10
      ITER=0
      NITER=1
      DO WHILE((RHO.GT.EPS1).AND.(ITER.LT.MAXIT))
        DO I=1,NUN
          RR(I)=FUNKNO(I)
        ENDDO
        CALL SNFLUX(KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,MAT,
     1  VOL,KEYFLX,RR,SUNKNO,TITR,NITER)
        NITER=NITER+1
        DO I=1,NUN
          X(I)=RR(I)-FUNKNO(I)
        ENDDO
        RHO=SQRT(DDOT(NUN,X,1,X,1))
*----
*  TEST FOR TERMINATION ON ENTRY
*----
        IF(RHO.LT.EPS1) THEN
           DEALLOCATE(QQ,RR)
           GO TO 100
        ENDIF
*
        CALL XDDSET(G,NSTART+1,0.0D0)
        CALL XDDSET(H,NSTART*NSTART,0.0D0)
        CALL XDDSET(V,NUN*(NSTART+1),0.0D0)
        CALL XDDSET(C,NSTART+1,0.0D0)
        CALL XDDSET(S,NSTART+1,0.0D0)
        G(1)=RHO
        DO I=1,NUN
          V(I,1)=X(I)/RHO
          X(I)=FUNKNO(I)
        ENDDO
*----
*  GMRES(1) ITERATION
*----
        K=0
        DO WHILE((RHO.GT.EPS1).AND.(K.LT.NSTART).AND.(ITER.LT.MAXIT))
          K=K+1
          ITER=ITER+1
          WRITE(IUNOUT,300) ITER,RHO
          DO I=1,NUN
            RR(I)=REAL(V(I,K))
            QQ(I)=0.0
          ENDDO
          CALL SNFLUX(KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,MAT,
     1    VOL,KEYFLX,RR,QQ,TITR,NITER)
          NITER=NITER+1
          DO I=1,NUN
            V(I,K+1)=V(I,K)-RR(I)
          ENDDO
*----
*  MODIFIED GRAM-SCHMIDT
*----
          DO J=1,K
            HR=DDOT(NUN,V(1,J),1,V(1,K+1),1)
            H(J,K)=HR
            DO I=1,NUN
              V(I,K+1)=V(I,K+1)-HR*V(I,J)
            ENDDO
          ENDDO
          H(K+1,K)=SQRT(DDOT(NUN,V(1,K+1),1,V(1,K+1),1))
*----
*  REORTHOGONALIZE
*----
          DO J=1,K
            HR=DDOT(NUN,V(1,J),1,V(1,K+1),1)
            H(J,K)=H(J,K)+HR
            DO I=1,NUN
              V(I,K+1)=V(I,K+1)-HR*V(I,J)
            ENDDO
          ENDDO
          H(K+1,K)=SQRT(DDOT(NUN,V(1,K+1),1,V(1,K+1),1))
*----
*  WATCH OUT FOR HAPPY BREAKDOWN 
*----
          IF(H(K+1,K).NE.0.0) THEN
            DO I=1,NUN
              V(I,K+1)=V(I,K+1)/H(K+1,K)
            ENDDO
          ENDIF
*----
*  FORM AND STORE THE INFORMATION FOR THE NEW GIVENS ROTATION
*----
          DO I=1,K-1
            W1=C(I)*H(I,K)-S(I)*H(I+1,K)
            W2=S(I)*H(I,K)+C(I)*H(I+1,K)
            H(I,K)=W1
            H(I+1,K)=W2
          ENDDO
          ZNU=SQRT(H(K,K)**2+H(K+1,K)**2)
          IF(ZNU.NE.0.0) THEN
            C(K)=H(K,K)/ZNU
            S(K)=-H(K+1,K)/ZNU
            H(K,K)=C(K)*H(K,K)-S(K)*H(K+1,K)
            H(K+1,K)=0.0D0
            W1=C(K)*G(K)-S(K)*G(K+1)
            W2=S(K)*G(K)+C(K)*G(K+1)
            G(K)=W1
            G(K+1)=W2
          ENDIF
*----
*  UPDATE THE RESIDUAL NORM
*----
          RHO=ABS(G(K+1))
        ENDDO
*----
*  AT THIS POINT EITHER K > NSTART OR RHO < EPS1.
*  IT'S TIME TO COMPUTE X AND CYCLE.
*----
        DO J=1,K
          H(J,K+1)=G(J)
        ENDDO
        CALL ALSBD(K,1,H,IER,NSTART)
        IF(IER.NE.0) CALL XABORT('SNGMRE: SINGULAR MATRIX.')
        DO I=1,NUN
          FUNKNO(I)=REAL(X(I)+DDOT(K,V(I,1),NUN,H(1,K+1),1))
        ENDDO
      ENDDO
      DEALLOCATE(QQ,RR)
*
      IF(IMPX.GT.0) WRITE(IUNOUT,'(32H SNGMRE: NUMBER OF ONE-SPEED ITE,
     1 8HRATIONS=,I5,1H.)') ITER
*----
*  SCRATCH STORAGE DEALLOCATION
*----
  100 DEALLOCATE(X,S,C,H,G,V)
      RETURN
*
  300 FORMAT(28H SNGMRE: ONE-SPEED ITERATION,I4,10H  L2 NORM=,1P,E11.4)
      END
