*DECK SNFLUX
      SUBROUTINE SNFLUX (KPSYS,INCONV,INGIND,IPTRK,IMPX,NGRP,NGEFF,
     1 NREG,NBMIX,NUN,MAT,VOL,KEYFLX,FUNKNO,SUNKNO,ITER)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Solve a single non-accelerated scattering iteration of the N-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. KPSYS is an array of
*         directories.
* INCONV  energy group convergence flag (set to .false. if converged).
* INGIND  energy group index assign to 1:NGEFF arrays.
* IPTRK   pointer to the tracking (L_TRACK signature).
* IMPX    print flag (equal to zero for no print).
* NGRP    number of energy groups.
* NGEFF   dimension of arrays KPSYS, INCONV and INGIND.
* 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.
* ITER    number of previous calls to SNFLUX.
*
*Parameters: input/output
* FUNKNO  unknown vector.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) KPSYS(NGEFF),IPTRK
      INTEGER     NGEFF,INGIND(NGEFF),IMPX,NGRP,NREG,NBMIX,NUN,
     1            MAT(NREG),KEYFLX(NREG),ITER
      LOGICAL     INCONV(NGEFF)
      REAL        VOL(NREG),FUNKNO(NUN,NGRP),SUNKNO(NUN,NGRP)
*----
*  LOCAL VARIABLES
*----
      PARAMETER  (IUNOUT=6,NSTATE=40)
      TYPE(C_PTR) JPSYS
      INTEGER     IPAR(NSTATE),NCODE(6)
      REAL        ZCODE(6),SIDE
      LOGICAL     LFIXUP,LDSA,LSHOOT
*----
*  ALLOCATABLE ARRAYS
*---
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IZGLOB,CONNEC,IDL
      INTEGER, DIMENSION(2,3,6) :: CONFROM
      REAL, ALLOCATABLE, DIMENSION(:,:) :: QEXT,OLD,SGAR
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SGAS,ESTOPW
*
      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,DELTAE
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(QEXT(NUN,NGRP),OLD(NUN,NGRP),IDL(NREG),DELTAE(NGRP))
*----
*  RECOVER SN SPECIFIC PARAMETERS.
*----
      CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
      ITYPE=IPAR(6)
      IELEM=IPAR(8)
      ISCHM=IPAR(10)
      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)
      ISPLH=IPAR(26)
      IOMP=IPAR(28)
      IGAV=IPAR(29)
      LSHOOT=.TRUE.
      IF(IPAR(30).EQ.0) LSHOOT=.FALSE.
      IBFP=IPAR(31)
      OLD(:NUN,:NGRP)=FUNKNO(:NUN,:NGRP)
*----
*  RECOVER TOTAL AND WITHIN-GROUP SCATTERING MULTIGROUP CROSS SECTIONS.
*----
      ALLOCATE(SGAR(0:NBMIX,NGRP),SGAS(0:NBMIX,ISCAT,NGRP),
     1 ESTOPW(0:NBMIX,2,NGRP))
      NANI=1
      DO 10 II=1,NGEFF
      IF(.NOT.INCONV(II)) GO TO 10
      JPSYS=KPSYS(II)
      IG=INGIND(II)
      CALL LCMLEN(JPSYS,'DRAGON-TXSC',ILONG,ITYLCM)
      IF(ILONG.NE.NBMIX+1) CALL XABORT('SNFLUX: INVALID TXSC LENGTH.')
      CALL LCMLEN(JPSYS,'DRAGON-S0XSC',ILONG,ITYLCM)
      NANI=MAX(NANI,ILONG/(NBMIX+1))
      IF(NANI.GT.ISCAT) CALL XABORT('SNFLUX: INVALID S0XSC LENGTH.')
      CALL LCMGET(JPSYS,'DRAGON-TXSC',SGAR(0,IG))
      CALL LCMGET(JPSYS,'DRAGON-S0XSC',SGAS(0,1,IG))
