*DECK TRIVAF
      SUBROUTINE TRIVAF(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 diffusion
* approximation or simplified PN method in TRIVAC.
*
*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
*----
      TYPE(C_PTR) KPSYS,IPTRK
      CHARACTER   TITR*72
      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,MAXIT=20,EPSINR=1.0E-5,ICL1=3,
     1            ICL2=3)
      DOUBLE PRECISION F1,F2,R1,R2,DMU
      INTEGER     IPAR(NSTATE)
      LOGICAL     LBIHET,CHEX
      CHARACTER   NAMP*12
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: KN,ZGLOB
      REAL, ALLOCATABLE, DIMENSION(:) :: SUNKN,GAR,OLD1,OLD2,FGAR
*----
*  MULTIPLICATION OF THE SOURCES BY THE VOLUMES.
*----
      IF(IDIR.NE.0) CALL XABORT('TRIVAF: EXPECTING IDIR=0')
      IF(IFTRAK.NE.0) CALL XABORT('TRIVAF: EXPECTING IFTRAK=0')
      IF(IMPX.GT.2) 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,'(//9H TRIVAF: ,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
*----
*  RECOVER TRIVAC SPECIFIC PARAMETERS.
*----
      CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
      ITY=2
      CHEX=(IPAR(6).EQ.8).OR.(IPAR(6).EQ.9)
      IELEM=ABS(IPAR(9))
      LL4=IPAR(11)
      ISPLH=IPAR(13)
      LX=IPAR(14)
      LZ=IPAR(16)
      NLF=IPAR(30)
      IF(IPAR(12).EQ.2) ITY=3
      IF((NLF.GT.0).AND.(ITY.GE.3)) ITY=10+ITY
      IF((ITY.EQ.11).OR.(ITY.EQ.13)) LL4=LL4*NLF/2
      NADI=IPAR(33)
      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
*
      DO 10 K=1,NREG
      IF(MAT(K).EQ.0) GO TO 10
      JND1=KEYFLX(K)
      SUNKNO(JND1)=SUNKNO(JND1)*VOL(K)
   10 CONTINUE
*----
*  SOLVE FOR THE FLUXES. USE EQUATION (C.24) IN IGE-281.
*----
      NAMP='A001001'
      ALLOCATE(GAR(NUN),OLD1(NUN),OLD2(NUN))
      CALL XDRSET(OLD2,NUN,0.0)
      TEST=0.0
      ITER=0
   20 ITER=ITER+1
      IF(ITER.GT.MAXIT) THEN
      WRITE(IUNOUT,'(46H TRIVAF: MAXIMUM NUMBER OF ONE-SPEED ITERATION,
     1        9H REACHED.)')
         GO TO 110
      ENDIF
      DO 30 I=1,NUN
      OLD1(I)=OLD2(I)
   30 OLD2(I)=FUNKNO(I)
      CALL MTLDLM(NAMP,IPTRK,KPSYS,LL4,ITY,FUNKNO,GAR)
      DO 40 I=1,NUN
   40 GAR(I)=SUNKNO(I)-GAR(I)
      CALL FLDADI(NAMP,IPTRK,KPSYS,LL4,ITY,GAR,NADI)
      DO 50 I=1,NUN
   50 FUNKNO(I)=FUNKNO(I)+GAR(I)
