*DECK SNTT3D
      SUBROUTINE SNTT3D(IMPX,LX,LY,LZ,IELEM,NLF,NPQ,NSCT,IQUAD,NCODE,
     1 ZCODE,MAT,XXX,YYY,ZZZ,VOL,IDL,DU,DE,DZ,W,MRMX,MRMY,MRMZ,DC,DB,
     2 DA,PL)
*
*-----------------------------------------------------------------------
*
*Purpose:
* numbering corresponding to a 3-D Cartesian with discrete ordinates
* approximation of the flux.
*
*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): N. Martin
*
*Parameters: input
* IMPX    print parameter.
* LX      number of elements along the X axis.
* LY      number of elements along the Y axis.
* LZ      number of elements along the Z axis.
* IELEM   degree of the spatial approximation (=1: diamond scheme).
* NLF     number of Legendre orders for the flux (even number).
* NPQ     number of SN directions in height octants.
* NSCT    maximum number of spherical harmonics moments of the flux.
* IQUAD   type of SN quadrature (1: Level symmetric, type IQUAD;
*         4: Legendre-Chebyshev; 5: symmetric Legendre-Chebyshev;
*         6: quadruple range).
* NCODE   type of boundary condition applied on each side
*         (i=1: X-  i=2: X+  i=3: Y-  i=4: Y+  i=5: Z-  i=6: Z+):
*         NCODE(I)=1: VOID;   NCODE(I)=2: REFL;   NCODE(I)=4: TRAN.
* ZCODE   ZCODE(I) is the albedo corresponding to boundary condition
*         'VOID' on each side (ZCODE(I)=0.0 by default).
* MAT     mixture index assigned to each element.
* XXX     Cartesian coordinates along the X axis.
* YYY     Cartesian coordinates along the Y axis.
* ZZZ     Cartesian coordinates along the Z axis.
*
*Parameters: output
* VOL     volume of each element.
* IDL     isotropic flux indices.
* DU      first direction cosines ($\mu$).
* DE      second direction cosines ($\eta$).
* DZ      third direction cosines ($\xi$).
* W       weights.
* MRMX    quadrature index.
* MRMY    quadrature index.
* MRMZ    quadrature index.
* DC      diamond-scheme parameter.
* DB      diamond-scheme parameter.
* DA      diamond-scheme parameter.
* PL      discrete values of the spherical harmonics corresponding
*         to the 3D SN quadrature.
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER IMPX,LX,LY,LZ,IELEM,NLF,NPQ,NSCT,IQUAD,NCODE(6),
     1 MAT(LX,LY,LZ),IDL(LX*LY*LZ),MRMX(NPQ),MRMY(NPQ),MRMZ(NPQ)
      REAL ZCODE(6),VOL(LX,LY,LZ),XXX(LX+1),YYY(LY+1),ZZZ(LZ+1),
     1 DU(NPQ),DE(NPQ),DZ(NPQ),W(NPQ),DC(LX,LY,NPQ),DB(LX,LZ,NPQ),
     2 DA(LY,LZ,NPQ),PL(NSCT,NPQ)
*----
*  LOCAL VARIABLES
*----
      CHARACTER HSMG*131
      LOGICAL L1,L2,L3,L4,L5,L6
      PARAMETER(RLOG=1.0E-8,PI=3.141592654)
      INTEGER, ALLOCATABLE, DIMENSION(:) :: JOP
      REAL, ALLOCATABLE, DIMENSION(:) :: XX,YY,ZZ,UU,WW,TPQ,UPQ,VPQ,WPQ
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(XX(LX),YY(LY),ZZ(LZ))
*----
*  UNFOLD HEIGHT-OCTANT QUADRATURES.
*----
      IF(MOD(NLF,2).EQ.1) CALL XABORT('SNTT3D: EVEN NLF EXPECTED.')
      NPQ0=NLF*(NLF/2+1)/4
      ALLOCATE(JOP(NLF/2),UU(NLF/2),WW(NLF/2),TPQ(NPQ0),UPQ(NPQ0),
     1 VPQ(NPQ0),WPQ(NPQ0))
      IF(IQUAD.EQ.1) THEN
!Level-symmetric quadrature of type 1
         CALL SNQU01(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ)
      ELSE IF(IQUAD.EQ.2) THEN
!Level-symmetric quadrature of type 2
         CALL SNQU02(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ)
      ELSE IF(IQUAD.EQ.3) THEN
!Snow Level-symmetric type quadrature 
         CALL SNQU03(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ)
      ELSE IF(IQUAD.EQ.4) THEN
!Legendre-Chebyshev quadrature 
         CALL SNQU04(NLF,JOP,UU,WW,TPQ,UPQ,VPQ,WPQ)
      ELSE IF(IQUAD.EQ.5) THEN
!Symmetric Legendre-Chebyshev quadrature
         CALL SNQU05(NLF,TPQ,UPQ,VPQ,WPQ)
      ELSE IF(IQUAD.EQ.6) THEN
