*DECK MCGMRE
      SUBROUTINE  MCGMRE(SUBFFI,SUBFFA,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK,
     1                   IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,
     2                   MATALB,M,NANI,NMU,NMAX,NANGL,NREG,NSOUT,SOUR,
     3                   IAAC,ISCR,LC,LFORW,PACA,ITST,MAXI,QFR,PHIIN,
     4                   CAZ,CPO,ZMU,WZMU,V,EPS,EPSI,REPSI,IKRYL,SIGAL,
     5                   LPS,NG,NGEFF,NGIND,NCONV,LNCONV,NFUNL,NMOD,
     6                   ISGNR,KEYFLX,KEYCUR,STIS,NPJJM,REBFLG,LPRISM,
     7                   N2REG,N2SOU,NZP,DELU,FACSYM)
*
*-----------------------------------------------------------------------
*
*Purpose:
* solve the linear system obtained by the characteristics formalism
* with GMRES iterative approach.
*
*Copyright:
* Copyright (C) 2002 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): R. Le Tellier
*
*Parameters:
* SUBFFI  isotropic flux integration subroutine.
* SUBFFA  anisotropic flux integration subroutine.
* SUBSCH  track coefficients calculation subroutine.
* CYCLIC  cyclic tracking flag.
* KPSYS   pointer array for each group properties.
* IPRINT  print parameter (equal to zero for no print).
* IPTRK   pointer to the tracking (L_TRACK signature).
* IFTRAK  tracking file unit number.
* IPMACR  pointer to the macrolib LCM object.
* NDIM    number of dimensions for the geometry.
* K       total number of volumes for which specific values
*         of the neutron flux and reactions rates are required.
* N       total number of unknowns in vectors SUNKNO and FUNKNO.
* NLONG   number of spatial unknowns.
* PHIOUT  output flux vector.
* NZON    mixture-albedo index array in MCCG format.
* MATALB  albedo-mixture index array in MOCC format.
* M       number of material mixtures.
* NANI    scattering anisotropy (=1 for isotropic scattering).
* NMU     order of the polar quadrature set.
* NMAX    maximum number of elements in a track.
* NANGL   number of tracking angles in the plan.
* NREG    number of regions (volumes).
* NSOUT   number of outer surfaces.
* PHIANG  scratch.
* SOUR    scratch.
* IAAC    no acceleration / CDD acceleration of inner iterations (0/1).
* ISCR    no acceleration / SCR acceleration of inner iterations (0/1).
* LC      dimension of profiled matrices MCU and CQ.
* LFORW   flag set to .false. to transpose the coefficient matrix.
* PACA    type of preconditioner to solve the ACA corrective system.
* ITST    output: number of inner iterations.
* MAXI    maximum number of inner iterations allowed.
* QFR     input source vector.
* PHIIN   input flux vector.
* CAZ     cosines of the different tracking azimuthal angles.
* CPO     cosines of the different tracking polar angles.
*         (polar quadrature in 2D / tracking angles in 3D).
* ZMU     polar quadrature set.
* WZMU    polar quadrature set.
* V       volumes.
* EPS     precision reached after min(MAXI,ITST) iterations.
* EPSI    tolerance for stopping criterion. process is stopped
*         as soon as ( ||.|| is the euclidean norm):
*         ||Phi(n+1)-Phi(n)||/||Phi(n)|| <= eps.
* REPSI   array containing precision of each iteration.
* IKRYL   size of Krylov subspace.
* SIGAL   total cross-section and albedo array.
* LPS     used in scr acceleration.
* NG      number of groups.
* NGEFF   number of groups to process.
* NGIND   index of the groups to process.
* NCONV   array of convergence flag for each group.
* LNCONV  number of unconverged groups.
* NFUNL   number of moments of the flux (in 2D : NFUNL=NANI*(NANI+1)/2).
* NMOD    second dimension of ISGNR.
* ISGNR   array of the spherical harmonics signs. 
* KEYFLX  position of flux elements in PHIOUT vector.
* KEYCUR  position of current elements in PHIOUT vector.
* STIS    'Source term isolation' option for flux integration.
* NPJJM   number of pjj modes to store for STIS option.
* REBFLG  ACA or SCR rebalancing flag.
* LPRISM  3D prismatic extended tracking flag.
* N2REG   number of regions in the 2D tracking if LPRISM.
* N2SOU   number of external surfaces in the 2D tracking if LPRISM.
* NZP     number of z-plans if LPRISM.
* DELU    input track spacing for 3D track reconstruction if LPRISM.
* FACSYM  tracking symmetry factor for maximum track length if LPRISM.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER NGEFF,KPSYS(NGEFF),IPRINT,IPTRK,IFTRAK,IPMACR,NDIM,K,N,
     1 NLONG,NG,NZON(NLONG),M,NANI,NMU,NMAX,IAAC,LC,PACA,ITST(NGEFF),
     2 IKRYL,MAXI,NANGL,NREG,NSOUT,ISCR,LPS,NGIND(NGEFF),
     3 LNCONV,NFUNL,NMOD,ISGNR(NFUNL,NMOD),KEYFLX(NREG,NFUNL),
     4 KEYCUR(NLONG-NREG),STIS,NPJJM,MATALB(-NSOUT:NREG),N2REG,N2SOU,NZP
      REAL QFR(N,NG),PHIIN(N,NG),CAZ(NANGL),CPO(*),ZMU(NMU),
     1 WZMU(NMU),V(NLONG),EPS(NGEFF),EPSI,REPSI(MAXI,NGEFF),
     2 SIGAL(-6:M,NGEFF),DELU,FACSYM
      DOUBLE PRECISION PHIOUT(N,NGEFF),SOUR(N,NGEFF)
      LOGICAL LFORW,CYCLIC,NCONV(NGEFF),REBFLG,LPRISM
      EXTERNAL SUBFFI,SUBFFA,SUBSCH
