*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