From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/LIBA20.f | 1346 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1346 insertions(+) create mode 100644 Dragon/src/LIBA20.f (limited to 'Dragon/src/LIBA20.f') diff --git a/Dragon/src/LIBA20.f b/Dragon/src/LIBA20.f new file mode 100644 index 0000000..73b65fc --- /dev/null +++ b/Dragon/src/LIBA20.f @@ -0,0 +1,1346 @@ +*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 + 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 + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR + REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, + 1 DELTF,SIGTF,SIGAF,ENER,AMASS,TEMP,TEMPS,SEQHO,SQRTE,PWD,PED + 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),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) + 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) + ENDIF + 610 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG) + DEALLOCATE(NFS,ITYPRO,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 -- cgit v1.2.3