*DECK SNDSA
      SUBROUTINE SNDSA (KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,
     1 ISCAT,MAT,VOL,KEYFLX,TITR,NUNSA,ZCODE,FUNOLD,FUNKNO)
*
*-----------------------------------------------------------------------
*
*Purpose:
* perform a synthetic acceleration using BIVAC (2D) or TRIVAC (3D)    
* for the discrete ordinates (SN) method using P1 approximation.
*
*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 and N. Martin
*
*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.
* ISCAT   anisotropy of one-speed sources in SN method.
* 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.
* NUNSA   number of unknowns in BIVAC/TRIVAC.
* ZCODE   albedos.
* FUNOLD  SN unknown vector at iteration kappa.
* FUNKNO  SN unknown vector at iteration kappa+1/2.
*
*Parameters: output
* FUNKNO  SN unknown vector at iteration kappa+1 (with DSA correction).
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) KPSYS,IPTRK
      CHARACTER   TITR*72
      INTEGER     IFTRAK,IMPX,IDIR,NREG,NBMIX,NUN,ISCAT,MAT(NREG),
     >            KEYFLX(NREG),NUNSA
      REAL        VOL(NREG),ZCODE(6),FUNOLD(NUN),FUNKNO(NUN)
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NSTATE=40,PI=3.141592654)
      INTEGER IPAR(NSTATE)
*
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IDL
      REAL, ALLOCATABLE, DIMENSION(:) :: FUNSA,SUNSA,SGAS
*
      TYPE(C_PTR) DU_PTR,DE_PTR,W_PTR,DZ_PTR
      REAL, POINTER, DIMENSION(:) :: DU,DE,W,DZ
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(IDL(NREG),FUNSA(NUNSA),SUNSA(NUNSA))
*----
*  RECOVER WITHIN-GROUP SCATTERING CROSS SECTION.
*----
      CALL LCMSIX(IPTRK,'DSA',1)
      CALL LCMLEN(KPSYS,'DRAGON-TXSC',ILONG,ITYLCM)
      IF(ILONG.NE.NBMIX+1) CALL XABORT('SNDSA: INVALID TXSC LENGTH.')
      CALL LCMLEN(KPSYS,'DRAGON-S0XSC',ILONG,ITYLCM)
      NANI=ILONG/(NBMIX+1)
      ALLOCATE(SGAS(ILONG))
      CALL LCMGET(KPSYS,'DRAGON-S0XSC',SGAS)
      CALL LCMGET(IPTRK,'KEYFLX',IDL)
*----
*  COMPUTE THE SOURCE OF THE DSA EQUATION.
*----
      CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR)
      IF(NREG.NE.IPAR(1)) CALL XABORT('SNDSA: INVALID NREG ON LCM.')
      IF(NUNSA.NE.IPAR(2)) CALL XABORT('SNDSA: INVALID NUN ON LCM.')
      ITYPE=IPAR(6)
      IF(ITYPE.EQ.7) THEN
        IELEM=IPAR(9)
        LX=IPAR(14)
        LY=IPAR(15)
        LZ=IPAR(16)
      ELSE
        IELEM=IPAR(8)
        LX=IPAR(12)
        LY=IPAR(13)
        LZ=0
      ENDIF
      CALL XDRSET(SUNSA,NUNSA,0.0)
      NSCT=0
      NLEG=0
      IF(ITYPE.EQ.2) THEN
         NSCT=ISCAT
         NLEG=IELEM
      ELSE IF(ITYPE.EQ.5) THEN
         NSCT=ISCAT*(ISCAT+1)/2
         NLEG=IELEM*IELEM
      ELSE IF(ITYPE.EQ.7) THEN
         NSCT=(ISCAT+1)**2
         NLEG=IELEM*IELEM*IELEM
      ELSE
         CALL XABORT('SNDSA: TYPE OF DISCRETIZATION NOT IMPLEMENTED.')
      ENDIF
      DO 20 IR=1,NREG
      IBM=MAT(IR)
      IF(IBM.LE.0) GO TO 20
      SIGS=SGAS(IBM+1)
      DO 10 IEL=1,NLEG
      IND=KEYFLX(IR)+IEL-1
      JND=IDL(IR)+IEL-1
  10  SUNSA(JND)=SUNSA(JND)+SIGS*(FUNKNO(IND)-FUNOLD(IND))       
  20  CONTINUE      
      DEALLOCATE(SGAS)
