Initial commit from Polytechnique Montreal

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