*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