diff options
Diffstat (limited to 'Dragon/src/APX.f')
| -rw-r--r-- | Dragon/src/APX.f | 556 |
1 files changed, 556 insertions, 0 deletions
diff --git a/Dragon/src/APX.f b/Dragon/src/APX.f new file mode 100644 index 0000000..e900aa4 --- /dev/null +++ b/Dragon/src/APX.f @@ -0,0 +1,556 @@ +*DECK APX + SUBROUTINE APX(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Creation and construction of an APEX database object. +* +*Copyright: +* Copyright (C) 2025 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/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) APEX database object; +* HENTRY(I) I>1 read-only type(L_BURNUP, L_LIBRARY or L_EDIT). +* 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 + USE hdf5_wrap +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,MAXPAR=50,MAXISO=800,NKEYS=6,NREAK=20, + 1 MAXLIN=50,MAXMAC=2) + INTEGER RANK,TYPE,NBYTE,DIMSR(5) + TYPE(C_PTR) IPAPX,IPLB1,IPDEPL,IPEDIT + CHARACTER TEXT4*4,TEXT8*8,TEXT12*12,TEXT20*20,HAPXX*80,HSIGN*12, + 1 KEYWRD(NKEYS)*4,NOMISO(MAXISO)*8,NOMEVO(MAXISO)*12, + 2 NOMREA(NREAK)*4,HSMG*131,NOMMAC(MAXMAC)*8 + DOUBLE PRECISION DFLOTT + LOGICAL LINIT,LWARN,LGNEW(MAXPAR) + INTEGER IDATA(NSTATE),NVALUE(MAXPAR),TYPISO(MAXISO),MUPLET(MAXPAR) + CHARACTER REV*48,DATE*64,HEQUI*80 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, POINTER, DIMENSION(:) :: HMIX + INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: HMIX2 + REAL, ALLOCATABLE, DIMENSION(:) :: TIMES,ENRGA + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPRHS + INTEGER, ALLOCATABLE, DIMENSION(:) :: DIMS_APX + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: PARFMT + CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: PARNAM + CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: TEXT4V1 + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: TEXT8V1 +*---- +* DATA STATEMENTS +*---- + DATA KEYWRD/'NOML','PARA','ISOT','MACR','REAC','; '/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IPRHS(NENTRY)) +*---- +* PARAMETER VALIDATION. +*---- + LINIT=.FALSE. + IF(NENTRY.EQ.0) CALL XABORT('APX: PARAMETERS EXPECTED.') + IF((IENTRY(1).EQ.6).AND.(JENTRY(1).EQ.0)) THEN + IPAPX=KENTRY(1) + LINIT=.TRUE. + HAPXX='DRAGON5_OUTPUT' + CALL hdf5_write_data(IPAPX,"/structure_type",TRIM(HAPXX)) + CALL KDRVER(REV,DATE) + WRITE(6,400) REV + CALL hdf5_write_data(IPAPX,"/structure_version",TRIM(REV)) + CALL hdf5_create_group(IPAPX,'explicit') + ELSE IF(IENTRY(1).EQ.6) THEN + IPAPX=KENTRY(1) + CALL hdf5_info(IPAPX,"/structure_type",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.EQ.99) THEN + TEXT12=HENTRY(1) + CALL XABORT('APX: HDF FILE '//TEXT12//' CANNOT BE READ.') + ENDIF + LINIT=.FALSE. + ELSE + CALL XABORT('APX: APEX HDF5 OBJECT EXPECTED.') + ENDIF + TYPISO(:MAXISO)=0 + IPLB1=C_NULL_PTR + IPDEPL=C_NULL_PTR + IPEDIT=C_NULL_PTR + IPRHS(:NENTRY)=C_NULL_PTR + DO 10 I=2,NENTRY + IF(IENTRY(I).LE.2) THEN + IF(JENTRY(I).NE.2) CALL XABORT('APX: READ-ONLY RHS EXPECTE' + 1 //'D.') + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_LIBRARY') THEN + IPLB1=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_BURNUP') THEN + IPDEPL=KENTRY(I) + ELSE IF(HSIGN.EQ.'L_EDIT') THEN + IPEDIT=KENTRY(I) + ENDIF + ELSE IF(IENTRY(I).EQ.6) THEN + IPRHS(I)=KENTRY(I) + ELSE + CALL XABORT('APX: LCM OR HDF5 OBJECTS EXPECTED AT RHS.') + ENDIF + 10 CONTINUE +*---- +* READ THE INPUT DATA. +*---- +* DEFAULT OPTIONS: + IMPX=1 + IF(LINIT) THEN + NCOMLI=0 + NPAR=0 + NPCHR=0 + NPPNT=0 + NLOC=0 + NPPNTL=0 + NPCHRL=0 + NISO=0 + NMAC=0 + NMIL=0 + NREA=0 + NISOF=0 + NISOP=0 + ELSE + GO TO 300 + ENDIF + ALLOCATE(PARNAM(MAXPAR),PARFMT(MAXPAR)) + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED(1).') + + 30 IF(TEXT8.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT8.EQ.'NOML') THEN + HAPXX=' ' + CALL REDGET(INDIC,NITMA,FLOTT,HAPXX(:72),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(2).') + CALL hdf5_write_data(IPAPX,"/LIBNAME",TRIM(HAPXX)) + ELSE IF(TEXT8.EQ.'PARA') THEN + NPAR=NPAR+1 + IF(NPAR.GT.MAXPAR) CALL XABORT('APX: TOO MANY PARAMETERS.') + PARNAM(NPAR)=' ' + CALL REDGET(INDIC,NITMA,FLOTT,PARNAM(NPAR),DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(3).') + DO 40 I=1,NPAR-1 + IF(PARNAM(NPAR).EQ.PARNAM(I)) CALL XABORT('APX: PARNAM '// + 1 PARNAM(NPAR)//' ALREADY DEFINED(1).') + 40 CONTINUE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(4).') + IF(TEXT4.EQ.'BURN') THEN + IF((PARNAM(NPAR).NE.'Burnup').AND.(PARNAM(NPAR).NE.'Time') + 1 .AND.(PARNAM(NPAR).NE.'Power').AND. + 2 (PARNAM(NPAR).NE.'Exposure').AND.(PARNAM(NPAR).NE.'Flux') + 3 .AND.(PARNAM(NPAR).NE.'Heavy')) THEN + WRITE(HSMG,'(15HAPX: PARAMETER ,A,19H CANNOT BE RECOVERE, + 1 21HD FROM BURNUP OBJECT.)') TRIM(PARNAM(NPAR)) + CALL XABORT(HSMG) + ENDIF + PARFMT(NPAR)='FLOTTANT' + ELSE IF(TEXT4.EQ.'VALE') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(5).') + IF(TEXT8.EQ.'FLOT')THEN + PARFMT(NPAR)='FLOTTANT' + ELSEIF(TEXT8.EQ.'CHAI')THEN + PARFMT(NPAR)='CHAINE' + ELSEIF(TEXT8.EQ.'ENTI')THEN + PARFMT(NPAR)='ENTIER' + ELSE + CALL XABORT('APX: INVALID KEYWORD='//TEXT4//'(1).') + ENDIF + ELSE + CALL XABORT('APX: INVALID KEYWORD='//TEXT4//'(2).') + ENDIF + NVALUE(NPAR)=0 + ELSE IF(TEXT8.EQ.'ISOT') THEN + 80 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(6).') + IF(.NOT.C_ASSOCIATED(IPLB1)) THEN + CALL XABORT('APX: MISSING HMIX OBJECT(1).') + ENDIF + DO 90 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 90 CONTINUE + IF(TEXT8.EQ.'TOUT') THEN + CALL COMISO(-1,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + GO TO 20 + ELSE IF(TEXT8.EQ.'FISS') THEN + CALL COMISO(-2,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE IF(TEXT8.EQ.'PF') THEN + CALL COMISO(-3,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE IF(TEXT8.EQ.'MILI') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTE'// + 1 'D(4).') + CALL COMISO(NITMA,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + ELSE + DO 100 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 100 CONTINUE + NISO=NISO+1 + IF(NISO.GT.MAXISO) CALL XABORT('APX: TOO MANY ISOTOPES.') + NOMISO(NISO)=TEXT8 + TYPISO(NISO)=0 + ENDIF + GO TO 80 + ELSE IF(TEXT8.EQ.'MACR') THEN + NMAC=0 + CALL hdf5_info(IPAPX,"/explicit/MACNAME",RANK,TYPE,NBYTE,DIMSR) + IF(TYPE.NE.99) THEN + CALL hdf5_read_data(IPAPX,"/explicit/MACNAME",TEXT8V1) + NMAC=SIZE(TEXT8V1) + NOMMAC(:NMAC)=TEXT8V1(:NMAC) + DEALLOCATE(TEXT8V1) + ENDIF + NMAC=NMAC+1 + IF(NMAC.GT.MAXMAC) CALL XABORT('APX: MAXMAC OVERFLOW.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(7).') + IF(TEXT4.EQ.'TOUT') THEN + NOMMAC(NMAC)='TOTAL' + ELSE IF(TEXT4.EQ.'REST') THEN + NOMMAC(NMAC)='RESIDUAL' + ELSE + CALL XABORT('APX: INVALID KEYWORD='//TEXT4//'(3).') + ENDIF + CALL hdf5_write_data(IPAPX,"/explicit/MACNAME",NOMMAC(:NMAC)) + ELSE IF(TEXT8.EQ.'REAC') THEN + 110 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(8).') + DO 120 IKEY=1,NKEYS + IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 + 120 CONTINUE + DO 130 IKEY=1,NREA + IF(TEXT8.EQ.NOMREA(IKEY)) GO TO 110 + 130 CONTINUE + NREA=NREA+1 + IF(NREA.GT.NREAK) CALL XABORT('APX: TOO MANY REACTIONS.') + NOMREA(NREA)=TEXT8(:4) + GO TO 110 + ELSE IF(TEXT8.EQ.'NAME') THEN +* READ MIXTURE NAMES. + MAXMIL=30 + ALLOCATE(HMIX(5*MAXMIL)) + 140 CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED'// + 1 '(9).') + IF(TEXT20.EQ.';') GO TO 160 + NMIL=NMIL+1 + IF(NMIL.GT.MAXMIL) THEN + ALLOCATE(HMIX2(5*(MAXMIL+30))) + DO 150 I=1,5*MAXMIL + HMIX2(I)=HMIX(I) + 150 CONTINUE + DEALLOCATE(HMIX) + MAXMIL=MAXMIL+30 + HMIX=>HMIX2 + ENDIF + READ(TEXT20,'(5A4)') (HMIX((NMIL-1)*5+I0),I0=1,5) + GO TO 140 + ELSE IF(TEXT8.EQ.';') THEN + GO TO 160 + ELSE + CALL XABORT('APX: INVALID KEYWORD='//TEXT8//'(4).') + ENDIF + GO TO 20 +* +* ADD THE TIME PARAMETER. + 160 DO 170 I=1,NPAR + IF((PARNAM(I).EQ.'Burnup').OR.(PARNAM(I).EQ.'Exposure')) GO TO 180 + 170 CONTINUE + GO TO 220 + 180 DO 210 I=1,NPAR + IF(PARNAM(I).EQ.'Time') GO TO 220 + 210 CONTINUE + NPAR=NPAR+1 + IF(NPAR.GT.MAXPAR) CALL XABORT('APX: TOO MANY PARAMETERS.') + PARNAM(NPAR)='Time' + PARFMT(NPAR)='FLOTTANT' + NVALUE(NPAR)=0 +*---- +* STORE THE APEX INITIALIZATION INFORMATION. +*---- + 220 CALL hdf5_create_group(IPAPX,'physconst') + IF(NISO.GT.0) THEN + IF(.NOT.C_ASSOCIATED(IPLB1)) THEN + CALL XABORT('APX: MISSING HMIX OBJECT(2).') + ENDIF + CALL COMISO(0,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) + CALL hdf5_write_data(IPAPX,"/explicit/ISONAME",NOMISO(:NISO)) + ALLOCATE(TEXT4V1(NISO)) + DO 230 I=1,NISO + IF(TYPISO(I).EQ.1) THEN + TEXT4V1(I)='OTHE' + ELSE IF(TYPISO(I).EQ.2) THEN + NISOF=NISOF+1 + TEXT4V1(I)='FISS' + ELSE IF(TYPISO(I).EQ.3) THEN + NISOP=NISOP+1 + TEXT4V1(I)='F.P.' + ENDIF + 230 CONTINUE + CALL hdf5_write_data(IPAPX,"/physconst/ISOTYP",TEXT4V1) + CALL hdf5_write_data(IPAPX,"/physconst/ISOTA",NOMISO(:NISO)) + DEALLOCATE(TEXT4V1) + ENDIF + IF(NREA.GT.0) THEN + CALL hdf5_write_data(IPAPX,"/explicit/REANAME",NOMREA(:NREA)) + ENDIF + IF(NPAR.GT.0) THEN + CALL hdf5_write_data(IPAPX,"/Calculation_Content",PARNAM(:NPAR)) + CALL hdf5_create_group(IPAPX,'paramvalues') + CALL hdf5_create_group(IPAPX,'paramdescrip') + CALL hdf5_write_data(IPAPX,"/paramdescrip/NVALUE",NVALUE(:NPAR)) + CALL hdf5_write_data(IPAPX,"/paramdescrip/PARFMT",PARFMT(:NPAR)) + CALL hdf5_write_data(IPAPX,"/paramdescrip/PARNAM",PARNAM(:NPAR)) + ENDIF + DEALLOCATE(PARFMT,PARNAM) +*---- +* FILL THE 'physconst' GROUP. +*---- + IF(C_ASSOCIATED(IPLB1)) THEN + CALL LCMGET(IPLB1,'STATE-VECTOR',IDATA) + NBISO=IDATA(2) + NGA=IDATA(3) + ALLOCATE(ENRGA(NGA+1)) + CALL LCMGET(IPLB1,'ENERGY',ENRGA) + DO 240 I=1,NGA+1 + ENRGA(I)=ENRGA(I)*1.0E-6 + 240 CONTINUE + CALL hdf5_write_data(IPAPX,"/physconst/ENRGA",ENRGA) + DEALLOCATE(ENRGA) + ELSE + NBISO=0 + NGA=0 + NISOTA=0 + ENDIF + NCALS=0 + CALL hdf5_write_data(IPAPX,"/NCALS",NCALS) + GO TO 390 +* END OF APEX FILE INITIALIZATION. ******************************** +*---- +* INPUT AN ELEMENTARY CALCULATION. ******************************* +*---- + 300 CALL hdf5_read_data(IPAPX,"NCALS",NCALS) + NORIG=NCALS + IF(hdf5_group_exists(IPAPX,"/paramdescrip")) THEN + CALL hdf5_get_shape(IPAPX,"/paramdescrip/NVALUE",DIMS_APX) + NPAR=DIMS_APX(1) + DEALLOCATE(DIMS_APX) + ELSE + NPAR=0 + ENDIF + IF(NPAR.GT.0) THEN + CALL hdf5_read_data(IPAPX,"/paramdescrip/PARNAM",PARNAM) + CALL hdf5_read_data(IPAPX,"/paramdescrip/PARFMT",PARFMT) + ENDIF +* + ITIM=0 + LWARN=.FALSE. + IMPX=1 + HEQUI=' ' + IPICK=0 + 310 CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(INDIC.EQ.10) GO TO 350 + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED(10).') + IF(TEXT20.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTED(5).') + ELSE IF(TEXT20.EQ.'SET') THEN + CALL REDGET(INDIC,NITMA,XT,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('APX: REAL DATA EXPECTED(1).') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED' + 1 //'(11).') + 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('APX: S, DAY OR YEAR EXPECTED.') + ENDIF + IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('APX: DEPLETION OBJ' + 1 //'ECT EXPECTED AT RHS.') + CALL LCMLEN(IPDEPL,'DEPL-TIMES',NTIM,ITYLCM) + IF(NTIM.EQ.0) CALL XABORT('APX: NO DEPLETION TIME STEPS.') + ALLOCATE(TIMES(NTIM)) + CALL LCMGET(IPDEPL,'DEPL-TIMES',TIMES) + DO 320 I=1,NTIM + IF(ABS(TIMES(I)-XT).LE.1.0E-4*XT) ITIM=I + 320 CONTINUE + IF(ITIM.EQ.0) THEN + WRITE(HSMG,'(39HAPX: 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(6,430) XT,XT/8.64E-4,TEXT12 + ENDIF + ELSE IF(TEXT20.EQ.'ORIG') THEN + CALL REDGET(INDIC,NORIG,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTED(6).') + ELSE IF(TEXT20.EQ.'EQUI') THEN + CALL REDGET(INDIC,NORIG,FLOTT,HEQUI,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPECTED(12).') + ELSE IF(TEXT20.EQ.';') THEN + GO TO 350 + ELSE IF(TEXT20.EQ.'ICAL') THEN + IPICK=1 + GO TO 350 + ELSE IF(TEXT20.EQ.'WARN') THEN + LWARN=.TRUE. + ELSE + IPAR=0 + DO 330 IKEY=1,NPAR + IF(TEXT20.EQ.PARNAM(IKEY)) THEN + IPAR=IKEY + GO TO 340 + ENDIF + 330 CONTINUE + CALL XABORT('APX: INVALID KEYWORD='//TEXT20//'(5).') + 340 CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT) + IF(PARFMT(IPAR).EQ.'ENTIER') THEN + IF(INDIC.NE.1) CALL XABORT('APX: INTEGER DATA EXPECTE'// + 1 'D(7).') + IF(IMPX.GT.0) WRITE(6,450) TRIM(PARNAM(IPAR)),NITMA + ELSE IF(PARFMT(IPAR).EQ.'FLOTTANT') THEN + IF(INDIC.NE.2) CALL XABORT('APX: REAL DATA EXPECTED(2).') + IF(IMPX.GT.0) WRITE(6,440) TRIM(PARNAM(IPAR)),FLOTT + ELSE IF(PARFMT(IPAR).EQ.'CHAINE') THEN + IF(INDIC.NE.3) CALL XABORT('APX: CHARACTER DATA EXPEC'// + 1 'TED(13).') + IF(IMPX.GT.0) WRITE(6,460) TRIM(PARNAM(IPAR)),TEXT20 + ENDIF + CALL APXPAV(IPAPX,IPAR,NPAR,PARFMT(IPAR),FLOTT,NITMA,TEXT20, + 1 MUPLET(IPAR),LGNEW(IPAR)) + ENDIF + GO TO 310 +*---- +* RECOVER AN ELEMENTARY CALCULATION FROM EDITION. +*---- + 350 IF(NPAR.GT.0) DEALLOCATE(PARFMT,PARNAM) + NCALS=0 + CALL hdf5_info(IPAPX,"/NCALS",RANK,TYPE,NBYTE,DIMSR) + IF(RANK.NE.99) CALL hdf5_read_data(IPAPX,"/NCALS",NCALS) + IF(NENTRY.GE.2) THEN + IF(C_ASSOCIATED(IPRHS(2))) GO TO 360 + ENDIF + IF(IMPX.GT.0) WRITE(6,420) NCALS+1 + IF(ITIM.GT.0) THEN + WRITE(TEXT12,'(8HDEPL-DAT,I4.4)') ITIM + CALL LCMSIX(IPDEPL,TEXT12,1) + ENDIF +* ------------------------------------------- + CALL APXCAL(IMPX,IPAPX,IPDEPL,IPEDIT,HEQUI) +* ------------------------------------------- + IF(ITIM.GT.0) CALL LCMSIX(IPDEPL,' ',2) +*---- +* RECOVER REMAINING GLOBAL PARAMETER AND LOCAL VALUES. +*---- + CALL APXGEP(IPAPX,IPDEPL,IMPX,ITIM,NORIG,NPAR,MUPLET,LGNEW,NVPNEW, + 1 NCALS) + IF(IMPX.GT.0) THEN + CALL APXTOC(IPAPX,IMPX,NLAM,NREA,NBISO,NBMAC,NMIL,NPARR,NVP, + 1 NISOF,NISOP,NISOS,NCALR,NG,NISOTS,NSURFD,NPRC) + ENDIF +*---- +* RECOVER THE CALCULATION INDEX AND SAVE IT IN A CLE-2000 VARIABLE +*---- + IF(IPICK.EQ.1) THEN + CALL REDGET(ITYP,NITMA,FLOTT,TEXT20,DFLOTT) + IF(ITYP.NE.-1) CALL XABORT('APX: OUTPUT INTEGER EXPECTED.') + ITYP=1 + CALL hdf5_read_data(IPAPX,"NCALS",NITMA) + CALL REDPUT(ITYP,NITMA,FLOTT,TEXT20,DFLOTT) + CALL REDGET(ITYP,NITMA,FLOTT,TEXT20,DFLOTT) + IF((ITYP.NE.3).OR.(TEXT20.NE.';')) THEN + CALL XABORT('APX: ; CHARACTER EXPECTED.') + ENDIF + ENDIF + GO TO 390 +*---- +* APEX CONCATENATION. +*---- + 360 DO 370 I=2,NENTRY + IF(.NOT.C_ASSOCIATED(IPRHS(I))) GO TO 370 + NG=0 + CALL APXTOC(IPRHS(I),IMPX,NLAM,NREA,NBISO,NBMAC,NMIL,NPARR,NVP, + 1 NISOF,NISOP,NISOS,NCALR,NG,NISOTS,NSURFD,NPRC) + IF(IMPX.GT.0) WRITE(6,470) NCALS+1,NCALS+NCALR +* --------------------------------------------------------------- + CALL APXCAT(IPAPX,IPRHS(I),NORIG,NPAR,NCALS,MUPLET,LGNEW,LWARN) +* --------------------------------------------------------------- + NCALS=NCALS+NCALR + 370 CONTINUE + CALL hdf5_write_data(IPAPX,"/NCALS",NCALS) + IF(IMPX.GT.0) THEN + CALL APXTOC(IPAPX,IMPX,NLAM,NREA,NBISO,NBMAC,NMIL,NPAR,NVP, + 1 NISOF,NISOP,NISOS,NCALS,NG,NISOTS,NSURFD,NPRC) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 390 DEALLOCATE(IPRHS) + IF(IMPX.GT.3) THEN + WRITE(6,'(/25H APX: APEX FILE CONTENTS:)') + FLUSH(6) + CALL hdf5_list(IPAPX,'') + WRITE(6,'()') + ENDIF + RETURN +* + 400 FORMAT(/14H APX: VERSION=,A) + 420 FORMAT(/1X,43(1H*)/34H * APX: ELEMENTARY CALCULATION NB.,I8, + 1 2H */1X,43(1H*)) + 430 FORMAT(/41H APX: 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(28H APX: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) + 450 FORMAT(28H APX: SET GLOBAL PARAMETER ',A,3H' =,I10) + 460 FORMAT(28H APX: SET GLOBAL PARAMETER ',A,5H' = ',A12,1H') + 470 FORMAT(/1X,55(1H*)/35H * APX: ELEMENTARY CALCULATIONS NB.,I8, + 1 3H TO,I8,2H */1X,55(1H*)) + END |