summaryrefslogtreecommitdiff
path: root/Dragon/src/LIBTR1.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/LIBTR1.f')
-rw-r--r--Dragon/src/LIBTR1.f793
1 files changed, 793 insertions, 0 deletions
diff --git a/Dragon/src/LIBTR1.f b/Dragon/src/LIBTR1.f
new file mode 100644
index 0000000..063d9a3
--- /dev/null
+++ b/Dragon/src/LIBTR1.f
@@ -0,0 +1,793 @@
+*DECK LIBTR1
+ SUBROUTINE LIBTR1 (IPLIB,NAMFIL,NGRO,NBISO,NL,ISONAM,ISONRF,
+ 1 IPISO,ICOHNA,IINCNA,NTFG,TN,SN,SB,MASKI,NED,HVECT,ITIME,IMPX,
+ 2 NGF,NGFR)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Transcription of the useful interpolated microscopic cross section
+* data from matxs to LCM data structures. Use matxs format from NJOY-II
+* or NJOY89.
+*
+*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 MATXS library 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.
+* ISONAM alias name of isotopes.
+* ISONRF library reference name of isotopes.
+* IPISO pointer array towards microlib isotopes.
+* ICOHNA hcoh name.
+* IINCNA hinc name.
+* NTFG number of thermal groups where the thermal inelastic
+* correction is applied.
+* 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.
+* MASKI isotopic mask. Isotope with index I is processed if
+* MASKI(I)=.true.
+* NED number of extra vector edits from matxs.
+* HVECT matxs names of the extra vector edits.
+* MATXS reserved names:
+* NWT0/NWT1 p0/p1 library weight function;
+* NTOT0/NTOT1 p0/p1 neutron total cross sections;
+* NELAS neutron elastic scattering cross section;
+* NINEL neutron inelastic scattering cross section;
+* NG radiative capture cross section;
+* NFTOT total fission cross section;
+* NUDEL number of delayed secondary neutrons (nu-d);
+* NFSLO nu * slow fission cross section;
+* CHIS/CHID slow/delayed fission spectrum;
+* NF/NNF/N2NF/N3NF nu * partial fission cross sections;
+* N2N/N3N/N4N (n,2n),(n,3n),(n,4n) cross sections.
+* ITIME MATXS type of fission spectrum:
+* =1 steady-state; =2 prompt.
+* IMPX print flag.
+*
+*Parameters: output
+* NGF number of fast groups without self-shielding.
+* NGFR number of fast and resonance groups.
+*
+*Reference:
+* R. E. Macfarlane, TRANSX-CTR: A code for interfacing matxs cross-
+* section libraries to nuclear transport codes for fusion systems
+* analysis, Los Alamos National Laboratory, Report LA-9863-MS,
+* New Mexico, February 1984.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT CHARACTER*6 (H)
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPLIB,IPISO(NBISO)
+ INTEGER NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO),
+ 1 ICOHNA(2,NBISO),IINCNA(2,NBISO),NTFG(NBISO),NED,ITIME,IMPX,
+ 2 NGF,NGFR
+ REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO)
+ LOGICAL MASKI(NBISO)
+ CHARACTER NAMFIL*(*),HVECT(NED)*(*)
+*----
+* LOCAL VARIABLES
+*----
+ CHARACTER FORM*4,HSMG*131,HNISOR*12,HINC*6,HCOH*6,README*88,
+ 1 HNAMIS*12
+ PARAMETER (MULT=2,IOUT=6,FORM='(A6)',MAXA=1000)
+ TYPE(C_PTR) KPLIB
+ LOGICAL LSUBM1,LTIME,LTERP
+ DOUBLE PRECISION HA(MAXA/2)
+ REAL A(MAXA)
+ INTEGER IA(MAXA),IHGAR(22)
+ CHARACTER*6 HGAR(18)
+ EQUIVALENCE (A(1),IA(1),HA(1))
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR
+ REAL, ALLOCATABLE, DIMENSION(:) :: AWR,CNORM,SNORM,DNORM,SFIS,
+ 1 SAVE,VECT,GAR,XS,TERP,TEMP,SIGZ
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: CHI,SIGF,TOTAL,FLUX
+ REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGS,SCAT
+ LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: LOGIED
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(IPR(2,NBISO),ITYPRO(NL))
+ ALLOCATE(AWR(NBISO),CNORM(NBISO),SNORM(NBISO),DNORM(NBISO),
+ 1 SFIS(NGRO),SAVE(NGRO),CHI(NGRO,NBISO),SIGS(NGRO,NL,NBISO),
+ 2 SIGF(NGRO,NBISO),TOTAL(NGRO,NBISO),SCAT(NGRO,NGRO,NL),
+ 3 FLUX(NGRO,NBISO),VECT(NGRO),GAR(NGRO))
+ ALLOCATE(LOGIED(NED,NBISO))
+*
+ NGF=NGRO+1
+ NGFR=0
+ DO 20 I=1,NBISO
+ IPR(1,I)=0
+ IPR(2,I)=0
+ 20 CONTINUE
+ IF(IMPX.GT.0) WRITE (IOUT,890) NAMFIL
+ NIN=KDROPN(NAMFIL,2,2,0)
+ IF(NIN.LE.0) THEN
+ WRITE (HSMG,'(36HLIBTR1: UNABLE TO OPEN LIBRARY FILE ,A,1H.)')
+ 1 NAMFIL
+ CALL XABORT(HSMG)
+ ENDIF
+*----
+* INITIALIZE MATXS LIBRARY
+*----
+ NWDS=1+3*MULT
+ IREC=1
+* --------------------------------
+ CALL XDREED (NIN,IREC,A(1),NWDS)
+* --------------------------------
+ WRITE(HN,FORM) HA(1)
+ WRITE(HU,FORM) HA(2)
+ WRITE(HS,FORM) HA(3)
+ IVER=IA(1+3*MULT)
+ IF(IMPX.GT.0) WRITE (IOUT,935) HN,HU,HS,IVER
+*----
+* FILE CONTROL
+*----
+ NWDS=3
+ IREC=2
+* --------------------------------
+ CALL XDREED (NIN,IREC,A(1),NWDS)
+* --------------------------------
+ NPART=IA(1)
+ NTYPE=IA(2)
+ NHOLL=IA(3)
+*----
+* SET HOLLERITH IDENTIFICATION
+*----
+ NWDS=NHOLL*MULT
+ IF(NWDS.GT.MAXA)
+ 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(1).')
+ IREC=3
+* --------------------------------
+ CALL XDREED (NIN,IREC,A(1),NWDS)
+* --------------------------------
+ WRITE(README(9:),'(6H FROM ,12A6)') (HA(I),I=1,MIN(NHOLL,12))
+ IF(IMPX.GT.0) WRITE (IOUT,'(1X,12A6)') (HA(I),I=1,MIN(NHOLL,12))
+*----
+* FILE DATA
+*----
+ NWDS=(NPART+NTYPE)*MULT+6*NTYPE+NPART
+ IF(NWDS.GT.MAXA)
+ 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(2).')
+ IREC=4
+* --------------------------------
+ CALL XDREED (NIN,IREC,A(1),NWDS)
+* --------------------------------
+ NWC=NPART+NTYPE
+ IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1
+ L2=1+NWDS
+ L2H=(L2-1)/MULT+1
+*----
+* CHECK GROUP STRUCTURES
+*----
+ NEX1=(NPART+NTYPE)*MULT+6*NTYPE
+ DO 170 I=1,NPART
+ WRITE(HPART,FORM) HA(I)
+ NG=IA(NEX1+I)
+ IF(((HPART.EQ.'NEUT').OR.(HPART.EQ.'N')).AND.(NG.NE.NGRO))
+ 1 CALL XABORT('LIBTR1: INCONSISTENT GROUP STRUCTURES.')
+ NWDS=IA(NEX1+I)+1
+ ALLOCATE(XS(NWDS))
+ IREC=IREC+1
+* ------------------------------
+ CALL XDREED (NIN,IREC,XS,NWDS)
+* ------------------------------
+ IF((HPART.EQ.'NEUT').OR.(HPART.EQ.'N')) THEN
+* ENERGY BOUND IN EACH GROUP (IN EV):
+ CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,XS)
+ DO 169 J=1,NGRO
+ VECT(J)=LOG(XS(J)/XS(J+1))
+ 169 CONTINUE
+ CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,VECT)
+ ENDIF
+ DEALLOCATE(XS)
+ 170 CONTINUE
+ IRZT=5+NPART
+*----
+* READ THROUGH MATXS FILE AND ACCUMULATE CROSS SECTIONS
+* FOR THIS RANGE OF MATS, LEGENDRE ORDERS, AND GROUPS.
+*----
+ DO 212 KM=1,NBISO
+ DO 205 IED=1,NED
+ LOGIED(IED,KM)=.FALSE.
+ 205 CONTINUE
+ CNORM(KM)=0.0
+ DO 211 KG=1,NGRO
+ CHI(KG,KM)=0.0
+ SIGF(KG,KM)=0.0
+ TOTAL(KG,KM)=0.0
+ DO 210 IL=1,NL
+ SIGS(KG,IL,KM)=0.0
+ 210 CONTINUE
+ 211 CONTINUE
+ 212 CONTINUE
+*----
+* ***DATA TYPE LOOP***
+*----
+ DO 680 IT=1,NTYPE
+ WRITE(HTYPE,FORM) HA(NPART+IT)
+ IF(HTYPE.EQ.'NSCAT') THEN
+ ITYPE=1
+ ELSE IF(HTYPE.EQ.'NTHERM') THEN
+ ITYPE=2
+ ELSE
+ GO TO 680
+ ENDIF
+ NDEX=(NPART+NTYPE)*MULT+IT
+ NMAT=IA(NDEX)
+ NDEX=NDEX+NTYPE
+ NINP=IA(NDEX)
+ NDEX=NDEX+NTYPE
+ NING=IA(NDEX)
+ NDEX=NDEX+NTYPE
+ NOUTP=IA(NDEX)
+ NDEX=NDEX+NTYPE
+ NOUTG=IA(NDEX)
+ NDEX=NDEX+NTYPE
+ LOCT=IA(NDEX)
+*----
+* DATA TYPE CONTROL
+*----
+ NWDS=(2+MULT)*NMAT+NINP+NOUTP+1
+ IF(L2+NWDS-1.GT.MAXA)
+ 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(3).')
+ IREC=LOCT+IRZT
+* ---------------------------------
+ CALL XDREED (NIN,IREC,A(L2),NWDS)
+* ---------------------------------
+ IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1
+ LMC=L2+NWDS
+ LMCH=L2H+NWDS/MULT
+ NSBLK=IA(L2+NMAT*(MULT+2)+NINP+NOUTP)
+ IRZM=IREC+1
+*----
+* ***MATERIAL/ISOTOPE LOOP***
+*----
+ DO 670 IM=1,NMAT
+ WRITE (HMAT,FORM) HA(L2H-1+IM)
+ 300 DO 305 IMX=1,NBISO
+ IF(MASKI(IMX)) THEN
+ IMT=IMX
+ WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,IMX),ITC=1,3)
+ WRITE(HNISOR,'(3A4)') (ISONRF(ITC,IMX),ITC=1,3)
+ WRITE(HCOH,'(A4,A2)') (ICOHNA(ITC,IMX),ITC=1,2)
+ WRITE(HINC,'(A4,A2)') (IINCNA(ITC,IMX),ITC=1,2)
+ IF(NTFG(IMX).EQ.0) IPR(2,IMX)=1
+ IF((HMAT.EQ.HNISOR(:6)).AND.(IPR(ITYPE,IMX).EQ.0)) GO TO 306
+ ENDIF
+ 305 CONTINUE
+ GO TO 670
+*----
+* MATERIAL CONTROL
+*----
+ 306 IPR(ITYPE,IMT)=1
+ KPLIB=IPISO(IMT) ! set IMT-th isotope
+ IF(ITYPE.EQ.1) THEN
+ DO 227 IL=0,NL-1
+ DO 226 IG2=1,NGRO
+ DO 225 IG1=1,NGRO
+ SCAT(IG1,IG2,IL+1)=0.0
+ 225 CONTINUE
+ 226 CONTINUE
+ 227 CONTINUE
+ ELSE
+ CALL XDRLGS(KPLIB,-1,0,0,NL-1,1,NGRO,SIGS(1,1,IMT),SCAT,
+ 1 ITYPRO)
+ ENDIF
+*
+ LOC=L2-1+MULT*NMAT+IM
+ NSUBM=IA(LOC)
+ LOCM=IA(LOC+NMAT)
+ IREC=LOCM+IRZM
+ NWDS=MULT+1+6*NSUBM
+ IF(LMC+NWDS-1.GT.MAXA)
+ 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(4).')
+* ----------------------------------
+ CALL XDREED (NIN,IREC,A(LMC),NWDS)
+* ----------------------------------
+* MASS RATIO OF EACH MATERIAL/ISOTOPE IN THE CALCULATION DOMAIN:
+ AWR(IMT)=A(LMC+MULT)
+ NWDS=NWDS+MULT-1
+ L3=LMC+NWDS
+ L3H=LMCH+NWDS/MULT
+ ALLOCATE(TERP(NSUBM*NGRO),TEMP(NSUBM),SIGZ(NSUBM))
+ DO 307 ISUBM=1,NSUBM
+ TEMP(ISUBM)=A(LMC+MULT+6*(ISUBM-1)+1)
+ SIGZ(ISUBM)=A(LMC+MULT+6*(ISUBM-1)+2)
+ 307 CONTINUE
+ CALL LIBTER(NGRO,NSUBM,TEMP,SIGZ,TN(IMT),SN(1,IMT),TERP)
+ DEALLOCATE(SIGZ,TEMP)
+ L5=0
+ IFTOT=0
+*----
+* TEMPERATURE AND BACKGROUND LOOP
+*----
+ DO 600 ISUBM=1,NSUBM
+ LOC=LMC+MULT+6*(ISUBM-1)
+ TMAT=A(LOC+1)
+ SMAT=A(LOC+2)
+ LOCS=IA(LOC+6)
+ LSUBM1=(ISUBM.EQ.1)
+ IF(.NOT.LSUBM1) THEN
+ LTERP=.TRUE.
+ DO 324 IK=1,NGRO
+ LTERP=LTERP.AND.(TERP(NGRO*(ISUBM-1)+IK).EQ.0.0)
+ 324 CONTINUE
+ IF(LTERP) GO TO 600
+ ENDIF
+*----
+* PROCESS THIS SUBMATERIAL
+*----
+ LOC=LMC+MULT+6*(ISUBM-1)
+ N1DR=IA(LOC+3)
+ N1DB=IA(LOC+4)
+ N2DB=IA(LOC+5)
+ JREC=IREC+LOCS
+*----
+* VECTOR CONTROL
+*----
+ IF(N1DR.EQ.0) GO TO 475
+ NWDS=(3+MULT)*N1DR
+ IF(L3+NWDS-1.GT.MAXA)
+ 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(5).')
+ JREC=JREC+1
+* ---------------------------------
+ CALL XDREED (NIN,JREC,A(L3),NWDS)
+* ---------------------------------
+ NEX1=L3-1+MULT*N1DR
+ NEX2=NEX1+N1DR
+ NEX3=NEX2+N1DR
+ IF(LSUBM1.AND.(IMPX.GT.4)) THEN
+ WRITE (IOUT,870) HTYPE,HMAT,(HA(L3H+IR-1),IR=1,N1DR)
+ ENDIF
+*----
+* VECTOR PARTIALS
+*----
+ IF(LSUBM1) THEN
+ IFTOT=0
+* IF NF IS PRESENT, SET IFTOT=1 AND USE NF+NNF+N2NF+N3NF
+ DO 325 IR=1,N1DR
+ WRITE(HVPS,FORM) HA(L3H-1+IR)
+ IF(HVPS.EQ.'NF') IFTOT=1
+ 325 CONTINUE
+ DO 335 KG=1,NGRO
+ SFIS(KG)=0.0
+ SAVE(KG)=0.0
+ 335 CONTINUE
+ ENDIF
+*----
+* LOOP OVER REACTIONS
+*----
+ IB=0
+ DO 470 IR=1,N1DR
+ IBLK=IA(NEX1+IR)
+ IF(IBLK.GT.IB) THEN
+ NWDS=0
+* MANY VECTORS (REACTIONS) ARE STORED IN BLOCK IBLK.
+ DO 340 IJ=1,N1DR
+ IF(IA(NEX1+IJ).NE.IBLK) GO TO 340
+ NWDS=NWDS+IA(NEX3+IJ)-IA(NEX2+IJ)+1
+ 340 CONTINUE
+ ALLOCATE(XS(NWDS))
+ JREC=JREC+1
+* ------------------------------
+ CALL XDREED (NIN,JREC,XS,NWDS)
+* ------------------------------
+ IB=IBLK
+ L5=0
+ ENDIF
+ WRITE(HVPS,FORM) HA(L3H-1+IR)
+ NK=IA(NEX3+IR)-IA(NEX2+IR)+1
+*----
+* SAVE REQUIRED EXTRA EDIT.
+*----
+ DO 346 IED=1,NED
+ IF(HVPS.EQ.HVECT(IED)) THEN
+ IF(LSUBM1) THEN
+ DO 341 IK=1,NGRO
+ VECT(IK)=0.0
+ 341 CONTINUE
+ ELSE
+ CALL LCMGET(KPLIB,HVECT(IED),VECT)
+ ENDIF
+ DO 345 IK=1,NK
+ IF(XS(L5+IK).EQ.0.0) GO TO 345
+ JJ=IA(NEX2+IR)+IK-1
+ TERPZ=1.0
+ IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ)
+ VECT(JJ)=VECT(JJ)+TERPZ*XS(L5+IK)
+ 345 CONTINUE
+ LOGIED(IED,IMT)=.TRUE.
+ CALL LCMPUT(KPLIB,HVECT(IED),NGRO,2,VECT)
+ GO TO 347
+ ENDIF
+ 346 CONTINUE
+*----
+* SAVE MODEL WEIGHT FUNCTIONS
+*----
+ 347 IF((HTYPE.EQ.'NSCAT').AND.(HVPS.EQ.'NWT0').AND.LSUBM1) THEN
+ DO 355 IK=1,NK
+ JJ=IA(NEX2+IR)+IK-1
+ FLUX(JJ,IMT)=XS(L5+IK)
+ 355 CONTINUE
+ GO TO 466
+ ENDIF
+ IF((HTYPE.EQ.'NTHERM').AND.(HVPS.NE.HINC).AND.
+ 1 (HVPS.NE.HCOH)) GO TO 466
+*----
+* LOOP OVER GROUPS
+*----
+ DO 440 IK=1,NK
+ IF(XS(L5+IK).EQ.0.0) GO TO 440
+ JJ=IA(NEX2+IR)+IK-1
+ LTIME=(ITIME.EQ.1)
+*----
+* INTERPOLATION FACTOR
+*----
+ TERPZ=1.0
+ IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ)
+ IF((SMAT.LT.0.9E10).AND.(ABS(XS(L5+IK)).GT.1.0E-6).AND.
+ 1 (.NOT.LSUBM1).AND.(HVPS.EQ.'NTOT0')) THEN
+ NGF=MIN(NGF,JJ-1)
+ NGFR=MAX(NGFR,JJ)
+ ENDIF
+ IF(ABS(TERPZ).LT.1.0E-3) GO TO 440
+ ADD=TERPZ*XS(L5+IK)
+*
+ IF(HVPS.EQ.'NTOT0') THEN
+* TOTAL XSEC
+ TOTAL(JJ,IMT)=TOTAL(JJ,IMT)+ADD
+ ELSE IF((.NOT.LSUBM1).AND.(HVPS.EQ.'NFTOT')) THEN
+* FISSION CROSS SECTION
+ SIGF(JJ,IMT)=SIGF(JJ,IMT)+ADD*SAVE(JJ)
+ ELSE IF(LSUBM1.AND.(HVPS.EQ.'NFTOT')) THEN
+ SFIS(JJ)=SFIS(JJ)+ADD
+ ELSE IF(LSUBM1.AND.(HVPS.EQ.'NFSLO')) THEN
+* SLOW FISSION
+ SIGF(JJ,IMT)=SIGF(JJ,IMT)+ADD
+ SAVE(JJ)=SAVE(JJ)+ADD
+ IF(IK.EQ.1) SNORM(IMT)=0.0
+ SNORM(IMT)=SNORM(IMT)+ADD*FLUX(JJ,IMT)
+ ELSE IF(LSUBM1.AND.(HVPS.EQ.'CHIS')) THEN
+* SLOW FISSION
+ IF(SNORM(IMT).EQ.0.0) THEN
+ WRITE (HSMG,1050) HMAT
+ CALL XABORT(HSMG)
+ ENDIF
+ ADDD=SNORM(IMT)*XS(L5+IK)
+ CNORM(IMT)=CNORM(IMT)+ADDD
+ CHI(JJ,IMT)=CHI(JJ,IMT)+ADDD
+ ELSE IF(LSUBM1.AND.LTIME.AND.(HVPS.EQ.'NUDEL')) THEN
+* DELAYED FISSION
+ SIGF(JJ,IMT)=SIGF(JJ,IMT)+ADD*SFIS(JJ)
+ SAVE(JJ)=SAVE(JJ)+SFIS(JJ)*ADD
+ IF(IK.EQ.1) DNORM(IMT)=0.0
+ DNORM(IMT)=DNORM(IMT)+ADD*SFIS(JJ)*FLUX(JJ,IMT)
+ ELSE IF(LSUBM1.AND.LTIME.AND.(HVPS.EQ.'CHID')) THEN
+* DELAYED FISSION
+ IF(DNORM(IMT).EQ.0.0) THEN
+ WRITE (HSMG,1060) HMAT
+ CALL XABORT(HSMG)
+ ENDIF
+ ADDD=DNORM(IMT)*XS(L5+IK)
+ CNORM(IMT)=CNORM(IMT)+ADDD
+ CHI(JJ,IMT)=CHI(JJ,IMT)+ADDD
+ ENDIF
+ 440 CONTINUE
+*
+* END OF REACTION LOOP
+ 466 L5=L5+NK
+ IF(L5.EQ.NWDS) DEALLOCATE(XS)
+ 470 CONTINUE
+*----
+* SCATTERING MATRIX CONTROL
+*----
+ 475 IF(N2DB.EQ.0) GO TO 600
+ DO 580 K=1,N2DB
+ NWDS=MULT+2+2*NOUTG
+ IF(L3+NWDS-1.GT.MAXA)
+ 1 CALL XABORT('LIBTR1: INSUFFICIENT VALUE OF MAXA(6).')
+ JREC=JREC+1
+* ---------------------------------
+ CALL XDREED (NIN,JREC,A(L3),NWDS)
+* ---------------------------------
+ LORD=IA(L3+MULT+1)
+ IF(LORD.EQ.0) GO TO 580
+ WRITE(HMTX,FORM) HA(L3H)
+ LONE=IA(L3+MULT)
+ LN=L3+MULT+1
+ LG=LN+NOUTG
+ IFISN=0
+ IF(HTYPE.EQ.'NSCAT'.AND.(HMTX.EQ.'NF'.OR.HMTX.EQ.'NNF'
+ 1 .OR.HMTX.EQ.'N2NF'.OR.HMTX.EQ.'N3NF')) IFISN=1
+ IF(HTYPE.EQ.'NSCAT'.AND.HMTX.EQ.'NFTOT')IFISN=2
+*----
+* SCATTERING SUB-BLOCKS
+*----
+ INC=(NOUTG-1)/NSBLK+1
+ DO 570 J=1,NSBLK
+ NWDS=0
+ DO 480 JJ=(J-1)*INC+1,MIN(J*INC,NOUTG)
+ NWDS=NWDS+IA(LN+JJ)
+ 480 CONTINUE
+ IF(NWDS.EQ.0) GO TO 570
+ NWDS=NWDS*LORD
+ ALLOCATE(XS(NWDS))
+ JREC=JREC+1
+* ------------------------------
+ CALL XDREED (NIN,JREC,XS,NWDS)
+* ------------------------------
+ IF(IFTOT.EQ.1.AND.IFISN.EQ.2) GO TO 560
+*----
+* STORE DESIRED CROSS SECTIONS
+*----
+ IF(HTYPE.EQ.'NTHERM'.AND.HMTX.NE.HINC.AND.
+ 1 HMTX.NE.HCOH) GO TO 530
+ L5=0
+*----
+* LOOP OVER SINK, ORDER, SOURCE
+*----
+ DO 525 JJ=(J-1)*INC+1,MIN(J*INC,NOUTG)
+ NP=IA(LN+JJ)
+ IF(NP.EQ.0) GO TO 520
+ DO 510 IL=1,LORD
+ ILNOW=IL+LONE
+ IF(ILNOW.GT.NL) GO TO 510
+ DO 500 IP=1,NP
+ XSNOW=XS(L5+IP+NP*(IL-1))
+ IF(XSNOW.EQ.0.) GO TO 500
+ JJP=IA(LG+JJ)-IP+1
+*----
+* INTERPOLATION FACTOR
+*----
+ TERPZ=1.0
+ IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJP)
+ IF(ABS(TERPZ).LT.1.0E-3) GO TO 500
+ XSEC=TERPZ*XSNOW
+*----
+* CHECK FOR FISSION MATRICES
+*----
+ IF(IFISN.GT.0) GO TO 490
+*----
+* THERMAL CORRECTION TO SCATTERING MATRIX
+*----
+ IF((HMTX.EQ.'NELAS').AND.(JJP.GE.NGRO-NTFG(IMT)+1)) THEN
+ IF(ILNOW.EQ.1) TOTAL(JJP,IMT)=TOTAL(JJP,IMT)-XSEC
+ GO TO 500
+ ENDIF
+ IF(((HMTX.EQ.HINC).OR.(HMTX.EQ.HCOH)).AND.(JJP.LT.
+ 1 NGRO-NTFG(IMT)+1)) GO TO 500
+*----
+* TOTAL SCATTERING MATRIX
+*----
+* SCAT(SECONDARY,PRIMARY,ORDER+1)
+ SCAT(JJ,JJP,ILNOW)=SCAT(JJ,JJP,ILNOW)+XSEC
+*----
+* TOTAL XS AND TOTAL SCATTERING VECTOR
+*----
+ SIGS(JJP,ILNOW,IMT)=SIGS(JJP,ILNOW,IMT)+XSEC
+ IF((ILNOW.EQ.1).AND.(JJP.GE.NGRO-NTFG(IMT)+1)) THEN
+ TOTAL(JJP,IMT)=TOTAL(JJP,IMT)+XSEC
+ ENDIF
+*----
+* FISSION VECTORS
+*----
+ 490 IF(ILNOW.NE.1) GO TO 500
+ IF(IFTOT.EQ.1.AND.IFISN.NE.1) GO TO 500
+ IF(IFTOT.EQ.0.AND.IFISN.NE.2) GO TO 500
+ SIGF(JJP,IMT)=SIGF(JJP,IMT)+XSEC
+ CNORM(IMT)=CNORM(IMT)+XSEC*FLUX(JJP,IMT)
+ CHI(JJ,IMT)=CHI(JJ,IMT)+XSEC*FLUX(JJP,IMT)
+ 500 CONTINUE
+ 510 CONTINUE
+ 520 L5=L5+NP*LORD
+ 525 CONTINUE
+*----
+* ACCUMULATE FISSION NUBAR
+*----
+ 530 IF(LSUBM1.AND.(HTYPE.EQ.'NSCAT')) THEN
+ IF(IFTOT.EQ.1.AND.IFISN.NE.1) GO TO 560
+ IF(IFTOT.EQ.0.AND.IFISN.NE.2) GO TO 560
+ L5=0
+ DO 555 JJ=(J-1)*INC+1,MIN(J*INC,NOUTG)
+ NP=IA(LN+JJ)
+ IF(NP.EQ.0) GO TO 550
+ DO 540 IP=1,NP
+ JJP=IA(LG+JJ)-IP+1
+ SAVE(JJP)=SAVE(JJP)+XS(L5+IP)
+ 540 CONTINUE
+ 550 L5=L5+NP*LORD
+ 555 CONTINUE
+ ENDIF
+ 560 DEALLOCATE(XS)
+ 570 CONTINUE
+ HGAR(MOD(K-1,18)+1)=HMTX
+ IF((K.EQ.1).AND.LSUBM1.AND.(IMPX.GT.4)) THEN
+ WRITE (IOUT,880) HTYPE,HMAT
+ ENDIF
+ IF((MOD(K-1,18).EQ.17).AND.LSUBM1.AND.(IMPX.GT.4)) THEN
+ WRITE (IOUT,885) (HGAR(I)//' ',I=1,18)
+ ELSE IF((K.EQ.N2DB).AND.LSUBM1.AND.(IMPX.GT.4)) THEN
+ WRITE (IOUT,885) (HGAR(I)//' ',I=1,MOD(N2DB-1,18)+1)
+ ENDIF
+ 580 CONTINUE
+*----
+* SAVE FISSION NU FOR SHIELDING TERMS
+*----
+ IF(LSUBM1.AND.(HTYPE.EQ.'NSCAT')) THEN
+ DO 590 JJ=1,NGRO
+ IF(SFIS(JJ).EQ.0) GO TO 590
+ SAVE(JJ)=SAVE(JJ)/SFIS(JJ)
+ 590 CONTINUE
+ ENDIF
+*----
+* END OF SUBMATERIAL LOOP
+*----
+ 600 CONTINUE
+ DEALLOCATE(TERP)
+*----
+* SAVE SCATTERING MATRICES ON LCM
+*----
+ CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS(1,1,IMT),SCAT,ITYPRO)
+*
+ GO TO 300
+*----
+* END OF MATERIAL AND DATA TYPE LOOPS
+*----
+ 670 CONTINUE
+ 680 CONTINUE
+*----
+* CLOSE MATXS FILE.
+*----
+ CALL XDRCLS(NIN)
+ IER=KDRCLS(NIN,1)
+ IF(IER.LT.0) THEN
+ WRITE (HSMG,'(37HLIBTR1: UNABLE TO CLOSE LIBRARY FILE ,A,1H.
+ 1 )') NAMFIL
+ CALL XABORT(HSMG)
+ ENDIF
+*----
+* CHECK IF ALL NBISO ISOTOPES HAVE BEEN PROCESSED.
+*----
+ NISOT=0
+ DO 700 I=1,NBISO
+ IF(MASKI(I)) THEN
+ IF((IPR(1,I).EQ.0).OR.(IPR(2,I).EQ.0)) THEN
+ WRITE (IOUT,910) (ISONAM(ITC,I),ITC=1,3),NAMFIL
+ NISOT=NISOT+1
+ ENDIF
+ ENDIF
+ 700 CONTINUE
+ IF(NISOT.GT.0) CALL XABORT('LIBTR1: MISSING ISOTOPES')
+*----
+* PRINT FINAL FLUX COMPONENTS
+*----
+ IF(IMPX.GT.6) THEN
+ DO 720 IRG=1,NBISO
+ IF(MASKI(IRG)) THEN
+ SUM=0.0
+ DO 710 JJ=1,NGRO
+ SUM=SUM+FLUX(JJ,IRG)
+ 710 CONTINUE
+ WRITE(IOUT,927) (ISONAM(ITC,IRG),ITC=1,3),SUM
+ WRITE(IOUT,928) (FLUX(I,IRG),I=1,NGRO)
+ ENDIF
+ 720 CONTINUE
+ ENDIF
+*----
+* PERFORM LIVOLANT-JEANPIERRE NORMALIZATION AND SAVE CROSS SECTION
+* INFORMATION ON LCM.
+*----
+ DO 830 IM=1,NBISO
+ IF(MASKI(IM)) THEN
+ WRITE(HNAMIS,'(3A4)') (ISONAM(ITC,IM),ITC=1,3)
+ KPLIB=IPISO(IM) ! set IM-th isotope
+ DO 740 I=1,NGRO
+ IF((SN(I,IM).NE.SB(I,IM)).AND.(SN(I,IM).LT.1.0E10)) THEN
+ VECT(I)=1.0/(1.0+(TOTAL(I,IM)-SIGS(I,1,IM))*(1.0/SN(I,IM)-
+ 1 1.0/SB(I,IM)))
+ ELSE
+ VECT(I)=1.0
+ ENDIF
+ IF(SN(I,IM).LT.1.0E10) THEN
+ FLUX(I,IM)=SN(I,IM)/(SN(I,IM)+TOTAL(I,IM)-SIGS(I,1,IM))/
+ 1 VECT(I)
+ ELSE
+ FLUX(I,IM)=1.0
+ ENDIF
+ TOTAL(I,IM)=TOTAL(I,IM)*VECT(I)
+ 740 CONTINUE
+ IF(IMPX.GT.5) THEN
+ WRITE(IOUT,920) HNAMIS
+ WRITE(IOUT,928) (VECT(I),I=1,NGRO)
+ ENDIF
+ CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,TOTAL(1,IM))
+ CALL LCMPUT(KPLIB,'NWT0',NGRO,2,FLUX(1,IM))
+ CALL XDRLGS(KPLIB,-1,0,0,NL-1,1,NGRO,SIGS(1,1,IM),SCAT,
+ 1 ITYPRO)
+ DO 752 IL=0,NL-1
+ DO 751 IG2=1,NGRO
+ FACTOR=VECT(IG2)
+ SIGS(IG2,IL+1,IM)=SIGS(IG2,IL+1,IM)*FACTOR
+ DO 750 IG1=1,NGRO
+ SCAT(IG1,IG2,IL+1)=SCAT(IG1,IG2,IL+1)*FACTOR
+ 750 CONTINUE
+ 751 CONTINUE
+ 752 CONTINUE
+ CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS(1,1,IM),SCAT,
+ 1 ITYPRO)
+ DO 780 IED=1,NED
+ IF(LOGIED(IED,IM).AND.(HVECT(IED)(:3).NE.'CHI')
+ 1 .AND.(HVECT(IED)(:2).NE.'NU')
+ 2 .AND.(HVECT(IED).NE.'NTOT0')
+ 3 .AND.(HVECT(IED)(:3).NE.'NWT')) THEN
+ CALL LCMGET(KPLIB,HVECT(IED),GAR)
+ DO 770 I=1,NGRO
+ GAR(I)=GAR(I)*VECT(I)
+ 770 CONTINUE
+ CALL LCMPUT(KPLIB,HVECT(IED),NGRO,2,GAR)
+ ENDIF
+ 780 CONTINUE
+*
+ IF(CNORM(IM).NE.0.0) THEN
+* FISSION SOURCE NORMALIZATION
+ DO 790 JJ=1,NGRO
+ CHI(JJ,IM)=CHI(JJ,IM)/CNORM(IM)
+ SIGF(JJ,IM)=SIGF(JJ,IM)*VECT(JJ)
+ 790 CONTINUE
+ CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SIGF(1,IM))
+ CALL LCMPUT(KPLIB,'CHI',NGRO,2,CHI(1,IM))
+ ENDIF
+ CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS)
+ CALL LCMPUT(KPLIB,'AWR',1,2,AWR(IM))
+ WRITE(README(:8),'(A8)') HNAMIS(1:8)
+ READ(README,'(22A4)') (IHGAR(I),I=1,22)
+ CALL LCMPUT(KPLIB,'README',22,3,IHGAR)
+ ENDIF
+ 830 CONTINUE
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ DEALLOCATE(LOGIED)
+ DEALLOCATE(GAR,VECT,FLUX,SCAT,TOTAL,SIGF,SIGS,CHI,SAVE,SFIS,
+ 1 DNORM,SNORM,CNORM,AWR)
+ DEALLOCATE(ITYPRO,IPR)
+ RETURN
+*
+ 870 FORMAT(/52H AVAILABLE IDENTIFIERS OF REACTION VECTORS FOR TYPE ,
+ 1 A6,14H AND MATERIAL ,A6,1H:/(1X,18A7))
+ 880 FORMAT(/53H AVAILABLE IDENTIFIERS OF REACTION MATRICES FOR TYPE ,
+ 1 A6,14H AND MATERIAL ,A6,1H:)
+ 885 FORMAT(1X,18A7)
+ 890 FORMAT(/32H PROCESSING MATXS LIBRARY NAMED ,A,1H.)
+ 910 FORMAT(/27H LIBTR1: MATERIAL/ISOTOPE ',3A4,16H' IS MISSING ON ,
+ 1 16HMATXS FILE NAME ,A,1H.)
+ 920 FORMAT(/40H L-J NORMALIZATION FACTORS FOR MATERIAL ,A12)
+ 927 FORMAT(/19H FLUX FOR MATERIAL ,3A4,7H SUM=,1P,E12.5)
+ 928 FORMAT(1X,1P,10E12.4)
+ 935 FORMAT(/16H MATXS FILE ID: ,3A6,6H VERS ,I2)
+ 1050 FORMAT(35HLIBTR1: SNORM MISSING FOR MATERIAL ,A6,1H.)
+ 1060 FORMAT(35HLIBTR1: DNORM MISSING FOR MATERIAL ,A6,1H.)
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:33:17 +0000