*DECK COMPO SUBROUTINE COMPO(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) * *----------------------------------------------------------------------- * *Purpose: * Creation and construction of a Multicompo database object. * *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, R. Chambon * *Parameters: input/output * NENTRY number of LCM objects or files used by the operator. * HENTRY name of each LCM object or file: * HENTRY(1): multicompo database object; * HENTRY(I): I>1 read-only type(L_BURNUP, L_LIBRARY, L_EDIT * or L_FLUX). * IENTRY type of each LCM object or file: * =1 LCM memory object; =2 XSM file; =3 sequential binary file; * =4 sequential ascii file. * JENTRY access of each LCM object or file: * =0 the LCM object or file is created; * =1 the LCM object or file is open for modifications; * =2 the LCM object or file is open in read-only mode. * KENTRY LCM object address or file unit number. * *----------------------------------------------------------------------- * USE GANLIB *---- * SUBROUTINE ARGUMENTS *---- INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) TYPE(C_PTR) KENTRY(NENTRY) CHARACTER HENTRY(NENTRY)*12 *---- * LOCAL VARIABLES *---- PARAMETER (NSTATE=40,MAXPAR=50,MAXLIN=50,MAXISO=100,IOUT=6) TYPE(C_PTR) ICPOLD,IPLB1,IPLB2,IPDEPL,IPEDIT,IPEDI2,IPCPO,IPWORK CHARACTER TEXT4*4,TEXT8*8,TEXT12*12,TEXT80*80,HPDEPL*12,NAMDIR*12, 1 HSIGN*12,PARKEY(MAXPAR)*12,PARCHR(MAXPAR)*8,PARTYP(MAXPAR)*4, 2 PARFMT(MAXPAR)*8,PARBIB(MAXPAR)*12,PARKEL(MAXPAR)*12, 3 PARCHL(MAXPAR)*8,PARTYL(MAXPAR)*4,HSMG*131,COMMEN(MAXLIN)*80, 4 NOMISP(MAXISO)*8,NOMEVO(MAXISO)*12 DOUBLE PRECISION DFLOTT LOGICAL LINIT,LGNEW(MAXPAR),LMACRO,LWARN,LISO,LCRED INTEGER ISTATE(NSTATE),MUPLET(MAXPAR),PARMIL(MAXPAR),IST1(NSTATE), 1 IST2(NSTATE),PARCAD(MAXPAR+1),PARPAD(MAXPAR+1),PARCAL(MAXPAR+1), 2 TYPISO(MAXISO) *---- * ALLOCATABLE ARRAYS *---- REAL, ALLOCATABLE, DIMENSION(:) :: TIMES TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPRHS *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IPRHS(NENTRY)) *---- * PARAMETER VALIDATION *---- LINIT=.FALSE. IF(NENTRY.EQ.0) CALL XABORT('COMPO: PARAMETERS EXPECTED.') IF((IENTRY(1).LE.2).AND.(JENTRY(1).EQ.0)) THEN ICPOLD=KENTRY(1) LINIT=.TRUE. HSIGN='L_MULTICOMPO' CALL LCMPTC(ICPOLD,'SIGNATURE',12,HSIGN) ELSE IF(IENTRY(1).LE.2) THEN ICPOLD=KENTRY(1) LINIT=(NENTRY.EQ.1) CALL LCMGTC(ICPOLD,'SIGNATURE',12,HSIGN) IF(HSIGN.NE.'L_MULTICOMPO') THEN TEXT12=HENTRY(1) CALL XABORT('COMPO: SIGNATURE OF '//TEXT12//' IS '//HSIGN// 1 '. L_MULTICOMPO EXPECTED.') ENDIF ELSE CALL XABORT('COMPO: COMPO LCM OBJECT EXPECTED.') ENDIF TYPISO(:MAXISO)=0 IPLB1=C_NULL_PTR IPLB2=C_NULL_PTR IPDEPL=C_NULL_PTR IPEDIT=C_NULL_PTR IPEDI2=C_NULL_PTR IPRHS(:NENTRY)=C_NULL_PTR HPDEPL=' ' LCRED=.FALSE. DO 10 I=2,NENTRY IF(IENTRY(I).LE.2) THEN IF(JENTRY(I).NE.2) CALL XABORT('COMPO: READ-ONLY RHS EXPECTE' 1 //'D.') CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) IF(HSIGN.EQ.'L_LIBRARY') THEN IF(.NOT.C_ASSOCIATED(IPLB1)) THEN IPLB1=KENTRY(I) ELSE IF(.NOT.C_ASSOCIATED(IPLB2)) IPLB2=KENTRY(I) ENDIF ELSE IF(HSIGN.EQ.'L_BURNUP') THEN IPDEPL=KENTRY(I) HPDEPL=HENTRY(I) ELSE IF(HSIGN.EQ.'L_EDIT') THEN IF(.NOT.C_ASSOCIATED(IPEDIT)) THEN IPEDIT=KENTRY(I) ELSE IF(.NOT.C_ASSOCIATED(IPEDI2)) IPEDI2=KENTRY(I) ENDIF ELSE IF(HSIGN.EQ.'L_MACROLIB') THEN CALL LCMOP(IPEDIT,'*EDITION*',0,1,0) LCRED=.TRUE. HSIGN='L_EDIT' CALL LCMPTC(IPEDIT,'SIGNATURE',12,HSIGN) NAMDIR='REF-CASE001' CALL LCMPTC(IPEDIT,'LAST-EDIT',12,NAMDIR) CALL LCMSIX(IPEDIT,NAMDIR,1) CALL LCMSIX(IPEDIT,'MACROLIB',1) CALL LCMEQU(KENTRY(I),IPEDIT) CALL LCMSIX(IPEDIT,' ',2) CALL LCMSIX(IPEDIT,' ',2) ELSE IF(HSIGN.EQ.'L_MULTICOMPO') THEN IPRHS(I)=KENTRY(I) ENDIF ELSE CALL XABORT('COMPO: LCM OBJECT EXPECTED AT RHS.') ENDIF 10 CONTINUE *---- * READ THE INPUT DATA *---- * DEFAULT OPTIONS: IMPX=1 NAMDIR='default' IPCPO=C_NULL_PTR LWARN=.FALSE. LISO=.FALSE. IF(LINIT) THEN MAXCAL=10 NCOMLI=0 NPAR=0 NPCHR=0 NPPNT=0 NLOC=0 NPCHRL=0 NISOP=0 NMIL=0 NGFF=0 NALBP=-1 IDF=-1 PARCAD(1)=1 PARPAD(1)=1 PARCAL(1)=1 ELSE IPICK=0 GO TO 110 ENDIF 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(1).') IF(TEXT8.EQ.'EDIT') THEN * READ THE PRINT INDEX. CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(1).') ELSE IF(TEXT8.EQ.'STEP') THEN * CHANGE THE HIERARCHICAL LEVEL ON THE COMPO. IF(LINIT) THEN MAXCAL=10 NCOMLI=0 NPAR=0 NPCHR=0 NPPNT=0 NLOC=0 NPCHRL=0 NISOP=0 NMIL=0 NGFF=0 NALBP=-1 PARCAD(1)=1 PARPAD(1)=1 PARCAL(1)=1 ENDIF CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF((INDIC.NE.3).OR.(TEXT4.NE.'UP')) CALL XABORT('COMPO: *UP* ' 1 //'EXPECTED.') CALL REDGET(INDIC,NITMA,FLOTT,NAMDIR,DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: DIR-NAME EXPECTED.') IF(IMPX.GT.0) WRITE(IOUT,'(/30H COMPO: CREATE A DIRECTORY NAM, 1 4HED '',A12,36H'' TO STORE THE MULTICOMPO STRUCTURE.)') NAMDIR ELSE IF(TEXT8.EQ.'MAXCAL') THEN CALL REDGET(INDIC,MAXCAL,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(2).') ELSE IF(TEXT8.EQ.'COMM') THEN 40 CALL REDGET(INDIC,NITMA,FLOTT,TEXT80(:72),DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: COMMENTS EXPECTED.') IF(TEXT80(:4).EQ.'ENDC') THEN IPCPO=LCMDID(ICPOLD,NAMDIR) CALL LCMPTC(IPCPO,'COMMENT',80,NCOMLI,COMMEN) IPCPO=C_NULL_PTR GO TO 20 ENDIF NCOMLI=NCOMLI+1 IF(NCOMLI.GT.MAXLIN) CALL XABORT('COMPO: TITLE OVERFLOW.') COMMEN(NCOMLI)=TEXT80(:72) GO TO 40 ELSE IF(TEXT8.EQ.'PARA') THEN NPAR=NPAR+1 IF(NPAR.GT.MAXPAR) CALL XABORT('COMPO: TOO MANY GLOBAL PARAME' 1 //'TERS(1).') CALL REDGET(INDIC,NITMA,FLOTT,PARKEY(NPAR),DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(2).') DO 50 I=1,NPAR-1 IF(PARKEY(NPAR).EQ.PARKEY(I)) CALL XABORT('COMPO: PARKEY '// 1 PARKEY(NPAR)//' ALREADY DEFINED(1).') 50 CONTINUE DO 60 I=1,NLOC IF(PARKEY(NPAR).EQ.PARKEL(I)) CALL XABORT('COMPO: PARKEY '// 1 PARKEY(NPAR)//' ALREADY DEFINED(2).') 60 CONTINUE CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(3).') IF(TEXT4.EQ.'TEMP') THEN NPPNT=NPPNT+1 CALL REDGET(INDIC,NITMA,FLOTT,PARBIB(NPPNT),DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(4).') CALL REDGET(INDIC,PARMIL(NPPNT),FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTE'// 1 'D(3).') PARFMT(NPAR)='REAL' ELSE IF(TEXT4.EQ.'CONC') THEN NPCHR=NPCHR+1 CALL REDGET(INDIC,NITMA,FLOTT,PARCHR(NPCHR),DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(5).') NPPNT=NPPNT+1 CALL REDGET(INDIC,NITMA,FLOTT,PARBIB(NPPNT),DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(6).') CALL REDGET(INDIC,PARMIL(NPPNT),FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTE'// 1 'D(4).') PARFMT(NPAR)='REAL' ELSE IF(TEXT4.EQ.'IRRA') THEN PARFMT(NPAR)='REAL' ELSE IF(TEXT4.EQ.'FLUE') THEN PARFMT(NPAR)='REAL' ELSE IF(TEXT4.EQ.'FLUB') THEN PARFMT(NPAR)='REAL' ELSE IF(TEXT4.EQ.'POWR') THEN PARFMT(NPAR)='REAL' ELSE IF(TEXT4.EQ.'TIME') THEN PARFMT(NPAR)='REAL' ELSE IF(TEXT4.EQ.'VALU') THEN CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(7).') IF(TEXT8.EQ.'REAL')THEN PARFMT(NPAR)='REAL' ELSEIF(TEXT8.EQ.'CHAR')THEN PARFMT(NPAR)='STRING' ELSEIF(TEXT8.EQ.'INTE')THEN PARFMT(NPAR)='INTEGER' ELSE CALL XABORT('COMPO: INVALID KEYWORD='//TEXT8//' (1).') ENDIF ELSE CALL XABORT('COMPO: INVALID KEYWORD='//TEXT4//' (2).') ENDIF PARTYP(NPAR)=TEXT4 PARCAD(NPAR+1)=NPCHR+1 PARPAD(NPAR+1)=NPPNT+1 ELSE IF(TEXT8.EQ.'LOCA') THEN NLOC=NLOC+1 IF(NLOC.GT.MAXPAR) CALL XABORT('COMPO: TOO MANY LOCAL PARAM'// 1 'ETERS(1).') CALL REDGET(INDIC,NITMA,FLOTT,PARKEL(NLOC),DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(8).') DO 70 I=1,NLOC-1 IF(PARKEL(NLOC).EQ.PARKEL(I)) CALL XABORT('COMPO: PARKEY '// 1 PARKEL(NLOC)//' ALREADY DEFINED(3).') 70 CONTINUE DO 80 I=1,NPAR IF(PARKEL(NLOC).EQ.PARKEY(I)) CALL XABORT('COMPO: PARKEY '// 1 PARKEL(NLOC)//' ALREADY DEFINED(4).') 80 CONTINUE CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(9).') IF(TEXT4.EQ.'CONC') THEN NPCHRL=NPCHRL+1 CALL REDGET(INDIC,NITMA,FLOTT,PARCHL(NPCHRL),DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(10).') ELSE IF((TEXT4.NE.'IRRA').AND.(TEXT4.NE.'FLUG').AND. 1 (TEXT4.NE.'FLUB').AND.(TEXT4.NE.'POWR').AND. 2 (TEXT4.NE.'MASL').AND.(TEXT4.NE.'FLUX').AND. 3 (TEXT4.NE.'TEMP')) THEN CALL XABORT('COMPO: INVALID KEYWORD='//TEXT4//' (3).') ENDIF PARTYL(NLOC)=TEXT4 PARCAL(NLOC+1)=NPCHRL+1 ELSE IF(TEXT8.EQ.'ISOT') THEN CALL REDGET(INDIC,NISOP,FLOTT,TEXT8,DFLOTT) IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(5).') IF(NISOP.GT.MAXISO) CALL XABORT('COMPO: MAXISO OVERFLOW.') DO 100 ISO=1,NISOP CALL REDGET(INDIC,NITMA,FLOTT,NOMISP(ISO),DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(11' 1 //').') IF(NOMISP(ISO).EQ.'*MAC*RES') CALL XABORT('COMPO: *MAC*RES CA' 1 //'NNOT BE SELECTED.') 100 CONTINUE ELSE IF(TEXT8.EQ.'GFF') THEN NGFF=-1 ELSE IF(TEXT8.EQ.'NOALBP') THEN NALBP=0 ELSE IF(TEXT8.EQ.'ALBP') THEN NALBP=-1 ELSE IF(TEXT8.EQ.'NOJSURF') THEN IDF=0 ELSE IF(TEXT8.EQ.'JSURF') THEN IDF=-1 ELSE IF(TEXT8.EQ.'INIT') THEN IPCPO=LCMDID(ICPOLD,NAMDIR) CALL LCMSIX(IPCPO,'GLOBAL',1) IF(NPAR.GT.0) THEN CALL LCMPTC(IPCPO,'PARKEY',12,NPAR,PARKEY) CALL LCMPTC(IPCPO,'PARTYP',4,NPAR,PARTYP) CALL LCMPTC(IPCPO,'PARFMT',8,NPAR,PARFMT) ENDIF IF(NPCHR.GT.0) CALL LCMPTC(IPCPO,'PARCHR',8,NPCHR,PARCHR) CALL LCMPUT(IPCPO,'PARCAD',NPAR+1,1,PARCAD) CALL LCMPUT(IPCPO,'PARPAD',NPAR+1,1,PARPAD) IF(NPPNT.GT.0) CALL LCMPUT(IPCPO,'PARMIL',NPPNT,1,PARMIL) IF(NPPNT.GT.0) CALL LCMPTC(IPCPO,'PARBIB',12,NPPNT,PARBIB) CALL LCMSIX(IPCPO,' ',2) * IF(NLOC.GT.0) THEN CALL LCMSIX(IPCPO,'LOCAL',1) CALL LCMPTC(IPCPO,'PARKEY',12,NLOC,PARKEL) CALL LCMPTC(IPCPO,'PARTYP',4,NLOC,PARTYL) IF(NPCHRL.GT.0) CALL LCMPTC(IPCPO,'PARCHR',8,NPCHRL,PARCHL) CALL LCMPUT(IPCPO,'PARCAD',NLOC+1,1,PARCAL) CALL LCMSIX(IPCPO,' ',2) ENDIF * IF(NISOP.GT.0) CALL LCMPTC(IPCPO,'NOMISP',8,NISOP,NOMISP) ISTATE(:NSTATE)=0 ISTATE(1)=NMIL ISTATE(4)=MAXCAL ISTATE(5)=NPAR ISTATE(6)=NLOC ISTATE(7)=NPCHR ISTATE(8)=NPPNT ISTATE(9)=NPCHRL ISTATE(10)=NCOMLI ISTATE(12)=2006 ISTATE(13)=NISOP ISTATE(14)=NGFF ISTATE(15)=NALBP ISTATE(16)=IDF CALL LCMPUT(IPCPO,'STATE-VECTOR',NSTATE,1,ISTATE) IF(IMPX.GT.0) WRITE(IOUT,400) NAMDIR,IMPX,(ISTATE(I),I=1,16) IF(IMPX.GT.4) CALL LCMLIB(IPCPO) ELSE IF(TEXT8.EQ.'DB-STRUC') THEN GO TO 300 ELSE IF(TEXT8.EQ.';') THEN IF(.NOT.C_ASSOCIATED(IPCPO)) CALL XABORT('COMPO: INIT NOT SET') GO TO 390 ELSE CALL XABORT('COMPO: INVALID KEYWORD='//TEXT8//' (4).') ENDIF GO TO 20 * END OF COMPO INITIALIZATION. ********************************** * 110 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) IF((INDIC.EQ.10).AND.(NENTRY.GE.2)) THEN IF(C_ASSOCIATED(IPRHS(2))) GO TO 230 ENDIF IF(INDIC.EQ.10) GO TO 180 IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(12).') IF(TEXT12.EQ.'EDIT') THEN * READ THE PRINT INDEX. CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(6).') ELSE IF (TEXT12.EQ.'ALLX') THEN LISO=.TRUE. ELSE IF(TEXT12.EQ.'STEP') THEN * CHANGE THE HIERARCHICAL LEVEL ON THE COMPO. CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF((INDIC.NE.3).OR.(TEXT4.NE.'UP')) CALL XABORT('COMPO: *UP* ' 1 //'EXPECTED.') CALL REDGET(INDIC,NITMA,FLOTT,NAMDIR,DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: DIR-NAME EXPECTED.') IF(NAMDIR.EQ.'*') THEN IF(.NOT.C_ASSOCIATED(IPEDIT)) CALL XABORT('COMPO: * NOT AL' 1 //'LOWED.') CALL LCMGTC(IPEDIT,'LAST-EDIT',12,NAMDIR) ENDIF CALL LCMLEN(ICPOLD,NAMDIR,ILENG,ITYLCM) IF((ILENG.EQ.0).OR.(ITYLCM.NE.0)) THEN CALL LCMLIB(ICPOLD) CALL XABORT('COMPO: NO '//NAMDIR//' DIRECTORY TO STEP.') ENDIF IF(IMPX.GT.0) WRITE(IOUT,'(/30H COMPO: ACCESS A DIRECTORY NAM, 1 4HED '',A12,36H'' TO STORE THE MULTICOMPO STRUCTURE.)') NAMDIR ELSE IF(TEXT12.EQ.'ORIG') THEN CALL REDGET(INDIC,NORIG,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTED(7).') ELSE GO TO 120 ENDIF GO TO 110 * 120 ITIM=0 IPCPO=LCMGID(ICPOLD,NAMDIR) CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) NCALS=ISTATE(3) NPAR=ISTATE(5) IF(NPAR.GT.MAXPAR) CALL XABORT('COMPO: TOO MANY GLOBAL PARAMETER' 1 //'S(2).') NLOC=ISTATE(6) IF(NLOC.GT.MAXPAR) CALL XABORT('COMPO: TOO MANY LOCAL PARAMETERS' 1 //'(2).') NORIG=ISTATE(3) IF(NPAR.GT.0) THEN CALL LCMSIX(IPCPO,'GLOBAL',1) CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARKEY) CALL LCMGTC(IPCPO,'PARTYP',4,NPAR,PARTYP) CALL LCMGTC(IPCPO,'PARFMT',8,NPAR,PARFMT) CALL LCMSIX(IPCPO,' ',2) ENDIF DO 130 I=1,NPAR MUPLET(I)=0 LGNEW(I)=.FALSE. 130 CONTINUE IF(NENTRY.EQ.1) THEN CALL XABORT('COMPO: NO COMPO OR EDITION OBJECTS AT RHS(1).') ELSE IF(C_ASSOCIATED(IPRHS(2))) THEN GO TO 200 ELSE IF(.NOT.C_ASSOCIATED(IPEDIT)) THEN CALL XABORT('COMPO: NO COMPO OR EDITION OBJECTS AT RHS(2).') ENDIF *---- * INPUT AN ELEMENTARY CALCULATION FROM AN EDITION OBJECT ******** *---- LMACRO=.FALSE. IF(LCRED) LMACRO=.TRUE. NCALS=NCALS+1 IF(IMPX.GT.0) WRITE(IOUT,420) NCALS,NAMDIR * 140 IF(TEXT12.EQ.'SET') THEN CALL REDGET(INDIC,NITMA,XT,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('COMPO: REAL DATA EXPECTED(1).') CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED' 1 //'(13).') IF(TEXT4.EQ.'S') THEN XT=XT*1.0E-8 ELSE IF(TEXT4.EQ.'DAY') THEN XT=XT*8.64E-4 ELSE IF(TEXT4.EQ.'YEAR') THEN XT=XT*3.1536E-1 ELSE CALL XABORT('COMPO: S, DAY OR YEAR EXPECTED.') ENDIF IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('COMPO: DEPLETION O' 1 //'BJECT EXPECTED AT RHS.') CALL LCMLEN(IPDEPL,'DEPL-TIMES',NTIM,ITYLCM) IF(NTIM.EQ.0) CALL XABORT('COMPO: NO DEPLETION TIME STEPS.') ALLOCATE(TIMES(NTIM)) CALL LCMGET(IPDEPL,'DEPL-TIMES',TIMES) DO 150 I=1,NTIM IF(ABS(TIMES(I)-XT).LE.1.0E-4*XT) ITIM=I 150 CONTINUE IF(ITIM.EQ.0) THEN WRITE(HSMG,'(41HCOMPO: UNABLE TO FIND A DEPLETION DIRECTO, 1 12HRY AT TIME =,1P,E12.4,5H DAY.)') XT/8.64E-4 CALL XABORT(HSMG) ENDIF DEALLOCATE(TIMES) IF(IMPX.GT.0) THEN WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM WRITE(IOUT,430) XT,XT/8.64E-4,TEXT12 ENDIF ELSE IF(TEXT12.EQ.'MACRO') THEN LMACRO=.TRUE. ELSE IF(TEXT12.EQ.';') THEN GO TO 180 ELSE IF(TEXT12.EQ.'ICAL') THEN IPICK=1 GO TO 180 ELSE DO 160 IKEY=1,NPAR IF(TEXT12.EQ.PARKEY(IKEY)) THEN IPAR=IKEY GO TO 170 ENDIF 160 CONTINUE CALL XABORT('COMPO: INVALID KEYWORD='//TEXT12//' (5).') 170 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) IF(PARFMT(IPAR).EQ.'INTEGER') THEN IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTE'// 1 'D(8).') IF(IMPX.GT.0) WRITE(IOUT,450) PARKEY(IPAR),NITMA ELSE IF(PARFMT(IPAR).EQ.'REAL') THEN IF(INDIC.NE.2) CALL XABORT('COMPO: REAL DATA EXPECTED(2).') IF(IMPX.GT.0) WRITE(IOUT,440) PARKEY(IPAR),FLOTT ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPEC'// 1 'TED(14).') IF(IMPX.GT.0) WRITE(IOUT,460) PARKEY(IPAR),TEXT12 ENDIF CALL LCMSIX(IPCPO,'GLOBAL',1) CALL COMPAV(IPCPO,IPAR,NPAR,PARFMT(IPAR),FLOTT,NITMA,TEXT12, 1 MUPLET(IPAR),LGNEW(IPAR)) CALL LCMSIX(IPCPO,' ',2) ENDIF CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(15).') GO TO 140 *---- * RECOVER AN ELEMENTARY CALCULATION *---- 180 IF(IMPX.GT.0) THEN WRITE(IOUT,'(24H COMPO: PROCESS DEPL-DAT,I4.4,11H DIRECTORY.)') 1 ITIM ENDIF IF(ITIM.GT.0) THEN WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM CALL LCMSIX(IPDEPL,TEXT12,1) ENDIF CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) CALL LCMSIX(IPEDIT,TEXT12,1) CALL LCMLEN(IPEDIT,'SIGNATURE',ILENG,ITYLCM) IF(ILENG.EQ.0) LMACRO=.TRUE. CALL LCMSIX(IPEDIT,' ',2) * -------------------------------------------------------------- CALL COMCAL(IMPX,IPCPO,IPDEPL,IPEDIT,IPEDI2,LMACRO,LISO,ITRES) * -------------------------------------------------------------- IF(ITIM.GT.0) CALL LCMSIX(IPDEPL,' ',2) *---- * RECOVER THE DEPLETION CHAIN *---- CALL LCMGTC(IPEDIT,'LAST-EDIT',12,TEXT12) CALL LCMSIX(IPEDIT,TEXT12,1) CALL LCMLEN(IPEDIT,'DEPL-CHAIN',ILENG1,ITYLCM) IF(ILENG1.NE.0) THEN CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) NISOP=ISTATE(13) IF(NISOP.GT.0) THEN CALL LCMGTC(IPCPO,'NOMISP',8,NISOP,NOMISP) CALL COMISO(0,MAXISO,IPEDIT,NISOP,NOMISP,NOMEVO,TYPISO) ENDIF CALL LCMOP(IPWORK,'*TEMPORARY*',0,1,0) CALL COMDEP(IMPX,IPEDIT,IPWORK,ITRES,NISOP,NOMEVO) CALL LCMLEN(IPCPO,'DEPL-CHAIN',ILENG2,ITYLCM) IF(ILENG2.NE.0) THEN CALL LCMSIX(IPWORK,'DEPL-CHAIN',1) CALL LCMGET(IPWORK,'STATE-VECTOR',IST1) CALL LCMSIX(IPWORK,' ',2) CALL LCMSIX(IPCPO,'DEPL-CHAIN',1) CALL LCMGET(IPCPO,'STATE-VECTOR',IST2) CALL LCMSIX(IPCPO,' ',2) DO 190 I=1,NSTATE IF(IST1(I).NE.IST2(I)) THEN WRITE(HSMG,'(39HCOMPO: INVALID STATE-VECTOR COMPONENT (, 1 I2,40H) FOR DEPL-CHAIN DATA IN EDITION OBJECT.)') I CALL XABORT(HSMG) ENDIF 190 CONTINUE ELSE CALL LCMEQU(IPWORK,IPCPO) ENDIF CALL LCMCL(IPWORK,2) ENDIF CALL LCMSIX(IPEDIT,' ',2) *---- * RECOVER REMAINING GLOBAL AND LOCAL PARAMETERS *---- CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) NMIL=ISTATE(1) CALL COMGEP(IPCPO,IPDEPL,IPLB1,IPLB2,IPEDIT,IMPX,ITIM,NORIG,NPAR, 1 NLOC,NMIL,MUPLET,LGNEW) * IF(IMPX.GT.0) WRITE(IOUT,400) NAMDIR,IMPX,(ISTATE(I),I=1,16) IF(IMPX.GT.4) CALL LCMLIB(IPCPO) IF(LCRED) CALL LCMCL(IPEDIT,2) *---- * RECOVER THE CALCULATION INDEX AND SAVE IT IN A CLE-2000 VARIABLE *---- IF(IPICK.EQ.1) THEN CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) IF(ITYP.NE.-1) CALL XABORT('COMPO: OUTPUT INTEGER EXPECTED.') ITYP=1 NITMA=ISTATE(3) CALL REDPUT(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) IF((ITYP.NE.3).OR.(TEXT12.NE.';')) THEN CALL XABORT('COMPO: ; CHARACTER EXPECTED.') ENDIF ENDIF GO TO 390 *---- * INPUT A SET OF ELEMENTARY CALCULATIONS FROM A COMPO ********** *---- 200 IF(TEXT12.EQ.';') THEN GO TO 230 ELSE IF(TEXT12.EQ.'WARNING-ONLY') THEN LWARN=.TRUE. ELSE DO 210 IKEY=1,NPAR IF(TEXT12.EQ.PARKEY(IKEY)) THEN IPAR=IKEY GO TO 220 ENDIF 210 CONTINUE CALL XABORT('COMPO: INVALID KEYWORD='//TEXT12//' (6).') 220 IF(PARTYP(IPAR).NE.'VALU') CALL XABORT('COMPO: '//TEXT12// 1 ' IS NOT OF VALU TYPE.') CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) IF(PARFMT(IPAR).EQ.'INTEGER') THEN IF(INDIC.NE.1) CALL XABORT('COMPO: INTEGER DATA EXPECTE'// 1 'D(9).') IF(IMPX.GT.0) WRITE(IOUT,450) PARKEY(IPAR),NITMA ELSE IF(PARFMT(IPAR).EQ.'REAL') THEN IF(INDIC.NE.2) CALL XABORT('COMPO: REAL DATA EXPECTED(3).') IF(IMPX.GT.0) WRITE(IOUT,440) PARKEY(IPAR),FLOTT ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPEC'// 1 'TED(16).') IF(IMPX.GT.0) WRITE(IOUT,460) PARKEY(IPAR),TEXT12 ENDIF CALL LCMSIX(IPCPO,'GLOBAL',1) CALL COMPAV(IPCPO,IPAR,NPAR,PARFMT(IPAR),FLOTT,NITMA,TEXT12, 1 MUPLET(IPAR),LGNEW(IPAR)) CALL LCMSIX(IPCPO,' ',2) ENDIF CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) IF(INDIC.NE.3) CALL XABORT('COMPO: CHARACTER DATA EXPECTED(17).') GO TO 200 230 DO 240 I=2,NENTRY IF(.NOT.C_ASSOCIATED(IPRHS(I))) GO TO 240 IPRHS(I)=LCMGID(IPRHS(I),NAMDIR) CALL LCMGET(IPRHS(I),'STATE-VECTOR',ISTATE) IF(IMPX.GT.0) WRITE(IOUT,470) NCALS+1,NCALS+ISTATE(3),NAMDIR * --------------------------------------------------------- CALL COMCAT(IPCPO,IPRHS(I),NORIG,NPAR,MUPLET,LGNEW,LWARN) * --------------------------------------------------------- NCALS=NCALS+ISTATE(3) 240 CONTINUE * IF(IMPX.GT.0) THEN CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) WRITE(IOUT,400) NAMDIR,IMPX,(ISTATE(I),I=1,15) ENDIF IF(IMPX.GT.4) CALL LCMLIB(IPCPO) GO TO 390 *---- * Display the COMPO structure********** *---- 300 IPCPO=LCMGID(ICPOLD,NAMDIR) CALL COMSDB(IMPX,IPCPO) CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) IF(TEXT8.NE.';') CALL XABORT('COMPO: ";" expected.') *---- * SCRATCH STORAGE DEALLOCATION *---- 390 DEALLOCATE(IPRHS) RETURN * 400 FORMAT(/29H COMPO: STATE-VECTOR VALUES (,A12,1H)/1X,26(1H-)/ 1 7H IMPX ,I7,22H (0=NO PRINT/1=SHORT)/ 2 7H NMIL ,I7,28H (NB. OF MIXTURES IN COMPO)/ 3 7H NG ,I7,33H (NB. OF ENERGY GROUPS IN COMPO)/ 4 7H NCALS ,I7,34H (NB. OF ELEMENTARY CALCULATIONS)/ 5 7H MAXCAL,I7,42H (MAXIMUM NB. OF ELEMENTARY CALCULATIONS)/ 6 7H NPAR ,I7,28H (NB. OF GLOBAL PARAMETERS)/ 7 7H NLOC ,I7,27H (NB. OF LOCAL PARAMETERS)/ 8 7H NPCHR ,I7,47H (NB. OF GLOBAL PARAMETERS LINKED TO ISOTOPES)/ 9 7H NPPNT ,I7,48H (NB. OF GLOBAL PARAMETERS LINKED TO LIBRARIES)/ 1 7H NPCHRL,I7,46H (NB. OF LOCAL PARAMETERS LINKED TO ISOTOPES)/ 2 7H NCOMLI,I7,27H (NB. OF LINES OF COMMENT)/ 3 7H LGEOM ,I7,34H (0/1: GEOMETRIES ABSENT/PRESENT)/ 4 7H LSPEC ,I7,34H (COMPO SPECIFICATION IDENTIFIER)/ 5 7H NISOP ,I7,47H (NB. OF USER-REQUESTED PARTICULARIZED ISOTOPE, 6 2HS)/ 7 7H NGFF ,I7,38H (0: NO GENERALIZED FORM FACTOR INFO)/ 8 7H NALBP ,I7,30H (0: NO PHYSICAL ALBEDO INFO)/ 9 7H IDF ,I7,35H (0: NO DISCONTINUITY FACTOR INFO)) 420 FORMAT(/1X,63(1H*)/36H * COMPO: ELEMENTARY CALCULATION NB.,I8, 1 4X,1H(,A12,3H) */1X,63(1H*)) 430 FORMAT(/43H COMPO: RECOVER INFORMATION RELATED TO TIME,1P,E12.4, 1 8H E+8 S (,E12.4,32H DAY) FROM LCM DIRECTORY NAMED ',A12,2H'.) 440 FORMAT(30H COMPO: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) 450 FORMAT(30H COMPO: SET GLOBAL PARAMETER ',A,3H' =,I10) 460 FORMAT(30H COMPO: SET GLOBAL PARAMETER ',A,5H' = ',A12,1H') 470 FORMAT(/1X,75(1H*)/37H * COMPO: ELEMENTARY CALCULATIONS NB.,I8, 1 3H TO,I8,4X,1H(,A12,3H) */1X,75(1H*)) END