*DECK SNF
      SUBROUTINE SNF (KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,MAT,
     1 VOL,KEYFLX,FUNKNO,SUNKNO,TITR)
*
*-----------------------------------------------------------------------
*
*Purpose:
* solve one-group transport equation for fluxes using the discrete
* ordinates (SN) method.
*
*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.
* MAT     index-number of the mixture type assigned to each volume.
* VOL     volumes.
* KEYFLX  position of averaged flux elements in FUNKNO vector.
* SUNKNO  input source vector.
* TITR    title.
*
*Parameters: input/output
* FUNKNO  unknown vector.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      CHARACTER   TITR*72
      TYPE(C_PTR) KPSYS,IPTRK
      INTEGER     IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,MAT(NREG),KEYFLX(NREG)
      REAL        VOL(NREG),FUNKNO(NUN),SUNKNO(NUN)
*----
*  LOCAL VARIABLES
*----
      PARAMETER  (IUNOUT=6,NSTATE=40)
      INTEGER     IPAR(NSTATE)
      LOGICAL     LBIHET,LIVO
      DOUBLE PRECISION F1,F2,R1,R2,DMU
      REAL, ALLOCATABLE, DIMENSION(:) :: SUNKN,OLD1,OLD2,FGAR
*----
*  RECOVER SN SPECIFIC PARAMETERS.
*----
      CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
      IF(NREG.NE.IPAR(1)) CALL XABORT('SNF: INVALID NREG ON LCM.')
      IF(NUN.NE.IPAR(2)) CALL XABORT('SNF: INVALID NUN ON LCM.')
      NSTART=IPAR(20)
      MAXIT=IPAR(22)
      LIVO=(IPAR(23).EQ.1)
      ICL1=IPAR(24)
      ICL2=IPAR(25)
      CALL LCMGET(IPTRK,'EPSI',EPSINR)
      IF(IMPX.GT.3) THEN
         ALLOCATE(FGAR(NREG))
         CALL XDRSET(FGAR,NREG,0.0)
         DO I=1,NREG
            IF(KEYFLX(I).NE.0) FGAR(I)=SUNKNO(KEYFLX(I))
         ENDDO
         WRITE(IUNOUT,'(//6H SNF: ,A72)') TITR
         WRITE(IUNOUT,'(/33H N E U T R O N    S O U R C E S :)')
         WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG)
         DEALLOCATE(FGAR)
      ENDIF
      LBIHET=IPAR(40).NE.0
*----
*  DOUBLE HETEROGENEITY TREATMENT.
*----
      NREGAR=0
      NBMIXG=0
      IF(LBIHET) THEN
         ALLOCATE(SUNKN(NUN))
         DO 5 I=1,NUN
    5    SUNKN(I)=SUNKNO(I)
         NREGAR=NREG
         NBMIXG=NBMIX
         CALL DOORFB2(KPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,NBMIX2,
     1   NREG2,SUNKNO)
         NREG=NREG2
         NBMIX=NBMIX2
         CALL LCMSIX(KPSYS,'BIHET',1)
      ENDIF
*
      IF(NSTART.GT.0) THEN
*----
*  GMRES(M) INNER ITERATION LOOP FOR ONE-GROUP TRANSPORT EQUATION.
*----
         CALL SNGMRE (KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,
     1   NSTART,MAXIT,EPSINR,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,TITR)
      ELSE
*----
*  LIVOLANT INNER ITERATION LOOP FOR ONE-GROUP TRANSPORT EQUATION.
*----
         ALLOCATE(OLD1(NUN),OLD2(NUN))
         CALL XDRSET(OLD2,NUN,0.0)
         TEST=0.0
         ITER=0
   10    ITER=ITER+1
         IF(ITER.GT.MAXIT) THEN
            WRITE(IUNOUT,'(40H SNF: MAXIMUM NUMBER OF ONE-SPEED ITERAT,
     1      12HION REACHED.)')
            GO TO 60
         ENDIF