*----
*  TEST FOR FOKKER-PLANCK TREATMENT.
*----
      IF(IBFP.GT.0) THEN
        CALL LCMLEN(JPSYS,'DRAGON-ESTOP',IFP,ITYLCM)
        IF(IFP.NE.(NBMIX+1)*2) CALL XABORT('SNFLUX: INVALID ESTOPW LEN'
     1  //'GTH.')
        CALL LCMGET(JPSYS,'DRAGON-ESTOP',ESTOPW(0,1,IG))
        CALL LCMGET(JPSYS,'DRAGON-DELTE',DELTAE(IG))
      ENDIF
*----
*  PRINT SOURCES.
*----
      IF(IMPX.GT.3) THEN
        WRITE(IUNOUT,500) IG
        WRITE(IUNOUT,'(1P,6(5X,E15.7))') (SUNKNO(KEYFLX(I),IG),I=1,NREG)
      ENDIF
   10 CONTINUE
*----
*  COMPUTE THE FLUX.
*----
      IF((ITYPE.EQ.2).AND.(IBFP.EQ.0)) THEN
*------------
* 1D SLAB
*------------
        NSCT=ISCAT
        IF(IELEM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW'
     1  //'(1)')
        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)
        DO 40 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 40
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN/1D-slab'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 30 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 30
        DO 20 IL=0,NANI-1
        FACT=REAL(2*IL+1)
        DO 15 IEL=1,IELEM
        IND=(IR-1)*NSCT*IELEM+IELEM*IL+IEL
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
   15   CONTINUE
   20   CONTINUE
   30   CONTINUE
        IF(LSHOOT)THEN
          CALL SNFT1P(NREG,NBMIX,ISCHM,IELEM,NLF,NSCT,U,W,PL,MAT,VOL,
     1    SGAR(0,IG),NCODE,ZCODE,QEXT(1,IG),LFIXUP,FUNKNO(1,IG))
        ELSE
          CALL SNFT1Q(NREG,NBMIX,ISCHM,IELEM,NLF,NSCT,U,W,PL,MAT,VOL,
     1    SGAR(0,IG),NCODE,ZCODE,QEXT(1,IG),LFIXUP,FUNKNO(1,IG),
     2    FUNKNO(L4+1,IG))
        ENDIF
   40   CONTINUE
      ELSE IF(ITYPE.EQ.2) THEN
*------------
* 1D SLAB BOLTZMANN-FOKKER-PLANCK
*------------
        NSCT=ISCAT
        IF(IELEM*NSCT*NREG+IELEM*NLF*NREG.GT.NUN) THEN
          CALL XABORT('SNFLUX: QEXT OVERFLOW(1a)')
        ENDIF
        IOF=IELEM*NSCT*NREG+1
        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)
        DO 80 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 80
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN-BFP/1D-slab'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 70 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 70
        DO 60 IL=0,NANI-1
        FACT=REAL(2*IL+1)
        DO 50 IEL=1,IELEM
        IND=(IR-1)*NSCT*IELEM+IELEM*IL+IEL
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
   50   CONTINUE
   60   CONTINUE
   70   CONTINUE
        CALL SNFP1P(NREG,NBMIX,ISCHM,IELEM,IBFP,NLF,NSCT,U,W,PL,MAT,
     1  VOL,SGAR(0,IG),ESTOPW(0,1,IG),NCODE,ZCODE,DELTAE(IG),QEXT(1,IG),
     2  QEXT(IOF,IG),LFIXUP,FUNKNO(1,IG),FUNKNO(IOF,IG))
   80   CONTINUE
      ELSE IF(ITYPE.EQ.3) THEN
*------------
* 1D TUBE/CYLINDRICAL
*------------
        IF(IELEM.NE.1) CALL XABORT('SNFLUX: DIAM 0 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)')
        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 /))
*
        DO 120 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 120
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN/1D-cyl'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 110 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 110
        IOF=0
        DO 100 IL=0,NANI-1
        FACT=REAL(2*IL+1)
        DO 90 IM=0,IL
        IF(MOD(IL+IM,2).EQ.1) GO TO 90
        IOF=IOF+1
        IND=(IR-1)*NSCT+IOF
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
   90   CONTINUE
  100   CONTINUE
  110   CONTINUE
        CURR=0.0
        CALL SNFT1C(NREG,NBMIX,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,ALPHA,
     1  PLZ,PL,MAT,VOL,SURF,SGAR(0,IG),IGAV,QEXT(1,IG),LFIXUP,CURR,
     2  FUNKNO(1,IG))
        IF(ZCODE(2).NE.0.0) THEN
          CA=CURR
          CB=1.0
          CALL SNFT1C(NREG,NBMIX,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,ALPHA,
     1    PLZ,PL,MAT,VOL,SURF,SGAR(0,IG),IGAV,QEXT(1,IG),LFIXUP,CB,
     2    FUNKNO(1,IG))
          CURR=ZCODE(2)*CA/(1.0+ZCODE(2)*(CA-CB))
          CALL SNFT1C(NREG,NBMIX,M2,NPQ,ISCAT,NSCT,JOP,U,UPQ,WPQ,ALPHA,
     1    PLZ,PL,MAT,VOL,SURF,SGAR(0,IG),IGAV,QEXT(1,IG),LFIXUP,CURR,
     2    FUNKNO(1,IG))
        ENDIF
  120   CONTINUE
      ELSE IF(ITYPE.EQ.4) THEN
