summaryrefslogtreecommitdiff
path: root/Dragon/src/LIBXS4.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/LIBXS4.f')
-rw-r--r--Dragon/src/LIBXS4.f958
1 files changed, 958 insertions, 0 deletions
diff --git a/Dragon/src/LIBXS4.f b/Dragon/src/LIBXS4.f
new file mode 100644
index 0000000..6debb37
--- /dev/null
+++ b/Dragon/src/LIBXS4.f
@@ -0,0 +1,958 @@
+*DECK LIBXS4
+ SUBROUTINE LIBXS4 (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-XSM to LCM data structures.
+*
+*Copyright:
+* Copyright (C) 2014 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-XSM 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)=.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.
+*
+*-----------------------------------------------------------------------
+*
+ 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
+*----
+ TYPE(C_PTR) IPAP
+ LOGICAL LSACO
+ PARAMETER (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 TEXT20*20,TEXT80*80,HNAMIS*12,HNISOR*12,HNISSS*12,
+ 1 HSMG*131,TEXT2*2,TEXT12*12
+ LOGICAL LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,L104,LABS,LDIF,
+ 1 LFIS,LPWD,LPED
+ INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG
+ DOUBLE PRECISION UU,XDRCST
+ INTEGER ITHOMO(MAXHOM),ITEXT(20)
+ REAL TKT(5)
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,NOM,NOMS,ISECTT,
+ 1 IFDG,IIAD,IDEPL
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR
+ REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX,
+ 1 DELTF,SIGTF,SIGAF,SIGFF,ENER,AMASS,TEMP,TEMPS,SEQHO,PWD,PED,DKA,
+ 2 DKD,DKF,DK104
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,CHID
+ REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT
+ LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE
+ REAL, POINTER, DIMENSION(:) :: RTSEGM
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(IPR(2,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 THE APOLIB-XSM FILE.
+*----
+ CALL LCMOP(IPAP,NAMFIL,2,2,0)
+*----
+* RECOVER INFORMATION FROM PHEAD DIRECTORY
+*----
+ CALL LCMSIX(IPAP,'PHEAD',1)
+ IF(IMPX.GT.0) THEN
+ CALL LCMGTC(IPAP,'COMH',80,TEXT80)
+ WRITE (IOUT,810) TEXT80
+ WRITE (IOUT,'(40H LIBXS4: NUMBER OF ISOTOPES IN MICROLIB=,I6)')
+ 1 NBISO
+ ENDIF
+ CALL LCMLEN(IPAP,'NOM',NV,ITYLCM)
+ NISOT=NV/5
+ ALLOCATE(NOM(5*NISOT))
+ CALL LCMGET(IPAP,'NOM',NOM)
+ IF(IMPX.GE.10) THEN
+ DO ISO=1,NISOT
+ WRITE(TEXT20,'(5A4)') (NOM((ISO-1)*5+II),II=1,5)
+ WRITE(IOUT,'(8H -----> ,A20)') TEXT20
+ ENDDO
+ ENDIF
+ CALL LCMLEN(IPAP,'NOMS',NV,ITYLCM)
+ NISOTS=NV/5
+ ALLOCATE(NOMS(5*NISOTS))
+ CALL LCMGET(IPAP,'NOMS',NOMS)
+ IF(IMPX.GE.10) THEN
+ DO ISO=1,NISOTS
+ WRITE(TEXT20,'(5A4)') (NOMS((ISO-1)*5+II),II=1,5)
+ WRITE(IOUT,'(8H -----> ,A20)') TEXT20
+ ENDDO
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+*----
+* RECOVER INFORMATION FROM PMAIL DIRECTORY
+*----
+ CALL LCMSIX(IPAP,'PMAIL',1)
+ CALL LCMLEN(IPAP,'E',NV,ITYLCM)
+ NGRO=NV-1
+ CALL LCMGET(IPAP,'E',ENERG)
+ CALL LCMGET(IPAP,'DEL',DELTA)
+ CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENERG)
+ CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA)
+ CALL LCMSIX(IPAP,' ',2)
+*----
+* RECOVER INFORMATION FROM PCONST DIRECTORY
+*----
+ CALL LCMSIX(IPAP,'PCONST',1)
+ CALL LCMLEN(IPAP,'AMASS',NAMASS,ITYLCM)
+ IF(NAMASS.NE.NISOT) CALL XABORT('LIBXS4: INVALID AWR INFO.')
+ ALLOCATE(AMASS(NAMASS))
+ CALL LCMGET(IPAP,'AMASS',AMASS)
+ DO IA=1,NAMASS
+ AMASS(IA)=AMASS(IA)/ANEUT
+ ENDDO
+ CALL LCMSIX(IPAP,' ',2)
+*----
+* SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES.
+*----
+ IF(IMPX.GT.1) WRITE(IOUT,820) NISOT,NISOTS
+ IPR(:2,:NBISO)=0
+ CALL KDRCPU(TK1)
+ DO 50 IMX=1,NBISO
+ IF(MASKI(IMX)) THEN
+ WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3)
+ WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3)
+ KISO=0
+ DO 10 ISO=1,NISOT
+ IF(ISONRF(1,IMX).EQ.NOM((ISO-1)*5+1)) THEN
+ IF(ISONRF(2,IMX).EQ.NOM((ISO-1)*5+2)) THEN
+ IF(ISONRF(3,IMX).EQ.NOM((ISO-1)*5+3)) THEN
+ KISO=ISO
+ GO TO 20
+ ENDIF
+ ENDIF
+ ENDIF
+ 10 CONTINUE
+ WRITE (HSMG,780) HNISOR,NAMFIL
+ CALL XABORT(HSMG)
+ 20 IPR(1,IMX)=KISO
+*
+ IF((NISOTS.GT.0).AND.(HNISSS.NE.' ')) THEN
+ KISO=0
+ DO 30 ISO=1,NISOTS
+ IF(ISHINA(1,IMX).EQ.NOMS((ISO-1)*5+1)) THEN
+ IF(ISHINA(2,IMX).EQ.NOMS((ISO-1)*5+2)) THEN
+ IF(ISHINA(3,IMX).EQ.NOMS((ISO-1)*5+3)) THEN
+ KISO=ISO
+ GO TO 40
+ ENDIF
+ ENDIF
+ ENDIF
+ 30 CONTINUE
+ WRITE (HSMG,790) HNISSS,NAMFIL
+ CALL XABORT(HSMG)
+ 40 IPR(2,IMX)=KISO
+ ENDIF
+ ENDIF
+ 50 CONTINUE
+ DEALLOCATE(NOM)
+ IF(NISOTS.GT.0) DEALLOCATE(NOMS)
+ CALL KDRCPU(TK2)
+ TKT(1)=TK2-TK1
+*----
+* READ THROUGH APOLIB-XSM 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.
+*----
+ CALL LCMSIX(IPAP,'QFIX',1)
+ KISEG=IPR(1,IMX)
+ IF(KISEG.GT.0) THEN
+ CALL KDRCPU(TK1)
+ IF(IMPX.GT.1) WRITE(IOUT,'(/29H LIBXS4: PROCESSING ISOTOPE '',
+ 1 3A4,2H''.)') (ISONRF(I0,IMX),I0=1,3)
+ WRITE(TEXT12,'(4HISOT,I8.8)') KISEG
+ CALL LCMSIX(IPAP,TEXT12,1)
+ WRITE(TEXT80,'(19HAPOLIB-XSM ISOTOPE:,3A4)') (ISONRF(I0,IMX),
+ 1 I0=1,3)
+ READ(TEXT80,'(20A4)') (ITEXT(I),I=1,20)
+ IF(IMPX.GT.2) WRITE(IOUT,870) TEXT80
+*----
+* RECOVER INFORMATION FROM ISOTOP DIRECTORY
+*----
+ CALL LCMSIX(IPAP,'ISOTOP',1)
+ CALL LCMGET(IPAP,'LGPROB',LGPROB)
+ CALL LCMGET(IPAP,'ZFISS',ZFISS)
+ CALL LCMGET(IPAP,'LGTTRA',LGTTRA)
+ CALL LCMGET(IPAP,'FGTD',FGTD)
+ CALL LCMLEN(IPAP,'ID2',NV,ITYLCM)
+ IF(NV.EQ.1) THEN
+ CALL LCMGET(IPAP,'ID2',ID2)
+ ELSE
+ ID2=0
+ ENDIF
+ CALL LCMLEN(IPAP,'TEMP',NTEMP,ITYLCM)
+ ALLOCATE(TEMP(NTEMP))
+ CALL LCMGET(IPAP,'TEMP',TEMP)
+ CALL LCMLEN(IPAP,'NANISD',NV,ITYLCM)
+ IF(NV.EQ.1) THEN
+ CALL LCMGET(IPAP,'NANISD',NANISD)
+ CALL LCMGET(IPAP,'NANIST',NANIST)
+ ELSE
+ NANISD=0
+ NANIST=0
+ ENDIF
+ CALL LCMLEN(IPAP,'LGTREA',NSECTT,ITYLCM)
+ ALLOCATE(LGTRE(NSECTT),ISECTT(2*NSECTT))
+ CALL LCMGET(IPAP,'LGTREA',LGTRE)
+ CALL LCMGET(IPAP,'TYSECT',ISECTT)
+ IF(IMPX.GT.2) WRITE(IOUT,880) (TEMP(I),I=1,NTEMP)
+ IF(IMPX.GT.2) WRITE(IOUT,890) ZFISS,LGPROB,LGTDIF,LGTTRA,
+ 1 FGTD,ID2,NSECTT,NANISD,NANIST,(LGTRE(I),I=1,NSECTT)
+ IF(NANIST.GT.NANISD) CALL XABORT('LIBXS4: NANIST.GT.NANISD')
+ CALL LCMLEN(IPAP,'PPPSN',NV,ITYLCM)
+ LTRAN=(NV.NE.0)
+ IF(LTRAN) THEN
+ CALL LCMSIX(IPAP,'PPPSN',1)
+ CALL LCMGET(IPAP,'FAGG',FAGG)
+ CALL LCMGET(IPAP,'LAGG',LAGG)
+ CALL LCMGET(IPAP,'FDGG',FDGG)
+ CALL LCMGET(IPAP,'WGAL',WGAL)
+ CALL LCMGET(IPAP,'FAG',FAG)
+ CALL LCMGET(IPAP,'LAG',LAG)
+ CALL LCMGET(IPAP,'NGTD',NGTD)
+ CALL LCMLEN(IPAP,'FDG',NV,ITYLCM)
+ ALLOCATE(IFDG(NV))
+ CALL LCMGET(IPAP,'FDG',IFDG)
+ CALL LCMLEN(IPAP,'IAD',NV,ITYLCM)
+ ALLOCATE(IIAD(NV))
+ CALL LCMGET(IPAP,'IAD',IIAD)
+ CALL LCMLEN(IPAP,'DEPL',NGTD,ITYLCM)
+ ALLOCATE(IDEPL(NGTD))
+ CALL LCMGET(IPAP,'DEPL',IDEPL)
+ IF(IMPX.GT.2) WRITE(IOUT,900) FAGG,LAGG,FDGG,WGAL,FAG,LAG,
+ 1 NGTD
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+*----
+* RECOVER INFORMATION FROM PSECT DIRECTORY
+*----
+ CALL LCMSIX(IPAP,'PSECT',1)
+ CALL LCMSIX(IPAP,'DIFP0',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,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('LIBXS4: BAD AWR.')
+ CALL LCMPUT(KPLIB,'AWR',1,2,AMASS(IPR(1,JMX)))
+ CALL LCMPUT(KPLIB,'README',20,3,ITEXT)
+ ENDIF
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SECT)
+ CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SECT)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ CALL LCMSIX(IPAP,' ',2)
+ CALL LCMLEN(IPAP,'SIGA',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'SIGA',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,
+ 1 SECT)
+ CALL LCMGET(KPLIB,'NTOT0',XSTOT)
+ DO IG=1,NGRO
+ XSTOT(IG)=XSTOT(IG)+SECT(IG)
+ ENDDO
+ CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,XSTOT)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMLEN(IPAP,'NEXCESS',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'NEXCESS',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ IF(NV.EQ.NGRO) THEN
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMGET(KPLIB,'SIGS00',SIGS)
+ LN2N=.FALSE.
+ DO IG=1,NGRO
+ LN2N=LN2N.OR.(SECT(IG).NE.0.0)
+ SIGS(IG,1)=SIGS(IG,1)+SECT(IG)
+ ENDDO
+ IF(LN2N) THEN
+ CALL LCMPUT(KPLIB,'N2N',NGRO,2,SECT)
+ CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SIGS)
+ ENDIF
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMLEN(IPAP,'SIGF',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'SIGF',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ IF(NV.EQ.NGRO) THEN
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMPUT(KPLIB,'NFTOT',NGRO,2,SECT)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMLEN(IPAP,'NUSIGF',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'NUSIGF',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ IF(NV.EQ.NGRO) THEN
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SECT)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMLEN(IPAP,'CHI',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'CHI',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ IF(NV.EQ.NGRO) THEN
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMPUT(KPLIB,'CHI',NGRO,2,SECT)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMLEN(IPAP,'CREA-A',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'CREA-A',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ IF(NV.EQ.NGRO) THEN
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMPUT(KPLIB,'NA',NGRO,2,SECT)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMLEN(IPAP,'CREA-P',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'CREA-P',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ IF(NV.EQ.NGRO) THEN
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMPUT(KPLIB,'NP',NGRO,2,SECT)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMLEN(IPAP,'CREA-H2',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'CREA-H2',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ IF(NV.EQ.NGRO) THEN
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMPUT(KPLIB,'ND',NGRO,2,SECT)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMLEN(IPAP,'CREA-H3',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'CREA-H3',1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ IF(NV.EQ.NGRO) THEN
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMPUT(KPLIB,'NT',NGRO,2,SECT)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+*----
+* RECOVER SCATTERING INFORMATION FROM ISOTOP DIRECTORY
+*----
+ CALL LCMSIX(IPAP,'ISOTOP',1)
+ IF(.NOT.LTRAN) THEN
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LCMGET(KPLIB,'SIGS00',SIGS)
+ SCAT(:NGRO,:NGRO,1)=0.0
+ DO IG=1,NGRO
+ SCAT(IG,IG,1)=SIGS(IG,1)
+ ENDDO
+ CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO)
+ ENDIF
+ ENDDO
+ ELSE
+ CALL LCMLEN(IPAP,'PSN',NV,ITYLCM)
+ IF(NV.EQ.0) CALL XABORT('LIBXS4: PPPSN MISSING.')
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'PSN',RTSEGM)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,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,SCAT)
+ CALL LCMGET(KPLIB,'SIGS00',SIGS)
+ IF(LGPROB) THEN
+ DO IG=1,NGRO
+ DO JG=1,NGRO
+ SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1)
+ ENDDO
+ ENDDO
+ ENDIF
+ CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO)
+ ENDIF
+ ENDDO
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ 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
+ WRITE(TEXT12,'(4HDIFF,I8.8)') IL-1
+ CALL LCMLEN(IPAP,TEXT12,NV,ITYLCM)
+ IF(NV.EQ.0) THEN
+ CALL LCMLIB(IPAP)
+ WRITE(HSMG,'(42HLIBXS4: MISSING SCATTERING MATRIX OF ORDER,
+ 1 I4,1H.)') IL-1
+ CALL XABORT(HSMG)
+ ENDIF
+ CALL LCMSIX(IPAP,TEXT12,1)
+ CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
+ IF(NV.EQ.0) CALL XABORT('LIBXS4: ZERO SCATTERING RECORD.')
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'SECT',RTSEGM)
+ DO 260 JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
+ CALL LCMPUT(KPLIB,'SIGS'//TEXT2,NGRO,2,SECT)
+ IF(IL.GT.NANIST) THEN
+ SCAT(:NGRO,:NGRO,1)=0.0
+ DO IG=1,NGRO
+ SIGS(IG,1)=SECT(IG)
+ SCAT(IG,IG,1)=SECT(IG)
+ ENDDO
+ CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT,
+ 1 ITYPRO)
+ ENDIF
+ ENDIF
+ 260 CONTINUE
+ CALL LCMSIX(IPAP,' ',2)
+ DEALLOCATE(RTSEGM)
+ 270 CONTINUE
+*----
+* RECOVER TRANSFER MATRICES FOR HIGHER LEGENDRE ORDERS.
+*----
+ DO 300 IL=2,MIN(NANIST,NL)
+ WRITE(TEXT2,'(I2.2)') IL-1
+ WRITE(TEXT12,'(4HTRAN,I8.8)') IL-1
+ CALL LCMLEN(IPAP,TEXT12,NV,ITYLCM)
+ IF(NV.EQ.0) THEN
+ CALL LCMLIB(IPAP)
+ WRITE(HSMG,'(40HLIBXS4: MISSING TRANSFER MATRIX OF ORDER,I4,
+ 1 1H.)') IL-1
+ CALL XABORT(HSMG)
+ ENDIF
+ CALL LCMSIX(IPAP,TEXT12,1)
+ CALL LCMLEN(IPAP,'PSN',NV,ITYLCM)
+ IF(NV.EQ.0) CALL XABORT('LIBXS4: ZERO TRANSFER RECORD.')
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'PSN',RTSEGM)
+ DO 290 JMX=IMX,NBISO
+ IF(IPR(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,SCAT)
+ CALL LCMGET(KPLIB,'SIGS'//TEXT2,SIGS)
+ IF(LGPROB) THEN
+ DO IG=1,NGRO
+ DO JG=1,NGRO
+ SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1)
+ ENDDO
+ ENDDO
+ ENDIF
+ CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT,ITYPRO)
+ ENDIF
+ 290 CONTINUE
+ CALL LCMSIX(IPAP,' ',2)
+ DEALLOCATE(RTSEGM)
+ 300 CONTINUE
+ CALL KDRCPU(TK2)
+ TKT(3)=TKT(3)+(TK2-TK1)
+*----
+* RECOVER DELAYED NEUTRON DATA.
+*----
+ CALL KDRCPU(TK1)
+ CALL LCMLEN(IPAP,'BETAEF',NV,ITYLCM)
+ IF(NV.NE.0) THEN
+ CALL LCMSIX(IPAP,'BETAEF',1)
+ CALL LCMLEN(IPAP,'WD',NDEL0,ITYLCM)
+ IF(NDEL0.GT.0) THEN
+ LPWD=.TRUE.
+ NDEL=MAX(NDEL,NDEL0)
+ ALLOCATE(PWD(NDEL0))
+ CALL LCMGET(IPAP,'WD',PWD)
+ ENDIF
+ CALL LCMLEN(IPAP,'PED',NV,ITYLCM)
+ IF(NV.EQ.NGRO) THEN
+ LPED=.TRUE.
+ ALLOCATE(PED(NGRO))
+ CALL LCMGET(IPAP,'PED',PED)
+ ENDIF
+ DO 340 JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) THEN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ CALL LCMLEN(IPAP,'LAMBDA',NV,ITYLCM)
+ IF(NV.GT.0) THEN
+ NDEL=MAX(NDEL,NV)
+ ALLOCATE(RTSEGM(NV))
+ CALL LCMGET(IPAP,'LAMBDA',RTSEGM)
+ CALL LCMPUT(KPLIB,'LAMBDA-D',NV,2,RTSEGM)
+ DEALLOCATE(RTSEGM)
+ ENDIF
+ CALL LCMLEN(IPAP,'CHID',NV,ITYLCM)
+ IF((NV.GT.0).AND.(NV.EQ.NDEL0*NGRO)) THEN
+ ALLOCATE(CHID(NGRO,NDEL0))
+ CALL LCMGET(IPAP,'CHID',CHID)
+ DO IDEL=1,NDEL0
+ WRITE(TEXT2,'(I2.2)') IDEL
+ CALL LCMPUT(KPLIB,'CHI'//TEXT2,NGRO,2,CHID(1,IDEL))
+ ENDDO
+ DEALLOCATE(CHID)
+ ENDIF
+ ENDIF
+ 340 CONTINUE
+ IF(LPWD.AND.LPED) THEN
+ DO 390 JMX=IMX,NBISO
+ IF(IPR(1,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)
+ CALL LCMSIX(IPAP,' ',2)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+ DO JMX=IMX,NBISO
+ IF(IPR(1,JMX).EQ.KISEG) IPR(1,JMX)=0
+ ENDDO
+ IF(LTRAN) DEALLOCATE(IDEPL,IIAD,IFDG)
+ DEALLOCATE(ISECTT,LGTRE,TEMP)
+ CALL KDRCPU(TK2)
+ TKT(2)=TKT(2)+(TK2-TK1)
+ IF((IMPX.GT.9).AND.(IPR(1,IMX).EQ.0)) THEN
+ KPLIB=IPISO(IMX) ! set IMX-th isotope
+ CALL LCMLIB(KPLIB)
+ ENDIF
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2)
+*----
+* PROCESS SELF-SHIELDING INFORMATION.
+*----
+ L104=.FALSE.
+ CALL LCMSIX(IPAP,'QFIXS',1)
+ KISEG=IPR(2,IMX)
+ IF(KISEG.GT.0) THEN
+ CALL KDRCPU(TK1)
+ IF(IMPX.GT.1) WRITE(IOUT,'(/31H LIBXS4: PROCESSING SELF SHIELD,
+ 1 13HING ISOTOPE '',3A4,2H''.)') (ISHINA(I0,IMX),I0=1,3)
+ WRITE(TEXT12,'(4HISOT,I8.8)') KISEG
+ CALL LCMSIX(IPAP,TEXT12,1)
+ CALL LCMSIX(IPAP,'SSDATA',1)
+ CALL LCMLEN(IPAP,'ITHOMO',NTHOMO,ITYLCM)
+ IF(NTHOMO.GT.MAXHOM) CALL XABORT('LIBXS4: ITHOMO OVERFLOW.')
+ CALL LCMGET(IPAP,'ITHOMO',ITHOMO)
+ FGHOMO=ITHOMO(1)
+ LGHOMO=ITHOMO(2)
+ FGRESO=ITHOMO(3)
+ NGHOMO=LGHOMO-FGHOMO+1
+ ALLOCATE(TAUX(7*NGHOMO))
+ TAUX(:7*NGHOMO)=0.0
+ CALL LCMGET(IPAP,'OXM',IOXM)
+ NGF=MIN(NGF,FGHOMO)
+ NGFR=MAX(NGFR,LGHOMO)
+ CALL LCMLEN(IPAP,'SEQHOM',NSEQHO,ITYLCM)
+ ALLOCATE(SEQHO(NSEQHO))
+ CALL LCMGET(IPAP,'SEQHOM',SEQHO)
+ CALL LCMLEN(IPAP,'TEMPS',NTEMPS,ITYLCM)
+ ALLOCATE(TEMPS(NTEMPS))
+ CALL LCMGET(IPAP,'TEMPS',TEMPS)
+ 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
+ ENDIF
+ CALL LCMSIX(IPAP,'PTHOM2',1)
+ LENGTH=NGHOMO*NTEMPS*NSEQHO
+ ALLOCATE(DKA(LENGTH),DKD(LENGTH),DKF(LENGTH),DK104(LENGTH))
+ DKA(:LENGTH)=0.0
+ DKD(:LENGTH)=0.0
+ DKF(:LENGTH)=0.0
+ DK104(:LENGTH)=0.0
+ CALL LCMLEN(IPAP,'ABSOH',NV,ITYLCM)
+ LABS=NV.EQ.LENGTH
+ CALL LCMLEN(IPAP,'DIFFH',NV,ITYLCM)
+ LDIF=NV.EQ.LENGTH
+ CALL LCMLEN(IPAP,'FISSH',NV,ITYLCM)
+ LFIS=NV.EQ.LENGTH
+ IF(LABS) CALL LCMGET(IPAP,'ABSOH',DKA)
+ IF(LDIF) CALL LCMGET(IPAP,'DIFFH',DKD)
+ IF(LFIS) THEN
+ CALL LCMGET(IPAP,'FISSH',DKF)
+ LFIS=.FALSE.
+ DO I=1,LENGTH
+ LFIS=LFIS.OR.(DKF(I).NE.0.0)
+ ENDDO
+ ENDIF
+ DO 460 JMX=IMX,NBISO
+ IF(IPR(2,JMX).EQ.KISEG) THEN
+ WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ IF(IMPX.GT.3) WRITE(6,'(/17H LIBXS4: PROCESS ,A12,1H:)')
+ 1 HNAMIS
+ CALL LIBA24(HNAMIS,NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS,LFIS,L104,
+ 1 SEQHO,TEMPS,TN(JMX),SN(1,JMX),DKA,DKD,DKF,DK104,IMPX,TAUX)
+*
+* COMPUTE THE SELF-SHIELDED FLUX AND CROSS SECTIONS.
+ CALL LIBA25(KPLIB,LABS,LDIF,LFIS,L104,NGRO,FGHOMO,NGHOMO,
+ 1 NSEQHO,NL,SEQHO,SN(1,JMX),SB(1,JMX),DELTA,ISONAM(1,JMX),
+ 2 TAUX,IMPX)
+ ENDIF
+ 460 CONTINUE
+ CALL LCMSIX(IPAP,' ',2) ! PTHOM2
+ CALL LCMSIX(IPAP,' ',2) ! SSDATA
+ DEALLOCATE(DK104,DKF,DKD,DKA)
+ CALL KDRCPU(TK2)
+ TKT(4)=TKT(4)+(TK2-TK1)
+*----
+* RECOVER THE AUTOLIB (BIN CROSS SECTIONS) INFORMATION.
+*----
+ CALL KDRCPU(TK1)
+ CALL LCMLEN(IPAP,'SSSECT',NV,ITYLCM)
+ IF((NV.NE.0).AND.(IPROC.GE.3)) THEN
+ CALL KDRCPU(TK1)
+ CALL LCMSIX(IPAP,'SSSECT',1)
+ LBIN=0
+ NFS(:NGRO)=0
+ NGBIN=MIN(NGHOMO,NGRO-FGRESO+1)
+ DO IG=1,NGBIN
+ WRITE(TEXT12,'(6HPTHOM5,I6.6)') IG
+ CALL LCMSIX(IPAP,TEXT12,1)
+ CALL LCMSIX(IPAP,'NTEMPS000001',1)
+ CALL LCMLEN(IPAP,'DELTF',NFS(FGRESO+IG-1),ITYLCM)
+ LBIN=LBIN+NFS(FGRESO+IG-1)
+ CALL LCMSIX(IPAP,' ',2)
+ CALL LCMSIX(IPAP,' ',2)
+ ENDDO
+ IF(LSACO) THEN
+ NFSBIN=NFS(FGRESO)
+ LBIN=LBIN+(FGRESO-FGHOMO)*NFSBIN
+ ELSE
+ NFSBIN=0
+ ENDIF
+ DO 530 JMX=IMX,NBISO
+ IF(IPR(2,JMX).EQ.KISEG) THEN
+ ALLOCATE(DELTF(LBIN),SIGTF(LBIN),SIGAF(LBIN),SIGFF(LBIN))
+ IOF=(FGRESO-FGHOMO)*NFSBIN
+ KPLIB=IPISO(JMX) ! set JMX-th isotope
+ DO 500 IG=1,NGBIN
+ IGG=FGRESO+IG-1
+ WRITE(TEXT12,'(6HPTHOM5,I6.6)') IG
+ CALL LCMSIX(IPAP,TEXT12,1)
+ CALL LIBXS5(IG,NGBIN,IPAP,NFS(IGG),TN(JMX),NTEMPS,TEMPS,
+ 1 DELTF(IOF+1),SIGTF(IOF+1),SIGAF(IOF+1),SIGFF(IOF+1),DELINF,
+ 2 SGTINF,SGAINF,SGFINF)
+ CALL LCMSIX(IPAP,' ',2)
+ 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))
+ IF(SGFINF.NE.0.0) THEN
+ F4=TAUX(6*NGHOMO+IG2)/(SGFINF*DELTA(IGG))
+ ELSE
+ F4=0.0
+ ENDIF
+ 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
+ IF(SGFINF.NE.0.0) SIGFF(IOF+I)=SIGFF(IOF+I)*F4
+ 490 CONTINUE
+ IOF=IOF+NFS(IGG)
+ 500 CONTINUE
+*----
+* 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)
+ E4=TAUX(6*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
+ IF(E4.NE.0.0) F4=TAUX(6*NGHOMO+IG2)/E4
+ 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
+ IF(E4.NE.0.0) SIGFF(IBIN)=SIGFF(JBIN)*F4/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)
+ IF(SGFINF.NE.0.0) CALL LCMPUT(KPLIB,'BIN-SIGF',LBIN,2,SIGFF)
+ DEALLOCATE(ENER,SIGFF,SIGAF,SIGTF)
+ ENDIF
+ 530 CONTINUE
+ CALL KDRCPU(TK2)
+ TKT(5)=TKT(5)+(TK2-TK1)
+ CALL LCMSIX(IPAP,' ',2) ! SSSECT
+ ENDIF
+ DO JMX=IMX,NBISO
+ IF(IPR(2,JMX).EQ.KISEG) IPR(2,JMX)=0
+ ENDDO
+ CALL LCMSIX(IPAP,' ',2) ! ISOT
+ DEALLOCATE(TAUX,TEMPS,SEQHO)
+ ENDIF
+ CALL LCMSIX(IPAP,' ',2) ! QFIXS
+ 560 CONTINUE
+ CALL LCMCL(IPAP,1)
+*----
+* CHECK IF ALL REACTIONS HAVE BEEN PROCESSED.
+*----
+ DO 575 IMX=1,NBISO
+ DO 570 I=1,2
+ 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(AMASS)
+ DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG)
+ DEALLOCATE(NFS,ITYPRO,IPR)
+ RETURN
+*
+ 780 FORMAT(26HLIBXS4: MATERIAL/ISOTOPE ',A12,20H' IS MISSING ON APOL,
+ 1 15HIB-2 FILE NAME ,A12,1H.)
+ 790 FORMAT(49HLIBXS4: SELF-SHIELDING DATA OF MATERIAL/ISOTOPE ',A12,
+ 1 35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.)
+ 800 FORMAT(/43H LIBXS4: PROCESSING APOLIB-2 LIBRARY NAME: ,A12,1H.)
+ 810 FORMAT(/32H LIBXS4: X-SECTION LIBRARY INFO:/9X,A80/)
+ 820 FORMAT(/35H LIBXS4: PROBING THE APOLIB-2 FILE./9X,11HNUMBER OF I,
+ 1 29HSOTOPES AT INFINITE DILUTION=,I8/9X,21HNUMBER OF SELF-SHIELD,
+ 2 12HED ISOTOPES=,I8)
+ 870 FORMAT(/9X,15HISOTOPE TITLE: ,A80)
+ 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/9X,7HNANISD=,I3,8H NANIST=,
+ 2 I3,8H LGTREA=,15L2/(38X,15L2))
+ 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)
+ 940 FORMAT(/26H LIBXS4: 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(26HLIBXS4: REMAINING REACTION,I3,14H FOR ISOTOPE ',3A4,
+ 1 2H'.)
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:33:53 +0000