*---
*   LOCAL VARIABLES
*---
      REAL FAC
      PARAMETER (FAC=100.0)
      INTEGER N1,I,J,L,J1,I1,IL,II,IG,ITER,MAXINT,MAXI1
      REAL RO,T,GAM,EPSIMAX,EPSINT,REPSMAX,EPSINTO,SDOT
      DOUBLE PRECISION DDOT
      LOGICAL RHSFLG,BEGIN
      INTRINSIC SQRT,ABS,MOD
*----
*  ALLOCATABLE ARRAYS
*----
      REAL, ALLOCATABLE, DIMENSION(:,:) :: RHS,PHI,C,S,RS,RS2
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: AUX,HH
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(RHS(N,NGEFF),PHI(N,NGEFF),AUX(N,NGEFF,IKRYL+1),
     1 HH(IKRYL+1,IKRYL,NGEFF),C(IKRYL,NGEFF),S(IKRYL,NGEFF),
     2 RS(IKRYL+1,NGEFF),RS2(IKRYL+1,NGEFF))
*---
      RHSFLG=.TRUE.
      EPSIMAX=1E-7
      EPSINTO=EPSI/FAC
      MAXINT=200
      N1=N+1
*---
      ITER=1
*     a first iteration
      CALL MCGFL1(SUBFFI,SUBFFA,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK,IFTRAK,
     1     IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB,M,NANI,NMU,NMAX,
     2     NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC,ISCR,LC,LFORW,PACA,
     3     EPSINTO,MAXINT,NFUNL,NMOD,ISGNR,KEYFLX,KEYCUR,QFR,PHIIN,CAZ,
     4     CPO,ZMU,WZMU,V,SIGAL,LPS,NCONV,.FALSE.,.FALSE.,STIS,NPJJM,
     5     REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM)
      DO II=1,NGEFF
         IG=NGIND(II)
         IF (NCONV(II)) THEN
            DO J=1,N
               AUX(J,II,1)=REAL(PHIOUT(J,II))-PHIIN(J,IG)
               PHIIN(J,IG)=REAL(PHIOUT(J,II))
            ENDDO
            RO=SQRT(SDOT(N,AUX(1,II,1),1,AUX(1,II,1),1))
            REPSI(ITER,II)=REAL(RO/SQRT(
     1           DDOT(N,PHIOUT(1,II),1,PHIOUT(1,II),1)))
            IF ((REPSI(ITER,II).LE.EPSI).OR.(MAXI.LE.2)) THEN 
               NCONV(II)=.FALSE.
               ITST(II)=ITER
               EPS(II)=REPSI(ITER,II)
               LNCONV=LNCONV-1
            ENDIF
            IF (LNCONV.EQ.0) RETURN
         ENDIF
      ENDDO