*------------
* 1D SPHERE
*------------
        IF(IELEM.NE.1) CALL XABORT('SNFLUX: DIAM 0 EXPECTED(2).')
        NSCT=ISCAT
        IF(NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW(3)')
        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 /))
        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 /))
*
        DO 150 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 150
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN/1D-sph'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 140 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 140
        DO 130 IL=0,NANI-1
        FACT=REAL(2*IL+1)
        IND=(IR-1)*NSCT+IL+1
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
  130   CONTINUE
  140   CONTINUE
        CURR=0.0
        CALL SNFT1S(NREG,NBMIX,NLF,NSCT,U,W,ALPHA,PLZ,PL,MAT,VOL,SURF,
     1  XXX,SGAR(0,IG),IGAV,QEXT(1,IG),LFIXUP,CURR,FUNKNO(1,IG))
        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(0,IG),IGAV,QEXT(1,IG),LFIXUP,CB,FUNKNO(1,IG))
          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(0,IG),IGAV,QEXT(1,IG),LFIXUP,CURR,FUNKNO(1,IG))
        ENDIF
  150   CONTINUE
      ELSE IF((ITYPE.EQ.5).AND.(IBFP.EQ.0)) THEN
*------------
* 2D CARTESIAN
*------------
        NSCT=ISCAT*(ISCAT+1)/2
        IF(IELEM*IELEM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVE'
     1  //'RFLOW(4a)')
        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)
        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 /))
        CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NPQ /))
*
        CALL LCMGET(IPTRK,'NCODE',NCODE)
        CALL LCMGET(IPTRK,'ZCODE',ZCODE)
        DO 200 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 200
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN/2D-car'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 190 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 190
        IOF=0
        DO 180 IL=0,NANI-1
        FACT=REAL(2*IL+1)
        DO 170 IM=-IL,IL
        IF(MOD(IL+IM,2).EQ.1) GO TO 170
        IOF=IOF+1
        DO 160 IEL=1,IELEM*IELEM
        IND=(IR-1)*NSCT*IELEM*IELEM+(IOF-1)*IELEM*IELEM+IEL
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
  160   CONTINUE
  170   CONTINUE
  180   CONTINUE
  190   CONTINUE
  200   CONTINUE
        IF((ISCHM.EQ.1).AND.(IOMP.EQ.0))THEN
          CALL SNFT12(NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,LX,LY,IELEM,
     1    NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,LFIXUP,DU,DE,W,
     2    MRM,MRMY,DB,DA,PL,FUNKNO)
        ELSE IF((ISCHM.EQ.1).AND.(IOMP.GE.1))THEN
          CALL SNFD12(IOMP,NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,LX,LY,
     1    IELEM,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,LFIXUP,
     2    DU,DE,W,MRM,MRMY,DB,DA,PL,FUNKNO)
        ELSEIF((ISCHM.EQ.2).AND.(IOMP.EQ.0))THEN
          CALL SNFT22(NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,LX,LY,IELEM,
     1    NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,DU,DE,W,MRM,
     2    MRMY,DB,DA,PL,FUNKNO)
        ELSE IF((ISCHM.EQ.2).AND.(IOMP.GE.1))THEN
          CALL SNFD22(IOMP,NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,LX,LY,
     1    IELEM,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,DU,DE,W,
     2    MRM,MRMY,DB,DA,PL,FUNKNO)
        ENDIF
      ELSE IF(ITYPE.EQ.5) THEN
