*DECK NXTPR3
      SUBROUTINE NXTPR3(IPTRK)
*
*-----------------------------------------------------------------------
*
*Purpose:
* To analyse a 3D prismatic geometry from a general 3D geometry analysis.
*
*Copyright:
* Copyright (C) 2006 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): R. Le Tellier
*
*Parameters: input
* IPTRK   pointer to the nxt tracking (L_TRACK).
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPTRK
*----
*  LOCAL VARIABLES
*----
      INTEGER NSTATE,IOUT
      PARAMETER(NSTATE=40,IOUT=6)
      INTEGER GSTATE(NSTATE),ESTATE(NSTATE),KSIGN(3),ICODE(6),NCODE(6),
     1 KTYPE(3)
      INTEGER IZ,IX,IY,NFREG,NFSUR,NDIM,IDIRG,NBOCEL,NBUCEL,IDIAG,
     1 ISAXIS(3),NOCELL(3),NUCELL(3),MAXMSH,MAXMDH,MAXREG,NBTCLS,
     2 MAXPIN,MAXMSP,MAXRSP,MXGSUR,MXGREG,NUNK,IDIR,JJ,NUCELZ,NZP,
     3 N2REG,N2SUR,N2CEL,N2PIN,I,K,NUNK2,NFSURO,ISUR,NUNKO,ITEMP,
     4 ILON,ITYLCM
      REAL RSTATT(NSTATE),ALBEDO(6)
      DOUBLE PRECISION DZ1,DZ2
      CHARACTER NAMASG*9,NAMREC*12
      LOGICAL HALFS(2),SSYM(2),INVER
      CHARACTER CDIR(4)*1
      DATA CDIR /'X','Y','Z','R'/
      TYPE(C_PTR) JPTRK
*----
*  Allocatable arrays
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,IUNFLD,MATALB2,
     1 IND2T3,KEYMRG,IND2T3F,MATALBF
      REAL, ALLOCATABLE, DIMENSION(:) :: SURVOL1,SURVOLF,ZCORF
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SURVOL,ZCOR,
     1 SURVOL2,SM
*----
* RECOVER STATE-VECTOR
*----
      CALL XDISET(GSTATE,NSTATE,0)
      CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE)
      NFREG=GSTATE(1)
      NFSUR=GSTATE(5)
      IZ=GSTATE(39)
*---
      IF (IZ.EQ.3) THEN
         IX=1
         IY=2
      ELSEIF (IZ.EQ.2) THEN
         IX=3
         IY=1
         CALL XABORT('NXTPR3: ONLY PRIZ IMPLEMENTED WITH NXT.')
      ELSEIF (IZ.EQ.1) THEN
         IX=2
         IY=3
         CALL XABORT('NXTPR3: ONLY PRIZ IMPLEMENTED WITH NXT.')
      ELSE
         CALL XABORT('NXTPR3: ILLEGAL PROJECTION AXIS')
      ENDIF
*----
* RECOVER INFORMATION FROM NXT 3D GEOMETRY ANALYSIS
*----
      CALL LCMGET(IPTRK,'EXCELTRACKOP',RSTATT)
      CALL LCMGET(IPTRK,'SIGNATURE',KSIGN)
      CALL LCMGET(IPTRK,'TRACK-TYPE',KTYPE)
      CALL LCMGET(IPTRK,'ICODE',ICODE)
      CALL LCMGET(IPTRK,'NCODE',NCODE)
      CALL LCMGET(IPTRK,'ALBEDO',ALBEDO)
      JPTRK=LCMDID(IPTRK,'PROJECTION')
      CALL LCMSIX(JPTRK,'NXTRecords',1)
      CALL LCMSIX(IPTRK,'NXTRecords',1)
      WRITE(NAMASG,'(A1,I8.8)') 'G',1
      NAMREC=NAMASG//'DIM'
      CALL XDISET(ESTATE,NSTATE,0)
      CALL LCMGET(IPTRK,NAMREC,ESTATE)
      NDIM     =ESTATE( 1)
      IF (NDIM.NE.3) 
     1 CALL XABORT('NXTPR3: NON 3D GEOMETRY')
      IDIRG    =ESTATE( 3)
      NBOCEL   =ESTATE( 4)
      NBUCEL   =ESTATE( 5)
      IDIAG    =ESTATE( 6)
      ISAXIS(1)=ESTATE( 7)
      ISAXIS(2)=ESTATE( 8)
      ISAXIS(3)=ESTATE( 9)
      IF (ISAXIS(IZ).NE.0)
     1 CALL XABORT('NXTPR3: Z+- SYMMETRIES NOT YET TREATED')
      NOCELL(1)=ESTATE(10)
      NOCELL(2)=ESTATE(11)
      NOCELL(3)=ESTATE(12)
      NUCELL(1)=ESTATE(13)
      NUCELL(2)=ESTATE(14)
      NUCELL(3)=ESTATE(15)
      MAXMSH   =ESTATE(16)
      MAXREG   =ESTATE(17)
      NBTCLS   =ESTATE(18)
      MAXPIN   =ESTATE(19)
      MAXMSP   =ESTATE(20)
      MAXRSP   =ESTATE(21)
      IF (NFSUR.NE.ESTATE(22))
     1 CALL XABORT('NXTPR3: INCONSISTENT NUMBER OF OUTER SURFACES')
      IF (NFREG.NE.ESTATE(23))
     1 CALL XABORT('NXTPR3: INCONSISTENT NUMBER OF REGIONS')
      MXGSUR   =ESTATE(24)
      MXGREG   =ESTATE(25)
      NUNK=NFSUR+NFREG+1
      MAXMDH=MAX(MAXMSH,MAXMSP,MAXREG)