*---
      MAXI1=MAXI-1
 10   CONTINUE
      DO WHILE((LNCONV.GT.0).AND.(ITER.LT.MAXI1))
*     beginning of outer loop
         ITER=ITER+1
         DO II=1,NGEFF
            IG=NGIND(II)
            IF (NCONV(II)) THEN
               DO J=1,N
                  PHI(J,II)=PHIIN(J,IG)
               ENDDO
            ENDIF
         ENDDO
*        compute initial residual vector
         CALL MCGFL1(SUBFFI,SUBFFA,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK,
     1        IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB,M,NANI,
     2        NMU,NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC,ISCR,
     2        LC,LFORW,PACA,EPSINTO,MAXINT,NFUNL,NMOD,ISGNR,KEYFLX,
     3        KEYCUR,QFR,PHIIN,CAZ,CPO,ZMU,WZMU,V,SIGAL,LPS,NCONV,
     4        .FALSE.,.FALSE.,STIS,NPJJM,REBFLG,LPRISM,N2REG,N2SOU,NZP,
     5        DELU,FACSYM)
         DO II=1,NGEFF
            IG=NGIND(II)
            IF (NCONV(II)) THEN
               DO J=1,N
                  AUX(J,II,1)=REAL(PHIOUT(J,II))-PHIIN(J,IG)
               ENDDO
               RO=SQRT(SDOT(N,AUX(1,II,1),1,AUX(1,II,1),1))
               REPSI(ITER,II)=REAL(RO/SQRT(
     1                        DDOT(N,PHIOUT(1,II),1,PHIOUT(1,II),1)))
               IF ((REPSI(ITER,II).LE.EPSI).OR.(MAXI.LE.3)) THEN 
                  NCONV(II)=.FALSE.
                  ITST(II)=ITER
                  EPS(II)=REPSI(ITER,II)
                  LNCONV=LNCONV-1
                  DO J=1,N
                     PHIIN(J,IG)=REAL(PHIOUT(J,II))
                  ENDDO
               ENDIF
               IF (LNCONV.EQ.0) RETURN
               RS(1,II)=RO
*              compute first vector v1=RO/||RO||
               DO J=1,N
                  AUX(J,II,1)=AUX(J,II,1)/RO
               ENDDO
            ENDIF
         ENDDO
*
*---
         IF (RHSFLG) THEN
*        evaluate RHS of the linear system
            IF (IPRINT.GT.3) THEN
               WRITE(6,100) IAAC,ISCR
            ENDIF
            CALL XDRSET(RHS,(N*NGEFF),0.0)
            CALL MCGFL1(SUBFFI,SUBFFA,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK,
     1           IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB,M,NANI,
     2           NMU,NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC,
     3           ISCR,LC,LFORW,PACA,EPSINTO,MAXINT,NFUNL,NMOD,ISGNR,
     4           KEYFLX,KEYCUR,QFR,RHS,CAZ,CPO,ZMU,WZMU,V,SIGAL,LPS,
     5           NCONV,.TRUE.,.FALSE.,STIS,NPJJM,REBFLG,LPRISM,N2REG,
     6           N2SOU,NZP,DELU,FACSYM)
            DO II=1,NGEFF
               IF (NCONV(II)) THEN
                  DO J=1,N
                     RHS(J,II)=REAL(PHIOUT(J,II))
                  ENDDO
               ENDIF
            ENDDO
            RHSFLG=.FALSE.
         ENDIF
