Initial commit from Polytechnique Montreal

1 files changed, 233 insertions, 0 deletions

diff --git a/Dragon/src/XELPRC.f b/Dragon/src/XELPRC.f
new file mode 100644
index 0000000..0fc52bf
--- /dev/null
+++ b/Dragon/src/XELPRC.f
@@ -0,0 +1,233 @@
+*DECK XELPRC
+      SUBROUTINE XELPRC (IPGEOM,GEONAM,NDIM,NNCYL,NNSUR,NNVOL,NAXREM)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Reads a cell geometry and check if acceptable for EXCELL.
+*
+*Copyright:
+* Copyright (C) 1989 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. Roy
+*
+*Parameters: input
+* IPGEOM  pointer to the geometry (L_GEOM).            
+* GEONAM  geometry name.                                
+* NDIM    number of dimensions (2 or 3).                    
+*
+*Parameters: output
+* NNCYL   number of cylinders in the geometry.               
+* NNSUR   number of surfaces.                                
+* NNVOL   number of volumes.                                 
+* NAXREM  max number of coordinates to specify that cell.    
+*
+*-----------------------------------------------------------------------
+*
+      USE          GANLIB
+      IMPLICIT     NONE
+*
+*     DECLARE      DUMMY ARGUMENTS
+      TYPE(C_PTR)  IPGEOM 
+      INTEGER      NDIM, NNCYL, NNSUR, NNVOL, NAXREM
+      CHARACTER*12 GEONAM
+*
+*     DECLARE      LOCAL VARIABLES
+      INTEGER      NLCM, NIXS, NIST, NSTATE, MAXSPL
+      PARAMETER  ( NLCM=26, NIXS=11, NIST=2, NSTATE=40, MAXSPL=100 )
+      CHARACTER*12 LCMNM(NLCM)
+      INTEGER      LNLCM(NLCM),INVLCM(NIXS),INVSTA(NIST),
+     >             ISTATE(NSTATE),ISPLT(MAXSPL)
+      INTEGER      ILCM, IIXS, IIST, ITYPE, LR, LX, LY, LZ, ISPLIT,
+     >             JX, JY, JZ, JR, JL, ILEN, ITYLCM
+*
+      DATA INVLCM/  6, 11, 12, 14,        16, 17, 18, 19,
+     >             20, 21, 22 /
+      DATA INVSTA/ 8, 12 /
+      DATA LCMNM /  'MIX',  'MESHX',  'MESHY',   'MESHZ',  'RADIUS',
+     >             'SIDE', 'SPLITX', 'SPLITY',  'SPLITZ',  'SPLITR',
+     >             'CELL',  'COORD',  'MERGE',    'TURN', 'CLUSTER',
+     >             'NPIN',   'RPIN',   'APIN',   'BIHET',  'POURCE',
+     >           'PROCEL',   'IHEX',  'NCODE',   'ZCODE',   'ICODE',
+     >           'CENTER'/
+*
+      DO 10 ILCM= 1, NLCM
+         CALL LCMLEN(IPGEOM,LCMNM(ILCM),LNLCM(ILCM),ITYLCM)
+   10 CONTINUE
+*
+*     ELIMINATES THE INVALID OPTIONS
+      DO 20 IIXS= 1, NIXS
+        IF( LNLCM(INVLCM(IIXS)).NE.0 )
+     >     CALL XABORT( 'XELPRC:*'//GEONAM//'* IS '//
+     >                  'NOT A VALID CELL GEOMETRY FOR EXCELL'//
+     >                  ' (LCM BLOCK *'//LCMNM(INVLCM(IIXS))//'*)')
+   20 CONTINUE
+      CALL LCMLEN(IPGEOM,'STATE-VECTOR',ILEN,ITYLCM)
+      IF(ILEN .LT. 1 .OR. ILEN .GT. NSTATE )
+     >   CALL XABORT( 'XELPRC: GEOMETRY HAS INVALID STATE VECTOR')
+      CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE)
+      DO 30 IIST= 1, NIST
+        IF( ISTATE(INVSTA(IIST)).NE.0 )
+     >     CALL XABORT( 'XELPRC: INVALID GEOMETRY FOR EXCELL')
+   30 CONTINUE
+*
+      ITYPE=  ISTATE(1)
+      LR=     ISTATE(2)
+      LX=     MAX(1,ISTATE(3))
+      LY=     MAX(1,ISTATE(4))
+      LZ=     MAX(1,ISTATE(5))
+      NNVOL=  ISTATE(6)
+      ISPLIT= ISTATE(11)
+*
+*     GET THE SPLITTING INFORMATION, AND COMPUTE JR, JX, JY, JZ VALUES
+      IF( ISPLIT.GT.0 )THEN
+         JR= 0
+         JX= 0
+         JY= 0
+         JZ= 0
+         CALL LCMLEN(IPGEOM,'SPLITR',ILEN,ITYLCM)
+         IF( ILEN.GT.MAXSPL )THEN
+            CALL XABORT('XELPRC: SPLITR OVERFLOW')
+         ELSEIF( ILEN.EQ.0 )THEN
+            JR= LR
+         ELSEIF( ILEN.NE.LR )THEN
+            CALL XABORT( 'XELPRC: R-SPLITTING NOT ACCEPTED' )
+         ELSE
+            CALL LCMGET(IPGEOM,'SPLITR',ISPLT)
+            JR=   0
+            DO 15 JL= 1, ILEN
+               JR= JR + ABS(ISPLT(JL))
+   15       CONTINUE
+         ENDIF
+         CALL LCMLEN(IPGEOM,'SPLITX',ILEN,ITYLCM)
+         IF( ILEN.GT.MAXSPL )THEN
+            CALL XABORT('XELPRC: SPLITX OVERFLOW')
+         ELSEIF( ILEN.EQ.0 )THEN
+            JX= LX
+         ELSEIF( ILEN.NE.LX )THEN
+            CALL XABORT( 'XELPRC: X-SPLITTING NOT ACCEPTED' )
+         ELSE
+            CALL LCMGET(IPGEOM,'SPLITX',ISPLT)
+            JX=   0
+            DO 25 JL= 1, ILEN
+               JX= JX + ISPLT(JL)
+   25       CONTINUE
+         ENDIF
+         CALL LCMLEN(IPGEOM,'SPLITY',ILEN,ITYLCM)
+         IF( ILEN.GT.MAXSPL )THEN
+            CALL XABORT('XELPRC: SPLITY OVERFLOW')
+         ELSEIF( ILEN.EQ.0 )THEN
+            JY= LY
+         ELSEIF( ILEN.NE.LY )THEN
+            CALL XABORT( 'XELPRC: Y-SPLITTING NOT ACCEPTED' )
+         ELSE
+            CALL LCMGET(IPGEOM,'SPLITY',ISPLT)
+            JY=   0
+            DO 35 JL= 1, ILEN
+               JY= JY + ISPLT(JL)
+   35       CONTINUE
+         ENDIF
+         CALL LCMLEN(IPGEOM,'SPLITZ',ILEN,ITYLCM)
+         IF(ILEN.GT.MAXSPL) CALL XABORT('XELPRC: SPLITZ OVERFLOW')
+         IF( ILEN.EQ.0 )THEN
+            JZ= LZ
+         ELSEIF( ILEN.NE.LZ )THEN
+            CALL XABORT( 'XELPRC: Z-SPLITTING NOT ACCEPTED' )
+         ELSE
+            JZ= 0
+            CALL LCMGET(IPGEOM,'SPLITZ',ISPLT)
+            DO 45 JL= 1, ILEN
+               JZ= JZ + ISPLT(JL)
+   45       CONTINUE
+         ENDIF
+      ELSE
+         JR= LR
+         JX= LX
+         JY= LY
+         JZ= LZ
+      ENDIF
+*
+      IF( ITYPE.EQ.0 )THEN
+*
+*        VIRTUAL ELEMENT
+         NNVOL= 0
+         NNCYL= 0
+         NNSUR= 0
+         NAXREM= 0
+      ELSE
+         IF( NDIM.EQ.2 )THEN
+            NNSUR= 2 * (JX+JY)
+            NNVOL=  JX*JY
+            IF( ITYPE.EQ.5 )THEN
+*              FOR *CAR2D* GEOMETRY
+*
+               NNCYL=  0
+*
+*              X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:2
+               NAXREM= JX+JY+4
+            ELSEIF( ITYPE.EQ.3 )THEN
+*              FOR *TUBE* GEOMETRY
+*
+               NNCYL=  1
+               IF( JX.NE.1 .OR. JY.NE.1 )THEN
+                  CALL XABORT( 'XELPRC: FOR TUBE, PLEASE NO XY SPLIT')
+               ENDIF
+               NNVOL=  NNVOL+JX*JY*JR
+*
+*              X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:2, R-AXIS:JR+3
+               NAXREM= JX+JY+JR+7
+            ELSEIF( ITYPE.EQ.20 )THEN
+*              FOR *CARCEL* GEOMETRY
+*
+               NNCYL=  1
+               NNVOL=  NNVOL+JX*JY*JR
+*
+*              X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:2, R-AXIS:JR+3
+               NAXREM= JX+JY+JR+7
+            ELSE
+               CALL XABORT('XELPRC: INVALID CELL GEOMETRY FOR EXCELL=>'
+     >                     //GEONAM(1:12) )
+            ENDIF
+         ELSE
+            NNSUR=  2 * (JX*JY+JX*JZ+JY*JZ )
+            NNVOL=  JX*JY*JZ
+            IF( ITYPE.EQ.7 )THEN
+*              FOR *CAR3D* GEOMETRY
+*
+               NNCYL=  0
+*
+*              X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:JZ+1
+               NAXREM= JX+JY+JZ+3
+            ELSEIF( ITYPE.EQ. 6 .OR. ITYPE.EQ.21 .OR.
+     >              ITYPE.EQ.22 .OR. ITYPE.EQ.23 )THEN
+*              FOR *TUBEZ*, *CARCELX*, *CARCELY* OR *CARCELZ* GEOMETRY
+*
+              NNCYL= 1
+              IF( ITYPE.EQ.6 )THEN
+                 IF( JX.NE.1 .OR. JY.NE.1 ) THEN
+                    CALL XABORT('XELPRC: FOR TUBEZ, PLEASE NO XY SPLIT')
+                 ENDIF
+              ELSEIF( ITYPE.EQ.23 )THEN
+                 NNSUR= NNSUR+2*JR*JX*JY
+              ELSEIF( ITYPE.EQ.22 )THEN
+                 NNSUR= NNSUR+2*JR*JX*JZ
+              ELSEIF( ITYPE.EQ.21 )THEN
+                 NNSUR= NNSUR+2*JR*JY*JZ
+              ENDIF
+              NNVOL= NNVOL+JR*JX*JY*JZ
+*
+*             X-AXIS:JX+1, Y-AXIS:JY+1, Z-AXIS:JZ+1, R-AXIS:JR+3
+              NAXREM= JX+JY+JZ+JR+6
+            ELSE
+            CALL XABORT( 'XELPRC: INVALID CELL GEOMETRY FOR EXCELL=>'//
+     >                   GEONAM(1:12) )
+            ENDIF
+         ENDIF
+      ENDIF
+*
+      RETURN
+      END