*DECK SNFLUX
      SUBROUTINE SNFLUX (KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,
     1 MAT,VOL,KEYFLX,FUNKNO,SUNKNO,TITR,ITER)
*
*-----------------------------------------------------------------------
*
*Purpose:
* solve a single non-accelerated scattering iteration of the 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.
* ITER    number of previous calls to SNFLUX.
*
*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),
     1            KEYFLX(NREG),ITER
      REAL        VOL(NREG),FUNKNO(NUN),SUNKNO(NUN)
*----
*  LOCAL VARIABLES
*----
      PARAMETER  (IUNOUT=6,NSTATE=40)
      INTEGER     IPAR(NSTATE),NCODE(6)
      REAL        ZCODE(6)
      LOGICAL     LFIXUP,LDSA
      REAL, TARGET, SAVE, DIMENSION(1) :: DUMMY
*----
*  ALLOCATABLE ARRAYS
*---
      REAL, ALLOCATABLE, DIMENSION(:) :: QEXT,OLD,SGAR,SGAS,BSNX,BSNY,
     1 BSNZ
*
      TYPE(C_PTR) U_PTR,W_PTR,PL_PTR,JOP_PTR,UPQ_PTR,WPQ_PTR,ALPHA_PTR,
     1 PLZ_PTR,SURF_PTR,XXX_PTR,DU_PTR,DE_PTR,MRM_PTR,MRMX_PTR,MRMY_PTR,
     2 MRMZ_PTR,DB_PTR,DA_PTR,DAL_PTR,DZ_PTR,DC_PTR
      INTEGER, POINTER, DIMENSION(:) :: JOP,MRM,MRMX,MRMY,MRMZ
      REAL, POINTER, DIMENSION(:) :: U,W,PL,UPQ,WPQ,ALPHA,PLZ,SURF,DU,
     1 DE,XXX,DB,DA,DAL,DZ,DC
*----
*  RECOVER SN SPECIFIC PARAMETERS.
*----
      CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
      ITYPE=IPAR(6)
      IELEM=IPAR(8)
      L4=IPAR(11)
      LX=IPAR(12)
      LY=IPAR(13)
      LZ=IPAR(14)
      NLF=IPAR(15)
      ISCAT=IPAR(16)
      LFIXUP=IPAR(18).EQ.1
      LDSA=IPAR(19).EQ.1
      NSDSA=IPAR(21)
      IGAV=IPAR(30)
      IF(IMPX.GT.2) THEN
         WRITE(IUNOUT,'(//33H N E U T R O N    S O U R C E S :)')
         WRITE(IUNOUT,'(1P,6(5X,E15.7))') (SUNKNO(KEYFLX(I)),I=1,NREG)
      ENDIF
      ALLOCATE(QEXT(NUN),OLD(NUN))
*----
*  WITHIN-GROUP SCATTERING REMOVAL FROM TOTAL CROSS SECTION.
*----
      CALL LCMLEN(KPSYS,'DRAGON-TXSC',ILONG,ITYLCM)
      IF(ILONG.NE.NBMIX+1) CALL XABORT('SNFLUX: INVALID TXSC LENGTH.')
      ALLOCATE(SGAR(ILONG))
      CALL LCMLEN(KPSYS,'DRAGON-S0XSC',ILONG,ITYLCM)
      NANI=ILONG/(NBMIX+1)
      ALLOCATE(SGAS(ILONG))
      CALL LCMGET(KPSYS,'DRAGON-TXSC',SGAR)
      CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS)
