*DECK LIBA20 SUBROUTINE LIBA20 (IPLIB,NAMFIL,NGRO,NBISO,NL,IPROC,ISONAM, 1 ISONRF,IPISO,ISHINA,MASKI,TN,SN,SB,IMPX,NGF,NGFR,NDEL) * *----------------------------------------------------------------------- * *Purpose: * Transcription of the useful interpolated microscopic cross section * data from APOLIB-2 to LCM data structures. * *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 * IPLIB pointer to the lattice microscopic cross section library * (L_LIBRARY signature). * NAMFIL name of the APOLIB-2 file. * NGRO number of energy groups. * NBISO number of isotopes present in the calculation domain. * NL number of Legendre orders required in the calculation * NL=1 or higher. * IPROC type of library processing. * ISONAM alias name of isotopes. * ISONRF library reference name of isotopes. * IPISO pointer array towards microlib isotopes. * ISHINA self shielding names. * MASKI isotopic mask. Isotope with index I is processed if * MASKI(I) is .true. * TN temperature of each isotope. * SN dilution cross section in each energy group of each. * isotope. a value of 1.0E10 is used for infinite dilution. * SB dilution cross section as used by Livolant and Jeanpierre * normalization. * IMPX print flag. * *Parameters: output * NGF number of fast groups without self-shielding. * NGFR number of fast and resonance groups. * NDEL number of precursor groups for delayed neutrons. * *Reference: * A. Hebert, P. Bellier, M. Coste, R. Sanchez, Z. Stankovski et * I. Zmijarevic, "APOLLO2: Notice informatique Version 2.4", * Commissariat a l'Energie Atomique, * Rapport SERMA/LENR/RT/98-2477/A, 1998. * *----------------------------------------------------------------------- * USE GANLIB *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIB,IPISO(NBISO) INTEGER NGRO,NBISO,NL,IPROC,ISONAM(3,NBISO),ISONRF(3,NBISO), 1 ISHINA(3,NBISO),IMPX,NGF,NGFR,NDEL REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO) CHARACTER NAMFIL*(*) LOGICAL MASKI(NBISO) *---- * LOCAL VARIABLES *---- LOGICAL LSACO PARAMETER (NXSMAX=10,IOUT=6,MAXHOM=9,LSACO=.FALSE.) * NOTE: LSACO MUST BE SET TO .TRUE. WITH THE SANCHEZ-COSTE METHOD. TYPE(C_PTR) KPLIB EXTERNAL LIBA21 CHARACTER TEXT8*8,TEXT20*20,TEXT80*80,NOMOBJ*20,TYPOBJ*8, 1 TYPSEG*8,HNAMIS*12,HNISOR*12,HNISSS*12,HSMG*131,TEXT2*2, 2 TEXT12*12 LOGICAL LPFIX,LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,LPTHOM,L104,LABS, 1 LDIF,LFIS,LPWD,LPED,LH INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG DOUBLE PRECISION UU,XDRCST INTEGER ITHOMO(MAXHOM),ITEXT(20),ISFICH(3),IPAR(3) REAL TKT(5) * INTEGER TKCARO(31) SAVE TKCARO DATA TKCARO / & 0, 1, 2, 3, 4, 5, 6, 30, 7, -8, & 9, -10, 11, -12, 13, -14, 15, 16, -17, 18, & -19, 20, -21, 22, 23, -24, 25, -26, 27, -28, & 29 / *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,KDS,LGS,NOM,NOMS, 1 NOMOB,VINTE,ITCARO,ITC104,ITS104,ITITLE,IZSECT,ISECTT,IFDG,IIAD, 2 IDEPL,IPR2 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, 1 DELTF,SIGTF,SIGAF,ENER,AMASS,TEMP,TEMPS,SEQHO,SQRTE,PWD,PED,QQNG, 2 QQF,HFACT REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM REAL, POINTER, DIMENSION(:) :: RTSEGM LOGICAL, POINTER, DIMENSION(:) :: LTSEGM *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IPR(7+2*(NL-1),NBISO),IPR2(NBISO),ITYPRO(NL),NFS(NGRO)) ALLOCATE(ENERG(NGRO+1),DELTA(NGRO),SECT(NGRO),SIGS(NGRO,NL), 1 SCAT(NGRO,NGRO,NL),XSTOT(NGRO)) * ANEUT=REAL(XDRCST('Neutron mass','amu')) NGF=NGRO+1 NGFR=0 NDEL=0 IF(IMPX.GT.0) WRITE (IOUT,800) NAMFIL *---- * OPEN AND PROBE THE APOLIB-2 FILE. *---- TKT(:5)=0.0 CALL KDRCPU(TK1) CALL AEXTPA(NAMFIL,ISFICH) IADRES=ISFICH(1) NBOBJ=ISFICH(2) LBLOC=ISFICH(3) IUNIT=KDROPN(NAMFIL,2,4,LBLOC) IF(IUNIT.LE.0) THEN TEXT12=NAMFIL CALL XABORT('LIBA20: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'// 1 'E OPENED') ENDIF *---- * INDEX THE APOLIB-2 FILE. *---- IDKNO=1-TKCARO(14) IDKTY=1-TKCARO(21) IDKDS=1-TKCARO(10) IDKTS=1-TKCARO(23) IDKDA=1-TKCARO(26) IDKNS=TKCARO(2)+1 IDKLS=TKCARO(8) ALLOCATE(KDS(NBOBJ-3),LGS(NBOBJ-3),NOMOB(7*(NBOBJ-3))) KDS(:NBOBJ-3)=0 LGS(:NBOBJ-3)=0 NOMOB(:7*(NBOBJ-3))=0 CALL LCMSIX(IPLIB,'INDEX',1) TEXT12=NAMFIL CALL LCMLEN(IPLIB,TEXT12,ILENG,ITYLCM) CALL LCMSIX(IPLIB,TEXT12,1) IF(ILENG.NE.0) THEN * RECOVER AN EXISTING INDEX. CALL LCMGET(IPLIB,'IPAR',IPAR) CALL LCMGET(IPLIB,'KDS',KDS) CALL LCMGET(IPLIB,'LGS',LGS) CALL LCMGET(IPLIB,'NOMOB',NOMOB) ELSE * CREATE A NEW INDEX. ALLOCATE(VINTE(2*NBOBJ)) CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ) NSEGM=0 DO 10 IOBJ=3,NBOBJ IDKOBJ=VINTE(2*IOBJ-1) LGSEG=VINTE(2*IOBJ)+1 ALLOCATE(ITCARO(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) IDK=ITCARO(IDKNO) CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) IDK=ITCARO(IDKTY) CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) JDKDS=ITCARO(IDKDS) JDKTS=ITCARO(IDKTS) NS=ITCARO(IDKNS) IDK=ITCARO(IDKDA) CALL AEXCPC(IDK,8,ITCARO(1),TEXT8) IF(TYPOBJ.EQ.'APOLIB') THEN IPAR(2)=IDKOBJ IPAR(3)=LGSEG ELSE IF(TYPOBJ.EQ.'APOLIBE') THEN NSEGM=NSEGM+1 ISO2=(NSEGM-1)*7+1 CALL LCMCAR(NOMOBJ,.TRUE.,NOMOB(ISO2)) CALL LCMCAR(TEXT8,.TRUE.,NOMOB(ISO2+5)) KDS(NSEGM)=IDKOBJ LGS(NSEGM)=LGSEG ELSE CALL XABORT('LIBA20: WEIRD SEGMENT TYPE: '//TYPOBJ//'.') ENDIF DEALLOCATE(ITCARO) 10 CONTINUE DEALLOCATE(VINTE) IPAR(1)=NSEGM * * SAVE THE INDEX. CALL LCMPUT(IPLIB,'IPAR',3,1,IPAR) CALL LCMPUT(IPLIB,'NOMOB',7*(NBOBJ-3),1,NOMOB) CALL LCMPUT(IPLIB,'KDS',NBOBJ-3,1,KDS) CALL LCMPUT(IPLIB,'LGS',NBOBJ-3,1,LGS) ENDIF CALL LCMSIX(IPLIB,' ',2) CALL LCMSIX(IPLIB,' ',2) *---- * RECOVER GENERIC INFORMATION FROM THE APOLIB SEGMENT. *---- NSEGM=IPAR(1) IDKOBJ=IPAR(2) LGSEG=IPAR(3) NISOT=0 NISOTS=0 NAMASS=0 IDKCOM=0 ISCOM=0 ALLOCATE(ITCARO(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) IDK=ITCARO(IDKNO) CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) IDK=ITCARO(IDKTY) CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) JDKDS=ITCARO(IDKDS) JDKTS=ITCARO(IDKTS) NS=ITCARO(IDKNS) IDK=ITCARO(IDKDA) CALL AEXCPC(IDK,8,ITCARO(1),TEXT8) IF(TYPOBJ.NE.'APOLIB') CALL XABORT('LIBA20: UNABLE TO FIND TH'// 1 'E APOLIB SEGMENT.') DO 80 IS=1,NS IDK=JDKTS+8*(IS-1) CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) LNGS=ITCARO(IDKLS+IS) IF(LNGS.LE.0) GO TO 80 JDKS=ITCARO(JDKDS+IS) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) IF(TYPSEG.EQ.'PHEAD') THEN CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) CALL AEXCPC(0,NV,ITSEGM(IDK),TEXT80) IF((IMPX.GT.0).AND.(NV.GT.0)) WRITE (IOUT,810) TEXT80 CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) IF(NV.EQ.0) THEN TEXT12=NAMFIL CALL XABORT('LIBA20: NO ISOTOPES PRESENT ON APOLIB-2 FIL'// 1 'E NAMED: '//TEXT12) ENDIF NISOT=NV/20 ALLOCATE(NOM(5*NISOT)) IF(IMPX.GE.10) THEN WRITE(IOUT,'(/41H LIBA20: STANDARD ISOTOPE NAMES PRESENT I, 1 10HN LIBRARY:)') ENDIF DO 20 ISO=1,NISOT ISO2=(ISO-1)*5+1 CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),TEXT20) IF(IMPX.GE.10) WRITE(IOUT,'(8H -----> ,A20)') TEXT20 CALL LCMCAR(TEXT20,.TRUE.,NOM(ISO2)) 20 CONTINUE CALL AEXGNV(6,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) NISOTS=NV/20 IF(NISOTS.GT.0) THEN ALLOCATE(NOMS(5*NISOTS)) IF(IMPX.GE.10) THEN WRITE(IOUT,'(/38H LIBA20: SELF-SHIELDED ISOTOPE NAMES P, 1 18HRESENT IN LIBRARY:)') ENDIF DO 30 ISO=1,NISOTS ISO2=(ISO-1)*5+1 CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),TEXT20) IF(IMPX.GE.10) WRITE(IOUT,'(8H -----> ,A20)') TEXT20 CALL LCMCAR(TEXT20,.TRUE.,NOMS(ISO2)) 30 CONTINUE ENDIF ELSE IF(TYPSEG.EQ.'PMAIL') THEN CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) IF(NV-1.NE.NGRO) CALL XABORT('LIBA20: BAD GROUP STRUCTURE.') DO 40 IG=1,NV ENERG(IG)=RTSEGM(IDK+IG-1)*1.0E6 40 CONTINUE CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) IF(NV.EQ.NGRO) THEN DO 50 IG=1,NGRO DELTA(IG)=RTSEGM(IDK+IG-1) 50 CONTINUE ELSE DO 60 IG=1,NGRO DELTA(IG)=LOG(ENERG(IG)/ENERG(IG+1)) 60 CONTINUE ENDIF CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENERG) CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA) ELSE IF(TYPSEG.EQ.'PCONST') THEN CALL AEXGNV(13,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NAMASS) ALLOCATE(AMASS(NAMASS)) DO 70 IA=1,NAMASS AMASS(IA)=RTSEGM(IDK+IA-1)/ANEUT 70 CONTINUE ELSE IF(TYPSEG.EQ.'PCOM') THEN * ISOTOPE-DEPENDENT COMMENTS ARE AVAILABLE. IDKCOM=IDKOBJ LGCOM=LGSEG ISCOM=IS ENDIF CALL LCMDRD(TSEGM_PTR) CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) 80 CONTINUE DEALLOCATE(ITCARO) IF(NAMASS.NE.NISOT) CALL XABORT('LIBA20: INVALID AWR INFO.') *---- * SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES. *---- IF(IMPX.GT.1) WRITE(IOUT,820) NISOT,NISOTS,NSEGM CALL LIBA27(NAMFIL,NBISO,NISOT,NSEGM,NL,ISONRF,ISHINA,MASKI, 1 NOM,NOMOB,IPR) IPR2(:NBISO)=IPR(1,:NBISO) !DEALLOCATE(NOM) IF(NISOTS.GT.0) DEALLOCATE(NOMS) CALL KDRCPU(TK2) TKT(1)=TK2-TK1 *---- * READ THROUGH APOLIB-2 FILE AND ACCUMULATE CROSS SECTIONS FOR THIS * RANGE OF MATS, LEGENDRE ORDERS, AND GROUPS. *---- CALL LCMGET(IPLIB,'ENERGY',ENERG) DO 560 IMX=1,NBISO *---- * PROCESS INFINITE DILUTION INFORMATION. *---- KISEG=IPR(2,IMX) IF(KISEG.GT.0) THEN IF(IMPX.GT.1) WRITE(IOUT,'(/29H LIBA20: PROCESSING ISOTOPE '', 1 3A4,2H''.)') (ISONRF(I0,IMX),I0=1,3) * * RECOVER THE ISOTOPE TITLE. CALL KDRCPU(TK1) IF(IDKCOM.EQ.0) THEN * MAKE A NEW TITLE. ISO2=(KISEG-1)*7+1 CALL LCMCAR(NOMOBJ,.FALSE.,NOMOB(ISO2)) CALL LCMCAR(TEXT8,.FALSE.,NOMOB(ISO2+5)) TEXT80='APOLIB-2 ISOTOPE:'//NOMOBJ(7:)//TEXT8 ELSE * RECOVER THE TITLE FROM THE PCOM SEGMENT. IF(IPR(1,IMX).LE.0) CALL XABORT('LIBA20: BAD TITLE.') ALLOCATE(ITITLE(LGCOM)) CALL AEXDIR(IUNIT,LBLOC,ITITLE,IDKCOM,LGCOM) JDKDS=ITITLE(IDKDS) JDKTS=ITITLE(IDKTS) NS=ITITLE(IDKNS) IDK=JDKTS+8*(ISCOM-1) CALL AEXCPC(IDK,8,ITITLE(1),TYPSEG) IF(TYPSEG.NE.'PCOM') CALL XABORT('LIBA20: SEGMENT ERROR.') LNGS=ITITLE(IDKLS+ISCOM) IF(LNGS.LE.0) CALL XABORT('LIBA20: LENGTH ERROR.') JDKS=ITITLE(JDKDS+ISCOM) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) ISO2=(IPR(1,IMX)-1)*20+1 CALL AEXCPC(0,NV,ITSEGM(IDK+ISO2-1),TEXT80) CALL LCMDRD(TSEGM_PTR) CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) DEALLOCATE(ITITLE) ENDIF READ(TEXT80,'(20A4)') (ITEXT(I),I=1,20) IF(IMPX.GT.2) WRITE(IOUT,870) TEXT80 * IDKOBJ=KDS(KISEG) LGSEG=LGS(KISEG) ALLOCATE(ITCARO(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) IDK=ITCARO(IDKNO) CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) IDK=ITCARO(IDKTY) CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) JDKDS=ITCARO(IDKDS) JDKTS=ITCARO(IDKTS) NS=ITCARO(IDKNS) *---- * RECOVER THE INFINITE DILUTION CROSS SECTION NUMEROTATION. *---- LPFIX=.FALSE. LTRAN=.FALSE. DO 160 IS=1,NS IDK=JDKTS+8*(IS-1) CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) LNGS=ITCARO(IDKLS+IS) IF(LNGS.LE.0) GO TO 160 JDKS=ITCARO(JDKDS+IS) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL C_F_POINTER(TSEGM_PTR,LTSEGM,(/ LNGS+1 /)) CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) IF(TYPSEG.EQ.'PFIX') THEN LPFIX=.TRUE. CALL AEXGNV(2,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) ZFISS=ITSEGM(IDK) CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) LGPROB=LTSEGM(IDK) CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) LGTDIF=LTSEGM(IDK) CALL AEXGNV(6,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) LGTTRA=LTSEGM(IDK) CALL AEXGNV(7,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) FGTD=ITSEGM(IDK) CALL AEXGNV(8,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) ID2=ITSEGM(IDK) CALL AEXGNV(12,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSECTT) ALLOCATE(IZSECT(NSECTT)) NSETOT=0 NPHY=MAX(0,NSECTT-5) DO 90 I=1,NSECTT IZSECT(I)=ITSEGM(IDK+I-1) IF((IZSECT(I).NE.0).AND.(I.LE.5)) NSETOT=NSETOT+1 90 CONTINUE IF(IMPX.GT.2) WRITE(IOUT,875) (IZSECT(I),I=1,NSECTT) CALL AEXGNV(14,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NANISD) CALL AEXGNV(16,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NANIST) CALL AEXGNV(18,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSECTT) ALLOCATE(LGTRE(NSECTT)) DO 100 I=1,NSECTT LGTRE(I)=LTSEGM(IDK+I-1) 100 CONTINUE CALL AEXGNV(24,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NTEMP) ALLOCATE(TEMP(NTEMP)) DO 110 I=1,NTEMP TEMP(I)=RTSEGM(IDK+I-1) 110 CONTINUE IF(IMPX.GT.2) WRITE(IOUT,880) (TEMP(I),I=1,NTEMP) CALL AEXGNV(26,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) IF(NV/8.NE.NSECTT) CALL XABORT('LIBA20: INVALID TYPSECT.') ALLOCATE(ISECTT(2*NSECTT)) III=0 DO 120 I=1,NSECTT I2=(I-1)*2+1 IF(IZSECT(I).NE.0) THEN III=III+1 I3=(III-1)*2+1 CALL AEXCPC(0,8,ITSEGM(IDK+I2-1),TEXT8) CALL LCMCAR(TEXT8,.TRUE.,ISECTT(I3)) ENDIF 120 CONTINUE IF(IMPX.GT.2) WRITE(IOUT,890) ZFISS,LGPROB,LGTDIF,LGTTRA, 1 FGTD,ID2,NSECTT,NSETOT,NPHY,NANISD,NANIST,(LGTRE(I),I=1, 2 NSECTT) IF(NANIST.GT.NANISD) CALL XABORT('LIBA20: NANIST.GT.NANISD') ELSE IF(TYPSEG.EQ.'PPPSN') THEN LTRAN=.TRUE. CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) FAGG=ITSEGM(IDK) CALL AEXGNV(2,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) LAGG=ITSEGM(IDK) CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) FDGG=ITSEGM(IDK) CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) WGAL=ITSEGM(IDK) CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) FAG=ITSEGM(IDK) CALL AEXGNV(6,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) LAG=ITSEGM(IDK) CALL AEXGNV(7,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) IF(NV.NE.NGRO) CALL XABORT('LIBA20: INVALID LIBRARY(1).') ALLOCATE(IFDG(NV)) DO 130 I=1,NV IFDG(I)=ITSEGM(IDK+I-1) 130 CONTINUE CALL AEXGNV(9,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) IF(NV.NE.NGRO+1) CALL XABORT('LIBA20: INVALID LIBRARY(2).') ALLOCATE(IIAD(NV)) DO 140 I=1,NV IIAD(I)=ITSEGM(IDK+I-1) 140 CONTINUE CALL AEXGNV(11,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NGTD) ALLOCATE(IDEPL(NGTD)) DO 150 I=1,NGTD IDEPL(I)=ITSEGM(IDK+I-1) 150 CONTINUE IF(IMPX.GT.2) WRITE(IOUT,900) FAGG,LAGG,FDGG,WGAL,FAG,LAG, 1 NGTD ENDIF CALL LCMDRD(TSEGM_PTR) CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) 160 CONTINUE IF(.NOT.LPFIX) CALL XABORT('LIBA20: NO PFIX SEGMENT.') *---- * RECOVER THE INFINITE DILUTION CROSS SECTIONS. *---- ITSEC=0 NDIFG=0 NPSN=0 DO 220 IS=1,NS IDK=JDKTS+8*(IS-1) CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) LNGS=ITCARO(IDKLS+IS) IF(LNGS.LE.0) GO TO 220 JDKS=ITCARO(JDKDS+IS) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) IF(TYPSEG.EQ.'PSECT') THEN * RECOVER A VECTOR CROSS SECTION. ITSEC=ITSEC+1 IF(ITSEC.GT.NXSMAX) THEN CALL XABORT('LIBA20: SECT OVERFLOW.') ELSE IF(ITSEC.LE.NSETOT) THEN I3=(ITSEC-1)*2+1 CALL LCMCAR(TEXT8,.FALSE.,ISECTT(I3)) ELSE IF(ITSEC.EQ.NSETOT+1) THEN TEXT8='SIGS00' ELSE IF(ITSEC.GT.NSETOT+1) THEN CALL XABORT('LIBA20: UNKNOWN CROSS SECTION TYPE(1).') ENDIF CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) DO 190 JMX=IMX,NBISO IF(IPR(2,JMX).EQ.KISEG) THEN KPLIB=IPISO(JMX) ! set JMX-th isotope CALL LCMLEN(KPLIB,'ALIAS',ILENG,ITYLCM) IF(ILENG.EQ.0) THEN WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3) CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) IF(IPR(1,JMX).LE.0) CALL XABORT('LIBA20: BAD AWR.') CALL LCMPUT(KPLIB,'AWR',1,2,AMASS(IPR(1,JMX))) CALL LCMPUT(KPLIB,'README',20,3,ITEXT) ENDIF IF(ITSEC.EQ.1) THEN SIGS(:NGRO,1)=0.0 CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SIGS) CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SIGS) ENDIF CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM(IDK), 1 SECT) IF(TEXT8.EQ.'SIGA') THEN CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SECT) ELSE IF(TEXT8.EQ.'NEXCESS') THEN LN2N=.FALSE. DO 170 IG=1,NGRO LN2N=LN2N.OR.(SECT(IG).NE.0.0) 170 CONTINUE IF(LN2N) THEN CALL LCMPUT(KPLIB,'N2N',NGRO,2,SECT) CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SECT) ENDIF ELSE IF(TEXT8.EQ.'SIGF') THEN CALL LCMPUT(KPLIB,'NFTOT',NGRO,2,SECT) ELSE IF(TEXT8.EQ.'NUSIGF') THEN CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SECT) ELSE IF(TEXT8.EQ.'CHI') THEN CALL LCMPUT(KPLIB,'CHI',NGRO,2,SECT) ELSE IF(TEXT8.EQ.'SIGS00') THEN CALL LCMGET(KPLIB,'NTOT0',XSTOT) CALL LCMGET(KPLIB,'SIGS00',SIGS) NDIFG=NV DO 180 IG=1,NGRO XSTOT(IG)=XSTOT(IG)+SECT(IG) SIGS(IG,1)=SIGS(IG,1)+SECT(IG) 180 CONTINUE CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,XSTOT) CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SIGS) ELSE CALL XABORT('LIBA20: UNKNOWN X-S TYPE:'//TEXT8) ENDIF ENDIF 190 CONTINUE ELSE IF(TYPSEG.EQ.'PPSN') THEN * RECOVER A MATRIX CROSS SECTION. IF(.NOT.LTRAN) CALL XABORT('LIBA20: PPPSN MISSING.') CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) NPSN=NV DO 210 JMX=IMX,NBISO IF(IPR(2,JMX).EQ.KISEG) THEN KPLIB=IPISO(JMX) ! set JMX-th isotope SCAT(:NGRO,:NGRO,1)=0.0 CALL LIBA23(NGRO,1,TN(JMX),NTEMP,NGTD,NV,TEMP,FGTD,ID2, 1 FAGG,LAGG,FDGG,WGAL,FAG,LAG,IFDG,IIAD,IDEPL,RTSEGM(IDK), 2 SCAT) CALL LCMGET(KPLIB,'SIGS00',SIGS) IF(LGPROB) THEN DO 205 IG=1,NGRO DO 200 JG=1,NGRO SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1) 200 CONTINUE 205 CONTINUE ENDIF CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO) ENDIF 210 CONTINUE ENDIF CALL LCMDRD(TSEGM_PTR) CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) 220 CONTINUE DEALLOCATE(ITCARO) DO 240 JMX=IMX,NBISO IF(IPR(2,JMX).EQ.KISEG) THEN IF(.NOT.LTRAN) THEN KPLIB=IPISO(JMX) ! set JMX-th isotope CALL LCMGET(KPLIB,'SIGS00',SIGS) SCAT(:NGRO,:NGRO,1)=0.0 DO 230 IG=1,NGRO SCAT(IG,IG,1)=SIGS(IG,1) 230 CONTINUE CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO) ENDIF IPR(2,JMX)=0 ENDIF 240 CONTINUE CALL KDRCPU(TK2) TKT(2)=TKT(2)+(TK2-TK1) *---- * RECOVER SCATTERING X-S FOR HIGHER LEGENDRE ORDERS. *---- CALL KDRCPU(TK1) DO 270 IL=2,MIN(NANISD,NL) WRITE(TEXT2,'(I2.2)') IL-1 KISEG=IPR(7+(IL-1),IMX) IF(KISEG.EQ.0) THEN WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) WRITE(HSMG,830) IL-1,HNAMIS,HNISOR,NAMFIL CALL XABORT(HSMG) ENDIF IDKOBJ=KDS(KISEG) LGSEG=LGS(KISEG) ALLOCATE(ITCARO(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) LDKDS=ITCARO(IDKDS) LDKTS=ITCARO(IDKTS) IF(ITCARO(IDKNS).NE.1) CALL XABORT('LIBA20: INVALID DIFF(1).') CALL AEXCPC(LDKTS,8,ITCARO(1),TYPSEG) IF(TYPSEG.NE.'PSECT') CALL XABORT('LIBA20: INVALID DIFF(2).') LNGS=ITCARO(IDKLS+1) IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID DIFF(3).') LDKS=ITCARO(LDKDS+1) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1) CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) IF(NV.NE.NDIFG) CALL XABORT('LIBA20: INVALID DIFF(4).') CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) DEALLOCATE(ITCARO) DO 260 JMX=IMX,NBISO IF(IPR(7+(IL-1),JMX).EQ.KISEG) THEN KPLIB=IPISO(JMX) ! set JMX-th isotope CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM(IDK), 1 SECT) CALL LCMPUT(KPLIB,'SIGS'//TEXT2,NGRO,2,SECT) IF(IL.GT.NANIST) THEN SCAT(:NGRO,:NGRO,1)=0.0 DO 250 IG=1,NGRO SIGS(IG,1)=SECT(IG) SCAT(IG,IG,1)=SECT(IG) 250 CONTINUE CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT, 1 ITYPRO) ENDIF IPR(7+(IL-1),JMX)=0 ENDIF 260 CONTINUE CALL LCMDRD(TSEGM_PTR) 270 CONTINUE *---- * RECOVER TRANSFER MATRICES FOR HIGHER LEGENDRE ORDERS. *---- DO 300 IL=2,MIN(NANIST,NL) WRITE(TEXT2,'(I2.2)') IL-1 KISEG=IPR(7+(NL-1)+(IL-1),IMX) IF(KISEG.EQ.0) THEN WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) WRITE(HSMG,830) IL-1,HNAMIS,HNISOR,NAMFIL CALL XABORT(HSMG) ENDIF IDKOBJ=KDS(KISEG) LGSEG=LGS(KISEG) ALLOCATE(ITCARO(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) LDKDS=ITCARO(IDKDS) LDKTS=ITCARO(IDKTS) IF(ITCARO(IDKNS).NE.1) CALL XABORT('LIBA20: INVALID TRAN(1).') CALL AEXCPC(LDKTS,8,ITCARO(1),TYPSEG) IF(TYPSEG.NE.'PPSN') CALL XABORT('LIBA20: INVALID TRAN(2).') LNGS=ITCARO(IDKLS+1) IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID TRAN(3).') LDKS=ITCARO(LDKDS+1) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1) CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) IF(NV.NE.NPSN) CALL XABORT('LIBA20: INVALID TRAN(4).') CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) DEALLOCATE(ITCARO) DO 290 JMX=IMX,NBISO IF(IPR(7+(NL-1)+(IL-1),JMX).EQ.KISEG) THEN KPLIB=IPISO(JMX) ! set JMX-th isotope CALL LIBA23(NGRO,IL,TN(JMX),NTEMP,NGTD,NV,TEMP,FGTD,ID2, 1 FAGG,LAGG,FDGG,WGAL,FAG,LAG,IFDG,IIAD,IDEPL,RTSEGM(IDK), 2 SCAT) CALL LCMGET(KPLIB,'SIGS'//TEXT2,SIGS) IF(LGPROB) THEN DO 285 IG=1,NGRO DO 280 JG=1,NGRO SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1) 280 CONTINUE 285 CONTINUE ENDIF CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT,ITYPRO) IPR(7+(NL-1)+(IL-1),JMX)=0 ENDIF 290 CONTINUE CALL LCMDRD(TSEGM_PTR) 300 CONTINUE CALL KDRCPU(TK2) TKT(3)=TKT(3)+(TK2-TK1) *---- * RECOVER A PRODUCTION X-S. *---- CALL KDRCPU(TK1) IF(NPHY.GE.1) THEN KISEG=IPR(3,IMX) IF(KISEG.EQ.0) THEN WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) WRITE(HSMG,840) HNAMIS,HNISOR,NAMFIL CALL XABORT(HSMG) ENDIF IDKOBJ=KDS(KISEG) LGSEG=LGS(KISEG) ALLOCATE(ITCARO(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) LDKDS=ITCARO(IDKDS) LDKTS=ITCARO(IDKTS) NS=ITCARO(IDKNS) IF(NS.NE.NPHY) CALL XABORT('LIBA20: INVALID PRODUCTION X-S(' 1 //'1).') ENDIF DO 320 IPHY=1,NPHY IDK=LDKTS+8*(IPHY-1) CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) IF(TYPSEG.NE.'PSECT') CALL XABORT('LIBA20: INVALID PRODUCTION' 1 //' X-S(2).') LNGS=ITCARO(IDKLS+IPHY) IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID PRODUCTION X-S(3).') LDKS=ITCARO(LDKDS+IPHY) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1) CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) I3=(NSETOT+IPHY-1)*2+1 CALL LCMCAR(TEXT8,.FALSE.,ISECTT(I3)) DO 310 JMX=IMX,NBISO IF(IPR(3,JMX).EQ.KISEG) THEN KPLIB=IPISO(JMX) ! set JMX-th isotope CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM(IDK), 1 SECT) IF(TEXT8.EQ.'CREA-P') THEN TEXT8='NP' ELSE IF (TEXT8.EQ.'CREA-H2') THEN TEXT8='ND' ELSE IF (TEXT8.EQ.'CREA-H3') THEN TEXT8='NT' ENDIF CALL LCMPUT(KPLIB,TEXT8,NGRO,2,SECT) ENDIF 310 CONTINUE CALL LCMDRD(TSEGM_PTR) 320 CONTINUE DO 330 JMX=IMX,NBISO IF(IPR(3,JMX).EQ.KISEG) IPR(3,JMX)=0 330 CONTINUE IF(NPHY.GE.1) DEALLOCATE(ITCARO) DEALLOCATE(ISECTT) *---- * RECOVER DELAYED NEUTRON DATA. *---- KISEG=IPR(4,IMX) IF(KISEG.GT.0) THEN IDKOBJ=KDS(KISEG) LGSEG=LGS(KISEG) ALLOCATE(ITCARO(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) IDK=ITCARO(IDKNO) CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) IDK=ITCARO(IDKTY) CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) JDKDS=ITCARO(IDKDS) JDKTS=ITCARO(IDKTS) NS=ITCARO(IDKNS) ICHI=0 NDEL0=0 LPWD=.FALSE. DO 350 IS=1,NS IDK=JDKTS+8*(IS-1) CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) LNGS=ITCARO(IDKLS+IS) IF(LNGS.LE.0) GO TO 350 JDKS=ITCARO(JDKDS+IS) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,ILENG) CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) IF(TYPSEG.EQ.'.R1 RCHI') THEN ICHI=ICHI+1 ELSE IF(TYPSEG.EQ.'.R1 RRBE') THEN NDEL0=ILENG NDEL=MAX(NDEL,NDEL0) ALLOCATE(PWD(NDEL)) DO IDEL=1,NDEL PWD(IDEL)=RTSEGM(IDK+IDEL-1) ENDDO LPWD=.TRUE. ELSE IF(TYPSEG.EQ.'.R1 RBET') THEN ALLOCATE(PED(NGRO)) DO IGR=1,NGRO PED(IGR)=RTSEGM(IDK+IGR-1) ENDDO LPED=.TRUE. ENDIF DO 340 JMX=IMX,NBISO IF(IPR(4,JMX).EQ.KISEG) THEN KPLIB=IPISO(JMX) ! set JMX-th isotope IF(TYPSEG.EQ.'.R1 RLAM') THEN CALL LCMPUT(KPLIB,'LAMBDA-D',ILENG,2,RTSEGM(IDK)) NDEL0=ILENG NDEL=MAX(NDEL,NDEL0) ELSE IF(TYPSEG.EQ.'.R1 RCHI') THEN WRITE(TEXT2,'(I2.2)') ICHI CALL LCMPUT(KPLIB,'CHI'//TEXT2,ILENG,2,RTSEGM(IDK)) ENDIF ENDIF 340 CONTINUE CALL LCMDRD(TSEGM_PTR) 350 CONTINUE DEALLOCATE(ITCARO) IF(LPWD.AND.LPED) THEN DO 390 JMX=IMX,NBISO IF(IPR(4,JMX).EQ.KISEG) THEN KPLIB=IPISO(JMX) ! set JMX-th isotope DO 380 IDEL=1,NDEL0 WRITE(TEXT2,'(I2.2)') IDEL CALL LCMGET(KPLIB,'NUSIGF',SECT) DO 370 IGR=1,NGRO SECT(IGR)=SECT(IGR)*PWD(IDEL)*PED(IGR) 370 CONTINUE CALL LCMPUT(KPLIB,'NUSIGF'//TEXT2,NGRO,2,SECT) 380 CONTINUE ENDIF 390 CONTINUE ENDIF IF(LPWD) DEALLOCATE(PWD) IF(LPED) DEALLOCATE(PED) DO 400 JMX=IMX,NBISO IF(IPR(4,JMX).EQ.KISEG) IPR(4,JMX)=0 400 CONTINUE ENDIF *---- * RELEASE ALLOCATED MEMORY FOR THE CURRENT ISOTOPE. *---- IF(LTRAN) DEALLOCATE(IDEPL,IIAD,IFDG) DEALLOCATE(TEMP,IZSECT,LGTRE) CALL KDRCPU(TK2) TKT(2)=TKT(2)+(TK2-TK1) IF((IMPX.GT.9).AND.(IPR(5,IMX).EQ.0)) THEN KPLIB=IPISO(IMX) ! set IMX-th isotope CALL LCMLIB(KPLIB) ENDIF ENDIF *---- * PROCESS SELF-SHIELDING INFORMATION. *---- KISEG=IPR(5,IMX) IF(KISEG.GT.0) THEN CALL KDRCPU(TK1) IDKOBJ=KDS(KISEG) LGSEG=LGS(KISEG) ALLOCATE(ITCARO(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) IDK=ITCARO(IDKNO) CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) IDK=ITCARO(IDKTY) CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) JDKDS=ITCARO(IDKDS) JDKTS=ITCARO(IDKTS) NS=ITCARO(IDKNS) *---- * RECOVER THE SELF-SHIELDED CROSS SECTION NUMEROTATION. *---- LPTHOM=.FALSE. LGHOMO=0 DO 440 IS=1,NS IDK=JDKTS+8*(IS-1) CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) LNGS=ITCARO(IDKLS+IS) IF(LNGS.LE.0) GO TO 440 JDKS=ITCARO(JDKDS+IS) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) IF(TYPSEG.EQ.'PTHOM1') THEN LPTHOM=.TRUE. CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NTHOMO) IF(NTHOMO.GT.MAXHOM) CALL XABORT('LIBA20: ITHOMO OVERFLOW.') DO 410 I=1,NTHOMO ITHOMO(I)=ITSEGM(IDK+I-1) 410 CONTINUE FGHOMO=ITHOMO(1) LGHOMO=ITHOMO(2) FGRESO=ITHOMO(3) NGHOMO=LGHOMO-FGHOMO+1 NGF=MIN(NGF,FGHOMO) NGFR=MAX(NGFR,LGHOMO) L104=.FALSE. IF(NTHOMO.GE.9) L104=ITHOMO(9).NE.0 CALL AEXGNV(13,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NBIN) CALL AEXGNV(16,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSEQHO) ALLOCATE(SEQHO(NSEQHO)) DO 420 I=1,NSEQHO SEQHO(I)=RTSEGM(IDK+I-1) 420 CONTINUE CALL AEXGNV(22,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NTEMPS) ALLOCATE(TEMPS(NTEMPS)) DO 430 I=1,NTEMPS TEMPS(I)=RTSEGM(IDK+I-1) 430 CONTINUE IF(IMPX.GT.1) THEN WRITE(IOUT,910) (SEQHO(I),I=1,NSEQHO) WRITE(IOUT,920) (TEMPS(I),I=1,NTEMPS) WRITE(IOUT,930) FGHOMO,FGRESO,NGHOMO,NSEQHO,NTEMPS,L104, 1 NBIN ENDIF ENDIF CALL LCMDRD(TSEGM_PTR) CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) 440 CONTINUE IF(.NOT.LPTHOM) CALL XABORT('LIBA20: NO PTHOM1 SEGMENT.') LENGTH=NGHOMO*NSEQHO*NTEMPS IF(LENGTH.EQ.0) THEN DEALLOCATE(SEQHO,ITCARO) DO 450 JMX=IMX,NBISO IF(IPR(5,JMX).EQ.KISEG) IPR(5,JMX)=0 450 CONTINUE GO TO 550 ENDIF ALLOCATE(TAUX(7*NGHOMO)) TAUX(:7*NGHOMO)=0.0 *---- * RECOVER THE SELF-SHIELDED FLUX (REACTION 104). *---- IF(L104) THEN KISEG=IPR(6,IMX) IF(KISEG.EQ.0) THEN WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3) WRITE(HSMG,850) HNAMIS,HNISSS,NAMFIL,1 CALL XABORT(HSMG) ENDIF IDKOBJ=KDS(KISEG) LGSEG=LGS(KISEG) ALLOCATE(ITC104(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITC104,IDKOBJ,LGSEG) LDKDS=ITC104(IDKDS) LDKTS=ITC104(IDKTS) IF(ITC104(IDKNS).NE.1) CALL XABORT('LIBA20: INVALID FL104(' 1 //'1).') CALL AEXCPC(LDKTS,8,ITC104(1),TYPSEG) IF(TYPSEG.NE.'.R3 TXSS') CALL XABORT('LIBA20: INVALID FL10' 1 //'4(2).') LNGS=ITC104(IDKLS+1) IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID FL104(3).') LDKS=ITC104(LDKDS+1) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) ALLOCATE(ITS104(LNGS+1)) CALL AEXDIR(IUNIT,LBLOC,ITS104,LDKS,LNGS+1) CALL AEXGNV(1,ITS104,ICHDIM,ICHTYP,ICHDKL,IDK104,NV) IF(NV.NE.LENGTH) CALL XABORT('LIBA20: INVALID FL104(4).') CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) DEALLOCATE(ITC104) ENDIF *---- * RECOVER THE SELF-SHIELDED EFFECTIVE RATES. *---- LPTHOM=.FALSE. KISEG=IPR(5,IMX) DO 470 IS=1,NS IDK=JDKTS+8*(IS-1) CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) LNGS=ITCARO(IDKLS+IS) IF(LNGS.LE.0) GO TO 470 JDKS=ITCARO(JDKDS+IS) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) IF(TYPSEG.EQ.'PTHOM2') THEN LPTHOM=.TRUE. CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKA,NV) LABS=NV.EQ.LENGTH CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKD,NV) LDIF=NV.EQ.LENGTH CALL AEXGNV(9,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKF,NV) LFIS=NV.EQ.LENGTH DO 460 JMX=IMX,NBISO IF(IPR(5,JMX).EQ.KISEG) THEN WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3) KPLIB=IPISO(JMX) ! set JMX-th isotope CALL LIBA24(HNAMIS,NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS, 1 LFIS,L104,SEQHO,TEMPS,TN(JMX),SN(1,JMX),ITSEGM(IDKA), 2 ITSEGM(IDKD),ITSEGM(IDKF),ITS104(IDK104),IMPX,TAUX) * * COMPUTE THE SELF-SHIELDED FLUX AND CROSS SECTIONS. CALL LIBA25(KPLIB,LABS,LDIF,LFIS,L104,NGRO,FGHOMO, 1 NGHOMO,NSEQHO,NL,SEQHO,SN(1,JMX),SB(1,JMX),DELTA, 2 ISONAM(1,JMX),TAUX,IMPX) IPR(5,JMX)=0 IPR(6,JMX)=0 ENDIF 460 CONTINUE ENDIF CALL LCMDRD(TSEGM_PTR) CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) 470 CONTINUE IF(.NOT.LPTHOM) CALL XABORT('LIBA20: NO PTHOM2 SEGMENT.') IF(L104) DEALLOCATE(ITS104) DEALLOCATE(SEQHO,ITCARO) CALL KDRCPU(TK2) TKT(4)=TKT(4)+(TK2-TK1) *---- * RECOVER THE AUTOLIB (BIN CROSS SECTIONS) INFORMATION. *---- IF((NBIN.GT.0).AND.(IPROC.GE.3)) THEN CALL KDRCPU(TK1) KISEG=IPR(7,IMX) IF(KISEG.EQ.0) THEN WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3) WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3) WRITE(HSMG,850) HNAMIS,HNISSS,NAMFIL,2 CALL XABORT(HSMG) ENDIF *---- * PROCESS THE RESOLVED ENERGY DOMAIN. *---- IDKOBJ=KDS(KISEG) LGSEG=LGS(KISEG) ALLOCATE(ITCARO(LGSEG)) CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) JDKDS=ITCARO(IDKDS) JDKTS=ITCARO(IDKTS) NS=ITCARO(IDKNS) FGRESO=MAX(FGRESO,FGHOMO) IF(NS.EQ.(LGHOMO-FGRESO+1)*NTEMPS) THEN NGBIN=LGHOMO-FGRESO+1 ELSE IF(NS.EQ.NGHOMO*NTEMPS) THEN NGBIN=NGHOMO ELSE CALL XABORT('LIBA20: INVALID PTHOM5(1).') ENDIF LBIN=0 NFS(:NGRO)=0 DO 480 IG=1,NGBIN IDK=JDKTS+8*(IG-1) CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) IF(TYPSEG.NE.'PTHOM5') CALL XABORT('LIBA20: INVALID PTH' 1 //'OM5(2).') LNGS=ITCARO(IDKLS+IG) IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID PTHOM5(3).') JDKS=ITCARO(JDKDS+IG) CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, 1 ICHDKL_PTR) CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) TSEGM_PTR=LCMARA(LNGS+1) CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1) CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKD,NV) LBIN=LBIN+NV NFS(FGRESO+IG-1)=NV CALL LCMDRD(TSEGM_PTR) CALL LCMDRD(ICHDIM_PTR) CALL LCMDRD(ICHTYP_PTR) CALL LCMDRD(ICHDKL_PTR) 480 CONTINUE IF(LSACO) THEN NFSBIN=NFS(FGRESO) LBIN=LBIN+(FGRESO-FGHOMO)*NFSBIN ELSE NFSBIN=0 ENDIF DO 530 JMX=IMX,NBISO IF(IPR(7,JMX).EQ.KISEG) THEN ALLOCATE(DELTF(LBIN),SIGTF(LBIN),SIGAF(LBIN)) IOF=(FGRESO-FGHOMO)*NFSBIN ALLOCATE(SQRTE(NTEMPS)) KPLIB=IPISO(JMX) ! set JMX-th isotope DO 500 IG=1,NGBIN IGG=FGRESO+IG-1 CALL LIBA26(LGSEG,IG,NGBIN,IUNIT,LBLOC,TKCARO,ITCARO, 1 NFS(IGG),TN(JMX),NTEMPS,TEMPS,DELTF(IOF+1),SIGTF(IOF+1), 2 SIGAF(IOF+1),DELINF,SGTINF,SGAINF) IG2=IG+FGRESO-FGHOMO F1=DELTA(IGG)/DELINF F2=(TAUX(4*NGHOMO+IG2)+ 1 TAUX(5*NGHOMO+IG2))/(SGTINF*DELTA(IGG)) F3=TAUX(4*NGHOMO+IG2)/(SGAINF*DELTA(IGG)) DO 490 I=1,NFS(IGG) DELTF(IOF+I)=DELTF(IOF+I)*F1 SIGTF(IOF+I)=SIGTF(IOF+I)*F2 SIGAF(IOF+I)=SIGAF(IOF+I)*F3 490 CONTINUE IOF=IOF+NFS(IGG) 500 CONTINUE DEALLOCATE(SQRTE) *---- * PROCESS THE UNRESOLVED ENERGY DOMAIN. THE AUTOLIB OF THE FIRST * RESOLVED ENERGY GROUP IS USED AND NORMALIZED TO THE CORRECT * INFINITE DILUTION VALUES. USED WITH THE SANCHEZ-COSTE METHOD. *---- IF(LSACO) THEN E0=ENERG(FGHOMO) IG2=FGRESO-FGHOMO+1 E1=DELTA(FGRESO) E2=(TAUX(4*NGHOMO+IG2)+TAUX(5*NGHOMO+IG2)) E3=TAUX(4*NGHOMO+IG2) IBIN=0 DO 515 IGG=FGHOMO,FGRESO-1 NFS(IGG)=NFSBIN IG2=IGG-FGHOMO+1 F1=DELTA(IGG)/E1 F2=(TAUX(4*NGHOMO+IG2)+TAUX(5*NGHOMO+IG2))/E2 F3=TAUX(4*NGHOMO+IG2)/E3 JBIN=(FGRESO-FGHOMO)*NFSBIN DO 510 I=1,NFSBIN IBIN=IBIN+1 JBIN=JBIN+1 DELTF(IBIN)=DELTF(JBIN)*F1 SIGTF(IBIN)=SIGTF(JBIN)*F2/F1 SIGAF(IBIN)=SIGAF(JBIN)*F3/F1 510 CONTINUE 515 CONTINUE ELSE E0=ENERG(FGRESO) ENDIF * ALLOCATE(ENER(LBIN+1)) ENER(1)=E0 UU=0.0D0 DO 520 I=1,LBIN UU=UU+DELTF(I) ENER(I+1)=REAL(E0*EXP(-UU)) SIGAF(I)=SIGTF(I)-SIGAF(I) 520 CONTINUE DEALLOCATE(DELTF) CALL LCMPUT(KPLIB,'BIN-NFS',NGRO,1,NFS) CALL LCMPUT(KPLIB,'BIN-ENERGY',LBIN+1,2,ENER) CALL LCMPUT(KPLIB,'BIN-NTOT0',LBIN,2,SIGTF) CALL LCMPUT(KPLIB,'BIN-SIGS00',LBIN,2,SIGAF) DEALLOCATE(SIGAF,SIGTF,ENER) IPR(7,JMX)=0 ENDIF 530 CONTINUE DEALLOCATE(ITCARO) CALL KDRCPU(TK2) TKT(5)=TKT(5)+(TK2-TK1) ELSE KISEG=IPR(7,IMX) DO 540 JMX=IMX,NBISO IF(IPR(7,JMX).EQ.KISEG) IPR(7,JMX)=0 540 CONTINUE ENDIF DEALLOCATE(TEMPS,TAUX) * 550 IF(IMPX.GT.9) THEN KPLIB=IPISO(IMX) ! set IMX-th isotope CALL LCMLIB(KPLIB) ENDIF ENDIF 560 CONTINUE * DEALLOCATE(LGS,KDS,NOMOB,AMASS) IERR=KDRCLS(IUNIT,1) IF(IERR.LT.0) THEN TEXT12=NAMFIL CALL XABORT('LIBA20: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'// 1 'E CLOSED') ENDIF *---- * CHECK IF ALL REACTIONS HAVE BEEN PROCESSED. *---- DO 575 IMX=1,NBISO DO 570 I=2,7+2*(NL-1) IF(IPR(I,IMX).NE.0) THEN WRITE(HSMG,950) I,(ISONAM(I0,IMX),I0=1,3) CALL XABORT(HSMG) ENDIF 570 CONTINUE 575 CONTINUE IF(IMPX.GT.2) WRITE(IOUT,940) (TKT(I),I=1,5) *---- * ADD NG CROSS SECTIONS. *---- DO 610 IMX=1,NBISO IF(MASKI(IMX)) THEN KPLIB=IPISO(IMX) ! set IMX-th isotope CALL LCMGET(KPLIB,'NTOT0',SECT) CALL LCMLEN(KPLIB,'SIGS00',LENGT,ITYLCM) IF(LENGT.EQ.NGRO) THEN CALL LCMGET(KPLIB,'SIGS00',XSTOT) DO 580 IU=1,NGRO SECT(IU)=SECT(IU)-XSTOT(IU) 580 CONTINUE ENDIF CALL LCMLEN(KPLIB,'NFTOT',LENGT,ITYLCM) IF(LENGT.EQ.NGRO) THEN CALL LCMGET(KPLIB,'NFTOT',XSTOT) DO 590 IU=1,NGRO SECT(IU)=SECT(IU)-XSTOT(IU) 590 CONTINUE ENDIF CALL LCMLEN(KPLIB,'N2N',LENGT,ITYLCM) IF(LENGT.EQ.NGRO) THEN CALL LCMGET(KPLIB,'N2N',XSTOT) DO 600 IU=1,NGRO SECT(IU)=SECT(IU)+XSTOT(IU) 600 CONTINUE ENDIF CALL LCMPUT(KPLIB,'NG',NGRO,2,SECT) CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM) IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR') ENDIF 610 CONTINUE *---- * PROCESS H-FACTOR INFORMATION *---- ALLOCATE(QQNG(NISOT),QQF(NISOT)) CALL LIBEAQ(NAMFIL,NISOT,IMPX,QQNG,QQF) DO 620 IMX=1,NBISO IF(MASKI(IMX)) THEN KPLIB=IPISO(IMX) ! set IMX-th isotope ISO=IPR2(IMX) ALLOCATE(HFACT(NGRO)) HFACT(:NGRO)=0.0 * NG ENERGY. VALUE=QQNG(ISO) IF(VALUE.NE.0.0) THEN CALL LCMGET(KPLIB,'NG',SECT) HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 LH=.TRUE. ENDIF * FISSION ENERGIES. VALUE=QQF(ISO) IF(VALUE.NE.0.0) THEN CALL LCMGET(KPLIB,'NFTOT',SECT) HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 LH=.TRUE. ENDIF IF(LH) CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,HFACT) DEALLOCATE(HFACT) ENDIF 620 CONTINUE DEALLOCATE(QQF,QQNG) *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG) DEALLOCATE(NFS,ITYPRO,IPR2,IPR) RETURN * 800 FORMAT(/43H LIBA20: PROCESSING APOLIB-2 LIBRARY NAME: ,A12,1H.) 810 FORMAT(/32H LIBA20: X-SECTION LIBRARY INFO:/9X,A80/) 820 FORMAT(/35H LIBA20: PROBING THE APOLIB-2 FILE./9X,11HNUMBER OF I, 1 29HSOTOPES AT INFINITE DILUTION=,I8/9X,21HNUMBER OF SELF-SHIELD, 2 12HED ISOTOPES=,I8/9X,27HNUMBER OF APOLIBE SEGMENTS=,I8) 830 FORMAT(9HLIBA20: P,I2,27H INFO OF MATERIAL/ISOTOPE ',A12,5H' = ', 1 A12,35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.) 840 FORMAT(45HLIBA20: PRODUCTION INFO OF MATERIAL/ISOTOPE ',A12, 1 5H' = ',A12,35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.) 850 FORMAT(49HLIBA20: SELF-SHIELDING DATA OF MATERIAL/ISOTOPE ',A12, 1 5H' = ',A12,35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H(,I1, 2 2H).) 870 FORMAT(/9X,15HISOTOPE TITLE: ,A80) 875 FORMAT(/9X,6HZSECT=,10I10/(15X,10I10)) 880 FORMAT(/9X,13HTEMPERATURES=,1P,9E12.4/(22X,9E12.4)) 890 FORMAT(/9X,6HZFISS=,I2,8H LGPROB=,L2,8H LGTDIF=,L2,8H LGTTRA=,L2, 1 6H FGTD=,I5,5H ID2=,I5,8H NSECTT=,I3,8H NSETOT=,I3,6H NPHY=,I3/ 2 9X,7HNANISD=,I3,8H NANIST=,I3,8H LGTREA=,10L2) 900 FORMAT(/9X,5HFAGG=,I5,6H LAGG=,I5,6H FDGG=,I5,6H WGAL=,I5,5H FAG=, 1 I5,5H LAG=,I5,6H NGTD=,I5) 910 FORMAT(/9X,10HDILUTIONS=,1P,9E12.4/(19X,9E12.4)) 920 FORMAT(/9X,28HSELF-SHIELDING TEMPERATURES=,1P,7E12.4/(37X,7E12.4)) 930 FORMAT(/9X,7HFGHOMO=,I4,8H FGRESO=,I4,8H NGHOMO=,I4,8H NSEQHO=, 1 I4,8H NTEMPS=,I4,6H L104=,L2,6H NBIN=,I5) 940 FORMAT(/26H LIBA20: CPU TIME USAGE --,F10.2,9H INDEXING/26X, 1 F10.2,24H INFINITE DILUTION P0 XS/26X,F10.2,11H PN XS DATA/ 2 26X,F10.2,27H DILUTION-DEPENDENT XS DATA/26X,F10.2,5H AUTO, 3 12HLIB XS DATA.) 950 FORMAT(26HLIBA20: REMAINING REACTION,I3,14H FOR ISOTOPE ',3A4, 1 2H'.) END