*DECK SNTRK
      SUBROUTINE SNTRK(MAXPTS,IPTRK,IPGEOM,IMPX,IELEM,NLF,MAXIT,EPSI,
     1 ISCAT,IQUAD,LFIXUP,LIVO,ICL1,ICL2,LDSA,NSTART,NSDSA,LBIHET)
*
*-----------------------------------------------------------------------
*
*Purpose:
* recover of the geometry and tracking for SN methods.
*
*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
* MAXPTS  allocated storage for arrays of dimension NEL.
* IPTRK   L_TRACK pointer to the tracking information.
* IPGEOM  L_GEOM pointer to the geometry.
* IMPX    print flag.
* IELEM   degree of the spatial approximation (=1: diamond scheme).
* NLF     number of Legendre orders for the flux. Equal to zero for
*         diffusion theory.
* MAXIT   Maximum number of inner iterations  (default=100)
* EPSI    Convergence criterion on inner iterations (default=5.E-5)
* ISCAT   anisotropy of one-speed sources:
*         =1: isotropic sources;
*         =2: linearly anisotropic sources.
* IQUAD   type of SN quadrature (1: Level symmetric, type IQUAD;
*         4: Gauss-Legendre and Gauss-Chebyshev; 10: product).
* LFIXUP  flag to enable negative flux fixup.
* LIVO    flag to enable Livolant acceleration.
* ICL1    Number of free iterations with Livolant acceleration.
* ICL2    Number of accelerated iterations with Livolant acceleration.
* LDSA    flag to enable diffusion synthetic acceleration.
* NSTART  restarts the GMRES method every NSTART iterations.
* NSDSA   number of inner flux iterations before enabling DSA.
* LBIHET  flag to enable the double-heterogeneity model.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPTRK,IPGEOM
      INTEGER MAXPTS,IMPX,IELEM,NLF,ISCAT,IQUAD,MAXIT,ICL1,ICL2,NSTART,
     1 NSDSA
      REAL EPSI
      LOGICAL LFIXUP,LDSA,LBIHET,LIVO
*----
*  LOCAL VARIABLES
*----
      PARAMETER(NSTATE=40)
      LOGICAL ILK
      CHARACTER HSMG*131
      INTEGER ISTATE(NSTATE),IGP(NSTATE),NCODE(6)
      REAL ZCODE(6)
      INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,IDL,ISPLX,ISPLY,ISPLZ,
     1 JOP,MRMX,MRMY,MRMZ
      REAL, ALLOCATABLE, DIMENSION(:) :: VOL,XXX,YYY,ZZZ,UU,WW,PL,TPQ,
     1 UPQ,VPQ,WPQ,ALPHA,PLZ,SURF,DU,DE,DZ,DC,DB,DA,DAL
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(MAT(MAXPTS),VOL(MAXPTS),IDL(MAXPTS))
*     
      CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE)
      ITYPE=ISTATE(1)
*
      IF((ITYPE.NE.2).AND.(ITYPE.NE.3).AND.(ITYPE.NE.4).AND.
     1   (ITYPE.NE.5).AND.(ITYPE.NE.6).AND.(ITYPE.NE.7)) THEN
         CALL XABORT('SNTRK: DISCRETIZATION NOT AVAILABLE.')
      ENDIF
      ALLOCATE(XXX(MAXPTS+1),YYY(MAXPTS+1),ZZZ(MAXPTS+1))
*
      ALLOCATE(ISPLX(MAXPTS),ISPLY(MAXPTS),ISPLZ(MAXPTS))
      CALL READ3D(MAXPTS,MAXPTS,MAXPTS,MAXPTS,IPGEOM,IHEX,IR,MAT,
     1 ILK,SIDE,XXX,YYY,ZZZ,IMPX,LX,LY,LZ,NEL,NCODE,ZCODE,ISPLX,
     2 ISPLY,ISPLZ)
      DEALLOCATE(ISPLZ,ISPLY,ISPLX)
*
      IF(LX*LY*LZ.GT.MAXPTS) THEN
         WRITE (HSMG,'(38HSNTRK: MAXPTS SHOULD BE INCREASED FROM,I7,
     1   3H TO,I7)') MAXPTS,LX*LY*LZ
         CALL XABORT(HSMG)
      ENDIF
      IF((ITYPE.EQ.2).OR.(ITYPE.EQ.3)) THEN
         NCODE(3)=2
         NCODE(4)=5
         ZCODE(3)=1.0
         ZCODE(4)=1.0
         YYY(1)=0.0
         YYY(2)=2.0
      ELSE IF(ITYPE.EQ.6) THEN
         LY=LZ
         DO 60 I=1,LZ+1
   60    YYY(I)=ZZZ(I)
         NCODE(3)=NCODE(5)
         NCODE(4)=NCODE(6)
         ZCODE(3)=ZCODE(5)
         ZCODE(4)=ZCODE(6)
      ENDIF