*     surface-volumes and mixture indexes
      ALLOCATE(MATALB(NUNK),SURVOL(NUNK),SURVOL1(NUNK))
      CALL LCMGET(IPTRK,'MATALB      ',MATALB)
      CALL LCMGET(IPTRK,'SAreaRvolume',SURVOL)
      CALL XDRSDB(NUNK,SURVOL1,SURVOL,1)
*     cell index and orientation for the cells filling the geometry
      ALLOCATE(IUNFLD(2*2*NBUCEL))
      NAMREC=NAMASG//'CUF'
      CALL LCMGET(IPTRK,NAMREC,IUNFLD)
      NUCELZ=NUCELL(IZ)
      ALLOCATE(IND2T3(NUNK*(MAXMDH*NUCELZ+2)),ZCOR(MAXMDH*NUCELZ+2),
     1 MATALB2(NUNK),SURVOL2(NUNK))
*----
* CONSTRUCT 2D GEOMETRY ANALYSIS
*----
*     CONSTRUCT (2D,Z)->3D INDEX AND FILL IN LEVEL 1-2 DESCRIPTION
      CALL NXT3T2(IPTRK,JPTRK,IX,IY,IZ,NFREG,NFSUR,NUNK,MAXMDH,
     1     NUCELL,NBUCEL,MXGSUR,MXGREG,MAXPIN,MATALB,SURVOL,IUNFLD,
     2     NZP,N2REG,N2SUR,N2CEL,N2PIN,IND2T3,ZCOR,MATALB2,SURVOL2)
*     NXT LEVEL 0 DESCRIPTION
*     record DIM
      ESTATE(1)=2
      ESTATE(4)=ESTATE(4)/NUCELL(3)
      ESTATE(5)=ESTATE(5)/NUCELL(3)
      ESTATE(9)=0
      ESTATE(12)=0
      ESTATE(13)=NUCELL(IX)
      ESTATE(14)=NUCELL(IY)
      ESTATE(15)=0
      ESTATE(16)=N2CEL
      ESTATE(22)=N2SUR
      ESTATE(23)=N2REG
      NAMREC=NAMASG//'DIM'
      CALL LCMPUT(JPTRK,NAMREC,NSTATE,1,ESTATE)
*     record CUF
      NAMREC=NAMASG//'CUF'
      CALL LCMPUT(JPTRK,NAMREC,2*ESTATE(5),1,IUNFLD(2*NBUCEL+1))
*     record SMX,SMY
      ALLOCATE(SM(NUCELL(IX)+1))
        NAMREC=NAMASG//'SM'//CDIR(IX)
        CALL LCMGET(IPTRK,NAMREC,SM)
        NAMREC=NAMASG//'SM'//CDIR(1)
        CALL LCMPUT(JPTRK,NAMREC,(NUCELL(IX)+1),4,SM)
      DEALLOCATE(SM)
      ALLOCATE(SM(NUCELL(IY)+1))
        NAMREC=NAMASG//'SM'//CDIR(IY)
        CALL LCMGET(IPTRK,NAMREC,SM)
        NAMREC=NAMASG//'SM'//CDIR(2)
        CALL LCMPUT(JPTRK,NAMREC,(NUCELL(IY)+1),4,SM)
      DEALLOCATE(SM)
*---
*  ADDITIONAL RECORDS TO MODIFY/ADD IN /PROJECTION/
*---
*     KEYMRG ARRAY
      CALL LCMLEN(IPTRK,'KEYMRG      ',ILON,ITYLCM)
      ALLOCATE(KEYMRG(ILON))
        CALL LCMGET(IPTRK,'KEYMRG      ',KEYMRG)
        CALL LCMPUT(JPTRK,'KEYMRG      ',N2SUR+N2REG+1,1,
     1       KEYMRG(NFSUR-N2SUR+1))
      DEALLOCATE(KEYMRG)
*     NXT SPECIFIC STATE-VECTOR
      CALL LCMSIX(JPTRK,' ',2)
      GSTATE(1)=N2REG
      GSTATE(2)=N2REG
      GSTATE(5)=N2SUR
      GSTATE(8)=1
      GSTATE(9)=0
      GSTATE(10)=0
      GSTATE(13)=1
      CALL LCMPUT(JPTRK,'STATE-VECTOR',NSTATE,1,GSTATE)
      CALL LCMPUT(JPTRK,'EXCELTRACKOP',NSTATE,2,RSTATT)  
      CALL LCMPUT(JPTRK,'SIGNATURE   ',3,3,KSIGN)
      CALL LCMPUT(JPTRK,'TRACK-TYPE  ',3,3,KTYPE)
      CALL LCMPUT(JPTRK,'ICODE       ',6,1,ICODE)
      CALL LCMPUT(JPTRK,'ALBEDO      ',6,2,ALBEDO)