*------------
* 2D CARTESIAN BOLTZMANN-FOKKER-PLANCK
*------------
        NSCT=ISCAT*(ISCAT+1)/2
        CALL LCMLEN(IPTRK,'DU',NPQ,ITYLCM)
        IF(IELEM*IELEM*NSCT*NREG+IELEM*IELEM*NPQ*NREG.GT.NUN) THEN
          CALL XABORT('SNFLUX: QEXT OVERFLOW(4b)')
        ENDIF
        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)
        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 /))
        CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NPQ /))
*
        CALL LCMGET(IPTRK,'NCODE',NCODE)
        CALL LCMGET(IPTRK,'ZCODE',ZCODE)
        DO 250 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 250
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN-BFP/2D-car'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 240 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 240
        IOF=0
        DO 230 IL=0,NANI-1
        FACT=REAL(2*IL+1)
        DO 220 IM=-IL,IL
        IF(MOD(IL+IM,2).EQ.1) GO TO 220
        IOF=IOF+1
        DO 210 IEL=1,IELEM*IELEM
        IND=(IR-1)*NSCT*IELEM*IELEM+(IOF-1)*IELEM*IELEM+IEL
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
  210   CONTINUE
  220   CONTINUE
  230   CONTINUE
  240   CONTINUE
  250   CONTINUE
        IF((ISCHM.EQ.1).AND.(IOMP.EQ.0))THEN
          CALL SNFP12(NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,LX,LY,IELEM,
     1    IBFP,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,ESTOPW,NCODE,ZCODE,DELTAE,
     2    QEXT,LFIXUP,DU,DE,W,MRM,MRMY,DB,DA,PL,FUNKNO)
        ELSE
          CALL XABORT('SNFLUX: TECHNIQUE NOT IMPLEMENTED.')
        ENDIF
      ELSE IF(ITYPE.EQ.6) THEN
*------------
* TUBE 2D (R-Z)
*------------
        IF(IELEM.NE.1) CALL XABORT('SNFLUX: DIAM 0 EXPECTED(3).')
        NSCT=ISCAT*(ISCAT+1)/2
        IF(NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVERFLOW(5)')
        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)
        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 /))
        CALL C_F_POINTER(DAL_PTR,DAL,(/ LX*LY*NPQ /))
        CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NPQ /))
*
        CALL LCMGET(IPTRK,'NCODE',NCODE)
        CALL LCMGET(IPTRK,'ZCODE',ZCODE)
        DO 290 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 290
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN/2D-rz'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 280 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 280
        IOF=0
        DO 270 IL=0,MIN(ISCAT,NANI)-1
        FACT=REAL(2*IL+1)
        DO 260 IM=-IL,IL
        IF(MOD(IL+IM,2).EQ.1) GO TO 260
        IOF=IOF+1
        IND=(IR-1)*NSCT+(IOF-1)*IELEM*IELEM+1
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
  260   CONTINUE
  270   CONTINUE
  280   CONTINUE
        CALL SNFC12(LX,LY,NBMIX,NPQ,NSCT,MAT,VOL,SGAR(0,IG),NCODE,ZCODE,
     1  QEXT(1,IG),LFIXUP,DU,DE,W,MRM,MRMY,DB,DA,DAL,PL,FUNKNO(1,IG),
     2  FUNKNO(L4+1,IG),FUNKNO(L4+IELEM*LY*NPQ+1,IG))
  290   CONTINUE
      ELSE IF(ITYPE.EQ.7) THEN
*----
*  3D CARTESIAN CASE
*----
        NSCT=(ISCAT)**2
        IF(IELEM*IELEM*IELEM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QE'
     1  //'XT OVERFLOW(6)')
        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)
