diff options
Diffstat (limited to 'Dragon/src/LIBTR2.f')
| -rw-r--r-- | Dragon/src/LIBTR2.f | 894 |
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 |