*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