Initial commit from Polytechnique Montreal

1 files changed, 282 insertions, 0 deletions

diff --git a/Dragon/src/EDIMCN.f b/Dragon/src/EDIMCN.f
new file mode 100644
index 0000000..9e894be
--- /dev/null
+++ b/Dragon/src/EDIMCN.f
@@ -0,0 +1,282 @@
+*DECK EDIMCN
+      SUBROUTINE EDIMCN(IPTRK ,IPRINT,NDIM  ,NUCELL,NBUCEL,MAXREG,
+     >                  NFREG ,NFSUR ,NNC   ,NREGIO,NMERGE,IMERGE)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Read NXT geometry and generate merging index.
+*
+*Copyright:
+* Copyright (C) 2011 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
+* IPTRK   pointer to the TRACKING data structure in
+*         update or creation mode.
+* IPRINT  print level.
+* NDIM    dimension of the problem.
+* NUCELL  number of cell after unfolding in
+*         $X$, $Y$ and $Z$ directions.
+* NBUCEL  number of cells in unfolded geometry.
+* MAXREG  maximum number of region for any geometry.
+* NFREG   final number of regions.
+* NFSUR   final number of surfaces.
+* NNC     number of saved cells.
+* NREGIO  number of regions.
+*
+*Parameters: output
+* NMERGE  final number of merged regions.
+* IMERGE  merged region index.
+*
+*----------
+*
+      USE              GANLIB
+      IMPLICIT         NONE
+*----
+*  Subroutine arguments
+*----
+      TYPE(C_PTR)      IPTRK
+      INTEGER          IPRINT,NDIM,NUCELL(3),NBUCEL,MAXREG,NFREG,NFSUR,
+     >                 NNC,NREGIO,NMERGE,IMERGE(NREGIO)
+*----
+*  Local parameters
+*----
+      INTEGER          IOUT
+      CHARACTER        NAMSBR*6
+      PARAMETER       (IOUT=6,NAMSBR='EDIMCN')
+      INTEGER          NSTATE
+      PARAMETER       (NSTATE=40)
+*----
+*  Allocatable arrays
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,ICMRG,IDREG
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ICIS,IUNFLD
+*----
+*  Local variables
+*----
+      INTEGER          IEDIMC(NSTATE)
+      CHARACTER        NAMREC*12,NAMCEL*9,NAMPIN*9
+      INTEGER          NX,NY,NZ,NXY,IX,IY,IZ,ICELL,ICELT,ITRN,ILEV,
+     >                 NREGC,IFPIN,ILPIN,IR,IREG,IREGM,IPIN,NBRP,KCIS,
+     >                 ICS,ITYLCM
+*----
+*  Data
+*----
+      CHARACTER        CLEV(2)*1
+      SAVE             CLEV
+      DATA             CLEV /'C','P'/
+*----
+*  Scratch storage allocation
+*   KEYMRG  merge region array
+*   ICIS    internal cell symmetry
+*   IUNFLD  description of unfolded geometry
+*   IDREG   region identification array
+*   ICMRG   cell material array
+*----
+      ALLOCATE(KEYMRG(-NFSUR:NFREG),ICMRG(NBUCEL),ICIS(4,NNC),
+     > IUNFLD(2,NBUCEL),IDREG(MAXREG))
+*----
+*  Processing starts:
+*  print routine openning output header if required
+*  and initialize various parameters.
+*----
+      IF(IPRINT .GE. 10) THEN
+        WRITE(IOUT,6000) NAMSBR
+      ENDIF
+*----
+*  Initialise some arrays
+*----
+      CALL LCMGET(IPTRK,'KEYMRG      ',KEYMRG)
+      ICMRG(:NBUCEL)=0
+      IMERGE(:NREGIO)=0
+      IF(IPRINT .GE. 10) THEN
+        WRITE(IOUT,*) 'MAXREG =',MAXREG
+        WRITE(IOUT,*) 'KEYMRG=',-NFSUR,NFREG
+        WRITE(IOUT,'(17I6)') (KEYMRG(IR),IR=-NFSUR,NFREG)
+      ENDIF
+*----
+*  Read global mesh for geometry
+*  and determine graphics size
+*----
+      CALL LCMGET(IPTRK,'G00000001CIS',ICIS)
+      CALL LCMGET(IPTRK,'G00000001CUF',IUNFLD)
+      IF(IPRINT .GE. 10) THEN
+        WRITE(IOUT,*) 'IUNFLD=',NBUCEL
+        WRITE(IOUT,'(2I6)') (IUNFLD(1,IR),IUNFLD(2,IR),IR=1,NBUCEL)
+      ENDIF
+      NX=NUCELL(1)
+      NY=NUCELL(2)
+      NZ=MAX(NUCELL(3),1)
+      NXY=NX*NY
+      NMERGE=0
+*----
+*  Scan over $Z$ directions
+*----
+      DO IZ=1,NZ
+*----
+*  Scan over $Y$ directions
+*----
+        DO IY=1,NY
+*----
+*  Scan over $X$ directions
+*----
+          DO IX=1,NX
+            ICELL=NXY*(IZ-1)+NX*(IY-1)+IX
+            ICELT=IUNFLD(1,ICELL)
+            ITRN=IUNFLD(2,ICELL)
+*----
+*  If cell not already merged create new merged mixture
+*  and associate cell regions to this mixture
+*----
+            IF(IPRINT .GE. 100) THEN
+              WRITE(IOUT,'(A6,6(1X,I8))') 'CELL  ',
+     >        IX,IY,IZ,ICELL,ICELT,ITRN
+            ENDIF
+            IF(ITRN .EQ.1) THEN
+              IF(ICMRG(ICELT) .NE. 0) GO TO 100
+              NMERGE=NMERGE+1
+              ICMRG(ICELT)=NMERGE
+*----
+*  Read cell info
+*----
+              ILEV=1
+              WRITE(NAMCEL,'(A1,I8.8)') CLEV(ILEV),ICELT
+              NAMREC=NAMCEL//'DIM'
+              IEDIMC(:NSTATE)=0
+              CALL LCMGET(IPTRK,NAMREC,IEDIMC)
+              NREGC=IEDIMC(8)
+              IF(NREGC .GT. MAXREG) CALL XABORT(NAMSBR//': MAXREG for '
+     >        //'main geometry not coherent with NREGC for cells')
+              IFPIN=IEDIMC(17)
+              ILPIN=IFPIN+IEDIMC(16)-1
+              NAMREC=NAMCEL//'RID'
+              CALL LCMGET(IPTRK,NAMREC,IDREG)
+              IF(IPRINT .GE. 100) THEN
+                WRITE(IOUT,*) NAMREC//'=',NREGC,IFPIN,ILPIN
+                WRITE(IOUT,'(17I6)') (IDREG(IR),IR=1,NREGC)
+              ENDIF
+              KCIS=0
+              DO ICS=1,4
+                IF(ICIS(ICS,ICELT) .NE. 0) KCIS=1 
+              ENDDO
+              DO IR=1,NREGC
+                IREG=IDREG(IR)
+                IF(IREG .GT. 0) THEN
+                  IREGM=KEYMRG(IREG)
+                  IF(IMERGE(IREGM) .EQ. 0) THEN
+                    IMERGE(IREGM)=NMERGE
+                  ELSE IF(IMERGE(IREGM) .NE. NMERGE) THEN
+                    WRITE(IOUT,9000) NAMSBR,ICELL,ICELT,
+     >                               IREG,IREGM,IMERGE(IREGM)
+                    CALL XABORT(NAMSBR//
+     >              ': Problem in cells for merge by cell') 
+                  ENDIF
+                ELSE IF(IREG .LT. 0) THEN
+                  IF(KCIS .NE. 1) THEN
+                    WRITE(IOUT,9002) NAMSBR,ICELL,ICELT,IREG,IREGM
+                    CALL XABORT(NAMSBR//
+     >            ': Negative region number for cell without symmetry')
+                  ENDIF                    
+                ENDIF
+              ENDDO
+*----
+*  Read pin info
+*----
+              ILEV=2
+              DO IPIN=IFPIN,ILPIN
+                WRITE(NAMPIN,'(A1,I8.8)') CLEV(ILEV),IPIN
+                NAMREC=NAMPIN//'RID'
+                CALL LCMLEN(IPTRK,NAMREC,NBRP,ITYLCM)
+                IF(NBRP .GT. MAXREG) CALL XABORT(NAMSBR//': MAXREG for'
+     >          //' main geometry not coherent with NBRP for pins')
+                CALL LCMGET(IPTRK,NAMREC,IDREG)
+                DO IR=1,NBRP
+                  IREG=ABS(IDREG(IR))
+                  IF(IREG .NE. 0) THEN
+                    IREGM=KEYMRG(IREG)
+                    IF(IMERGE(IREGM) .EQ. 0) THEN
+                      IMERGE(IREGM)=NMERGE
+                    ELSE IF(IMERGE(IREGM) .NE. NMERGE) THEN
+                      WRITE(IOUT,9001) NAMSBR,IPIN,ICELL,ICELT,
+     >                               IREG,IREGM,IMERGE(IREGM)
+                      CALL XABORT(NAMSBR//
+     >                ': Problem in pins for merge by cell')
+                    ENDIF
+                  ENDIF
+                ENDDO
+              ENDDO
+ 100          CONTINUE
+            ENDIF
+          ENDDO
+        ENDDO
+      ENDDO
+*----
+*  Verify if all cells analysed
+*----
+      DO ICELL=1,NX*NY*NZ
+        ICELT=IUNFLD(1,ICELL)
+        IF(ICMRG(ICELT) .EQ. 0) THEN
+          WRITE(IOUT,*) 'Merge Error',ICELL,ICELT
+          CALL XABORT(NAMSBR//': Some cells not merged')
+        ENDIF
+      ENDDO
+*----
+*  print routine closing  header if required
+*----
+      IF(IPRINT .GE. 10) THEN
+        IF(IPRINT .GE. 100) THEN
+          WRITE(IOUT,6010)
+          DO IZ=1,NZ
+*----
+*  Scan over $Y$ directions
+*----
+            IF(NDIM .EQ. 3) THEN
+              WRITE(IOUT,6011) IZ
+            ENDIF
+            WRITE(IOUT,6012) (IX,IX=1,NX)
+            WRITE(IOUT,6013) ('------',IX=1,NX)
+            DO IY=NY,1,-1
+*----
+*  Scan over $X$ directions
+*----
+              WRITE(IOUT,6014) IY,(ICMRG(IUNFLD(1,ICELL)),
+     >        ICELL=NXY*(IZ-1)+NX*(IY-1)+1,NXY*(IZ-1)+NX*IY)
+            ENDDO
+          ENDDO
+          WRITE(IOUT,6020)
+          WRITE(IOUT,6021) (IMERGE(IREGM),IREGM=1,NREGIO)
+        ENDIF
+        WRITE(IOUT,6001) NAMSBR
+      ENDIF
+*----
+*  Scratch storage deallocation
+*----
+      DEALLOCATE(IDREG,IUNFLD,ICIS,ICMRG,KEYMRG)
+      RETURN
+*----
+*  Output formats
+*----
+ 6000 FORMAT('(* Output from --',A6,'-- follows ')
+ 6001 FORMAT('   Output from --',A6,'-- completed *)')
+ 6010 FORMAT('Material homogenisation indices for cells'//
+     >       ' --  Unfolded geometry')
+ 6011 FORMAT('Plan Z =',5x,I5)
+ 6012 FORMAT('    Y | X=',100(1X,I5))
+ 6013 FORMAT('-----------',100(A6))
+ 6014 FORMAT(I6,'    |',100(1X,I5))
+ 6020 FORMAT('Merging Index :')
+ 6021 FORMAT(12(1X,I5))
+ 9000 FORMAT(' Error in ',A6,' virtual cell ',I5,
+     >       ' (real cell=',I5,') analysis'/3I10)
+ 9001 FORMAT(' Error in ',A6,' pin ',I5,' virtual cell ',I5,
+     >       ' (real cell=',I5,') analysis'/3I10)
+ 9002 FORMAT(' Internal symmetries problem in ',A6,' virtual cell ',I5,
+     >       ' (real cell=',I5,') analysis'/3I10)
+      END