*----
*  UNFOLD THE DOMAIN IN DIAGONAL SYMMETRY CASES.
*----
      IF(ITYPE.EQ.7) THEN 
       
      IDIAG=0
      IF((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) THEN
         IDIAG=1
         NCODE(3)=NCODE(1)
         NCODE(2)=NCODE(4)
         ZCODE(3)=ZCODE(1)
         ZCODE(2)=ZCODE(4)
         K=NEL
         DO 85 IZ=LZ,1,-1
         IOFF=(IZ-1)*LX*LY
         DO 85 IY=LY,1,-1
         DO 75 IX=LX,IY+1,-1
   75    MAT(IOFF+(IY-1)*LX+IX)=MAT(IOFF+(IX-1)*LY+IY)
         DO 85 IX=IY,1,-1
         MAT(IOFF+(IY-1)*LX+IX)=MAT(K)
   85    K=K-1
         NEL=LX*LY*LZ
         IF(K.NE.0) THEN
            CALL XABORT('SNTRK: UNABLE TO UNFOLD THE DOMAIN.')
         ENDIF
      ELSE IF((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) THEN
         IDIAG=1
         NCODE(1)=NCODE(3)
         NCODE(4)=NCODE(2)
         ZCODE(1)=ZCODE(3)
         ZCODE(4)=ZCODE(2)
         K=NEL
         DO 95 IZ=LZ,1,-1
         IOFF=(IZ-1)*LX*LY
         DO 95 IY=LY,1,-1
         DO 95 IX=LX,IY,-1
         MAT(IOFF+(IY-1)*LX+IX)=MAT(K)
   95    K=K-1
         DO 110 IZ=1,LZ
         IOFF=(IZ-1)*LX*LY
         DO 110 IY=1,LY
         DO 110 IX=1,IY-1
 110        MAT(IOFF+(IY-1)*LX+IX)=MAT(IOFF+(IX-1)*LY+IY)
         NEL=LX*LY*LZ
         IF(K.NE.0) THEN
            CALL XABORT('SNTRK: UNABLE TO UNFOLD THE DOMAIN.')
         ENDIF
      ENDIF

      ELSE 
      IF((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) THEN
         NCODE(3)=NCODE(1)
         NCODE(2)=NCODE(4)
         ZCODE(3)=ZCODE(1)
         ZCODE(2)=ZCODE(4)
         K=LX*(LX+1)/2
         DO 80 IY=LY,1,-1
         DO 70 IX=LX,IY+1,-1
   70    MAT((IY-1)*LX+IX)=MAT((IX-1)*LY+IY)
         DO 80 IX=IY,1,-1
         MAT((IY-1)*LX+IX)=MAT(K)
   80    K=K-1
         NEL=LX*LY
         IF(K.NE.0) THEN
            CALL XABORT('SNTRK: UNABLE TO UNFOLD THE DOMAIN.')
         ENDIF
      ELSE IF((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) THEN
         NCODE(1)=NCODE(3)
         NCODE(4)=NCODE(2)
         ZCODE(1)=ZCODE(3)
         ZCODE(4)=ZCODE(2)
         K=LX*(LX+1)/2
         DO 90 IY=LY,1,-1
         DO 90 IX=LX,IY,-1
         MAT((IY-1)*LX+IX)=MAT(K)
   90    K=K-1
         DO 100 IY=1,LY
         DO 100 IX=1,IY-1
  100    MAT((IY-1)*LX+IX)=MAT((IX-1)*LY+IY)
         NEL=LX*LY
         IF(K.NE.0) THEN
            CALL XABORT('SNTRK: UNABLE TO UNFOLD THE DOMAIN.')
         ENDIF
      ENDIF
      ENDIF
        
      IF(IMPX.GT.5) THEN
         WRITE(6,600) 'NCODE',(NCODE(I),I=1,6)
         WRITE(6,600) 'MAT',(MAT(I),I=1,LX*LY*LZ)
      ENDIF
*
      IF(ITYPE.EQ.2) THEN
*        1D SLAB GEOMETRY.
         IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.')
         NSCT=ISCAT
         ALLOCATE(UU(NLF),WW(NLF),PL(NSCT*NLF))
         CALL SNT1DP(IMPX,LX,IELEM,NCODE,ZCODE,XXX,NLF,NSCT,UU,WW,PL,
     1   VOL,IDL)
         CALL LCMPUT(IPTRK,'U',NLF,2,UU)
         CALL LCMPUT(IPTRK,'W',NLF,2,WW)
         CALL LCMPUT(IPTRK,'PL',NSCT*NLF,2,PL)
         DEALLOCATE(PL,WW,UU)
         LL4=LX*NSCT*IELEM
         NUN=LL4
      ELSE IF(ITYPE.EQ.3) THEN
*        1D CYLINDRICAL GEOMETRY.
         IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.')
         NSCT=(ISCAT/2)*(ISCAT/2+1)+(ISCAT+1)*MOD(ISCAT,2)/2
         IF(IQUAD.GE.10) THEN
*           PRODUCT QUADRATURE.
            NPQ=(NLF**2)/2
         ELSE
            NPQ=NLF*(1+NLF/2)/2
         ENDIF
         ALLOCATE(JOP(NLF/2),UU(NLF/2),WW(NLF/2),TPQ(NPQ),UPQ(NPQ),
     1   VPQ(NPQ),WPQ(NPQ),ALPHA(NPQ),PLZ(NSCT*NLF/2),PL(NSCT*NPQ),
     2   SURF(LX+1))
         CALL SNT1DC(IMPX,LX,NCODE,ZCODE,XXX,NLF,NPQ,NSCT,IQUAD,JOP,
     1   UU,WW,TPQ,UPQ,VPQ,WPQ,ALPHA,PLZ,PL,VOL,IDL,SURF)
         DEALLOCATE(VPQ,TPQ,WW)
         CALL LCMPUT(IPTRK,'JOP',NLF/2,1,JOP)
         CALL LCMPUT(IPTRK,'U',NLF/2,2,UU)
         CALL LCMPUT(IPTRK,'UPQ',NPQ,2,UPQ)
         CALL LCMPUT(IPTRK,'WPQ',NPQ,2,WPQ)
         CALL LCMPUT(IPTRK,'ALPHA',NPQ,2,ALPHA)
         CALL LCMPUT(IPTRK,'PLZ',NSCT*NLF/2,2,PLZ)
         CALL LCMPUT(IPTRK,'PL',NSCT*NPQ,2,PL)
         CALL LCMPUT(IPTRK,'SURF',LX+1,2,SURF)
         DEALLOCATE(SURF,PL,PLZ,ALPHA,WPQ,UPQ,UU,JOP)
         LL4=LX*NSCT
         NUN=LL4
      ELSE IF(ITYPE.EQ.4) THEN
*        1D SPHERICAL GEOMETRY.
         IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.')
         NSCT=ISCAT
         ALLOCATE(UU(NLF),WW(NLF),ALPHA(NLF),PLZ(NSCT),PL(NSCT*NLF),
     1   SURF(LX+1))
         CALL SNT1DS(IMPX,LX,NCODE,ZCODE,XXX,NLF,NSCT,UU,WW,ALPHA,
     1   PLZ,PL,VOL,IDL,SURF)
         CALL LCMPUT(IPTRK,'U',NLF,2,UU)
         CALL LCMPUT(IPTRK,'W',NLF,2,WW)
         CALL LCMPUT(IPTRK,'ALPHA',NLF,2,ALPHA)
         CALL LCMPUT(IPTRK,'PLZ',NSCT,2,PLZ)
         CALL LCMPUT(IPTRK,'PL',NSCT*NLF,2,PL)
         CALL LCMPUT(IPTRK,'SURF',LX+1,2,SURF)
         CALL LCMPUT(IPTRK,'XXX',LX+1,2,XXX)
         DEALLOCATE(SURF,PL,PLZ,ALPHA,WW,UU)
         LL4=LX*NSCT
         NUN=LL4
      ELSE IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6)) THEN
*        2D GEOMETRIES.
         IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.')
         NSCT=ISCAT*(ISCAT+1)/2
         IGE=0
         IF(ITYPE.EQ.6) IGE=1
         NPQ=(NLF+4)*NLF/2
         ALLOCATE(MRMX(NPQ),MRMY(NPQ))
         ALLOCATE(DU(NPQ),DE(NPQ),WW(NPQ),DB(LX*NPQ),DA(LX*LY*NPQ),
     1   DAL(LX*LY*NPQ),PL(NSCT*NPQ))
         CALL SNTT2D(IGE,IMPX,LX,LY,IELEM,NLF,NPQ,NSCT,IQUAD,NCODE,
     1   ZCODE,MAT,XXX,YYY,VOL,IDL,DU,DE,WW,MRMX,MRMY,DB,DA,DAL,PL)
         CALL LCMPUT(IPTRK,'DU',NPQ,2,DU)
         CALL LCMPUT(IPTRK,'DE',NPQ,2,DE)
         CALL LCMPUT(IPTRK,'W',NPQ,2,WW)
         CALL LCMPUT(IPTRK,'MRM',NPQ,1,MRMX)
         CALL LCMPUT(IPTRK,'MRMY',NPQ,1,MRMY)
         CALL LCMPUT(IPTRK,'DB',LX*NPQ,2,DB)
         CALL LCMPUT(IPTRK,'DA',LX*LY*NPQ,2,DA)
         IF(IGE.GT.0) CALL LCMPUT(IPTRK,'DAL',LX*LY*NPQ,2,DAL)
         CALL LCMPUT(IPTRK,'PL',NSCT*NPQ,2,PL)
         DEALLOCATE(PL,DAL,DA,DB,WW,DE,DU)
         DEALLOCATE(MRMY,MRMX)
         LL4=LX*LY*NSCT*IELEM*IELEM
         NUN=LL4+(LX+LY)*NPQ*IELEM
      ELSE IF(ITYPE.EQ.7) THEN
*        3D CARTESIAN GEOMETRY
         IF(ISCAT.EQ.0) CALL XABORT('SNTRK: SCAT NOT DEFINED.')
         NSCT=(ISCAT+1)**2
         NPQ=(NLF+2)*NLF
         ALLOCATE(MRMX(NPQ),MRMY(NPQ),MRMZ(NPQ))
         ALLOCATE(DU(NPQ),DE(NPQ),DZ(NPQ),WW(NPQ),DC(LX*LY*NPQ),
     1   DB(LX*LZ*NPQ),DA(LY*LZ*NPQ),PL(NSCT*NPQ))
         CALL SNTT3D(IMPX,LX,LY,LZ,IELEM,NLF,NPQ,NSCT,IQUAD,NCODE,
     1   ZCODE,MAT,XXX,YYY,ZZZ,VOL,IDL,DU,DE,DZ,WW,MRMX,MRMY,MRMZ,
     3   DC,DB,DA,PL)  
*
         CALL LCMPUT(IPTRK,'DU',NPQ,2,DU)
         CALL LCMPUT(IPTRK,'DE',NPQ,2,DE)
         CALL LCMPUT(IPTRK,'DZ',NPQ,2,DZ)
         CALL LCMPUT(IPTRK,'W',NPQ,2,WW)
         CALL LCMPUT(IPTRK,'MRMX',NPQ,1,MRMX)
         CALL LCMPUT(IPTRK,'MRMY',NPQ,1,MRMY)
         CALL LCMPUT(IPTRK,'MRMZ',NPQ,1,MRMZ)
         CALL LCMPUT(IPTRK,'DC',LX*LY*NPQ,2,DC)
         CALL LCMPUT(IPTRK,'DB',LX*LZ*NPQ,2,DB)
         CALL LCMPUT(IPTRK,'DA',LY*LZ*NPQ,2,DA)   
         CALL LCMPUT(IPTRK,'PL',NSCT*NPQ,2,PL)
         DEALLOCATE(PL,DA,DB,DC,WW,DZ,DE,DU)
         DEALLOCATE(MRMZ,MRMY,MRMX)
         LL4=LX*LY*LZ*NSCT*IELEM*IELEM*IELEM
         NUN=LL4+(LX*(LY+LZ)+LY*LZ)*NPQ*IELEM*IELEM
      ELSE
         CALL XABORT('SNTRK: UNKNOWN GEOMETRY.')
      ENDIF
      DEALLOCATE(YYY,ZZZ)
      IF(IMPX.GT.0) WRITE (6,'(/33H SNTRK: ORDER OF LINEAR SYSTEMS =,
     1 I7/8X,37HNUMBER OF UNKNOWNS PER ENERGY GROUP =,I7)') LL4,NUN
*
      IF(IMPX.GT.5) THEN
         I1=1
         DO 200 I=1,(NEL-1)/8+1
         I2=I1+7
         IF(I2.GT.NEL) I2=NEL
         WRITE (6,620) (J,J=I1,I2)
         WRITE (6,630) (MAT(J),J=I1,I2)
         WRITE (6,640) (IDL(J),J=I1,I2)
         WRITE (6,650) (VOL(J),J=I1,I2)
  200    I1=I1+8
      ENDIF
*----
*  SYNTHETIC ACCELERATION TRACKING INFORMATION.
*----
        IF(LDSA) THEN
         IF(IMPX.GT.0) WRITE (6,'(/32H SNTRK: SYNTHETIC ACCELERATION I,
     1   19HNFORMATION FOLLOWS:)')
         CALL LCMSIX(IPTRK,'DSA',1)
         ICOL=3  ! Gauss-Legendre quadrature
         ISPLH=0 ! non-hexagonal geometry
         NLFSA=2 ! P1 method
         ISPN=1  ! simplified PN method
         ISCSA=1 ! isotropic scattering
         NVD=1   ! SN-type VOID boundary conditions
         NADI=2  ! ADI iteration
         IF(MAXPTS.EQ.0) CALL XABORT('SNTRK: MAXPTS NOT DEFINED.')
         IF(ITYPE.EQ.7) THEN
            ICHX=2 ! Raviart-Thomas finite elements
            ISEG=0 ! scalar algorithm
            IMPV=0 ! print parameter for vector operations
            CALL TRITRK(MAXPTS,IPTRK,IPGEOM,IMPX,IELEM,ICOL,ICHX,ISPLH,
     1      ISEG,IMPV,NLFSA,NVD,ISPN,ISCSA,NADI)
         ELSE
            CALL BIVTRK(MAXPTS,IPTRK,IPGEOM,IMPX,IELEM,ICOL,ISPLH,
     1      NLFSA,NVD,ISPN,ISCSA)
         ENDIF
         CALL LCMSIX(IPTRK,' ',2)
      ENDIF
*----
*  SAVE GENERAL AND SN-SPECIFIC TRACKING INFORMATION.
*----
      CALL XDISET(IGP,NSTATE,0)
      IGP(1)=NEL
      IGP(2)=NUN
      IF(ILK) THEN
         IGP(3)=0
      ELSE
         IGP(3)=1
      ENDIF
      IGP(4)=ISTATE(7)
      IGP(5)=1
      IGP(6)=ITYPE
      IGP(7)=0
      IGP(8)=IELEM
      IGP(9)=0
      IGP(10)=0
      IGP(11)=LL4
      IGP(12)=LX
      IGP(13)=LY
      IGP(14)=LZ
      IGP(15)=NLF
      IGP(16)=ISCAT
      IGP(17)=IQUAD
      IGP(18)=0
      IF(LFIXUP) IGP(18)=1
      IGP(19)=0
      IF(LDSA) IGP(19)=1
      IGP(20)=NSTART
      IGP(21)=NSDSA
      IGP(22)=MAXIT
      IF(LIVO) IGP(23)=1
      IGP(24)=ICL1
      IGP(25)=ICL2
      IF((ITYPE.EQ.3).OR.(ITYPE.GE.4)) IGP(30)=1
      IF(LBIHET) IGP(40)=1
      CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,IGP)
      CALL LCMPUT(IPTRK,'MATCOD',NEL,1,MAT)
      CALL LCMPUT(IPTRK,'VOLUME',NEL,2,VOL)
      CALL LCMPUT(IPTRK,'KEYFLX',NEL,1,IDL)
      CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE)
      CALL LCMPUT(IPTRK,'ZCODE',6,2,ZCODE)
      CALL LCMPUT(IPTRK,'EPSI',1,2,EPSI)
      IF(ITYPE.EQ.4) CALL LCMPUT(IPTRK,'XXX',LX+1,2,XXX)
      DEALLOCATE(XXX)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(IDL,VOL,MAT)
      RETURN
*
  600 FORMAT(/25H SNTRK: VALUES OF VECTOR ,A6,4H ARE/(1X,1P,20I6))
  620 FORMAT (///11H REGION    ,8(I8,6X,1HI))
  630 FORMAT (   11H MIXTURE   ,8(I8,6X,1HI))
  640 FORMAT (   11H POINTER   ,8(I8,6X,1HI))
  650 FORMAT (   11H VOLUME    ,8(1P,E13.6,2H I))
      END
