Initial commit from Polytechnique Montreal

1 files changed, 164 insertions, 0 deletions

diff --git a/Dragon/src/XELPR3.f b/Dragon/src/XELPR3.f
new file mode 100644
index 0000000..95f25f9
--- /dev/null
+++ b/Dragon/src/XELPR3.f
@@ -0,0 +1,164 @@
+*DECK XELPR3
+      SUBROUTINE XELPR3(IPTRK,IZ,NZP)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Create 2D projection (EXCELT geometry analysis) of a 3D prismatic
+* geometry.
+*
+*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): R. Le Tellier
+*
+*Parameters: input
+* IPTRK   pointer to the excell tracking (L_TRACK).
+* IZ      projection axis.
+*
+*Parameters: output
+* NZP     number of IZ-plans.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPTRK
+      INTEGER IZ,NZP
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER NSTATE,IOUT
+      PARAMETER(NSTATE=40,IOUT=6)
+      INTEGER GSTATE(NSTATE),ESTATE(NSTATE),ICODE(6),NCODE(6),KSIGN(3),
+     1 KTYPE(3),LCLSYM(3)
+      INTEGER IX,IY,NDIM,N3MS,N3MR,LDIM,LMESH,N3RS,I,N2MS,N2MR,
+     1 N2RS,N3R,N3S,NFI
+      REAL ALBEDO(6)
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: MINDIM,MAXDIM,ICORD,MATALB,
+     1 KEYMRG,INDEX,MIN2,MAX2,ICOR2,MAT2,KEY2,IND2,IND2T3,MATMRG
+      REAL, ALLOCATABLE, DIMENSION(:) :: REMESH,VOLSUR,REM2,VOL2,ZCOR,
+     1 VOLMRG
+*---
+      IF (IZ.EQ.3) THEN
+         IX=1
+         IY=2
+      ELSEIF (IZ.EQ.2) THEN
+         IX=3
+         IY=1
+      ELSEIF (IZ.EQ.1) THEN
+         IX=2
+         IY=3
+      ELSE
+         CALL XABORT('XELPR3: ILLEGAL PROJECTION AXIS')
+      ENDIF
+*---
+* RECOVER INFORMATION FROM EXCELL 3D GEOMETRY ANALYSIS
+*---
+      CALL LCMGET(IPTRK,'SIGNATURE',KSIGN)
+      CALL LCMGET(IPTRK,'TRACK-TYPE',KTYPE)
+      GSTATE(:NSTATE)=0
+      CALL LCMGET(IPTRK,'STATE-VECTOR',GSTATE)
+      CALL LCMGET(IPTRK,'ICODE',ICODE)
+      CALL LCMGET(IPTRK,'NCODE',NCODE)
+      CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE)     
+      CALL LCMGET(IPTRK,'ALBEDO',ALBEDO)
+      CALL LCMSIX(IPTRK,'EXCELL',1)
+      ESTATE(:NSTATE)=0
+      CALL LCMGET(IPTRK,'STATE-VECTOR',ESTATE)
+      NDIM=ESTATE(1)
+      IF (NDIM.NE.3) 
+     1   CALL XABORT('XELPR3: NON 3D GEOMETRY')
+      N3MS=ESTATE(2)
+      N3MR=ESTATE(3)
+      LDIM=ESTATE(4)
+      LMESH=ESTATE(5)
+      N3RS=ESTATE(6)
+      LCLSYM(1)=ESTATE(8)
+      LCLSYM(2)=ESTATE(9)
+      LCLSYM(3)=ESTATE(10)
+      ALLOCATE(MINDIM(LDIM),MAXDIM(LDIM),ICORD(LDIM),MATALB(N3RS),
+     1 KEYMRG(N3RS),INDEX(4*N3RS))
+      ALLOCATE(REMESH(LMESH),VOLSUR(N3RS))
+      CALL LCMGET(IPTRK,'MINDIM',MINDIM)
+      CALL LCMGET(IPTRK,'MAXDIM',MAXDIM)
+      CALL LCMGET(IPTRK,'ICORD',ICORD)
+      CALL LCMGET(IPTRK,'REMESH',REMESH)
+      CALL LCMGET(IPTRK,'VOLSUR',VOLSUR)
+      CALL LCMGET(IPTRK,'MATALB',MATALB)
+      CALL LCMGET(IPTRK,'KEYMRG',KEYMRG)
+      CALL LCMGET(IPTRK,'INDEX',INDEX)
+      CALL LCMSIX(IPTRK,' ',2)
+*--- 
+* CHECK FOR CYLINDER ORIENTATION
+*---
+      IF (LDIM.GT.3) THEN
+         DO I=3,LDIM-1
+            IF (ICORD(I+1).NE.IZ)
+     1         CALL XABORT('XELPR3: NON Z-PRISMATIC GEOMETRY')
+         ENDDO
+      ENDIF
+*---
+* CONSTRUCT 2D GEOMETRY ANALYSIS AND (2D,Z)->3D INDEX 
+*---
+      CALL LCMSIX(IPTRK,'PROJECTION',1)
+      CALL LCMPUT(IPTRK,'SIGNATURE',3,3,KSIGN)
+      CALL LCMPUT(IPTRK,'TRACK-TYPE',3,3,KTYPE)
+      NZP=MAXDIM(IZ)-MINDIM(IZ)
+      N2MR=N3MR/NZP
+      N2MS=(N3MS-2*N2MR)/NZP
+      N2RS=N2MR+N2MS+1
+      GSTATE(1)=N2MR
+      GSTATE(2)=N2MR
+      GSTATE(5)=N2MS
+      GSTATE(7)=1
+      GSTATE(8)=1
+      CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,GSTATE)
+      CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE)
+      CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE)
+      CALL LCMPUT(IPTRK,'ALBEDO',6,2,ALBEDO)
+      CALL LCMSIX(IPTRK,'EXCELL',1)
+      ALLOCATE(MIN2(LDIM),MAX2(LDIM),ICOR2(LDIM),MAT2(N2RS),KEY2(N2RS),
+     1 IND2(4*N2RS),IND2T3(N2RS*(NZP+2)),MATMRG(N3RS))
+      ALLOCATE(REM2(LMESH),VOL2(N2RS),ZCOR(NZP+1),VOLMRG(N3RS))
+      CALL XEL3T2(IX,IY,IZ,LDIM,N3MS,N3MR,N3RS,LMESH,NZP,N2MS,N2MR,
+     1     N3S,N3R,NFI,MINDIM,MAXDIM,REMESH,VOLSUR,MATALB,KEYMRG,
+     2     INDEX,MAX2,MIN2,ICOR2,REM2,VOL2,MAT2,KEY2,IND2,IND2T3,
+     3     MATMRG,VOLMRG,ZCOR)
+      ESTATE(1)=2
+      ESTATE(2)=N2MS
+      ESTATE(3)=N2MR
+      ESTATE(6)=N2RS
+      ESTATE(8)=LCLSYM(IX)
+      ESTATE(9)=LCLSYM(IY)
+      ESTATE(10)=LCLSYM(IZ)
+      CALL LCMPUT(IPTRK,'MINDIM',LDIM,1,MIN2)
+      CALL LCMPUT(IPTRK,'MAXDIM',LDIM,1,MAX2)
+      CALL LCMPUT(IPTRK,'ICORD',LDIM,1,ICOR2)
+      CALL LCMPUT(IPTRK,'INDEX',4*N2RS,1,IND2)
+      CALL LCMPUT(IPTRK,'REMESH',LMESH,2,REM2)
+      CALL LCMPUT(IPTRK,'KEYMRG',N2RS,1,KEY2)
+      CALL LCMPUT(IPTRK,'MATALB',N2RS,1,MAT2)
+      CALL LCMPUT(IPTRK,'VOLSUR',N2RS,2,VOL2)
+      CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ESTATE)
+      CALL LCMSIX(IPTRK,' ',2)
+      CALL LCMPUT(IPTRK,'MATALB',NFI,1,MATMRG)
+      CALL LCMPUT(IPTRK,'VOLSUR',NFI,2,VOLMRG)
+      CALL LCMPUT(IPTRK,'ZCOORD',NZP+1,2,ZCOR)
+      CALL LCMPUT(IPTRK,'IND2T3',N2RS*(NZP+2),1,IND2T3)
+      CALL LCMSIX(IPTRK,' ',2)
+      DEALLOCATE(VOLMRG,ZCOR,VOL2,REM2)
+      DEALLOCATE(MATMRG,IND2T3,IND2,KEY2,MAT2,ICOR2,MAX2,MIN2)
+*
+      DEALLOCATE(VOLSUR,REMESH)
+      DEALLOCATE(INDEX,KEYMRG,MATALB,ICORD,MAXDIM,MINDIM)
+*
+      RETURN
+      END