*----
*  COMPUTE THE FLUX.
*----
      DO 20 I=1,NUN
      QEXT(I)=SUNKNO(I)
   20 OLD(I)=FUNKNO(I)
      IF(ITYPE.EQ.2) THEN
         NSCT=ISCAT
         IF(IELEM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW'
     1   //'(1)')
         DO 40 IR=1,NREG
         IBM=MAT(IR)
         IF(IBM.EQ.0) GO TO 40
         DO 30 IL=0,MIN(ISCAT,NANI)-1
         FACT=REAL(2*IL+1)
         DO 30 IEL=1,IELEM
         IND=(IR-1)*NSCT*IELEM+IELEM*IL+IEL
   30    QEXT(IND)=QEXT(IND)+FACT*SGAS(IL*(NBMIX+1)+IBM+1)*FUNKNO(IND)
   40    CONTINUE
         CALL LCMGPD(IPTRK,'U',U_PTR)
         CALL LCMGPD(IPTRK,'W',W_PTR)
         CALL LCMGPD(IPTRK,'PL',PL_PTR)
         CALL C_F_POINTER(U_PTR,U,(/ NLF /))
         CALL C_F_POINTER(W_PTR,W,(/ NLF /))
         CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NLF /))
         CALL LCMGET(IPTRK,'NCODE',NCODE)
         CALL LCMGET(IPTRK,'ZCODE',ZCODE)
         CALL SNFT1P(NREG,NBMIX,IELEM,NLF,NSCT,U,W,PL,MAT,VOL,SGAR,
     1   NCODE,ZCODE,QEXT,LFIXUP,FUNKNO)
      ELSE IF(ITYPE.EQ.3) THEN
         IF(IELEM.NE.1) CALL XABORT('SNFLUX: DIAM 1 EXPECTED(1).')
         NSCT=(ISCAT/2)*(ISCAT/2+1)+(ISCAT+1)*MOD(ISCAT,2)/2
         IF(NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW(2)')
         DO 60 IR=1,NREG
         IBM=MAT(IR)
         IF(IBM.EQ.0) GO TO 60
         IOF=0
         DO 50 IL=0,MIN(ISCAT,NANI)-1
         FACT=REAL(2*IL+1)
         DO 50 IM=0,IL
         IF(MOD(IL+IM,2).EQ.1) GO TO 50
         IOF=IOF+1
         IND=(IR-1)*NSCT+IOF
         QEXT(IND)=QEXT(IND)+FACT*SGAS(IL*(NBMIX+1)+IBM+1)*FUNKNO(IND)
   50    CONTINUE
   60    CONTINUE
         M2=NLF/2
         CALL LCMLEN(IPTRK,'UPQ',NPQ,ITYLCM)
         CALL LCMGPD(IPTRK,'JOP',JOP_PTR)
         CALL LCMGPD(IPTRK,'U',U_PTR)
         CALL LCMGPD(IPTRK,'UPQ',UPQ_PTR)
         CALL LCMGPD(IPTRK,'WPQ',WPQ_PTR)
         CALL LCMGPD(IPTRK,'ALPHA',ALPHA_PTR)
         CALL LCMGPD(IPTRK,'PLZ',PLZ_PTR)
         CALL LCMGPD(IPTRK,'PL',PL_PTR)
         CALL LCMGPD(IPTRK,'SURF',SURF_PTR)
         CALL LCMGET(IPTRK,'ZCODE',ZCODE)
*
         CALL C_F_POINTER(JOP_PTR,JOP,(/ M2 /))
         CALL C_F_POINTER(U_PTR,U,(/ NPQ /))
         CALL C_F_POINTER(UPQ_PTR,UPQ,(/ NPQ /))
         CALL C_F_POINTER(WPQ_PTR,WPQ,(/ NPQ /))
         CALL C_F_POINTER(ALPHA_PTR,ALPHA,(/ NPQ /))
         CALL C_F_POINTER(PLZ_PTR,PLZ,(/ NSCT*M2 /))
         CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NPQ /))
         CALL C_F_POINTER(SURF_PTR,SURF,(/ NREG+1 /))
