*DECK EDIMRC SUBROUTINE EDIMRC(IPTRK ,IPRINT ,NREGIO, NMERGE, IMERGE) * *----------------------------------------------------------------------- * *Purpose: * To generate the region merging index for homogenisation * per CELL for NXT treated geometry * *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. * IPRINT print level. * 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 INTEGER NREGIO INTEGER NMERGE INTEGER IMERGE(NREGIO) *---- * Local parameters *---- CHARACTER NAMSBR*6 PARAMETER (NAMSBR='EDIMRC') INTEGER NSTATE PARAMETER (NSTATE=40) INTEGER ILCMUP,ILCMDN PARAMETER (ILCMUP=1,ILCMDN=2) *---- * Local variables *---- INTEGER ISTATE(NSTATE),IEDIMG(NSTATE) CHARACTER HSIGN*12 INTEGER NDIM,NFREG,NFSUR,NNC,NBUCEL,NUCELL(3),MAXREG *---- * Test if valid tracking data structure * EXCELL with type 4 tracking *---- CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) *---- * TEST IF GEOMETRY OR EXCELL TRACK DATA STRUCTURE *---- IF(HSIGN .NE. 'L_TRACK ') CALL XABORT(NAMSBR// >': Invalid data structure for merge by cell') CALL LCMGTC(IPTRK,'TRACK-TYPE',12,HSIGN) IF((HSIGN .NE. 'EXCELL') .AND. (HSIGN .NE. 'MCCG')) THEN CALL XABORT(NAMSBR//': Invalid tracking for merge by cell') ENDIF ISTATE(:NSTATE)=0 CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) IF(ISTATE(7) .NE. 4) CALL XABORT(NAMSBR// >': Only NXT tracking permitted for merge by cell') IF(ISTATE(40) .EQ. 1) CALL XABORT(NAMSBR// >': Double heterogeneity (Bihet) not implemented') CALL LCMSIX(IPTRK,'NXTRecords ',ILCMUP) CALL LCMGET(IPTRK,'G00000001DIM',IEDIMG) NDIM =IEDIMG( 1) NNC =IEDIMG( 4) NBUCEL =IEDIMG( 5) NUCELL(1)=IEDIMG(13) NUCELL(2)=IEDIMG(14) NUCELL(3)=IEDIMG(15) NFSUR =IEDIMG(22) NFREG =IEDIMG(23) MAXREG =IEDIMG(25) CALL EDIMCN(IPTRK ,IPRINT,NDIM ,NUCELL,NBUCEL,MAXREG, > NFREG,NFSUR,NNC,NREGIO,NMERGE,IMERGE) CALL LCMSIX(IPTRK,'NXTRecords ',ILCMDN) RETURN END