summaryrefslogtreecommitdiff
path: root/Dragon/src/COMPO.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/COMPO.f')
-rw-r--r--Dragon/src/COMPO.f711
1 files changed, 711 insertions, 0 deletions
diff --git a/Dragon/src/COMPO.f b/Dragon/src/COMPO.f
new file mode 100644
index 0000000..b8f8fcc
--- /dev/null
+++ b/Dragon/src/COMPO.f
@@ -0,0 +1,711 @@
+*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
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:22:59 +0000