*
        DO 340 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 340
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN/3D-car'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 330 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 330
        IOF=0
        DO 320 IL=0,NANI-1
        FACT=REAL(2*IL+1)
        DO 310 IM=-IL,IL
        IOF=IOF+1
        DO 300 IEL=1,IELEM*IELEM*IELEM
        IND=(IR-1)*NSCT*IELEM*IELEM*IELEM+(IOF-1)*IELEM*IELEM*IELEM+IEL
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
  300   CONTINUE
  310   CONTINUE
  320   CONTINUE
  330   CONTINUE
  340   CONTINUE
        IF((ISCHM.EQ.1).AND.(IOMP.EQ.0)) THEN
          CALL SNFT13(NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,LX,LY,LZ,IELEM,
     1    NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,LFIXUP,DU,DE,DZ,
     2    W,MRMX,MRMY,MRMZ,DC,DB,DA,PL,FUNKNO)
        ELSE IF((ISCHM.EQ.1).AND.(IOMP.GE.1)) THEN
          CALL SNFD13(IOMP,NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,LX,LY,LZ,
     1    IELEM,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,LFIXUP,DU,
     2    DE,DZ,W,MRMX,MRMY,MRMZ,DC,DB,DA,PL,FUNKNO)
        ELSE IF((ISCHM.EQ.2).AND.(IOMP.EQ.0)) THEN
          CALL SNFT23(NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,LX,LY,LZ,IELEM,
     1    NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,DU,DE,DZ,W,MRMX,
     2    MRMY,MRMZ,DC,DB,DA,PL,FUNKNO)
        ELSE IF((ISCHM.EQ.2).AND.(IOMP.GE.1)) THEN
          CALL SNFD23(IOMP,NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,LX,LY,LZ,
     1    IELEM,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,NCODE,ZCODE,QEXT,DU,DE,DZ,
     2    W,MRMX,MRMY,MRMZ,DC,DB,DA,PL,FUNKNO)
        ENDIF
      ELSE IF(ITYPE.EQ.8) THEN