*----
*  SOLVE THE DSA EQUATION USING A P1 METHOD.
*----
      IF(ITYPE.EQ.7) THEN  
         CALL XDRSET(FUNSA,NUNSA,0.0)
         CALL TRIVAF(KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUNSA,MAT,
     >   VOL,IDL,FUNSA,SUNSA,TITR)
      ELSE
         CALL XDRSET(FUNSA,NUNSA,0.0)
         CALL PNF(KPSYS,IPTRK,IFTRAK,IMPX,IDIR,NREG,NBMIX,NUNSA,MAT,
     >   VOL,IDL,FUNSA,SUNSA,TITR)
      ENDIF
      CALL LCMSIX(IPTRK,' ',2)
*----
*  UPGRADE THE SN SURFACE FLUX IN 2D CARTESIAN CASES
*----
      IF(ITYPE.EQ.5) THEN  
         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 C_F_POINTER(DU_PTR,DU,(/ NPQ /))
         CALL C_F_POINTER(DE_PTR,DE,(/ NPQ /))
         CALL C_F_POINTER(W_PTR,W,(/ NPQ /))
         IR=0
         DO 160 K1=1,LY
         DO 160 K2=1,LX
         IR=IR+1
         IF(MAT(IR).EQ.0) GO TO 160
         IF(VOL(IR).EQ.0.0) GO TO 150
*******XNEI-
         IF((K2.EQ.1).AND.(ZCODE(1).NE.0.0)) THEN
            DO 50 J0=1,IELEM
            FSN=0.0
            DFPN=0.0
            SG=1.0
            DO 40 I0=1,IELEM
            IND0=KEYFLX(IR)+(J0-1)*IELEM+I0-1
            IND1=IDL(IR)+(J0-1)*IELEM+I0-1
            FSN=FSN+SG*SQRT(REAL(2*I0-1))*FUNKNO(IND0)
            DFPN=DFPN+SG*SQRT(REAL(2*I0-1))*FUNSA(IND1)
   40       SG=-SG
            BSN=0.0
            DO 45 M=1,NPQ
            IF(DU(M).LT.0.0) THEN
               IND0=LY*LX*NSCT*IELEM**2+(M-1)*LY*IELEM+(K1-1)*IELEM+J0
               BSN=BSN+2.0*W(M)*FUNKNO(IND0)*(1.0+ZCODE(1))
            ENDIF
   45       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 50 M=1,NPQ
            IF(DU(M).LT.0.0) THEN
               IND0=LY*LX*NSCT*IELEM**2+(M-1)*LY*IELEM+(K1-1)*IELEM+J0
               FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
   50       CONTINUE
         ENDIF
*******XNEI+
         IF((K2.EQ.LX).AND.(ZCODE(2).NE.0.0)) THEN
            DO 70 J0=1,IELEM
            FSN=0.0
            DFPN=0.0
            DO 60 I0=1,IELEM
            IND0=KEYFLX(IR)+(J0-1)*IELEM+I0-1
            IND1=IDL(IR)+(J0-1)*IELEM+I0-1
            FSN=FSN+SQRT(REAL(2*I0-1))*FUNKNO(IND0)
   60       DFPN=DFPN+SQRT(REAL(2*I0-1))*FUNSA(IND1)
            BSN=0.0
            DO 65 M=1,NPQ
            IF(DU(M).GT.0.0) THEN
               IND0=LY*LX*NSCT*IELEM**2+(M-1)*LY*IELEM+(K1-1)*IELEM+J0
               BSN=BSN+2.0*W(M)*FUNKNO(IND0)*(1.0+ZCODE(2))
            ENDIF
   65       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 70 M=1,NPQ
            IF(DU(M).GT.0.0) THEN
               IND0=LY*LX*NSCT*IELEM**2+(M-1)*LY*IELEM+(K1-1)*IELEM+J0
               FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
   70       CONTINUE
         ENDIF
******XNEJ-
         IF((K1.EQ.1).AND.(ZCODE(3).NE.0.0)) THEN
            DO 90 I0=1,IELEM
            FSN=0.0
            DFPN=0.0
            SG=1.0
            DO 80 J0=1,IELEM
            IND0=KEYFLX(IR)+(I0-1)*IELEM+J0-1
            IND1=IDL(IR)+(I0-1)*IELEM+J0-1
            FSN=FSN+SG*SQRT(REAL(2*J0-1))*FUNKNO(IND0)
            DFPN=DFPN+SG*SQRT(REAL(2*J0-1))*FUNSA(IND1)
   80       SG=-SG
            BSN=0.0
            DO 85 M=1,NPQ
            IF(DE(M).LT.0.0) THEN
               IND0=LY*LX*NSCT*IELEM**2+IELEM*LY*NPQ+(M-1)*LX*IELEM+
     >         (K2-1)*IELEM+I0
               BSN=BSN+2.0*W(M)*FUNKNO(IND0)*(1.0+ZCODE(3))
            ENDIF
   85       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 90 M=1,NPQ
            IF(DE(M).LT.0.0) THEN
               IND0=LY*LX*NSCT*IELEM**2+IELEM*LY*NPQ+(M-1)*LX*IELEM+
     >         (K2-1)*IELEM+I0
               FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
   90       CONTINUE
          ENDIF
