1 files changed, 96 insertions, 0 deletions
diff --git a/Dragon/src/KELSYM.f b/Dragon/src/KELSYM.f
new file mode 100644
index 0000000..0b1c437
--- /dev/null
+++ b/Dragon/src/KELSYM.f
@@ -0,0 +1,96 @@
+*DECK KELSYM
+      FUNCTION KELSYM(   IPRT,   NDIM,   MAXDO,  NSURO,  NVOLO,
+     >                 IDLGEO,  INDEXO, MATGEO, KEYSYM )
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Generate the vector KEYSYM for a block. 
+*
+*Copyright:
+* Copyright (C) 1990 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
+* IPRT    intermediate printing level.                
+* NDIM    number of dimensions (2 or 3).                    
+* MAXDO   max index values for all axes (rect/cyl).   
+* NSURO   number of surfaces for a specific geometry.      
+* NVOLO   number of zones for a specific geometry.         
+* IDLGEO  specific position for a geometry.           
+* INDEXO  coordinates for zones & surfaces of a cell. 
+* MATGEO  material numbers corresponding to geometries.    
+*
+*Parameters: output
+* KEYSYM  symmetry numbers corresponding to geometries.
+* KELSYM  number of surfaces and zones renumbered.
+*
+*-----------------------------------------------------------------------
+*
+      IMPLICIT        NONE
+*
+      INTEGER         KELSYM, IPRT, NDIM, NSURO, NVOLO, IDLGEO
+      INTEGER         MAXDO(*),INDEXO(4,*),KEYSYM(*),MATGEO(*)
+*
+      INTEGER         ICUR(4), I, J, IVS, MAXPRC, MAXSUI, ISYM, IND
+      LOGICAL         SWITCH
+      INTEGER         IOUT
+      PARAMETER     ( IOUT=6 )
+*
+      IND(I)= IDLGEO + I
+*
+      DO 5 IVS= 0, NVOLO
+         KEYSYM(IND(IVS))= 0
+    5 CONTINUE
+      KELSYM= 0
+*
+*     LOCATES THE SYMMETRIC SURFACE TO EACH SURFACE
+      DO 50 IVS = NSURO, -1
+         IF( MATGEO(IND(IVS)).EQ.0 )GO TO 51
+         MAXPRC= 0
+         DO 10 J = 1, 4
+            ICUR(J)= INDEXO(J,IND(IVS))
+*
+*           FIND THE SYMMETRIC SURFACE BY CHANGING END-FACE
+            IF( J.LE.NDIM )THEN
+               MAXSUI= MAXDO(J)
+               IF( ICUR(J).EQ.MAXPRC)THEN
+                  ICUR(J)= MAXSUI
+               ELSEIF( ICUR(J).EQ.MAXSUI)THEN
+                  ICUR(J)= MAXPRC
+               ENDIF
+               MAXPRC= MAXSUI
+            ENDIF
+*
+*           THE SENTINEL VALUE IS IVS=0
+            INDEXO(J,IND(0))= ICUR(J)
+   10    CONTINUE
+         ISYM= NSURO
+   20       SWITCH= .TRUE.
+            DO 30 J    = 1, 4
+               SWITCH= SWITCH .AND. ICUR(J).EQ.INDEXO(J,IND(ISYM))
+   30       CONTINUE
+            IF( SWITCH )GO TO 40
+            ISYM= ISYM + 1
+         GO TO 20
+   40    KEYSYM(IND(IVS))= ISYM
+         IF( IPRT.GE.10 )THEN
+            WRITE(IOUT,'(22H SURFACE SYMMETRIC TO ,I6,4H IS ,I6)')
+     >                                         -IVS,     -ISYM
+         ENDIF
+         IF( ISYM.NE.0 ) KELSYM=KELSYM-1
+   51    CONTINUE
+   50 CONTINUE
+*
+*     RESET SENTINEL INDEXO(J,IND(0)) FOR SUBSEQUENT USES
+      DO 60 J= 1, 4
+         INDEXO(J,IND(0))= 0
+   60 CONTINUE
+*
+      RETURN
+      END