!Quadruple Range quadrature
         CALL SNQU06(NLF,TPQ,UPQ,VPQ,WPQ)
      ELSE
         CALL XABORT('SNTT3D: UNKNOWN QUADRATURE TYPE.')
      ENDIF
      M=0
      IOF=0
      DO 320 I=1,NLF/2
         JOF=IOF+NLF-2*I+2
         DO 330 J=0,NLF/2-I
            IOF=IOF+1
            KOF=IOF+(NLF+2)*NLF/4
            LOF=IOF+(NLF+2)*NLF/2
            MRMX(IOF)=JOF
            MRMY(IOF)=KOF
            MRMZ(IOF)=LOF
            DU(IOF)=-UPQ(M+J+1)
            DE(IOF)=-VPQ(M+J+1)
            DZ(IOF)=-TPQ(M+J+1)
            W(IOF)=WPQ(M+J+1)
 330        JOF=JOF-1
         DO 340 J=NLF/2-I,0,-1
            IOF=IOF+1
            KOF=IOF+(NLF+2)*NLF/4
            LOF=IOF+(NLF+2)*NLF/2
            MRMX(IOF)=JOF
            MRMY(IOF)=KOF
            MRMZ(IOF)=LOF
            DU(IOF)=UPQ(M+J+1)
            DE(IOF)=-VPQ(M+J+1)
            DZ(IOF)=-TPQ(M+J+1)
            W(IOF)=WPQ(M+J+1)
 340        JOF=JOF-1
 320     M=M+NLF/2-I+1
         M=0
      DO 350 I=1,NLF/2
         JOF=IOF+NLF-2*I+2
         DO 360 J=0,NLF/2-I
            IOF=IOF+1
            KOF=IOF-(NLF+2)*NLF/4
            LOF=IOF+(NLF+2)*NLF/2
            MRMX(IOF)=JOF
            MRMY(IOF)=KOF
            MRMZ(IOF)=LOF
            DU(IOF)=-UPQ(M+J+1)
            DE(IOF)=VPQ(M+J+1)
            DZ(IOF)=-TPQ(M+J+1)
            W(IOF)=WPQ(M+J+1)
 360        JOF=JOF-1
         DO 370 J=NLF/2-I,0,-1
            IOF=IOF+1
            KOF=IOF-(NLF+2)*NLF/4
            LOF=IOF+(NLF+2)*NLF/2
            MRMX(IOF)=JOF
            MRMY(IOF)=KOF
            MRMZ(IOF)=LOF
            DU(IOF)=UPQ(M+J+1)
            DE(IOF)=VPQ(M+J+1)
            DZ(IOF)=-TPQ(M+J+1)
            W(IOF)=WPQ(M+J+1)
 370        JOF=JOF-1
 350     M=M+NLF/2-I+1
      M=0
      DO 380 I=1,NLF/2
         JOF=IOF+NLF-2*I+2
         DO 390 J=0,NLF/2-I
            IOF=IOF+1
            KOF=IOF+(NLF+2)*NLF/4
            LOF=IOF-(NLF+2)*NLF/2
            MRMX(IOF)=JOF
            MRMY(IOF)=KOF
            MRMZ(IOF)=LOF
            DU(IOF)=-UPQ(M+J+1)
            DE(IOF)=-VPQ(M+J+1)
            DZ(IOF)=TPQ(M+J+1)
            W(IOF)=WPQ(M+J+1)
 390        JOF=JOF-1
         DO 400 J=NLF/2-I,0,-1
            IOF=IOF+1
            KOF=IOF+(NLF+2)*NLF/4
            LOF=IOF-(NLF+2)*NLF/2
            MRMX(IOF)=JOF
            MRMY(IOF)=KOF
            MRMZ(IOF)=LOF
            DU(IOF)=UPQ(M+J+1)
            DE(IOF)=-VPQ(M+J+1)
            DZ(IOF)=TPQ(M+J+1)
            W(IOF)=WPQ(M+J+1)
 400        JOF=JOF-1
 380     M=M+NLF/2-I+1
         M=0
      DO 410 I=1,NLF/2
         JOF=IOF+NLF-2*I+2
         DO 420 J=0,NLF/2-I
            IOF=IOF+1
            KOF=IOF-(NLF+2)*NLF/4
            LOF=IOF-(NLF+2)*NLF/2
            MRMX(IOF)=JOF
            MRMY(IOF)=KOF
            MRMZ(IOF)=LOF
            DU(IOF)=-UPQ(M+J+1)
            DE(IOF)=VPQ(M+J+1)
            DZ(IOF)=TPQ(M+J+1)
            W(IOF)=WPQ(M+J+1)
 420        JOF=JOF-1
         DO 430 J=NLF/2-I,0,-1
            IOF=IOF+1
            KOF=IOF-(NLF+2)*NLF/4
            LOF=IOF-(NLF+2)*NLF/2
            MRMX(IOF)=JOF
            MRMY(IOF)=KOF
            MRMZ(IOF)=LOF
            DU(IOF)=UPQ(M+J+1)
            DE(IOF)=VPQ(M+J+1)
            DZ(IOF)=TPQ(M+J+1)
            W(IOF)=WPQ(M+J+1)
 430        JOF=JOF-1
 410     M=M+NLF/2-I+1
      DEALLOCATE(WPQ,VPQ,UPQ,TPQ,WW,UU,JOP)
     
      IF(IMPX.GE.4) THEN
         WRITE(6,'(/41H SNTT3D:HEIGHT-OCTANT ANGULAR QUADRATURES:/26X,
     1   2HMU,9X,3HETA,10X,2HXI,6X,6HWEIGHT)')
         SUM=0.0
         DO 70 M=1,NPQ
         SUM=SUM+W(M)
         WRITE(6,'(1X,4I5,1P,4E12.4)') M,MRMX(M),MRMY(M),MRMZ(M),DU(M)
     1    ,DE(M),DZ(M),W(M)
   70    CONTINUE
         WRITE(6,'(54X,10(1H-)/52X,1P,E12.4)') SUM
      ENDIF