*
         CURR=0.0
         CALL SNFT1C(NREG,NBMIX,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,ALPHA,
     1   PLZ,PL,MAT,VOL,SURF,SGAR,IGAV,QEXT,LFIXUP,CURR,FUNKNO)
         IF(ZCODE(2).NE.0.0) THEN
           CA=CURR
           CB=1.0
           CALL SNFT1C(NREG,NBMIX,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,
     1     ALPHA,PLZ,PL,MAT,VOL,SURF,SGAR,IGAV,QEXT,LFIXUP,CB,FUNKNO)
           CURR=ZCODE(2)*CA/(1.0+ZCODE(2)*(CA-CB))
           CALL SNFT1C(NREG,NBMIX,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,
     1     ALPHA,PLZ,PL,MAT,VOL,SURF,SGAR,IGAV,QEXT,LFIXUP,CURR,FUNKNO)
         ENDIF
      ELSE IF(ITYPE.EQ.4) THEN
         IF(IELEM.NE.1) CALL XABORT('SNFLUX: DIAM 1 EXPECTED(2).')
         NSCT=ISCAT
         IF(NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW(3)')
         DO 80 IR=1,NREG
         IBM=MAT(IR)
         IF(IBM.EQ.0) GO TO 80
         DO 70 IL=0,MIN(ISCAT,NANI)-1
         FACT=REAL(2*IL+1)
         IND=(IR-1)*NSCT+IL+1
   70    QEXT(IND)=QEXT(IND)+FACT*SGAS(IL*(NBMIX+1)+IBM+1)*FUNKNO(IND)
   80    CONTINUE
         CALL LCMGPD(IPTRK,'U',U_PTR)
         CALL LCMGPD(IPTRK,'W',W_PTR)
         CALL LCMGPD(IPTRK,'ALPHA',ALPHA_PTR)
         CALL LCMGPD(IPTRK,'PLZ',PLZ_PTR)
         CALL LCMGPD(IPTRK,'PL',PL_PTR)
         CALL LCMGPD(IPTRK,'SURF',SURF_PTR)
         CALL LCMGPD(IPTRK,'XXX',XXX_PTR)
         CALL LCMGET(IPTRK,'ZCODE',ZCODE)
*
         CALL C_F_POINTER(U_PTR,U,(/ NLF /))
         CALL C_F_POINTER(W_PTR,W,(/ NLF /))
         CALL C_F_POINTER(ALPHA_PTR,ALPHA,(/ NLF /))
         CALL C_F_POINTER(PLZ_PTR,PLZ,(/ NSCT*M2 /))
         CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NLF /))
         CALL C_F_POINTER(SURF_PTR,SURF,(/ NREG+1 /))
         CALL C_F_POINTER(XXX_PTR,XXX,(/ NREG+1 /))
         CURR=0.0
         CALL SNFT1S(NREG,NBMIX,NLF,NSCT,U,W,ALPHA,PLZ,PL,MAT,VOL,SURF,
     1   XXX,SGAR,IGAV,QEXT,LFIXUP,CURR,FUNKNO)
         IF(ZCODE(2).NE.0.0) THEN
            CA=CURR
            CB=1.0
            CALL SNFT1S(NREG,NBMIX,NLF,NSCT,U,W,ALPHA,PLZ,PL,MAT,VOL,
     1      SURF,XXX,SGAR,IGAV,QEXT,LFIXUP,CB,FUNKNO)
            CURR=ZCODE(2)*CA/(1.0+ZCODE(2)*(CA-CB))
            CALL SNFT1S(NREG,NBMIX,NLF,NSCT,U,W,ALPHA,PLZ,PL,MAT,VOL,
     1      SURF,XXX,SGAR,IGAV,QEXT,LFIXUP,CURR,FUNKNO)
         ENDIF
      ELSE IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6)) THEN
         NSCT=ISCAT*(ISCAT+1)/2
         IF(NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW(4)')
         IGE=0
         IF(ITYPE.EQ.6) IGE=1
         DO 100 IR=1,NREG
         IBM=MAT(IR)
         IF(IBM.EQ.0) GO TO 100
         IOF=0
         DO 90 IL=0,MIN(ISCAT,NANI)-1
         FACT=REAL(2*IL+1)
         DO 90 IM=-IL,IL
         IF(MOD(IL+IM,2).EQ.1) GO TO 90
         IOF=IOF+1
         DO 85 IEL=1,IELEM*IELEM
         IND=(IR-1)*NSCT*IELEM*IELEM+(IOF-1)*IELEM*IELEM+IEL
   85    QEXT(IND)=QEXT(IND)+FACT*SGAS(IL*(NBMIX+1)+IBM+1)*FUNKNO(IND)
   90    CONTINUE
  100    CONTINUE
         CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM)
         CALL LCMGPD(IPTRK,'DU',DU_PTR)
         CALL LCMGPD(IPTRK,'DE',DE_PTR)
         CALL LCMGPD(IPTRK,'W',W_PTR)
         CALL LCMGPD(IPTRK,'MRM',MRM_PTR)
         CALL LCMGPD(IPTRK,'MRMY',MRMY_PTR)
         CALL LCMGPD(IPTRK,'DB',DB_PTR)
         CALL LCMGPD(IPTRK,'DA',DA_PTR)
         IF(IGE.GT.0) CALL LCMGPD(IPTRK,'DAL',DAL_PTR)
         CALL LCMGPD(IPTRK,'PL',PL_PTR)
