Initial commit from Polytechnique Montreal

1 files changed, 894 insertions, 0 deletions

diff --git a/Dragon/src/LIBTR2.f b/Dragon/src/LIBTR2.f
new file mode 100644
index 0000000..29c75ef
--- /dev/null
+++ b/Dragon/src/LIBTR2.f
@@ -0,0 +1,894 @@
+*DECK LIBTR2
+      SUBROUTINE LIBTR2 (IPLIB,NAMFIL,NGRO,NBISO,NL,ISONAM,ISONRF,
+     1 IPISO,ICOHNA,IINCNA,IIRESK,NTFG,TN,SN,SB,MASKI,NED,HVECT,ITIME,
+     2 IMPX,NGF,NGFR,NPART)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Transcription of the useful interpolated microscopic cross section
+* data from matxs to lcm data structures. Use matxs format from NJOY-91.
+*
+*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 name of isotopes.
+* IPISO   pointer array towards microlib isotopes.
+* ICOHNA  hcoh name.
+* IINCNA  hinc name.
+* IIRESK  resk 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);
+*          CHID  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.
+* NPART   number of particles.
+*
+*Reference:
+*  R. E. Macfarlane, TRANSX 2: A code for interfacing matxs cross-
+*  section libraries to nuclear transport codes, Los Alamos National
+*  Laboratory, Report LA-12312-MS, New Mexico, July 1992.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      USE LIBEEDR
+      IMPLICIT CHARACTER*6 (H)
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      CHARACTER*(*) HVECT(NED),NAMFIL
+      TYPE(C_PTR) IPLIB,IPISO(NBISO)
+      INTEGER NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO),
+     1 ICOHNA(2,NBISO),IINCNA(2,NBISO),IIRESK(2,NBISO),NTFG(NBISO),
+     2 NED,ITIME,IMPX,NGF,NGFR,NPART
+      LOGICAL MASKI(NBISO)
+      REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO)
+*----
+*  LOCAL VARIABLES
+*----
+      CHARACTER FORM*4,HSMG*131,HNISOR*12,HINC*6,HCOH*6,HRSK*6,
+     1 README*88,HNAMIS*12,TEXT12*12,HPRT1*1,HPRT2*1
+      CHARACTER HN*8,HU*8,HS*8
+      PARAMETER (MULT=2,IOUT=6,FORM='(A6)',MAXA=10000)
+      TYPE(C_PTR) KPLIB
+      LOGICAL LSUBM1,LTIME,LTERP,LPART,LDEP(2)
+      DOUBLE PRECISION XHA(MAXA/2)
+      REAL A(MAXA)
+      INTEGER IA(MAXA),IHGAR(22)
+      EQUIVALENCE (A(1),IA(1),XHA(1))
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IPR,ITYPRO,NGPART
+      REAL, ALLOCATABLE, DIMENSION(:) :: SFIS,SAVE,CHI,SIGF,TOTAL,FLUX,
+     1 VECT,GAR,XS,TERP,TEMP,SIGZ,C2PART
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGS,XSMAT
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SCAT
+      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LOGIED
+      CHARACTER(LEN=1), ALLOCATABLE, DIMENSION(:) :: HNPART
+      CHARACTER(LEN=6), ALLOCATABLE, DIMENSION(:) :: HMTX2
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(IPR(NBISO),ITYPRO(NL))
+      ALLOCATE(SFIS(NGRO),SAVE(NGRO),CHI(NGRO),SIGF(NGRO),TOTAL(NGRO),
+     1 FLUX(NGRO),VECT(NGRO+1),GAR(NGRO),XSMAT(NGRO,NGRO,NL))
+      ALLOCATE(LOGIED(NED))
+*
+      NGF=NGRO+1
+      NGFR=0
+      DO 100 I=1,NBISO
+      IPR(I)=0
+  100 CONTINUE
+      IF(IMPX.GT.0) WRITE (IOUT,920) NAMFIL
+      ILIBIN=2
+      IF(NAMFIL(:1).EQ.'_') ILIBIN=3
+      NIN=KDROPN(NAMFIL,2,ILIBIN,0)
+      IF(NIN.LE.0) THEN
+        WRITE (HSMG,'(36HLIBTR2: UNABLE TO OPEN LIBRARY FILE ,A,1H.)')
+     1  NAMFIL
+        CALL XABORT(HSMG)
+      ENDIF
+*----
+*  INITIALIZE MATXS LIBRARY
+*----
+      NWDS=1+3*MULT
+      IREC=1
+*     --FILE IDENTIFICATION--------------
+      IF(ILIBIN.EQ.2) THEN
+         CALL XDREED (NIN,IREC,A(1),NWDS)
+      ELSE IF(ILIBIN.EQ.3) THEN
+         CALL LIBEED (NIN,IREC,A(1),NWDS)
+      ENDIF
+*     -----------------------------------
+      WRITE(HN,'(A8)') XHA(1)
+      WRITE(HU,'(A8)') XHA(2)
+      WRITE(HS,'(A8)') XHA(3)
+      IVER=IA(1+3*MULT)
+      IF(IMPX.GT.0) WRITE (IOUT,970) HN,HU,HS,IVER
+*
+      NWDS=6
+      IREC=2
+*     --FILE CONTROL---------------------
+      IF(ILIBIN.EQ.2) THEN
+         CALL XDREED (NIN,IREC,A(1),NWDS)
+      ELSE IF(ILIBIN.EQ.3) THEN
+         CALL LIBEED (NIN,IREC,A(1),NWDS)
+      ENDIF
+*     -----------------------------------
+      NPART=IA(1)
+      NTYPE=IA(2)
+      NHOLL=IA(3)
+      NMAT=IA(4)
+      MAXW=IA(5)
+      ALLOCATE(NGPART(NPART),C2PART(NPART),HNPART(NPART),
+     1 SIGS(NGRO,NL,NPART),SCAT(NGRO,NGRO,NL,NPART))
+*
+      NWDS=NHOLL*MULT
+      IF(NWDS.GT.MAXA)
+     1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(1).')
+      IREC=3
+*     --HOLLERITH IDENTIFICATION---------
+      IF(ILIBIN.EQ.2) THEN
+         CALL XDREED (NIN,IREC,A(1),NWDS)
+      ELSE IF(ILIBIN.EQ.3) THEN
+         CALL LIBEED (NIN,IREC,A(1),NWDS)
+      ENDIF
+*     -----------------------------------
+      WRITE(README(9:),'(6H FROM ,9A8)') (XHA(I),I=1,MIN(NHOLL,9))
+      IF(IMPX.GT.0) WRITE (IOUT,'(1X,9A8)') (XHA(I),I=1,MIN(NHOLL,9))
+*
+      NWDS=(NPART+NTYPE+NMAT)*MULT+2*NTYPE+NPART+2*NMAT
+      IF(NWDS.GT.MAXA)
+     1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(2).')
+      IREC=4
+*     --FILE DATA------------------------
+      IF(ILIBIN.EQ.2) THEN
+         CALL XDREED (NIN,IREC,A(1),NWDS)
+      ELSE IF(ILIBIN.EQ.3) THEN
+         CALL LIBEED (NIN,IREC,A(1),NWDS)
+      ENDIF
+*     -----------------------------------
+      
+      IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1
+      L2=1+NWDS
+      L2H=1+NWDS/MULT
+*----
+*  CHECK GROUP STRUCTURES AND FIND INCIDENT PARTICLE TYPE
+*----
+      NEX1=(NPART+NTYPE+NMAT)*MULT
+      LPART=.FALSE.
+      HCOH=' '
+      HINC=' '
+      HRSK=' '
+      DO 120 I=1,NPART
+      WRITE(HPRT,FORM) XHA(I)
+      CALL LIBCOV(HPRT)
+      LPART=(HPRT.EQ.'N').OR.(HPRT.EQ.'G').OR.(HPRT.EQ.'B').OR.
+     1 (HPRT.EQ.'C')
+      NG=IA(NEX1+I)
+      IF(LPART.AND.(I.EQ.1).AND.(NG.NE.NGRO))
+     1 CALL XABORT('LIBTR2: INCONSISTENT GROUP STRUCTURES.')
+      HNPART(I)=HPRT(:1)
+      IF(HPRT.EQ.'N') THEN
+         C2PART(I)=9.39565413E8
+      ELSE IF((HPRT.EQ.'B').OR.(HPRT.EQ.'C')) THEN
+         C2PART(I)=5.10976031E5
+      ELSE
+         C2PART(I)=0.0
+      ENDIF
+      NGPART(I)=NG
+      NWDS=NG+1
+      ALLOCATE(XS(NWDS))
+      IREC=IREC+1
+*     --GROUP STRUCTURE----------------
+      IF(ILIBIN.EQ.2) THEN
+         CALL XDREED (NIN,IREC,XS,NWDS)
+      ELSE IF(ILIBIN.EQ.3) THEN
+         CALL LIBEED (NIN,IREC,XS,NWDS)
+      ENDIF
+*     ---------------------------------
+      IF(LPART) THEN
+*        ENERGY BOUND IN EACH GROUP (IN EV):
+         DO 110 J=1,NGRO
+         VECT(J)=LOG(XS(J)/XS(J+1))
+  110    CONTINUE
+         IF(I.EQ.1) THEN
+            CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,XS)
+            CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,VECT)
+            CALL LCMPTC(IPLIB,'PARTICLE',1,HNPART(1))
+         ELSE
+            CALL LCMPUT(IPLIB,HNPART(I)//'ENERGY',NGRO+1,2,XS)
+            CALL LCMPUT(IPLIB,HNPART(I)//'DELTAU',NGRO,2,VECT)
+         ENDIF
+      ENDIF
+      DEALLOCATE(XS)
+  120 CONTINUE
+      CALL LCMPTC(IPLIB,'PARTICLE-NAM',1,NPART,HNPART)
+      CALL LCMPUT(IPLIB,'PARTICLE-NGR',NPART,1,NGPART)
+      CALL LCMPUT(IPLIB,'PARTICLE-MC2',NPART,2,C2PART)
+      IF(.NOT.LPART) THEN
+         WRITE(HSMG,'(8HLIBTR2: ,A,32HIS NOT A SUPPORTED PARTICLE TYPE,
+     1   35H (''N'', ''G'', ''B'' AND ''C'' SUPPORTED).)') HPRT
+         CALL XABORT(HSMG)
+      ENDIF
+*----
+*  READ THROUGH MATXS FILE AND ACCUMULATE CROSS SECTIONS FOR THIS RANGE
+*  MATS, LEGENDRE ORDERS, AND GROUPS.
+*
+*  ***MATERIAL/ISOTOPE LOOP***
+*----
+      HPRT1=HNPART(1)
+      IRZM=IREC+1
+      DO 840 IM=1,NMAT
+  130 CNORM=0.0
+      DO 153 IG1=1,NGRO
+      CHI(IG1)=0.0
+      SIGF(IG1)=0.0
+      TOTAL(IG1)=0.0
+      DO 152 IL=1,NL
+      DO 151 IP=1,NPART
+      SIGS(IG1,IL,IP)=0.0
+      DO 150 IG2=1,NGRO
+      SCAT(IG1,IG2,IL,IP)=0.0
+  150 CONTINUE
+  151 CONTINUE
+  152 CONTINUE
+  153 CONTINUE
+      WRITE (HMAT,FORM) XHA(NPART+NTYPE+IM)
+      DO 160 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)
+         WRITE(HRSK,'(A4,A2)') (IIRESK(ITC,IMX),ITC=1,2)
+         CALL LIBCOV(HCOH)
+         CALL LIBCOV(HINC)
+         CALL LIBCOV(HRSK)
+         IF((HMAT.EQ.HNISOR(:6)).AND.(IPR(IMX).EQ.0)) GO TO 170
+      ENDIF
+  160 CONTINUE
+      GO TO 840
+*----
+*  RECOVER THE MATERIAL CONTROL
+*----
+  170 IPR(IMT)=1
+      LOGIED(:NED)=.FALSE.
+      LDEP(:2)=.FALSE.
+      KPLIB=IPISO(IMT) ! set IMT-th isotope
+      LOC=(NPART+NTYPE+NMAT)*MULT+NPART+2*NTYPE+IM
+      NSUB=IA(LOC)
+      LOCM=IA(LOC+NMAT)
+      IREC=LOCM+IRZM
+      NWDS=MULT+1+6*NSUB
+      IF(L2+NWDS-1.GT.MAXA)
+     1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(3).')
+*     --MATERIAL CONTROL------------------
+      IF(ILIBIN.EQ.2) THEN
+         CALL XDREED (NIN,IREC,A(L2),NWDS)
+      ELSE IF(ILIBIN.EQ.3) THEN
+         CALL LIBEED (NIN,IREC,A(L2),NWDS)
+      ENDIF
+*     ------------------------------------
+*     MASS RATIO OF EACH MATERIAL/ISOTOPE IN THE CALCULATION DOMAIN:
+      AWR=A(L2+MULT)
+      IF((NWDS/2)*2.NE.NWDS) NWDS=NWDS+1
+      L3=L2+NWDS
+      L3H=L2H+NWDS/MULT
+      ALLOCATE(TERP(NSUB*NGRO),TEMP(NSUB),SIGZ(NSUB))
+      DO 175 ISUBM=1,NSUB
+      TEMP(ISUBM)=A(L2+MULT+6*(ISUBM-1)+1)
+      SIGZ(ISUBM)=A(L2+MULT+6*(ISUBM-1)+2)
+  175 CONTINUE
+      NSUB0=0
+      DO 185 ITYPE=1,NTYPE
+      N0=0
+      DO 180 ISUBM=1,NSUB
+      IF(IA(L2+MULT+6*(ISUBM-1)+3).EQ.ITYPE) N0=N0+1
+  180 CONTINUE
+      CALL LIBTE2(NGRO,N0,TEMP(NSUB0+1),SIGZ(NSUB0+1),TN(IMT),
+     1 SN(1,IMT),TERP(NSUB0*NGRO+1))
+      NSUB0=NSUB0+N0
+  185 CONTINUE
+      IF(NSUB0.NE.NSUB) CALL XABORT('LIBTR2: DATA TYPE FAILURE.')
+      DEALLOCATE(SIGZ,TEMP)
+*----
+*  TEMPERATURE AND BACKGROUND LOOP
+*----
+      IOLDTY=0
+      L5=0
+      DNORM=0.0
+      DO 720 ISUBM=1,NSUB
+      LOC=L2+MULT+6*(ISUBM-1)
+      TMAT=A(LOC+1)
+      SMAT=A(LOC+2)
+      ITYPE=IA(LOC+3)
+      LSUBM1=(ITYPE.NE.IOLDTY)
+      IOLDTY=ITYPE
+      N1D=IA(LOC+4)
+      N2D=IA(LOC+5)
+      LOCS=IA(LOC+6)
+      LOCG=(NPART+NTYPE+NMAT)*MULT
+      JINP=IA(LOCG+NPART+ITYPE)
+      NING=IA(LOCG+JINP)
+      JOUTP=IA(LOCG+NPART+NTYPE+ITYPE)
+      NOUTG=IA(LOCG+JOUTP)
+      HPRT1=HNPART(JINP)
+      HPRT2=HNPART(JOUTP)
+      CALL LIBCOV(HPRT1)
+      CALL LIBCOV(HPRT2)
+      WRITE(HTYPE,FORM) XHA(NPART+ITYPE)
+      CALL LIBCOV(HTYPE)
+      IF(IMPX.GT.6) WRITE(IOUT,870) ISUBM,HPRT1,HPRT2,HTYPE,HMAT
+      IF(.NOT.LSUBM1) THEN
+         LTERP=.TRUE.
+         DO 190 IK=1,NGRO
+         LTERP=LTERP.AND.(TERP(NGRO*(ISUBM-1)+IK).EQ.0.0)
+  190    CONTINUE
+         IF(LTERP) GO TO 720
+      ENDIF
+*----
+*  PROCESS THIS SUBMATERIAL
+*----
+      JREC=IREC+LOCS
+      IF(N1D.EQ.0) GO TO 460
+      NWDS=(2+MULT)*N1D
+      IF(L3+NWDS-1.GT.MAXA)
+     1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(4).')
+      JREC=JREC+1
+*     --VECTOR CONTROL--------------------
+      IF(ILIBIN.EQ.2) THEN
+         CALL XDREED (NIN,JREC,A(L3),NWDS)
+      ELSE IF(ILIBIN.EQ.3) THEN
+         CALL LIBEED (NIN,JREC,A(L3),NWDS)
+      ENDIF
+*     ------------------------------------
+      NEX1=L3-1+MULT*N1D
+      NEX2=NEX1+N1D
+      IF(LSUBM1.AND.(IMPX.GT.4)) THEN
+         WRITE (IOUT,880) HTYPE,HMAT,(XHA(L3H+IR-1),IR=1,N1D)
+      ENDIF
+*----
+*  VECTOR PARTIALS
+*----
+      IF(LSUBM1) THEN
+         DO 210 KG=1,NGRO
+         SFIS(KG)=0.0
+         SAVE(KG)=0.0
+  210    CONTINUE
+      ENDIF
+*----
+*  LOOP OVER REACTIONS
+*----
+      IRMAX=0
+      DO 455 IR=1,N1D
+      IF(IR.GT.IRMAX) THEN
+*        MANY VECTORS (REACTIONS) ARE STORED IN VECTOR BLOCK.
+         NWDS=0
+         IJ0=IRMAX+1
+         DO 220 IJ=IJ0,N1D
+         NW=IA(NEX2+IJ)-IA(NEX1+IJ)+1
+         IF(NWDS+NW.GE.MAXW) GO TO 230
+         IRMAX=IRMAX+1
+         NWDS=NWDS+NW
+  220    CONTINUE
+  230    IF(NWDS.EQ.0) CALL XABORT('LIBTR2: MAXW IS TOO SMALL.')
+         ALLOCATE(XS(NWDS))
+         JREC=JREC+1
+*        --VECTOR BLOCK-------------------
+         IF(ILIBIN.EQ.2) THEN
+            CALL XDREED (NIN,JREC,XS,NWDS)
+         ELSE IF(ILIBIN.EQ.3) THEN
+            CALL LIBEED (NIN,JREC,XS,NWDS)
+         ENDIF
+*        ---------------------------------
+         L5=0
+      ENDIF
+      WRITE(HVPS,FORM) XHA(L3H-1+IR)
+      CALL LIBCOV(HVPS)
+      IF(IMPX.GT.5) WRITE(IOUT,890) 'VECTOR',HVPS
+      NK=IA(NEX2+IR)-IA(NEX1+IR)+1
+*----
+*  SAVE REQUIRED EXTRA EDIT.
+*----
+      DO 260 I=1,NED
+      TEXT12=HVECT(I)
+      CALL LIBCOV(TEXT12)
+      IF(HVPS.EQ.TEXT12) THEN
+         VECT(:NGRO+1)=0.0
+         IF(.NOT.LSUBM1) CALL LCMGET(KPLIB,HVECT(I),VECT)
+         DO 250 IK=1,NK
+         IF(XS(L5+IK).EQ.0.0) GO TO 250
+         JJ=IA(NEX1+IR)+IK-1
+         TERPZ=1.0
+         IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ)
+         VECT(JJ)=VECT(JJ)+TERPZ*XS(L5+IK)
+  250    CONTINUE
+         LOGIED(I)=.TRUE.
+         IF((TEXT12(:3).EQ.'BST').OR.(TEXT12(:3).EQ.'CST')) THEN
+*           STOPPING POWER
+            CALL LCMPUT(KPLIB,HVECT(I),NGRO+1,2,VECT)
+         ELSE
+            CALL LCMPUT(KPLIB,HVECT(I),NGRO,2,VECT)
+         ENDIF
+         GO TO 270
+      ENDIF
+  260 CONTINUE
+*----
+*  SAVE ENERGY DEPOSITION.
+*----
+      IF(HVPS(2:).EQ.'HEAT') THEN
+         VECT(:NGRO+1)=0.0
+         IF(.NOT.LSUBM1) CALL LCMGET(KPLIB,HVECT(I),VECT)
+         DO 261 IK=1,NK
+         IF(XS(L5+IK).EQ.0.0) GO TO 261
+         JJ=IA(NEX1+IR)+IK-1
+         TERPZ=1.0
+         IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ)
+         VECT(JJ)=VECT(JJ)+TERPZ*XS(L5+IK)
+  261    CONTINUE
+         LDEP(1)=.TRUE.
+         CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,VECT)
+         GO TO 270
+      ELSE IF(HVPS(2:).EQ.'CHAR') THEN
+         VECT(:NGRO+1)=0.0
+         IF(.NOT.LSUBM1) CALL LCMGET(KPLIB,HVECT(I),VECT)
+         DO 262 IK=1,NK
+         IF(XS(L5+IK).EQ.0.0) GO TO 262
+         JJ=IA(NEX1+IR)+IK-1
+         TERPZ=1.0
+         IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJ)
+         VECT(JJ)=VECT(JJ)+TERPZ*XS(L5+IK)
+  262    CONTINUE
+         LDEP(2)=.TRUE.
+         CALL LCMPUT(KPLIB,'C-FACTOR',NGRO,2,VECT)
+         GO TO 270
+      ENDIF
+*----
+*  SAVE MODEL WEIGHT FUNCTIONS
+*----
+  270 IF((HTYPE.EQ.HPRT1//'SCAT').AND.(HVPS.EQ.HPRT1//'WT0').AND.LSUBM1)
+     1 THEN
+         DO 280 IK=1,NK
+         JJ=IA(NEX1+IR)+IK-1
+         FLUX(JJ)=XS(L5+IK)
+  280    CONTINUE
+         GO TO 450
+      ENDIF
+      IF((HTYPE.EQ.'NTHERM').AND.(HVPS.NE.HINC).AND.
+     1   (HVPS.NE.HCOH).AND.(HVPS.NE.HRSK)) GO TO 450
+*----
+*  LOOP OVER GROUPS
+*----
+      DO 440 IK=1,NK
+      IF(XS(L5+IK).EQ.0.0) GO TO 440
+      JJ=IA(NEX1+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.HPRT1//'TOT0') THEN
+*        TOTAL XSEC
+         TOTAL(JJ)=TOTAL(JJ)+ADD
+      ELSE IF((.NOT.LSUBM1).AND.(HVPS.EQ.'NFTOT')) THEN
+*        FISSION CROSS SECTION
+         SIGF(JJ)=SIGF(JJ)+ADD*SAVE(JJ)
+      ELSE IF(LSUBM1.AND.(HVPS.EQ.'NFTOT')) THEN
+         SFIS(JJ)=SFIS(JJ)+ADD
+      ELSE IF(LSUBM1.AND.LTIME.AND.(HVPS.EQ.'NUDEL')) THEN
+*        DELAYED FISSION
+         SIGF(JJ)=SIGF(JJ)+ADD*SFIS(JJ)
+         SAVE(JJ)=SAVE(JJ)+SFIS(JJ)*ADD
+         IF(IK.EQ.1) DNORM=0.0
+         DNORM=DNORM+ADD*SFIS(JJ)*FLUX(JJ)
+      ELSE IF(LSUBM1.AND.LTIME.AND.(HVPS.EQ.'CHID')) THEN
+*        DELAYED FISSION
+         IF(DNORM.EQ.0.0) THEN
+            WRITE (HSMG,980) HMAT
+            CALL XABORT(HSMG)
+         ENDIF
+         ADDD=DNORM*XS(L5+IK)
+         CNORM=CNORM+ADDD
+         CHI(JJ)=CHI(JJ)+ADDD
+      ENDIF
+  440 CONTINUE
+*
+* END OF REACTION LOOP
+  450 L5=L5+NK
+      IF(L5.EQ.NWDS) DEALLOCATE(XS)
+  455 CONTINUE
+*----
+*  RECOVER SCATTERING MATRIX CONTROL INFORMATION.
+*----
+  460 IF(N2D.EQ.0) GO TO 720
+      ALLOCATE(HMTX2(N2D))
+      DO 700 K=1,N2D
+      NWDS=MULT+2+2*NOUTG
+      IF(L3+NWDS-1.GT.MAXA)
+     1 CALL XABORT('LIBTR2: INSUFFICIENT VALUE OF MAXA(5).')
+      JREC=JREC+1
+*     --MATRIX CONTROL--------------------
+      IF(ILIBIN.EQ.2) THEN
+         CALL XDREED (NIN,JREC,A(L3),NWDS)
+      ELSE IF(ILIBIN.EQ.3) THEN
+         CALL LIBEED (NIN,JREC,A(L3),NWDS)
+      ENDIF
+*     ------------------------------------
+      LORD=IA(L3+MULT)
+      IF(LORD.EQ.0) GO TO 700
+      WRITE(HMTX,FORM) XHA(L3H)
+      HMTX2(K)=HMTX
+      CALL LIBCOV(HMTX)
+      IF(IMPX.GT.5) WRITE(IOUT,890) 'MATRIX',HMTX
+      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
+      JCONST=IA(L3+MULT+1)
+*----
+*  RECOVER A NEW SCATTERING MATRIX SUB-BLOCK.
+*----
+      IF(NING.NE.NOUTG) CALL XABORT('LIBTR2: ONLY (N,N) ALLOWED.')
+      DO 467 IL=1,NL
+      DO 466 JJ=1,NOUTG
+      DO 465 JJP=1,NING
+      XSMAT(JJP,JJ,IL)=0.0
+  465 CONTINUE
+  466 CONTINUE
+  467 CONTINUE
+      NOUMAX=0
+  470 NWDS=0
+      NOUMIN=NOUMAX+1
+      DO 475 JJ=NOUMIN,NOUTG
+      NW=IA(LN+JJ)*LORD
+      IF(NWDS+NW.GE.MAXW) GO TO 480
+      NOUMAX=NOUMAX+1
+      NWDS=NWDS+NW
+  475 CONTINUE
+  480 IF(NWDS.GT.0) THEN
+         ALLOCATE(XS(NWDS))
+         JREC=JREC+1
+*        --MATRIX SUB-BLOCK---------------
+         IF(ILIBIN.EQ.2) THEN
+            CALL XDREED (NIN,JREC,XS,NWDS)
+         ELSE IF(ILIBIN.EQ.3) THEN
+            CALL LIBEED (NIN,JREC,XS,NWDS)
+         ENDIF
+*        ---------------------------------
+         L5=0
+      ELSE
+         GO TO 520
+      ENDIF
+      DO 515 JJ=NOUMIN,NOUMAX
+      NP=IA(LN+JJ)
+      IF(NP.EQ.0) GO TO 510
+      DO 500 IL=1,LORD
+      IF(IL.GT.NL) GO TO 500
+      DO 490 IP=1,NP
+      JJP=IA(LG+JJ)-IP+1
+      XSMAT(JJP,JJ,IL)=XS(L5+IP+NP*(IL-1))
+  490 CONTINUE
+  500 CONTINUE
+  510 L5=L5+NP*LORD
+  515 CONTINUE
+      DEALLOCATE(XS)
+  520 IF(NOUMAX.LT.NOUTG) GO TO 470
+      IF(JCONST.NE.0) THEN
+         IF(LORD.GT.1) CALL XABORT('LIBTR2: INVALID DATA ON MATXS2.')
+         NWDS=NOUTG+JCONST
+         ALLOCATE(XS(NWDS))
+         JREC=JREC+1
+*        --CONSTANT SUB-BLOCK-------------
+         IF(ILIBIN.EQ.2) THEN
+            CALL XDREED (NIN,JREC,XS,NWDS)
+         ELSE IF(ILIBIN.EQ.3) THEN
+            CALL LIBEED (NIN,JREC,XS,NWDS)
+         ENDIF
+*        ---------------------------------
+         L5=0
+         DO 535 JJ=1,NOUTG
+         SPEC=XS(L5+JJ)
+         JJP0=NING-JCONST+1
+         DO 530 JJP=JJP0,NING
+         XSMAT(JJP,JJ,1)=XSMAT(JJP,JJ,1)+SPEC*XS(L5+NOUTG+JJP-JJP0+1)
+  530    CONTINUE
+  535    CONTINUE
+         DEALLOCATE(XS)
+      ENDIF
+*----
+*  STORE DESIRED CROSS SECTIONS
+*----
+      IF((HTYPE.EQ.'NTHERM').AND.(HMTX.NE.HINC).AND.
+     1   (HMTX.NE.HCOH).AND.(HMTX.NE.HRSK)) GO TO 670
+*----
+*  LOOP OVER SINK, ORDER, SOURCE
+*----
+      DO 660 JJ=1,NOUTG
+      DO 650 IL=1,LORD
+      IF(IL.GT.NL) GO TO 650
+      DO 640 JJP=1,NING
+      XSNOW=XSMAT(JJP,JJ,IL)
+      IF(XSNOW.EQ.0.) GO TO 640
+*----
+*  INTERPOLATION FACTOR
+*----
+      TERPZ=1.0
+      IF(.NOT.LSUBM1) TERPZ=TERP(NGRO*(ISUBM-1)+JJP)
+      IF(ABS(TERPZ).LT.1.0E-3) GO TO 640
+      XSEC=TERPZ*XSNOW
+*----
+*  CHECK FOR SCATTERING AND FISSION MATRICES
+*----
+      IF(IFISN.EQ.0) THEN
+*        THERMAL CORRECTION TO SCATTERING MATRIX
+         IF((HMTX.EQ.'NELAS').AND.(JJP.GE.NGRO-NTFG(IMT)+1)) THEN
+            IF(IL.EQ.1) TOTAL(JJP)=TOTAL(JJP)-XSEC
+            GO TO 640
+         ENDIF
+         IF(((HMTX.EQ.HINC).OR.(HMTX.EQ.HCOH).OR.(HMTX.EQ.HRSK)).AND.
+     1   (JJP.LT.NGRO-NTFG(IMT)+1)) GO TO 640
+*        TOTAL SCATTERING MATRIX
+*        SCAT(SECONDARY,PRIMARY,ORDER+1)
+         SCAT(JJ,JJP,IL,JOUTP)=SCAT(JJ,JJP,IL,JOUTP)+XSEC
+*        TOTAL XS AND TOTAL SCATTERING VECTOR
+         SIGS(JJP,IL,JOUTP)=SIGS(JJP,IL,JOUTP)+XSEC
+         IF((IL.EQ.1).AND.(JJP.GE.NGRO-NTFG(IMT)+1)) THEN
+            TOTAL(JJP)=TOTAL(JJP)+XSEC
+         ENDIF
+      ELSE IF((IL.EQ.1).AND.(IFISN.NE.0).AND.(HTYPE.EQ.'NSCAT')) THEN
+*        FISSION VECTORS
+         SIGF(JJP)=SIGF(JJP)+XSEC
+         CNORM=CNORM+XSEC*FLUX(JJP)
+         CHI(JJ)=CHI(JJ)+XSEC*FLUX(JJP)
+      ENDIF
+  640 CONTINUE
+  650 CONTINUE
+  660 CONTINUE
+*----
+*  ACCUMULATE FISSION NUBAR
+*----
+  670 IF(LSUBM1.AND.(IFISN.NE.0).AND.(HTYPE.EQ.'NSCAT')) THEN
+         DO 685 JJ=1,NOUTG
+         DO 680 JJP=1,NING
+         SAVE(JJP)=SAVE(JJP)+XSMAT(JJP,JJ,1)
+  680    CONTINUE
+  685    CONTINUE
+      ENDIF
+*
+      IF((K.EQ.N2D).AND.LSUBM1.AND.(IMPX.GT.4)) THEN
+         WRITE (IOUT,900) HTYPE,HMAT,(HMTX2(I),I=1,N2D)
+      ENDIF
+  700 CONTINUE
+      DEALLOCATE(HMTX2)
+*----
+*  SAVE FISSION NU FOR SHIELDING TERMS
+*----
+      IF(LSUBM1.AND.(HTYPE.EQ.'NSCAT')) THEN
+         DO 710 JJ=1,NGRO
+         IF(SFIS(JJ).EQ.0) GO TO 710
+         SAVE(JJ)=SAVE(JJ)/SFIS(JJ)
+  710    CONTINUE
+      ENDIF
+*
+* END OF SUBMATERIAL LOOP.
+  720 CONTINUE
+      DEALLOCATE(TERP)
+*----
+*  PRINT FINAL FLUX COMPONENTS
+*----
+      IF((IMPX.GT.6).AND.MASKI(IMT)) THEN
+         SUM=0.0
+         DO 730 JJ=1,NGRO
+         SUM=SUM+FLUX(JJ)
+  730    CONTINUE
+         WRITE(IOUT,950) HNAMIS,SUM
+         WRITE(IOUT,960) (FLUX(I),I=1,NGRO)
+      ENDIF
+*----
+*  PERFORM LIVOLANT-JEANPIERRE NORMALIZATION AND SAVE CROSS SECTION
+*  INFORMATION ON LCM.
+*----
+      IF(HNPART(1).EQ.'N') THEN
+         DO 740 I=1,NGRO
+         IF((SN(I,IMT).NE.SB(I,IMT)).AND.(SN(I,IMT).LT.1.0E10)) THEN
+            VECT(I)=1.0/(1.0+(TOTAL(I)-SIGS(I,1,1))*(1.0/SN(I,IMT)
+     1      -1.0/SB(I,IMT)))
+         ELSE
+            VECT(I)=1.0
+         ENDIF
+         IF(SN(I,IMT).LT.1.0E10) THEN
+            FLUX(I)=SN(I,IMT)/(SN(I,IMT)+TOTAL(I)-SIGS(I,1,1))/VECT(I)
+         ELSE
+            FLUX(I)=1.0
+         ENDIF
+         TOTAL(I)=TOTAL(I)*VECT(I)
+  740    CONTINUE
+         IF(IMPX.GT.5) THEN
+            WRITE(IOUT,940) HNAMIS
+            WRITE(IOUT,960) (VECT(I),I=1,NGRO)
+         ENDIF
+         DO 752 IL=0,NL-1
+         DO 751 IG2=1,NGRO
+         FACTOR=VECT(IG2)
+         SIGS(IG2,IL+1,1)=SIGS(IG2,IL+1,1)*FACTOR
+         DO 750 IG1=1,NGRO
+         SCAT(IG1,IG2,IL+1,1)=SCAT(IG1,IG2,IL+1,1)*FACTOR
+  750    CONTINUE
+  751    CONTINUE
+  752    CONTINUE
+*
+         DO 810 IED=1,NED
+         TEXT12=HVECT(IED)
+         CALL LIBCOV(TEXT12)
+         IF(LOGIED(IED).AND.(TEXT12(:3).NE.'CHI')
+     1                 .AND.(TEXT12(:2).NE.'NU')
+     2                 .AND.(TEXT12.NE.'NTOT0')
+     3                 .AND.(TEXT12(2:).NE.'HEAT')
+     4                 .AND.(TEXT12(2:).NE.'CHAR')
+     5                 .AND.(TEXT12(:3).NE.'NWT')) THEN
+            CALL LCMGET(KPLIB,HVECT(IED),GAR)
+            DO 800 I=1,NGRO
+            GAR(I)=GAR(I)*VECT(I)
+  800       CONTINUE
+            CALL LCMPUT(KPLIB,HVECT(IED),NGRO,2,GAR)
+         ENDIF
+  810    CONTINUE
+         IF(LDEP(1)) THEN
+            CALL LCMGET(KPLIB,'H-FACTOR',GAR)
+            DO 811 I=1,NGRO
+            GAR(I)=GAR(I)*VECT(I)
+  811       CONTINUE
+            CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,GAR)
+         ENDIF
+         IF(LDEP(2)) THEN
+            CALL LCMGET(KPLIB,'C-FACTOR',GAR)
+            DO 812 I=1,NGRO
+            GAR(I)=GAR(I)*VECT(I)
+  812       CONTINUE
+            CALL LCMPUT(KPLIB,'C-FACTOR',NGRO,2,GAR)
+         ENDIF
+      ENDIF
+*----
+*  SAVE CROSS SECTION INFORMATION ON LCM.
+*----
+      DO 815 IP=1,NPART
+      IF(IP.EQ.1) THEN
+         CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,TOTAL)
+         CALL LCMPUT(KPLIB,'NWT0',NGRO,2,FLUX)
+         CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS(1,1,IP),
+     1   SCAT(1,1,1,IP),ITYPRO)
+      ELSE
+         CALL LCMSIX(KPLIB,HNPART(IP),1)
+         CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS(1,1,IP),
+     1   SCAT(1,1,1,IP),ITYPRO)
+         CALL LCMSIX(KPLIB,' ',2)
+      ENDIF
+  815 CONTINUE
+*
+      IF(CNORM.NE.0.0) THEN
+*        FISSION SOURCE NORMALIZATION
+         DO 820 JJ=1,NGRO
+         CHI(JJ)=CHI(JJ)/CNORM
+         SIGF(JJ)=SIGF(JJ)*VECT(JJ)
+  820    CONTINUE
+         CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SIGF)
+         CALL LCMPUT(KPLIB,'CHI',NGRO,2,CHI)
+      ENDIF
+      CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS)
+      CALL LCMPUT(KPLIB,'AWR',1,2,AWR)
+      WRITE(README(:8),'(A8)') HNAMIS(1:8)
+      READ(README,'(22A4)') (IHGAR(I),I=1,22)
+      CALL LCMPUT(KPLIB,'README',22,3,IHGAR)
+      GO TO 130
+*----
+*  END OF MATERIAL/ISOTOPE LOOP.
+*----
+  840 CONTINUE
+*----
+*  CLOSE MATXS FILE.
+*----
+*     --CLOSE CCCC FILE--
+      IF(ILIBIN.EQ.2) THEN
+         CALL XDRCLS(NIN)
+      ELSE IF(ILIBIN.EQ.3) THEN
+         CALL LIBCLS()
+      ENDIF
+*     -------------------
+      IER=KDRCLS(NIN,1)
+      IF(IER.LT.0) THEN
+        WRITE (HSMG,'(37HLIBTR2: UNABLE TO CLOSE LIBRARY FILE ,A,1H.
+     1  )') NAMFIL
+        CALL XABORT(HSMG)
+      ENDIF
+*----
+*  CHECK IF ALL NBISO ISOTOPES HAVE BEEN PROCESSED.
+*----
+      NISOT=0
+      DO 860 IMT=1,NBISO
+      IF(MASKI(IMT)) THEN
+         IF(IPR(IMT).EQ.0) THEN
+            WRITE (IOUT,930) (ISONAM(ITC,IMT),ITC=1,3),NAMFIL
+            NISOT=NISOT+1
+         ENDIF
+      ENDIF
+  860 CONTINUE
+      IF(NISOT.GT.0) CALL XABORT('LIBTR2: MISSING ISOTOPES')
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(SCAT,SIGS,HNPART,C2PART,NGPART)
+      DEALLOCATE(LOGIED)
+      DEALLOCATE(XSMAT,GAR,VECT,FLUX,TOTAL,SIGF,CHI,SAVE,SFIS)
+      DEALLOCATE(ITYPRO,IPR)
+      RETURN
+*
+  870 FORMAT(/31H LIBTR2: PROCESSING SUBMATERIAL,I5,5X,12HINCIDENT PAR,
+     1 6HTICLE=,A1,3H-->,A1,5X,10HDATA TYPE=,A6,5X,9HMATERIAL=,A6)
+  880 FORMAT(/52H AVAILABLE IDENTIFIERS OF REACTION VECTORS FOR TYPE ,
+     1 A6,14H AND MATERIAL ,A6,1H:/(1X,18A7))
+  890 FORMAT(/9H PROCESS ,A6,10H REACTION ,A6)
+  900 FORMAT(/53H AVAILABLE IDENTIFIERS OF REACTION MATRICES FOR TYPE ,
+     1 A6,14H AND MATERIAL ,A6,1H:/(1X,18A7))
+  920 FORMAT(/33H PROCESSING MATXS2 LIBRARY NAMED ,A,1H.)
+  930 FORMAT(/27H LIBTR2: MATERIAL/ISOTOPE ',3A4,16H' IS MISSING ON ,
+     1 16HMATXS FILE NAME ,A,1H.)
+  940 FORMAT(/40H L-J NORMALIZATION FACTORS FOR MATERIAL ,A12)
+  950 FORMAT(/19H FLUX FOR MATERIAL ,A12,7H   SUM=,1P,E12.5)
+  960 FORMAT(1X,1P,10E12.4)
+  970 FORMAT(/17H MATXS2 FILE ID: ,3A8,6H VERS ,I2)
+  980 FORMAT(35HLIBTR2: DNORM MISSING FOR MATERIAL ,A6,1H.)
+      END