*----
*  CALCULATION OF ELEMENT-AVERAGED FLUXES.
*----
      IF(CHEX) THEN
         NBLOS=LX*LZ*ISPLH**2
         CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM)
         ALLOCATE(ZGLOB(NBLOS),KN(MAXKN))
         CALL LCMGET(IPTRK,'ZGLOB',ZGLOB)
         CALL LCMGET(IPTRK,'KN',KN)
         DO 60 IHEX=1,NREG
         IF(KEYFLX(IHEX).NE.0) FUNKNO(KEYFLX(IHEX))=0.0
   60    CONTINUE
         NUM=0
         DO 70 KEL=1,NBLOS
         IHEX=ZGLOB(KEL)
         IF(IHEX.EQ.0) GO TO 70
         NUM=NUM+1
         JND1=(NUM-1)*IELEM**3+1
         JND2=(KN(NUM)-1)*IELEM**3+1
         JND3=(KN(NBLOS+NUM)-1)*IELEM**3+1
         TEMP=FUNKNO(JND1)+FUNKNO(JND2)+FUNKNO(JND3)
         FUNKNO(KEYFLX(IHEX))=FUNKNO(KEYFLX(IHEX))+TEMP/REAL(3*ISPLH**2)
   70    CONTINUE
         DEALLOCATE(KN,ZGLOB)
      ENDIF
*----
*  VARIATIONAL ACCELERATION.
*----
      IF(MOD(ITER-1,ICL1+ICL2).GE.ICL1) THEN
         F1=0.0
         F2=0.0
         DO  80 I=1,NUN
         R1=OLD2(I)-OLD1(I)
         R2=FUNKNO(I)-OLD2(I)
         F1=F1+R1*(R2-R1)
   80    F2=F2+(R2-R1)*(R2-R1)
         DMU=-F1/F2
         IF(DMU.GT.0.0) THEN
            DO  90 I=1,NUN
            FUNKNO(I)=OLD2(I)+REAL(DMU)*(FUNKNO(I)-OLD2(I))
            OLD2(I)=OLD1(I)+REAL(DMU)*(OLD2(I)-OLD1(I))
   90       CONTINUE
         ENDIF
      ENDIF      
      AAA=0.0
      BBB=0.0
      DO 100 I=1,NREG
      IF(KEYFLX(I).EQ.0) GO TO 100
      AAA=MAX(AAA,ABS(FUNKNO(KEYFLX(I))-OLD2(KEYFLX(I))))
      BBB=MAX(BBB,ABS(FUNKNO(KEYFLX(I))))
  100 CONTINUE
      IF(IMPX.GT.1) WRITE(IUNOUT,300) ITER,AAA,BBB,DMU
      IF(AAA.LE.EPSINR*BBB) GO TO 110
      IF(ITER.EQ.1) TEST=AAA
      IF((ITER.GE.10).AND.(AAA.GT.TEST)) THEN
         WRITE(IUNOUT,'(43H TRIVAF: UNABLE TO CONVERGE ONE-SPEED ITERA,
     1   6HTIONS.)')
         GO TO 110
      ENDIF
      GO TO 20
  110 DEALLOCATE(OLD2,OLD1,GAR)
*----
*  DIVISION OF THE SOURCES BY THE VOLUMES.
*----
      DO 120 K=1,NREG
      IF(MAT(K).EQ.0) GO TO 120
      JND1=KEYFLX(K)
      SUNKNO(JND1)=SUNKNO(JND1)/VOL(K)
  120 CONTINUE
*----
*  DOUBLE HETEROGENEITY TREATMENT
*----
      IF(LBIHET) THEN
         CALL LCMSIX(KPSYS,' ',2)
         NREG=NREGAR
         NBMIX=NBMIXG
         DO 130 I=1,NUN
  130    SUNKNO(I)=SUNKN(I)
         DEALLOCATE(SUNKN)
         CALL DOORFB3(KPSYS,IPTRK,IMPX,NBMIX,NREG,NUN,KEYFLX,SUNKNO,
     1   FUNKNO)
      ENDIF
*
      IF(IMPX.GT.2) 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,'(//39H C O R R E C T I V E S  F L U X E S   :)')
         WRITE(IUNOUT,'(1P,6(5X,E15.7))') (FGAR(I),I=1,NREG)
         DEALLOCATE(FGAR)
      ENDIF
      RETURN
  300 FORMAT(28H TRIVAF: ONE-SPEED ITERATION,I3,8H  ERROR=,1P,E11.4,
     1 5H OVER,E11.4,22H  ACCELERATION FACTOR=,0P,F7.3)
      END