*
         CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /))
         CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /))
         CALL C_F_POINTER(W_PTR,W,(/ NPQ /))
         CALL C_F_POINTER(MRM_PTR,MRM,(/ NPQ /))
         CALL C_F_POINTER(MRMY_PTR,MRMY,(/ NPQ /))
         CALL C_F_POINTER(DB_PTR,DB,(/ LX*NPQ /))
         CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /))
         IF(IGE.GT.0) THEN
            CALL C_F_POINTER(DAL_PTR,DAL,(/ LX*LY*NPQ /))
         ELSE
            DAL=>DUMMY
         ENDIF
         CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NPQ /))
*
         CALL LCMGET(IPTRK,'NCODE',NCODE)
         CALL LCMGET(IPTRK,'ZCODE',ZCODE)
*
         CALL SNFT12(IGE,LX,LY,IELEM,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,
     1   ZCODE,QEXT,LFIXUP,DU,DE,W,MRM,MRMY,DB,DA,DAL,PL,FUNKNO,
     2   FUNKNO(L4+1),FUNKNO(L4+IELEM*LY*NPQ+1))
      ELSE IF(ITYPE.EQ.7) THEN
*----
*  3D CARTESIAN CASE
*----
         NSCT=(ISCAT+1)**2
         IF(NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW(5)')
         IGE=0
         DO 310 IR=1,NREG
         IBM=MAT(IR)
         IF(IBM.EQ.0) GO TO 310
         IOF=0
         DO 320 IL=0,MIN(ISCAT,NANI)-1
         FACT=REAL(2*IL+1)
         DO 320 IM=-IL,IL
         IOF=IOF+1
         DO 330 IEL=1,IELEM*IELEM*IELEM
         IND=(IR-1)*NSCT*IELEM*IELEM*IELEM+(IOF-1)*IELEM*IELEM*IELEM+IEL
  330    QEXT(IND)=QEXT(IND)+FACT*SGAS(IL*(NBMIX+1)+IBM+1)*FUNKNO(IND)
  320    CONTINUE
  310    CONTINUE
         CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM)
         CALL LCMGPD(IPTRK,'DU',DU_PTR)
         CALL LCMGPD(IPTRK,'DE',DE_PTR)
         CALL LCMGPD(IPTRK,'DZ',DZ_PTR)
         CALL LCMGPD(IPTRK,'W',W_PTR)
         CALL LCMGPD(IPTRK,'MRMX',MRMX_PTR)
         CALL LCMGPD(IPTRK,'MRMY',MRMY_PTR)
         CALL LCMGPD(IPTRK,'MRMZ',MRMZ_PTR)
         CALL LCMGPD(IPTRK,'DC',DC_PTR)
         CALL LCMGPD(IPTRK,'DB',DB_PTR)
         CALL LCMGPD(IPTRK,'DA',DA_PTR)
         CALL LCMGPD(IPTRK,'PL',PL_PTR)
