*DECK SNFT1P
      SUBROUTINE SNFT1P(NREG,NMAT,IELEM,NLF,NSCT,U,W,PL,MAT,VOL,TOTAL,
     1 NCODE,ZCODE,QEXT,LFIXUP,FLUX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* perform one inner iteration for solving SN equations in 1D slab
* geometry. Albedo boundary conditions.
*
*Copyright:
* Copyright (C) 2005 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
* NREG    number of regions.
* NMAT    number of material mixtures.
* IELEM   degree of the spatial approximation (=1: diamond scheme).
* NLF     number of $\mu$ levels.
* NSCT    number of Legendre components in the flux.
*         =1: isotropic sources;
*         =2: linearly anisotropic sources.
* U       base points in $\mu$ of the SN quadrature.
* W       weights of the SN quadrature.
* PL      discrete values of the Legendre polynomials corresponding
*         to the SN quadrature.
* MAT     material mixture index in each region.
* VOL     volumes of each region.
* TOTAL   macroscopic total cross sections.
* NCODE   boundary condition indices.
* ZCODE   albedos.
* QEXT    Legendre components of the fixed source.
* LFIXUP  flag to enable negative flux fixup.
*
*Parameters: output
* FLUX    Legendre components of the flux.
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER NREG,NMAT,IELEM,NLF,NSCT,MAT(NREG),NCODE(2)
      REAL U(NLF),W(NLF),PL(NSCT,NLF),VOL(NREG),TOTAL(0:NMAT),ZCODE(2),
     1 QEXT(IELEM,NSCT,NREG),FLUX(IELEM,NSCT,NREG)
      LOGICAL LFIXUP
*----
*  LOCAL VARIABLES
*----
      DOUBLE PRECISION Q(3),AFB,Q2(3,4),CURR(2)
      PARAMETER(RLOG=1.0E-8)
*----
*  COMPUTE A NORMALIZATION CONSTANT.
*----
      IF(IELEM.GT.3) CALL XABORT('SNFT1P: IELEM OVERFLOW.')
      DENOM=0.0
      DO 10 I=1+NLF/2,NLF
   10 DENOM=DENOM+W(I)*U(I)
*----
*  OUTER LOOP OVER MU LEVELS.
*----
      CALL XDRSET(FLUX,IELEM*NSCT*NREG,0.0)
      NSCT0=NSCT
      CURR(1)=0.0D0
      CURR(2)=0.0D0
      DO 200 IP=1,NLF/2
      AFB=0.0
      AFB1=0.0
      AFB2=0.0
*----
*  SHOOTING METHOD FOR NON-VACUUM RIGHT BOUNDARY CONDITION.
*----
      IF(ZCODE(2).NE.0.0) THEN
*----
*  BACKWARD SWEEP (FROM RIGHT TO LEFT).
*----
         DO 30 I=NREG,1,-1
            IBM=MAT(I)
            DO 20 IEL=1,IELEM
            Q(IEL)=0.0
            DO 20 IL=0,NSCT-1
   20       Q(IEL)=Q(IEL)+QEXT(IEL,IL+1,I)*PL(IL+1,IP)/2.0
            IF(IELEM.EQ.1) THEN
               Q2(1,2)=Q(1)*VOL(I)-2.0D0*U(IP)*AFB
               Q2(1,1)=TOTAL(IBM)*VOL(I)-2.0D0*U(IP)
            ELSE IF(IELEM.EQ.2) THEN
               Q2(1,1)=TOTAL(IBM)*VOL(I)
               Q2(1,2)=2.0D0*SQRT(3.0D0)*U(IP)
               Q2(1,3)=Q(1)*VOL(I)
               Q2(2,1)=Q2(1,2)
               Q2(2,2)=-TOTAL(IBM)*VOL(I)+6.0D0*U(IP)
               Q2(2,3)=-Q(2)*VOL(I)+2.0D0*SQRT(3.0D0)*U(IP)*AFB
            ELSE IF(IELEM.EQ.3) THEN
               Q2(1,1)=TOTAL(IBM)*VOL(I)-2.0D0*U(IP)
               Q2(1,2)=0.0
               Q2(1,3)=-2.0D0*SQRT(5.0D0)*U(IP)
               Q2(1,4)=Q(1)*VOL(I)-2.0D0*U(IP)*AFB
               Q2(2,1)=Q2(1,2)
               Q2(2,2)=-TOTAL(IBM)*VOL(I)
               Q2(2,3)=-2.0D0*SQRT(15.0D0)*U(IP)
               Q2(2,4)=-Q(2)*VOL(I)
               Q2(3,1)=Q2(1,3)
               Q2(3,2)=Q2(2,3)
               Q2(3,3)=TOTAL(IBM)*VOL(I)-10.0D0*U(IP)
               Q2(3,4)=Q(3)*VOL(I)-2.0D0*SQRT(5.0D0)*U(IP)*AFB
            ENDIF
            CALL ALSBD(IELEM,1,Q2,IER,3)
            IF(IER.NE.0) CALL XABORT('SNFT1P: SINGULAR MATRIX(1).')
            IF(IELEM.EQ.1) THEN
               IF(LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0
               AFB=2.0D0*Q2(1,2)-AFB
            ELSE IF(IELEM.EQ.2) THEN
               AFB=AFB-2.0D0*SQRT(3.0D0)*Q2(2,3)
            ELSE IF(IELEM.EQ.3) THEN
               AFB=2.0D0*Q2(1,4)+2.0D0*SQRT(5.0D0)*Q2(3,4)-AFB
            ENDIF
            IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0
   30    CONTINUE
*----
*  FORWARD SWEEP (FROM LEFT TO RIGHT).
*----
         AFBA1=0.0
         IF(NCODE(1).EQ.4) THEN
            AFBA1=REAL(AFB)
            AFB=0.0
         ELSE
            AFB=ZCODE(1)*REAL(AFB)
         ENDIF
         DO 50 I=1,NREG
            IBM=MAT(I)
            DO 40 IEL=1,IELEM
            Q(IEL)=0.0
            DO 40 IL=0,NSCT-1
   40       Q(IEL)=Q(IEL)+QEXT(IEL,IL+1,I)*PL(IL+1,NLF-IP+1)/2.0
            IF(IELEM.EQ.1) THEN
               Q2(1,2)=Q(1)*VOL(I)+2.0D0*U(NLF-IP+1)*AFB
               Q2(1,1)=TOTAL(IBM)*VOL(I)+2.0D0*U(NLF-IP+1)
            ELSE IF(IELEM.EQ.2) THEN
               Q2(1,1)=TOTAL(IBM)*VOL(I)
               Q2(1,2)=2.0D0*SQRT(3.0D0)*U(NLF-IP+1)
               Q2(1,3)=Q(1)*VOL(I)
               Q2(2,1)=Q2(1,2)
               Q2(2,2)=-TOTAL(IBM)*VOL(I)-6.0D0*U(NLF-IP+1)
               Q2(2,3)=-Q(2)*VOL(I)+2.0D0*SQRT(3.0D0)*U(NLF-IP+1)*AFB
            ELSE IF(IELEM.EQ.3) THEN
               Q2(1,1)=TOTAL(IBM)*VOL(I)+2.0D0*U(NLF-IP+1)
               Q2(1,2)=0.0
               Q2(1,3)=2.0D0*SQRT(5.0D0)*U(NLF-IP+1)
               Q2(1,4)=Q(1)*VOL(I)+2.0D0*U(NLF-IP+1)*AFB
               Q2(2,1)=Q2(1,2)
               Q2(2,2)=-TOTAL(IBM)*VOL(I)
               Q2(2,3)=-2.0D0*SQRT(15.0D0)*U(NLF-IP+1)
               Q2(2,4)=-Q(2)*VOL(I)
               Q2(3,1)=Q2(1,3)
               Q2(3,2)=Q2(2,3)
               Q2(3,3)=TOTAL(IBM)*VOL(I)+10.0D0*U(NLF-IP+1)
               Q2(3,4)=Q(3)*VOL(I)+2.0D0*SQRT(5.0D0)*U(NLF-IP+1)*AFB
            ENDIF
            CALL ALSBD(IELEM,1,Q2,IER,3)
            IF(IER.NE.0) CALL XABORT('SNFT1P: SINGULAR MATRIX(2).')
            IF(IELEM.EQ.1) THEN
               IF(LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0
               AFB=2.0D0*Q2(1,2)-AFB
            ELSE IF(IELEM.EQ.2) THEN
               AFB=AFB+2.0D0*SQRT(3.0D0)*Q2(2,3)
            ELSE IF(IELEM.EQ.3) THEN
               AFB=2.0D0*Q2(1,4)+2.0D0*SQRT(5.0D0)*Q2(3,4)-AFB
            ENDIF
            IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0
   50    CONTINUE
*----
*  BACKWARD SWEEP (FROM RIGHT TO LEFT).
*----
         AFBA2=0.0
         AFBA=0.0
         IF(NCODE(1).EQ.4) THEN
            AFBA2=REAL(AFB)
         ELSE
            AFBA=REAL(AFB)
         ENDIF
         AFB=1.0
         DO 70 I=NREG,1,-1
            IBM=MAT(I)
            DO 60 IEL=1,IELEM
            Q(IEL)=0.0
            DO 60 IL=0,NSCT-1
   60       Q(IEL)=Q(IEL)+QEXT(IEL,IL+1,I)*PL(IL+1,IP)/2.0
            IF(IELEM.EQ.1) THEN
               Q2(1,2)=Q(1)*VOL(I)-2.0D0*U(IP)*AFB
               Q2(1,1)=TOTAL(IBM)*VOL(I)-2.0D0*U(IP)
            ELSE IF(IELEM.EQ.2) THEN
               Q2(1,1)=TOTAL(IBM)*VOL(I)
               Q2(1,2)=2.0D0*SQRT(3.0D0)*U(IP)
               Q2(1,3)=Q(1)*VOL(I)
               Q2(2,1)=Q2(1,2)
               Q2(2,2)=-TOTAL(IBM)*VOL(I)+6.0D0*U(IP)
               Q2(2,3)=-Q(2)*VOL(I)+2.0D0*SQRT(3.0D0)*U(IP)*AFB
            ELSE IF(IELEM.EQ.3) THEN
               Q2(1,1)=TOTAL(IBM)*VOL(I)-2.0D0*U(IP)
               Q2(1,2)=0.0
               Q2(1,3)=-2.0D0*SQRT(5.0D0)*U(IP)
               Q2(1,4)=Q(1)*VOL(I)-2.0D0*U(IP)*AFB
               Q2(2,1)=Q2(1,2)
               Q2(2,2)=-TOTAL(IBM)*VOL(I)
               Q2(2,3)=-2.0D0*SQRT(15.0D0)*U(IP)
               Q2(2,4)=-Q(2)*VOL(I)
               Q2(3,1)=Q2(1,3)
               Q2(3,2)=Q2(2,3)
               Q2(3,3)=TOTAL(IBM)*VOL(I)-10.0D0*U(IP)
               Q2(3,4)=Q(3)*VOL(I)-2.0D0*SQRT(5.0D0)*U(IP)*AFB
            ENDIF
            CALL ALSBD(IELEM,1,Q2,IER,3)
            IF(IER.NE.0) CALL XABORT('SNFT1P: SINGULAR MATRIX(3).')
            IF(IELEM.EQ.1) THEN
               IF(LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0
               AFB=2.0D0*Q2(1,2)-AFB
            ELSE IF(IELEM.EQ.2) THEN
               AFB=AFB-2.0D0*SQRT(3.0D0)*Q2(2,3)
            ELSE IF(IELEM.EQ.3) THEN
               AFB=2.0D0*Q2(1,4)+2.0D0*SQRT(5.0D0)*Q2(3,4)-AFB
            ENDIF
            IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0
   70    CONTINUE
*----
*  FORWARD SWEEP (FROM LEFT TO RIGHT).
*----
         IF(NCODE(1).EQ.4) THEN
            AFBB1=REAL(AFB)
            AFB1=AFBA1/(1.0+AFBA1-AFBB1)
            AFB=1.0
         ELSE
            AFB=ZCODE(1)*AFB
         ENDIF
         DO 90 I=1,NREG
            IBM=MAT(I)
            DO 80 IEL=1,IELEM
            Q(IEL)=0.0
            DO 80 IL=0,NSCT-1
   80       Q(IEL)=Q(IEL)+QEXT(IEL,IL+1,I)*PL(IL+1,NLF-IP+1)/2.0
            IF(IELEM.EQ.1) THEN
               Q2(1,2)=Q(1)*VOL(I)+2.0D0*U(NLF-IP+1)*AFB
               Q2(1,1)=TOTAL(IBM)*VOL(I)+2.0D0*U(NLF-IP+1)
            ELSE IF(IELEM.EQ.2) THEN
               Q2(1,1)=TOTAL(IBM)*VOL(I)
               Q2(1,2)=2.0D0*SQRT(3.0D0)*U(NLF-IP+1)
               Q2(1,3)=Q(1)*VOL(I)
               Q2(2,1)=Q2(1,2)
               Q2(2,2)=-TOTAL(IBM)*VOL(I)-6.0D0*U(NLF-IP+1)
               Q2(2,3)=-Q(2)*VOL(I)+2.0D0*SQRT(3.0D0)*U(NLF-IP+1)*AFB
            ELSE IF(IELEM.EQ.3) THEN
               Q2(1,1)=TOTAL(IBM)*VOL(I)+2.0D0*U(NLF-IP+1)
               Q2(1,2)=0.0
               Q2(1,3)=2.0D0*SQRT(5.0D0)*U(NLF-IP+1)
               Q2(1,4)=Q(1)*VOL(I)+2.0D0*U(NLF-IP+1)*AFB
               Q2(2,1)=Q2(1,2)
               Q2(2,2)=-TOTAL(IBM)*VOL(I)
               Q2(2,3)=-2.0D0*SQRT(15.0D0)*U(NLF-IP+1)
               Q2(2,4)=-Q(2)*VOL(I)
               Q2(3,1)=Q2(1,3)
               Q2(3,2)=Q2(2,3)
               Q2(3,3)=TOTAL(IBM)*VOL(I)+10.0D0*U(NLF-IP+1)
               Q2(3,4)=Q(3)*VOL(I)+2.0D0*SQRT(5.0D0)*U(NLF-IP+1)*AFB
            ENDIF
            CALL ALSBD(IELEM,1,Q2,IER,3)
            IF(IER.NE.0) CALL XABORT('SNFT1P: SINGULAR MATRIX(4).')
            IF(IELEM.EQ.1) THEN
               IF(LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0
               AFB=2.0D0*Q2(1,2)-AFB
               IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0
            ELSE IF(IELEM.EQ.2) THEN
               AFB=AFB+2.0D0*SQRT(3.0D0)*Q2(2,3)
            ELSE IF(IELEM.EQ.3) THEN
               AFB=2.0D0*Q2(1,4)+2.0D0*SQRT(5.0D0)*Q2(3,4)-AFB
            ENDIF
   90    CONTINUE
         IF(NCODE(1).EQ.4) THEN
            AFBB2=REAL(AFB)
            AFB2=AFBA2/(1.0+AFBA2-AFBB2)
         ELSE
            AFBB=REAL(AFB)
            AFB=ZCODE(2)*AFBA/(1.0+ZCODE(2)*(AFBA-AFBB))
         ENDIF
      ENDIF
*----
*  BACKWARD SWEEP (FROM RIGHT TO LEFT).
*----
      IF(NCODE(1).EQ.4) AFB=AFB1
      DO 120 I=NREG,1,-1
         IBM=MAT(I)
         DO 100 IEL=1,IELEM
         Q(IEL)=0.0
         DO 100 IL=0,NSCT-1
  100    Q(IEL)=Q(IEL)+QEXT(IEL,IL+1,I)*PL(IL+1,IP)/2.0
         IF(IELEM.EQ.1) THEN
            Q2(1,2)=Q(1)*VOL(I)-2.0D0*U(IP)*AFB
            Q2(1,1)=TOTAL(IBM)*VOL(I)-2.0D0*U(IP)
         ELSE IF(IELEM.EQ.2) THEN
            Q2(1,1)=TOTAL(IBM)*VOL(I)
            Q2(1,2)=2.0D0*SQRT(3.0D0)*U(IP)
            Q2(1,3)=Q(1)*VOL(I)
            Q2(2,1)=Q2(1,2)
            Q2(2,2)=-TOTAL(IBM)*VOL(I)+6.0D0*U(IP)
            Q2(2,3)=-Q(2)*VOL(I)+2.0D0*SQRT(3.0D0)*U(IP)*AFB
         ELSE IF(IELEM.EQ.3) THEN
            Q2(1,1)=TOTAL(IBM)*VOL(I)-2.0D0*U(IP)
            Q2(1,2)=0.0
            Q2(1,3)=-2.0D0*SQRT(5.0D0)*U(IP)
            Q2(1,4)=Q(1)*VOL(I)-2.0D0*U(IP)*AFB
            Q2(2,1)=Q2(1,2)
            Q2(2,2)=-TOTAL(IBM)*VOL(I)
            Q2(2,3)=-2.0D0*SQRT(15.0D0)*U(IP)
            Q2(2,4)=-Q(2)*VOL(I)
            Q2(3,1)=Q2(1,3)
            Q2(3,2)=Q2(2,3)
            Q2(3,3)=TOTAL(IBM)*VOL(I)-10.0D0*U(IP)
            Q2(3,4)=Q(3)*VOL(I)-2.0D0*SQRT(5.0D0)*U(IP)*AFB
         ENDIF
         CALL ALSBD(IELEM,1,Q2,IER,3)
         IF(IER.NE.0) CALL XABORT('SNFT1P: SINGULAR MATRIX(5).')
         IF(IELEM.EQ.1) THEN
            IF(LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0
            AFB=2.0D0*Q2(1,2)-AFB
         ELSE IF(IELEM.EQ.2) THEN
            AFB=AFB-2.0D0*SQRT(3.0D0)*Q2(2,3)
         ELSE IF(IELEM.EQ.3) THEN
            AFB=2.0D0*Q2(1,4)+2.0D0*SQRT(5.0D0)*Q2(3,4)-AFB
         ENDIF
         IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0
         DO 110 K=1,NSCT
         DO 110 IEL=1,IELEM
  110    FLUX(IEL,K,I)=FLUX(IEL,K,I)+W(IP)*REAL(Q2(IEL,IELEM+1))*
     1   PL(K,IP)
  120 CONTINUE
      CURR(1)=CURR(1)+W(IP)*U(IP)*AFB
*----
*  FORWARD SWEEP (FROM LEFT TO RIGHT).
*----
      AFB=ZCODE(1)*AFB
      IF(NCODE(1).EQ.4) AFB=AFB2
      DO 150 I=1,NREG
         IBM=MAT(I)
         DO 130 IEL=1,IELEM
         Q(IEL)=0.0
         DO 130 IL=0,NSCT-1
  130    Q(IEL)=Q(IEL)+QEXT(IEL,IL+1,I)*PL(IL+1,NLF-IP+1)/2.0
         IF(IELEM.EQ.1) THEN
            Q2(1,2)=Q(1)*VOL(I)+2.0D0*U(NLF-IP+1)*AFB
            Q2(1,1)=TOTAL(IBM)*VOL(I)+2.0D0*U(NLF-IP+1)
         ELSE IF(IELEM.EQ.2) THEN
            Q2(1,1)=TOTAL(IBM)*VOL(I)
            Q2(1,2)=2.0D0*SQRT(3.0D0)*U(NLF-IP+1)
            Q2(1,3)=Q(1)*VOL(I)
            Q2(2,1)=Q2(1,2)
            Q2(2,2)=-TOTAL(IBM)*VOL(I)-6.0D0*U(NLF-IP+1)
            Q2(2,3)=-Q(2)*VOL(I)+2.0D0*SQRT(3.0D0)*U(NLF-IP+1)*AFB
         ELSE IF(IELEM.EQ.3) THEN
            Q2(1,1)=TOTAL(IBM)*VOL(I)+2.0D0*U(NLF-IP+1)
            Q2(1,2)=0.0
            Q2(1,3)=2.0D0*SQRT(5.0D0)*U(NLF-IP+1)
            Q2(1,4)=Q(1)*VOL(I)+2.0D0*U(NLF-IP+1)*AFB
            Q2(2,1)=Q2(1,2)
            Q2(2,2)=-TOTAL(IBM)*VOL(I)
            Q2(2,3)=-2.0D0*SQRT(15.0D0)*U(NLF-IP+1)
            Q2(2,4)=-Q(2)*VOL(I)
            Q2(3,1)=Q2(1,3)
            Q2(3,2)=Q2(2,3)
            Q2(3,3)=TOTAL(IBM)*VOL(I)+10.0D0*U(NLF-IP+1)
            Q2(3,4)=Q(3)*VOL(I)+2.0D0*SQRT(5.0D0)*U(NLF-IP+1)*AFB
         ENDIF
         CALL ALSBD(IELEM,1,Q2,IER,3)
         IF(IER.NE.0) CALL XABORT('SNFT1P: SINGULAR MATRIX(6).')
         IF(IELEM.EQ.1) THEN
            IF(LFIXUP.AND.(Q2(1,2).LE.RLOG)) Q2(1,2)=0.0
            AFB=2.0D0*Q2(1,2)-AFB
         ELSE IF(IELEM.EQ.2) THEN
            AFB=AFB+2.0D0*SQRT(3.0D0)*Q2(2,3)
         ELSE IF(IELEM.EQ.3) THEN
            AFB=2.0D0*Q2(1,4)+2.0D0*SQRT(5.0D0)*Q2(3,4)-AFB
         ENDIF
         IF(LFIXUP.AND.(AFB.LE.RLOG)) AFB=0.0
         DO 140 K=1,NSCT
         DO 140 IEL=1,IELEM
  140    FLUX(IEL,K,I)=FLUX(IEL,K,I)+W(NLF-IP+1)*REAL(Q2(IEL,IELEM+1))*
     1   PL(K,NLF-IP+1)
  150 CONTINUE
      CURR(2)=CURR(2)+W(NLF-IP+1)*U(NLF-IP+1)*AFB
*----
*  END OF OUTER LOOP OVER MU LEVELS
*----
  200 CONTINUE
      RETURN
      END