*----
*  IDENTIFICATION OF THE GEOMETRY.
*----
         DO 80 M=1,NPQ
         VU=DU(M)
         VE=DE(M)
         VZ=DZ(M)
         DO 80 I=1,LX
         DO 80 J=1,LY
         DO 80 K=1,LZ                  
         XX(I)=XXX(I+1)-XXX(I)
         YY(J)=YYY(J+1)-YYY(J)
         ZZ(K)=ZZZ(K+1)-ZZZ(K)
         DA(J,K,M)=VU*YY(J)*ZZ(K)   
         DB(I,K,M)=VE*XX(I)*ZZ(K) 
         DC(I,J,M)=VZ*XX(I)*YY(J)                  
   80    VOL(I,J,K)=XX(I)*YY(J)*ZZ(K)
*----
*  GENERATE SPHERICAL HARMONICS FOR SCATTERING SOURCE.
*----
      IOF=0
      DO 210 IL=0,NLF-1
      DO 210 IM=-IL,IL   
      IOF=IOF+1
      IF(IOF.GT.NSCT) GO TO 220
      DO 200 M=1,NPQ
  200 PL(IOF,M)=PNSH(IL,IM,DU(M),DE(M),DZ(M))
  210 CONTINUE
*----
*  COMPUTE ISOTROPIC FLUX INDICES.
*----
  220 DO 230 I=1,LX*LY*LZ
  230 IDL(I)=(I-1)*NSCT*IELEM*IELEM*IELEM+1
*----
*  SET BOUNDARY CONDITIONS.
*----
      DO 240 I=1,6
      IF(NCODE(I).NE.1) ZCODE(I)=1.0
      IF(NCODE(I).EQ.7) CALL XABORT('SNTT3D: ZERO FLUX BC NOT ALLOWED.')
  240 CONTINUE
*----
*  CHECK FOR INVALID VIRTUAL ELEMENTS.
*----
      DO 290 I=2,LX-1
      DO 290 J=2,LY-1
      DO 290 K=2,LZ-1
      IF(MAT(I,J,K).EQ.0) THEN
         L1=(NCODE(1).NE.1)
         DO 250 J1=1,J-1
         DO 250 K1=1,K-1
  250    L1=L1.OR.(MAT(I,J1,K1).NE.0)
         L2=(NCODE(2).NE.1)
         DO 260 J1=J+1,LY
         DO 260 K1=K+1,LZ
  260    L2=L2.OR.(MAT(I,J1,K1).NE.0)
         L3=(NCODE(3).NE.1)
         DO 270 I1=1,I-1
         DO 270 K1=1,K-1
  270    L3=L3.OR.(MAT(I1,J,K1).NE.0)
         L4=(NCODE(4).NE.1)
         DO 280 I1=I+1,LX
         DO 280 K1=K+1,LZ
  280    L4=L4.OR.(MAT(I1,J,K1).NE.0)
         L5=(NCODE(5).NE.1)
         DO 300 I1=1,I-1
         DO 300 J1=1,J-1
  300    L5=L5.OR.(MAT(I1,J1,K).NE.0)
         L6=(NCODE(6).NE.0)
         DO 310 I1=I+1,LX
         DO 310 J1=I+1,LY
 310     L6=L6.OR.(MAT(I1,J1,K).NE.0)
         IF(L1.AND.L2.AND.L3.AND.L4.AND.L5.AND.L6) THEN
            WRITE(HSMG,'(17HSNTT3D: ELEMENT (,I3,1H,,I3,11H) CANNOT BE,
     1      9H VIRTUAL.)') I,J,K
            CALL XABORT(HSMG)
         ENDIF
      ENDIF
  290 CONTINUE
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(ZZ,YY,XX)
      RETURN
      END