*
         CALL C_F_POINTER(DU_PTR,DU,(/ NPQ /))
         CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /))
         CALL C_F_POINTER(DZ_PTR,DZ,(/ NPQ /))
         CALL C_F_POINTER(W_PTR,W,(/ NPQ /))
         CALL C_F_POINTER(MRMX_PTR,MRMX,(/ NPQ /))
         CALL C_F_POINTER(MRMY_PTR,MRMY,(/ NPQ /))
         CALL C_F_POINTER(MRMZ_PTR,MRMZ,(/ NPQ /))
         CALL C_F_POINTER(DC_PTR,DC,(/ LX*LY*NPQ /))
         CALL C_F_POINTER(DB_PTR,DB,(/ LX*LY*NPQ /))
         CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /))
         CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NPQ /))
*
         CALL LCMGET(IPTRK,'NCODE',NCODE)
         CALL LCMGET(IPTRK,'ZCODE',ZCODE)
         ALLOCATE(BSNX(LX*LY*LZ),BSNY(LX*LY*LZ),BSNZ(LX*LY*LZ))
         CALL XDRSET(BSNX,LX*LY*LZ,0.0)
         CALL XDRSET(BSNY,LX*LY*LZ,0.0)
         CALL XDRSET(BSNZ,LX*LY*LZ,0.0)
         CALL SNFT13(LX,LY,LZ,IELEM,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,
     1   ZCODE,QEXT,LFIXUP,DU,DE,DZ,W,MRMX,MRMY,MRMZ,DC,DB,DA,PL,FUNKNO,
     2   FUNKNO(L4+1),FUNKNO(L4+IELEM*IELEM*LY*LZ*NPQ+1),
     3   FUNKNO(L4+IELEM*IELEM*(LY+LX)*LZ*NPQ+1),BSNX,BSNY,BSNZ)
      ELSE
         CALL XABORT('SNFLUX: TYPE OF DISCRETIZATION NOT IMPLEMENTED.')
      ENDIF
*----
*  SYNTHETIC ACCELERATION.
*  disable DSA for the NSDSA first source iterations for IELEM=2 or 3
*  in 3D.
*----
      IF((ITYPE.EQ.7).AND.(IELEM.NE.1).AND.(ITER.LE.NSDSA)) LDSA=.FALSE.
      IF(LDSA)  THEN
         CALL LCMSIX(IPTRK,'DSA',1)
         CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
         IF(NREG.NE.IPAR(1)) CALL XABORT('SNFLUX: INVALID NREG (DSA).')
         NUNSA=IPAR(2)
         IMPY=MAX(0,IMPX-1)
         CALL LCMSIX(IPTRK,' ',2)
         CALL SNDSA(KPSYS,IPTRK,IFTRAK,IMPY,IDIR,NREG,NBMIX,NUN,ISCAT,
     1   MAT,VOL,KEYFLX,TITR,NUNSA,ZCODE,OLD,FUNKNO)
      ENDIF
      DEALLOCATE(SGAS,SGAR,OLD,QEXT)
*----
*  PRINT SURFACE FLUXES
*----
      IF((ITYPE.EQ.7).AND.(IMPX.GT.100)) THEN
         WRITE(IUNOUT,'(//36H X   D I R E C T E D   S U R F A C E,
     1     17 H   F L U X E S  :)')
         WRITE(IUNOUT,'(1P,6(5X,E15.7))') (BSNX(I),I=1,NREG)
         WRITE(IUNOUT,'(//36H Y   D I R E C T E D   S U R F A C E,
     1     17 H   F L U X E S  :)')
         WRITE(IUNOUT,'(1P,6(5X,E15.7))') (BSNY(I),I=1,NREG)
         WRITE(IUNOUT,'(//36H Z   D I R E C T E D   S U R F A C E,
     1     17 H   F L U X E S  :)')
         WRITE(IUNOUT,'(1P,6(5X,E15.7))') (BSNZ(I),I=1,NREG)
      ENDIF
      IF(ITYPE.EQ.7) DEALLOCATE(BSNX,BSNY,BSNZ)
      RETURN
      END
