diff options
Diffstat (limited to 'Trivac/src/GEODIN.f')
| -rwxr-xr-x | Trivac/src/GEODIN.f | 765 |
1 files changed, 765 insertions, 0 deletions
diff --git a/Trivac/src/GEODIN.f b/Trivac/src/GEODIN.f new file mode 100755 index 0000000..7d8725e --- /dev/null +++ b/Trivac/src/GEODIN.f @@ -0,0 +1,765 @@ +*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 |