*------------
* 2D HEXAGONAL
*------------
        NSCT=ISCAT*(ISCAT+1)/2
        IF(IELEM*IELEM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QEXT OVE'
     1  //'RFLOW(7)')
        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,'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(W_PTR,W,(/ NPQ /))
        CALL C_F_POINTER(DB_PTR,DB,(/ LX*NPQ /))
        CALL C_F_POINTER(DA_PTR,DA,(/ LX*LY*NPQ /))
        CALL C_F_POINTER(PL_PTR,PL,(/ NSCT*NPQ /))
*
        NHEX     =LX/(3*ISPLH**2)
        MAXCON   =(NHEX*3)*2*3*6
        ALLOCATE(CONNEC(MAXCON),IZGLOB(NHEX*6))
        CALL LCMGET(IPTRK,'CONNEC',CONNEC)
        CALL LCMGET(IPTRK,'IZGLOB',IZGLOB)
        CALL LCMGET(IPTRK,'SIDE',SIDE)
        CALL LCMGET(IPTRK,'CONFROM',CONFROM)
*
        DO 390 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 390
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN/2D-hex'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 380 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 380
        IOF=0
        DO 370 IL=0,NANI-1
        FACT=REAL(2*IL+1)
        DO 360 IM=-IL,IL
        IF(MOD(IL+IM,2).EQ.1) GO TO 360
        IOF=IOF+1
        DO 350 IEL=1,IELEM*IELEM
        IND=(((IR-1)*NSCT+(IOF-1))*IELEM**2)+IEL
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
  350   CONTINUE
  360   CONTINUE
  370   CONTINUE
  380   CONTINUE
  390   CONTINUE
        IF(ISCHM.EQ.1)THEN
          CALL SNFTH1(NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,NHEX,IELEM,
     1    ISPLH,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,QEXT,DU,DE,W,DB,DA,PL,
     2    CONNEC,IZGLOB,SIDE,CONFROM,FUNKNO)
        ELSEIF(ISCHM.EQ.2)THEN
          CALL SNFTH2(NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,NHEX,IELEM,
     1    ISPLH,NBMIX,NPQ,NSCT,MAT,VOL,SGAR,QEXT,DU,DE,W,DB,DA,PL,
     2    CONNEC,IZGLOB,SIDE,CONFROM,FUNKNO)
        ENDIF
        DEALLOCATE(CONNEC,IZGLOB)
      ELSE IF(ITYPE.EQ.9) THEN
*------------
* 3D HEXAGONAL
*------------
        NSCT=(ISCAT)**2
        IF(IELEM*IELEM*IELEM*NSCT*NREG.GT.NUN) CALL XABORT('SNFLUX: QE'
     1  //'XT OVERFLOW(8)')
        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,'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(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)
*
        NHEX     =LX/(3*ISPLH**2)
        MAXCON   =(NHEX*3)*2*3*6
        ALLOCATE(CONNEC(MAXCON),IZGLOB(NHEX*6))
        CALL LCMGET(IPTRK,'CONNEC',CONNEC)
        CALL LCMGET(IPTRK,'IZGLOB',IZGLOB)
        CALL LCMGET(IPTRK,'SIDE',SIDE)
        CALL LCMGET(IPTRK,'CONFROM',CONFROM)
*
        DO 440 II=1,NGEFF
        IF(.NOT.INCONV(II)) GO TO 440
        IG=INGIND(II)
        IF(IMPX.GT.1) WRITE(IUNOUT,510) IG,'SN/3D-hex'
        QEXT(:NUN,IG)=SUNKNO(:NUN,IG)
        DO 430 IR=1,NREG
        IBM=MAT(IR)
        IF(IBM.EQ.0) GO TO 430
        IOF=0
        DO 420 IL=0,NANI-1
        FACT=REAL(2*IL+1)
        DO 410 IM=-IL,IL
        IOF=IOF+1
        DO 400 IEL=1,IELEM*IELEM*IELEM
        IND=(((IR-1)*NSCT+(IOF-1))*IELEM**3)+IEL
        QEXT(IND,IG)=QEXT(IND,IG)+FACT*SGAS(IBM,IL+1,IG)*FUNKNO(IND,IG)
  400   CONTINUE
  410   CONTINUE
  420   CONTINUE
  430   CONTINUE
  440   CONTINUE
        IF(ISCHM.EQ.1)THEN
          CALL SNFTH3(NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,NHEX,LZ,IELEM,
     1    ISPLH,SIDE,NBMIX,NPQ,NSCT,MAT,VOL,NCODE,ZCODE,SGAR,QEXT,DU,
     2    DE,DZ,W,MRMZ,DC,DB,DA,PL,CONNEC,IZGLOB,CONFROM,FUNKNO)
        ELSEIF(ISCHM.EQ.2)THEN
          CALL SNFTH4(NUN,NGRP,NGEFF,IMPX,INCONV,INGIND,NHEX,LZ,IELEM,
     1    ISPLH,SIDE,NBMIX,NPQ,NSCT,MAT,VOL,NCODE,ZCODE,SGAR,QEXT,DU,
     2    DE,DZ,W,MRMZ,DC,DB,DA,PL,CONNEC,IZGLOB,CONFROM,FUNKNO)
        ENDIF
        DEALLOCATE(CONNEC,IZGLOB)
      ELSE
        CALL XABORT('SNFLUX: TYPE OF DISCRETIZATION NOT IMPLEMENTED.')
      ENDIF
      DEALLOCATE(ESTOPW,SGAS,SGAR)
*----
*  PRINT COMPLETE UNKNOWN VECTOR.
*----
      DO 450 II=1,NGEFF
         IF(.NOT.INCONV(II)) GO TO 450
         IG=INGIND(II)
         IF(IMPX.GT.5) THEN
            WRITE(IUNOUT,520) IG
            WRITE(IUNOUT,'(1P,4(5X,E15.7))') (FUNKNO(:,IG))
         ENDIF
  450 CONTINUE
*----
*  DIFFUSION SYNTHETIC ACCELERATION.
*----
      IF((ITER.LE.NSDSA)) LDSA=.FALSE.
      IF(LDSA) THEN
        CALL LCMSIX(IPTRK,'DSA',1)
        CALL LCMGET(IPTRK,'KEYFLX',IDL)
        CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
        IF(NREG.NE.IPAR(1)) CALL XABORT('SNFLUX: INVALID NREG (DSA).')
        NUNSA=IPAR(2)
        ITYPE=IPAR(6)
        IELEMSA=IPAR(8)
        IF(ITYPE.EQ.7) IELEMSA=IPAR(9)
        IMPY=MAX(0,IMPX-1)
        CALL LCMSIX(IPTRK,' ',2)
        CALL SNDSA(KPSYS,INCONV,INGIND,IPTRK,IMPY,NGRP,NGEFF,NREG,
     1  NBMIX,NUN,ISCAT,MAT,VOL,KEYFLX,IDL,NUNSA,IELEMSA,ZCODE,OLD,
     2  FUNKNO,NHEX)
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(DELTAE,IDL,OLD,QEXT)
      RETURN
*
  500 FORMAT(//41H SNFLUX: N E U T R O N    S O U R C E S (,I5,3H ):)
  510 FORMAT(/25H SNFLUX: PROCESSING GROUP,I5,6H WITH ,A,1H.)
  520 FORMAT(//41H SNFLUX: A F T E R    T R A N S P O R T (,I5,3H ):)
      END
