*DECK GEODIN SUBROUTINE GEODIN (GEONAM,IPLIST,LEVEL,IMPX,MAXMIX) * *----------------------------------------------------------------------- * *Purpose: * Read and/or modify an object oriented geometry * *Copyright: * Copyright (C) 2002 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): A. Hebert * *Parameters: input * GEONAM name of the directory where the geometry is stored. * IPLIST pointer to the geometry LCM object (L_GEOM signature). * LEVEL hierarchical level of the geometry. * IMPX print flag (IMPX=0 for no print). * *Parameters: output * MAXMIX maximum number of mixtures, considering all sub-geometries. * *----------------------------------------------------------------------- * USE GANLIB *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIST INTEGER LEVEL,IMPX,MAXMIX CHARACTER GEONAM*12 *---- * LOCAL VARIABLES *---- PARAMETER (MAXCOD=21,MAXHEX=9,MAXTEX=4,MAXTUR=12,MAXTYP=30, 1 MXCL=500,NSTATE=40,IOUT=6) LOGICAL LHEX,LTRI,EMPTY,LCM,SWANG LOGICAL LTOT,LCOUR CHARACTER NAMT*12,COND(MAXCOD)*4,CHEX(MAXHEX)*8,CHET(MAXTEX)*8, 1 CTUR(MAXTUR)*1,TYPE(0:MAXTYP)*16,TEXT4*4,CARLIR*12,TEXT12*12, 2 DIR*1 INTEGER ISTATE(NSTATE),NCODE(6),ICODE(6) REAL ZCODE(6) DOUBLE PRECISION DBLLIR EQUIVALENCE (LR,ISTATE(2)),(LX,ISTATE(3)),(LY,ISTATE(4)), 1 (LZ,ISTATE(5)),(LREG,ISTATE(6)) INTEGER, DIMENSION(:), ALLOCATABLE :: MIX,MERGE,TURN,MESH REAL, DIMENSION(:), ALLOCATABLE :: RMESH,XR0,RR0,ANG CHARACTER(LEN=12), DIMENSION(:), ALLOCATABLE :: CELL *---- * Data *---- SAVE COND,CHEX,CTUR,TYPE DATA COND > /'VOID','REFL','DIAG','TRAN','SYME', > 'ALBE','ZERO','PI/2','PI' ,'SSYM', > 9*' ','CYLI','ACYL'/ DATA CHEX > /'S30 ','SA60 ','SB60 ','S90 ','R120 ', > 'R180 ','SA180 ','SB180 ','COMPLETE'/ DATA CTUR > /'A','B','C','D','E','F','G','H','I','J','K','L'/ DATA TYPE > /'VIRTUAL ','HOMOGENEOUS ','CARTESIAN 1-D ', > 'TUBE 1-D ','SPHERE 1-D ','CARTESIAN 2-D ', > 'TUBE 2-D (Z) ','CARTESIAN 3-D ','HEXAGONAL 2-D ', > 'HEXAGONE 3-D (Z)','TUBE 2-D (X) ','TUBE 2-D (Y) ', > 'R-THETA ','TRIANGULAR 2-D ','TRIANGULAR 3-D ', > ' ',' ',' ', > ' ',' ','2-D RECT. CELL ', > '3-D RECT. CELL X','3-D RECT. CELL Y','3-D RECT. CELL X', > '2-D HEX. CELL ','3-D HEX. CELL Z ',' ', > ' ',' ',' ', > 'DO-IT-YOURSELF '/ * MINMIX=0 MINICO=1 CALL LCMLEN(IPLIST,'SIGNATURE',ILONG,ITYX) IF(ILONG.EQ.0) THEN * INPUT A NEW GEOMETRY. DO 10 I=1,NSTATE ISTATE(I)=0 10 CONTINUE LHEX=.FALSE. LTRI=.FALSE. LCOUR=.FALSE. DO 20 I=1,6 NCODE(I)=0 ZCODE(I)=0.0 ICODE(I)=0 20 CONTINUE ELSE * MODIFY AN EXISTING GEOMETRY. CALL LCMGTC(IPLIST,'SIGNATURE',12,CARLIR) IF(CARLIR.NE.'L_GEOM') THEN NAMT=GEONAM CALL XABORT('GEODIN: SIGNATURE OF '//NAMT//' IS '//CARLIR 1 //'. L_GEOM EXPECTED.') ENDIF CALL LCMGET(IPLIST,'STATE-VECTOR',ISTATE) LHEX=(ISTATE(1).EQ.8).OR.(ISTATE(1).EQ.9).OR.(ISTATE(1).EQ.24) 1 .OR.(ISTATE(1).EQ.25) LTRI=(ISTATE(1).EQ.13).OR.(ISTATE(1).EQ.14) LCOUR=.FALSE. IF(LHEX) THEN CALL LCMLEN(IPLIST,'IHEX',ILONG,ITYX) IF(ILONG.EQ.0) CALL XABORT('GEODIN: MISSING IHEX RECORD.') CALL LCMGET(IPLIST,'IHEX',IHEX) LCOUR=IHEX.EQ.9 ENDIF CALL LCMGET(IPLIST,'NCODE',NCODE) CALL LCMGET(IPLIST,'ZCODE',ZCODE) CALL LCMGET(IPLIST,'ICODE',ICODE) IF(LEVEL.EQ.1) GO TO 50 ENDIF * CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED(1).') IF(CARLIR.EQ.'VIRTUAL') THEN ISTATE(1)=0 ELSE IF(CARLIR.EQ.'HOMOGE') THEN ISTATE(1)=1 LREG=1 ELSE IF(CARLIR.EQ.'CAR1D') THEN ISTATE(1)=2 CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LX ELSE IF(CARLIR.EQ.'SPHERE') THEN ISTATE(1)=4 CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LR ELSE IF(CARLIR.EQ.'CAR2D') THEN ISTATE(1)=5 CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LX*LY ELSE IF(CARLIR.EQ.'CAR3D') THEN ISTATE(1)=7 CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LX*LY*LZ ELSE IF(CARLIR.EQ.'HEX') THEN ISTATE(1)=8 LHEX=.TRUE. CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LX ELSE IF(CARLIR.EQ.'HEXZ') THEN ISTATE(1)=9 LHEX=.TRUE. CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LX*LZ ELSE IF(CARLIR.EQ.'TRI') THEN ISTATE(1)=13 LTRI=.TRUE. CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LX ELSE IF(CARLIR.EQ.'TRIZ') THEN ISTATE(1)=14 LTRI=.TRUE. CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LX*LZ ELSE IF(CARLIR.EQ.'RTHETA') THEN ISTATE(1)=12 CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LR*LZ ELSE IF(CARLIR(1:4).EQ.'TUBE') THEN DIR=CARLIR(5:5) CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') IF(DIR.EQ.' ') THEN ISTATE(1)=3 LX=1 LY=1 IRLXY=1 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.EQ.3) THEN IRLXY=0 ELSE IF(ITYPLU.EQ.2) THEN CALL XABORT('GEODIN: INVALID REAL DATA.') ELSE LX=INTLIR CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTE' 1 //'D.') ENDIF LREG=LR*LY*LX IF(IRLXY.EQ.0) GO TO 60 ELSE LX=1 LY=1 LZ=1 CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IRLYZ=-99 IF(ITYPLU.EQ.3) THEN IRLYZ=0 ELSE IF(ITYPLU.EQ.2) THEN CALL XABORT('GEODIN: REAL DATA NOT EXPECTED.') ELSE LY=INTLIR IRLYZ=1 CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTE' 1 //'D.') ENDIF LREG=LR*LY*LZ*LX IF(DIR.EQ.'X') THEN ISTATE(1)=10 IF(IRLYZ.EQ.0) GO TO 60 ELSE IF(DIR.EQ.'Y') THEN ISTATE(1)=11 IF(IRLYZ.EQ.0) THEN LY=LX LX=1 GO TO 60 ENDIF ELSE IF(DIR.EQ.'Z') THEN ISTATE(1)=6 IF(IRLYZ.EQ.0) THEN LZ=LX LX=1 GO TO 60 ENDIF ELSE CALL XABORT('GEODIN: INVALID DATA IN TUBE CONSTRUCT.') ENDIF ENDIF ELSE IF(CARLIR(1:6).EQ.'CARCEL') THEN CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') DIR=CARLIR(7:7) IF(DIR.EQ.' ') THEN ISTATE(1)=20 LX=1 LY=1 IRLXY=1 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.EQ.3) THEN IRLXY=0 ELSE IF(ITYPLU.EQ.2) THEN CALL XABORT('GEODIN: INVALID REAL DATA.') ELSE LX=INTLIR CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTE' 1 //'D.') ENDIF LREG=(LR+1)*LY*LX IF(IRLXY.EQ.0) GO TO 60 ELSE LX=1 LY=1 LZ=1 CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IRLYZ=-99 IF(ITYPLU.EQ.3) THEN IRLYZ=0 ELSE IF(ITYPLU.EQ.2) THEN CALL XABORT('GEODIN: INVALID REAL DATA.') ELSE LY=INTLIR IRLYZ=1 CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTE' 1 //'D.') ENDIF LREG=(LR+1)*LY*LZ*LX IF(DIR.EQ.'X') THEN ISTATE(1)=21 ELSE IF(DIR.EQ.'Y') THEN ISTATE(1)=22 IF(IRLYZ.EQ.0) THEN LY=LX LX=1 GO TO 60 ENDIF ELSE IF(DIR.EQ.'Z') THEN ISTATE(1)=23 IF(IRLYZ.EQ.0) THEN LZ=LX LX=1 GO TO 60 ENDIF ELSE CALL XABORT('GEODIN: INVALID DATA.') ENDIF ENDIF ELSE IF(CARLIR(1:6).EQ.'HEXCEL') THEN LHEX=.TRUE. CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LX=1 IF(CARLIR(7:7).EQ.' ') THEN ISTATE(1)=24 LREG=LR+1 ELSE IF(CARLIR(7:7).EQ.'Z') THEN ISTATE(1)=27 CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=(LR+1)*LZ ELSE CALL XABORT('GEODIN: INVALID SUFFIX FOR HEXCEL.') ENDIF ELSE IF(CARLIR.EQ.'GROUP') THEN * DO-IT-YOURSELF OPTION. ISTATE(1)=30 CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') LREG=LX ELSE IF(CARLIR.NE.GEONAM) THEN * COPY ATTRIBUTES FROM AN EXISTING GEOMETRY LOCATED ON A PARALLEL * DIRECTORY OF THE LCM OBJECT POINTED BY IPLIST. IF(LEVEL.EQ.1) CALL XABORT('GEODIN: THE GEOMETRY NAME SHOULD A' 1 //'PPEAR BEFORE THE ::.') CALL LCMSIX(IPLIST,' ',2) CALL LCMLEN(IPLIST,CARLIR,ILONG,ITYX) IF(ILONG.EQ.0) CALL XABORT('GEODIN: UNKNOWN GEOMETRY.') CALL LCMSIX(IPLIST,CARLIR,1) IFILE=KDROPN('DUMMYSQ',0,2,0,0) IF(IFILE.LE.0) CALL XABORT('GEODIN: KDROPN FAILURE.') CALL LCMEXP(IPLIST,0,IFILE,1,1) REWIND(IFILE) CALL LCMSIX(IPLIST,' ',2) CALL LCMSIX(IPLIST,GEONAM,1) CALL LCMEXP(IPLIST,0,IFILE,1,2) IRC=KDRCLS(IFILE,2) IF(IRC.LT.0) CALL XABORT('GEODIN: KDRCLS FAILURE.') CALL LCMGET(IPLIST,'STATE-VECTOR',ISTATE) LHEX=(ISTATE(1).EQ.8).OR.(ISTATE(1).EQ.9).OR.(ISTATE(1).EQ.24) 1 .OR.(ISTATE(1).EQ.25) LTRI=(ISTATE(1).EQ.13).OR.(ISTATE(1).EQ.14) CALL LCMGET(IPLIST,'NCODE',NCODE) CALL LCMGET(IPLIST,'ZCODE',ZCODE) CALL LCMGET(IPLIST,'ICODE',ICODE) ENDIF * 50 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED(2).') 60 IF(CARLIR.EQ.'EDIT') THEN CALL REDGET(ITYPLU,IMPX,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') ELSE IF((CARLIR.EQ.'MIX').OR.(CARLIR.EQ.'CELL')) THEN * INPUT MIXTURE NUMBERS OR FORCE SUB GEOMETRIES AT SPECIFIC * LOCATIONS. ALLOCATE(CELL(LREG),MIX(LREG)) MIX(:LREG)=0 LTOT=.TRUE. I=0 IKG=0 70 I=I+1 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.EQ.3) THEN IF(CARLIR.EQ.'PLANE') THEN IF(I.EQ.1) THEN IF(ISTATE(1).EQ.7.OR.ISTATE(1).EQ.9) THEN IF(ISTATE(1).EQ.9) LY=1 CALL GEODMI(LX,LY,LZ,LCOUR,MIX,MINMIX,ISTATE(7)) LTOT=.FALSE. GO TO 70 ELSE CALL XABORT('GEODIN: INVALID KEY WORD PLANE FOR NON ' 1 //' 3-D GEOMETRY') ENDIF ELSE CALL XABORT('GEODIN: WRONG USE OF KEYWORD PLANE.') ENDIF ENDIF IF((CARLIR(2:2).EQ.'-').OR.(CARLIR(2:2).EQ.'+').OR. 1 (CARLIR.EQ.'HBC').OR.(CARLIR(1:4).EQ.'MESH').OR. 2 (CARLIR(1:5).EQ.'SPLIT').OR.(CARLIR.EQ.'SIDE').OR. 3 (CARLIR(:3).EQ.'MIX').OR.(CARLIR.EQ.'MERGE').OR. 4 (CARLIR.EQ.'TURN').OR.(CARLIR.EQ.'CLUSTER').OR. 5 (CARLIR(2:4).EQ.'PIN').OR.(CARLIR.EQ.'BIHET').OR. 6 (CARLIR.EQ.'POURCE').OR.(CARLIR.EQ.'PROCEL').OR. 7 (CARLIR.EQ.'SECT').OR.(CARLIR.EQ.'RADIUS').OR. 8 (CARLIR.EQ.';').OR.(CARLIR.EQ.':::')) GO TO 90 IF(I.GT.LREG) CALL XABORT('GEODIN: MIX/CELL INDEX OVERFLO' 1 //'W.') DO 80 J=1,I-1 JKG=-MIX(J) IF(CARLIR.EQ.CELL(JKG)) THEN MIX(I)=-JKG GO TO 70 ENDIF 80 CONTINUE IKG=IKG+1 ISTATE(8)=1 MIX(I)=-IKG CELL(IKG)=CARLIR ELSE IF(ITYPLU.EQ.1) THEN IF(I.GT.LREG) CALL XABORT('GEODIN: MIX INDEX OVERFLOW.') MIX(I)=INTLIR ISTATE(7)=MAX(ISTATE(7),MIX(I)) MINMIX=MIN(MINMIX,MIX(I)) ELSE CALL XABORT('GEODIN: INTEGER OR CHARACTER DATA EXPECTED.') ENDIF GO TO 70 90 CONTINUE IF(CARLIR.EQ.'REPEAT') THEN NBR=LREG/(I-1) NBRR=NBR*(I-1) IF(NBRR.NE.LREG) THEN WRITE(IOUT,530) I-1,LREG CALL XABORT('GEODIN: IMPOSSIBLE TO REPEAT AN INTEGER NUMB' 1 //'ER OF TIMES.') ENDIF JREP=I-1 DO IREP=1,NBR-1 DO II=1,I-1 JREP=JREP+1 MIX(JREP)=MIX(II) ENDDO ENDDO I=JREP+1 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTE' 1 //'D.') ENDIF IF(LTOT) LREG=I-1 IF(IKG.GT.0) CALL LCMPTC(IPLIST,'CELL',12,IKG,CELL) CALL LCMPUT(IPLIST,'MIX',LREG,1,MIX) DEALLOCATE(MIX,CELL) GO TO 60 ELSE IF(CARLIR(1:4).EQ.'MESH') THEN * INPUT CARTESIAN COORDINATES. IF(CARLIR(5:5).EQ.'X') THEN IF(LX.EQ.0) CALL XABORT('GEODIN: MESHX - LX=0.') LMESH=LX+1 ELSE IF(CARLIR(5:5).EQ.'Y') THEN IF(LY.EQ.0) CALL XABORT('GEODIN: MESHY - LY=0.') LMESH=LY+1 ELSE IF(CARLIR(5:5).EQ.'Z') THEN IF(LZ.EQ.0) CALL XABORT('GEODIN: MESHZ - LZ=0.') LMESH=LZ+1 ELSE CALL XABORT('GEODIN: INVALID MESH SUFFIX.') ENDIF ALLOCATE(RMESH(LMESH)) DO 100 I=1,LMESH CALL REDGET(ITYPLU,INTLIR,RMESH(I),TEXT12,DBLLIR) IF(ITYPLU.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') IF(I.GT.1) THEN IF(RMESH(I).LE.RMESH(I-1)) THEN CALL XABORT('GEODIN: NON INCREASING MESHES.') ENDIF ENDIF 100 CONTINUE CALL LCMPUT(IPLIST,CARLIR,LMESH,2,RMESH) DEALLOCATE(RMESH) ELSE IF(CARLIR.EQ.'SIDE') THEN * INPUT THE SIDE LENGTH IN TRIANGULAR OR HEXAGONAL GEOMETRY. IF((.NOT.LHEX).AND.(.NOT.LTRI)) CALL XABORT('GEODIN: SIDE PRO' 1 //'HIBITED.') CALL REDGET(ITYPLU,INTLIR,SIDE,CARLIR,DBLLIR) IF(ITYPLU.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') CALL LCMPUT(IPLIST,'SIDE',1,2,SIDE) ELSE IF (CARLIR.EQ.'RADS') THEN * OPTIONS FOR CYLINDRICAL CORRECTION IN CARTESIAN GEOMETRY. IF((ISTATE(1).NE.5).AND.(ISTATE(1).NE.7)) CALL XABORT('GEO' 1 //'IN1: OPTION RADS IS LIMITED TO CARTESIAN GEOMETRIES.') CALL REDGET(INDIC,NR0,REALIR,TEXT4,DBLLIR) SWANG=TEXT4.EQ.'ANG' IF(SWANG) CALL REDGET(INDIC,NR0,REALIR,TEXT4,DBLLIR) IF(INDIC.NE.1) CALL XABORT('GEO: INTEGER DATA EXPECTED.') IF(NR0.EQ.0) CALL XABORT('GEODIN: NON-ZERO INTEGER EXPECTED.') ALLOCATE(XR0(NR0),RR0(NR0),ANG(NR0)) DO 135 I=1,NR0 CALL REDGET(INDIC,INTLIR,XR0(I),TEXT4,DBLLIR) IF(INDIC.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') CALL REDGET(INDIC,INTLIR,RR0(I),TEXT4,DBLLIR) IF(INDIC.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') IF(SWANG) THEN CALL REDGET(INDIC,INTLIR,ANG(I),TEXT4,DBLLIR) IF(INDIC.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') ELSE * USE PI/2 + 0.1 ANG(I)=1.670796327 ENDIF 135 CONTINUE CALL LCMPUT(IPLIST,'XR0',NR0,2,XR0) CALL LCMPUT(IPLIST,'RR0',NR0,2,RR0) CALL LCMPUT(IPLIST,'ANG',NR0,2,ANG) DEALLOCATE(ANG,RR0,XR0) ELSE IF(CARLIR(1:5).EQ.'SPLIT') THEN * INPUT MESH SPLITTING FACTORS. ISTATE(11)=1 IF(CARLIR(6:6).EQ.'X') THEN IF(LX.EQ.0) CALL XABORT('GEODIN: SPLITX - LX=0.') LMESH=LX ELSE IF(CARLIR(6:6).EQ.'Y') THEN IF(LY.EQ.0) CALL XABORT('GEODIN: SPLITY - LY=0.') LMESH=LY ELSE IF(CARLIR(6:6).EQ.'Z') THEN IF(LZ.EQ.0) CALL XABORT('GEODIN: SPLITZ - LZ=0.') LMESH=LZ ELSE IF(CARLIR(6:6).EQ.'R') THEN IF(LR.EQ.0) CALL XABORT('GEODIN: SPLITR - LR=0.') LMESH=LR ELSE IF(CARLIR(6:6).EQ.'H') THEN IF(LX.EQ.0) CALL XABORT('GEODIN: SPLITH - LX=0.') LMESH=1 ELSE IF(CARLIR(6:6).EQ.'L') THEN IF(LX.EQ.0) CALL XABORT('GEODIN: SPLITL - LX=0.') LMESH=1 ELSE CALL XABORT('GEODIN: INVALID SPLIT SUFFIX.') ENDIF ALLOCATE(MESH(LMESH)) DO 140 I=1,LMESH CALL REDGET(ITYPLU,MESH(I),REALIR,TEXT12,DBLLIR) IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') IF(CARLIR.EQ.'SPLITR') THEN IF(MESH(I).EQ.0) THEN CALL XABORT('GEODIN: INVALID MESH-SPLITTING INDEX(1).') ENDIF ELSE IF((CARLIR.EQ.'SPLITH').OR.(CARLIR.EQ.'SPLITL')) THEN IF(MESH(I).LT.0) THEN CALL XABORT('GEODIN: INVALID MESH-SPLITTING INDEX(2).') ENDIF ELSE IF(MESH(I).LE.0) THEN CALL XABORT('GEODIN: INVALID MESH-SPLITTING INDEX(3).') ENDIF ENDIF 140 CONTINUE CALL LCMPUT(IPLIST,CARLIR,LMESH,1,MESH) DEALLOCATE(MESH) ELSE IF(CARLIR.EQ.'MERGE') THEN * INPUT CELL-MERGING INDICES. ISTATE(10)=1 ALLOCATE(MERGE(LREG)) I=0 150 I=I+1 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.EQ.3) GO TO 160 IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') IF(I.GT.LREG) CALL XABORT('GEODIN: MERGE INDEX OVERFLOW.') MERGE(I)=INTLIR GO TO 150 160 LREG=I-1 CALL LCMPUT(IPLIST,'MERGE',LREG,1,MERGE) DEALLOCATE(MERGE) GO TO 60 ELSE IF(CARLIR.EQ.'TURN') THEN * INPUT ORIENTATION INFORMATION. ALLOCATE(TURN(LREG)) I=0 170 I=I+1 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED.') DO 180 J=1,MAXTUR IF(CARLIR.EQ.CTUR(J)) THEN IF(I.GT.LREG) CALL XABORT('GEODIN: TURN INDEX OVERFLOW(1).') TURN(I)=J GO TO 170 ELSE IF(CARLIR.EQ.'-'//CTUR(J)) THEN IF(I.GT.LREG) CALL XABORT('GEODIN: TURN INDEX OVERFLOW(2).') TURN(I)=MAXTUR+J GO TO 170 ENDIF 180 CONTINUE LREG=I-1 CALL LCMPUT(IPLIST,'TURN',LREG,1,TURN) DEALLOCATE(TURN) GO TO 60 ELSE IF((CARLIR(2:2).EQ.'+').OR.(CARLIR(2:2).EQ.'-').OR. 1 (CARLIR.EQ.'HBC')) THEN * INPUT BOUNDARY CONDITIONS. ISURF=-99 IF(CARLIR.EQ.'X-') THEN ISURF=1 IF(LX.EQ.0) CALL XABORT('GEODIN: HBC X- -> LX=0.') ELSE IF(CARLIR.EQ.'X+') THEN ISURF=2 IF(LX.EQ.0) CALL XABORT('GEODIN: HBC X+ -> LX=0.') ELSE IF(CARLIR.EQ.'R+') THEN ISURF=2 IF(LR.EQ.0) CALL XABORT('GEODIN: HBC R+ -> LR=0.') ELSE IF(CARLIR.EQ.'Y-') THEN ISURF=3 IF(LY.EQ.0) CALL XABORT('GEODIN: HBC Y- -> LY=0.') ELSE IF(CARLIR.EQ.'Y+') THEN ISURF=4 IF(LY.EQ.0) CALL XABORT('GEODIN: HBC Y+ -> LY=0.') ELSE IF(CARLIR.EQ.'Z-') THEN ISURF=5 IF(LZ.EQ.0) CALL XABORT('GEODIN: HBC Z- -> LZ=0.') ELSE IF(CARLIR.EQ.'Z+') THEN ISURF=6 IF(LZ.EQ.0) CALL XABORT('GEODIN: HBC Z+ -> LZ=0.') ELSE IF(CARLIR.EQ.'HBC') THEN ISURF=1 IF(.NOT.LHEX) CALL XABORT('GEODIN: HBC PROHIBITED.') CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTE' 1 //'D.') DO 330 I=1,MAXHEX IF(CARLIR.EQ.CHEX(I)) THEN IHEX=I GO TO 340 ENDIF 330 CONTINUE CALL XABORT('GEODIN: INVALID TYPE OF HEXAGONAL SYMMETRY.') 340 CALL LCMPUT(IPLIST,'IHEX',1,1,IHEX) LCOUR=IHEX.EQ.9 ELSE IF(CARLIR.EQ.'TBC') THEN ISURF=1 IF(.NOT.LTRI) CALL XABORT('GEODIN: TBC PROHIBITED.') CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTE' 1 //'D.') DO 350 I=1,MAXTEX IF(CARLIR.EQ.CHET(I)) THEN ITRI=I GO TO 360 ENDIF 350 CONTINUE CALL XABORT('GEODIN: INVALID TYPE OF TRIANGULAR SYMMETRY.') 360 CALL LCMPUT(IPLIST,'ITRI',1,1,ITRI) ELSE CALL XABORT('GEODIN: INVALID KEY WORD '//CARLIR//'.') ENDIF CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED.') DO 370 I=1,MAXCOD IF(TEXT4.EQ.COND(I)) THEN NCODE(ISURF)=I IF(TEXT4.EQ.'ACYL') NCODE(ISURF)=I-1 GO TO 380 ENDIF 370 CONTINUE CALL XABORT('GEODIN: INVALID TYPE OF BOUNDARY CONDITION.') 380 IF(TEXT4.EQ.'ALBE') THEN CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) IF(ITYPLU.EQ.1) THEN ICODE(ISURF)=INTLIR MINICO=MIN(MINICO,INTLIR) ELSE IF(ITYPLU.EQ.2) THEN ZCODE(ISURF)=REALIR ELSE CALL XABORT('GEODIN: INTEGER OR REAL DATA EXPECTED.') ENDIF ELSE IF(TEXT4.EQ.'ACYL') THEN CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) IF(ITYPLU.EQ.1) THEN ICODE(ISURF)=INTLIR MINICO=MIN(MINICO,INTLIR) ELSE IF(ITYPLU.EQ.2) THEN ZCODE(ISURF)=REALIR ELSE CALL XABORT('GEODIN: INTEGER OR REAL DATA EXPECTED ' 1 //'AFTER ACYL.') ENDIF ELSE IF(TEXT4.EQ.'REFL') THEN ZCODE(ISURF)=1.0 ELSE IF(TEXT4.EQ.'VOID') THEN ZCODE(ISURF)=0.0 ENDIF ELSE IF(CARLIR.EQ.';') THEN * END-OF-GEOMETRY. GO TO 410 ELSE IF(CARLIR.EQ.':::') THEN * INPUT A SUB GEOMETRY. CALL XABORT('GEODIN: SUB-GEOMETRY NOT ALLOWED.') ELSE IF(CARLIR.EQ.'MIX-NAMES') THEN * DEFINE MIXTURE CHARACTER NAMES. IF(LEVEL.NE.1) CALL XABORT('GEODIN: MIX-NAMES DATA SHOULD BE ' 1 //'WRITTEN ON FIRST DIRECTORY LEVEL.') ALLOCATE(CELL(LREG)) I=0 390 I=I+1 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED.') IF((CARLIR(2:2).EQ.'-').OR.(CARLIR(2:2).EQ.'+').OR. 1 (CARLIR.EQ.'HBC').OR.(CARLIR(1:4).EQ.'MESH').OR.(CARLIR(1:5) 2 .EQ.'SPLIT').OR.(CARLIR.EQ.'SIDE').OR.(CARLIR(:3).EQ.'MIX').OR. 3 (CARLIR.EQ.'CELL').OR.(CARLIR.EQ.'MERGE').OR.(CARLIR.EQ.'TURN') 4 .OR.(CARLIR(2:4).EQ.'PIN').OR.(CARLIR.EQ.'BIHET').OR. 5 (CARLIR.EQ.'POURCE').OR.(CARLIR.EQ.'PROCEL').OR. 6 (CARLIR.EQ.'SECT').OR.(CARLIR.EQ.'RADIUS').OR.(CARLIR.EQ.';') 7 .OR. (CARLIR.EQ.':::')) GO TO 400 IF(I.GT.LREG) CALL XABORT('GEODIN: MIX-NAMES INDEX OVERFLOW.') CELL(I)=CARLIR GO TO 390 400 CALL LCMPTC(IPLIST,'MIX-NAMES',12,I-1,CELL) ISTATE(13)=I-1 DEALLOCATE(CELL) GO TO 60 ELSE CALL XABORT('GEODIN: '//CARLIR//' IS AN INVALID KEY WORD.') ENDIF GO TO 50 * 410 CARLIR='L_GEOM' CALL LCMPTC(IPLIST,'SIGNATURE',12,CARLIR) CALL LCMPUT(IPLIST,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMPUT(IPLIST,'NCODE',6,1,NCODE) CALL LCMPUT(IPLIST,'ZCODE',6,2,ZCODE) CALL LCMPUT(IPLIST,'ICODE',6,1,ICODE) IF(MINMIX.LT.0) > CALL XABORT('GEODIN: NEGATIVE MIXTURE NUMBERS INVALID') IF(MINICO.LT.1) > CALL XABORT('GEODIN: ALBEDO NUMBER MUST BE GREATER THAN 0') MAXMIX=ISTATE(7) IF(IMPX.GT.0) THEN CALL LCMINF(IPLIST,CARLIR,TEXT12,EMPTY,ILONG,LCM) WRITE (IOUT,510) LEVEL,GEONAM,CARLIR,TYPE(ISTATE(1)) ENDIF IF(IMPX.GT.1) THEN WRITE (IOUT,520) ISTATE(1),TYPE(ISTATE(1)),(ISTATE(I),I=2,14) ENDIF IF((ISTATE(8).EQ.1).AND.(ISTATE(9).EQ.0)) CALL XABORT('GEODIN: ' 1 //'CELL OPTION ACTIVATED WITHOUT SUB-GEOMETRIES.') RETURN * 510 FORMAT(/20H CREATION OF A LEVEL,I3,27H GEOMETRY ON THE DIRECTORY , 1 7HNAMED ',A12,21H' OF THE LCM OBJECT ',A12,12H' WITH TYPE ,A16, 2 1H.) 520 FORMAT(/14H STATE VECTOR:/ 1 7H ITYPE ,I6, 4H (,A16,1H)/ 2 7H LR ,I6,20H (NUMBER OF TUBES)/ 3 7H LX ,I6,22H (X-DIMENSION INDEX)/ 4 7H LY ,I6,22H (Y-DIMENSION INDEX)/ 5 7H LZ ,I6,22H (Z-DIMENSION INDEX)/ 6 7H LREG ,I6,22H (NUMBER OF REGIONS)/ 7 7H MAXMIX,I6,48H (MAX. NB. OF MIXTURES/0=TRANSPARENT GEOMETRY)/ 8 7H ISUB1 ,I6,34H (1=COMMAND CELL IS USED/0=ELSE)/ 9 7H ISUB2 ,I6,29H (NUMBER OF SUB GEOMETRIES)/ 1 7H IMERGE,I6,26H (1=CELL-MERGING/0=ELSE)/ 2 7H ISPLIT,I6,28H (1=MESH-SPLITTING/0=ELSE)/ 3 7H IBIHET,I6,34H (1=DOUBLE HETEROGENEITY/0=ELSE)/ 4 7H ICLUST,I6,28H (NUMBER OF CLUSTER RINGS)/ 5 7H ISECT ,I6,26H (TYPE OF SECTORIZATION)) 530 FORMAT(' ***** Error in GEODIN *****'/ 1 ' Initial number of mixtures ',I10/ 2 ' Cannot be repeated an integer number of times', 3 ' to fill ',I10,' mixtures') END