*****XNEJ+
         IF((K1.EQ.LY).AND.(ZCODE(4).NE.0.0)) THEN
            DO 110 I0=1,IELEM
            FSN=0.0
            DFPN=0.0
            DO 100 J0=1,IELEM
            IND0=KEYFLX(IR)+(I0-1)*IELEM+J0-1
            IND1=IDL(IR)+(I0-1)*IELEM+J0-1
            FSN=FSN+SQRT(REAL(2*J0-1))*FUNKNO(IND0)
  100       DFPN=DFPN+SQRT(REAL(2*J0-1))*FUNSA(IND1)
            BSN=0.0
            DO 105 M=1,NPQ
            IF(DE(M).GT.0.0) THEN
               IND0=LY*LX*NSCT*IELEM**2+IELEM*LY*NPQ+(M-1)*LX*IELEM+
     >         (K2-1)*IELEM+I0
               BSN=BSN+2.0*W(M)*FUNKNO(IND0)*(1.0+ZCODE(4))
            ENDIF
  105       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 110 M=1,NPQ
            IF(DE(M).GT.0.0) THEN
               IND0=LY*LX*NSCT*IELEM**2+IELEM*LY*NPQ+(M-1)*LX*IELEM+
     >         (K2-1)*IELEM+I0
               FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
  110       CONTINUE
         ENDIF
  150    CONTINUE
  160    CONTINUE   
*----
*  UPGRADE THE SN SURFACE FLUX IN 3D CARTESIAN CASES
*----
         ELSE IF(ITYPE.EQ.7) THEN   
         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 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(DZ_PTR,DZ,(/ NPQ /))
         IR=0
         DO 180 K3=1,LZ
         DO 180 K2=1,LY
         DO 180 K1=1,LX
         IR=IR+1
         IF(MAT(IR).EQ.0) GO TO 180
         IF(VOL(IR).EQ.0.0) GO TO 190
******** XNEI-
         IF((K1.EQ.1).AND.(ZCODE(1).NE.0.0)) THEN 
            DO 200 J0=1,IELEM
            DO 200 K0=1,IELEM           
            FSN=0.0
            DFPN=0.0
            SG=1.0
            DO 210 I0=1,IELEM
            IND0=KEYFLX(IR)+(J0-1)*IELEM**2+(K0-1)*IELEM+I0-1
            IND1=IDL(IR)+(J0-1)*IELEM**2+(K0-1)*IELEM+I0-1
            FSN=FSN+SG*SQRT(REAL(2*I0-1))*FUNKNO(IND0)
            DFPN=DFPN+SG*SQRT(REAL(2*I0-1))*FUNSA(IND1)
  210       SG=-SG
            BSN=0.0           
            DO 220 M=1,NPQ
            IF(DU(M).LT.0.0) THEN
            IND0=LZ*LY*LX*NSCT*IELEM**3+(M-1)*LY*LZ*IELEM**2+
     >      LY*(K3-1)*IELEM**2+(K2-1)*IELEM**2+(J0-1)*IELEM+K0
            BSN=BSN+W(M)*FUNKNO(IND0)*(1.0+ZCODE(1))
            ENDIF
  220       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 200 M=1,NPQ
            IF(DU(M).LT.0.0) THEN
            IND0=LZ*LY*LX*NSCT*IELEM**3+(M-1)*LY*LZ*IELEM**2+
     >      LY*(K3-1)*IELEM**2+(K2-1)*IELEM**2+(J0-1)*IELEM+K0
            FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
  200       CONTINUE
         ENDIF