*---
         I=0
         BEGIN=.TRUE.
         REPSMAX=0.0
         DO WHILE ((I.LT.IKRYL).AND.(LNCONV.GT.0)
     1                         .AND.(ITER.LT.MAXI1))
            I=I+1
            ITER=ITER+1
            I1=I+1
            IF (BEGIN) THEN
               EPSINT=EPSINTO
               BEGIN=.FALSE.
            ELSE
               EPSINT=MAX(EPSINTO,
     1                    MIN(1.0,(EPSINTO/MIN(FAC*REPSMAX,1.0))))
            ENDIF
            CALL MCGFL1(SUBFFI,SUBFFA,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK,
     1           IFTRAK,IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB,M,NANI,
     2           NMU,NMAX,NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,IAAC,
     3           ISCR,LC,LFORW,PACA,EPSINT,MAXINT,NFUNL,NMOD,ISGNR,
     4           KEYFLX,KEYCUR,QFR,AUX(1,1,I),CAZ,CPO,ZMU,WZMU,V,SIGAL,
     5           LPS,NCONV,.TRUE.,.FALSE.,STIS,NPJJM,REBFLG,LPRISM,
     6           N2REG,N2SOU,NZP,DELU,FACSYM)
            REPSMAX=0.0
            DO II=1,NGEFF
               IG=NGIND(II)
               IF (NCONV(II)) THEN
                  DO J=1,N
                   AUX(J,II,I1)=AUX(J,II,I)-REAL(PHIOUT(J,II))+RHS(J,II)
                  ENDDO
*                 apply modified Gram-Schmidt with Arnoldi step
                  DO J=1,I
                     T=SDOT(N,AUX(1,II,J),1,AUX(1,II,I1),1)
                     HH(J,I,II)=T
                     CALL SAXPY(N,-T,AUX(1,II,J),1,AUX(1,II,I1),1)
                  ENDDO
                  T=SQRT(SDOT(N,AUX(1,II,I1),1,AUX(1,II,I1),1))
                  HH(I1,I,II)=T
                  IF (T.NE.(0.0)) THEN
                     T=1.0/T
                     DO J=1,N
                        AUX(J,II,I1)=AUX(J,II,I1)*T
                     ENDDO
                  ENDIF
*                 update factorization of Heisenberg matrix HH (Givens rotation)
                  IF (I.NE.1) THEN
*                 perform previous transformations on i-th column of HH
                     DO J=2,I
                        J1=J-1
                        T=HH(J1,I,II)
                        HH(J1,I,II)=C(J1,II)*T+S(J1,II)*HH(J,I,II)
                        HH(J,I,II)=-S(J1,II)*T+C(J1,II)*HH(J,I,II)
                     ENDDO
                  ENDIF
                  GAM=SQRT(HH(I,I,II)**2+HH(I1,I,II)**2)
                  IF (GAM.EQ.(0.0)) GAM=EPSIMAX
*                 determine next plane rotation
                  C(I,II)=HH(I,I,II)/GAM
                  S(I,II)=HH(I1,I,II)/GAM
                  RS(I1,II)=-S(I,II)*RS(I,II)
                  RS(I,II)=C(I,II)*RS(I,II)
*                 determine residual norm
                  HH(I,I,II)=C(I,II)*HH(I,I,II)+S(I,II)*HH(I1,I,II)
                  RO=ABS(RS(I1,II))
*
*                 compute solution
*                 first solve upper triangular system.
                  DO J=1,I
                     RS2(J,II)=RS(J,II)
                  ENDDO
                  RS2(I,II)=RS2(I,II)/HH(I,I,II)
                  DO IL=2,I
                     L=I-IL+1
                     T=RS2(L,II)
                     DO J=(L+1),I
                        T=T-HH(L,J,II)*RS2(J,II)
                     ENDDO
                     RS2(L,II)=T/HH(L,L,II)
                  ENDDO
