*DECK SAP SUBROUTINE SAP(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) * *----------------------------------------------------------------------- * *Purpose: * Creation and construction of a Saphyb database object. * *Copyright: * Copyright (C) 2007 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) Saphyb 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 (NDIMSA=50,MAXPAR=50,MAXISO=800,NKEYS=8,NREAK=20, 1 MAXLIN=50,MAXMAC=2) TYPE(C_PTR) IPSAP,IPLB1,IPLB2,IPDEPL,IPEDIT,IPFLUX CHARACTER TEXT4*4,TEXT8*8,TEXT12*12,TEXT20*20,HSSAP*80,HSIGN*12, 1 KEYWRD(NKEYS)*4,PARNAM(MAXPAR)*80,PARKEY(MAXPAR)*4, 2 PARCHR(MAXPAR)*8,PARTYP(MAXPAR)*4,PARFMT(MAXPAR)*8, 3 PARBIB(MAXPAR)*12,PARNAL(MAXPAR)*80,PARKEL(MAXPAR)*4, 4 PARCHL(MAXPAR)*8,PARTYL(MAXPAR)*4,PARFML(MAXPAR)*8, 5 NOMISO(MAXISO)*8,NOMEVO(MAXISO)*12,REAKEY(NREAK)*4, 6 REANAM(NREAK)*10,NOMREA(NREAK)*12,HSMG*131,COMMEN(MAXLIN)*80, 7 NOMMAC(MAXMAC)*8 DOUBLE PRECISION DFLOTT LOGICAL LINIT,LWARN,LCRON,LGNEW(MAXPAR) INTEGER IDATA(NDIMSA),PARMIL(MAXPAR),NVALUE(MAXPAR), 1 PARCAD(MAXPAR+1),PARPAD(MAXPAR+1),PARCAL(MAXPAR+1), 2 PARPAL(MAXPAR+1),TYPISO(MAXISO),MUPLET(MAXPAR),TYPMAC(MAXMAC) *---- * ALLOCATABLE ARRAYS *---- INTEGER, POINTER, DIMENSION(:) :: HMIX INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: HMIX2 REAL, ALLOCATABLE, DIMENSION(:) :: TIMES LOGICAL, ALLOCATABLE, DIMENSION(:) :: LOG TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPRHS *---- * DATA STATEMENTS *---- DATA KEYWRD/'NOML','PARA','LOCA','ISOT','MACR','REAC','NAME', 1 '; '/ DATA REAKEY/'TOTA','ABSO','SNNN','FISS','CHI ','NUFI','ENER', 1 'EFIS','EGAM','FUIT','SELF','DIFF','PROF','TRAN', 2 'FUIR','FUIZ','NP ','NT ','NA ','TOP1'/ DATA REANAM/'TOTALE ','ABSORPTION','EXCESS ','FISSION ', 1 'SPECTRE ','NU*FISSION','ENERGIE ','ENERGIE F.', 2 'ENERGIE G.','FUITES ','SELF ','DIFFUSION ', 3 'PROFIL ','TRANSFERT ','FUITES R ','FUITES Z ', 4 'NP ','NT ','NA ','TOTALE P1 '/ *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IPRHS(NENTRY)) *---- * PARAMETER VALIDATION. *---- LINIT=.FALSE. IF(NENTRY.EQ.0) CALL XABORT('SAP: PARAMETERS EXPECTED.') IF((IENTRY(1).LE.2).AND.(JENTRY(1).EQ.0)) THEN IPSAP=KENTRY(1) LINIT=.TRUE. HSSAP='SAPHYB LIBRARY VER. 0.02' CALL LCMPTC(IPSAP,'TITLE',80,HSSAP) TEXT12='L_SAPHYB' CALL LCMPTC(IPSAP,'SIGNATURE',12,TEXT12) ELSE IF(IENTRY(1).LE.2) THEN IPSAP=KENTRY(1) CALL LCMGTC(IPSAP,'TITLE',80,HSSAP) IF(HSSAP(:6).NE.'SAPHYB') THEN TEXT12=HENTRY(1) CALL XABORT('SAP: SIGNATURE OF '//TEXT12//' IS '// 1 HSSAP(:6)//'. SAPHYB EXPECTED.') ENDIF LINIT=.FALSE. ELSE CALL XABORT('SAP: SAPHYB LCM OBJECT EXPECTED.') ENDIF TYPISO(:MAXISO)=0 IPLB1=C_NULL_PTR IPLB2=C_NULL_PTR IPDEPL=C_NULL_PTR IPEDIT=C_NULL_PTR IPFLUX=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('SAP: 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) ELSE IF(HSIGN.EQ.'L_EDIT') THEN IPEDIT=KENTRY(I) ELSE IF(HSIGN.EQ.'L_FLUX') THEN IPFLUX=KENTRY(I) ELSE IF(HSIGN.EQ.'L_SAPHYB') THEN IPRHS(I)=KENTRY(I) ENDIF ELSE CALL XABORT('SAP: LCM OBJECT 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 PARCAD(1)=1 PARPAD(1)=1 PARCAL(1)=1 PARPAL(1)=1 ELSE GO TO 300 ENDIF 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: 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('SAP: INTEGER DATA EXPECTED(1).') ELSE IF(TEXT8.EQ.'COMM') THEN 35 CALL REDGET(INDIC,NITMA,FLOTT,HSSAP(:72),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: COMMENTS EXPECTED.') IF(HSSAP(:4).EQ.'ENDC') THEN CALL LCMPTC(IPSAP,'COMMEN',80,NCOMLI,COMMEN) GO TO 20 ENDIF NCOMLI=NCOMLI+1 IF(NCOMLI.GT.MAXLIN) CALL XABORT('SAP: TITLE OVERFLOW.') COMMEN(NCOMLI)=HSSAP(:72) GO TO 35 ELSE IF(TEXT8.EQ.'NOML') THEN HSSAP=' ' CALL REDGET(INDIC,NITMA,FLOTT,HSSAP(:72),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(2).') CALL LCMPTC(IPSAP,'NOMLIB',80,HSSAP) ELSE IF(TEXT8.EQ.'PARA') THEN NPAR=NPAR+1 IF(NPAR.GT.MAXPAR) CALL XABORT('SAP: TOO MANY PARAMETERS.') PARNAM(NPAR)=' ' CALL REDGET(INDIC,NITMA,FLOTT,PARNAM(NPAR)(:72),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(3).') DO 40 I=1,NPAR-1 IF(PARNAM(NPAR).EQ.PARNAM(I)) CALL XABORT('SAP: PARNAM '// 1 PARNAM(NPAR)//' ALREADY DEFINED(1).') 40 CONTINUE CALL REDGET(INDIC,NITMA,FLOTT,PARKEY(NPAR),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(4).') DO 50 I=1,NPAR-1 IF(PARKEY(NPAR).EQ.PARKEY(I)) CALL XABORT('SAP: PARKEY '// 1 PARKEY(NPAR)//' ALREADY DEFINED(1).') 50 CONTINUE CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(4).') IF(TEXT4.EQ.'TEMP') THEN NPPNT=NPPNT+1 CALL REDGET(INDIC,NITMA,FLOTT,PARBIB(NPPNT),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(5).') CALL REDGET(INDIC,PARMIL(NPPNT),FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTE'// 1 'D(2).') PARFMT(NPAR)='FLOTTANT' ELSE IF(TEXT4.EQ.'CONC') THEN NPCHR=NPCHR+1 CALL REDGET(INDIC,NITMA,FLOTT,PARCHR(NPCHR),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(6).') NPPNT=NPPNT+1 CALL REDGET(INDIC,NITMA,FLOTT,PARBIB(NPPNT),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(7).') CALL REDGET(INDIC,PARMIL(NPPNT),FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTE'// 1 'D(3).') PARFMT(NPAR)='FLOTTANT' ELSE IF(TEXT4.EQ.'IRRA') THEN PARFMT(NPAR)='FLOTTANT' ELSE IF(TEXT4.EQ.'FLUX') THEN PARFMT(NPAR)='FLOTTANT' ELSE IF(TEXT4.EQ.'FLUB') THEN PARFMT(NPAR)='FLOTTANT' ELSE IF(TEXT4.EQ.'PUIS') THEN PARFMT(NPAR)='FLOTTANT' ELSE IF(TEXT4.EQ.'TIME') THEN PARFMT(NPAR)='FLOTTANT' ELSE IF(TEXT4.EQ.'VALE') THEN CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(8).') 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('SAP: INVALID KEYWORD='//TEXT4//'(1).') ENDIF ELSE CALL XABORT('SAP: INVALID KEYWORD='//TEXT4//'(2).') ENDIF NVALUE(NPAR)=0 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('SAP: TOO MANY LOCAL VAR'// 1 'IABLES.') PARNAL(NLOC)=' ' CALL REDGET(INDIC,NITMA,FLOTT,PARNAL(NLOC)(:72),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(9).') DO 60 I=1,NLOC-1 IF(PARNAL(NLOC).EQ.PARNAL(I)) CALL XABORT('SAP: PARNAM '// 1 PARNAL(NLOC)//' ALREADY DEFINED(2).') 60 CONTINUE CALL REDGET(INDIC,NITMA,FLOTT,PARKEL(NLOC),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(10).') DO 70 I=1,NLOC-1 IF(PARKEL(NLOC).EQ.PARKEL(I)) CALL XABORT('SAP: PARKEY '// 1 PARKEL(NLOC)//' ALREADY DEFINED(2).') 70 CONTINUE CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(11).') IF(TEXT4.EQ.'CONC') THEN NPCHRL=NPCHRL+1 CALL REDGET(INDIC,NITMA,FLOTT,PARCHL(NPCHRL),DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(12).') ELSE IF((TEXT4.NE.'IRRA').AND.(TEXT4.NE.'FLUG').AND. 1 (TEXT4.NE.'FLUB').AND.(TEXT4.NE.'PUIS').AND. 2 (TEXT4.NE.'MASL').AND.(TEXT4.NE.'FLUX').AND. 3 (TEXT4.NE.'EQUI').AND.(TEXT4.NE.'TEMP')) THEN CALL XABORT('SAP: INVALID KEYWORD='//TEXT4//'(3).') ENDIF PARFML(NLOC)='FLOTTANT' PARTYL(NLOC)=TEXT4 PARCAL(NLOC+1)=NPCHRL+1 PARPAL(NLOC+1)=NPPNTL+1 ELSE IF(TEXT8.EQ.'ISOT') THEN 80 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(13).') 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('SAP: 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('SAP: TOO MANY ISOTOPES.') NOMISO(NISO)=TEXT8 TYPISO(NISO)=0 ENDIF GO TO 80 ELSE IF(TEXT8.EQ.'MACR') THEN CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(14).') CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(15).') NMACRT=0 IF(TEXT4.EQ.'TOUT') THEN NMACRT=1 ELSE IF(TEXT4.EQ.'REST') THEN NMACRT=2 ELSE CALL XABORT('SAP: INVALID KEYWORD='//TEXT4//'(3).') ENDIF CALL LCMSIX(IPSAP,'contenu',1) IF(NMAC.GT.0) THEN CALL LCMGTC(IPSAP,'NOMMAC',8,NMAC,NOMMAC) CALL LCMGET(IPSAP,'TYPMAC',TYPMAC) ENDIF NMAC=NMAC+1 IF(NMAC.GT.MAXMAC) CALL XABORT('SAP: MAXMAC OVERFLOW.') NOMMAC(NMAC)=TEXT8 TYPMAC(NMAC)=NMACRT CALL LCMPTC(IPSAP,'NOMMAC',8,NMAC,NOMMAC) CALL LCMPUT(IPSAP,'TYPMAC',NMAC,1,TYPMAC) CALL LCMSIX(IPSAP,' ',2) ELSE IF(TEXT8.EQ.'REAC') THEN 110 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(16).') DO 120 IKEY=1,NKEYS IF(TEXT8.EQ.KEYWRD(IKEY)) GO TO 30 120 CONTINUE NREA=NREA+1 IF(NREA.GT.NREAK) CALL XABORT('SAP: TOO MANY REACTIONS.') DO 130 IKEY=1,NREAK NOMREA(NREA)=REANAM(IKEY) IF(TEXT8.EQ.REAKEY(IKEY)) GO TO 110 130 CONTINUE NOMREA(NREA)=TEXT8 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('SAP: CHARACTER DATA EXPECTED'// 1 '(17).') IF(TEXT20.EQ.';') THEN CALL LCMSIX(IPSAP,'geom',1) IF(NMIL.GT.0) CALL LCMPUT(IPSAP,'NOMMIL',5*NMIL,3,HMIX) CALL LCMSIX(IPSAP,' ',2) DEALLOCATE(HMIX) GO TO 160 ENDIF 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('SAP: INVALID KEYWORD='//TEXT8//'(4).') ENDIF GO TO 20 * * ADD THE TIME PARAMETER. 160 DO 170 I=1,NPAR IF((PARTYP(I).EQ.'IRRA').OR.(PARTYP(I).EQ.'FLUB')) GO TO 180 170 CONTINUE GO TO 220 180 DO 210 I=1,NPAR IF(PARTYP(I).EQ.'TIME') GO TO 220 210 CONTINUE NPAR=NPAR+1 IF(NPAR.GT.MAXPAR) CALL XABORT('SAP: TOO MANY PARAMETERS.') PARNAM(NPAR)='TEMPS' PARKEY(NPAR)='TIME' PARTYP(NPAR)='TIME' PARFMT(NPAR)='FLOTTANT' NVALUE(NPAR)=0 PARCAD(NPAR+1)=PARCAD(1)+NPCHR PARPAD(NPAR+1)=PARPAD(1)+NPPNT *---- * STORE THE SAPHYB INITIALIZATION INFORMATION. *---- 220 CALL LCMSIX(IPSAP,'contenu',1) IF(NISO.GT.0) THEN CALL COMISO(0,MAXISO,IPLB1,NISO,NOMISO,NOMEVO,TYPISO) CALL LCMPTC(IPSAP,'NOMISO',8,NISO,NOMISO) DO 230 I=1,NISO IF(TYPISO(I).EQ.2) NISOF=NISOF+1 IF(TYPISO(I).EQ.3) NISOP=NISOP+1 230 CONTINUE ENDIF IF(NREA.GT.0) CALL LCMPTC(IPSAP,'NOMREA',12,NREA,NOMREA) CALL LCMSIX(IPSAP,' ',2) * IF(NPAR.GT.0) THEN CALL LCMSIX(IPSAP,'paramdescrip',1) CALL LCMPUT(IPSAP,'NPAR',1,1,NPAR) CALL LCMPUT(IPSAP,'NPCHR',1,1,NPCHR) CALL LCMPTC(IPSAP,'PARNAM',80,NPAR,PARNAM) CALL LCMPTC(IPSAP,'PARKEY',4,NPAR,PARKEY) CALL LCMPTC(IPSAP,'PARTYP',4,NPAR,PARTYP) CALL LCMPTC(IPSAP,'PARFMT',8,NPAR,PARFMT) IF(NPCHR.GT.0) THEN CALL LCMPTC(IPSAP,'PARCHR',8,NPCHR,PARCHR) ELSE * dummy record to make Lisaph happy PARCHR(1)=' ' PARCHR(2)=' ' CALL LCMPTC(IPSAP,'PARCHR',8,2,PARCHR) ENDIF CALL LCMPUT(IPSAP,'NVALUE',NPAR,1,NVALUE) CALL LCMPUT(IPSAP,'PARCAD',NPAR+1,1,PARCAD) CALL LCMPUT(IPSAP,'PARPAD',NPAR+1,1,PARPAD) IF(NPPNT.GT.0) CALL LCMPUT(IPSAP,'PARMIL',NPPNT,1,PARMIL) IF(NPPNT.GT.0) CALL LCMPTC(IPSAP,'PARBIB',12,NPPNT,PARBIB) CALL LCMSIX(IPSAP,' ',2) ENDIF * IF(NLOC.GT.0) THEN CALL LCMSIX(IPSAP,'varlocdescri',1) CALL LCMPUT(IPSAP,'NPAR',1,1,NLOC) CALL LCMPUT(IPSAP,'NPCHR',1,1,NPCHRL) CALL LCMPTC(IPSAP,'PARNAM',80,NLOC,PARNAL) CALL LCMPTC(IPSAP,'PARKEY',4,NLOC,PARKEL) CALL LCMPTC(IPSAP,'PARTYP',4,NLOC,PARTYL) CALL LCMPTC(IPSAP,'PARFMT',8,NLOC,PARFML) IF(NPCHRL.GT.0) THEN CALL LCMPTC(IPSAP,'PARCHR',8,NPCHRL,PARCHL) ELSE * dummy record to make Lisaph happy PARCHL(1)=' ' PARCHL(2)=' ' CALL LCMPTC(IPSAP,'PARCHR',8,2,PARCHL) ENDIF CALL LCMPUT(IPSAP,'PARCAD',NLOC+1,1,PARCAL) CALL LCMPUT(IPSAP,'PARPAD',NLOC+1,1,PARPAL) CALL LCMSIX(IPSAP,' ',2) ENDIF *---- * FILL THE 'constphysiq' DIRECTORY. *---- IF(C_ASSOCIATED(IPLB1)) THEN CALL LCMGET(IPLB1,'STATE-VECTOR',IDATA) NBISO=IDATA(2) NGA=IDATA(3) CALL SAPFWC(IPSAP,IPLB1,MAXISO,NBISO,NGA,NISOTA) ELSE NBISO=0 NGA=0 NISOTA=0 ENDIF *---- * CREATE A dummy 'geom' DIRECTORY TO MAKE LISAPH HAPPY. *---- CALL LCMSIX(IPSAP,'geom',1) IDATA(1)=4040200 CALL LCMPUT(IPSAP,'GEOTYP',1,1,IDATA) IDATA(1)=1 IDATA(2)=2 IDATA(3)=3 IDATA(4)=4 IDATA(5)=5 CALL LCMPUT(IPSAP,'FIRSTS',5,1,IDATA) IDATA(1)=1 IDATA(2)=3 CALL LCMPUT(IPSAP,'XNP',2,1,IDATA) FLOTT=1.0 CALL LCMPUT(IPSAP,'XVOLMR',1,2,FLOTT) FLOTT=1.0 CALL LCMPUT(IPSAP,'XNUR',1,2,FLOTT) CALL LCMSIX(IPSAP,' ',2) *---- * FILL THE 'contenu' DIRECTORY WITH LOGICAL INFORMATION. *---- CALL LCMSIX(IPSAP,'contenu',1) IF(NISOTA*NMAC.GT.0) THEN ALLOCATE(LOG(NISOTA*NMAC)) LOG(:NISOTA*NMAC)=.FALSE. CALL LCMPUT(IPSAP,'LISMAC',NISOTA*NMAC,5,LOG) DEALLOCATE(LOG) ENDIF IF(NMIL*NISO.GT.0) THEN ALLOCATE(LOG(NMIL*NISO)) LOG(:NMIL*NISO)=.TRUE. CALL LCMPUT(IPSAP,'LISMIL',NMIL*NISO,5,LOG) DEALLOCATE(LOG) ENDIF IF(NMIL*NMAC.GT.0) THEN ALLOCATE(LOG(NMIL*NMAC)) LOG(:NMIL*NMAC)=.TRUE. CALL LCMPUT(IPSAP,'LMAMIL',NMIL*NMAC,5,LOG) DEALLOCATE(LOG) ENDIF IF(NREA*NISO.GT.0) THEN ALLOCATE(LOG(NREA*NISO)) LOG(:NREA*NISO)=.TRUE. CALL LCMPUT(IPSAP,'LISREA',NREA*NISO,5,LOG) DEALLOCATE(LOG) ENDIF IF(NREA*NMAC.GT.0) THEN ALLOCATE(LOG(NREA*NMAC)) LOG(:NREA*NMAC)=.TRUE. CALL LCMPUT(IPSAP,'LMAREA',NREA*NMAC,5,LOG) DEALLOCATE(LOG) ENDIF CALL LCMSIX(IPSAP,' ',2) * IDATA(:NDIMSA)=0 IDATA(1)=NCOMLI IDATA(2)=NISOTA IDATA(4)=NREA IDATA(5)=NISO IDATA(6)=NMAC IDATA(7)=NMIL IDATA(8)=NPAR IDATA(9)=NPCHR IDATA(10)=NPPNT IDATA(11)=NLOC IDATA(12)=NPCHRL IDATA(13)=NPPNTL IDATA(14)=NISOF IDATA(15)=NISOP IDATA(16)=1 IDATA(22)=2 IDATA(30)=NGA CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA) IF(IMPX.GT.0) THEN WRITE(6,400) IMPX,(IDATA(I),I=1,17) WRITE(6,410) (IDATA(I),I=18,33) ENDIF GO TO 390 * END OF SAPHYB INITIALIZATION. ********************************** *---- * INPUT AN ELEMENTARY CALCULATION. ******************************* *---- 300 CALL LCMGET(IPSAP,'DIMSAP',IDATA) IF(IDATA(22).NE.2) CALL XABORT('SAP: INVALID VERSION OF SAP'// 1 'HYB SPECIFICATION.') NPAR=IDATA(8) IF(NPAR.GT.MAXPAR) CALL XABORT('SAP: TOO MANY PARAMETERS(3).') NPCHR=IDATA(9) NPPNT=IDATA(10) NCALS=IDATA(19) NORIG=NCALS IF(NPAR.GT.0) THEN CALL LCMSIX(IPSAP,'paramdescrip',1) CALL LCMGTC(IPSAP,'PARKEY',4,NPAR,PARKEY) CALL LCMGTC(IPSAP,'PARTYP',4,NPAR,PARTYP) CALL LCMGTC(IPSAP,'PARFMT',8,NPAR,PARFMT) CALL LCMSIX(IPSAP,' ',2) ENDIF * ITIM=0 LWARN=.FALSE. LCRON=.FALSE. IMPX=1 IPICK=0 310 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF(INDIC.EQ.10) GO TO 350 IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED(18).') IF(TEXT4.EQ.'EDIT') THEN * READ THE PRINT INDEX. CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTED(5).') ELSE IF(TEXT4.EQ.'SET') THEN CALL REDGET(INDIC,NITMA,XT,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('SAP: REAL DATA EXPECTED(1).') CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPECTED' 1 //'(19).') 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('SAP: S, DAY OR YEAR EXPECTED.') ENDIF IF(.NOT.C_ASSOCIATED(IPDEPL)) CALL XABORT('SAP: DEPLETION OBJ' 1 //'ECT EXPECTED AT RHS.') CALL LCMLEN(IPDEPL,'DEPL-TIMES',NTIM,ITYLCM) IF(NTIM.EQ.0) CALL XABORT('SAP: 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,'(39HSAP: 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(TEXT4.EQ.'ORIG') THEN CALL REDGET(INDIC,NORIG,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTED(6).') ELSE IF(TEXT4.EQ.';') THEN GO TO 350 ELSE IF(TEXT4.EQ.'ICAL') THEN IPICK=1 GO TO 350 ELSE IF(TEXT4.EQ.'WARN') THEN LWARN=.TRUE. ELSE IF(TEXT4.EQ.'CRON') THEN LCRON=.TRUE. ELSE DO 330 IKEY=1,NPAR IF(TEXT4.EQ.PARKEY(IKEY)) THEN IPAR=IKEY GO TO 340 ENDIF 330 CONTINUE CALL XABORT('SAP: INVALID KEYWORD='//TEXT4//'(5).') 340 IF(PARTYP(IPAR).NE.'VALE') CALL XABORT('SAP: '//TEXT4// 1 ' IS NOT OF VALE TYPE.') CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT) IF(PARFMT(IPAR).EQ.'ENTIER') THEN IF(INDIC.NE.1) CALL XABORT('SAP: INTEGER DATA EXPECTE'// 1 'D(7).') IF(IMPX.GT.0) WRITE(6,450) PARKEY(IPAR),NITMA ELSE IF(PARFMT(IPAR).EQ.'FLOTTANT') THEN IF(INDIC.NE.2) CALL XABORT('SAP: REAL DATA EXPECTED(2).') IF(IMPX.GT.0) WRITE(6,440) PARKEY(IPAR),FLOTT ELSE IF(PARFMT(IPAR).EQ.'CHAINE') THEN IF(INDIC.NE.3) CALL XABORT('SAP: CHARACTER DATA EXPEC'// 1 'TED(20).') IF(IMPX.GT.0) WRITE(6,460) PARKEY(IPAR),TEXT12 ENDIF CALL SAPPAV(IPSAP,IPAR,NPAR,PARFMT(IPAR),FLOTT,NITMA,TEXT12, 1 MUPLET(IPAR),LGNEW(IPAR)) ENDIF GO TO 310 *---- * RECOVER AN ELEMENTARY CALCULATION FROM EDITION. *---- 350 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 SAPCAL(IMPX,IPSAP,IPDEPL,IPEDIT,LCRON) * ------------------------------------------- *---- * RECOVER THE FLUX OF THE REFERENCE CALCULATION. *---- IF(C_ASSOCIATED(IPFLUX)) THEN CALL LCMGET(IPFLUX,'STATE-VECTOR',IDATA) NGA=IDATA(1) NRT=IDATA(2) CALL SAPFLU(IMPX,NCALS+1,IPSAP,IPFLUX,IPDEPL,NGA,NRT) ELSE NGA=0 NRT=0 ENDIF IF(ITIM.GT.0) CALL LCMSIX(IPDEPL,' ',2) *---- * RECOVER REMAINING GLOBAL PARAMETER AND LOCAL VALUES. *---- CALL SAPGEP(IPSAP,IPDEPL,IPLB1,IPLB2,IPEDIT,IMPX,ITIM,NORIG,NPAR, 1 MUPLET,LGNEW,NVPNEW,NCALAR) CALL LCMGET(IPSAP,'DIMSAP',IDATA) IF((C_ASSOCIATED(IPDEPL)).AND.(IDATA(3).EQ.0)) THEN IDATA(3)=1 CALL LCMSIX(IPSAP,'constphysiq',1) WRITE(TEXT8,'(8HDECAY )') CALL LCMPTC(IPSAP,'NOMLAM',8,TEXT8) CALL LCMSIX(IPSAP,' ',2) ENDIF IDATA(17)=NVPNEW IDATA(19)=NCALAR IF(IDATA(28).EQ.0) THEN IDATA(28)=NRT ELSE IF(NRT.NE.IDATA(28)) CALL XABORT('SAP: BAD VALUE OF NRT.') ENDIF IF(NGA.NE.0) THEN IF(NGA.NE.IDATA(30)) CALL XABORT('SAP: BAD VALUE OF NGA.') ENDIF CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA) * NISO=IDATA(5) NMAC=IDATA(6) NMIL=IDATA(7) CALL LCMSIX(IPSAP,'contenu',1) CALL LCMLEN(IPSAP,'LISMIL',ILONG,ITYLCM) IF((ILONG.EQ.0).AND.(NMIL*NISO.GT.0)) THEN ALLOCATE(LOG(NMIL*NISO)) LOG(:NMIL*NISO)=.TRUE. CALL LCMPUT(IPSAP,'LISMIL',NMIL*NISO,5,LOG) DEALLOCATE(LOG) ENDIF CALL LCMLEN(IPSAP,'LMAMIL',ILONG,ITYLCM) IF((ILONG.EQ.0).AND.(NMIL*NMAC.GT.0)) THEN ALLOCATE(LOG(NMIL*NMAC)) LOG(:NMIL*NMAC)=.TRUE. CALL LCMPUT(IPSAP,'LMAMIL',NMIL*NMAC,5,LOG) DEALLOCATE(LOG) ENDIF CALL LCMSIX(IPSAP,' ',2) * IF(IMPX.GT.0) THEN WRITE(6,400) IMPX,(IDATA(I),I=1,17) WRITE(6,410) (IDATA(I),I=18,33) ENDIF *---- * SAVE THE CALCULATION INDEX IN A CLE-2000 VARIABLE *---- IF(IPICK.EQ.1) THEN CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT) IF(ITYP.NE.-1) CALL XABORT('SAP: OUTPUT INTEGER EXPECTED.') ITYP=1 CALL REDPUT(ITYP,NCALAR,FLOTT,TEXT4,DFLOTT) CALL REDGET(ITYP,NITMA,FLOTT,TEXT4,DFLOTT) IF((ITYP.NE.3).OR.(TEXT4.NE.';')) THEN CALL XABORT('SAP: ; CHARACTER EXPECTED.') ENDIF ENDIF GO TO 390 *---- * SAPHYB CONCATENATION. *---- 360 DO 370 I=2,NENTRY IF(.NOT.C_ASSOCIATED(IPRHS(I))) GO TO 370 CALL LCMGET(IPRHS(I),'DIMSAP',IDATA) IF(IMPX.GT.0) WRITE(6,470) NCALS+1,NCALS+IDATA(19) * --------------------------------------------------------- CALL SAPCAT(IPSAP,IPRHS(I),NORIG,NPAR,MUPLET,LGNEW,LWARN) * --------------------------------------------------------- NCALS=NCALS+IDATA(19) 370 CONTINUE * IF(IMPX.GT.0) THEN CALL LCMGET(IPSAP,'DIMSAP',IDATA) WRITE(6,400) IMPX,(IDATA(I),I=1,17) WRITE(6,410) (IDATA(I),I=18,33) ENDIF *---- * SCRATCH STORAGE DEALLOCATION *---- 390 DEALLOCATE(IPRHS) RETURN * 400 FORMAT(/19H SAP: DIMSAP VALUES/1X,19(1H-)/ 1 7H IMPX ,I7,22H (0=NO PRINT/1=SHORT)/ 2 7H NCOMLI,I7,43H (NB. OF COMMENT LINES IN RECORD 'COMMEN')/ 3 7H NISOTA,I7,48H (NB. OF ISOTOPES IN THE REFERENCE CALCULATION)/ 4 7H NCHANN,I7,34H (NB. OF RADIOACTIVE DECAY TYPES)/ 5 7H NREA ,I7,43H (NB. OF REQUESTED NUCLEAR REACTION TYPES)/ 6 7H NISO ,I7,44H (NB. OF PARTICULARIZED ISOTOPES IN SAPHYB)/ 7 7H NMAC ,I7,40H (NB. OF MACROSCOPIC XS SETS IN SAPHYB)/ 8 7H NMIL ,I7,29H (NB. OF MIXTURES IN SAPHYB)/ 9 7H NPAR ,I7,28H (NB. OF GLOBAL PARAMETERS)/ 1 7H NPCHR ,I7,47H (NB. OF GLOBAL PARAMETERS LINKED TO ISOTOPES)/ 2 7H NPPNT ,I7,48H (NB. OF GLOBAL PARAMETERS LINKED TO LIBRARIES)/ 3 7H NLOC ,I7,26H (NB. OF LOCAL VARIABLES)/ 4 7H NPCHRL,I7,45H (NB. OF LOCAL VARIABLES LINKED TO ISOTOPES)/ 5 7H NPPNTL,I7,46H (NB. OF LOCAL VARIABLES LINKED TO LIBRARIES)/ 6 7H NISOF ,I7,42H (NB. OF PARTICULARIZED FISSILE ISOTOPES)/ 7 7H NISOP ,I7,42H (NB. OF PARTICULARIZED FISSION PRODUCTS)/ 8 7H NMGY ,I7,36H (NB. OF FISSION YIELD MACROGROUPS)/ 9 7H NVP ,I7,45H (NB. OF NODES IN THE GLOBAL PARAMETER TREE)) 410 FORMAT(7H NADRX ,I7,31H (NB. OF ADDRESS SETS IN ADRX)/ 1 7H NCALS ,I7,34H (NB. OF ELEMENTARY CALCULATIONS)/ 2 7H NG ,I7,34H (NB. OF ENERGY GROUPS IN SAPHYB)/ 3 7H NISOY ,I7,42H (NB. OF FISSION YIELDS SETS PER MIXTURE)/ 4 7H NVERS ,I7,40H (VERSION OF SAPHYB SPECIFICATION USED)/ 5 7H NFACES,I7,44H (NB. OF SURFACES SURROUNDING THE GEOMETRY)/ 6 7H NSURFS,I7,35H (NB. OF SURFACES IN THE GEOMETRY)/ 7 7H NRINGS,I7,27H (RELATED TO THE GEOMETRY)/ 8 7H NCASE ,I7,27H (RELATED TO THE GEOMETRY)/ 9 7H NCOORD,I7,33H (NB. OF MESHES IN THE GEOMETRY)/ 1 7H NRT ,I7,45H (NB. OF UNKNOWNS IN THE REFERENCE GEOMETRY)/ 2 7H NSURFT,I7,47H (NB. OF SURFACES IN THE HOMOGENIZED GEOMETRY)/ 3 7H NGA ,I7,43H (NB. OF GROUPS IN THE REFERENCE GEOMETRY)/ 4 7H NPRC ,I7,43H (NB. OF DELAYED NEUTRON PRECURSOR GROUPS)/ 5 7H NISOTS,I7,36H (NB. OF ISOTOPES IN OUTPUT TABLES)/ 6 7H NMINLR,I7,47H (NB. OF OUTPUT MIXTURES WITH DELAYED NEUTRON , 7 5HDATA)) 420 FORMAT(/1X,43(1H*)/34H * SAP: ELEMENTARY CALCULATION NB.,I8, 1 2H */1X,43(1H*)) 430 FORMAT(/41H SAP: 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 SAP: SET GLOBAL PARAMETER ',A,3H' =,1P,E12.4) 450 FORMAT(28H SAP: SET GLOBAL PARAMETER ',A,3H' =,I10) 460 FORMAT(28H SAP: SET GLOBAL PARAMETER ',A,5H' = ',A12,1H') 470 FORMAT(/1X,55(1H*)/35H * SAP: ELEMENTARY CALCULATIONS NB.,I8, 1 3H TO,I8,2H */1X,55(1H*)) END