******** XNEI+
         IF((K1.EQ.LX).AND.(ZCODE(2).NE.0.0)) THEN            
            DO 230 J0=1,IELEM
            DO 230 K0=1,IELEM
            FSN=0.0
            DFPN=0.0
            DO 240 I0=1,IELEM
            IND0=KEYFLX(IR)+(J0-1)*IELEM**2+(K0-1)*IELEM+I0-1
            IND1=IDL(IR)+(J0-1)*IELEM**2+(K0-1)*IELEM+I0-1   
            FSN=FSN+SQRT(REAL(2*I0-1))*FUNKNO(IND0)
  240       DFPN=DFPN+SQRT(REAL(2*I0-1))*FUNSA(IND1)
            BSN=0.0
            DO 250 M=1,NPQ
            IF(DU(M).GT.0.0) THEN
            IND0=LZ*LY*LX*NSCT*IELEM**3+(M-1)*LY*LZ*IELEM**2+
     >      LY*(K3-1)*IELEM**2+(K2-1)*IELEM**2+(J0-1)*IELEM+K0
            BSN=BSN+W(M)*FUNKNO(IND0)*(1.0+ZCODE(2))
            ENDIF
  250       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 230 M=1,NPQ
            IF(DU(M).GT.0.0) THEN
            IND0=LZ*LY*LX*NSCT*IELEM**3+(M-1)*LY*LZ*IELEM**2+
     >      LY*(K3-1)*IELEM**2+(K2-1)*IELEM**2+(J0-1)*IELEM+K0
            FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
  230       CONTINUE
         ENDIF
***********XNEJ-
         IF((K2.EQ.1).AND.(ZCODE(3).NE.0.0)) THEN                    
            DO 260 I0=1,IELEM
            DO 260 K0=1,IELEM
            FSN=0.0
            DFPN=0.0
            SG=1.0
            DO 270 J0=1,IELEM
            IND0=KEYFLX(IR)+(I0-1)*IELEM*IELEM+(K0-1)*IELEM+J0-1
            IND1=IDL(IR)+(I0-1)*IELEM*IELEM+(K0-1)*IELEM+J0-1 
            FSN=FSN+SG*SQRT(REAL(2*J0-1))*FUNKNO(IND0)
            DFPN=DFPN+SG*SQRT(REAL(2*J0-1))*FUNSA(IND1)
  270       SG=-SG
            BSN=0.0
            DO 280 M=1,NPQ
            IF(DE(M).LT.0.0) THEN
            IND0=LZ*LY*LX*NSCT*IELEM**3+(M-1)*LX*LZ*IELEM**2+
     >      LX*(K3-1)*IELEM**2+(K1-1)*IELEM**2+(I0-1)*IELEM+K0
     >      +LY*LZ*NPQ*IELEM**2
            BSN=BSN+W(M)*FUNKNO(IND0)*(1.0+ZCODE(3))
            ENDIF
  280       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 260 M=1,NPQ
            IF(DE(M).LT.0.0) THEN
            IND0=LZ*LY*LX*NSCT*IELEM**3+(M-1)*LX*LZ*IELEM**2+
     >      LX*(K3-1)*IELEM**2+(K1-1)*IELEM**2+(I0-1)*IELEM+K0
     >      +LY*LZ*NPQ*IELEM**2
            FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
  260       CONTINUE
         ENDIF
*******XNEJ +
         IF((K2.EQ.LY).AND.(ZCODE(4).NE.0.0)) THEN
            DO 290 I0=1,IELEM
            DO 290 K0=1,IELEM
            FSN=0.0
            DFPN=0.0
            DO 300 J0=1,IELEM
            IND0=KEYFLX(IR)+(I0-1)*IELEM*IELEM+(K0-1)*IELEM+J0-1
            IND1=IDL(IR)+(I0-1)*IELEM*IELEM+(K0-1)*IELEM+J0-1  
            FSN=FSN+SQRT(REAL(2*J0-1))*FUNKNO(IND0)
  300       DFPN=DFPN+SQRT(REAL(2*J0-1))*FUNSA(IND1)
            BSN=0.0
            DO 310 M=1,NPQ
            IF(DE(M).GT.0.0) THEN
            IND0=LZ*LY*LX*NSCT*IELEM**3+(M-1)*LX*LZ*IELEM**2+
     >      LX*(K3-1)*IELEM**2+(K1-1)*IELEM**2+(I0-1)*IELEM+K0
     >      +LY*LZ*NPQ*IELEM**2
            BSN=BSN+W(M)*FUNKNO(IND0)*(1.0+ZCODE(4))
            ENDIF
  310       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 290 M=1,NPQ
            IF(DE(M).GT.0.0) THEN      
            IND0=LZ*LY*LX*NSCT*IELEM**3+(M-1)*LX*LZ*IELEM**2+
     >      LX*(K3-1)*IELEM**2+(K1-1)*IELEM**2+(I0-1)*IELEM+K0
     >      +LY*LZ*NPQ*IELEM**2
            FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
  290       CONTINUE
         ENDIF
