Initial commit from Polytechnique Montreal

1 files changed, 203 insertions, 0 deletions

diff --git a/Dragon/src/AXGXEL.f b/Dragon/src/AXGXEL.f
new file mode 100644
index 0000000..c1a5a67
--- /dev/null
+++ b/Dragon/src/AXGXEL.f
@@ -0,0 +1,203 @@
+*DECK AXGXEL
+      SUBROUTINE AXGXEL(IPGEOM,IPTRKM,IPRINT,GEONAM)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Analyze XEL geometry for original Excell tracking with XELTRK module.
+*
+*Copyright:
+* Copyright (C) 2002 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): G. Marleau
+*
+*Parameters: input
+* IPGEOM  geometry data structure pointer.
+* IPTRKM  tracking data structure pointer.         
+* IPRINT  print level.                              
+* GEONAM  geometry name.
+*
+*-----------------------------------------------------------------------
+*
+      USE          GANLIB
+      IMPLICIT     NONE
+      INTEGER      IOUT,NALB,MREGIO,MXDIM,NSTATE
+      CHARACTER    NAMSBR*6
+      PARAMETER   (IOUT=6,NALB=6,MREGIO=100000,MXDIM=3,NSTATE=40,
+     >             NAMSBR='AXGXEL')
+*----
+*  ROUTINE PARAMETERS
+*----
+      TYPE(C_PTR)  IPGEOM
+      TYPE(C_PTR)  IPTRKM
+      INTEGER      IPRINT
+      CHARACTER*12 GEONAM
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER      NCODE(NALB),ICODE(NALB)
+      REAL         ALBEDO(NALB)
+      INTEGER      MAXGRI(MXDIM),LCLSYM(MXDIM),LCLTRA(MXDIM),
+     >             MRGSUR(-NALB:-1)
+      INTEGER      ISTATE(NSTATE)
+      LOGICAL      LEAKSW,LL1,LL2,L1CELL
+      INTEGER      NDIM,NTYPO,NBLOCK,NBMIX,NEXTGE,IFCSYM
+      INTEGER      NTOTCO,MAXRO,NGEOME,NGIDL,NTIDL,NUNKO
+      INTEGER      NTYP,NTOTCL,MAXR
+      INTEGER      NSUR,NSURC,NVOL,NVOLC,NUNK,NSBC
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: MRGCEL, NSURO, NVOLO,IDLGEO,
+     >   IDLDIM,KEYGEO,IDLTYP,KEYTYP,IDLBLK,KCELLG,KEYTRN,IDLREM, MINDO,
+     >    MAXDO,ICORDO,MATGEO,INDEXO,MATTYP,KEYINT,KEYCYL,KEYMRG,MATALB,
+     >   MINDIM,MAXDIM, ICORD,INCELL, MATRT, INDEX
+      REAL, ALLOCATABLE, DIMENSION(:) :: REMSHO,VOLSRO,VOLSUR,REMESH
+*----
+*  GET DIMENSIONING INFORMATION
+*----
+      CALL XELPRP( IPGEOM,  GEONAM,  NDIM, NTYPO , NBLOCK,  NBMIX,
+     >             MAXGRI,  ALBEDO, ICODE,  NCODE, LCLSYM, LCLTRA,
+     >             MRGSUR,  LEAKSW,   LL1,    LL2, L1CELL, NEXTGE,
+     >             IFCSYM,  IPRINT)
+*----
+*  ALLOCATE MEMORY - 1
+*----
+      ALLOCATE(MRGCEL(NBLOCK),NSURO(NBLOCK),NVOLO(NBLOCK),
+     > IDLGEO(NBLOCK),IDLDIM(NBLOCK),KEYGEO(NBLOCK),IDLTYP(NBLOCK),
+     > KEYTYP(NBLOCK),IDLBLK(NBLOCK),KCELLG(3*NBLOCK),KEYTRN(NBLOCK))
+*----
+*  READ GEOMETRY BLOCK DESCRIPTION
+*----
+      CALL XELDCL(IPGEOM,GEONAM,NDIM  ,MAXGRI,LCLSYM,NBLOCK,NTYPO ,
+     >            LL1   ,LL2   ,IPRINT,NTOTCO,MAXRO ,NGEOME,NTYP  ,
+     >            NGIDL ,NTIDL ,NUNKO ,KCELLG,NSURO ,NVOLO ,IDLDIM,
+     >            IDLGEO,KEYTRN,KEYGEO,IDLTYP,KEYTYP,MRGCEL,IDLBLK)
+*----
+*  ALLOCATE MEMORY - 2
+*----
+      ALLOCATE(IDLREM(NGEOME),MINDO(NTOTCO),MAXDO(NTOTCO),
+     > ICORDO(NTOTCO),MATGEO(NGIDL),INDEXO(4*NGIDL))
+      ALLOCATE(REMSHO(MAXRO),VOLSRO(NGIDL))
+*----
+*  PRODUCE REGION NUMBERING AND VOLUME EVALUATION
+*----
+      CALL XELTRP(IPGEOM,NGIDL ,NDIM  ,NGEOME,L1CELL,NTOTCO,NEXTGE,
+     >            MAXRO ,IPRINT,KCELLG,NSURO ,NVOLO ,IDLDIM,IDLGEO,
+     >            KEYTRN,MAXDO ,MINDO ,ICORDO,REMSHO,IDLREM,INDEXO,
+     >            VOLSRO,MATGEO)
+*----
+*  RELEASE SOME MEMORY
+*----
+      DEALLOCATE(KEYTRN)
+*----
+*  ALLOCATE MEMORY - 3
+*----
+      ALLOCATE(MATTYP(NTIDL),KEYINT(NUNKO))
+*----
+*     INTERFACE ALL CELLS IN THE GEOMETRY
+*----
+      CALL XELBIN(IPGEOM,NDIM  ,NGEOME,L1CELL,  NTYP, NGIDL,NTIDL ,
+     >            NBLOCK,MAXGRI,NUNKO ,IPRINT,KCELLG, NSURO,NVOLO ,
+     >            IDLGEO,MATGEO,KEYGEO,IDLTYP,IDLBLK,KEYTYP,MATTYP,
+     >            KEYINT)
+*----
+*  ALLOCATE MEMORY - 4
+*----
+      ALLOCATE(KEYCYL(NBLOCK))
+*----
+*  COMPUTE ALLOCATION IN EXACT GEOMETRY.
+*----
+      CALL XELEDC(NDIM  ,MAXGRI,NGEOME,NTOTCO,NTYP  ,NBLOCK,NUNKO ,
+     >            NSURO ,NVOLO ,MINDO ,MAXDO ,ICORDO,IDLDIM,KEYGEO,
+     >            KEYTYP,IDLBLK,KEYINT,NTOTCL,MAXR  ,NSUR  ,NVOL  ,
+     >            KEYCYL)
+      NUNK= NVOL + 1 - NSUR
+*----
+*  ALLOCATE MEMORY - 5
+*----
+      ALLOCATE(KEYMRG(NUNK),MATALB(NUNK),MINDIM(NTOTCL),MAXDIM(NTOTCL),
+     > ICORD(NTOTCL),INDEX(4*NUNK),INCELL(NUNK))
+      ALLOCATE(VOLSUR(NUNK),REMESH(MAXR))
+*----
+*  TO RECONSTRUCT THE MESH IN EXACT GEOMETRY.
+*----
+      CALL XELETR(IPRINT,NDIM  ,MAXGRI,NGEOME,NTOTCO,NTYP  ,NTIDL ,
+     >            NBLOCK,NSUR  ,NVOL  ,NTOTCL,NUNKO ,NSURO ,NVOLO ,
+     >            MINDO, MAXDO ,ICORDO,IDLDIM,IDLGEO,KEYGEO,IDLTYP,
+     >            KEYTYP,IDLBLK,KEYCYL,REMSHO,IDLREM,INDEXO,VOLSRO,
+     >            MATGEO,KEYINT,MATTYP,REMESH,MINDIM,MAXDIM,ICORD ,
+     >            VOLSUR,KEYMRG,INDEX ,INCELL,MATALB,NSURC ,NVOLC )
+      NSUR=NSURC
+      NVOL=NVOLC
+      NUNK= NVOL + 1 - NSUR
+      DEALLOCATE(KEYCYL,KEYINT,MATTYP,INDEXO,MATGEO,ICORDO,MAXDO,MINDO,
+     > IDLBLK,KEYTYP,IDLTYP,KEYGEO,IDLDIM,IDLREM,KCELLG,IDLGEO,NVOLO,
+     > NSURO)
+      DEALLOCATE(VOLSRO,REMSHO)
+*----
+*  ALLOCATE MEMORY - 6
+*----
+      ALLOCATE(MATRT(-NSUR*2))
+*----
+*  PREPARE MERGING OF ZONES AND SURFACES USING BOUNDARY CONDITIONS.
+*  SET UP REFLECTION-TRANSMISSION MATRIX
+*----
+      CALL XELMRG(IPRINT,NSUR  ,NVOL  ,NSBC  ,NTOTCL,INDEX ,MINDIM,
+     >            MAXDIM,LCLSYM,LCLTRA,LL1   ,LL2   ,MRGCEL,MATALB,
+     >            KEYMRG,INCELL,MATRT )
+*----
+*  SAVE EXCELL TRACKING FOR CARTESIAN GEOMETRY
+*----
+      CALL LCMSIX(IPTRKM,'EXCELL      ',1)
+      ISTATE(:NSTATE)=0
+      ISTATE(1)=NDIM
+      ISTATE(2)=-NSUR
+      ISTATE(3)=NVOL
+      ISTATE(4)=NTOTCL
+      ISTATE(5)=MAXR
+      ISTATE(6)=NUNK
+      ISTATE(7)=NEXTGE
+      ISTATE(8)=LCLSYM(1)
+      ISTATE(9)=LCLSYM(2)
+      IF(NDIM .EQ. 3) ISTATE(10)=LCLSYM(3)
+*----
+*  LL1 is for diagonal symmetry
+*  with region Pi/4 to Pi/2 defined in x-y plane
+*  LL2 is for diagonal symmetry
+*  with region 0 to Pi/4 defined in x-y plane
+*----
+      IF(LL1) THEN
+        ISTATE(11)=-1
+      ELSE IF(LL2) THEN
+        ISTATE(11)=1
+      ENDIF
+      CALL LCMPUT(IPTRKM,'MINDIM      ',NTOTCL,1,MINDIM)
+      CALL LCMPUT(IPTRKM,'MAXDIM      ',NTOTCL,1,MAXDIM)
+      CALL LCMPUT(IPTRKM,'ICORD       ',NTOTCL,1,ICORD )
+      CALL LCMPUT(IPTRKM,'INDEX       ',4*NUNK,1,INDEX )
+      CALL LCMPUT(IPTRKM,'REMESH      ',MAXR  ,2,REMESH)
+      CALL LCMPUT(IPTRKM,'KEYMRG      ',NUNK  ,1,KEYMRG)
+      CALL LCMPUT(IPTRKM,'MATALB      ',NUNK  ,1,MATALB)
+      CALL LCMPUT(IPTRKM,'VOLSUR      ',NUNK  ,2,VOLSUR)
+      CALL LCMPUT(IPTRKM,'STATE-VECTOR',NSTATE,1,ISTATE)
+      CALL LCMSIX(IPTRKM,'EXCELL      ',2)
+*----
+*  SAVE REFLECTION-TRANSMISSION MATRIX
+*----
+      CALL LCMPUT(IPTRKM,'BC-REFL+TRAN',NSBC,1,MATRT)
+      CALL LCMPUT(IPTRKM,'ALBEDO      ',6     ,2,ALBEDO       )
+      CALL LCMPUT(IPTRKM,'ICODE       ',6     ,1,ICODE        )
+      CALL LCMPUT(IPTRKM,'NCODE       ',6     ,1,NCODE        )
+      DEALLOCATE(MATRT)
+*----
+*  RELEASE REMAINING MEMORY
+*----
+      DEALLOCATE(INCELL,INDEX,ICORD,MAXDIM,MINDIM,MATALB,KEYMRG,MRGCEL)
+      DEALLOCATE(REMESH,VOLSUR)
+      RETURN
+      END