*----
*  UPDATE THE FIXED SOURCE AND COMPUTE THE FLUX.
*----
         DO 20 I=1,NUN
         OLD1(I)=OLD2(I)
   20    OLD2(I)=FUNKNO(I)
         CALL SNFLUX(KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,MAT,
     1   VOL,KEYFLX,FUNKNO,SUNKNO,TITR,ITER)
*----
*  VARIATIONAL ACCELERATION.
*----
         IF(LIVO.AND.(MOD(ITER-1,ICL1+ICL2).GE.ICL1)) THEN
            F1=0.0
            F2=0.0
            DO 30 I=1,NUN
            R1=OLD2(I)-OLD1(I)
            R2=FUNKNO(I)-OLD2(I)
            F1=F1+R1*(R2-R1)
   30       F2=F2+(R2-R1)*(R2-R1)
            DMU=-F1/F2
            IF(DMU.GT.0.0) THEN
               DO 40 I=1,NUN
               FUNKNO(I)=OLD2(I)+REAL(DMU)*(FUNKNO(I)-OLD2(I))
               OLD2(I)=OLD1(I)+REAL(DMU)*(OLD2(I)-OLD1(I))
   40          CONTINUE
            ENDIF
         ELSE
            DMU=1.0D0
         ENDIF
*----
*  CALCULATE ERROR AND TEST FOR CONVERGENCE.
*----
         AAA=0.0
         BBB=0.0
         DO 50 I=1,NREG
         IF(KEYFLX(I).EQ.0) GO TO 50
         AAA=MAX(AAA,ABS(FUNKNO(KEYFLX(I))-OLD2(KEYFLX(I))))
         BBB=MAX(BBB,ABS(FUNKNO(KEYFLX(I))))
   50    CONTINUE
         IF(IMPX.GT.1) WRITE(IUNOUT,300) ITER,AAA,BBB,AAA/BBB,DMU
         IF(IMPX.GT.5) THEN
            ALLOCATE(FGAR(NREG))
            CALL XDRSET(FGAR,NREG,0.0)
            DO I=1,NREG
              IF(KEYFLX(I).NE.0) FGAR(I)=FUNKNO(KEYFLX(I))
            ENDDO
            WRITE(IUNOUT,'(//33H N E U T R O N    F L U X E S   :)')
            WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG)
            DEALLOCATE(FGAR)
         ENDIF
         IF(AAA.LE.0.1*EPSINR*BBB) GO TO 60
         IF(ITER.EQ.1) TEST=AAA
         IF((ITER.GE.10).AND.(AAA.GT.TEST)) THEN
            WRITE(IUNOUT,'(40H SNF: UNABLE TO CONVERGE ONE-SPEED ITERA,
     1      6HTIONS.)')
            GO TO 60
         ENDIF
         GO TO 10
   60    DEALLOCATE(OLD2,OLD1)
         IF(IMPX.GT.0) WRITE(IUNOUT,'(29H SNF: NUMBER OF ONE-SPEED ITE,
     1   8HRATIONS=,I5,1H.)') ITER
      ENDIF
*----
*  DOUBLE HETEROGENEITY TREATMENT.
*----
      IF(LBIHET) THEN
         CALL LCMSIX(KPSYS,' ',2)
         NREG=NREGAR
         NBMIX=NBMIXG
         DO 70 I=1,NUN
   70    SUNKNO(I)=SUNKN(I)
         DEALLOCATE(SUNKN)
         CALL DOORFB3(KPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,SUNKNO,
     1   FUNKNO)
      ENDIF
*
      IF(IMPX.GT.3) THEN
         ALLOCATE(FGAR(NREG))
         CALL XDRSET(FGAR,NREG,0.0)
         DO I=1,NREG
            IF(KEYFLX(I).NE.0) FGAR(I)=FUNKNO(KEYFLX(I))
         ENDDO
         WRITE(IUNOUT,'(//33H N E U T R O N    F L U X E S   :)')
         WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG)
         DEALLOCATE(FGAR)
      ENDIF
      RETURN
*
  300 FORMAT(26H SNF: ONE-SPEED ITERATION ,I3,8H  ERROR=,1P,E11.4,
     1 5H OVER,E11.4,5H PREC,E12.4,22H  ACCELERATION FACTOR=,0P,F7.3)
      END