********* XNEK -
       IF((K3.EQ.1).AND.(ZCODE(5).NE.0.0)) THEN
            DO 320 I0=1,IELEM
            DO 320 J0=1,IELEM
            FSN=0.0
            DFPN=0.0
            SG=1.0
            DO 330 K0=1,IELEM
            IND0=KEYFLX(IR)+(I0-1)*IELEM**2+(J0-1)*IELEM+K0-1
            IND1=IDL(IR)+(I0-1)*IELEM**2+(J0-1)*IELEM+K0-1
            FSN=FSN+SG*SQRT(REAL(2*K0-1))*FUNKNO(IND0)
            DFPN=DFPN+SG*SQRT(REAL(2*K0-1))*FUNSA(IND1)
  330       SG=-SG
            BSN=0.0
            DO 340 M=1,NPQ
            IF(DZ(M).LT.0.0) THEN
            IND0=LZ*LY*LX*NSCT*IELEM**3+LY*LZ*NPQ*IELEM**2+
     >      LX*LZ*NPQ*IELEM**2+(M-1)*LX*LY*IELEM**2+
     >      LX*(K2-1)*IELEM**2+(K1-1)*IELEM**2+(I0-1)*IELEM+J0  
            BSN=BSN+W(M)*FUNKNO(IND0)*(1.0+ZCODE(5))
            ENDIF
  340       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 320 M=1,NPQ
            IF(DZ(M).LT.0.0) THEN
            IND0=LZ*LY*LX*NSCT*IELEM**3+LY*LZ*NPQ*IELEM**2+
     >      LX*LZ*NPQ*IELEM**2+(M-1)*LX*LY*IELEM**2+
     >      LX*(K2-1)*IELEM**2+(K1-1)*IELEM**2+(I0-1)*IELEM+J0 
            FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
  320       CONTINUE
         ENDIF
********** XNEK +
         IF((K3.EQ.LZ).AND.(ZCODE(6).NE.0.0)) THEN
            DO 350 I0=1,IELEM
            DO 350 J0=1,IELEM
            FSN=0.0
            DFPN=0.0
            DO 360 K0=1,IELEM                      
            IND0=KEYFLX(IR)+(I0-1)*IELEM**2+(J0-1)*IELEM+K0-1
            IND1=IDL(IR)+(I0-1)*IELEM**2+(J0-1)*IELEM+K0-1
            FSN=FSN+SQRT(REAL(2*K0-1))*FUNKNO(IND0)
  360       DFPN=DFPN+SQRT(REAL(2*K0-1))*FUNSA(IND1)
            BSN=0.0
            DO 370 M=1,NPQ
            IF(DZ(M).GT.0.0) THEN        
            IND0=LZ*LY*LX*NSCT*IELEM**3+LY*LZ*NPQ*IELEM**2+
     >      LX*LZ*NPQ*IELEM**2+(M-1)*LX*LY*IELEM**2+
     >      LX*(K2-1)*IELEM**2+(K1-1)*IELEM**2+(I0-1)*IELEM+J0 
            BSN=BSN+W(M)*FUNKNO(IND0)*(1.0+ZCODE(6))
            ENDIF
  370       CONTINUE
            IF(FSN.NE.0.0) DFPN=DFPN*BSN/FSN
            DO 350 M=1,NPQ
            IF(DZ(M).GT.0.0) THEN                      
            IND0=LZ*LY*LX*NSCT*IELEM**3+LY*LZ*NPQ*IELEM**2+
     >      LX*LZ*NPQ*IELEM**2+(M-1)*LX*LY*IELEM**2+
     >      LX*(K2-1)*IELEM**2+(K1-1)*IELEM**2+(I0-1)*IELEM+J0 
            FUNKNO(IND0)=FUNKNO(IND0)+DFPN/(4.0*PI)
            ENDIF
  350       CONTINUE
         ENDIF
  190    CONTINUE
  180    CONTINUE
         ENDIF
*----
*  UPGRADE THE SOLUTION OF THE SN EQUATION.
*----
      DO 170 IR=1,NREG
      IF(MAT(IR).LE.0) GO TO 170
      DO 165 IEL=1,NLEG
      IND=KEYFLX(IR)+IEL-1
      JND=IDL(IR)+IEL-1
      OLD=FUNKNO(IND)
 165  FUNKNO(IND)=FUNKNO(IND)+FUNSA(JND)   
 170  CONTINUE
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(SUNSA,FUNSA,IDL)
      RETURN
      END
