summaryrefslogtreecommitdiff
path: root/Dragon/src/EDIMCN.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/EDIMCN.f')
-rw-r--r--Dragon/src/EDIMCN.f282
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
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:28:46 +0000