*                 form linear combination to get solution
                  DO J=1,N
                     PHIIN(J,IG)=PHI(J,II)
                  ENDDO
                  DO J=1,I
                     T=RS2(J,II)
                     CALL SAXPY(N,T,AUX(1,II,J),1,PHIIN(1,IG),1)
                  ENDDO
                  REPSI(ITER,II)=RO/SQRT(SDOT(N,PHIIN(1,IG),1,
     1                                          PHIIN(1,IG),1))
                  REPSMAX=MAX(REPSMAX,REPSI(ITER,II))
                  IF (REPSI(ITER,II).LE.EPSI) THEN 
                     NCONV(II)=.FALSE.
                     ITST(II)=ITER
                     EPS(II)=REPSI(ITER,II)
                     LNCONV=LNCONV-1
                  ENDIF
               ENDIF
            ENDDO
         ENDDO
*     end of outer loop
      ENDDO
*      
*     determine final residual norm
      ITER=ITER+1
      DO II=1,NGEFF
         IF (NCONV(II)) THEN
            ITST(II)=ITER
         ELSE
            !IF (MOD(ITST(II),IKRYL).NE.1) THEN
               NCONV(II)=.TRUE.
               ITST(II)=ITST(II)+1
            !ENDIF
         ENDIF
      ENDDO
      CALL MCGFL1(SUBFFI,SUBFFA,SUBSCH,CYCLIC,KPSYS,IPRINT,IPTRK,IFTRAK,
     1     IPMACR,NDIM,K,N,NLONG,PHIOUT,NZON,MATALB,M,NANI,NMU,NMAX,
     2     NANGL,NREG,NSOUT,NG,NGEFF,NGIND,SOUR,0,0,LC,LFORW,PACA,
     3     EPSINTO,MAXINT,NFUNL,NMOD,ISGNR,KEYFLX,KEYCUR,QFR,PHIIN,CAZ,
     4     CPO,ZMU,WZMU,V,SIGAL,LPS,NCONV,.FALSE.,.FALSE.,STIS,NPJJM,
     5     REBFLG,LPRISM,N2REG,N2SOU,NZP,DELU,FACSYM)
      DO II=1,NGEFF
         IG=NGIND(II)
         IF (NCONV(II)) THEN
            DO J=1,N
               AUX(J,II,1)=REAL(PHIOUT(J,II))-PHIIN(J,IG)
               PHIIN(J,IG)=REAL(PHIOUT(J,II))
            ENDDO
            RO=SQRT(SDOT(N,AUX(1,II,1),1,AUX(1,II,1),1))
            REPSI(ITST(II),II)=RO/SQRT(SDOT(N,PHIIN(1,IG),1,
     1                                        PHIIN(1,IG),1))
            EPS(II)=REPSI(ITST(II),II)
         ENDIF
      ENDDO
      LNCONV=0
      IF (ITER.LT.MAXI) THEN
         DO II=1,NGEFF
            IF (EPS(II).GT.EPSI) THEN
               IF ((IAAC.GT.0).OR.(ISCR.GT.0)) THEN
                  IAAC=0
                  ISCR=0
                  RHSFLG=.TRUE.
               ENDIF
               IF (IPRINT.GT.2) THEN
                  WRITE(6,200) ITER
               ENDIF
               NCONV(II)=.TRUE.
               LNCONV=LNCONV+1
            ELSE
               NCONV(II)=.FALSE.
            ENDIF
         ENDDO
         IF (LNCONV.GT.0) GO TO 10
      ENDIF
!!!!      DO II=1,NGEFF
!!!!         IG=NGIND(II)
!!!!         IF (NCONV(II)) THEN
!!!!            DO J=1,N
!!!!               PHIIN(J,IG)=PHIOUT(J,II)
!!!!            ENDDO
!!!!         ENDIF
!!!!      ENDDO
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(RS2,RS,S,C,HH,AUX,PHI,RHS)
      RETURN
*
 100  FORMAT(31H RHS CALCULATED WITH AAC-SCR : ,I1,1H-,I1)
 200  FORMAT(37H WARNING : BAD PREVISION, RESTART AT ,I4,10H ITERATION)
      END
