*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