*---
*  TAKE CARE OF SYMMETRIES ALONG THE PROJECTION AXIS 
*  UPDATE RECORDS ACCORDINGLY
*---
*     MAIN STATE-VECTOR: store the number of z-plan in the prismatic geometry
      CALL LCMSIX(IPTRK,' ',2)
      CALL XDISET(GSTATE,NSTATE,0)
      CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE)
      GSTATE(39)=NZP
*     NCODE ARRAY
      DO JJ=1,2
         HALFS(JJ)=(NCODE(2*(IZ-1)+JJ).EQ.5)
         SSYM(JJ)=((NCODE(2*(IZ-1)+JJ).EQ.10).OR.(HALFS(JJ)))
      ENDDO
      INVER=(SSYM(1).AND.(.NOT.SSYM(2)))
      IF (SSYM(1).OR.SSYM(2)) NCODE(2*IZ)=30
      IF (SSYM(1).AND.SSYM(2)) NCODE(2*IZ-1)=30
      IF (HALFS(1).OR.HALFS(2)) 
     1 CALL XABORT('NXTPR3: SYME NOT SUPPORTED IN PRISMATIC, USE SSYM.')
      CALL LCMPUT(IPTRK,'NCODE       ',6,1,NCODE)
*
      IF (SSYM(1)) CALL XDISET(IND2T3(NFSUR+2),N2REG,0)
      IF (SSYM(2)) CALL XDISET(IND2T3((NZP+1)*NUNK+NFSUR+2),N2REG,0)
      NFSURO=NFSUR
      NUNKO=NUNK
      IF (SSYM(1)) NFSUR=NFSUR-N2REG
      IF (SSYM(2)) NFSUR=NFSUR-N2REG
      NUNK=NFSUR+NFREG+1
*
      NUNK2=N2SUR+N2REG+1
      ALLOCATE(IND2T3F(NUNK2*(NZP+2)),SURVOLF(NUNK),MATALBF(NUNK))
      DO JJ=0,NFREG
         SURVOLF(NFSUR+JJ+1)=SURVOL1(NFSURO+JJ+1)
         MATALBF(NFSUR+JJ+1)=MATALB(NFSURO+JJ+1)
      ENDDO
      JJ=-1
      ISUR=0
      DO 15 K=0,NZP+1
      DO 10 I=0,NUNK2-1
         JJ=JJ+1
         IDIR=IND2T3(K*NUNKO+I+NFSURO-N2SUR+1)
         IF (IDIR.LT.0) THEN
            ISUR=ISUR+1
            IND2T3F(JJ+1)=-ISUR
            SURVOLF(NFSUR-ISUR+1)=0.25*SURVOL1(NFSURO+IDIR+1)
            MATALBF(NFSUR-ISUR+1)=MATALB(NFSURO+IDIR+1)
         ELSE
            IND2T3F(JJ+1)=IDIR
         ENDIF
 10   CONTINUE
 15   CONTINUE
      IF (ISUR.NE.NFSUR) THEN
         write(*,*) ISUR,NFSUR,NFSURO,N2REG
         CALL XABORT('NXTPR3: NFSUR OVERFLOW.')
      ENDIF   
      GSTATE(5)=NFSUR
      ALLOCATE(ZCORF(NZP+1))
      IF (INVER) THEN
         DO K=0,(NZP+1)/2
            DO I=0,NUNK2-1
               ITEMP=IND2T3F(K*NUNK2+I+1)
               IND2T3F(K*NUNK2+I+1)=IND2T3F((NZP+1-K)*NUNK2+I+1)
               IND2T3F((NZP+1-K)*NUNK2+I+1)=ITEMP
            ENDDO
         ENDDO
         ZCORF=0.0
         DO K=1,NZP
            DZ1=ZCOR(NZP-K+1)
            DZ2=ZCOR(NZP-K+2)
            ZCORF(K+1)=ZCORF(K)+REAL(DZ2-DZ1)
         ENDDO
      ELSE
         CALL XDRSDB(NZP+1,ZCORF,ZCOR,1)
      ENDIF
      CALL LCMPUT(JPTRK,'MATALB      ',NUNK,1,MATALBF)
      CALL LCMPUT(JPTRK,'VOLSUR      ',NUNK,2,SURVOLF)
      CALL LCMPUT(JPTRK,'IND2T3      ',NUNK2*(NZP+2),1,IND2T3F)  
      CALL LCMPUT(JPTRK,'ZCOORD      ',(NZP+1),2,ZCORF)   
      CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,GSTATE)
      DEALLOCATE(ZCORF,MATALBF,SURVOLF,IND2T3F)
*----
*  DEALLOCATE MEMORY
*----
      DEALLOCATE(SURVOL2,MATALB2,ZCOR,IND2T3,IUNFLD,SURVOL1,SURVOL,
     1 MATALB)
*
      RETURN
      END
