*cpl all *lst *set sw *ident up1 */ leapr -- 04apr00 */ this fixes errors that destroy the calculation of s(alpha,beta) */ for cold para-hydrogen and for both cold deuteriums. the first */ was introduced in 97.53 while making the constants symbolic, */ and the second was introduced in the cleanup process for njoy99. *d leapr.1902 if (law.gt.3) de=ded *d leapr.2121 sum2=(sjbes(jp,y)*cn(j,jp,jp))**2 *ident up2 */ groupr -- 04apr00 */ there is an error in the indexing for the xmas 172-group structure */ that throws all the group bounds off by one. this structure is */ used in europe for thermal reactor calculations. *d groupr.1835 eg(ig)=eg18(174-ig) */ fix a problem introduced with the activation patch of 97.102. the */ nk parameter is only used when doing mf values for activation */ products, and it is not appropriate for fission nubar values. *d groupr.3824 nk=0 if (mf.gt.99) nk=nint(a(iyld+4)) *i groupr.3853 if (nk.eq.0) go to 180 */ don't strip off the upscatter groups for the neutron spectra */ coming from delayed neutron emission (mt=455). *d groupr.8913 if (mfd.ne.15.and.mtd.ne.455) then */ add a missing save statement and fix an unset variable in anased. */ these problems affect delayed neutron spectra. *d groupr.8983 save new,theta,xc,rc,bot,ca,loct *i groupr.9050 np=nint(a(loct+6)) *ident up3 */ acer -- 04apr00 */ the acer consistency checks include an option to readjust */ eprime values that are greater than e, when appropriate. */ there are some problems with the logic, especially for */ cases that use histogram interpolation for the distribution. *i acer.18017 ishift=j-nn-1 *d acer.18019 xss(j+loci)=sigfig(epmax,7,ishift) *i acer.18022 xss(j-1+nn+loci)=p xss(j+nn+loci)=p *i acer.18026 xss(j+nn+loci)=p *d acer.18028 *i acer.18131 xss(j-1+nn+loci)=p xss(j+nn+loci)=p *i acer.18135 xss(j+nn+loci)=p *d acer.18137 */ when using the old format (mcnp4b and earlier), some angle-energy */ distributions from file 6 are converted into the law 67 format, */ because these earlier versions of mcnp couldn't use all the */ file 6 representations. when converting from the cm to the lab, */ the methods used in subroutine fix6 are a little crude. they get */ confused when cm energies are so small that lab cosines of -1 */ are not reached. this patch tries to fix that in a rough way, */ but evaluations that use the cm frame in file 6 will work best */ if most of the cm energies are greater than e/(awr+1)**2 for */ each incident energy e. for mcnp4c and later, the code can */ sample directly from tabulated cm representations, and the */ approximations of the fix6 routine are avoided. this patch */ is needed for one evaluation from JEFF-3. *d acer.3238 *i acer.3250 data namax/1000/ *d acer.3353 if (lct.ne.1) then *d acer.3372 if (ep.gt.zero) then csn=clb*sqrt(elb/ep)-sqrt(ein/ep)/aw1 endif *i acer.3398,3420 if (j.le.l2+8.or.elb.gt.a(j-2)) then a(j)=elb a(j+1)=fmu*drv j=j+2 endif if (j.ge.namax-1) call error('fix6', & 'storage in a exceeded',' ') *i acer.3421 nnep=(j-(l2+8))/2 if (nnep.eq.1) then a(l2+10)=2*a(l2+8) a(l2+11)=0 nnep=2 endif a(l2+5)=nnep a(l2+6)=nnep j2=l2 call tab1io(0,nout,ndebug,a(j2),nb,nw) do while (nb.ne.0) j2=j2+nw call moreio(0,nout,ndebug,a(j2),nb,nw) enddo */ increase the available storage to handle the very large */ mf6/mt16 tabulation in JEFF-3 Be-9. *d acer.226 common/astore/a(80000) *d acer.235 data namax/80000/, nidmax/27/ *d acer.460 common/astore/a(80000) *d acer.2130 data nwmaxn/65000/ *d acer.4672 common/astore/a(80000) *d acer.5604 common/astore/a(80000) *d acer.5765 common/astore/a(80000) *d acer.5954 common/astore/a(80000) *d acer.6326 common/astore/a(80000) *d acer.7385 common/astore/a(80000) *d acer.8058 common/astore/a(80000) *d acer.8068 data namax/40000/ *d acer.9762 common/astore/a(80000) *d acer.10677 common/astore/a(80000) *d acer.13068 common/astore/a(80000) *d acer.13464 common/astore/a(80000) *d acer.14300 common/astore/a(80000) *d acer.14665 common/astore/a(80000) *d acer.15215 common/astore/a(80000) *d acer.21814 common/astore/a(80000) */ increase the space available for discontinuities in convr */ to allow for JENDL-3.2 si-nat *d acer.254 nned=50 *ident up4 */ reconr -- 05apr00 */ be sure to count subsections of file 12 before allocating */ storage for the elements of the new directory. otherwise, */ some materials with many sections of file 12 will overflow. */ this is a longstanding problem that we never noticed before. *i reconr.419 nxn=nxn+1 *ident up5 */ purr -- 7may00 */ fix a problem introduced while installing the heating part */ of the probability tables. it shows up when doing elements */ that have unresolved data. also, increase the number of */ resonance sections allowed to handle the very large cd-nat */ evaluation from JENDL. *d purr.1076 e=abs(eunr(ie)) *d purr.1106,1108 common/sigcon/e,t,cth(50),csz(50),cc2p(50),cs2p(50), & cgn(50),cgg(50),cgf(50),cgx(50),cgt(50),dbar(50), & spot,dbarin,sigi(4),ndfn(50),ndff(50),ndfx(50),nseq0 *d purr.1139 *d purr.1187,1189 *d purr.1247 if (nseq0.gt.50) call error('unresx', *d purr.1501,1503 common/sigcon/e,t,cth(50),csz(50),cc2p(50),cs2p(50), & cgn(50),cgg(50),cgf(50),cgx(50),cgt(50),dbar(50), & spot,dbarin,sigi(4),ndfn(50),ndff(50),ndfx(50),nseqz *d purr.1621,1623 common/sigcon/e,t,cth(50),csz(50),cc2p(50),cs2p(50), & cgn(50),cgg(50),cgf(50),cgx(50),cgt(50),dbar(50), & spot,dbarin,sigi(4),ndfn(50),ndff(50),ndfx(50),nseqz *d purr.1739,1741 common/sigcon/e,t,cth(50),csz(50),cc2p(50),cs2p(50), & cgn(50),cgg(50),cgf(50),cgx(50),cgt(50),dbar(50), & spot,dbarin,sigi(4),ndfn(50),ndff(50),ndfx(50),nseq0 *ident up6 */ acer -- 30may00 */ fix a typo in up3 (reported by bunde, anl) *d up3.93 data namax/80000/ */ acer -- 30may00 */ fix problems with converting cm distributions to law=7 */ and problems reading law=7 into the ace file. these problems */ show up when running newfor=0 with njoy2000, especially on */ some materials from jef-2.2. *d acer.3342 *d acer.3347,3348 *d acer.3364 c if(imu.lt.nmu.and.amu(imu+1).le.cmn) drv=0 *i acer.3377 c include jacobian for cm-to-lab transformation if (ep.ne.zero) drv=drv*sqrt(elb/ep) *d up3.46,up3.50 if (j.le.l2+8) then a(j)=elb a(j+1)=fmu*drv j=j+2 else if (elb.gt.a(j-2)) then a(j)=elb a(j+1)=fmu*drv j=j+2 endif *d acer.3399,3420 if (iep.eq.nep) idone=1 *d acer.6330 external listio,terpa,terp1,bachaa,mess,fndar1,fndar2,skip6a *d acer.6380 call skip6a(nin,0,0,a(jscr),law) *d acer.6412 call skip6a(nin,0,0,a(jscr),law) *d acer.6497 call skip6a(nin,0,0,a(jscr),law) *i acer.6935 c subroutine skip6a(nin,nout,nscr,a,law) c ****************************************************************** c special version of skip6 for special version of File 6 used c in acer. law=7 has a tab1 containing the angular distribution c instead of the normal tab2 for each incident energy. c skip the next subsection in the current section (mt). c ****************************************************************** *if sw implicit real*8 (a-h,o-z) *endif common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension a(*) c if (law.eq.6) then call contio(nin,nout,nscr,a(1),nb,nw) else if (law.eq.1.or.law.eq.2.or.law.eq.5) then call tab2io(nin,nout,nscr,a(1),nb,nw) ne=n2h do ie=1,ne call listio(nin,nout,nscr,a(1),nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a(1),nb,nw) enddo enddo else if (law.eq.7) then call tab2io(nin,nout,nscr,a(1),nb,nw) ne=n2h do ie=1,ne call tab1io(nin,nout,nscr,a(1),nb,nw) nmu=n2h do imu=1,nmu call tab1io(nin,nout,nscr,a(1),nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a(1),nb,nw) enddo enddo enddo endif return end *ident up7 */ viewr -- 30may00 */ increase the allowed size of 3d plots. */ pushed by pb-nat from jef-2.2. *d viewr.680 if (l+5000.ge.maxaa) then *d viewr.1295 dimension x(2000),y(2000),z(2000) *d viewr.1304 kmax=1999 *ident up8 */ acer -- 3jun00 */ subroutine ptleg2 does not need the dynamic array xat. */ this problem was first noted by Waclaw Gudowski for ENDF/B-VI */ si-nat. it shows up as "id xat not defined". *d acer.5628 *d acer.5632 call ptleg2(a(iscr)) *d acer.5646 call ptleg2(a(iscr)) *d acer.6838,6839 call ptleg2(a(jscr)) *d acer.6937 subroutine ptleg2(a) *d acer.6950 *d acer.8470,8471 call ptleg2(a(lld)) *d acer.8720 *d acer.8731 call ptleg2(a(lld)) *d acer.16034 *d acer.16037 call ptleg2(a(lld)) *ident up9 */ acer -- 07jun00 */ add the capability for processing anisotropic charged particle */ emission using tabulated legendre coefficients into the */ mcnp4c law61 format. this is needed for jeff-3 cr-52. */ allow for multiple interpolation ranges in file 6. this */ also occurs for jeff-3 cr-52. currently, the neutron */ energy-angle distribution only allows for combinations of */ histogram and linear linear interpolation, but the */ charged-particle sections allow for general combinations of */ all allowed interpolation laws. *d acer.6391 jnt=nint(a(jscr+5+2*m)) *i acer.6456 if (idis.eq.1.and.xx.lt..9999*xn) xn=sigfig(xn,7,-1) *d acer.8278,8285 next=next+2 nrint=nint(a(iscr+4)) if (nrint.eq.1.and.nint(a(iscr+7)).eq.2) then xss(next)=0 else xss(next)=nrint do i=1,nrint xss(next+i)=nint(a(iscr+4+2*i)) xss(next+nrint+i)=nint(a(iscr+5+2*i)) enddo next=next+2*nrint endif next=next+1 ne=nint(a(iscr+5)) xss(next)=ne do i=1,ne xss(next+i)= & sigfig(a(iscr+4+2*nrint+2*i)/emev,7,0) xss(next+i+ne)= & sigfig(a(iscr+5+2*nrint+2*i),7,0) enddo next=next+1+2*ne *d acer.9031,9032 *i acer.9033 lang=nint(a(ll+2)) lawnow=0 if (law.eq.1.and.lang.eq.1) lawnow=61 if (law.eq.1.and.lang.eq.2) lawnow=44 if (law.eq.2) lawnow=33 if (lawnow.eq.0) call error('acelcp', & 'unsupported law and lang',' ') xss(last+1)=lawnow *i acer.9090 nexcd=next+4*ng+2 *d acer.9121 c kalbach distribution if (lang.eq.2) then *i acer.9126 c legendre distribution else if (lang.eq.1) then ep=xss(next+1+ig) a(ll)=0 a(ll+1)=ep a(ll+2)=0 a(ll+3)=0 a(ll+4)=na a(ll+5)=0 do ia=1,na lll=lld+7+ncyc*(ig-1) a(ll+5+ia)=0 if (a(lll).ne.zero) then a(ll+5+ia)=a(lll+ia)/a(lll) endif enddo call ptleg2(a(ll)) xss(next+1+3*ng+ig)=nexcd-dlwh+1 intmu=2 xss(nexcd)=intmu nmu=nint(a(ll+5)) xss(nexcd+1)=nmu do imu=1,nmu xss(nexcd+1+imu)=sigfig( & a(ll+6+2*imu),7,0) xss(nexcd+1+nmu+imu)=sigfig( & a(ll+7+2*imu),7,0) if (imu.eq.1) then xss(nexcd+1+2*nmu+imu)=0 else if (imu.eq.nmu) then xss(nexcd+1+2*nmu+imu)=1 else del=a(ll+6+2*imu) & -a(ll+4+2*imu) av=(a(ll+7+2*imu) & +a(ll+5+2*imu))/2 xss(nexcd+1+2*nmu+imu) & =xss(nexcd+1+2*nmu+imu-1) & +del*av xss(nexcd+1+2*nmu+imu)=sigfig & (xss(nexcd+1+2*nmu+imu),7,0) endif enddo nexcd=nexcd+2+3*nmu *d acer.9160 if (lang.eq.1) then next=nexcd else next=next+2+(2*na+3)*ng endif *d acer.11158,11163 l2=sigh+l1+1 nrint=nint(xss(l2)) write(nsyso,'(4x,''nr ='',i4)') nrint if (nrint.ne.0) then write(nsyso,'(4x,''nbt(i=1,nr) = '',20i5)') & (nint(xss(l2+ii)),ii=1,nrint) l2=l2+nrint write(nsyso,'(4x,''int(i=1,nr) = '',20i5)') & (nint(xss(l2+ii)),ii=1,nrint) l2=l2+nrint endif l2=l2+1 ne=nint(xss(l2)) write(nsyso,'(4x,''ne ='',i4)') ne *d acer.11169 & xss(l2+ii),xss(l2+ne+ii) *d acer.11255,11257 write(nsyso,'(4x,''nr ='',i4)') nrint if (nrint.ne.0) then write(nsyso,'(4x,''nbt(i=1,nr) = '',20i5)') & (nint(xss(l3+ii)),ii=1,nrint) l3=l3+nrint write(nsyso,'(4x,''int(i=1,nr) = '',20i5)') & (nint(xss(l3+ii)),ii=1,nrint) l3=l3+nrint endif l3=l3+1 ne=nint(xss(l3)) write(nsyso,'(4x,''ne ='',i4)') ne *d acer.11259,11260 e2=xss(l3+ie) loci=nint(xss(l3+ne+ie))+dlwh-1 *d acer.11286,11288 write(nsyso,'(4x,''nr ='',i4)') nrint if (nrint.ne.0) then write(nsyso,'(4x,''nbt(i=1,nr) = '',20i5)') & (nint(xss(l3+ii)),ii=1,nrint) l3=l3+nrint write(nsyso,'(4x,''int(i=1,nr) = '',20i5)') & (nint(xss(l3+ii)),ii=1,nrint) l3=l3+nrint endif l3=l3+1 ne=nint(xss(l3)) write(nsyso,'(4x,''ne ='',i4)') ne *d acer.11290,11291 e2=xss(l3+ie) loci=nint(xss(l3+ne+ie))+dlwh-1 *i acer.11311 c c ***law=61 else if (law.eq.61) then nrint=nint(xss(l3)) write(nsyso,'(4x,''nr ='',i4)') nrint if (nrint.ne.0) then write(nsyso,'(4x,''nbt(i=1,nr) = '',20i5)') & (nint(xss(l3+ii)),ii=1,nrint) l3=l3+nrint write(nsyso,'(4x,''int(i=1,nr) = '',20i5)') & (nint(xss(l3+ii)),ii=1,nrint) l3=l3+nrint endif l3=l3+1 ne=nint(xss(l3)) write(nsyso,'(4x,''ne ='',i4)') ne do ie=1,ne e2=xss(ie+l3) loci=nint(xss(ie+ne+l3)+dlwh-1) intt=mod(nint(xss(loci)),10) nd=nint(xss(loci)/10) nn=nint(xss(loci+1)) loci=loci+1 write(nsyso,'(/6x,'' incident energy = '', & 1p,e14.6,'' intt ='',i2,'' nd ='',i4, & '' np ='',i3)') e2,intt,nd,nn do ip=1,nn locj=nint(xss(ip+3*nn+loci)+dlwh-1) intmu=nint(xss(locj)) nmu=nint(xss(locj+1)) write(nsyso,'(/ & 6x,'' secondary energy = '',1p,e14.6/ & 6x,'' pdf = '',e14.6/ & 6x,'' cdf = '',e14.6/ & 6x,'' intmu = '',i8/ & 6x,'' nmu = '',i8/ & '' cosine pdf cdf'', & '' cosine pdf cdf''/ & '' ------------ ------------ ------------'', & '' ------------ ------------ ------------'')') & xss(ip+loci),xss(ip+nn+loci), & xss(ip+2*nn+loci),intmu,nmu do imu=1,nmu,2 if (imu.eq.nmu) then write(nsyso,'(1x,1p,3e14.6)') & xss(locj+1+imu),xss(locj+1+nmu+imu), & xss(locj+1+2*nmu+imu) else write(nsyso,'(1x,1p,6e14.6)') & xss(locj+1+imu),xss(locj+1+nmu+imu), & xss(locj+1+2*nmu+imu),xss(locj+1+imu+1), & xss(locj+1+nmu+imu+1), & xss(locj+1+2*nmu+imu+1) endif enddo enddo enddo *d acer.11333,11335 write(nsyso,'(4x,''nr ='',i4)') nrint if (nrint.ne.0) then write(nsyso,'(4x,''nbt(i=1,nr) = '',20i5)') & (nint(xss(l3+ii)),ii=1,nrint) l3=l3+nrint write(nsyso,'(4x,''int(i=1,nr) = '',20i5)') & (nint(xss(l3+ii)),ii=1,nrint) l3=l3+nrint endif l3=l3+1 ne=nint(xss(l3)) write(nsyso,'(4x,''ne ='',i4)') ne *d acer.11337,11339 e2=xss(l3+ie) loci=nint(xss(l3+ne+ie))+dlwh-1 intmu=nint(xss(loci)) *i acer.12617 if (nout.ne.1) nr=nint(xss(l)) if (nout.eq.1) nr=iss(l) *i acer.12619 if (nr.gt.0) then n=2*nr do jj=1,n call typen(l,nout,1) l=l+1 enddo endif *i acer.12791 else if (law.eq.61) then if (nout.ne.1) nr=nint(xss(l)) if (nout.eq.1) nr=iss(l) call typen(l,nout,1) l=l+1 if (nr.ne.0) then n=2*nr do j=1,n call typen(l,nout,1) l=l+1 enddo endif if (nout.ne.1) ne=nint(xss(l)) if (nout.eq.1) ne=iss(l) call typen(l,nout,1) l=l+1 do j=1,ne call typen(l,nout,2) l=l+1 enddo do j=1,ne call typen(l,nout,1) l=l+1 enddo do j=1,ne call typen(l,nout,1) l=l+1 if (nout.ne.1) np=nint(xss(l)) if (nout.eq.1) np=iss(l) call typen(l,nout,1) l=l+1 n=3*np do k=1,n call typen(l,nout,2) l=l+1 enddo do k=1,np call typen(l,nout,1) l=l+1 enddo do k=1,np call typen(l,nout,1) l=l+1 if (nout.ne.1) nmu=nint(xss(l)) if (nout.eq.1) nmu=iss(l) call typen(l,nout,1) l=l+1 nw=3*nmu do kk=1,nw call typen(l,nout,2) l=l+1 enddo enddo enddo *d acer.18174 locj=nint(xss(j+3*nn+loci)+dlw-1) *d acer.18179 cc=xss(locj+1+2*nmu+k) *d acer.18353 j=nint(xss(l3)) if (j.ne.0) then l3=l3+2*j endif l3=l3+1 ne=nint(xss(l3)) *d acer.18355,18356 e=xss(l3+ie) loci=nint(xss(l3+ne+ie))+dlwh-1 *d acer.18384 j=nint(xss(l3)) if (j.ne.0) then l3=l3+2*j endif l3=l3+1 ne=nint(xss(l3)) *d acer.18386,18387 e=xss(l3+ie) loci=nint(xss(l3+ne+ie))+dlwh-1 *d acer.18424 j=nint(xss(l3)) if (j.ne.0) then l3=l3+2*j endif l3=l3+1 ne=nint(xss(l3)) *d acer.18426,18427 e=xss(l3+ie) loci=nint(xss(l3+ne+ie))+dlwh-1 *d acer.18449 locj=nint(xss(j+3*nn+loci)+dlwh-1) *d acer.18454 cc=xss(locj+1+2*nmu+k) *d acer.18459 & '' at'',1p,e14.6,'' ->'',e13.6,e14.6)') *ident up10 */ leapr -- 13jun00 */ fix two incorrect constants in leapr. one affects cases with */ diffusive effects, and it has been incorrect since njoy97.0 */ (oct 97). the other affects cold hydrogen calculations, and it */ has been incorrect since njoy97.53 (dec98). *d leapr.1186 data c0/.125d0/ *d leapr.1864 data amassh/3.3465d-24/ *ident up11 */ acer -- 26jun00 */ fix an error in determinining which reactions have to be */ converted into law=7 format when using newfor=0. because of */ overzealous code cleanup, acer is trying to convert sections */ with the kalbach representation in addition to sections with */ tabulated angular distributions. *d acer.2324,2330 do while(nb.ne.0) call moreio(nin,0,0,a(iscr),nb,nw) enddo if (lf.eq.6) then call contio(nin,0,0,a(iscr),nb,nw) else if (lf.eq.1.or.lf.eq.2.or.lf.eq.5) then call tab2io(nin,0,0,a(iscr),nb,nw) lang=l1h if (dzap.le.test.and.lf.eq.1.and.lang.ne.2) new6=1 ne=n2h do ie=1,ne call listio(nin,0,0,a(iscr),nb,nw) do while (nb.ne.0) call moreio(nin,0,0,a(iscr),nb,nw) enddo enddo else if (lf.eq.7) then call tab2io(nin,0,0,a(iscr),nb,nw) ne=n2h do ie=1,ne call tab1io(nin,0,0,a(iscr),nb,nw) nmu=n2h do imu=1,nmu call tab1io(nin,0,0,a(iscr),nb,nw) do while (nb.ne.0) call moreio(nin,0,0,a(iscr),nb,nw) enddo enddo enddo endif */ acer -- 26jun00 */ during the cleanup of the topfil routine, the logic to process */ sections of file 6 using law=2 (two-body distributions) into */ equally probable bins for newfor=0 was omitted. this shows up */ for evaluations that use mf6/mt51, etc., to represent inelastic */ levels. *d acer.2379 if (lf.eq.1) then *d acer.2387,2388 c law=2 for newfor=1 - copy the subsection else if (lf.eq.2.and.newfor.eq.1) then *i acer.2394 c law=2 for newfor=0 - convert to probability bins else if (lf.eq.2.and.newfor.eq.0) then call listio(nin,0,0,a(iscr),nb,nw) now=iscr+nw do while (nb.ne.0) call moreio(nin,0,0,a(now),nb,nw) now=now+nw enddo now=now-1 lang=nint(a(iscr+2)) if (lang.eq.0) then c legendre coefficients call ptleg(nout,a) else c tabulated angular distribution do i=iscr,now a(now+2-i+iscr)=a(now-1+iscr) enddo np=nint(a(iscr+7)) a(iscr)=a(iscr+2) a(iscr+1)=a(iscr+3) a(iscr+2)=0 a(iscr+3)=0 a(iscr+4)=1 a(iscr+5)=np a(iscr+6)=np a(iscr+7)=lang-10 call pttab(ltt,a(iscr),nout) endif c law=5 for - copy the subsection else if (lf.eq.5) then call listio(nin,nout,0,a(iscr),nb,nw) now=iscr+nw do while (nb.ne.0) call moreio(nin,nout,0,a(now),nb,nw) now=now+nw enddo */ acer -- 26jun00 */ fix an error in the reaction naming. it affects mt=44 (n,n2p) and */ mt=45 (n,npa). this problem was introduced in may of 1995. */ examples of cases that use these reactions are later releases of */ endf/b-vi al-27. *d acer.11415,11416 & '(n,x) ', '(n,2np) ', '(n,3np) ', '(n,x) ', & '(n,n2p) ', '(n,npa) ', '(n,2/2*1) ', '(n,2/2*2) ', */ acer -- 26jun00 */ add missing external statement. reported by bokyun seo (kaeri) *i acer.3250 external error */ acer -- 26jun00 */ add missing line for the sequential (n,2n) reactions for be-9. */ this line was accidentally removed in njoy 94.19 (jan96). the */ error was continued through njoy 97 and 99. discovered by */ bob little (lanl). *i acer.5102 if (mth.ge.46.and.mth.le.49) s=sigfig(s/2,7,0) */ acer -- 26jun00 */ fix anisotropic photon production (e.g., endf c,n,o) *d acer.7559 if (lff.le.1) then *ident up12 */ njoy -- 27jul00 */ fix two typographical errors in the 64-bit version of the */ slatec math library. reported by piet de leege (delft). *d njoy.4617 if (a.ge.(-0.5).or.aeps.ne.0.0) then *d njoy.4935 gamma=0.9375+csevl(2.*y-1.,gamcs,ngamcs) *ident up13 */ reconr -- 12jul00 */ if a reaction uses histogram interpolation, reconr tries to */ change it to linear interpolation by moving each point down by */ one in the seventh place and and adding a point higher by one in */ the seventh place. if there is already a point in the evaluator's */ grid higher by one in the seventh place, the algorithm gets */ confused. this currently occurs for carbon from release 6 of */ endf/b-vi. the symptom is an infinite loop while processing */ mf=12,mt=51. we found this at los alamos, and skipped over the */ problem by temporarily patching the evaluation. more recently, */ it was re-reported by waclaw gudowski, and now we are making a */ real fix for the problem. *i reconr.1830 if (er.lt.(1+small)*enl) go to 255 *ident up14 */ acer -- 20jul00 */ acer fails if you run it on a pendf tape that only has the */ single reaction mt=2 (elastic). this can happen for he-4 if you */ don't run heatr, thermr, or gaspr first. found by gudowski. *d acer.5121 mt=2 */ acer -- 20jul00 */ acer fails for mf=6, law=2, lang>0 (angular distribution with */ tabulated cosines). the only known example is mt=51 for pb-208 from */ release 6 of endf/b-vi. found by waclaw gudowski. *d up11.67 a(now+2-i+iscr)=a(now-i+iscr) */ acer -- 21jul00 */ an error was included in up9, which added a capability to handle */ anisotropic charged-particle emission represented using legendre */ polynomials. the update disabled the case of isotropic */ charged-particle emission, which occurs in a number of important */ materials from release 6 of endf/b-vi. the symptom is a serious */ clobbering of the ace file, such that it cannot even be read into */ mcnp or even printed using acer. also reported by gudowski. *d up9.56 else if (lang.eq.1.and.na.gt.0) then *d up9.100 if (lang.eq.1.and.na.gt.0) then *ident up15 */ heatr -- 31jul00 */ incorrect initial value found by m.mattes (u.stuttgart). *d heatr.2586 ir=1 */ increase the allowed number of legendre terms in h6ddx */ to handle the new jeff-3t fe-56 evaluation. *d heatr.3284 dimension cnow(*),p(15) *i heatr.3292 data nlmax/15/ *i heatr.3315 if (nl.gt.nlmax) call error('h6ddx', & 'too many legendre terms',' ') */ watch for ill-defined vertical segments in distributions. these */ have been seen in zr90 from cendl3 and fe56 from jeff3. actually, */ the evaluations should be fixed to avoid such features, because */ we don't really know what y value to select in the vertical */ segment. we choose to just move the second energy of the double */ point up a little. we only print the diagnostic once to keep the */ output cleaner, but there could be more than one vertical segment. *i heatr.3286 external mess *i heatr.3287 save illdef *i heatr.3318 illdef=0 *d heatr.3352,3353 x1=cnow(lnow-ncnow) x2=cnow(lnow) if (x1.eq.x2.and.lep.gt.1) then x2=sigfig(x2,6,1) if (illdef.eq.0) then call mess('h6ddx', & 'vertical segment(s) in distribution', & 'y(x) is ill defined') illdef=1 endif endif y1=cnow(lll-ncnow) y2=cnow(lll) call terp1(x1,y1,x2,y2,ep,tt,lep) *d heatr.3364,3367 x1=cnow(lnow-ncnow) x2=cnow(lnow) if (x1.eq.x2.and.lep.gt.1) then x2=sigfig(x2,6,1) if (illdef.eq.0) then call mess('h6ddx', & 'vertical segment(s) in distribution', & 'y(x) is ill defined') illdef=1 endif endif y1=cnow(lnow-ncnow+1) y2=cnow(lnow+1) call terp1(x1,y1,x2,y2,ep,s,lep) y1=cnow(lnow-ncnow+2) y2=cnow(lnow+2) call terp1(x1,y1,x2,y2,ep,r,lep) *d heatr.3380 x1=cnow(ii) x2=cnow(jj) if (x1.eq.x2.and.lep.gt.1) then x2=sigfig(x2,6,1) if (illdef.eq.0) then call mess('h6ddx', & 'vertical segment(s) in distribution', & 'y(x) is ill defined') illdef=1 endif endif y1=cnow(ii+1) y2=cnow(jj+1) call terp1(x1,y1,x2,y2,ep,s,lep) *d heatr.3395 call terp1(x1,tii,x2,tjj,ep,t,lep) *ident up16 */ groupr -- 31jul00 */ watch for ill-defined vertical segments in distributions. these */ have been seen in zr90 from cendl3 and fe56 from jeff3. actually, */ the evaluations should be fixed to avoid such features, because */ we don't really know what y value to select in the vertical */ segment. we choose to just move the second energy of the double */ point up a little. we only print the diagnostic once to keep the */ output cleaner, but there could be more than one vertical segment. *i groupr.5588 save illdef *i groupr.5591 external mess *i groupr.5633 illdef=0 *d groupr.5675,5676 x1=cnow(lnow-ncnow) x2=cnow(lnow) if (x1.eq.x2.and.lep.gt.1) then x2=sigfig(x2,6,1) if (illdef.eq.0) then call mess('h6ddx', & 'vertical segment(s) in distribution', & 'y(x) is ill defined') illdef=1 endif endif y1=cnow(lll-ncnow) y2=cnow(lll) call terp1(x1,y1,x2,y2,ep,tt,lep) *d groupr.5688,5691 x1=cnow(lnow-ncnow) x2=cnow(lnow) if (x1.eq.x2.and.lep.gt.1) then x2=sigfig(x2,6,1) if (illdef.eq.0) then call mess('h6ddx', & 'vertical segment(s) in distribution', & 'y(x) is ill defined') illdef=1 endif endif y1=cnow(lnow-ncnow+1) y2=cnow(lnow+1) call terp1(x1,y1,x2,y2,ep,s,lep) y1=cnow(lnow-ncnow+2) y2=cnow(lnow+2) call terp1(x1,y1,x2,y2,ep,r,lep) *d groupr.5722 x1=cnow(ii) x2=cnow(jj) if (x1.eq.x2.and.lep.gt.1) then x2=sigfig(x2,6,1) if (illdef.eq.0) then call mess('h6ddx', & 'vertical segment(s) in distribution', & 'y(x) is ill defined') illdef=1 endif endif y1=cnow(ii+1) y2=cnow(jj+1) call terp1(x1,y1,x2,y2,ep,s,lep) *d groupr.5737 call terp1(x1,tii,x2,tjj,ep,t,lep) *ident up17 */ acer -- 31jul00 */ fix an incorrect index in the law=61 section for the primary */ particle. the effect of this error is to give an incorrect */ angular distribution for the energy points with scattering */ probability zero (which should be isotropic). this change */ is strictly cosmetic and shouldn't affect any results. *d acer.6833 a(jscr+5+ia)=0 */ acer -- 31jul00 */ we want to use the compact law=4 for isotropic charged particle */ distributions, and the more general law=61 for anisotropic cp */ distributions. unfortunately, we can't tell which is which */ without reading past the first few energies for some evaluations. */ the need for this patch was first noticed by jeff3 fe56. *i acer.8982 c c ***first check the subsection to see whether c ***the distribution is isotropic or not. isocp=1 call findf(matd,mf,mt,nin) call contio(nin,0,0,a(iscr),nb,nw) nk=n1h ik=0 idone=0 do while (ik.lt.nk.and.idone.eq.0) ik=ik+1 ll=iscr lly=ll call tab1io(nin,0,0,a(ll),nb,nw) izap=nint(c1h) awp=c2h law=l2h ll=ll+nw do while (nb.ne.0) call moreio(nin,0,0,a(ll),nb,nw) ll=ll+nw enddo c c ***if not the desired particle, skip the subsection if (izap.ne.ip) then call skip6(nin,0,0,a(iscr),law) c c ***we only need to check law 1 subsections else if (law.eq.1) theN call tab2io(nin,0,0,a(ll),nb,nw) lang=nint(a(ll+2)) lep=nint(a(ll+3)) ne=nint(a(ll+5)) do ie=1,ne ll=lld call listio(nin,0,0,a(ll),nb,nw) ll=ll+nw do while (nb.ne.0) call moreio(nin,0,0,a(ll),nb,nw) ll=ll+nw enddo na=nint(a(lld+3)) if (na.gt.0) isocp=0 enddo endif enddo c c ***go back and process the subsection *d up9.43 if (law.eq.1.and.lang.eq.1.and.isocp.eq.0) & lawnow=61 if (law.eq.1.and.lang.eq.1.and.isocp.eq.1) & lawnow=4 *i up9.48 if (law.eq.1.and.isocp.eq.1) xss(landh+jp-1)=0 *d acer.9079,9082 *d acer.9085 if (lawnow.eq.4) then *d up14.23 else if (lawnow.eq.61) then *d up14.25 if (lawnow.eq.61) then *ident up18 */ acer -- 03aug00 */ some jef, eff, and jeff evaluations contain a redundant reaction */ mt=10 that gives the continuum neutron production. it is */ necessary to exclude this reaction from the reconstructed total */ cross section and to omit the associated energy-angle distribution. */ otherwise, the continuum neutron production will be counted twice. *i acer.1941 if (mt.eq.10) then idone=0 call mess('unionx','redundant mt=10 found', & 'cross section and distribution excluded') endif *i acer.2193 & (mf.eq.6.and.mt.eq.10).or. */ acer -- 03aug00 */ this change can fix an infinite loop during acer plotting *d acer.22571 if (ep.lt.zero) then */ acer -- 03aug00 */ for file 6 sections with only one subsection, the mt number is */ set to zero for the messages about energy-dependent yields. */ this is a trivial cosmetic patch and doesn't affect results. *i acer.6414 if (ikk.eq.nk) idone=1 */ acer -- 03aug00 */ this change is needed to handle nubar for jendl-3.2 u-235. it */ was originally made at los alamos in april, but somehow didn't */ make it to the official update file. *d acer.1090 if (int.gt.2) nonlin=1 *ident up19 */ heatr -- 03aug00 */ as noted above, some jef, eff, and jeff evaluations use the */ redundant mt=10. this value needs to be excluded from the */ heating and damage calculations. *d heatr.639 else if (mt.ne.10) then *d heatr.690 else if (mt.ne.10) then *i heatr.855 if (mt.eq.10) go to 110 *ident up20 */ acer -- 16aug00 */ there is an error in processing angular distributions using ltt=3 */ when newfor=0 (mcnp4b compatibility). the extra tosend causes the */ code to skip over the first reaction after the elastic mf=4. */ this leads to a bad tyr=0 value in the ace file, which causes */ mcnp to issue a confusing error message about "sabcol," even */ when s(alpha,beta) is not being used. this problem occurs only */ when processing the 150-mev evalutions from endf/b-vi.6. it */ is probably best to use release 5 with mcnp4b anyway. the */ release 5 and 6 data are identical below 20 mev. *d acer.2292 */ acer -- 16aug00 */ the code is finding the wrong value for the lct parameter (lab */ or cm frame) when processing file 4 angular distributions if */ the section is fully isotropic. this can result in an incorrect */ value for the ace tyr parameter, which can result in an apparent */ error from sabcol, even with no s(alpha,beta) data in the problem. */ this problem was introduced while the njoy97 coding was being */ converted to block structuring. *d acer.5342 *i acer.5359 lct=nint(a(iscr+3)) *d acer.5361 */ acer -- 16aug00 */ the consistency check for incorrect reference frame should take */ place for isotropic distributions also. sometimes, this check is */ not a real error. users should check the evaluation to see if the */ reference frame is really as intended by the evaluator. as fixed, */ this check would have found the two problems above! *d acer.17785 if (na.ge.0) then */ acer-- 16aug00 */ we are not currently handling law=5 for energy distributions. */ this occurs for u-233 fission from jef-2.2. the evaluation can */ be patched by converting the lf=5 part of the distribution to */ lf=1, which is sampled much better by mcnp using cummulative */ probability distributions anyway. *i acer.6098 call error('acelf5','sorry. acer cannot handle lf=5.', & 'you will have to patch the evaluation to use lf=1.') */ acer -- 16aug00 */ there are some additional places where skip6 should be skip6a. */ see up6 above. this shows up for endf be-9 with newfor=1. *d acer.8066 external error,findex,skip6a,contio,listio,tab1io,moreio,tab2io *d acer.8289 call skip6a(nin,0,0,a(iscr),law) *d acer.8880 call skip6a(nin,0,0,a(iscr),law) *d up17.42 call skip6a(nin,0,0,a(iscr),law) *d acer.9004 call skip6a(nin,0,0,a(iscr),law) *d acer.9027 call skip6a(nin,0,0,a(iscr),law) *d acer.9725 call skip6a(nin,0,0,a(iscr),law) */ acer -- 16aug00 */ there is an error in the law=7 part of up11. this shows up */ when processing endf be-9 using newfor=0 *d up11.29 call tab2io(nin,0,0,a(iscr),nb,nw) */ acer -- 16aug00 */ there is an error in the new skip6a routine introduced by up6 */ that shows up when processing sections with law=7 with newfor=0. *d up6.69 nmu=nint(a(4)) */ acer -- 16aug00 */ missing initialization in ptlegc (this could affect incident */ charged particles on some systems). *i acer.2217 dco=0 *ident up21 */ groupr -- 28sep00 */ the self-shielded cross sections are not being printed out */ correctly for the reactions, but total is ok. the gendf */ file is ok, so libraries made with njoy99 are ok. *d groupr.3613 call a10(ans(il,i,2),field(i)) *ident up22 */ reconr -- 28sep00 */ add capability to handle the new extension to the reich-moore */ resonance format that uses the sign of aj to designate which */ channel spin to use for a particular resonance. based on */ coding provided by nancy larson, ornl. *d reconr.2828,2942 c c ***loop over possible channel spins kchanl=0 idone=0 do while (kchanl.lt.2.and.idone.eq.0) kchanl=kchanl+1 inow=inowb kpstv=0 kngtv=0 c initialize matrix do j=1,3 do i=1,3 s(j,i)=0 r(j,i)=0 enddo enddo c c ***loop over resonances inow=inow+6 in=inow+nrs*6 do i=1,nrs aj=abs(a(inow+1)) c select only resonances with current j value if (abs(aj-ajc).le.quar) then if (a(inow+1).lt.zero) kngtv=kngtv+1 if (a(inow+1).gt.zero) kpstv=kpstv+1 iskip=0 if (kchanl.eq.1.and.a(inow+1).lt.zero) iskip=1 if (kchanl.eq.2.and.a(inow+1).gt.zero) iskip=1 if (iskip.eq.0) then c retrieve parameters er=a(inow) gn=a(inow+2) gg=a(inow+3) gfa=a(inow+4) gfb=a(inow+5) per=a(in+1) c gc=a(in+2) a1=sqrt(gn*pe/per) a2=0 if (gfa.ne.zero) a2=sqrt(abs(gfa)) if (gfa.lt.zero) a2=-a2 a3=0 if (gfb.ne.zero) a3=sqrt(abs(gfb)) if (gfb.lt.zero) a3=-a3 c compute energy factors diff=er-e den=diff*diff+quar*gg*gg de2=haf*diff/den gg4=quar*gg/den c calculate r-function, or c calculate upper triangular matrix terms r(1,1)=r(1,1)+gg4*a1*a1 s(1,1)=s(1,1)-de2*a1*a1 if (gfa.ne.zero.or.gfb.ne.zero) then r(1,2)=r(1,2)+gg4*a1*a2 s(1,2)=s(1,2)-de2*a1*a2 r(1,3)=r(1,3)+gg4*a1*a3 s(1,3)=s(1,3)-de2*a1*a3 r(2,2)=r(2,2)+gg4*a2*a2 s(2,2)=s(2,2)-de2*a2*a2 r(3,3)=r(3,3)+gg4*a3*a3 s(3,3)=s(3,3)-de2*a3*a3 r(2,3)=r(2,3)+gg4*a2*a3 s(2,3)=s(2,3)-de2*a2*a3 gf=1 endif endif endif inow=inow+ncyc in=in+3 enddo c ***take care of extra channel spin as defined c ***by the sign of aj: c *** kkkkkk = 0 => do not add anything in here c *** kkkkkk = 1 => add resonance contribution but c *** not extra hard-sphere c *** kkkkkk = 2 => add resonance plus hard-sphere c *** phase shift contribution kkkkkk = 0 if (kchanl.eq.1) then if (kpstv.gt.0) then if (kngtv.eq.0) then if (jj.gt.jjl.and.jj.lt.numj) then kkkkkk=2 else kkkkkk=1 endif else if (kngtv.gt.0) then kkkkkk=1 endif else if (kpstv.eq.0) then if (kngtv.eq.0) then if (jj.gt.jjl.and.jj.lt.numj) then kkkkkk=2 else kkkkkk=1 endif else if (kngtv.gt.0) then kkkkkk=0 endif endif else if (kchanl.eq.2) then if (kpstv.gt.0) then if (kngtv.eq.0) then else if (kngtv.gt.0) then kkkkkk=1 endif else if (kpstv.eq.0) then if (kngtv.eq.0) then else if (kngtv.gt.0) then if (jj.gt.jjl.and.jj.lt.numj) then kkkkkk=2 else kkkkkk=1 endif endif endif endif if (kkkkkk.ne.0) then c ***r-matrix path -- make symmetric matrix if (gf.ne.zero) then r(1,1)=uno+r(1,1) r(2,2)=uno+r(2,2) r(3,3)=uno+r(3,3) r(2,1)=r(1,2) s(2,1)=s(1,2) r(3,1)=r(1,3) s(3,1)=s(1,3) r(3,2)=r(2,3) s(3,2)=s(2,3) c invert the complex matrix call frobns(r,s,ri,si) c fission term for r-matrix path t1=ri(1,2) t2=si(1,2) t3=ri(1,3) t4=si(1,3) termf=four*gj*(t1*t1+t2*t2+t3*t3+t4*t4) u11r=p1*(two*ri(1,1)-uno)+two*p2*si(1,1) u11i=p2*(uno-two*ri(1,1))+two*p1*si(1,1) termt=two*gj*(uno-u11r) termn=gj*((uno-u11r)**2+u11i**2) c ***r-function path else dd=r(1,1) rr=uno+dd ss=s(1,1) amag=rr**2+ss**2 rri=rr/amag ssi=-ss/amag uur=p1*(two*rri-uno)+two*p2*ssi uui=p2*(uno-two*rri)+two*p1*ssi if (abs(dd).lt.small.and. & abs(phid).lt.small) then xx=2*dd xx=xx+2*(dd*dd+ss*ss+phid*phid+p2*ss) xx=xx-2*phid*phid*(dd*dd+ss*ss) xx=xx/amag termt=two*gj*xx termn=gj*(xx**2+uui**2) else termt=two*gj*(uno-uur) termn=gj*((uno-uur)**2+uui**2) endif termf=0 endif c c ***cross sections contributions if (kkkkkk.eq.2) then termn=termn+two*gj*(1-p1) termt=termt+two*gj*(1-p1) endif termg=termt-termf-termn sigp(2)=sigp(2)+termn sigp(4)=sigp(4)+termg sigp(3)=sigp(3)+termf sigp(1)=sigp(1)+termt endif enddo *ident up23 */ gaminr -- 28sep00 */ allow for up to 400 groups (added by request) *d gaminr.78 common/groupg/igg,ngg,egg(400) *d gaminr.87 dimension a(250000) *d gaminr.91 dimension ng2s(400),ig2s(400) *d gaminr.455 common/groupg/igg,ngg,egg(400) *d gaminr.602 data ngmax/400/ *d gaminr.521 common/groupg/igg,ngg,egg(400) *d gaminr.1138 common/groupg/igg,ngg,egg(400) *ident up24 */ dtfr -- 28sep00 */ allow for up to 400 groups (added by request) *d dtfr.105,107 common/dgrpn/egn(400),ngn common/dgrpg/egg(400),ngg common/dstore/a(20000),sig(200000) *d dtfr.110,111 dimension spect(400) dimension fcap(400),ffis(400) *d dtfr.114 data nwamax/20000/, nwsmax/200000/ *d dtfr.928 common/dgrpn/egn(400),ngn *d dtfr.932 common/dstore/x(3500),y(3500),z(1000),a(212000) *d dtfr.1262 common/dgrpn/egn(400),ngn *d dtfr.1409,1410 common/dgrpn/egn(400),ngn common/dgrpg/egg(400),ngg *d viewr.1294 dimension lll(400) *ident up25 */ groupr -- 11oct00 */ fix the section that reduces the number of sig figs in getdis. */ it was only acting on the in-group probabilities. this helps */ to make the results for elastic and discrete inelastic matrices */ the same on different machines. the basic idea is that these */ numbers are obtained by subtraction of numbers on the order of */ unity, so any results less than about 1e-7 are just random */ numbers and can be removed. *d groupr.6637,6642 ndig=7 fact=ten**ndig do il=1,nl do ii=1,ng iii=nint(fact*ff(il,ii)+ten**(ndig-11)) ff(il,ii)=iii/fact enddo enddo */ groupr -- 12oct00 */ change the size of common groupg to agree with the changes */ made in gaminr above. *d groupr.229 common/groupg/igg,ngg,egg(400) *d groupr.773 common/groupg/igg,ngg,egg(400) *d groupr.1919 common/groupg/igg,ngg,egg(400) *d groupr.3075 common/groupg/igg,ngg,egg(400) *d groupr.4275 common/groupg/igg,ngg,egg(400) *d groupr.7780 common/groupg/igg,ngg,egg(400) *ident up26 */ acer -- 12oct00 */ the current coding sometimes gets the threshold for charged */ particle production off by one point. *i acer.8075 data delt/1.d-10/ *i acer.8082 data delt/1.e-10/ *d acer.8166 do while (xss(esz+it-1).lt.thresh*(1-delt)) *ident up27 */ dtfr -- 27oct00 */ fix problem with finding right material and temperature */ on the pendf tape. the goto loop was not translated correctly! *d dtfr.220 idone=0 do while (idone.eq.0) *i dtfr.239 else idone=1 */ dtfr -- 27oct00 */ fix error made in up24 *d up24.21 common/dgrpg/egg(400),ngp *ident up28 */ acer -- 05nov00 */ the pointer into the a array is not being correctly incremented */ for the "call moreio" line. this only affects the new JEFF */ evaluation for beryllium, which has exceptionally detailed */ angulur tabulations. found by fischer (fzk). *i acer.2439 l=l+nw */ fix an indexing error in adjusting the normalization and */ precision for the pdf of angular distributions for law67 charged */ particle production that causes the pdf to be the same as the */ cdf. this problem shows up for beryllium (n,2n) alpha production */ in endf/b-vi, for example. identified by konno (jaeri). *d acer.8864 & sigfig(renorm*xss(next+1+nx+ix),7,0) *ident up29 */ ccccr -- 05nov00 */ the pointer in the e array for moreio is wrong. the result of */ this is that larger group structures cannot be handled correctly */ for delayed neutrons. found by broeders (karlsruhe). *d ccccr.3140 call moreio(nin,0,0,e(loc),nb,nw) *ident up30 */ heatr -- 05nov00 */ the insert of the data value for nlmax was incorrectly done into */ the "sw" conditional block instead of after the conditional */ block was complete. thus, it was only available to 32-bit */ versions of the code. this was discovered by deleege (delft) */ when running in 64-bit mode on a vax/alpha. *d up15.11 *i heatr.3298 data nlmax/15/ *ident up31 */ groupr -- 05nov00 */ fix two problems with the ltt3 option for 150 mev evaluations. */ the incorrect index for the c array leads to findex problems */ caused by clobbering the index for the dynamic storage system. */ you also have to make sure that the "over" option that allows */ getfle to extrapolate to energies slightly higher than the */ upper limit of the table doesn't act at the break between */ the two energy ranges with ltt3. this problem was reported */ by wienke (sck-cen). *d groupr.6838 if (nne.eq.ne.and.e.lt.over*ehi) then if (ltt3.eq.3.and.lttn.eq.1) go to 210 go to 300 endif *d groupr.6850,6851 call tab2io(nin,0,0,c(ifls),nb,nwc) ne=nint(c(ifls+5)) *ident up32 */ reconr -- 05nov00 */ some fission products from the jendl-3.2 library include */ an unresolved resonance range with no corresponding resolved */ range. trkov (iaea) proposed the following fix. *i reconr.672 if (eresr.lt.eresl) eresr=eresl *ident up33 */ gaminr -- 18jan01 */ the photoatomic group cross sections are not printed out */ correctly for a p-order greater than 5. *d gaminr.1075 & write(nsyso,'(13x,1p,6a11)') (field(i),i=7,nl) *ident up34 */ groupr -- 29jan01 */ need more storage in groupr to handle mt=91 for am243 from */ endf/b-vi release 5, which goes to 30 mev. the symptom was */ "storage exceeded" from cm2lab. *d groupr.248 dimension a(150000) *d groupr.273 iamax=150000 *ident up35 */ groupr -- 08feb01 */ when we increased the common block for photon group structures */ to allow as many as 400 groups (see up25), we forgot to update */ the parameter ngmax. this causes a "too many groups" error if */ you run with more than 150 gamma groups. *d groupr.2000 data ngmax/400/ *ident up36 */ acer -- 08feb01 */ in up17, we checked for isotropic distributions in order to use */ a more compact presentation. the logic misses one special case, */ namely, pb208 from endf/b-vi release 6. *d up17.41 if (izap.ne.ip.or.law.ne.1) then *d up17.45 else *ident up37 */ reconr -- 09feb01 */ all through njoy, we have been using 1e10 ev as our idea of */ an infinite energy. progress happens, and red cullen at llnl */ is putting out an endf version of the evaluated photon data */ library (epdl97), which contains data to 100 gev. the following */ change prevents reconr from going into an infinite loop in the */ emerge routine with 100 gev data. *d reconr.4126 data finity/.99d12/ *d reconr.4130 data finity/.99e12/ *ident up38 */ njoy -- 09feb01 */ keep on increasing infinity for the 100 gev data. the routines */ gety1, gety2, and terpa return an "infinite" energy at the end */ of the table, and we now increase that to 1e12 ev. this doesn't */ seem to cause any problems in njoy modules (such as groupr) that */ still check for return values of 1e10 or more; all the standard */ test problems still work fine. *d njoy.2204 data xbig/1.d12/ *d njoy.2208 data xbig/1.e12/ *d njoy.2418 data xbig/1.d12/ *d njoy.2422 data xbig/1.e12/ *d njoy.2532 data xbig/1.d12/ *d njoy.2536 data xbig/1.e12/ *ident up39 */ gaminr -- 09feb01 */ keep on increasing infinity for the 100 gev data. *d gaminr.106 data emax/1.d12/ *d gaminr.110 data emax/1.e12/ *d gaminr.779 data emax/1.d12/ *d gaminr.782 data emax/1.e12/ *d gaminr.1164 data emax/1.d12/ *d gaminr.1186 data emax/1.e12/ *ident up40 */ acer -- 23mar01 */ due to a bad if clause, the contribution to heating from charged */ particles is not being included for mf=6, law 3 or 4. this was */ noticed in the run for endf/b-vi be-9 by lanl/x-5. the errors in */ this particular case are quite small because of the small cross */ sections for charged-particle emission. this error will only */ effect mcnpx calculations for coupled neutron-proton transport. *d acer.9220,9231 c add in contribution to heating naa=nint(xss(hpd+1)) do ie=it,nes e=xss(esz+ie-1) ss=0 if (ie.ge.iaa) ss=xss(2+k+ie-iaa) tt=xss(next+1)*(e-xss(next))*ss xss(hpd+2+naa+ie-it)=xss(hpd+2+naa+ie-it) & +tt enddo *ident up41 */ acer -- 27mar01 */ the value "nr = 0", implying linear interpolation over all points, */ is not printed on the acer output listing for two cases, as reported */ by lanl/x-5. these errors do not affect mcnp results, but the */ repair makes the printout for photon yields and energy distributions */ match those for other types of data. *i acer.10808 write(nsyso,'(12x,''nr ='',i4)') m *d acer.10810 *i acer.10998 write(nsyso,'(12x,''nr ='',i4)') m *d acer.11000,11002 *ident up42 */ purr -- 27mar01 */ remove the timers that are given as each ladder is processed */ in order to reduce the number of diffs that show up when */ succesive runs are checked for qa purposes using the same */ sequence of random numbers. for lanl/x-5. *d purr.1746 external fsort,ladr2,fsrch *d purr.1798 & ''capture'')') e,spot,dbart,sigx *d purr.2145,2147 if (iprint.gt.0) write(nsyso,'(i6,1p,4e12.4)') & iladr,totf,elsf,fisf,capf *ident up43 */ heatr -- 27mar01 */ the roundup applied to the first energy grid point should */ be smaller now that we are routinely working with 7-digit */ energies. the effect if this in current files is that the */ first energy in any of the heating and damage reactions is */ a little larger than the normal 1e-5. this shows up as a */ zero heating or damage value for the first point in the mcnp */ ace files, which is strange looking, but of little significant */ impact on real calculations. reported by lanl/x-5. *d heatr.425 data rup/1.0000001d0/ *ident up44 */ acer -- 29mar01 */ lanl/x-5 has requested that the main container array be increased */ in size to allow bigger ace files to be generated. it is also */ necessary to increase the i7 length field on the xsdir cards to i8 */ to accomodate the larger ace files. *d acer.257 max3=1500000 *d acer.4662 common/xsst/xss(1500000),n3 *d acer.5601 common/xsst/xss(1500000),n3 *d acer.5762 common/xsst/xss(1500000),n3 *d acer.5951 common/xsst/xss(1500000),n3 *d acer.6322 common/xsst/xss(1500000),n3 *d acer.7383 common/xsst/xss(1500000),n3 *d acer.8055 common/xsst/xss(1500000),n3 *d acer.9754 common/xsst/xss(1500000),n3 *d acer.10202 common/xsst/xss(1500000),n3 *d acer.10675 common/xsst/xss(1500000),n3 *d acer.11068 common/xsst/xss(1500000),n3 *d acer.11588 common/xsst/xss(1500000),n3 *d acer.11649 & '(a10,f12.6,'' filename route'',i2,i4,i8,2i6,1p,e10.3, *d acer.11653 & '(a10,f12.6,'' filename route'',i2,i4,i8,2i6,1p,e10.3)') *d acer.11659 & '(a13,f12.6,'' file route'',i2,i4,i8,2i6,1p,e10.3, *d acer.11663 & '(a13,f12.6,'' file route'',i2,i4,i8,2i6,1p,e10.3)') *d acer.11689 common/xsst/xss(1500000),n3 *d acer.12854 common/xsst/xss(1500000),n3 *d acer.13452 common/xsst/xss(1500000),n3 *d acer.13591 common/xsst/xss(1500000),n3 *d acer.13771 common/xsst/xss(1500000),n3 *d acer.14170 common/xsst/xss(1500000),n3 *d acer.14274 & '(a10,f12.6,'' filename route'',i2,2h 1,i8,2i6,1p,e10.3)') *d acer.14278 & '(a13,f12.6,'' filename route'',i2,2h 1,i8,2i6,1p,e10.3)') *d acer.14305 common/xsst/xss(1500000),n3 *d acer.14462 common/xsst/xss(1500000),n3 *d acer.14548 common/xsst/xss(1500000),n3 *d acer.14640 & '(a10,f12.6,'' filename route'',i2,2h 1,i8,2i6,1p,e10.3)') *d acer.14644 & '(a13,f12.6,'' filename route'',i2,2h 1,i8,2i6,1p,e10.3)') *d acer.14674 common/xsst/xss(1500000),n3 *d acer.15012 common/xsst/xss(1500000),n3 *d acer.15107 common/xsst/xss(1500000),n3 *d acer.15187 & '(a10,f12.6,'' filename route'',i2,'' 1'',i8,2i6,1p,e10.3)') *d acer.15191 & '(a13,f12.6,'' filename route'',i2,'' 1'',i8,2i6,1p,e10.3)') *d acer.15216 common/xsst/xss(1500000),n3 *d acer.16604 common/xsst/xss(1500000),n3 *d acer.17057 common/xsst/xss(1500000),n3 *d acer.17436 & '(a10,f12.6,'' filename route'',i2,'' 1'',i8,2i6,1p,e10.3)') *d acer.17440 & '(a13,f12.6,'' filename route'',i2,'' 1'',i8,2i6,1p,e10.3)') *d acer.17459 common/xsst/xss(1500000),n3 *d acer.17727 common/xsst/xss(1500000),n3 *d acer.18534 common/xsst/xss(1500000),n3 *d acer.19545 common/xsst/xss(1500000),n3 *d acer.19817 common/xsst/xss(1500000),n3 *d acer.19934 common/xsst/xss(1500000),n3 *d acer.20164 common/xsst/xss(1500000),n3 *d acer.20610 common/xsst/xss(1500000),n3 *d acer.21222 common/xsst/xss(1500000),n3 *d acer.21815 common/xsst/xss(1500000),n3 *ident up45 */ acer -- 08apr01 */ as discovered by jean christophe sublet, sun forte6 f95 is */ finiky about opening a scratch file that is already open, */ although all other compilers used for njoy thus far were more */ accepting. we just have to be careful to close a unit used */ as a scratch file before reusing the unit for another purpose. *i acer.2082 call closz(nscr) *ident up46 */ gaspr -- 09apr01 */ close another scratch unit. *i gaspr.838 call closz(nscr1) *ident up47 */ acer -- 09apr01 */ the length published for thermal data files is too long by one */ for cases including incoherent elastic scattering. for endf, */ this is poly, h(zrh), and cold solid methane. discovered by */ roberto orsi (enea-bologna). *d acer.13517 *ident up48 */ acer -- 09apr01 */ the landh parameter should be zero (not -1) for isotropic */ subsections of mf=6 described using law=3. this occurs for */ the reactions (n,p0) through (n,a0) in be-9 from endf/b-vi. */ Noted by bob little (lanl/x-5). *i acer.9209 if (law.eq.3) xss(landh+jp-1)=0 *ident up49 */ acer -- 09apr01 */ the representation for ace law3/33 should use -q instead of */ abs(q) in order to handle two-body reactions for isomeric */ targets. this change in the ace specifications was recommended */ by bob little (lanl/x-5) after a query by waclaw gudowski. it */ only affects a small number of evaluations. *d acer.5465 xss(next+9)=sigfig(x*(-q),7,0) *d acer.8964 xss(next)=sigfig((1+amass)*(-q)/amass,7,0) *d acer.9167 xss(next)=sigfig((1+amass)*(-q)/amass,7,0) *d acer.9216 xss(next)=sigfig((1+amass)*(-q)/amass,7,0) *d acer.16168 xss(nex)=sigfig(-q,7,0) *d acer.16526 xss(nex)=sigfig(-q,7,0) *ident up50 */ acer -- 09apr01 */ most of the jendl photonuclear evaluations currently available */ from http://iaeand.iaea.or.at/photonuclear/ crash with an i/o */ error because they use a non-conforming format where mf=6, */ mt=201-27 are used to represent particle production. we are */ providing a clearer error message for the user's convenience. */ these evaluations cannot be used in njoy or mcnpx in their */ current form. *i acer.15310 if (mfd.eq.6.and.mtd.ge.201.and.mtd.le.207) & call error('acephn','mf=6/mt=201-207 not supported.', & 'does not conform to endf format.') *ident up51 */ acer -- 12apr01 */ add a capability to handle a two-body recoil subsection of mf=6 */ for photonuclear files. this may be useful for representing the */ photodisintegration of the deuteron with full distributions for */ both neutron and proton. we tested the patch using a modified */ version of the g+2H evaluation from JENDL. *d acer.16011 c c ***special steps for two-body recoil c ***back up to the corresponding law=2 distr. izarec=0 awprec=0 if (izap.eq.ip.and.law.eq.4) then izarec=izap awprec=awp mf=6 call findf(matd,mf,mt,nin) call contio(nin,0,0,a(iscr),nb,nw) call tab1io(nin,0,0,a(iscr),nb,nw) izap=nint(c1h) awp=c2h law=l2h jscr=iscr+nw do while (nb.ne.0) call moreio(nin,0,0,a(jscr),nb,nw) jscr=jscr+nw enddo endif c c ***law2 angular distribution c ***also used for law 4 two-body recoils if ((izap.eq.ip.and.law.eq.2).or. & (izarec.eq.ip.and.law.eq.2)) then lld=jscr *i acer.16030 if (izarec.eq.0) then awpp=awp else awpp=awprec endif *i acer.16036 if (izarec.ne.0) then nl=nint(a(lld+5)) do iil=1,nl if (mod(iil,2).eq.1) then a(lld+5+iil)=-a(lld+5+iil) endif enddo endif *d acer.16104 a(llht+7+2*iie)=(awr-awpp)*(e+q)/awr *d acer.16354 if (law.ne.1.and.law.ne.2.and.law.ne.4) then *d acer.16356 & 'law=2, or law=4 currently') *i acer.16540 else if (law.eq.4) then xss(last+1)=33 xss(nex)=0 xss(nex+1)=2 nnr=nint(a(iscr+4)) nnp=nint(a(iscr+5)) xss(nex+2)=sigfig(a(iscr+6+2*nnr)/emev,7,0) xss(nex+3)= & sigfig(a(iscr+4+2*nnr+2*nnp)/emev,7,0) xss(nex+4)=1 xss(nex+5)=1 nex=nex+2+2*2 xss(last+2)=nex-dlwp+1 xss(nex)=sigfig(-q,7,0) xss(nex+1)=sigfig(awr/(1+awr),7,0) nex=nex+2 *ident up52 */ acer -- 13apr01 */ add a capability to handle tabulated sections of File 5 (lf=1) */ for photonuclear files. Such sections are used in the Russian */ evaluations for three isotopes of plutonium included in the */ iaea photonuclear compilation. this also fixes a bug in the */ storage of fission nubar. the first point for energy distributions */ often has a nonrealistic sharp triangle given for the spectrum. */ this can cause problems with the vertical scale for plots */ because the emission probabilities get very large for small */ ranges of secondary energy. therefore, we ignore the first */ incident energy in determining the vertical scale for the plot. *d acer.15858,15859 xss(nex+3+j)=sigfig(fnubar(5+2*nr+2*j)/emev,7,0) xss(nex+3+ne+j)=sigfig(fnubar(6+2*nr+2*j),7,0) *d acer.16247 if (lf.eq.1) then call tab2io(nin,0,0,a(iscr),nb,nw) m=nint(a(iscr+4)) n=nint(a(iscr+5)) jnt=nint(a(iscr+7)) jnt=mod(jnt,10) if (jnt.gt.2) jnt=2 if (m.ne.1.or.jnt.ne.2) then xss(nex)=m do j=1,m xss(j+nex)=a(2*j+4+iscr) jnt=nint(a(2*j+5+iscr)) jnt=mod(jnt,10) if (jnt.gt.2) jnt=2 xss(j+m+nex)=jnt enddo nex=nex+1+2*m else xss(nex)=0 nex=nex+1 endif xss(nex)=n nexn=nex+n nexd=nexn+n+1 ne=n do j=1,ne call tab1io(nin,0,0,a(iscr),nb,nw) jscr=iscr do while (nb.ne.0) jscr=jscr+nw call moreio(nin,0,0,a(jscr),nb,nw) enddo e=c2h xss(nex+j)=sigfig(e/emev,6,0) xss(nexn+j)=nexd-dlwp+1 m=n1h n=n2h jnt=nint(a(iscr+5+2*m)) xss(nexd)=jnt xss(nexd+1)=n nexd=nexd+1 xss(nexd+1+2*n)=0 do ki=1,n ep=a(iscr+4+2*m+2*ki) ll=iscr+4+2*m+2*ki xss(ki+nexd)=sigfig(a(ll)/emev,7,0) xss(ki+n+nexd)=sigfig(a(ll+1)*emev,7,0) if (xss(ki+n+nexd).lt.rmin) xss(ki+n+nexd)=0 if (ki.gt.1.and.jnt.eq.1) xss(ki+2*n+nexd)= & xss(ki+2*n-1+nexd)+a(ll-1)*(a(ll)-a(ll-2)) if (ki.gt.1.and.jnt.eq.2) xss(ki+2*n+nexd)= & xss(ki+2*n-1+nexd)+((a(ll-1) & +a(ll+1))/2)*(a(ll)-a(ll-2)) enddo c renormalize renorm=1 if (xss(3*n+nexd).ne.zero) & renorm=1/xss(3*n+nexd) do ki=1,n xss(ki+n+nexd)= & sigfig(xss(ki+n+nexd)*renorm,7,0) xss(ki+2*n+nexd)= & sigfig(xss(ki+2*n+nexd)*renorm,9,0) enddo nexd=nexd+3*n+1 enddo nex=nexd else if (lf.eq.7.or.lf.eq.9) then *d acer.22424 do ie=2,ne *ident up53 */ groupr -- 11jun01 */ if the file6 distribution is fully isotropic (law=3), the getfle */ routine doesn't realize that when doing a discrete recoil (law=4). */ we create a special flag of law=-4 to pass the fact of isotropy */ into getfle. this problem only affects runs that compute a */ transfer matrix for the recoil particle when the first particle */ emitted is given as totally isotropic (for example, mt=701 for */ endf be-9). the error message is "desired energy above highest */ given." found by dieter leichtle (fzk). *i groupr.4859 lf=nint(c(l+3)) *i groupr.4860 if (lf.eq.3) law=-4 *i groupr.4869 if (law.eq.-4) go to 194 *i groupr.6786 if (law.eq.-4) iso=1 *ident up54 */ reconr -- 12jun01 */ allow for the series of mt numbers 875-891 that can be used */ to represent different levels of the (n,2n) reaction in the */ same way that 600-649 are used to represent different levels */ of the (n,p) reaction. the code expects that mf=3/mt=16 */ contains the sum of mt=875 through 891 in the same way that */ mt=103 contains the sum of 600-649. this representation is */ used for be-9 for eff-3.1 and jeff-3.0. *d reconr.1696 if (mth.ge.900) go to 150 *ident up55 */ heatr -- 12jun01 */ if mt=875-891 appears in the file, mt=16 is redundant. this */ is analogous to the way mt=107 is redundant if mt=800-850 */ is present. *d heatr.412 common/heat4/mt103,mt104,mt105,mt106,mt107,mt16 *i heatr.440 mt16=0 *i heatr.499 if (mtd.ge.875.and.mtd.lt.891) mt16=1 *d heatr.783 common/heat4/mt103,mt104,mt105,mt106,mt107,mt16 *i heatr.865 if (mt.eq.16.and.mt16.gt.0) go to 110 */ the integration over secondary energy for law 7 in getsix */ must allow for histogram interpolation as used in be-9 */ from eff-3.1. the effect of this is to get especially */ bad particle energies for the discrete neutron in mt=876. *i heatr.3008 iint=nint(c(l+7)) *d heatr.3020 if (i.gt.1) then if (iint.eq.1) then h=h+(xx-xl)*el else h=h+(xx-xl)*(en+el)/2 endif endif *d heatr.3022 if (i.gt.1) then if (iint.eq.1) then d=d+(xx-xl)*fl else d=d+(xx-xl)*(fn+fl)/2 endif endif *ident up56 */ acer 12jun01 */ the angle-energy law in file 6 is always causing trouble. */ it is especially difficult when more than one subsection */ is used to describe the emission for a particle, because */ an overall angular distribution for the reaction must be */ contructed. with the new formats, it is easy to eliminate */ law=7 sections by converting them to law=1 with tabulated */ angular distributions. *d acer.2111,2112 c mf4 and 5. mf6 is also copied, unless law=7 is found, c in which case the law=7 data are converted to law=1. c all other conversions of the distributions will be c done in acelod. *i acer.2132 zero=0 one=1 *i acer.2365 if (newfor.eq.1.and.lf.eq.7) a(iscr+3)=1 *i acer.2371 else if (lf.eq.7.and.newfor.eq.1) then c law=7 for newfor=1 -- convert the law7 c data into law1 format. call tab2io(nin,0,0,b,nb,nw) ne=nint(b(6)) do ie=1,ne c read in the data call tab2io(nin,0,0,a(iscr),nb,nw) ei=a(iscr+1) intmu=nint(a(iscr+7)) nmu=n2h loc=iscr+nmu do imu=1,nmu a(iscr+imu-1)=loc call tab1io(nin,0,0,a(loc),nb,nw) intep=nint(a(loc+7)) loc=loc+nw do while (nb.ne.0) call moreio(nin,0,0,a(loc),nb,nw) loc=loc+nw enddo enddo c fix up the tab2 for law1 if (ie.eq.1) then b(3)=10+intmu b(4)=intep call tab2io(0,nout,0,b,nb,nw) ncs(nxc)=ncs(nxc)+2 endif c construct a union grid for eprime igrd=loc ngrd=0 do imu=1,nmu loc=nint(a(iscr+imu-1)) m=nint(a(loc+4)) n=nint(a(loc+5)) do iep=1,n ngrd=ngrd+1 a(igrd+ngrd-1)=a(loc+4+2*m+2*iep) enddo enddo call ordr(a(igrd),ngrd) c interpolate for angular distributions c on the union eprime grid to construct c the law1 distribution. ians=igrd+ngrd a(ians)=0 a(ians+1)=ei a(ians+2)=0 a(ians+3)=2*nmu a(ians+4)=ngrd*(2+2*nmu) a(ians+5)=ngrd ll=ians+6 do iep=1,ngrd ep=a(igrd+iep-1) a(ll)=ep ss=0 do imu=1,nmu loc=nint(a(iscr+imu-1)) ipp=2 irr=1 call terpa(ff,ep,epn,idis,a(loc), & ipp,irr) a(ll+2*imu)=a(loc+1) a(ll+1+2*imu)=ff if (imu.gt.1) then dmu=a(ll+2*imu)-a(ll+2*imu-2) if (intmu.eq.1) then ss=ss+dmu*a(ll+1+2*imu-2) else ss=ss+dmu* & (a(ll+1+2*imu)+a(ll+1+2*imu-2))/2 endif endif enddo a(ll+1)=ss do imu=1,nmu if (ss.ne.zero) then a(ll+1+2*imu)=a(ll+1+2*imu)/ss else a(ll+1+2*imu)=one/2 endif enddo ll=ll+2+2*nmu enddo call listio(0,nout,0,a(ians),nb,nw) ll=ians+nw do while (nb.ne.0) call moreio(0,nout,0,a(ll),nb,nw) ll=ll+nw enddo nw=ngrd*(2+2*nmu) nw=(nw+5)/6 ncs(nxc)=ncs(nxc)+1+nw enddo *i acer.2457 c subroutine ordr(x,n) c ****************************************************************** c sort the n elements of x into ascending order c removing any duplicate elements c ****************************************************************** *if sw implicit real*8 (a-h,o-z) *endif dimension x(*) *if sw data small/1.d-10/ *else data small/1.e-10/ *endif c if (n.le.2) return c sort i=0 110 i=i+1 j=i 120 j=j+1 if (x(j).lt.x(i)) then tsave=x(j) x(j)=x(i) x(i)=tsave endif if (j.lt.n) go to 120 if (i.lt.n-1) go to 110 c remove duplicates m=n i=1 do while (i.lt.m) i=i+1 if (abs(x(i)-x(i-1)).le.small*x(i)) then m=m-1 do k=i,m x(k)=x(k+1) enddo i=i-1 endif enddo n=m return end *d acer.6792 else if (lang.gt.2.and.newfor.eq.0) then *i acer.6861 c c ***convert tabulated distribution to law 61 else if (lang.gt.2.and.newfor.eq.1) then xss(ki+3*n+nexd)=nexcd-dlw+1 ll=iscr+6+ncyc*(ki-1) intmu=lang-10 xss(nexcd)=intmu nmu=na/2 xss(nexcd+1)=nmu do imu=1,nmu xss(nexcd+1+imu)=a(ll+2*imu) xss(nexcd+1+nmu+imu)=a(ll+2*imu+1) if (imu.eq.1) then sum=0 xss(nexcd+1+2*nmu+imu)=0 else del=a(ll+2*imu)-a(ll+2*imu-2) if (intmu.eq.1) then sum=sum+del*a(ll+1+2*imu-2) xss(nexcd+1+2*nmu+imu)=sum else av=(a(ll+1+2*imu)+a(ll+1+2*imu-2))/2 sum=sum+del*av xss(nexcd+1+2*nmu+imu)=sum endif endif enddo do imu=1,nmu xss(nexcd+1+imu)= & sigfig(xss(nexcd+1+imu)/sum,7,0) xss(nexcd+1+nmu+imu)= & sigfig(xss(nexcd+1+nmu+imu)/sum,7,0) xss(nexcd+1+2*nmu+imu)= & sigfig(xss(nexcd+1+2*nmu+imu)/sum,7,0) enddo nexcd=nexcd+2+3*nmu */ add support for law1 with tabulated angular distributions */ to the charged-particle section. *i up9.45 if (law.eq.1.and.lang.ge.11) lawnow=61 *d up9.55 c legendre or tabulated distribution *d up9.58,up9.97 if (lang.eq.1) then a(ll)=0 a(ll+1)=ep a(ll+2)=0 a(ll+3)=0 a(ll+4)=na a(ll+5)=0 do ia=1,na lll=lld+7+ncyc*(ig-1) a(ll+5+ia)=0 if (a(lll).ne.zero) then a(ll+5+ia)=a(lll+ia)/a(lll) endif enddo call ptleg2(a(ll)) intmu=2 nmu=nint(a(ll+5)) llx=ll+6 else intmu=lang-10 nmu=na/2 llx=lld+6 endif xss(next+1+3*ng+ig)=nexcd-dlwh+1 xss(nexcd)=intmu xss(nexcd+1)=nmu do imu=1,nmu xss(nexcd+1+imu)= & a(llx+2*imu) xss(nexcd+1+nmu+imu)= & a(llx+1+2*imu) if (imu.eq.1) then sum=0 xss(nexcd+1+2*nmu+imu)=0 else del=a(llx+2*imu) & -a(llx+2*imu-2) if (intmu.eq.1) then sum=sum & +del*a(llx+1+2*imu-2) xss(nexcd+1+2*nmu+imu)=sum else av=(a(llx+1+2*imu) & +a(llx+1+2*imu-2))/2 sum=sum+del*av xss(nexcd+1+2*nmu+imu)=sum endif endif enddo do imu=1,nmu xss(nexcd+1+imu)=sigfig( & xss(nexcd+1+imu)/sum,7,0) xss(nexcd+1+nmu+imu)=sigfig( & xss(nexcd+1+nmu+imu)/sum,7,0) xss(nexcd+1+2*nmu+imu)=sigfig( & xss(nexcd+1+2*nmu+imu)/sum,7,0) enddo *ident up57 */ acer -- 12jun01 */ changes to acer needed to support the eff-3.1/jeff-3.0 */ representation for be-9. we have to allow for the series */ of mt numbers 875-891. if present, mt=16 is redundant and */ must appear after the distributions in the reaction list. */ the section for mt=876 has two subsections for neutron */ emission. this problem is handled by the previous update. *i acer.551 common/ace9/mt16 *i acer.642 mt16=0 *i acer.663 if (mtd.ge.875.and.mtd.le.891) mt16=1 *d acer.1939 & (iverf.ge.6.and.mt.gt.900)) then *i acer.4671 common/ace9/mt16 *i acer.4760 if (mt16.gt.0.and.mt.eq.16) nr=nr-1 *d acer.4759 if ((mt.ge.5.and.mt.le.91).or. & (mt.ge.875.and.mt.le.899)) then *i acer.5021 if (mt.gt.91.and.mt.le.849) iskip=1 if (mt16.gt.0.and.mt.eq.16) iskip=1 *d acer.5118,5120 call findf(matd,3,2,nin) *d acer.5127 if (mt.gt.91.and.mt.le.849) iskip=0 if (mt16.gt.0.and.mt.eq.16) iskip=0 *d acer.9481 renorm=1 if (xss(next+3*npep).ne.zero) & renorm=1/xss(next+3*npep) */ add the new reaction names to the mtname routine *d acer.11389 character*10 hndf(457) *d acer.11393,11394 character*10 hndf9(50) character*10 hndf10(7) character*10 hndf11(1) *d acer.11403,11404 equivalence (hndf9(1),hndf(400)) equivalence (hndf10(1),hndf(450)) equivalence (hndf11(1),hndf(457)) *i acer.11514 data hndf9/'(n,x) ', & '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', & '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', & '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', & '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', & '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', & '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', & '(n,2n*0) ', & '(n,2n*1) ', '(n,2n*2) ', '(n,2n*3) ', '(n,2n*4) ', & '(n,2n*5) ', '(n,2n*6) ', '(n,2n*7) ', '(n,2n*8) ', & '(n,2n*9) ', '(n,2n*10) ', '(n,2n*11) ', '(n,2n*12) ', & '(n,2n*13) ', '(n,2n*14) ', '(n,2n*15) ', '(n,2n*c) ', & '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', & '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) '/ *d acer.11520,11522 data hndf10/'(n,xn) ','(n,xgma) ','(n,xp) ', & '(n,xd) ','(n,xt) ','(n,xhe3) ','(n,xa) '/ data hndf11(1)/'damage '/ *d acer.11526,11528 if (i.ge.201.and.i.le.207) i=i+249 if (i.ge.600) i=i-450 if (mt.eq.444) i=457 *d acer.11534 name=hndf(mt+250) *d acer.11536 name=hndf(457) */ need more storage for eff-3.1 be-9 *d up44.8 max3=3000000 *d up44.10 common/xsst/xss(3000000),n3 *d up44.12 common/xsst/xss(3000000),n3 *d up44.14 common/xsst/xss(3000000),n3 *d up44.16 common/xsst/xss(3000000),n3 *d up44.18 common/xsst/xss(3000000),n3 *d up44.20 common/xsst/xss(3000000),n3 *d up44.22 common/xsst/xss(3000000),n3 *d up44.24 common/xsst/xss(3000000),n3 *d up44.26 common/xsst/xss(3000000),n3 *d up44.28 common/xsst/xss(3000000),n3 *d up44.30 common/xsst/xss(3000000),n3 *d up44.32 common/xsst/xss(3000000),n3 *d up44.42 common/xsst/xss(3000000),n3 *d up44.44 common/xsst/xss(3000000),n3 *d up44.46 common/xsst/xss(3000000),n3 *d up44.48 common/xsst/xss(3000000),n3 *d up44.50 common/xsst/xss(3000000),n3 *d up44.52 common/xsst/xss(3000000),n3 *d up44.58 common/xsst/xss(3000000),n3 *d up44.60 common/xsst/xss(3000000),n3 *d up44.62 common/xsst/xss(3000000),n3 *d up44.68 common/xsst/xss(3000000),n3 *d up44.70 common/xsst/xss(3000000),n3 *d up44.72 common/xsst/xss(3000000),n3 *d up44.78 common/xsst/xss(3000000),n3 *d up44.80 common/xsst/xss(3000000),n3 *d up44.82 common/xsst/xss(3000000),n3 *d up44.88 common/xsst/xss(3000000),n3 *d up44.90 common/xsst/xss(3000000),n3 *d up44.92 common/xsst/xss(3000000),n3 *d up44.94 common/xsst/xss(3000000),n3 *d up44.96 common/xsst/xss(3000000),n3 *d up44.98 common/xsst/xss(3000000),n3 *d up44.100 common/xsst/xss(3000000),n3 *d up44.102 common/xsst/xss(3000000),n3 *d up44.104 common/xsst/xss(3000000),n3 *d up44.106 common/xsst/xss(3000000),n3 *ident up58 */ broadr -- 10jul01 */ increase the storage area in broadr to reduce paging and make */ comparisons between njoy99 and njoy2001 easier. there will */ normally be a small difference in the grids produced by broadr */ each time paging takes place, and this makes it hard to compare */ files using diff. *d broadr.113 dimension a(95000) *d broadr.137 namax=95000 *ident up59 */ acer -- 20jul01 */ in charged-particle emission, the first point for energy */ distributions often has a nonrealistic sharp triangle given for */ the spectrum. this can cause problems with the vertical scale */ incident energy in determining the vertical scale for the plot. *d acer.21529 do ie=2,ne *ident up60 */ reconr -- 24sep01 */ occasionally, reactions are given with a nonzero cross section */ at threshold, even though this violates endf procedures. reconr */ had some logic for handling this that was being overwritten by */ another change. we fix it here by inserting an extra energy */ point just above the threshold and zeroing the cross section at */ the threshold. a diagnostic message is provided. one example */ of a place were this occurs is gd158 from endf/b-vi. reported */ by frankle (lanl). *i reconr.1588 character*40 text *d reconr.1716,1719 write(text,'(''xsec nonzero at threshold for mt='',i3)') mth call mess('lunion',text,'adusted using jump in xsec') *d reconr.1767 er=sigfig(er,7,0) *d reconr.1783 enl=sigfig(er,7,0) *d reconr.4204 */ reconr -- 24sep01 */ reconr contains some logic that tries to avoid doing work on */ very small charged-particle cross sections by defining a */ "pseudo-threshold" when the cross section rises to more than */ 1e-15 barns. however, this scheme isn't carried out completely, */ and it only results in the omission of the threshold energy for */ reactions that have less than this cross section just above */ the threshold. this effect shows up for the (n,n't) reaction */ mt=33 for cd-110 from endf/b-vi.4. at the request of bob */ little (lanl), we are changing the constant "ssmall" that */ triggers this effect to a smaller number. in the long term, */ we should reconsider this logic. *d reconr.1601 ssmall=1.d-30 *d reconr.1614 ssmall=1.e-30 *ident up61 */ acer -- 25sep01 */ kisako kazuaki (sumimoto) has observed that the common variable */ coeff in eval is not set. actually, eval is not really used in */ tabize anymore. it is just leftover as an intialization for a(iy). */ the only other place it is used is in islin2, and islin2 is not */ called anymore! This update removes these leftover remnants. *d acer.1019 *d acer.1022 external loada,finda,error,sigfig *d acer.1128 a(iy)=0 *d acer.1216,1263 */ kazuaki also noticed that the photoatomic heating value was */ being stored in ev instead of mev and that the atomic number */ aw0 was not being set. *i acer.14730 aw0=c2h *d acer.14839 xss(lhnm-1+i)=heat/emev *ident up62 */ purr -- 28sep01 */ lanl group x-5 has noted that the conditional heating cross */ section in the mcnp probability tables is not quite what they */ expected. we change the calculation here to get results that */ are consistently given as eV/reaction for lssf=0 and fluctuation */ factors for lssf=1. *i purr.79 zero=0 *d purr.454,458 if (sigu(2,1,1).ne.zero) h=h*a(n1+j+2*nbin)/sigu(2,1,1) *d purr.461,465 if (sigu(3,1,1).ne.zero) h=h*a(n1+j+3*nbin)/sigu(3,1,1) *d purr.468,472 if (sigu(4,1,1).ne.zero) h=h*a(n1+j+4*nbin)/sigu(4,1,1) *d purr.477 if (a(n1+j+nbin).ne.zero) a(l)=a(l)/a(n1+j+nbin) *ident up63 */ acer -- 15oct01 */ add a capability to include delayed neutron data in the ace */ file as allowed for mcnp4c. *d up57.10 common/ace9/mt16,mt455 *i up57.12 mt455=0 *i up57.14 if (mfd.eq.5.and.mtd.eq.455) mt455=1 *d up57.18 common/ace9/mt16,mt455 *d acer.2194 & (mf.eq.5.and.mt.gt.900)) then *d acer.4645 integer dndat,dnd,ptype,ploct *d acer.4658,4661 common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *i acer.4674 dimension dntc(6) *i acer.4680 data shake/1.d8/ *i acer.4684 data shake/1.e8/ *i acer.4743 nnud=0 *d acer.4754 if (mf.eq.1.and.mt.eq.455) kfis=2 *i acer.4869 if (mta.eq.455) then call listio(nin,0,0,a(iscr),nb,nw) nnf=n1h do i=1,nnf dntc(i)=a(iscr+5+i) enddo endif *i acer.4883 if (mta.eq.455) call reserv('nud',nw,inud,a) *i acer.4885 if (mta.eq.455) in=inud *i acer.4904 if (mta.eq.455) nnud=nw *d acer.4907,4908 if (mta.eq.452.and.kfis.eq.2) then mta=455 else if (mta.eq.455) then mta=456 else idone=1 endif *d acer.5474 c ***after energy distributions *i acer.5515 c c ***store delayed neutron data ndnf=0 if (nnud.gt.0.and.mt455.eq.0) write(nsyso, & '(/'' a delayed nubar section was found, but''/ & '' no delayed neutron spectra were found:''/ & '' delayed neutron data supressed'')') if (nnud.gt.0.and.mt455.eq.1) then write(nsyso,'(/'' adding delayed neutron data'')') nud=next l=next-1 c c ***fission delayed nubar data do i=1,nnud l=l+1 xss(l)=a(i-1+inud) enddo next=l+1 c ***locate the delayed neutron data in file 5 call findf(matd,5,455,nin) call contio(nin,0,0,a(iscr),nb,nw) ndnf=n1h c c ***dndat block dndat=next c c ***read through the section to load the dndat block lff=dndat do i=1,ndnf call tab1io(nin,0,0,a(iscr),nb,nw) law=l2h n=n2h c dndat entry xss(lff)=dntc(i)/shake xss(lff+1)=0 xss(lff+2)=n do j=1,n xss(lff+2+j)=sigfig(a(iscr+6+2*j)/emev,7,0) xss(lff+2+n+j)=sigfig(a(iscr+6+2*j+1),7,0) enddo lff=lff+3+2*n if (law.eq.1) then c law=1 call tab2io(nin,0,0,a(iscr),nb,nw) ne=n2h do ie=1,ne call tab1io(nin,0,0,a(iscr),b,nw) do while (nb.ne.0) call moreio(nin,0,0,a(iscr),nb,nw) enddo enddo else if (law.eq.5) then c law=5 call tab1io(nin,0,0,a(iscr),nb,nw) call tab1io(nin,0,0,a(iscr),nb,nw) do while (nb.ne.0) call moreio(nin,0,0,a(iscr),nb,nw) enddo endif enddo next=lff c c ***ldnd block ldnd=next next=ldnd+ndnf c c ***dnd block dnd=next c c ***go back to the start of the sections call repoz(nin,-2) call findf(matd,5,455,nin) call contio(nin,0,0,a(iscr),nb,nw) c c ***store the data do i=1,ndnf call tab1io(nin,0,0,a(iscr),nb,nw) law=l2h n=n2h c ldnd entry xss(ldnd-1+i)=next-dnd+1 c dnd data c there is only one law per family xss(next)=0 xss(next+1)=4 xss(next+2)=10 xss(next+3)=0 xss(next+4)=2 xss(next+5)=sigfig(xxmin/emev,7,0) xss(next+6)=sigfig(xxmax/emev,7,0) xss(next+7)=1 xss(next+8)=1 if (law.eq.1) then c law=1 call tab2io(nin,0,0,a(iscr),nb,nw) ne=n2h xss(next+9)=0 xss(next+10)=ne next=next+11 lxx=next next=next+2*ne do ie=1,ne call tab1io(nin,0,0,a(iscr),b,nw) nn=n1h mm=n2h iint=nint(a(iscr+7)) xss(lxx+ie-1)=c2h xss(lxx+ne+ie-1)=next-dnd+1 xss(next)=iint xss(next+1)=mm loc=iscr+nw do while (nb.ne.0) call moreio(nin,0,0,a(loc),nb,nw) loc=loc+nw enddo l=next+1 sumup=0 do j=1,mm xss(l+j)=sigfig(a(iscr+4+2*nn+2*j)/emev,7,0) xss(l+j+2+3*mm)= & sigfig(a(iscr+4+2*nn+2*j)/emev,7,0) xss(l+mm+j)=sigfig(a(iscr+4+2*nn+2*j+1)*emev,7,0) xss(l+mm+j+2+3*mm)= & sigfig(a(iscr+4+2*nn+2*j+1)*emev,7,0) xss(l+2*mm+j)=sigfig(sumup,9,0) xss(l+2*mm+j+2+3*mm)=sigfig(sumup,9,0) ll=iscr+4+2*nn+2*j if (j.lt.mm.and.iint.eq.1) then sumup=sumup+(a(ll+2)-a(ll))*a(ll+1) else if (j.lt.mm.and.iint.eq.2) then sumup=sumup+(a(ll+2)-a(ll))*(a(ll+3)+a(ll+1))/2 endif enddo next=next+2+3*mm enddo else if (law.eq.5) then c law=5 call tab1io(nin,0,0,a(iscr),nb,nw) xxmin=a(iscr+8) xxmax=a(iscr+10) call tab1io(nin,0,0,a(iscr),nb,nw) loc=iscr+nw do while (nb.ne.0) call moreio(nin,0,0,a(loc),nb,nw) loc=loc+nw enddo nn=n1h mm=n2h c there is no incident energy dependence, we represent c this by two energies with duplicated distributions xss(next+9)=0 xss(next+10)=2 xss(next+11)=sigfig(xxmin/emev,7,0) xss(next+12)=sigfig(xxmax/emev,7,0) xss(next+13)=next+15-dnd+1 xss(next+14)=next+15+2+3*mm-dnd+1 iint=nint(a(iscr+7)) xss(next+15)=iint xss(next+15+2+3*mm)=iint xss(next+16)=mm xss(next+16+2+3*mm)=mm l=next+16 sumup=0 do j=1,mm xss(l+j)=sigfig(a(iscr+4+2*nn+2*j)/emev,7,0) xss(l+j+2+3*mm)=sigfig(a(iscr+4+2*nn+2*j)/emev,7,0) xss(l+mm+j)=sigfig(a(iscr+4+2*nn+2*j+1)*emev,7,0) xss(l+mm+j+2+3*mm)= & sigfig(a(iscr+4+2*nn+2*j+1)*emev,7,0) xss(l+2*mm+j)=sigfig(sumup,9,0) xss(l+2*mm+j+2+3*mm)=sigfig(sumup,9,0) ll=iscr+4+2*nn+2*j if (j.lt.mm.and.iint.eq.1) then sumup=sumup+(a(ll+2)-a(ll))*a(ll+1) else if (j.lt.mm.and.iint.eq.2) then sumup=sumup+(a(ll+2)-a(ll))*(a(ll+3)+a(ll+1))/2 endif enddo next=next+15+2*(2+3*mm) endif enddo endif *d acer.7378,7381 integer dndat,dnd,ptype,ploct common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *d acer.8049,8053 integer dndat,dnd,ptype,ploct,hpd,tyrh,sigh,andh,dlwh,yh common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *d acer.9746 integer dndat,dnd,ptype,ploct *d acer.9750,9753 common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *d acer.9784,9797 & 6x,''* *'',9x,''ndnf'',i10/ & 6x,''* njoy *'',10x,''esz'',i10/ & 6x,''* *'',11x,''nu'',i10/ & 6x,''***********************'',10x,''mtr'',i10/ & 39x,''lqr'',i10/39x,''tyr'',i10/38x,''lsig'',i10/ & 39x,''sig'',i10/38x,''land'',i10//39x,''and'',i10/ & 38x,''ldlw'',i10/39x,''dlw'',i10/39x,''gpd'',i10/ & 38x,''mtrp'',i10/37x,''lsigp'',i10/38x,''sigp'',i10/ & 37x,''landp'',i10/38x,''andp'',i10/37x,''ldlwp'',i10/ & 38x,''dlwp'',i10/40x,''yp'',i10/39x,''fis'',i10/ & 39x,''end'',i10/37x,''iurpt'',i10/39x,''nud'',i10/ & 37x,''dndat'',i10/38x,''ldnd'',i10/39x,''dnd'',i10/ & 37x,''ptype'',i10/38x,''ntro'',i10/ & 37x,''ploct'',i10///6x,''hk---'',a70)') & hz,aw0,tz,hd,hm,nxs(1),(nxs(i),i=3,8), & (jxs(i),i=1,27),(jxs(i),i=30,32),hk *i acer.10147 c c ***print delayed neutron data if (nud.gt.0) then c c ***delayed nubar write(nsyso,'(''1''/'' delayed nubar data''/ & '' ------------------''/)') l=nud j=nint(xss(l)) write(nsyso,'(12x,''lnu = '',i3,25x,''tabular nu'')') j l=l+1 j=nint(xss(l)) write(nsyso,'(12x,''nr ='',i4)') j if (j.ne.0) then write(nsyso,'(12x,''nbt(i=1,nr) = '',20i5)') & (nint(xss(l+i)),i=1,j) l=l+j write(nsyso,'(12x,''int(i=1,nr) = '',20i5)') & (nint(xss(l+i)),i=1,j) l=l+j endif l=l+1 j=nint(xss(l)) write(nsyso,'(12x,''ne ='',i4)') j write(nsyso,'(12x,''e(i=1,ne) = '',1p,6e14.6/ & (12x,7e14.6))') & (xss(l+i),i=1,j) l=l+j write(nsyso,'(12x,''nu(i=1,ne) = '',1p,6e14.6/ & (12x,7e14.6))') & (xss(l+i),i=1,j) l=l+j c c ***precursor information write(nsyso,'(/'' precursor information''/ & '' ---------------------'')') l=dndat do i=1,ndnf write(nsyso,'(/6x,''decay constant'',i3,'' of'',i3, & '' (per shake) ='',1p,e13.5)') i,ndnf,xss(l) l=l+2 j=nint(xss(l)) write(nsyso,'(/6x,''delayed fraction'')') write(nsyso,'(12x,''ne ='',i4)') j write(nsyso,'(12x, & ''e(i=1,ne) = '',1p,6e14.6/(12x,7e14.6))') & (xss(l+ii),ii=1,j) l=l+j write(nsyso,'(12x, & ''p(i=1,ne) = '',1p,6e14.6/(12x,7e14.6))') & (xss(l+ii),ii=1,j) l=l+j+1 enddo c c ***precursor energy distributions write(nsyso,'(/ & '' delayed neutron energy distributions by precursor''/ & '' -------------------------------------------------'')') l=0 k=3 do i=1,ndnf nlaw=1 loct=nint(xss(i-1+ldnd)+dnd-1) law=nint(xss(loct+1)) if (law.eq.4) then l=l+1 if (l.gt.1) write(nsyso,'(/)') if (l.gt.1) k=1 write(nsyso,'(// & '' energy distribution for delayed neutrons from '', & ''precursor '',i3,'' of'',i3)') i,ndnf write(nsyso,'(/ & '' law ='',i2,i5,''st of'',i2,'' laws''/)') & law,nlaw,nlaw k=k+3 m=nint(xss(loct+3)) loct=loct+3 write(nsyso,'(8x,''probability of law'')') write(nsyso,'(12x,''nr ='',i4)') m if (m.ne.0) then write(nsyso,'(12x,''nbt(i=1,nr) = '',20i5)') & (nint(xss(j+loct)),j=1,m) write(nsyso,'(12x,''int(i=1,nr) = '',20i5)') & (nint(xss(j+m+loct)),j=1,m) k=k+4 loct=loct+2*m endif loct=loct+1 n=nint(xss(loct)) write(nsyso,'(12x,''ne ='',i4)') n write(nsyso,'(12x,''e(i=1,ne) = '',1p,6e14.6 & /(12x,7e14.6))') (xss(j+loct),j=1,n) write(nsyso,'(12x,''p(i=1,ne) = '',1p,6e14.6 & /(12x,7e14.6))') (xss(j+n+loct),j=1,n) k=k+3 loct=loct+1+2*n write(nsyso,'(/)') write(nsyso,'(8x,''data for law'')') k=k+2 m=nint(xss(loct)) write(nsyso,'(12x,''nr ='',i4)') m if (m.ne.0) then k=k+4 write(nsyso,'(12x,''nbt(i=1,nr) = '',20i5)') & (nint(xss(j+loct)),j=1,m) write(nsyso,'(12x,''int(i=1,nr) = '',20i5)') & (nint(xss(j+m+loct)),j=1,m) loct=loct+2*m endif loct=loct+1 ne=nint(xss(loct)) write(nsyso,'(12x,''ne ='',i4)') ne if (m.eq.0) k=k+1 do ie=1,ne eg=xss(ie+loct) loci=nint(xss(ie+ne+loct))+dnd-1 intt=nint(xss(loci)) n=nint(xss(loci+1)) loci=loci+1 if (ie.ne.1.and.k+6+n.ge.57) then write(nsyso,'(/)') k=1 endif write(nsyso,'(/6x,'' incident energy = '',1p,e14.6, & '' intt ='',i2,'' np ='',i3// & 1x, & 2('' energy pdf cdf'')/ & 1x, & 2('' ------------ ------------ ------------'')/ & (1x,1p,6e14.6))') & eg,intt,n,(xss(j+loci),xss(j+n+loci), & xss(j+2*n+loci),j=1,n) k=k+n+6 enddo endif enddo endif *i acer.10197 integer dndat,dnd,ptype,ploct *d acer.10198,10201 common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *d acer.10671,10674 integer dndat,dnd,ptype,ploct common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *d acer.11063 integer dndat,dnd,ptype,ploct,hpd,tyrh,sigh,andh,dlwh,yh *d acer.11064,11067 common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *i acer.11579 integer dndat,dnd,ptype,ploct *d acer.11583,11587 common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *d acer.11685,11688 integer dndat,dnd,ptype,ploct common/nxst/len2,izaid,nes,ntr,nrx,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *i acer.12303 c c ***delayed neutron block if (ndnf.ne.0) then c delayed nubar l=nud if (nout.ne.1) lnu=nint(xss(l)) if (nout.eq.1) lnu=iss(l) call typen(l,nout,1) l=l+1 if (nout.ne.1) nr=nint(xss(l)) if (nout.eq.1) nr=iss(l) call typen(l,nout,1) l=l+1 if (nr.ne.0) then n=2*nr do j=1,n call typen(l,nout,1) l=l+1 enddo endif if (nout.ne.1) ne=nint(xss(l)) if (nout.eq.1) ne=iss(l) call typen(l,nout,1) l=l+1 n=2*ne do j=1,n call typen(l,nout,2) l=l+1 enddo c precursor data l=dndat do i=1,ndnf call typen(l,nout,2) l=l+1 if (nout.ne.1) nr=nint(xss(l)) if (nout.eq.1) nr=iss(l) call typen(l,nout,1) l=l+1 if (nr.ne.0) then n=2*nr do j=1,n call typen(l,nout,1) l=l+1 enddo endif if (nout.ne.1) ne=nint(xss(l)) if (nout.eq.1) ne=iss(l) call typen(l,nout,1) l=l+1 n=2*ne do j=1,n call typen(l,nout,2) l=l+1 enddo enddo c precursor energy distribution locators do i=1,ndnf call typen(l,nout,1) l=l+1 enddo c precursor energy distributions do i=1,ndnf call typen(l,nout,1) l=l+1 call typen(l,nout,1) l=l+1 call typen(l,nout,1) l=l+1 if (nout.ne.1) nr=nint(xss(l)) if (nout.eq.1) nr=iss(l) call typen(l,nout,1) l=l+1 if (nr.ne.0) then n=2*nr do j=1,n call typen(l,nout,1) l=l+1 enddo endif if (nout.ne.1) ne=nint(xss(l)) if (nout.eq.1) ne=iss(l) call typen(l,nout,1) l=l+1 n=2*ne do j=1,n call typen(l,nout,2) l=l+1 enddo c law=4 data if (nout.ne.1) nr=nint(xss(l)) if (nout.eq.1) nr=iss(l) call typen(l,nout,1) l=l+1 if (nr.gt.0) then n=2*nr do j=1,n call typen(l,nout,1) l=l+1 enddo endif if (nout.ne.1) ne=nint(xss(l)) if (nout.eq.1) ne=iss(l) call typen(l,nout,1) l=l+1 do j=1,ne call typen(l,nout,2) l=l+1 enddo do j=1,ne call typen(l,nout,1) l=l+1 enddo do j=1,ne call typen(l,nout,1) l=l+1 if (nout.ne.1) np=nint(xss(l)) if (nout.eq.1) np=iss(l) call typen(l,nout,1) l=l+1 n=3*np do k=1,n call typen(l,nout,2) l=l+1 enddo enddo enddo endif *ident up64 */ acer -- 07dec01 */ there was a mistake introduced with up57 that only affects */ 64-bit compiles (when "*set sw" is not used). In addition, there */ were three mistakes related to the delayed neutron patch of up63. */ it's bad practice to use different names in common blocks in */ different places! *d up56.16,17 *i acer.2135 zero=0 one=1 *d up63.255 common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntyph,ndnf,nxsd(8) *d up63.430 common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntyph,ndnf,nxsd(8) *i up63.440 common/ace7/awi,izai,mcnpx,newfor *ident up65 */ groupr -- 10dec01 */ fix groupr to handle radionuclide production using the new */ endf file 8 and data from eaf2001. *d groupr.501,502 if (mfd.gt.36.and.mfd.lt.10000000) go to 381 *d groupr.516 if (mfd.gt.10000000) izam=mod(mfd,10000000) *d groupr.525 if (mfd.le.10000000) go to 405 *d groupr.621,622 if (mfd.lt.1000000) then write(nsyso,'('' for mf'',i3,'' and mt'',i3,1x,15a4)') & mfd,mtd,(mtname(i),i=1,15) else mfdn=mfd/10000000 jzam=mod(mfd,10000000) if (mfdn.eq.1) then write(nsyso, & '('' for mf3 mt'',i3,'' zam'',i8,1x,15a4)') & mtd,jzam,(mtname(i),i=1,15) else if (mfdn.eq.2) then write(nsyso, & '('' for mf3*mf6 mt'',i3,'' zam'',i8,1x,15a4)') & mtd,jzam,(mtname(i),i=1,15) else if (mfdn.eq.3) then write(nsyso, & '('' for mf3*mf9 mt'',i3,'' zam'',i8,1x,15a4)') & mtd,jzam,(mtname(i),i=1,15) else if (mfdn.eq.4) then write(nsyso, & '('' for mf10 mt'',i3,'' zam'',i8,1x,15a4)') & mtd,jzam,(mtname(i),i=1,15) endif endif *i groupr.633 if (mfd.gt.10000000) mfh=3 *i groupr.657 if (mfd.gt.10000000) mfh=3 *d groupr.910 mfd=mf10i(ir) *d groupr.1163 else if (mfd.gt.10000000) then *d groupr.3123 if (mfd.ne.3.and.mfd.ne.8.and.mfd.ne.18.and.mfd.lt.10000000) then *d groupr.3857 if (mft.eq.9.or.mft.eq.10) lfn=nint(a(iyld+3)) if (mft.eq.6) lfn=nint(a(iyld+2)) *d groupr.3862,3871 call skip6(itape,0,0,a(loc),law) *d groupr.3859 if (mft.gt.6.and.izn.eq.0.and.lfs.eq.lfn) go to 180 *d groupr.3975,3982 if (mf.eq.10) then nfs=n1h jfs=-1 do i=1,nfs call tab1io(nsig,0,0,a(isig),nb,nw) if (l2h.eq.lfs) jfs=i do while (nb.ne.0) call moreio(nsig,0,0,a(isig),nb,nw) enddo enddo if (jfs.lt.0) call error('getsig', & 'desired lfs not found',' ') nskip=jfs-1 call skiprz(nsig,-1) call findf(matd,mf,mt,nsig) call contio(nsig,0,0,a(isig),nb,nw) if (nskip.gt.0) then do i=1,nskip call tab1io(nsig,0,0,a(isig),nb,nw) do while (nb.ne.0) call moreio(nsig,0,0,a(isig),nb,nw) enddo enddo endif *d groupr.4345 if (mfd.eq.12.or.(mfd.gt.20000000.and.mfd.lt.40000000)) *ident up66 */ groupr -- 12feb02 */ if you mix automatic reactions with manual reactions where */ the mtname string is not given, the mtname on the manual */ reaction will have whatever string was left from the previous */ case. we fix that here. *d groupr.507 */ groupr -- 13feb02 */ there is an error in the calculation of the kalbach a factor */ for the photonuclear case. it is necessary to convert e to */ mev for this formula. the symptom is results for a that are */ so large that sinh(a) overflows with a floating point error. *d groupr.5980 bb=bb*sqrt((tomev*e)/(2*emc2))*fact *ident up67 */ matxsr -- 12feb02 */ add photonuclear capability *i matxsr.30 c * ngen8 photonuclear data from groupr (default=0) * *d matxsr.210 cd gscat gamma scattering (atomic) - cd gg gamma scattering (photonuclear) - *d matxsr.392 & nscrt5,nscrt6,nscrt7,ngen3,ngen4,ngen5,ngen6,ngen7,ngen8 *d matxsr.422 ngen8=0 read(nsysi,*) & ngen1,ngen2,nmatx,ngen3,ngen4,ngen5,ngen6,ngen7,ngen8 *d matxsr.433,434 & '' incident alpha unit .................. '',i10/ & '' photonuclear unit .................... '',i10)') & ngen3,ngen4,ngen5,ngen6,ngen7,ngen8 *d matxsr.441 nscrt8=17 *i matxsr.448 call openz(ngen8,0) *i matxsr.475 call closz(ngen8) *d matxsr.495 & nscrt5,nscrt6,nscrt7,ngen3,ngen4,ngen5,ngen6,ngen7,ngen8 *d matxsr.892 & nscrt5,nscrt6,nscrt7,ngen3,ngen4,ngen5,ngen6,ngen7,ngen8 *i matxsr.909 character*8 hgg *d matxsr.917 data hgsct/'gscat '/, hgg/'gg '/, hnthr/'ntherm'/ *i matxsr.945 if (nin.eq.0) nin=ngen8 *d matxsr.1012 if (hprt(ip1).eq.hgm) nin=ngen8 if (hprt(ip1).eq.hgm.and.htyp.eq.hgsct) nin=ngen2 *d matxsr.1027,1028 if (hprt(ip2).eq.hgm.and.htyp.ne.hgg) mfv=13 if (hprt(ip1).eq.hgm.and.htyp.eq.hgsct) mfv=23 *i matxsr.1035 if (hprt(ip2).eq.hgm.and.htyp.eq.hgg) mfm=16 *d matxsr.1478 & nscrt5,nscrt6,nscrt7,ngen3,ngen4,ngen5,ngen6,ngen7,ngen8 *d matxsr.1809 & nscrt5,nscrt6,nscrt7,ngen3,ngen4,ngen5,ngen6,ngen7,ngen8 *ident up68 */ reconr -- 18apr02 */ the name "pi" is being used for both the imaginary part of */ p and the pi constant. the former is changed to "pim" as */ used in the version of this subroutine in purr. the symptom */ is a floating point error when sqrt(pi) is calculated with */ pi changed to a negative value. *d reconr.4868 pim=aimw *d reconr.4873 if (abs(aimw-pim).ge.eps) go to 380 *d reconr.4908 pim=aimw *d reconr.4912 if (abs(aimw-pim).ge.eps) go to 470 */ allow for more digits in the temperature printout to */ handle the usage of reconr being made for eaf-2001. the */ temperature field is not being used for resonance */ reconstruction but only passed to the output file for */ later use. *d reconr.348 & '' reconstruction temperature ........... '',f10.2,''k''/ *ident up69 */ acer -- 07dec01 */ add a capability to generate fluorescence data for mcnp using */ the existing cashwell-everett format with new numbers obtained */ from the endf versions of eadl and epdl. the data produced with */ this method should give reasonable results for transport and */ heating for energies above 1 kev. the new evaluations allow */ for lower incident photon energies and for more detail in photon */ and electron distributions from photoabsorption, and future */ versions of njoy and mcnp can take advantage of this. *d acer.66 c * data. the input photoatomic data is mounted on nendf. * c * fluorescence data can be generated from atomic relaxation * c * data in endf format mounted on npend. * *i acer.186 c * photoatomic data on nendf * c * atomic relaxation data on npend * *d acer.428 call acepho(nendf,npend) *d acer.14651 subroutine acepho(nin,nlax) *d acer.14690 data emax/1.01d11/ *d acer.14702 data emax/1.01e11/ *i acer.14780 c c ***set number of fluorescence lines iz=matd/100 if (iz.lt.12) then nflo=0 else if (iz.lt.20) then nflo=2 else if (iz.lt.31) then nflo=4 else if (iz.lt.37) then nflo=5 else nflo=6 endif *d acer.14786 lhnm=jflo+4*nflo *d acer.14843 c ***for fluorescence photons *d acer.14845,14846 if (nlax.eq.0) then call mess('acepho','no atomic relaxation data', & 'fluorescence data not processed') else if (nflo.gt.0) then call alax(nin,nlax,xss(jflo),a(iscr)) endif *i acer.14997 c subroutine alax(nin,nlax,fluor,a) c ****************************************************************** c generate fluorescence data in the cashwell-everett format. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/mainio/nsysi,nsyso,nsyse,ntty common/ace1/tempd,err,matd,nbina,nbinp,negn,iprint,iopt,ndigit dimension fluor(*) dimension a(*) dimension loc(50) dimension enl(3),rhol(3),wtl(3) *if sw data dn/.9999d0/ data up/1.0001d0/ data emev/1.d6/ *else data dn/.9999e0/ data up/1.0001e0/ data emev/1.e6/ *endif c c ***charge for desired material iz=matd/100 c c ***read in the atomic relaxation file for the desired material call openz(nlax,0) call tpidio(nlax,0,0,a,nw,nb) 110 call contio(nlax,0,0,a,nw,nb) if (math.gt.0) go to 120 call error('alax','mat not found',' ') 120 if (math.eq.matd) go to 130 call tomend(nlax,0,0,a) go to 110 130 call tofend(nlax,0,0,a) call contio(nlax,0,0,a,nw,nb) nss=n1h ll=1 do iss=1,nss loc(iss)=ll call listio(nlax,0,0,a(ll),nb,nw) ntr=n2h ll=ll+nw do while (nb.ne.0) call moreio(nlax,0,0,a(ll),nb,nw) ll=ll+nw enddo enddo c c ***read in the photoionization cross section for the material kk=ll call openz(nin,0) call tpidio(nin,0,0,a(ll),nw,b) 210 call contio(nin,0,0,a(ll),nw,b) if (math.gt.0) go to 220 call error('spect','mat not found',' ') 220 if (math.eq.matd) go to 230 call tomend(nin,0,0,a(ll)) go to 210 230 call tofend(nin,0,0,a(ll)) call findf(matd,23,522,nin) call contio(nin,0,0,a(ll),nw,nb) e=0 call gety1(e,en,idis,sig,nin,a(ll)) c c ***for z>30, get the l1, l2, and l3 edges and jumps if (iz.gt.30) then do i=1,3 jj=loc(5-i) enl(4-i)=a(jj+6) e=dn*enl(4-i) call gety1(e,en,idis,slo,nin,a(ll)) e=up*enl(4-i) call gety1(e,en,idis,shi,nin,a(ll)) rhol(4-i)=slo/shi enddo endif c c ***get the energy and jump of the k edge ek=a(7) e=dn*ek call gety1(e,en,idis,slo,nin,a(ll)) e=up*ek call gety1(e,en,idis,shi,nin,a(ll)) rhok=slo/shi c c ***case of 1119 and z<31 else if (iz.gt.19.and.iz.lt.31) then c c ***extract l2, l3, and total for higher shells n=nint(a(6)) sum1=0 sum2=0 do i=1,n jj=8+6*i if (nint(a(jj)).eq.0.and.nint(a(jj-1)).eq.3) then el2=a(jj+1) pl2=a(jj+2) else if (nint(a(jj)).eq.0.and.nint(a(jj-1)).eq.4) then el3=a(jj+1) pl3=a(jj+2) else if (nint(a(jj)).eq.0.and.nint(a(jj-1)).gt.4) then sum1=sum1+a(jj+2) sum2=sum2+a(jj+1)*a(jj+2) endif enddo sum2=sum2/sum1 c c ***store the results tot=(pl2+pl3+sum1)/(1-rhok) y=0 phi=rhok fluor(1)=ek/emev fluor(5)=phi fluor(9)=y fluor(13)=0 phi=phi+pl3/tot y=y+(1-rhok)*pl3 fluor(2)=ek/emev fluor(6)=phi fluor(10)=y fluor(14)=el3/emev phi=phi+pl2/tot y=y+(1-rhok)*pl2 fluor(3)=ek/emev fluor(7)=phi fluor(11)=y fluor(15)=el2/emev phi=1 y=y+(1-rhok)*sum1 fluor(4)=ek/emev fluor(8)=phi fluor(12)=y fluor(16)=sum2/emev c c ***all other z values else rholt=rhol(1)*rhol(2)*rhol(3) elav=(enl(1)+enl(2)+enl(3))/3 wtl(1)=1/rhol(1) wtl(2)=wtl(1)/rhol(2) wtl(3)=wtl(2)/rhol(3) denom=wtl(3)-1 wtl(3)=(wtl(3)-wtl(2))/denom wtl(2)=(wtl(2)-wtl(1))/denom wtl(1)=(wtl(1)-1)/denom c c ***compute the average yield and energy for l fluorescence sum1=0 sum2=0 do iss=2,4 jj=loc(iss) n=nint(a(jj+5)) wt=wtl(iss-1) do i=1,n if (nint(a(jj+7+6*i)).eq.0) then sum1=sum1+a(jj+9+6*i)*wt sum2=sum2+a(jj+8+6*i)*a(jj+9+6*i)*wt endif enddo enddo sum2=sum2/sum1 ylt=sum1 flt=sum2 if (flt.gt.enl(1)) then write(nsyso,'('' L edge problem'')') write(nsyso,'(1x,3f10.4)') flt,enl(1),elav endif c c ***extract kalpha1, kalpha2, kbeta1, and kbeta2 n=nint(a(6)) sum11=0 sum12=0 sum21=0 sum22=0 do i=1,n jj=8+6*i if (nint(a(jj)).eq.0) then mm=nint(a(jj-1)) if (mm.eq.3) then el2=a(jj+1) pl2=a(jj+2) else if (mm.eq.4) then el3=a(jj+1) pl3=a(jj+2) else if (mm.ge.5.and.mm.le.9) then sum11=sum11+a(jj+2) sum12=sum12+a(jj+1)*a(jj+2) else if (mm.ge.10.and.mm.le.16) then sum21=sum21+a(jj+2) sum22=sum22+a(jj+1)*a(jj+2) endif endif enddo if (iz.ge.37) then sum22=sum22/sum21 else sum11=sum11+sum21 sum12=sum12+sum22 sum21=0 endif sum12=sum12/sum11 c c ***store the results n=5 if (iz.gt.36) n=6 fluor(1)=elav/emev fluor(1+n)=rholt fluor(1+2*n)=0 fluor(1+3*n)=0 y=(1-rholt)*ylt fluor(2)=elav/emev fluor(2+n)=1 fluor(2+2*n)=y fluor(2+3*n)=flt/emev phi=1/rhok phik=phi-1 tot=(pl2+pl3+sum11+sum21)/phik phi=1 phi=phi+pl3/tot y=y+phik*pl3 fluor(3)=ek/emev fluor(3+n)=phi fluor(3+2*n)=y fluor(3+3*n)=el3/emev phi=phi+pl2/tot y=y+phik*pl2 fluor(4)=ek/emev fluor(4+n)=phi fluor(4+2*n)=y fluor(4+3*n)=el2/emev phi=phi+sum11/tot y=y+phik*sum11 fluor(5)=ek/emev fluor(5+n)=phi fluor(5+2*n)=y fluor(5+3*n)=sum12/emev if (iz.ge.37) then phi=phi+sum21/tot y=y+phik*sum21 fluor(6)=ek/emev fluor(6+n)=phi fluor(6+2*n)=y fluor(6+3*n)=sum22/emev endif c endif return end *i acer.15088 c c ***print the fluorescence data if (nflo.gt.0) then write(nsyso,'(// & '' fluorescence data''/ & '' -----------------'')') write(nsyso,'(/ & '' edge phi y f''/ & '' ---------- ------- ------- ---------'')') do i=1,nflo write(nsyso,'(3x,f11.7,f10.4,f10.4,2x,f10.6)') & (xss(jflo+i-1+nflo*(j-1)),j=1,4) enddo endif *i acer.15147 c c ***fluorescence data block l=jflo if (nflo.ne.0) then do i=1,4*nflo call typen(l,nout,2) l=l+1 enddo endif *ident up70 */ acer -- 20feb02 */ add consistency checks for delayed neutrons */ add plots for nubar and delayed neutron spectra *d acer.17720 integer dndat,dnd,ptype,ploct,hpd,sigh,dlwh *d acer.17723 common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntyph,ndnf,nxsd(8) *d acer.17726 & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct *i acer.18202 c c ***check delayed neutron data if (ndnf.gt.0) then write(nsyso,'(/'' check delayed neutron fractions'')') l=dndat sum=0 do j=1,ndnf l=l+2 nn=nint(xss(l)) l=l+nn frac=xss(l+1) sum=sum+frac l=l+nn+1 enddo if (abs(sum-1)*1000.gt.one) then write(nsyso,'('' consis: delayed fractions do not'', & '' sum to one'')') nerr=nerr+1 endif write(nsyso,'(/'' check delayed neutron distributions'')') do i=1,ndnf nlaw=1 loct=nint(xss(i-1+ldnd)+dnd-1) law=nint(xss(loct+1)) m=nint(xss(loct+3)) loct=loct+3+2*m loct=loct+1 n=nint(xss(loct)) loct=loct+1+2*n m=nint(xss(loct)) loct=loct+2*m loct=loct+1 ne=nint(xss(loct)) loci=nint(xss(1+ne+loct))+dnd-1 intt=nint(xss(loci)) n=nint(xss(loci+1)) loci=loci+1 do j=1,n x=xss(j+loci) y=xss(j+loci+n) c=xss(j+loci+2*n) if (j.gt.1) then if (x.lt.xlast) then write(nsyso,'('' consis: delayed spectrum'', & '' energies not monotonic'')') nerr=nerr+1 endif if (c.lt.clast) then write(nsyso,'('' consis: delayed spectrum'', & '' cummulative probs not monotonic'')') nerr=nerr+1 endif endif xlast=x clast=c enddo enddo endif *d acer.18530 common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntyph,ndnf,nxsd(8) *i acer.19514 c c ***plot nubar if (nu.gt.0) call aplonu(nout,iwcol) *i acer.19517 c c ***plot delayed-neutron data if (ndnf.gt.0) call aplodn(nout,iwcol) *i acer.20148 c subroutine aplonu(nout,iwcol) c ****************************************************************** c plot the total fission nubar curve c ****************************************************************** *if sw implicit real*8 (a-h,o-z) *endif integer esz,sig,and,tyr,dlw,gpd,fis,sigp,andp,dlwp,yp,end common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,nxsd(9) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end,jxsd(10) character hz*13,hd*10,hk*70,hm*10 common/mis1/hz,hd,hk,hm common/xsst/xss(3000000),n3 common/ace7/awi,izai,mcnpx,newfor character*1 qu character*10 name data qu/''''/ *if sw data big/1.d10/ data small/1.d-12/ data ten/10.d0/ data step/0.2d0/ *else data big/1.e10/ data ten/10.e0/ data small/1.e-12/ data step/0.2e0/ *endif zero=0 one=1 c c ***set up the page for the total nubar curve xmin=big xmax=0 ymin=big ymax=-big l=nu j=nint(xss(l)) kf=j if (kf.lt.0) then l=l+iabs(kf)+1 j=nint(xss(l)) endif if (j.ne.2) then e=xss(esz) emax=xss(esz+nes-1) l=l+1 n=nint(xss(l)) ymin=xss(l+1) ymax=ymin do i=2,n ymax=ymax+xss(l+i)*e**(i-1) enddo else l=l+1 nr=nint(xss(l)) if (nr.gt.0) l=l+2*nr l=l+1 ne=nint(xss(l)) do i=1,ne x=xss(l+i) y=xss(l+i+ne) if (x.lt.xmin) xmin=x if (x.gt.xmax) xmax=x if (y.lt.ymin) ymin=y if (y.gt.ymax) ymax=y enddo endif call ascle(4,ymin,ymax,major,minor) ystep=(ymax-ymin)/major xstep=(xmax-xmin)/4 write(nout,'(''1'',i3,''/'')') iwcol it=1 do i=1,70 if (hk(i:i).ne.' ') it=i enddo write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''otal fission nubar'',a,''/'')') qu,qu write(nout,'(''1 0 2/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,xstep write(nout,'(a,''nergy (e)'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,ystep write(nout,'(a,''ission nubar'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''/'')') write(nout,'(''0/'')') l=nu j=nint(xss(l)) kf=j if (kf.lt.0) then l=l+iabs(kf)+1 j=nint(xss(l)) endif if (j.ne.2) then e=xss(esz) emax=xss(esz+nes-1) l=l+1 n=nint(xss(l)) do while (e.lt.emax) sum=xss(l+1) do i=2,n sum=sum+xss(l+i)*e**(i-1) enddo write(nout,'(1p,2e14.6,''/'')') e,sum e=e+step enddo else l=l+1 nr=nint(xss(l)) if (nr.gt.0) l=l+2*nr l=l+1 ne=nint(xss(l)) do i=1,ne x=xss(l+i) y=xss(l+i+ne) write(nout,'(1p,2e14.6,''/'')') x,y enddo endif write(nout,'(''/'')') return end *i acer.20593 c subroutine aplodn(nout,iwcol) c ****************************************************************** c plot the delayed-neutron data c ****************************************************************** *if sw implicit real*8 (a-h,o-z) *endif integer esz,sig,and,tyr,dlw,gpd,fis,sigp,andp,dlwp,yp,end integer dndat,dnd,ptype,ploct common/nxst/len2,izaid,nes,ntr,nr,ntrp,ntype,ndnf,nxsd(8) common/jxst/esz,nu,mtr,lqr,tyr,lsig,sig,land,and,ldlw,dlw, & gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, & iurpt,nud,dndat,ldnd,dnd,jxsd(2),ptype,ntro,ploct character hz*13,hd*10,hk*70,hm*10 common/mis1/hz,hd,hk,hm common/xsst/xss(3000000),n3 common/ace7/awi,izai,mcnpx,newfor character*1 qu character*10 name external ascll,ascle data qu/''''/ *if sw data big/1.d10/ data small/1.d-12/ data ten/10.d0/ data step/1.2d0/ data scale/1.d2/ *else data big/1.e10/ data ten/10.e0/ data small/1.e-12/ data step/1.2e0/ data scale/1.e2/ *endif zero=0 one=1 c c ***set up the page for the delayed nubar curve xmin=big xmax=0 ymin=big ymax=-big l=nud j=nint(xss(l)) l=l+1 nr=nint(xss(l)) if (nr.gt.0) l=l+2*nr l=l+1 ne=nint(xss(l)) do i=1,ne x=xss(l+i) y=xss(l+i+ne) if (x.lt.xmin) xmin=x if (x.gt.xmax) xmax=x if (y.lt.ymin) ymin=y if (y.gt.ymax) ymax=y enddo ymin=ymin/step ymax=ymax*step call ascle(4,ymin,ymax,major,minor) ystep=(ymax-ymin)/major xstep=(xmax-xmin)/4 write(nout,'(''1'',i3,''/'')') iwcol it=1 do i=1,70 if (hk(i:i).ne.' ') it=i enddo write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''elayed nubar'',a,''/'')') qu,qu write(nout,'(''1 0 2/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,xstep write(nout,'(a,''nergy (e)'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,ystep write(nout,'(a,''elayed nubar'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''/'')') write(nout,'(''0/'')') l=nud j=nint(xss(l)) l=l+1 nr=nint(xss(l)) if (nr.gt.0) l=l+2*nr l=l+1 ne=nint(xss(l)) do i=1,ne x=xss(l+i) y=xss(l+i+ne) write(nout,'(1p,2e14.6,''/'')') x,y enddo write(nout,'(''/'')') c c ***set up the page for the delayed spectra curves xmin=big xmax=0 ymin=big ymax=-big do i=1,ndnf nlaw=1 loct=nint(xss(i-1+ldnd)+dnd-1) law=nint(xss(loct+1)) m=nint(xss(loct+3)) loct=loct+3+2*m loct=loct+1 n=nint(xss(loct)) loct=loct+1+2*n m=nint(xss(loct)) loct=loct+2*m loct=loct+1 ne=nint(xss(loct)) loci=nint(xss(1+ne+loct))+dnd-1 intt=nint(xss(loci)) n=nint(xss(loci+1)) loci=loci+1 l=dndat do j=1,ndnf if (j.eq.i) decay=xss(l) l=l+2 nn=nint(xss(l)) l=l+nn if (j.eq.i) frac=xss(l+1) l=l+nn+1 enddo do j=1,n x=xss(j+loci) if (x.eq.zero) x=xss(j+1+loci)/10 y=frac*xss(j+loci+n) if (x.lt.xmin) xmin=x if (x.gt.xmax) xmax=x if (y.lt.ymin) ymin=y if (y.gt.ymax) ymax=y enddo enddo call ascll(xmin,xmax) if (ymin.lt.ymax/scale) ymin=ymax/scale call ascll(ymin,ymax) write(nout,'(''1'',i3,''/'')') iwcol it=1 do i=1,70 if (hk(i:i).ne.' ') it=i enddo write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''elayed neutron spectra'',a,''/'')') qu,qu xtag=step*xmin ytag=ymax/30 write(nout,'(''4 0 2 1'',2e12.4,''/'')') xtag,ytag write(nout,'(1p,3e12.3,''/'')') xmin,xmax,one write(nout,'(a,''nergy (e)'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,one write(nout,'(a,''

robability'',a,''/'')') qu,qu write(nout,'(''/'')') do i=1,ndnf if (i.gt.1) then write(nout,'(i2,''/'')') i write(nout,'(''/'')') endif if (iwcol.eq.0) then write(nout,'(''0 0'',i2,''/'')') i else write(nout,'(''0 0 0'',i2,''/'')') i endif l=dndat do j=1,ndnf if (j.eq.i) decay=xss(l) l=l+2 n=nint(xss(l)) l=l+n if (j.eq.i) frac=xss(l+1) l=l+n+1 enddo write(nout,'(a,''group'',i2,'' frac'',f7.4,'' decay/shake'', & 1p,e10.3,a,''/'')') qu,i,frac,decay,qu write(nout,'(''0/'')') loct=nint(xss(i-1+ldnd)+dnd-1) law=nint(xss(loct+1)) m=nint(xss(loct+3)) loct=loct+3+2*m loct=loct+1 n=nint(xss(loct)) loct=loct+1+2*n m=nint(xss(loct)) loct=loct+2*m loct=loct+1 ne=nint(xss(loct)) loci=nint(xss(1+ne+loct))+dnd-1 intt=nint(xss(loci)) n=nint(xss(loci+1)) loci=loci+1 m=n if (intt.eq.1) m=m-1 do j=1,m x=xss(j+loci) if (x.eq.zero) x=xss(j+1+loci)/10 y=frac*xss(j+loci+n) if (y.lt.ymin) y=ymin write(nout,'(1p,2e14.6,''/'')') x,y if (intt.eq.1) then x=xss(j+1+loci) y=frac*xss(j+loci+n) if (y.lt.ymin) y=ymin write(nout,'(1p,2e14.6,''/'')') x,y endif enddo write(nout,'(''/'')') enddo return end *ident up71 */ reconr -- 25aug02 */ if the cross section or yield in a section is zero at all */ energies, the union grid is spoiled. we fix lunion so the */ so called pseudo-threshold search cannot go past one less */ than the number of points in the section. this problem was */ seen in n-15 of jendl-3.3 for 12/104 and 12/105. *i reconr.1742 npr=nint(a(iscr+5)) *d reconr.1764 if (sr.lt.ssmall.and.srnext.lt.ssmall.and.ir.lt.npr-1) go to 205 *ident up72 */ acer -- 3sep02 */ allow for up to 8 groups of delayed neutrons as used in some */ of the materials in jeff-3. *d up63.23 dimension dntc(8) */ there were some small problems with the use of endf law=1 in */ addition to the more common law=5. we also have to be sure to */ renormalize distributions that don't have the proper normalization. *i up63.136 xxmin=a(iscr+8) xxmax=a(iscr+10) *d up63.164 xss(lxx+ie-1)=sigfig(c2h/emev,7,0) *d up63.177,178 *d up63.180,181 *d up63.183 *i up63.190 if (10000000*abs(sumup-1).gt.1) then write(nsyso,'( & '' renormalizing delayed spectrum:'', & '' precursor'',i2,'' e='',f5.2, & '' norm='',f8.6)') i,xss(lxx+ie-1),sumup do j=1,mm xss(l+mm+j)=sigfig(xss(l+mm+j)/sumup,7,0) xss(l+2*mm+j)=sigfig(xss(l+2*mm+j)/sumup,9,0) enddo endif *d up63.196,197 *i up63.235 if (10000000*abs(sumup-1).gt.1) then write(nsyso,'( & '' renormalizing delayed spectrum:'', & '' precursor'',i2,'' e='',f5.2, & '' norm='',f8.6)') i,xss(lxx+ie-1),sumup do j=1,mm xss(l+mm+j)=sigfig(xss(l+mm+j)/sumup,7,0) xss(l+mm+j+2+3*mm)= & sigfig(xss(l+mm+j+2+3*mm)/sumup,7,0) xss(l+2*mm+j)=sigfig(xss(l+2*mm+j)/sumup,9,0) xss(l+2*mm+j+2+3*mm)= & sigfig(xss(l+2*mm+j+2+3*mm)/sumup,9,0) enddo endif */ watch for a special case in plotting *d acer.21528 *d up59.8 i1=1 if (ne.gt.2) then i1=2 if (ymax.gt.test*xss(l3+2+ne-2)) ymax=xss(l3+2+ne-2) endif do ie=i1,ne *ident up73 */ groupr -- 3sep02 */ allow for up to 8 groups of delayed neutrons as used in some */ materials of jeff-3. *d groupr.240 common/delayg/ndelg common/delayn/dntc(8) *d groupr.567 do i=1,ndelg *d groupr.570,571 nll=ndelg l=ians+ndelg *i groupr.3071 common/delayg/ndelg *d groupr.3100 if (mfd.eq.5.and.mtd.eq.455) nl=ndelg *d groupr.3391 common/delayn/dntc(8) *d groupr.3802 common/delayn/dntc(8) *d groupr.3842 if (lnd.gt.8) call error('getyld','illegal lnd.',' ') *i groupr.4272 common/delayg/ndelg *d groupr.4386 if (mtd.eq.455) nk=ndelg *i groupr.7934 common/delayg/ndelg *i groupr.7955 ndelg=0 *i groupr.8380 if (mth.eq.455) then call listio(nin,nout,nscr,a(iscr),nb,nw) ndelg=n1h endif *ident up74 */ groupr -- 03sep02 */ fix editing error in the lwr epri weight function. */ reported by skip kahler (bechtel bettis). *d groupr.2171 & 1.407d7,1.154d-6,1.42d7,1.087d-6,1.43d7,9.5757d-7,1.44d7, *d groupr.2234 & 1.407e7,1.154e-6,1.42e7,1.087e-6,1.43e7,9.5757e-7,1.44e7, */ fix an incorrect boolean statement in the removal of upscatter */ in subroutine getsed. reported by kazuaki (sae, japan). *d groupr.8914 if (mtd.lt.18.or.(mtd.gt.21.and.mtd.ne.38)) then *ident up75 */ acer -- 09oct02 */ fix some typographical errors in recent updates *d up63.104 call tab1io(nin,0,0,a(iscr),nb,nw) *d up63.128 call skiprz(nin,-2) *d up63.160 call tab1io(nin,0,0,a(iscr),nb,nw) *d up69.82,83 call tpidio(nlax,0,0,a,nb,nw) 110 call contio(nlax,0,0,a,nb,nw) *d up69.90 call contio(nlax,0,0,a,nb,nw) *d up69.107,108 call tpidio(nin,0,0,a(ll),nb,nw) 210 call contio(nin,0,0,a(ll),nb,nw) *d up69.116 call contio(nin,0,0,a(ll),nb,nw) *ident up76 */ plotr -- 09oct02 */ allow for more energy resolutions in plotr output */ for looking at the details of resonance reconstruction *d plotr.1939 write(nplt,'(1p,2e16.8,''/'')') x(i),y(i) *d plotr.1941,1942 write(nplt,'(1p,6e16.8,''/'')') x(i),y(i), & dym(i),dyp(i),dxm(i),dxp(i) *ident up77 */ plotr -- 11oct02 */ add a capability to plot percent difference or ratios *i plotr.21 c * percent difference and ratio plots can be requested. * *d plotr.178 c * ntp special features * c * 1 for regular plots (default) * c * 2 for percent difference plots * c * read a second "card 8" for percent diff * c * of second curve with respect to first * c * 3 for ratio plots * c * read a second "card 8" for ratio * c * of second curve to first * *i plotr.630 if (mfd.eq.3.and.ntp.gt.1) then nin2=0 matd2=0 matd2=0 mtd2=0 temper2=0 nth2=1 ntp2=1 nkh2=1 read(nsysi,*) & iverf2,nin2,matd2,mfd2,mtd2,temper2,nth2,ntp2,nkh2 call openz(nin2,0) write(nsyso,'(/ & '' iverf2 ............................... '',i10/ & '' nin2 ................................. '',i10/ & '' matd2 ................................ '',i10/ & '' mfd2 ................................. '',i10/ & '' mtd2 ................................. '',i10/ & '' temp2 ................................ '',1p,e10.2/ & '' nth2 ................................. '',i10/ & '' ntp2 ................................. '',i10/ & '' nkh2 ................................. '',i10)') & iverf2,nin2,matd2,mfd2,mtd2,temper2,nth2,ntp2,nkh2 endif *i plotr.702 if (nin2.ne.0) call tpidio(nin2,0,0,a,nb,nw) *i plotr.726 if (nin2.eq.0) go to 320 idone=0 do while (idone.eq.0) call contio(nin2,0,0,a,nb,nw) if (math.lt.0) then write(strng, & '(''desired mat2 and temp2 not found '',i4,f10.1)') & matd2,temper2 call error('plotr',strng,' ') endif if (math.eq.matd2) then if (mfd2.eq.7) then idone=1 else if (iverf2.ge.5) call contio(nin2,0,0,a,nb,nw) if (iverf2.ge.6) call contio(nin2,0,0,a,nb,nw) call contio(nin2,0,0,a,nb,nw) tem=a(1) if (abs(tem-temper2).le.temper2/1000) idone=1 endif endif if (idone.eq.0) call tomend(nin2,0,0,a) enddo *i plotr.729 if (nin2.ne.0) call findf(matd2,mfd2,mtd2,nin2) *i plotr.730 if (nin2.ne.0) call contio(nin2,0,0,a,nb,nw) *i plotr.990 else if (nin2.ne.0) then enext=big reset=-1 loc2=50+npage call getz(reset,enxt,idis,zz,0,a) call getz(enow,enxt,idis,zz,nin,a) if (enxt.lt.enext) enext=enxt call getz(enow,enxt,idis,zz,nin2,a(loc2)) if (enxt.lt.enext) enext=enxt *i plotr.1072 else if (nin2.ne.0) then enext=big call getz(enow,enxt,idis,zz,nin,a) if (enxt.lt.enext) enext=enxt call getz(enow,enxt,idis,z2,nin2,a(loc2)) if (enxt.lt.enext) enext=enxt if (ntp.eq.2) then yf=100*(z2-zz) if (zz.ne.zero) yf=yf/zz else if (ntp.eq.3) then yf=z2 if (zz.ne.zero) yf=yf/zz endif *i plotr.1102 else if (nin2.ne.0) then enext=big call getz(enow,enxt,idis,zz,nin,a) if (enxt.lt.enext) enext=enxt call getz(enow,enxt,idis,z2,nin2,a(loc2)) if (enxt.lt.enext) enext=enxt if (ntp.eq.2) then yf=100*(z2-zz) if (zz.ne.zero) yf=yf/zz else if (ntp.eq.3) then yf=z2 if (zz.ne.zero) yf=yf/zz endif *i plotr.2104 c subroutine getz(x,xnext,idis,z,itape,a) c ****************************************************************** c retrieve z(x) from an endf/b tab1 structure using paged bcd or c blocked binary formats. call with x=0 to read in first page c or block of data and initialize pointers. routine assumes c values will be called in ascending order. xnext is the first c data grid point greater than x unless x is the last point. c this version will keep track of pointers for up to 10 units. c call with x=-1 to clear the pointers before each group of files. c based on gety from mixr. c ****************************************************************** *if sw implicit real*8 (a-h,o-z) *endif dimension a(*) common/getzc/ntape,jtape(10),nrt(10),npt(10),irt(10),ipt(10), & ip1t(10),ip2t(10),nbt(10),nwt(10) save lt external tab1io,error,moreio,terp1 *if sw data big/1.d10/ *else data big/1.e10/ *endif zero=0 c c ***branch on value of x idis=0 if (x.eq.zero) go to 100 if (x.gt.zero) go to 115 c c ***clear pointer storage ntape=0 return c c ***read first page or block of data and initialize 100 ntape=ntape+1 jtape(ntape)=itape call tab1io(itape,0,0,a,nb,nw) nwtot=nw nr=nint(a(5)) np=nint(a(6)) lt=6+2*nr ip1=1 ip2=(nw-lt)/2 if (nb.eq.0) ip2=ip2+2 ir=1 ip=2 xnext=a(lt+1) c c ***save pointers and return nrt(ntape)=nr npt(ntape)=np irt(ntape)=ir ipt(ntape)=ip ip1t(ntape)=ip1 ip2t(ntape)=ip2 nbt(ntape)=nb nwt(ntape)=nwtot return c c ***restore pointers 115 if (ntape.eq.0) & call error('gety','not properly initialized',' ') do 120 i=1,ntape if (jtape(i).ne.itape) go to 120 ktape=i nr=nrt(i) np=npt(i) ir=irt(i) ip=ipt(i) ip1=ip1t(i) ip2=ip2t(i) nb=nbt(i) nwtot=nwt(i) go to 125 120 continue z=0 xnext=big return c c ***is x in this panel 125 ln=2*(ip-ip1)+lt if (x.lt.a(ln-1)) go to 135 if (x.lt.a(ln+1)) go to 130 if (ip.eq.np) go to 140 c c ***no. move up to next range. c ***read in new page of data if needed. ip=ip+1 nbx=nint(a(5+2*ir)) if (ip.gt.nbx) ir=ir+1 if (ip.lt.ip2) go to 125 if (nb.eq.0) go to 130 a(lt+1)=a(nwtot-3) a(lt+2)=a(nwtot-2) a(lt+3)=a(nwtot-1) a(lt+4)=a(nwtot) call moreio(itape,0,0,a(lt+5),nb,nw) nwtot=nw+lt+4 ip1=ip-1 ip2=ip1+nw/2+1 if (nb.eq.0) ip2=ip2+2 go to 125 c c ***yes. interpolate for desired value 130 int=nint(a(6+2*ir)) if (int.eq.1) idis=1 call terp1(a(ln-1),a(ln),a(ln+1),a(ln+2),x,z,int) xnext=a(ln+1) if ((ln+3).gt.nwtot.and.nb.eq.0) return xn=a(ln+3) if (xn.eq.xnext) idis=1 go to 150 c c ***special branch for x outside range of table 135 z=0 xnext=a(ln-1) go to 150 c c ***special branch for last point 140 z=a(ln+2) xnext=big c c ***save pointers and return 150 nrt(ktape)=nr npt(ktape)=np irt(ktape)=ir ipt(ktape)=ip ip1t(ktape)=ip1 ip2t(ktape)=ip2 nbt(ktape)=nb nwt(ktape)=nwtot return end *ident up78 */ broadr -- 10oct02 */ tighten up the tolerances for integral thinning a bit *d broadr.56 c * (errmax.ge.errthn, default=10*errthn) * *d broadr.58 c * (usage as in reconr) (default=errthn/20000) * *d broadr.177,178 if (errmax.eq.zero) errmax=10*errthn if (errint.eq.zero) errint=errthn/20000 */ broadr -- 10oct02 */ fix some problems related to keeping computed cross sections */ on printable 7- or 9-digit grids. this was discovered when */ doing testing at 0.01% for u235 above 1 kev, and it doesn't */ usually make itself evident for easier cases. *i broadr.1080 xt=sqrt(alpha*es(2)) *d broadr.1087 call bsigma(k,xt,ss(1,2),e,s,nx) *d broadr.1120 xt=sqrt(alpha*es(1)) call bsigma(k,xt,ss(1,1),e,s,nx) *ident up79 */ reconr -- 10oct02 */ tighten up the default tolerances for integral thinning a bit *d reconr.63 c * (errmax.ge.err, default=10*err) * *d reconr.65 c * per grid point (default=err/20000) * *d reconr.314 if (errmax.le.zero) errmax=10*err *d reconr.316 if (errint.le.zero) errint=err/20000 */ reconr -- 10oct02 */ make some improvements in grid generation to make sure that */ all cross sections are computed on printable 7- or 9-digit */ energies and that the original nodes for resonance reconstruction */ are reasonable. these changes were made to remove some small */ artifacts on the order of 0.05% above 1 kev for some materials. *i reconr.341 do i=1,ngrid a(ienode+i-1)=sigfig(a(ienode+i-1),7,0) enddo *d reconr.801 *d reconr.804 & hw=hw+(a(jnow+3)+abs(a(jnow+4))+abs(a(jnow+5)))/2 ndig=5 if (a(jnow).gt.zero) ndig=2+nint(log10(a(jnow)/(hw/10))) if (ndig.lt.5) ndig=5 if (ndig.gt.9) ndig=9 a(ienode+nodes-1)=sigfig(a(jnow),ndig,0) *d reconr.810 a(ienode+nodes-1)=sigfig(ehalf,ndig,0) *d reconr.817 a(ienode+nodes-1)=sigfig(ehalf,ndig,0) *d reconr.900,901 hw=a(nloc+ien*jen+1) ndig=5 if (ener.gt.zero) ndig=2+nint(log10(ener/(hw/10))) if (ndig.lt.5) ndig=5 if (ndig.gt.9) ndig=9 a(ienode+nodes-1)=sigfig(ener,ndig,0) *d reconr.907 a(ienode+nodes-1)=sigfig(ehalf,ndig,0) *d reconr.914 a(ienode+nodes-1)=sigfig(ehalf,ndig,0) *i reconr.993 ndig=5 if (enow.gt.zero) ndig=2+nint(log10(enow/(hw/10))) if (ndig.lt.5) ndig=5 if (ndig.gt.9) ndig=9 *d reconr.998 a(ienode+nodes-1)=sigfig(enow,ndig,0) *d reconr.1002 a(ienode+nodes-1)=sigfig(ehalf,ndig,0) *d reconr.1007 a(ienode+nodes-1)=sigfig(ehalf,ndig,0) *d reconr.1103 a(ienode+nodes-1)=sigfig(ener,7,0) *d reconr.1107 a(ieunr+nunr-1)=sigfig(ener,7,0) *d reconr.1176 a(ienode+nodes-1)=sigfig(ener,7,0) *d reconr.1180 a(ieunr+nunr-1)=sigfig(ener,7,0) *d reconr.1194 a(ienode+nodes-1)=sigfig(ener,7,0) *d reconr.1198 a(ieunr+nunr-1)=sigfig(ener,7,0) *d reconr.1303 a(ienode+nodes-1)=sigfig(ener,7,0) *d reconr.1307 a(ieunr+nunr-1)=sigfig(ener,7,0) *d reconr.1322 a(ienode+nodes-1)=sigfig(ener,7,0) *d reconr.1326 a(ieunr+nunr-1)=sigfig(ener,7,0) */ the printout for errors caused by significant figure reduction */ are obsolete now that we can go to 9 digits when necessary. */ we remove them and add a column for the error introduced into */ the fission integral by integral thinning. *d reconr.2044 *d reconr.2046 *d reconr.2050 *i reconr.2051 fint=0 fmax=0 *d reconr.2074,2078 & 15x,''resonance integral check (errmax,errint)''// & 4x,''upper'',6x,''elastic'',3x,''percent'',3x, & ''capture'',3x,''percent'',3x,''fission'',3x,''percent''/ & 4x,''energy'',5x,''integral'',3x,''error'',4x, & ''integral'',3x,''error'',4x,''integral'',3x,''error''/ & 1p,e10.2)') elo *d reconr.2113,2139 *i reconr.2177 fmax=fmax+dm2*dx/(2*xm) *i reconr.2202 c1=a(isigs+3*(i-1)+1) c2=a(isigs+3*(i-2)+1) fint=fint+(c1+c2)*dx/(2*xm) *d reconr.2207,2214 if (cint.ne.zero) cmax=100*cmax/cint if (eint.ne.zero) emax=100*emax/eint if (fint.ne.zero) fmax=100*fmax/fint write(nsyso,'(1p,e10.2,1x,3(1p,e12.2,f8.3))') & a(ix+i-2),eint,emax,cint,cmax,fint,fmax *i reconr.2229 fint=0 *d reconr.2232,2233 fmax=0 *d reconr.2286 *d reconr.2288 & ngneg,nmax,nrtot *ident up80 */ acer -- 10dec02 */ fix the photoatomic energy grid to include the discontinuities */ at the photo edges. reported by morgan white (lanl x-5). *d acer.14736 e=sigfig(enext,7,0) if (idis.ne.0) then e=sigfig(e,7,-1) call gety1(e,enxt,idis,s,nin,a(iscr)) l=l+1 xss(l)=e e=sigfig(e,7,+2) endif */ fix the values of the production cross section and heating */ at the particle production thresholds. *i acer.8264 if (y.lt.delt) y=0 *i acer.9533 if (xss(hpd+2+naa+ie-it).lt.delt) xss(hpd+2+naa+ie-it)=0 */ modify the acer listing to allow 6-digit energy indexes with */ the first column always blank. this allows for materials with */ more than 99999 energy points. *d acer.9863 & '(''1''/6x,''i'',5x,''energy'',11x,'' total '',7x, *d acer.9865 & ''gamma prod''/1x,''------'',3x,''--------------'', *d acer.9868 & '(''1''/6x,''i'',5x,''energy'',11x,'' total '',7x, *d acer.9870 & 1x,''------'',3x,''--------------'', *d acer.9874 write(nsyso,'(1x,i6,1p,e17.8,7e15.6)') i,xss(esz+i), *d acer.9877 write(nsyso,'(1x,i6,1p,e17.8,7e15.6)') i,xss(esz+i), *d acer.9916 write(nsyso,'(''1''/6x,''i'',5x,''energy'',11x,a10, *d acer.9918 write(nsyso,'(1x,''------'',3x,''--------------'', *d acer.9929 write(nsyso,'(1x,i6,1p,e17.8,7a15)') */ the global value of ntr is being overwritten when charged particle */ production is present. allow both fission flags. this only */ affects the plots. it showed up when processing a high-energy */ u-238 case with proton production by causing a bad plot of capture */ and fission resonance contours. *d acer.12592 ntrh=nint(xss(ntro-1+i)) *d acer.12595 do k=1,ntrh *d acer.12601 do k=1,ntrh *d acer.12607 do k=1,ntrh *d acer.12613 do j=1,ntrh *d acer.12632 do k=1,ntrh *d acer.12638 do ir=1,ntrh *d acer.12682 do k=1,ntrh *d acer.12688 do ii=1,ntrh *d acer.18808 if (mt.eq.18.or.mt.eq.19) then *ident up81 */ moder -- 2dec02 */ fix up the processing of the covariance sections to match */ the endf-6 format specifications. *d moder.1282,1290 ner=n1h do j=1,ner call contio(nin,nout,nscr,a,nb,nw) lru=l1h nro=n1h if (nro.gt.0) then call contio(nin,nout,nscr,a,nb,nw) ni=n2h do k=1,ni call listio(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo endif call contio(nin,nout,nscr,a,nb,nw) lcomp=l2h nls=n1h if (lru.eq.2) then do l=1,nls call listio(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo call listio(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo else if (lcomp.eq.0) then do l=1,nls call listio(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo else call contio(nin,nout,nscr,a,nb,nw) nsrs=n1h nlrs=n2h do k=1,nsrs call listio(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo if (nlrs.gt.0) then do k=1,nsrs call listio(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo endif endif enddo *ident up82 */ acer -- 28jan03 */ the heating value in the photoatomic ace file is supposed to be */ used in an "f6" tally with the computed photon flux to compute */ the energy deposition from electrons, positrons, and atomic */ recoils. the original heating value was designed to be used */ with an explicit calculation of heating during a coupled */ electron-photon calculation, and it only included the atomic */ recoil. this update adds in the other parts of the heating. */ it was also necessary to modify the quadrature in iheat to */ handle the very high incident energies now given in endf. *i up69.23 data epair/1.022d0/ *i up69.25 data epair/1.022e0/ *d acer.14745 eszg=1 *d acer.14767 e=xss(eszg-1+i) *d acer.14769 xss(l-1+i)=s *d acer.14838 call iheat(xss(i)*emev,en,idis,a(iscr),heat,siginc) *d up61.20 xss(lhnm-1+i)=xss(iinc-1+i)*heat/emev *d acer.14778 xss(eszg-1+i)=xss(eszg-1+i)/emev *d acer.14780 *d acer.14783 jinc=next *i acer.14844 do i=1,nes xss(lhnm-1+i)=xss(lhnm-1+i)+xss(eszg-1+i)*xss(iabs-1+i) enddo *d up69.50 call alax(nin,nlax,xss(jflo),xss(eszg),xss(iabs),xss(lhnm), 1 a(iscr),nes) *i up69.51 c c ***add in heating contribution from pair production do i=1,nes xss(lhnm-1+i)=xss(lhnm-1+i) 1 +xss(ipair-1+i)*(xss(eszg-1+i)-epair) enddo c c ***convert heating to a per collision basis do i=1,nes tot=xss(iinc-1+i)+xss(icoh-1+i)+xss(iabs-1+i)+xss(ipair-1+i) xss(lhnm-1+i)=xss(lhnm-1+i)/tot enddo *i acer.14934 c ***also limit panels by the fractional energy change. *i acer.14956 if (pnext.lt.pnow/2) pnext=pnow/2 *d acer.14993 heat=e-ebar *d up69.54 subroutine alax(nin,nlax,fluor,ener,abs,heat,a,nes) *i up69.63 dimension ener(nes),abs(nes),heat(nes) *i up69.155 c c ***subtract the photon energy from the heating do i=1,nes if (ener(i).gt.ek/emev) heat(i)=heat(i) 1 -abs(i)*sum1*sum2/emev enddo *i up69.187 c c ***subtract the photon energy from the heating do i=1,nes if (ener(i).gt.ek/emev) heat(i)=heat(i)-abs(i) 1 *(sum1*sum2+el2*pl2+el3*pl3)/emev enddo *i up69.282 c c ***subtract the photon energy from the heating do i=1,nes if (ener(i).gt.elav/emev) heat(i)=heat(i) 1 -abs(i)*ylt*flt/emev if (ener(i).gt.ek/emev) heat(i)=heat(i) 1 -abs(i)*(sum11*sum12+sum21*sum22 2 +el2*pl2+el3*pl3)/emev enddo *ident up83 */ plotr -- 12feb03 */ fixes an error in plotr that prevents it from printing out */ negative values of percent differences. zero percent */ difference confuses the thinning logic, so we add a small */ amount to all the percent differences. *d up77.88 yf=100*(z2-zz)+small *d up77.102 yf=100*(z2-zz)+small *d plotr.1113,1114 if (itype.eq.1) then if (yf.eq.zero.and.y(n).gt.zero) go to 380 if (yf.gt.zero.and.y(n).eq.zero) go to 380 else test=ten**(-15) if (yf.le.test) yf=test if (yf.eq.test.and.y(n).gt.test) go to 380 if (yf.gt.test.and.y(n).eq.test) go to 380 endif *d plotr.1118,1122 375 if (idis.gt.0) go to 380 if (itype.eq.3) then if (yf.eq.zero.and.y(n).gt.zero) go to 380 if (yf.gt.zero.and.y(n).eq.zero) go to 380 else test=ten**(-15) if (yf.le.test) yf=test if (yf.eq.test.and.y(n).gt.test) go to 380 if (yf.gt.test.and.y(n).eq.test) go to 380 endif *d plotr.1136 if (yf.ne.zero.and.itype.ne.2.and.itype.ne.4) nlast=n *ident up84 */ purr -- 30sep02 */ change the sampling scheme to use a different set of total cross */ section bins for each temperature. change the binning logic to */ use approximately equally probable bins over most of the range */ with two bins of lower probabilities on the low and high ends. *d purr.56 common/pustore/a(180000) *d purr.72 data namax/180000/, nidmax/24/, ipr/1/ *d purr.78 nsamp=5000 *d purr.136 nwds=5*ntemp*nbin *d purr.138 nwds=nbin*ntemp call reserv('tval',nwds,itval,a) *d purr.228 nw=1+5*ntemp*nbin *d purr.409 nw=1+5*ntemp*nbin *d purr.415,424 do i=1,5 do j=1,nbin n=n+1 a(n)=sigfig(a(itabl-1+j+nbin*(i-1)+5*(it-1)*nbin),7,0) enddo enddo *d purr.1730,1731 dimension bkg(4),sig0(nsig0),tval(nbin,ntemp) dimension sigf(5,10,10),tabl(nbin,5,ntemp) *i purr.1743 dimension tmin(10),tmax(10),tsum(10) *i purr.1794 do itemp=1,ntemp do i=1,nsig0 do j=1,8 bval(j,i,itemp)=0 enddo enddo enddo *i purr.2163 c c ***loop over temperatures c ***using a different total cross section bin structure for each do 140 itemp=1,ntemp *d purr.2169 es(ie)=els(itemp,ie)+fis(itemp,ie)+cap(itemp,ie)+bkg(1) *d purr.2172,2173 tmin(itemp)=es(1) tmax(itemp)=es(ne) nebin=nsamp/(nbin-3.375) ibin=nebin/16 do i=1,nbin-1 tval(i,itemp)=es(ibin) if (i.eq.1) ibin=ibin+nebin/4 if (i.gt.1.and.i.lt.nbin-2) ibin=ibin+nebin if (i.eq.nbin-2) ibin=ibin+nebin/4 if (i.eq.nbin-1) ibin=ibin+nebin/16 enddo tval(nbin,itemp)=big *d purr.2174 *d purr.2176,2177 do j=1,5 tabl(i,j,itemp)=0 *d purr.2180,2195 tsum(itemp)=0 *d purr.2200 tot=els(itemp,ie)+fis(itemp,ie)+cap(itemp,ie)+bkg(1) *d purr.2201,2203 if (tot.lt.tmin(itemp)) tmin(itemp)=tot if (tot.gt.tmax(itemp)) tmax(itemp)=tot call fsrch(tot,tval(1,itemp),nbin,ii,mfl) *d purr.2206,2228 tsum(itemp)=tsum(itemp)+1 tabl(ii,1,itemp)=tabl(ii,1,itemp)+1 tabl(ii,2,itemp)=tabl(ii,2,itemp)+tot tabl(ii,3,itemp)=tabl(ii,3,itemp)+els(itemp,ie)+bkg(2) tabl(ii,4,itemp)=tabl(ii,4,itemp)+fis(itemp,ie)+bkg(3) tabl(ii,5,itemp)=tabl(ii,5,itemp)+cap(itemp,ie)+bkg(4) do i=1,nsig0 tem=sig0(i)/(sig0(i)+tot) bval(1,i,itemp)=bval(1,i,itemp)+tot*tem bval(2,i,itemp)=bval(2,i,itemp) & +(els(itemp,ie)+bkg(2))*tem bval(3,i,itemp)=bval(3,i,itemp) & +(fis(itemp,ie)+bkg(3))*tem bval(4,i,itemp)=bval(4,i,itemp) & +(cap(itemp,ie)+bkg(4))*tem bval(5,i,itemp)=bval(5,i,itemp)+tot*tem*tem bval(6,i,itemp)=bval(6,i,itemp)+tem bval(7,i,itemp)=bval(7,i,itemp)+tem*tem enddo *i purr.2229 c c ***close loop over temperatures 140 continue *d purr.2296,2299 *d purr.2301,2309 *d purr.2311,2315 tmin(itemp)=tmin(itemp)+tnorm tval(nbin,itemp)=tmax(itemp) denom=tabl(i,1,itemp) if (denom.eq.zero) denom=1 tabl(i,1,itemp)=tabl(i,1,itemp)/tsum(itemp) tabl(i,2,itemp)=tabl(i,2,itemp)/denom tabl(i,3,itemp)=tabl(i,3,itemp)/denom tabl(i,4,itemp)=tabl(i,4,itemp)/denom tabl(i,5,itemp)=tabl(i,5,itemp)/denom tabl(i,2,itemp)=tabl(i,2,itemp)-tnorm tabl(i,3,itemp)=tabl(i,3,itemp)-enorm tabl(i,4,itemp)=tabl(i,4,itemp)-fnorm tabl(i,5,itemp)=tabl(i,5,itemp)-cnorm *d purr.2318,2321 *d purr.2325,2332 do itemp=1,ntemp do ixx=1,4 if (ixx.eq.1) then write(nsyso, & '('' tmax'',1p,e11.3,1p,10e11.3/(16x,10e11.3))') & temp(itemp),(tval(i,itemp),i=1,nbin) write(nsyso, & '('' prob'',1p,e11.3,1p,10e11.3/(16x,10e11.3))') & temp(itemp),(tabl(i,1,itemp),i=1,nbin) endif write(nsyso,'(1x,a,1x,1p,e11.3,10e11.3/(16x,10e11.3))') & nmr(ixx),temp(itemp),(tabl(i,ixx+1,itemp),i=1,nbin) enddo *d purr.2347 *d purr.2349,2357 if (tabl(j,1,itemp).ne.zero) then den=sig0(i)/(sig0(i)+tabl(j,2,itemp)) ttt=tabl(j,1,itemp) bval(1,i,itemp)=bval(1,i,itemp) & +ttt*tabl(j,2,itemp)*den bval(2,i,itemp)=bval(2,i,itemp) & +ttt*tabl(j,3,itemp)*den bval(3,i,itemp)=bval(3,i,itemp) & +ttt*tabl(j,4,itemp)*den bval(4,i,itemp)=bval(4,i,itemp) & +ttt*tabl(j,5,itemp)*den bval(5,i,itemp)=bval(5,i,itemp) & +ttt*tabl(j,2,itemp)*den*den *d purr.2383 *d purr.2385 & tabl(j,i,itemp)=tabl(j,i,itemp)*sigi(i-1) & /sigf(i-1,1,itemp) *ident up85 */ heatr -- 25feb02 */ add mt=442 to hold the total photon production ev-barns *i heatr.66 c * 442 total photon ev-barns * *i heatr.835 npkkk=0 do ipk=3,npk if (mtp(ipk).eq.442) npkkk=ipk enddo *i heatr.1145 if (izap.eq.0.and.npkkk.gt.0) c(npkkk)=c(npkkk)+h *d heatr.1199 if (mtp(index).lt.442) c(index)=c(index)+h+ebal6 *i heatr.1270 if (mtp(index).eq.442) go to 286 *i heatr.1332 c 442=total photon ev-barns in kerma *i heatr.1350 if (mtpi.eq.442) iflag=1 *d heatr.4625 if (mtp(index).lt.442) c(index)=c(index)+h if (mtp(index).eq.442) c(index)=c(index)-h *d heatr.4657,4659 if (mtp(index).lt.442) c(index)=c(index)+h if (mtp(index).eq.442) c(index)=c(index)-h *d heatr.5041 if (mtp(i).ge.442) then *ident up86 */ leapr -- 10dec02 */ add the fcc lattices for aluminum and lead to the */ coherent scattering option. *i leapr.97 c * 4 aluminum * c * 5 lead * c * 6 iron * *d leapr.380 maxb=60000 *i leapr.2407 data al1,al3,al4/4.04d-8,26.7495d0,1.495/ data pb1,pb3,pb4/4.94d-8,207.d0,1.d0/ data fe1,fe3,fe4/2.86d-8,55.454d0,12.9d0/ data twothd/0.666666666667d0/ *i leapr.2414 data al1,al3,al4/4.04e-8,26.7495e0,1.495/ data pb1,pb3,pb4/4.94e-8,207.e0,1.e0/ data fe1,fe3,fe4/2.86e-8,55.454e0,12.e0/ data twothd/0.666666666667e0/ *i leapr.2419 taufcc(m1,m2,m3)=c1*(m1*m1+m2*m2+m3*m3+twothd*m1*m2 & +twothd*m1*m3-twothd*m2*m3)*twopis taubcc(m1,m2,m3)=c1*(m1*m1+m2*m2+m3*m3+m1*m2+m2*m3+m1*m3)*twopis *i leapr.2450 else if (lat.eq.4) then c aluminum a=al1 amsc=al3 scoh=al4/natom else if (lat.eq.5) then c lead a=pb1 amsc=pb3 scoh=pb4/natom else if (lat.eq.6) then c iron a=fe1 amsc=fe3 scoh=fe4/natom *d leapr.2454,2456 if (lat.lt.4) then c1=4/(3*a*a) c2=1/(c*c) scon=scoh*(4*pi)**2/(2*a*a*c*sqrt3*econ) else if (lat.ge.4.and.lat.le.5) then c1=3/(a*a) scon=scoh*(4*pi)**2/(16*a*a*a*econ) else if (lat.eq.6) then c1=2/(a*a) scon=scoh*(4*pi)**2/(8*a*a*a*econ) endif *d leapr.2463 c ***compute lattice factors for hexagonal lattices if (lat.gt.3) go to 210 *i leapr.2553 go to 220 c c ***compute lattice factors for fcc lattices 210 if (lat.gt.5) go to 215 phi=ulim/twopis i1m=int(a*sqrt(phi)) i1m=15 k=0 do i1=-i1m,i1m i2m=i1m do i2=-i2m,i2m i3m=i1m do i3=-i3m,i3m tsq=taufcc(i1,i2,i3) if (tsq.gt.zero.and.tsq.le.ulim) then tau=sqrt(tsq) w=exp(-tsq*t2*wint)/tau f=w*formf(lat,i1,i2,i3) k=k+1 if ((2*k).gt.nw) call error('coh', & 'storage exceeded',' ') b(ifl+2*k-2)=tsq b(ifl+2*k-1)=f endif enddo enddo enddo imax=k-1 go to 220 c c ***compute lattice factors for bcc lattices 215 continue phi=ulim/twopis i1m=int(a*sqrt(phi)) i1m=15 k=0 do i1=-i1m,i1m i2m=i1m do i2=-i2m,i2m i3m=i1m do i3=-i3m,i3m tsq=taubcc(i1,i2,i3) if (tsq.gt.zero.and.tsq.le.ulim) then tau=sqrt(tsq) w=exp(-tsq*t2*wint)/tau f=w*formf(lat,i1,i2,i3) k=k+1 if ((2*k).gt.nw) call error('coh', & 'storage exceeded',' ') b(ifl+2*k-2)=tsq b(ifl+2*k-1)=f endif enddo enddo enddo imax=k-1 c c ***sort lattice factors 220 do i=1,imax jmin=i+1 do j=jmin,k if (b(ifl+2*j-2).lt.b(ifl+2*i-2)) then st=b(ifl+2*i-2) sf=b(ifl+2*i-1) b(ifl+2*i-2)=b(ifl+2*j-2) b(ifl+2*i-1)=b(ifl+2*j-1) b(ifl+2*j-2)=st b(ifl+2*j-1)=sf endif enddo enddo k=k+1 b(ifl+2*k-2)=ulim b(ifl+2*k-1)=b(ifl+2*k-3) nw=2*k *i leapr.2600 c lat=4,5 fcc lattice (aluminum, lead) c lat=6 bcc lattice (iron) *i leapr.2626 else if (lat.eq.4.or.lat.eq.5) then c fcc lattices. e1=2*pi*l1 e2=2*pi*(l1+l2) e3=2*pi*(l1+l3) formf=(1+cos(e1)+cos(e2)+cos(e3))**2 & +(sin(e1)+sin(e2)+sin(e3))**2 else if (lat.eq.6) then c bcc lattices. e1=2*pi*(l1+l2+l3) formf=(1+cos(e1))**2+(sin(e1))**2 *ident up87 */ acer -- 2jul03 */ the mt numbers used for determining charged particle production */ have some errors. this affects some light-isotope runs for */ incident charged particles. *d acer.4770,4771 if (mt.eq.5.or.mt.eq.28.or.mt.eq.41.or. & mt.eq.42.or.mt.eq.44.or.mt.eq.45.or. *d acer.4785 if (mt.eq.5.or.mt.eq.32.or.mt.eq.35.or. *d acer.4798 if (mt.eq.5.or.mt.eq.33.or.mt.eq.36.or. *d acer.4811 if (mt.eq.5.or.mt.eq.34.or.mt.eq.106.or. *d acer.4823,4825 if (mt.eq.5.or.(mt.ge.22.and.mt.le.25).or. & mt.eq.29.or.mt.eq.30.or. & mt.eq.35.or.mt.eq.36.and.mt.eq.45.or. *d acer.5024 if (mt.eq.2.or.mt.eq.5.or.mt.eq.28.or.mt.eq.41.or. & mt.eq.42.or.mt.eq.44.or.mt.eq.45.or. *d acer.5031 if (mt.eq.2.or.mt.eq.5.or.mt.eq.32.or.mt.eq.35.or. *d acer.5036 if (mt.eq.2.or.mt.eq.5.or.mt.eq.33.or.mt.eq.36.or. *d acer.5041 if (mt.eq.2.or.mt.eq.5.or.mt.eq.34.or.mt.eq.106.or. *d acer.5045 if (mt.eq.2.or.mt.eq.5.or.(mt.ge.22.and.mt.le.25).or. *d acer.5047 & mt.eq.35.or.mt.eq.36.and.mt.eq.45.or. *d acer.5130 if (mt.eq.2.or.mt.eq.5.or.mt.eq.28.or.mt.eq.41.or. & mt.eq.42.or.mt.eq.44.or.mt.eq.45.or. *d acer.5137 if (mt.eq.2.or.mt.eq.5.or.mt.eq.32.or.mt.eq.35.or. *d acer.5142 if (mt.eq.2.or.mt.eq.5.or.mt.eq.33.or.mt.eq.36.or. *d acer.5147 if (mt.eq.2.or.mt.eq.5.or.mt.eq.34.or.mt.eq.106.or. *d acer.5153 & mt.eq.35.or.mt.eq.36.and.mt.eq.45.or. */ acer -- 02jul03 */ for the particle production sections, the acer logic fails for */ some cases where two identical particles are produced by */ file 6, such as p+t->alpha+alpha. the acer job seems to run */ ok, but it fails when the file is read back in for checking */ and plotting. this patch fixes the problem. this problem */ only shows up for a few light-isotope cases with incident */ charged particles. *d acer.224 & nprod,kprod(300),mprod(300),iprod(300),lprod(300) *d acer.551 & nprod,kprod(300),mprod(300),iprod(300),lprod(300) *i acer.741 lprod(nprod)=0 *i acer.746 lprod(nprod)=0 *i acer.751 lprod(nprod)=0 *i acer.756 lprod(nprod)=0 *i acer.761 lprod(nprod)=0 *i acer.766 lprod(nprod)=0 *i acer.929 lprod(nprod)=ik *i acer.937 lprod(nprod)=ik *i acer.945 lprod(nprod)=ik *i acer.953 lprod(nprod)=ik *i acer.961 lprod(nprod)=ik *i acer.969 lprod(nprod)=ik *d acer.980,981 isort1=100000*mprod(i)+10*iprod(i)+lprod(j) isort2=100000*mprod(j)+10*iprod(j)+lprod(j) *i acer.985 isave4=lprod(j) *i acer.991 lprod(i)=isave4 *d acer.8061 & nprod,kprod(300),mprod(300),iprod(300),lprod(300) *d acer.8259 if (ik.eq.lprod(j)) then *d acer.8662 if (ik.eq.lprod(j)) then *d acer.8671 if (ik.eq.lprod(j).and.law.eq.4) then *d acer.8691 if ((ik.eq.lprod(j).and.law.eq.2).or. *d acer.8819 else if (ik.eq.lprod(j).and.law.eq.7) then *d up36.7 if (ik.ne.lprod(j).or.law.ne.1) then *i up20.56 c c ***skip if not correct subsection else if (ik.ne.lprod(j)) then call skip6a(nin,0,0,a(iscr),law) */ acer -- 02jul03 */ patch the phase-space option for the primary particle. this */ problem showed up for the proton distribution for 3He(p,2p). *d acer.6582,6583 test1=one+one/100000 test2=one/10-one/1000000 test3=one-one/100000 do while (xx.lt.test1) *d acer.6585,6587 if (xx.lt.test2) then *d acer.6603,6604 do while (xx.lt.test1) *d acer.6606,6607 if (xx.gt.test3) then *d acer.6620,6622 if (xx.lt.test2) then *ident up88 */ matxsr -- 28jul03 */ the update that introduced a photonuclear capability for */ matxsr on 12feb02 accidently removed the assignment of the */ scratch file used for computing the self-shielding delta */ cross section values. any matxs files that include temperature */ and sigma-zero data and that were generated with versions of */ njoy99 from 99.67 up are incorrect. *i matxsr.440 nscrt7=16 */ the read statement that brings in the group structures has a */ scale factor in it by mistake. this distorts group energies */ that are written on the gendf tape in f format. the result is */ an incorrect group structure on the matxs file. this error */ has existed for many years without causing problems. *d matxsr.2291 read(nin,'(6e11.0)') (a(i+nw1),i=1,lim) */ more room is need to read in vector cross sections for */ 187 group runs. this shows up for delayed-neutron data. *d matxsr.1488 dimension b(2000) *d matxsr.1501 maxb=2000 *ident up89 */ groupr -- 29jul03 */ increase the main container array to allow for up to p5 for */ the lanl u233 evaluation proposed for endf/b-vii. *d up34.7 dimension a(200000) *d up34.9 iamax=200000 */ increase the number of gammas allowed to handle w-182 and */ w-186 from endf/b-vi release 8. *d groupr.7783 dimension loca(550) *d groupr.7791 data nylmax/550/ *ident up90 */ purr -- 6aug03 */ the purr module is zeroing out the lssf and intunr flags in */ the section mt=152 that contains the bondarenko selfshielding */ information. this has the dramatic effect giving different */ infinitely dilute cross sections when nsigz is one or greater */ than one, and incorrectly interpolated values. note that purr */ is substituting its bondarenko values for the ones from unresr */ if both unresr and purr are run in that order. these errors */ can have important effects on multigroup results from groupr. *d purr.337 a(l+2)=lssf *d purr.340 a(l+5)=2 *ident up91 */ purr -- 06dec03 */ alain hebert noticed that the normalization of the sampled */ bondarenko tables to match the infinitely dilute cross sections */ was being done incorrectly and provided this fix. *d purr.2390 do i=nsig0,1,-1 *ident up92 */ reconr -- 10dec03 */ reuven perel noticed that zero=0 needed to be added to subroutines */ rdf2aa and rdf2hy in reconr. *i reconr.853 zero=0 *i reconr.937 zero=0 *ident up93 */ thermr -- 01mar04 */ allow for higher incident energies in calcem. this also requires */ some tightening up of the calculation near e'=e. also, add */ some energies near the zrh einstein oscillator. *d thermr.1422,1423 dimension egrid(117) dimension ubar(117) *d thermr.1427 data ngrid/117/ *d thermr.1429,1439 data egrid/ & 1.d-5,1.78d-5,2.5d-5,3.5d-5,5.0d-5,7.0d-5,1.d-4, & 1.26d-4,1.6d-4,2.0d-4,.000253d0,.000297d0,.000350d0, & .00042d0,.000506d0,.000615d0,.00075d0,.00087d0, & .001012d0,.00123d0,.0015d0,.0018d0,.00203d0,.002277d0, & .0026d0,.003d0,.0035d0,.004048d0,.0045d0,.005d0, & .0056d0,.006325d0,.0072d0,.0081d0,.009108d0,.01d0, & .01063d0,.0115d0,.012397d0,.0133d0,.01417d0,.015d0, & .016192d0,.0182d0,.0199d0,.020493d0,.0215d0,.0228d0, & .0253d0,.028d0,.030613d0,.0338d0,.0365d0,.0395d0, & .042757d0,.0465d0,.050d0,.056925d0,.0625d0,.069d0, & .075d0,.081972d0,.09d0,.096d0,.1035d0,.111573d0, & .120d0,.128d0,.1355d0,.145728d0,.160d0,.172d0, & .184437d0,.20d0,.2277d0,.2510392d0,.2705304d0, & .2907501d0,.3011332d0,.3206421d0,.3576813d0,.39d0, & .4170351d0,.45d0,.5032575d0,.56d0,.625d0, & .70d0,.78d0,.86d0,.95d0,1.05d0,1.16d0,1.28d0, & 1.42d0,1.55d0,1.70d0,1.855d0,2.02d0,2.18d0, & 2.36d0,2.59d0,2.855d0,3.12d0,3.42d0,3.75d0, & 4.07d0,4.46d0,4.90d0,5.35d0,5.85d0,6.40d0, & 7.00d0,7.65d0,8.40d0,9.15d0,10.00d0/ *d thermr.1451,1461 data egrid/ & 1.e-5,1.78e-5,2.5e-5,3.5e-5,5.0e-5,7.0e-5,1.e-4, & 1.26e-4,1.6e-4,2.0e-4,.000253e0,.000297e0,.000350e0, & .00042e0,.000506e0,.000615e0,.00075e0,.00087e0, & .001012e0,.00123e0,.0015e0,.0018e0,.00203e0,.002277e0, & .0026e0,.003e0,.0035e0,.004048e0,.0045e0,.005e0, & .0056e0,.006325e0,.0072e0,.0081e0,.009108e0,.01e0, & .01063e0,.0115e0,.012397e0,.0133e0,.01417e0,.015e0, & .016192e0,.0182e0,.0199e0,.020493e0,.0215e0,.0228e0, & .0253e0,.028e0,.030613e0,.0338e0,.0365e0,.0395e0, & .042757e0,.0465e0,.050e0,.056925e0,.0625e0,.069e0, & .075e0,.081972e0,.09e0,.096e0,.1035e0,.111573e0, & .120e0,.128e0,.1355e0,.145728e0,.160e0,.172e0, & .184437e0,.20e0,.2277e0,.2510392e0,.2705304e0, & .2907501e0,.3011332e0,.3206421e0,.3576813e0,.39e0, & .4170351e0,.45e0,.5032575e0,.56e0,.625e0, & .70e0,.78e0,.86e0,.95e0,1.05e0,1.16e0,1.28e0, & 1.42e0,1.55e0,1.70e0,1.855e0,2.02e0,2.18e0, & 2.36e0,2.59e0,2.855e0,3.12e0,3.42e0,3.75e0, & 4.07e0,4.46e0,4.90e0,5.35e0,5.85e0,6.40e0, & 7.00e0,7.65e0,8.40e0,9.15e0,10.00e0/ *d thermr.1735 enow=sigfig(enow,6,0) *d thermr.1756 ep=sigfig(ep,6,0) if (ep.eq.enow) ep=sigfig(enow,6,-1) *i thermr.1758 ep=sigfig(ep,6,0) *d thermr.1760 ep=sigfig(enow,6,+1) *d thermr.1764 if (ep.gt.x(2)) go to 316 *d thermr.1767 316 ep=sigfig(ep,6,0) *d thermr.1782 xm=sigfig(xm,6,0) *d thermr.1875 write(nsyso,'(4x,1p,e12.5,e12.4,0p,10f9.4)') *d thermr.2155 if (abs(x(2)).gt.1-eps) x(2)=0.99 *d thermr.2211 if (abs(x(2)).gt.1-eps) x(2)=0.99 *ident up94 */ acer -- 01mar04 */ allow for up to 1024 secondary energies for thermal scattering. *d acer.13079 dimension wt(1025) *d acer.13098 ninmax=20000 *i acer.13399 if (loc.ge.ninmax) call error('acesix','storage exceeded',' ') */ acer -- 15mar04 */ increase storage available *d up3.71 common/astore/a(120000) *d up3.73 data namax/120000/, nidmax/27/ *d up3.75 common/astore/a(120000) *d up3.79 common/astore/a(120000) *d up3.81 common/astore/a(120000) *d up3.83 common/astore/a(120000) *d up3.85 common/astore/a(120000) *d up3.87 common/astore/a(120000) *d up3.89 common/astore/a(120000) *d up3.91 common/astore/a(120000) *d up6.5 data namax/120000/ *d up3.95 common/astore/a(120000) *d up3.97 common/astore/a(120000) *d up3.99 common/astore/a(120000) *d up3.101 common/astore/a(120000) *d up3.103 common/astore/a(120000) *d up3.105 common/astore/a(120000) *d up3.107 common/astore/a(120000) *d up3.109 common/astore/a(120000) *ident up95 */ viewr -- 20sep04 */ make symbol size scale with character size in legend. */ fix viewr to handle colors of filled symbols correctly. *d viewr.1029 ssym=.3*hleg *d viewr.1182 ssym=.3*hleg *d viewr.3038 ifg=10+ishade *d viewr.3042 ifg=ishade-40 *d viewr.3903,3914 c curve colors r=ifrgb(1,ifg)/rgb g=ifrgb(2,ifg)/rgb b=ifrgb(3,ifg)/rgb else if (color.lt.cmin.and.ifg.le.20) then c shades of gray ten=10 r=(20-ifg)/ten g=(20-ifg)/ten r=(20-ifg)/ten else if (color.lt.cmin.and.ifg.gt.20) then c filling in shades of curve colors r=ifrgb(1,ifg-50)/rgb g=ifrgb(2,ifg-50)/rgb b=ifrgb(3,ifg-50)/rgb *ident up96 */ acer -- 30mar05 */ correct treatment of delayed neutrons to handle jeff-3.1t *i up63.88 nn=n1h *d up63.92,98 lff=lff+1 if (nn.eq.1.and.nint(a(iscr+7)).eq.2) then xss(lff)=0 lff=lff+1 else xss(lff)=nn do j=1,nn xss(lff+j)=a(iscr+4+2*j) xss(lff+nn+j)=a(iscr+5+2*j) enddo lff=lff+1+2*nn endif xss(lff)=n do j=1,n xss(lff+j)=sigfig(a(iscr+4+2*nn+2*j)/emev,7,0) xss(lff+n+j)=sigfig(a(iscr+5+2*nn+2*j),7,0) enddo lff=lff+1+2*n *i up63.135 nn=n1h *d up63.143 xss(next+2)=next-dnd+10 *d up63.317 l=l+1 nn=nint(xss(l)) write(nsyso,'(12x,''nr ='',i4)') nn if (nn.ne.0) then write(nsyso,'(12x,''nbt(i=1,nr) = '',20i5)') & (nint(xss(j+l)),j=1,nn) write(nsyso,'(12x,''int(i=1,nr) = '',20i5)') & (nint(xss(j+nn+l)),j=1,nn) l=l+2*nn endif l=l+1 *d up70.19 l=l+1 nj=nint(xss(l)) l=l+1+2*nj *ident up97 */ thermr -- 11apr05 */ changes recommended by m.mattes, ike-stuttgart */ increase array size for ike evaluations *d thermr.101 dimension a(800000) *d thermr.131 namax=800000 */ fix reading long tab1 and list records *i thermr.1543 ll=loc do while (nb.ne.0) ll=ll+nw call moreio(nendf,0,0,a(ll),nb,nw) enddo *i thermr.1573 ll=loc do while (nb.ne.0) ll=ll+nw call moreio(nendf,0,0,a(ll),nb,nw) enddo *i thermr.1598 ll=loc do while (nb.ne.0) ll=ll+nw call moreio(nendf,0,0,a(ll),nw,nw) enddo *i thermr.1602 ll=loc do while (nb.ne.0) ll=ll+nw call moreio(nendf,0,0,a(ll),nb,nw) enddo */ fix print of max energy transfer at higher temperatures *i thermr.1622 if (lat.eq.1) tmax=tmax*tevz/(bk*temp) *ident up98 */ leapr -- 11apr05 */ changes recommended by m.mattes, ike-stuttgart */ allow for up to 400 beta values as needed for ike h2o *d leapr.164 common/ab/nalpha,nbeta,naint,nbint,alpha(200),beta(400) *d leapr.173 common/lstore/a(7500000) *d leapr.178 data nbmax,namax/400,200/ *d leapr.189 maxa=7500000 *d leapr.391 mscr=4000 *d leapr.420 common/ab/nalph1,nbeta1,naint,nbint,alph1(200),beta1(400) *d leapr.426 dimension maxt(400) *d leapr.794 common/ab/nalpha,nbeta,naint,nbint,alpha(200),beta1(400) *d leapr.1252 common/ab/nalpha1,nbeta1,naint,nbint,alpha(200),beta1(400) *d leapr.1852 common/ab/nalph1,nbeta1,naint,nbint,alpha(200),beta1(400) */ allow for more pages in record to handle ike h2o *i leapr.3122 l_mm=1+nw do while (nb.ne.0) call moreio(0,nout,nprnt,scr(l_mm),nb,nw) l_mm=l_mm+nw enddo */ for h(h2o) and d(d2o), ns should be equal to 1 *d leapr.2976,2977 if(nss.gt.0) scr(5)=6*(nss+1) scr(6)=nss */ correct calculation of t-eff *d leapr.1557 tempf(itemp)=(tbeta+twt)*tempf(itemp)+tsave */ allow for up to 20 temperatures *d leapr.166,167 common/te/tempr(20),tempf(20),tempf1(20) common/dw/dwpix(20),dwp1(20) *d leapr.179 data ntmax/20/ *d leapr.600,601 common/te/tempr(20),tempf(20),tempf1(20) common/dw/dwpix(20),dwp1(20) *d leapr.797 common/te/tempr(20),tempf(20),tempf1(20) *d leapr.1256 common/te/tempr(20),tempf(20),tempf1(20) *d leapr.1258 common/dw/dwpix(20),dwp1(20) *d leapr.1856 common/te/tempr(20),tempf(20),tempf1(20) *d leapr.2651.2652 common/te/tempr(20),tempf(20),tempf1(20) common/dw/dbw(20),dbw1(20) */ correct directory entry *i leapr.2797 scr(5)=scr(5)+1 if(iel.ne.0) scr(5)=scr(5)+1 *ident up99 */ reconr -- 11apr05 */ add forgotten initializations of zero (a.hogenbirk, nrg) *i reconr.853 zero=0 *i reconr.937 zero=0 *ident up100 */ heatr -- 11pr05 */ increase number of legendre terms to handle new mo95 evaluation *d up15.9 dimension cnow(*),p(65) *d up30.10 *i heatr.3298 data nlmax/65/ *ident up101 */ gaspr -- 11apr05 */ need more space for for ni-58 from jeff-3.1t */ provided by d.l.aldama, nds/iaea consultant *d gaspr.28 dimension egas(80000),sgas(5,80000) *d gaspr.41 maxg=80000 *ident up102 */ matxsr -- 11apr05 */ changes recommended by kazuaki kosako (shimizu corporation) *d matxsr.1973 dimension b(30000) *d matxsr.1978 maxb=30000 *d matxsr.2078 dimension b(30000) *d matxsr.2080 maxb=30000 */ changes for processing be-9 from jeff-3.0 from iaea. *d matxsr.1418 290 if (mt.gt.891) go to 300 *i matxsr.1433 if (mt.ge.875.and.mt.lt.885) write(strng,'(''2n0'',i1)') mt-875 if (mt.ge.885.and.mt.lt.891) write(strng,'(''2n'',i2)') mt-875 if (mt.eq.891) write(strng,'(''2ncn'')') *i matxsr.1504 k016=0 *i matxsr.1652 if (mt.eq.16) k016=1 if (k016.eq.1.and.mt.ge.875.and.mt.le.891) go to 310 */ remove a problem in case of multi-temperature matxs files processing. */ scratch tapes iref and nscr should be simultaneously forwarded. */ the problem seems to affect only multi-temperature runs, if the mf=6 */ of gendf tape was not ordered by mt numbers. */ recommended by d.l.aldama, nds/iaea consultant, july 2005 *i matxsr.1870 if (iref.ne.0) call contio(iref,0,0,b(1),nb,nw) *d matxsr.1878 if (iskip.eq.0) then if (iref.ne.0) call tosend(iref,0,0,b(1)) call tosend(nscr,0,0,b(1)) endif *ident up103 */ groupr -- 11apr05 */ changes to groupr recommended by d.l.aldama, nds/iaea consultant */ process be-9 from jeff-3.0 *i groupr.1147 else if (mtd.ge.875.and.mtd.le.884) then write(reac,'(''2n0'',i1)') mtd-875 else if (mtd.ge.885.and.mtd.le.890) then write(reac,'(''2n'',i2)') mtd-875 else if (mtd.eq.891) then reac='2nc' *i groupr.3964 if (iverf.ge.6.and.mtd.ge.875.and.mtd.le.891) mt=mtd *i groupr.4331 if (mfd.ge.31.and.mfd.le.36.and.iverf.ge.6.and. & (mtd.ge.875.and.mtd.lt.891)) go to 400 *i groupr.8014 if (mth.ge.875.and.mth.lt.891) za2=1 *i groupr.8330 if (iverf.ge.6.and.mth.ge.875.and.mth.le.890) mt0=875 */ correct namer for mt=659 *d groupr.1124 else if (mtd.ge.650.and.mtd.le.659) then *ident up104 */ purr -- 11apr05 */ increase scratch space to handle pu-239 from jef-2.2 (trkov,iaea) *d purr.95 maxscr=12000 */ allow pt for multi-isotope materials when */ not all the isotopes have unresolved resonance data */ from d.l.aldama, nds/iaea consultant *d purr.624 *i purr.651 if (ier.eq.ner) go to 110 *ident up105 */ groupr -- 11apr05 */ patch the initialization of getsig, getflx, and getff */ provided by shimuzu corp. *i groupr.548 ee=0 *d groupr.550 */ changes recommended by a.trkov, nds/iaea */ increase the maximum number of legendre coefficients allowed *i groupr.4756 c maximum legendre coefficients parameter (mxlg=65) *d groupr.4764 dimension term(mxlg),terml(mxlg) *i groupr.5209 c maximum legendre coefficients parameter (mxlg=65) *d groupr.5212 dimension term(mxlg),x(10),y(10,mxlg) *d groupr.5329,5330 c maximum legendre coefficients parameter (mxlg=65) dimension cnow(*),term(*),p(mxlg) dimension x(10),y(10,mxlg),yt(mxlg) *d groupr.5333 external f6ddx,f6psp,f6dis,legndr,error *i groupr.5358 if(nl.gt.mxlg) call error('f6cm','nl>mxlg',' ') *d groupr.5586 c maximum legendre coefficients parameter (mxlg=65) dimension cnow(*),p(mxlg) *d groupr.5768 c maximum legendre coefficients parameter (mxlg=65) dimension cnow(*),p(mxlg) *i groupr.5630 if(nl.gt.mxlg) call error('f6ddx','nl>mxlg',' ') *i groupr.5992 c maximum legendre coefficients parameter (mxlg=65) *d groupr.5995 dimension term(mxlg),p(mxlg),amu(50),fmu(50),qp(8),qw(8) *i groupr.6130 c maximum legendre coefficients parameter (mxlg=65) *d groupr.6133,6134 dimension term1(mxlg),term2(mxlg),p(mxlg) dimension qp(8),qw(8) *i groupr.6733 c maximum legendre coefficients parameter (mxlg=65) *d groupr.6740 dimension flo(mxlg),fhi(mxlg) *i groupr.7314 c maximum legendre coefficients parameter (mxlg=65) *d groupr.7318 dimension b(6),alo(mxlg),ahi(mxlg) *i groupr.7929 c maximum legendre coefficients parameter (mxlg=65) *d groupr.7942 dimension fl(mxlg) */ provide more space for the flux calculator *d up89.6 dimension a(400000) *d up89.8 iamax=400000 */ fix inconsistent usage of output weighting flux unit number *i groupr.80 c * note: weighting flux file is always written binary * *d groupr.99 c * ninwt tape unit for flux parameters (binary) * *d groupr.272 *d groupr.2290 ninwt=iabs( ninwt) call openz(-ninwt,1) *d groupr.2294 & ehi,sigpot,nflmax,-ninwt,jsigz *d groupr.2307,2308 call openz(-ninwt,0) write(nsyso,'(/'' ninwt......'',i4)') -ninwt */ fix logic when searching for the right flux point *d groupr.3037 if (e.gt.el*(1-small).and.e.lt.en*(1+small)) go to 230 */ fix a test that has misbehaved for lahey pc compilers *d groupr.6054 test=shade*epn if (idis.gt.0.and.ep.lt.test) epn=test */ accept old proposal from c.dean *d groupr.2745,2746 b(iz+3+li)=(sigz(iz)-sam)*wtf*(1-beta) *ident up106 */ acer -- 18aug05 */ fix a problem with the patching of distributions with */ e'>e. the distributions with too high e' values are */ moved down to e' values below e. the previous version */ generated non-sequential e' values for jeff-3.1 be-9. *d acer.6707 if (ep.gt.e-e/1000.and.ki.lt.n.and.mth.ne.5 & .and.q.lt.zero) then *i acer.6713 else if (ep.gt.e.and.ki.eq.n.and.mth.ne.5 & .and.q.lt.zero) then write(nsyso,'(/'' ---warning from acelod---'', & 6x,''mf6 ep.gt.e with negative q''/ & 6x,''mt='',i2,'' e='',1p,e12.4,'' ep='',e12.4/ & 6x,''patching...'')') mt,e/emev,ep/emev ep=e-(n-ki)*1000 a(iscr+6+ncyc*(ki-1))=ep *ident up107 */ groupr -- 18aug05 */ add the ecco33, ecco1968, tripoli315, xmas172 and vitamin-j */ group structures with 7 significant decimal digits. those */ group structures are used in europe for fast breeder and */ thermal reactor neutronics calculations. for compatibility */ with calendf and apollo *b groupr.132 c * 18 xmas nea-lanl c * all new additional group structure with 7 significant c * decimal digits compatible with calendf c * 19 ecco 33-group structure c * 20 ecco 1968-group structure c * 21 tripoli 315-group structure c * 22 xmas lwpc 172-group structure c * 23 vit-j lwpc 175-group structure *b groupr.1297 c 19 ecco 33-group structure c 20 ecco 1968-group structure c 21 tripoli 315-group structure c 22 xmas lwpc 172-group structure c 23 vit-j lwpc 175-group structure *b groupr.1312 dimension eg19(34) dimension eg20(1969) dimension eg20a(95),eg20b(95),eg20c(95),eg20d(95), * eg20e(95),eg20f(95),eg20g(95),eg20h(95), * eg20i(95),eg20j(95),eg20k(95),eg20l(95), * eg20m(95),eg20n(95),eg20o(95),eg20p(95), * eg20q(95),eg20r(95),eg20s(95),eg20t(95), * eg20u(69) dimension eg21(316) dimension eg21a(95),eg21b(95),eg21c(95),eg21d(31) dimension eg22(173) dimension eg22a(95),eg22b(78) dimension eg23(176) dimension eg23a(95),eg23b(81) equivalence (eg20a(1),eg20(1)),(eg20b(1),eg20(96)), * (eg20c(1),eg20(191)),(eg20d(1),eg20(286)), * (eg20e(1),eg20(381)),(eg20f(1),eg20(476)), * (eg20g(1),eg20(571)),(eg20h(1),eg20(666)), * (eg20i(1),eg20(761)),(eg20j(1),eg20(856)), * (eg20k(1),eg20(951)),(eg20l(1),eg20(1046)), * (eg20m(1),eg20(1141)),(eg20n(1),eg20(1236)), * (eg20o(1),eg20(1331)),(eg20p(1),eg20(1426)), * (eg20q(1),eg20(1521)),(eg20r(1),eg20(1616)), * (eg20s(1),eg20(1711)),(eg20t(1),eg20(1806)), * (eg20u(1),eg20(1901)) equivalence (eg21a(1),eg21(1)),(eg21b(1),eg21(96)), * (eg21c(1),eg21(191)),(eg21d(1),eg21(286)) equivalence (eg22a(1),eg22(1)),(eg22b(1),eg22(96)) equivalence (eg23a(1),eg23(1)),(eg23b(1),eg23(96)) *b groupr.1470 data eg19/ &1.000010d-05,1.000000d-01,5.400000d-01,4.000000d+00,8.315287d+00, &1.370959d+01,2.260329d+01,4.016900d+01,6.790405d+01,9.166088d+01, &1.486254d+02,3.043248d+02,4.539993d+02,7.485183d+02,1.234098d+03, &2.034684d+03,3.354626d+03,5.530844d+03,9.118820d+03,1.503439d+04, &2.478752d+04,4.086771d+04,6.737947d+04,1.110900d+05,1.831564d+05, &3.019738d+05,4.978707d+05,8.208500d+05,1.353353d+06,2.231302d+06, &3.678794d+06,6.065307d+06,1.000000d+07,1.964033d+07/ data eg20a/ &1.000010d-05,3.000000d-03,5.000000d-03,6.900000d-03,1.000000d-02, &1.500000d-02,2.000000d-02,2.500000d-02,3.000000d-02,3.500000d-02, &4.200000d-02,5.000000d-02,5.800000d-02,6.700000d-02,7.700000d-02, &8.000000d-02,9.500000d-02,1.000000d-01,1.150000d-01,1.340000d-01, &1.400000d-01,1.463700d-01,1.530300d-01,1.600000d-01,1.697100d-01, &1.800000d-01,1.890000d-01,1.988100d-01,2.091400d-01,2.200000d-01, &2.335800d-01,2.480000d-01,2.635100d-01,2.800000d-01,3.000000d-01, &3.145000d-01,3.200000d-01,3.346600d-01,3.500000d-01,3.699300d-01, &3.910000d-01,4.000000d-01,4.139900d-01,4.330000d-01,4.496800d-01, &4.670100d-01,4.850000d-01,5.000000d-01,5.196200d-01,5.315800d-01, &5.400000d-01,5.669600d-01,5.952800d-01,6.250000d-01,6.531500d-01, &6.825600d-01,7.050000d-01,7.415500d-01,7.800000d-01,7.900000d-01, &8.194500d-01,8.500000d-01,8.600000d-01,8.764250d-01,9.100000d-01, &9.300000d-01,9.500000d-01,9.720000d-01,9.860000d-01,9.960000d-01, &1.020000d+00,1.035000d+00,1.045000d+00,1.071000d+00,1.080000d+00, &1.097000d+00,1.110000d+00,1.123000d+00,1.150000d+00,1.170000d+00, &1.202060d+00,1.235000d+00,1.267080d+00,1.300000d+00,1.337500d+00, &1.370000d+00,1.404560d+00,1.440000d+00,1.475000d+00,1.500000d+00, &1.544340d+00,1.590000d+00,1.629510d+00,1.670000d+00,1.711970d+00/ data eg20b/ &1.755000d+00,1.797000d+00,1.840000d+00,1.855390d+00,1.884460d+00, &1.930000d+00,1.974490d+00,2.020000d+00,2.059610d+00,2.100000d+00, &2.130000d+00,2.185310d+00,2.242050d+00,2.300270d+00,2.360000d+00, &2.382370d+00,2.421710d+00,2.485030d+00,2.550000d+00,2.600000d+00, &2.659320d+00,2.720000d+00,2.767920d+00,2.837990d+00,2.909830d+00, &2.983490d+00,3.059020d+00,3.137330d+00,3.217630d+00,3.300000d+00, &3.380750d+00,3.466330d+00,3.554080d+00,3.644050d+00,3.736300d+00, &3.830880d+00,3.927860d+00,4.000000d+00,4.129250d+00,4.233782d+00, &4.340961d+00,4.450853d+00,4.563526d+00,4.679053d+00,4.797503d+00, &4.918953d+00,5.043477d+00,5.085681d+00,5.128239d+00,5.171153d+00, &5.214426d+00,5.258061d+00,5.302061d+00,5.346430d+00,5.391169d+00, &5.436284d+00,5.481775d+00,5.527647d+00,5.573904d+00,5.620547d+00, &5.667581d+00,5.715008d+00,5.762832d+00,5.811056d+00,5.859684d+00, &5.908719d+00,5.958164d+00,6.008022d+00,6.058298d+00,6.108995d+00, &6.160116d+00,6.211665d+00,6.263645d+00,6.316060d+00,6.368914d+00, &6.422210d+00,6.475952d+00,6.530144d+00,6.584789d+00,6.639892d+00, &6.695455d+00,6.751484d+00,6.807981d+00,6.864952d+00,6.922399d+00, &6.980326d+00,7.038739d+00,7.097640d+00,7.157034d+00,7.216925d+00, &7.277317d+00,7.338215d+00,7.399622d+00,7.461544d+00,7.523983d+00/ data eg20c/ &7.586945d+00,7.650434d+00,7.714454d+00,7.779009d+00,7.844105d+00, &7.909746d+00,7.975936d+00,8.042680d+00,8.109982d+00,8.177848d+00, &8.246281d+00,8.315287d+00,8.384871d+00,8.455037d+00,8.525790d+00, &8.597135d+00,8.669077d+00,8.741621d+00,8.814772d+00,8.888536d+00, &8.962916d+00,9.037919d+00,9.113550d+00,9.189814d+00,9.266715d+00, &9.344261d+00,9.422455d+00,9.501303d+00,9.580812d+00,9.660985d+00, &9.741830d+00,9.823351d+00,9.905554d+00,9.988446d+00,1.007203d+01, &1.015631d+01,1.024130d+01,1.032701d+01,1.041342d+01,1.050056d+01, &1.058843d+01,1.067704d+01,1.076639d+01,1.085648d+01,1.094733d+01, &1.103894d+01,1.113132d+01,1.122446d+01,1.131839d+01,1.141311d+01, &1.150861d+01,1.160492d+01,1.170203d+01,1.179995d+01,1.189870d+01, &1.199827d+01,1.209867d+01,1.219991d+01,1.230201d+01,1.240495d+01, &1.250876d+01,1.261343d+01,1.271898d+01,1.282542d+01,1.293274d+01, &1.304097d+01,1.315010d+01,1.326014d+01,1.337110d+01,1.348299d+01, &1.359582d+01,1.370959d+01,1.382431d+01,1.394000d+01,1.405665d+01, &1.417428d+01,1.429289d+01,1.441250d+01,1.453310d+01,1.465472d+01, &1.477735d+01,1.490101d+01,1.502570d+01,1.515144d+01,1.527823d+01, &1.540608d+01,1.553500d+01,1.566500d+01,1.579609d+01,1.592827d+01, &1.606156d+01,1.619597d+01,1.633150d+01,1.646816d+01,1.660597d+01/ data eg20d/ &1.674493d+01,1.688506d+01,1.702635d+01,1.716883d+01,1.731250d+01, &1.745738d+01,1.760346d+01,1.775077d+01,1.789931d+01,1.804910d+01, &1.820013d+01,1.835244d+01,1.850601d+01,1.866087d+01,1.881703d+01, &1.897449d+01,1.913328d+01,1.929339d+01,1.945484d+01,1.961764d+01, &1.978180d+01,1.994734d+01,2.011426d+01,2.028258d+01,2.045231d+01, &2.062345d+01,2.079603d+01,2.097006d+01,2.114554d+01,2.132249d+01, &2.150092d+01,2.168084d+01,2.186227d+01,2.204522d+01,2.222969d+01, &2.241572d+01,2.260329d+01,2.279244d+01,2.298317d+01,2.317550d+01, &2.336944d+01,2.356499d+01,2.376219d+01,2.396104d+01,2.416154d+01, &2.436373d+01,2.456761d+01,2.477320d+01,2.498050d+01,2.518954d+01, &2.540033d+01,2.561289d+01,2.582722d+01,2.604335d+01,2.626128d+01, &2.648104d+01,2.670264d+01,2.692609d+01,2.715141d+01,2.737862d+01, &2.760773d+01,2.783875d+01,2.807171d+01,2.830662d+01,2.854349d+01, &2.878235d+01,2.902320d+01,2.926607d+01,2.951098d+01,2.975793d+01, &3.000695d+01,3.025805d+01,3.051126d+01,3.076658d+01,3.102404d+01, &3.128365d+01,3.154544d+01,3.180942d+01,3.207560d+01,3.234401d+01, &3.261467d+01,3.288760d+01,3.316281d+01,3.344032d+01,3.372015d+01, &3.400233d+01,3.428686d+01,3.457378d+01,3.486310d+01,3.515484d+01, &3.544902d+01,3.574566d+01,3.604479d+01,3.634642d+01,3.665057d+01/ data eg20e/ &3.695727d+01,3.726653d+01,3.757838d+01,3.789285d+01,3.820994d+01, &3.852969d+01,3.885211d+01,3.917723d+01,3.950507d+01,3.983565d+01, &4.016900d+01,4.050514d+01,4.084410d+01,4.118589d+01,4.153054d+01, &4.187807d+01,4.222851d+01,4.258189d+01,4.293822d+01,4.329753d+01, &4.365985d+01,4.402521d+01,4.439361d+01,4.476511d+01,4.513971d+01, &4.551744d+01,4.589834d+01,4.628243d+01,4.666972d+01,4.706026d+01, &4.745407d+01,4.785117d+01,4.825160d+01,4.865538d+01,4.906253d+01, &4.947309d+01,4.988709d+01,5.030456d+01,5.072551d+01,5.114999d+01, &5.157802d+01,5.200963d+01,5.244486d+01,5.288373d+01,5.332626d+01, &5.377251d+01,5.422248d+01,5.467623d+01,5.513376d+01,5.559513d+01, &5.606036d+01,5.652948d+01,5.700253d+01,5.747954d+01,5.796053d+01, &5.844556d+01,5.893464d+01,5.942781d+01,5.992511d+01,6.042657d+01, &6.093223d+01,6.144212d+01,6.195628d+01,6.247474d+01,6.299754d+01, &6.352471d+01,6.405630d+01,6.459233d+01,6.513285d+01,6.567789d+01, &6.622749d+01,6.678169d+01,6.734053d+01,6.790405d+01,6.847228d+01, &6.904527d+01,6.962305d+01,7.020566d+01,7.079316d+01,7.138556d+01, &7.198293d+01,7.258529d+01,7.319270d+01,7.380518d+01,7.442280d+01, &7.504558d+01,7.567357d+01,7.630682d+01,7.694537d+01,7.758926d+01, &7.823854d+01,7.889325d+01,7.955344d+01,8.021915d+01,8.089044d+01/ data eg20f/ &8.156734d+01,8.224991d+01,8.293819d+01,8.363223d+01,8.433208d+01, &8.503778d+01,8.574939d+01,8.646695d+01,8.719052d+01,8.792015d+01, &8.865588d+01,8.939776d+01,9.014586d+01,9.090021d+01,9.166088d+01, &9.242791d+01,9.320136d+01,9.398128d+01,9.476773d+01,9.556076d+01, &9.636043d+01,9.716679d+01,9.797990d+01,9.879981d+01,9.962658d+01, &1.004603d+02,1.013009d+02,1.021486d+02,1.030034d+02,1.038654d+02, &1.047345d+02,1.056110d+02,1.064947d+02,1.073859d+02,1.082845d+02, &1.091907d+02,1.101044d+02,1.110258d+02,1.119548d+02,1.128917d+02, &1.138364d+02,1.147890d+02,1.157496d+02,1.167182d+02,1.176949d+02, &1.186798d+02,1.196729d+02,1.206744d+02,1.216842d+02,1.227024d+02, &1.237292d+02,1.247646d+02,1.258087d+02,1.268615d+02,1.279231d+02, &1.289935d+02,1.300730d+02,1.311615d+02,1.322590d+02,1.333658d+02, &1.344818d+02,1.356072d+02,1.367420d+02,1.378862d+02,1.390401d+02, &1.402036d+02,1.413768d+02,1.425599d+02,1.437529d+02,1.449558d+02, &1.461688d+02,1.473920d+02,1.486254d+02,1.498691d+02,1.511232d+02, &1.523879d+02,1.536631d+02,1.549489d+02,1.562456d+02,1.575531d+02, &1.588715d+02,1.602010d+02,1.615415d+02,1.628933d+02,1.642565d+02, &1.656310d+02,1.670170d+02,1.684146d+02,1.698239d+02,1.712451d+02, &1.726781d+02,1.741231d+02,1.755802d+02,1.770494d+02,1.785310d+02/ data eg20g/ &1.800250d+02,1.815315d+02,1.830505d+02,1.845823d+02,1.861269d+02, &1.876845d+02,1.892551d+02,1.908388d+02,1.924358d+02,1.940461d+02, &1.956699d+02,1.973073d+02,1.989584d+02,2.006233d+02,2.023021d+02, &2.039950d+02,2.057021d+02,2.074234d+02,2.091592d+02,2.109095d+02, &2.126744d+02,2.144541d+02,2.162487d+02,2.180583d+02,2.198830d+02, &2.217230d+02,2.235784d+02,2.254494d+02,2.273360d+02,2.292384d+02, &2.311567d+02,2.330910d+02,2.350416d+02,2.370084d+02,2.389917d+02, &2.409917d+02,2.430083d+02,2.450418d+02,2.470924d+02,2.491601d+02, &2.512451d+02,2.533476d+02,2.554676d+02,2.576054d+02,2.597611d+02, &2.619348d+02,2.641267d+02,2.663370d+02,2.685657d+02,2.708131d+02, &2.730793d+02,2.753645d+02,2.776688d+02,2.799924d+02,2.823354d+02, &2.846980d+02,2.870804d+02,2.894827d+02,2.919052d+02,2.943479d+02, &2.968110d+02,2.992948d+02,3.017993d+02,3.043248d+02,3.068715d+02, &3.094394d+02,3.120288d+02,3.146399d+02,3.172729d+02,3.199279d+02, &3.226051d+02,3.253047d+02,3.280269d+02,3.307719d+02,3.335398d+02, &3.363309d+02,3.391454d+02,3.419834d+02,3.448452d+02,3.477309d+02, &3.506408d+02,3.535750d+02,3.565338d+02,3.595173d+02,3.625258d+02, &3.655595d+02,3.686185d+02,3.717032d+02,3.748137d+02,3.779502d+02, &3.811129d+02,3.843021d+02,3.875180d+02,3.907608d+02,3.940308d+02/ data eg20h/ &3.973281d+02,4.006530d+02,4.040057d+02,4.073865d+02,4.107955d+02, &4.142332d+02,4.176995d+02,4.211949d+02,4.247195d+02,4.282736d+02, &4.318575d+02,4.354713d+02,4.391154d+02,4.427900d+02,4.464953d+02, &4.502317d+02,4.539993d+02,4.577984d+02,4.616294d+02,4.654923d+02, &4.693877d+02,4.733156d+02,4.772763d+02,4.812703d+02,4.852976d+02, &4.893587d+02,4.934537d+02,4.975830d+02,5.017468d+02,5.059455d+02, &5.101793d+02,5.144486d+02,5.187536d+02,5.230946d+02,5.274719d+02, &5.318859d+02,5.363368d+02,5.408249d+02,5.453506d+02,5.499142d+02, &5.545160d+02,5.591563d+02,5.638354d+02,5.685536d+02,5.733114d+02, &5.781089d+02,5.829466d+02,5.878248d+02,5.927438d+02,5.977040d+02, &6.027057d+02,6.077492d+02,6.128350d+02,6.179633d+02,6.231345d+02, &6.283489d+02,6.336071d+02,6.389092d+02,6.442557d+02,6.496469d+02, &6.550832d+02,6.605651d+02,6.660928d+02,6.716668d+02,6.772874d+02, &6.829550d+02,6.886701d+02,6.944330d+02,7.002441d+02,7.061038d+02, &7.120126d+02,7.179709d+02,7.239790d+02,7.300373d+02,7.361464d+02, &7.423066d+02,7.485183d+02,7.547820d+02,7.610981d+02,7.674671d+02, &7.738894d+02,7.803654d+02,7.868957d+02,7.934805d+02,8.001205d+02, &8.068160d+02,8.135676d+02,8.203756d+02,8.272407d+02,8.341631d+02, &8.411435d+02,8.481824d+02,8.552801d+02,8.624372d+02,8.696542d+02/ data eg20i/ &8.769316d+02,8.842699d+02,8.916696d+02,8.991312d+02,9.066553d+02, &9.142423d+02,9.218928d+02,9.296074d+02,9.373865d+02,9.452307d+02, &9.531405d+02,9.611165d+02,9.691593d+02,9.772694d+02,9.854473d+02, &9.936937d+02,1.002009d+03,1.010394d+03,1.018849d+03,1.027375d+03, &1.035972d+03,1.044641d+03,1.053383d+03,1.062198d+03,1.071087d+03, &1.080050d+03,1.089088d+03,1.098201d+03,1.107391d+03,1.116658d+03, &1.126002d+03,1.135425d+03,1.144926d+03,1.154507d+03,1.164168d+03, &1.173910d+03,1.183734d+03,1.193639d+03,1.203628d+03,1.213700d+03, &1.223857d+03,1.234098d+03,1.244425d+03,1.254839d+03,1.265339d+03, &1.275928d+03,1.286605d+03,1.297372d+03,1.308228d+03,1.319176d+03, &1.330215d+03,1.341346d+03,1.352571d+03,1.363889d+03,1.375303d+03, &1.386811d+03,1.398416d+03,1.410118d+03,1.421919d+03,1.433817d+03, &1.445816d+03,1.457915d+03,1.470115d+03,1.482417d+03,1.494822d+03, &1.507331d+03,1.519944d+03,1.532663d+03,1.545489d+03,1.558422d+03, &1.571463d+03,1.584613d+03,1.597874d+03,1.611245d+03,1.624728d+03, &1.638324d+03,1.652034d+03,1.665858d+03,1.679798d+03,1.693855d+03, &1.708030d+03,1.722323d+03,1.736735d+03,1.751268d+03,1.765923d+03, &1.780701d+03,1.795602d+03,1.810628d+03,1.825780d+03,1.841058d+03, &1.856464d+03,1.871999d+03,1.887665d+03,1.903461d+03,1.919389d+03/ data eg20j/ &1.935451d+03,1.951647d+03,1.967979d+03,1.984447d+03,2.001053d+03, &2.017798d+03,2.034684d+03,2.051710d+03,2.068879d+03,2.086192d+03, &2.103650d+03,2.121253d+03,2.139004d+03,2.156904d+03,2.174953d+03, &2.193153d+03,2.211506d+03,2.230012d+03,2.248673d+03,2.267490d+03, &2.286465d+03,2.305599d+03,2.324892d+03,2.344347d+03,2.363965d+03, &2.383747d+03,2.403695d+03,2.423809d+03,2.444092d+03,2.464545d+03, &2.485168d+03,2.505965d+03,2.526935d+03,2.548081d+03,2.569403d+03, &2.590904d+03,2.612586d+03,2.634448d+03,2.656494d+03,2.678723d+03, &2.701139d+03,2.723743d+03,2.746536d+03,2.769519d+03,2.792695d+03, &2.816065d+03,2.839630d+03,2.863392d+03,2.887354d+03,2.911515d+03, &2.935879d+03,2.960447d+03,2.985221d+03,3.010202d+03,3.035391d+03, &3.060792d+03,3.086405d+03,3.112233d+03,3.138276d+03,3.164538d+03, &3.191019d+03,3.217722d+03,3.244649d+03,3.271800d+03,3.299179d+03, &3.326787d+03,3.354626d+03,3.382698d+03,3.411005d+03,3.439549d+03, &3.468332d+03,3.497355d+03,3.526622d+03,3.556133d+03,3.585891d+03, &3.615898d+03,3.646157d+03,3.676668d+03,3.707435d+03,3.738460d+03, &3.769744d+03,3.801290d+03,3.833099d+03,3.865175d+03,3.897520d+03, &3.930135d+03,3.963023d+03,3.996186d+03,4.029627d+03,4.063347d+03, &4.097350d+03,4.131637d+03,4.166211d+03,4.201075d+03,4.236230d+03/ data eg20k/ &4.271679d+03,4.307425d+03,4.343471d+03,4.379817d+03,4.416468d+03, &4.453426d+03,4.490693d+03,4.528272d+03,4.566165d+03,4.604375d+03, &4.642906d+03,4.681758d+03,4.720936d+03,4.760441d+03,4.800277d+03, &4.840447d+03,4.880952d+03,4.921797d+03,4.962983d+03,5.004514d+03, &5.046393d+03,5.088622d+03,5.131204d+03,5.174143d+03,5.217441d+03, &5.261101d+03,5.305127d+03,5.349521d+03,5.394287d+03,5.439427d+03, &5.484945d+03,5.530844d+03,5.577127d+03,5.623797d+03,5.670858d+03, &5.718312d+03,5.766164d+03,5.814416d+03,5.863072d+03,5.912135d+03, &5.961609d+03,6.011496d+03,6.061802d+03,6.112528d+03,6.163678d+03, &6.215257d+03,6.267267d+03,6.319712d+03,6.372597d+03,6.425924d+03, &6.479697d+03,6.533920d+03,6.588597d+03,6.643731d+03,6.699327d+03, &6.755388d+03,6.811918d+03,6.868921d+03,6.926401d+03,6.984362d+03, &7.042809d+03,7.101744d+03,7.161172d+03,7.221098d+03,7.281525d+03, &7.342458d+03,7.403901d+03,7.465858d+03,7.528334d+03,7.591332d+03, &7.654857d+03,7.718914d+03,7.783507d+03,7.848641d+03,7.914319d+03, &7.980548d+03,8.047330d+03,8.114671d+03,8.182576d+03,8.251049d+03, &8.320095d+03,8.389719d+03,8.459926d+03,8.530719d+03,8.602106d+03, &8.674090d+03,8.746676d+03,8.819869d+03,8.893675d+03,8.968099d+03, &9.043145d+03,9.118820d+03,9.195127d+03,9.272074d+03,9.349664d+03/ data eg20l/ &9.427903d+03,9.506797d+03,9.586352d+03,9.666572d+03,9.747463d+03, &9.829031d+03,9.911282d+03,9.994221d+03,1.007785d+04,1.016219d+04, &1.024723d+04,1.033298d+04,1.041944d+04,1.050664d+04,1.059456d+04, &1.068321d+04,1.077261d+04,1.086276d+04,1.095366d+04,1.104532d+04, &1.113775d+04,1.123095d+04,1.132494d+04,1.141970d+04,1.151527d+04, &1.161163d+04,1.170880d+04,1.180678d+04,1.190558d+04,1.200521d+04, &1.210567d+04,1.220697d+04,1.230912d+04,1.241212d+04,1.251599d+04, &1.262073d+04,1.272634d+04,1.283283d+04,1.294022d+04,1.304851d+04, &1.315770d+04,1.326780d+04,1.337883d+04,1.349079d+04,1.360368d+04, &1.371752d+04,1.383231d+04,1.394806d+04,1.406478d+04,1.418247d+04, &1.430116d+04,1.442083d+04,1.454151d+04,1.466319d+04,1.478590d+04, &1.490963d+04,1.503439d+04,1.516020d+04,1.528706d+04,1.541499d+04, &1.554398d+04,1.567406d+04,1.580522d+04,1.593748d+04,1.607085d+04, &1.620533d+04,1.634094d+04,1.647768d+04,1.661557d+04,1.675461d+04, &1.689482d+04,1.703620d+04,1.717876d+04,1.732251d+04,1.746747d+04, &1.761364d+04,1.776104d+04,1.790966d+04,1.805953d+04,1.821066d+04, &1.836305d+04,1.851671d+04,1.867166d+04,1.882791d+04,1.898547d+04, &1.914434d+04,1.930454d+04,1.946608d+04,1.962898d+04,1.979324d+04, &1.995887d+04,2.012589d+04,2.029431d+04,2.046413d+04,2.063538d+04/ data eg20m/ &2.080806d+04,2.098218d+04,2.115777d+04,2.133482d+04,2.151335d+04, &2.169338d+04,2.187491d+04,2.205796d+04,2.224255d+04,2.242868d+04, &2.261636d+04,2.280562d+04,2.299646d+04,2.318890d+04,2.338295d+04, &2.357862d+04,2.377593d+04,2.397489d+04,2.417552d+04,2.437782d+04, &2.458182d+04,2.478752d+04,2.499495d+04,2.520411d+04,2.541502d+04, &2.562770d+04,2.584215d+04,2.605841d+04,2.627647d+04,2.649635d+04, &2.671808d+04,2.694166d+04,2.700000d+04,2.716711d+04,2.739445d+04, &2.762369d+04,2.785485d+04,2.808794d+04,2.832299d+04,2.850000d+04, &2.856000d+04,2.879899d+04,2.903999d+04,2.928300d+04,2.952804d+04, &2.977514d+04,3.002430d+04,3.027555d+04,3.052890d+04,3.078437d+04, &3.104198d+04,3.130174d+04,3.156368d+04,3.182781d+04,3.209415d+04, &3.236272d+04,3.263353d+04,3.290662d+04,3.318198d+04,3.345965d+04, &3.373965d+04,3.402199d+04,3.430669d+04,3.459377d+04,3.488326d+04, &3.517517d+04,3.546952d+04,3.576633d+04,3.606563d+04,3.636743d+04, &3.667176d+04,3.697864d+04,3.728808d+04,3.760011d+04,3.791476d+04, &3.823203d+04,3.855196d+04,3.887457d+04,3.919988d+04,3.952791d+04, &3.985869d+04,4.019223d+04,4.052857d+04,4.086771d+04,4.120970d+04, &4.155455d+04,4.190229d+04,4.225293d+04,4.260651d+04,4.296305d+04, &4.332257d+04,4.368510d+04,4.405066d+04,4.441928d+04,4.479099d+04/ data eg20n/ &4.516581d+04,4.554376d+04,4.592488d+04,4.630919d+04,4.669671d+04, &4.708747d+04,4.748151d+04,4.787884d+04,4.827950d+04,4.868351d+04, &4.909090d+04,4.950170d+04,4.991594d+04,5.033364d+04,5.075484d+04, &5.117957d+04,5.160785d+04,5.203971d+04,5.247518d+04,5.291430d+04, &5.335710d+04,5.380360d+04,5.425384d+04,5.470784d+04,5.516564d+04, &5.562728d+04,5.609278d+04,5.656217d+04,5.703549d+04,5.751277d+04, &5.799405d+04,5.847935d+04,5.896871d+04,5.946217d+04,5.995976d+04, &6.046151d+04,6.096747d+04,6.147765d+04,6.199211d+04,6.251086d+04, &6.303396d+04,6.356144d+04,6.409333d+04,6.462968d+04,6.517051d+04, &6.571586d+04,6.626579d+04,6.682031d+04,6.737947d+04,6.794331d+04, &6.851187d+04,6.908519d+04,6.966330d+04,7.024626d+04,7.083409d+04, &7.142684d+04,7.202455d+04,7.262726d+04,7.323502d+04,7.384786d+04, &7.446583d+04,7.508897d+04,7.571733d+04,7.635094d+04,7.698986d+04, &7.763412d+04,7.828378d+04,7.893887d+04,7.950000d+04,7.959944d+04, &8.026554d+04,8.093721d+04,8.161451d+04,8.229747d+04,8.250000d+04, &8.298615d+04,8.368059d+04,8.438084d+04,8.508695d+04,8.579897d+04, &8.651695d+04,8.724094d+04,8.797098d+04,8.870714d+04,8.944945d+04, &9.019798d+04,9.095277d+04,9.171388d+04,9.248135d+04,9.325525d+04, &9.403563d+04,9.482253d+04,9.561602d+04,9.641615d+04,9.722297d+04/ data eg20o/ &9.803655d+04,9.885694d+04,9.968419d+04,1.005184d+05,1.013595d+05, &1.022077d+05,1.030630d+05,1.039254d+05,1.047951d+05,1.056720d+05, &1.065563d+05,1.074480d+05,1.083471d+05,1.092538d+05,1.101681d+05, &1.110900d+05,1.120196d+05,1.129570d+05,1.139022d+05,1.148554d+05, &1.158165d+05,1.167857d+05,1.177629d+05,1.187484d+05,1.197421d+05, &1.207441d+05,1.217545d+05,1.227734d+05,1.238008d+05,1.248368d+05, &1.258814d+05,1.269348d+05,1.279970d+05,1.290681d+05,1.301482d+05, &1.312373d+05,1.323355d+05,1.334429d+05,1.345596d+05,1.356856d+05, &1.368210d+05,1.379660d+05,1.391205d+05,1.402847d+05,1.414586d+05, &1.426423d+05,1.438360d+05,1.450396d+05,1.462533d+05,1.474772d+05, &1.487113d+05,1.499558d+05,1.512106d+05,1.524760d+05,1.537519d+05, &1.550385d+05,1.563359d+05,1.576442d+05,1.589634d+05,1.602936d+05, &1.616349d+05,1.629875d+05,1.643514d+05,1.657268d+05,1.671136d+05, &1.685120d+05,1.699221d+05,1.713441d+05,1.727779d+05,1.742237d+05, &1.756817d+05,1.771518d+05,1.786342d+05,1.801291d+05,1.816364d+05, &1.831564d+05,1.846891d+05,1.862346d+05,1.877930d+05,1.893645d+05, &1.909491d+05,1.925470d+05,1.941583d+05,1.957830d+05,1.974214d+05, &1.990734d+05,2.007393d+05,2.024191d+05,2.041130d+05,2.058210d+05, &2.075434d+05,2.092801d+05,2.110314d+05,2.127974d+05,2.145781d+05/ data eg20p/ &2.163737d+05,2.181844d+05,2.200102d+05,2.218512d+05,2.237077d+05, &2.255797d+05,2.274674d+05,2.293709d+05,2.312903d+05,2.332258d+05, &2.351775d+05,2.371455d+05,2.391299d+05,2.411310d+05,2.431488d+05, &2.451835d+05,2.472353d+05,2.493042d+05,2.513904d+05,2.534941d+05, &2.556153d+05,2.577544d+05,2.599113d+05,2.620863d+05,2.642794d+05, &2.664910d+05,2.687210d+05,2.709697d+05,2.732372d+05,2.755237d+05, &2.778293d+05,2.801543d+05,2.824986d+05,2.848626d+05,2.872464d+05, &2.896501d+05,2.920740d+05,2.945181d+05,2.969826d+05,2.972000d+05, &2.985000d+05,2.994678d+05,3.019738d+05,3.045008d+05,3.070489d+05, &3.096183d+05,3.122093d+05,3.148219d+05,3.174564d+05,3.201129d+05, &3.227916d+05,3.254928d+05,3.282166d+05,3.309631d+05,3.337327d+05, &3.365254d+05,3.393415d+05,3.421812d+05,3.450446d+05,3.479320d+05, &3.508435d+05,3.537795d+05,3.567399d+05,3.597252d+05,3.627354d+05, &3.657708d+05,3.688317d+05,3.719181d+05,3.750304d+05,3.781687d+05, &3.813333d+05,3.845243d+05,3.877421d+05,3.909868d+05,3.942586d+05, &3.975578d+05,4.008846d+05,4.042393d+05,4.076220d+05,4.110331d+05, &4.144727d+05,4.179410d+05,4.214384d+05,4.249651d+05,4.285213d+05, &4.321072d+05,4.357231d+05,4.393693d+05,4.430460d+05,4.467535d+05, &4.504920d+05,4.542618d+05,4.580631d+05,4.618963d+05,4.657615d+05/ data eg20q/ &4.696591d+05,4.735892d+05,4.775523d+05,4.815485d+05,4.855782d+05, &4.896416d+05,4.937390d+05,4.978707d+05,5.020369d+05,5.062381d+05, &5.104743d+05,5.147461d+05,5.190535d+05,5.233971d+05,5.277769d+05, &5.321934d+05,5.366469d+05,5.411377d+05,5.456660d+05,5.502322d+05, &5.548366d+05,5.594796d+05,5.641614d+05,5.688824d+05,5.736429d+05, &5.784432d+05,5.832837d+05,5.881647d+05,5.930866d+05,5.980496d+05, &6.030542d+05,6.081006d+05,6.131893d+05,6.183206d+05,6.234948d+05, &6.287123d+05,6.339734d+05,6.392786d+05,6.446282d+05,6.500225d+05, &6.554620d+05,6.609470d+05,6.664779d+05,6.720551d+05,6.776790d+05, &6.833499d+05,6.890683d+05,6.948345d+05,7.006490d+05,7.065121d+05, &7.124243d+05,7.183860d+05,7.243976d+05,7.304594d+05,7.365720d+05, &7.427358d+05,7.489511d+05,7.552184d+05,7.615382d+05,7.679109d+05, &7.743369d+05,7.808167d+05,7.873507d+05,7.939393d+05,8.005831d+05, &8.072825d+05,8.140380d+05,8.208500d+05,8.277190d+05,8.346455d+05, &8.416299d+05,8.486728d+05,8.557746d+05,8.629359d+05,8.701570d+05, &8.774387d+05,8.847812d+05,8.921852d+05,8.996511d+05,9.071795d+05, &9.147709d+05,9.224259d+05,9.301449d+05,9.379285d+05,9.457772d+05, &9.536916d+05,9.616723d+05,9.697197d+05,9.778344d+05,9.860171d+05, &9.942682d+05,1.002588d+06,1.010978d+06,1.019438d+06,1.027969d+06/ data eg20r/ &1.036571d+06,1.045245d+06,1.053992d+06,1.062812d+06,1.071706d+06, &1.080674d+06,1.089717d+06,1.098836d+06,1.108032d+06,1.117304d+06, &1.126654d+06,1.136082d+06,1.145588d+06,1.155175d+06,1.164842d+06, &1.174589d+06,1.184418d+06,1.194330d+06,1.204324d+06,1.214402d+06, &1.224564d+06,1.234812d+06,1.245145d+06,1.255564d+06,1.266071d+06, &1.276666d+06,1.287349d+06,1.298122d+06,1.308985d+06,1.319938d+06, &1.330984d+06,1.342122d+06,1.353353d+06,1.364678d+06,1.376098d+06, &1.387613d+06,1.399225d+06,1.410934d+06,1.422741d+06,1.434646d+06, &1.446652d+06,1.458758d+06,1.470965d+06,1.483274d+06,1.495686d+06, &1.508202d+06,1.520823d+06,1.533550d+06,1.546383d+06,1.559323d+06, &1.572372d+06,1.585530d+06,1.598797d+06,1.612176d+06,1.625667d+06, &1.639271d+06,1.652989d+06,1.666821d+06,1.680770d+06,1.694834d+06, &1.709017d+06,1.723318d+06,1.737739d+06,1.752281d+06,1.766944d+06, &1.781731d+06,1.796640d+06,1.811675d+06,1.826835d+06,1.842122d+06, &1.857538d+06,1.873082d+06,1.888756d+06,1.904561d+06,1.920499d+06, &1.936570d+06,1.952776d+06,1.969117d+06,1.985595d+06,2.002210d+06, &2.018965d+06,2.035860d+06,2.052897d+06,2.070076d+06,2.087398d+06, &2.104866d+06,2.122480d+06,2.140241d+06,2.158151d+06,2.176211d+06, &2.194421d+06,2.212785d+06,2.231302d+06,2.249973d+06,2.268802d+06/ data eg20s/ &2.287787d+06,2.306932d+06,2.326237d+06,2.345703d+06,2.365332d+06, &2.385126d+06,2.405085d+06,2.425211d+06,2.445505d+06,2.465970d+06, &2.486605d+06,2.507414d+06,2.528396d+06,2.549554d+06,2.570889d+06, &2.592403d+06,2.614096d+06,2.635971d+06,2.658030d+06,2.680272d+06, &2.702701d+06,2.725318d+06,2.748124d+06,2.771121d+06,2.794310d+06, &2.817693d+06,2.841272d+06,2.865048d+06,2.889023d+06,2.913199d+06, &2.937577d+06,2.962159d+06,2.986947d+06,3.011942d+06,3.037147d+06, &3.062562d+06,3.088190d+06,3.114032d+06,3.140091d+06,3.166368d+06, &3.192864d+06,3.219583d+06,3.246525d+06,3.273692d+06,3.301087d+06, &3.328711d+06,3.356566d+06,3.384654d+06,3.412978d+06,3.441538d+06, &3.470337d+06,3.499377d+06,3.528661d+06,3.558189d+06,3.587965d+06, &3.617989d+06,3.648265d+06,3.678794d+06,3.709579d+06,3.740621d+06, &3.771924d+06,3.803488d+06,3.835316d+06,3.867410d+06,3.899773d+06, &3.932407d+06,3.965314d+06,3.998497d+06,4.031957d+06,4.065697d+06, &4.099719d+06,4.134026d+06,4.168620d+06,4.203504d+06,4.238679d+06, &4.274149d+06,4.309916d+06,4.345982d+06,4.382350d+06,4.419022d+06, &4.456001d+06,4.493290d+06,4.530890d+06,4.568805d+06,4.607038d+06, &4.645590d+06,4.684465d+06,4.723666d+06,4.763194d+06,4.803053d+06, &4.843246d+06,4.883775d+06,4.924643d+06,4.965853d+06,5.007408d+06/ data eg20t/ &5.049311d+06,5.091564d+06,5.134171d+06,5.177135d+06,5.220458d+06, &5.264143d+06,5.308195d+06,5.352614d+06,5.397406d+06,5.442572d+06, &5.488116d+06,5.534042d+06,5.580351d+06,5.627049d+06,5.674137d+06, &5.721619d+06,5.769498d+06,5.817778d+06,5.866462d+06,5.915554d+06, &5.965056d+06,6.014972d+06,6.065307d+06,6.116062d+06,6.167242d+06, &6.218851d+06,6.270891d+06,6.323367d+06,6.376282d+06,6.429639d+06, &6.483443d+06,6.537698d+06,6.592406d+06,6.647573d+06,6.703200d+06, &6.759294d+06,6.815857d+06,6.872893d+06,6.930406d+06,6.988401d+06, &7.046881d+06,7.105850d+06,7.165313d+06,7.225274d+06,7.285736d+06, &7.346704d+06,7.408182d+06,7.470175d+06,7.532687d+06,7.595721d+06, &7.659283d+06,7.723377d+06,7.788008d+06,7.853179d+06,7.918896d+06, &7.985162d+06,8.051983d+06,8.119363d+06,8.187308d+06,8.255820d+06, &8.324906d+06,8.394570d+06,8.464817d+06,8.535652d+06,8.607080d+06, &8.679105d+06,8.751733d+06,8.824969d+06,8.898818d+06,8.973284d+06, &9.048374d+06,9.124092d+06,9.200444d+06,9.277435d+06,9.355070d+06, &9.433354d+06,9.512294d+06,9.591895d+06,9.672161d+06,9.753099d+06, &9.834715d+06,9.917013d+06,1.000000d+07,1.008368d+07,1.016806d+07, &1.025315d+07,1.033895d+07,1.042547d+07,1.051271d+07,1.060068d+07, &1.068939d+07,1.077884d+07,1.086904d+07,1.095999d+07,1.105171d+07/ data eg20u/ &1.114419d+07,1.123745d+07,1.133148d+07,1.142631d+07,1.152193d+07, &1.161834d+07,1.171557d+07,1.181360d+07,1.191246d+07,1.201215d+07, &1.211267d+07,1.221403d+07,1.231624d+07,1.241930d+07,1.252323d+07, &1.262802d+07,1.273370d+07,1.284025d+07,1.294770d+07,1.305605d+07, &1.316531d+07,1.327548d+07,1.338657d+07,1.349859d+07,1.361155d+07, &1.372545d+07,1.384031d+07,1.395612d+07,1.407291d+07,1.419068d+07, &1.430943d+07,1.442917d+07,1.454991d+07,1.467167d+07,1.479444d+07, &1.491825d+07,1.504309d+07,1.516897d+07,1.529590d+07,1.542390d+07, &1.555297d+07,1.568312d+07,1.581436d+07,1.594670d+07,1.608014d+07, &1.621470d+07,1.635039d+07,1.648721d+07,1.662518d+07,1.676430d+07, &1.690459d+07,1.704605d+07,1.718869d+07,1.733253d+07,1.747757d+07, &1.762383d+07,1.777131d+07,1.792002d+07,1.806998d+07,1.822119d+07, &1.837367d+07,1.852742d+07,1.868246d+07,1.883880d+07,1.899644d+07, &1.915541d+07,1.931570d+07,1.947734d+07,1.964033d+07/ data eg21a/ &1.000010d-05,1.100000d-04,3.000000d-03,5.500100d-03,1.000000d-02, &1.500000d-02,2.000000d-02,3.000000d-02,3.200000d-02,3.238000d-02, &4.300000d-02,5.900100d-02,7.700100d-02,9.500000d-02,1.000000d-01, &1.150000d-01,1.340000d-01,1.600000d-01,1.890000d-01,2.200000d-01, &2.480000d-01,2.825000d-01,3.145000d-01,3.520000d-01,3.910100d-01, &4.139900d-01,4.330000d-01,4.850100d-01,5.315800d-01,5.400100d-01, &6.250100d-01,6.825600d-01,7.050000d-01,7.900100d-01,8.600100d-01, &8.764200d-01,9.300100d-01,9.860100d-01,1.010000d+00,1.035000d+00, &1.070000d+00,1.080000d+00,1.090000d+00,1.110000d+00,1.125400d+00, &1.170000d+00,1.235000d+00,1.305000d+00,1.370000d+00,1.440000d+00, &1.445000d+00,1.510000d+00,1.590000d+00,1.670000d+00,1.755000d+00, &1.840000d+00,1.855400d+00,1.930000d+00,2.020000d+00,2.130000d+00, &2.360000d+00,2.372400d+00,2.767900d+00,3.059000d+00,3.380700d+00, &3.927900d+00,4.129200d+00,4.470000d+00,4.670000d+00,5.043500d+00, &5.623000d+00,6.160100d+00,6.476000d+00,7.079000d+00,7.524000d+00, &7.943000d+00,8.315300d+00,8.913000d+00,9.189800d+00,1.000000d+01, &1.067700d+01,1.122400d+01,1.259000d+01,1.371000d+01,1.522700d+01, &1.674500d+01,1.760300d+01,1.902800d+01,2.045200d+01,2.260300d+01, &2.498000d+01,2.791800d+01,2.920300d+01,3.051100d+01,3.388900d+01/ data eg21b/ &3.726700d+01,3.981000d+01,4.551700d+01,4.785100d+01,5.012000d+01, &5.559500d+01,6.144200d+01,6.310000d+01,6.790400d+01,7.079000d+01, &7.889300d+01,8.527700d+01,9.166100d+01,1.013000d+02,1.122000d+02, &1.300700d+02,1.367400d+02,1.585000d+02,1.670200d+02,1.778000d+02, &2.039900d+02,2.144500d+02,2.430100d+02,2.753600d+02,3.043200d+02, &3.535800d+02,3.981000d+02,4.540000d+02,5.144600d+02,5.829500d+02, &6.310000d+02,6.772900d+02,7.079000d+02,7.485200d+02,8.482000d+02, &9.611200d+02,1.010400d+03,1.116700d+03,1.234100d+03,1.363900d+03, &1.507300d+03,1.584600d+03,1.795600d+03,2.034700d+03,2.113000d+03, &2.248700d+03,2.371000d+03,2.485200d+03,2.612600d+03,2.661000d+03, &2.746500d+03,2.818000d+03,3.035400d+03,3.162000d+03,3.354600d+03, &3.548000d+03,3.707400d+03,3.981000d+03,4.307400d+03,4.642900d+03, &5.004500d+03,5.530800d+03,6.267300d+03,7.101700d+03,7.465900d+03, &8.251000d+03,9.118800d+03,1.007800d+04,1.113800d+04,1.170900d+04, &1.272600d+04,1.383200d+04,1.503400d+04,1.585000d+04,1.661600d+04, &1.778000d+04,1.930500d+04,1.995000d+04,2.054000d+04,2.113000d+04, &2.187500d+04,2.239000d+04,2.304000d+04,2.357900d+04,2.417600d+04, &2.441000d+04,2.478800d+04,2.512000d+04,2.585000d+04,2.605800d+04, &2.661000d+04,2.700000d+04,2.738000d+04,2.818000d+04,2.850000d+04/ data eg21c/ &2.901000d+04,2.985000d+04,3.073000d+04,3.162000d+04,3.182800d+04, &3.430700d+04,3.697900d+04,4.086800d+04,4.358900d+04,4.630900d+04, &4.939200d+04,5.247500d+04,5.516600d+04,5.656200d+04,6.172500d+04, &6.737900d+04,7.200000d+04,7.499000d+04,7.950000d+04,8.229700d+04, &8.250000d+04,8.651700d+04,9.803700d+04,1.110900d+05,1.167900d+05, &1.227700d+05,1.290700d+05,1.356900d+05,1.426400d+05,1.499600d+05, &1.576400d+05,1.657300d+05,1.742200d+05,1.831600d+05,1.925500d+05, &2.024200d+05,2.128000d+05,2.237100d+05,2.351800d+05,2.472400d+05, &2.732400d+05,2.872500d+05,2.945200d+05,2.972000d+05,2.985000d+05, &3.019700d+05,3.337300d+05,3.688300d+05,3.877400d+05,4.076200d+05, &4.504900d+05,5.234000d+05,5.502300d+05,5.784400d+05,6.081000d+05, &6.392800d+05,6.720600d+05,7.065100d+05,7.427400d+05,7.808200d+05, &8.208500d+05,8.629400d+05,9.071800d+05,9.616400d+05,1.002600d+06, &1.108000d+06,1.164800d+06,1.224600d+06,1.287300d+06,1.353400d+06, &1.422700d+06,1.495700d+06,1.572400d+06,1.653000d+06,1.737700d+06, &1.826800d+06,1.920500d+06,2.019000d+06,2.122500d+06,2.231300d+06, &2.306900d+06,2.345700d+06,2.365300d+06,2.385200d+06,2.466000d+06, &2.592400d+06,2.725300d+06,2.865000d+06,3.011900d+06,3.166400d+06, &3.328700d+06,3.678800d+06,4.065700d+06,4.493300d+06,4.723700d+06/ data eg21d/ &4.965900d+06,5.220500d+06,5.488100d+06,5.769500d+06,6.065300d+06, &6.376300d+06,6.592400d+06,6.703200d+06,7.046900d+06,7.408200d+06, &7.788000d+06,8.187300d+06,8.607100d+06,9.048400d+06,9.512300d+06, &1.000000d+07,1.051300d+07,1.105200d+07,1.161800d+07,1.221400d+07, &1.284000d+07,1.349900d+07,1.384000d+07,1.419100d+07,1.455000d+07, &1.491800d+07,1.568300d+07,1.648700d+07,1.690500d+07,1.733300d+07, &1.964000d+07/ data eg22a/ &1.000010d-05,3.000000d-03,5.000000d-03,6.900000d-03,1.000000d-02, &1.500000d-02,2.000000d-02,2.500000d-02,3.000000d-02,3.500000d-02, &4.200000d-02,5.000000d-02,5.800000d-02,6.700000d-02,7.700000d-02, &8.000000d-02,9.500000d-02,1.000000d-01,1.150000d-01,1.340000d-01, &1.400000d-01,1.600000d-01,1.800000d-01,1.890000d-01,2.200000d-01, &2.480000d-01,2.800000d-01,3.000000d-01,3.145000d-01,3.200000d-01, &3.500000d-01,3.910000d-01,4.000000d-01,4.330000d-01,4.850000d-01, &5.000000d-01,5.400000d-01,6.250000d-01,7.050000d-01,7.800000d-01, &7.900000d-01,8.500000d-01,8.600000d-01,9.100000d-01,9.300000d-01, &9.500000d-01,9.720000d-01,9.860000d-01,9.960000d-01,1.020000d+00, &1.035000d+00,1.045000d+00,1.071000d+00,1.097000d+00,1.110000d+00, &1.123000d+00,1.150000d+00,1.170000d+00,1.235000d+00,1.300000d+00, &1.337500d+00,1.370000d+00,1.440000d+00,1.475000d+00,1.500000d+00, &1.590000d+00,1.670000d+00,1.755000d+00,1.840000d+00,1.930000d+00, &2.020000d+00,2.100000d+00,2.130000d+00,2.360000d+00,2.550000d+00, &2.600000d+00,2.720000d+00,2.767920d+00,3.300000d+00,3.380750d+00, &4.000000d+00,4.129250d+00,5.043477d+00,5.346430d+00,6.160116d+00, &7.523983d+00,8.315287d+00,9.189814d+00,9.905554d+00,1.122446d+01, &1.370959d+01,1.592827d+01,1.945484d+01,2.260329d+01,2.498050d+01/ data eg22b/ &2.760773d+01,3.051126d+01,3.372015d+01,3.726653d+01,4.016900d+01, &4.551744d+01,4.825160d+01,5.157802d+01,5.559513d+01,6.790405d+01, &7.567357d+01,9.166088d+01,1.367420d+02,1.486254d+02,2.039950d+02, &3.043248d+02,3.717032d+02,4.539993d+02,6.772874d+02,7.485183d+02, &9.142423d+02,1.010394d+03,1.234098d+03,1.433817d+03,1.507331d+03, &2.034684d+03,2.248673d+03,3.354626d+03,3.526622d+03,5.004514d+03, &5.530844d+03,7.465858d+03,9.118820d+03,1.113775d+04,1.503439d+04, &1.661557d+04,2.478752d+04,2.739445d+04,2.928300d+04,3.697864d+04, &4.086771d+04,5.516564d+04,6.737947d+04,8.229747d+04,1.110900d+05, &1.227734d+05,1.831564d+05,2.472353d+05,2.732372d+05,3.019738d+05, &4.076220d+05,4.504920d+05,4.978707d+05,5.502322d+05,6.081006d+05, &8.208500d+05,9.071795d+05,1.002588d+06,1.108032d+06,1.224564d+06, &1.353353d+06,1.652989d+06,2.018965d+06,2.231302d+06,2.465970d+06, &3.011942d+06,3.678794d+06,4.493290d+06,5.488116d+06,6.065307d+06, &6.703200d+06,8.187308d+06,1.000000d+07,1.1618343d+07, &1.3840307d+07,1.4918247d+07,1.733253d+07,1.964033d+07/ data eg23a/ &1.000010d-05,1.000010d-01,4.139940d-01,5.315790d-01,6.825600d-01, &8.764250d-01,1.123000d+00,1.440000d+00,1.855390d+00,2.382370d+00, &3.059020d+00,3.927860d+00,5.043480d+00,6.475950d+00,8.315290d+00, &1.067700d+01,1.370960d+01,1.760350d+01,2.260330d+01,2.902320d+01, &3.726650d+01,4.785120d+01,6.144210d+01,7.889320d+01,1.013010d+02, &1.300730d+02,1.670170d+02,2.144540d+02,2.753640d+02,3.535750d+02, &4.539990d+02,5.829470d+02,7.485180d+02,9.611170d+02,1.234100d+03, &1.584610d+03,2.034680d+03,2.248670d+03,2.485170d+03,2.612590d+03, &2.746540d+03,3.035390d+03,3.354630d+03,3.707440d+03,4.307420d+03, &5.530840d+03,7.101740d+03,9.118820d+03,1.059460d+04,1.170880d+04, &1.503440d+04,1.930450d+04,2.187490d+04,2.357860d+04,2.417550d+04, &2.478750d+04,2.605840d+04,2.700010d+04,2.850110d+04,3.182780d+04, &3.430670d+04,4.086770d+04,4.630920d+04,5.247520d+04,5.656220d+04, &6.737950d+04,7.202450d+04,7.949870d+04,8.250340d+04,8.651700d+04, &9.803650d+04,1.110900d+05,1.167860d+05,1.227730d+05,1.290680d+05, &1.356860d+05,1.426420d+05,1.499560d+05,1.576440d+05,1.657270d+05, &1.742240d+05,1.831560d+05,1.925470d+05,2.024190d+05,2.127970d+05, &2.237080d+05,2.351770d+05,2.472350d+05,2.732370d+05,2.872460d+05, &2.945180d+05,2.972110d+05,2.984910d+05,3.019740d+05,3.337330d+05/ data eg23b/ &3.688320d+05,3.877420d+05,4.076220d+05,4.504920d+05,4.978710d+05, &5.233970d+05,5.502320d+05,5.784430d+05,6.081010d+05,6.392790d+05, &6.720550d+05,7.065120d+05,7.427360d+05,7.808170d+05,8.208500d+05, &8.629360d+05,9.071800d+05,9.616720d+05,1.002590d+06,1.108030d+06, &1.164840d+06,1.224560d+06,1.287350d+06,1.353350d+06,1.422740d+06, &1.495690d+06,1.572370d+06,1.652990d+06,1.737740d+06,1.826840d+06, &1.920500d+06,2.018970d+06,2.122480d+06,2.231300d+06,2.306930d+06, &2.345700d+06,2.365330d+06,2.385130d+06,2.465970d+06,2.592400d+06, &2.725320d+06,2.865050d+06,3.011940d+06,3.166370d+06,3.328710d+06, &3.678790d+06,4.065700d+06,4.493290d+06,4.723670d+06,4.965850d+06, &5.220460d+06,5.488120d+06,5.769500d+06,6.065310d+06,6.376280d+06, &6.592410d+06,6.703200d+06,7.046880d+06,7.408180d+06,7.788010d+06, &8.187310d+06,8.607080d+06,9.048370d+06,9.512290d+06,1.000000d+07, &1.051270d+07,1.105170d+07,1.161830d+07,1.221400d+07,1.252320d+07, &1.284030d+07,1.349860d+07,1.384030d+07,1.419070d+07,1.454990d+07, &1.491820d+07,1.568310d+07,1.648720d+07,1.690460d+07,1.733250d+07, &1.964030d+07/ *b groupr.1837 c c ***ecco 33-group structure else if (ign.eq.19) then ng=33 do ig=1,34 eg(ig)=eg19(ig) enddo c c ***ecco 1968-group structure else if (ign.eq.20) then ng=1968 do ig=1,1969 eg(ig)=eg20(ig) enddo c c ***tripoli 315-group structure else if (ign.eq.21) then ng=315 do ig=1,316 eg(ig)=eg21(ig) enddo c c ***xmas lwpc 172-group structure else if (ign.eq.22) then ng=172 do ig=1,173 eg(ig)=eg22(ig) enddo c c ***vit-j lwpc 175-group structure else if (ign.eq.23) then ng=175 do ig=1,176 eg(ig)=eg23(ig) enddo *b groupr.1888 if (ign.eq.19) write(nsyso,'(/ & '' neutron group structure......ecco 33-group'')') if (ign.eq.20) write(nsyso,'(/ & '' neutron group structure......ecco 1968-group'')') if (ign.eq.21) write(nsyso,'(/ & '' neutron group structure......tripoli 315-group'')') if (ign.eq.22) write(nsyso,'(/ & '' neutron group structure......xmas lwpc 172-group'')') if (ign.eq.23) write(nsyso,'(/ & '' neutron group structure......vit-j lwpc 175-group'')') */ increase the size of egn from 641 to 15000 i.e dice 13193 apollo 11276 *d groupr.1643 data ngmax/15000/ *d groupr.228 common/groupn/ign,ngn,egn(15000) *d groupr.772 common/groupn/ign,ngn,egn(15000) *d groupr.1303 common/groupn/ign,ng,eg(15000) *d groupr.2643 common/groupn/ig,ngn,egn(15000) *d groupr.3074 common/groupn/ign,ngn,egn(15000) *d groupr.4274 common/groupn/ign,ngn,egn(15000) *d groupr.6415 common/groupn/ign,ngn,egn(15000) *d groupr.6918 common/groupn/ign,ngn,egn(15000) */ increase the size of storage array to handle certain groupr figures *d up105.67 dimension a(5000000) *d up105.69 iamax=5000000 *ident up108 */ acer -- 18aug05 */ provide more space for angular distributions in ptleg2. */ recommended by aldama (iaea nds). *d acer.6951 dimension aco(3597),cprob(3597),cumm(3597) *d acer.7031 if (ii.gt.3597) call error('ptleg2','too many angles',' ') */ format extension for negative energies (overlap) */ recommended by aldama (iaea nds). *d acer.4947,4948 write(nsyso,'('' energy range: '',1p,e11.4, & '' - '',e11.4,'' ev'')') urlo,urhi */ declare "error" external to avoid conflict with intrinsic function */ provided by trkov (iaea). *i up69.66 external error */ if pointwise representation in cm system, csn should be used */ from trkov, iaea (pointed out by harry wienke). *d acer.3394,3396 if (csn.ge.a(ll).and.csn.le.a(ll+2)) & call terp1(a(ll),a(ll+1),a(ll+2),a(ll+3), & csn,fmu,lang-10) */ fix6 may run out of space without warning */ provided by trkov (iaea). *d acer.3247 dimension a(2000) *d up3.38 data namax/2000/ *i acer.3262 if(nw.gt.namax) call error('fix6','storage exceeded.',' ') *i acer.3272 if(nw.gt.namax) call error('fix6','storage exceeded.',' ') *i acer.3278 if(nw.gt.namax) call error('fix6','storage exceeded.',' ') *i acer.3280 if(nw.gt.namax) call error('fix6','storage exceeded.',' ') *i acer.3282 if(nw.gt.namax) call error('fix6','storage exceeded.',' ') *i acer.3284 if(nw.gt.namax) call error('fix6','storage exceeded.',' ') *i acer.3290 if(nw.gt.namax) call error('fix6','storage exceeded.',' ') *i acer.3296 if(nw+l.gt.namax) call error('fix6','storage exceeded.',' ') *i acer.3299 if(nw+l.gt.namax) call error('fix6','storage exceeded.',' ') */ provide for larger output files to handle jeff-3.1 u-238. */ recommended by aldama (iaea nds). *d up57.76 max3=4000000 *d up57.78 common/xsst/xss(4000000),n3 *d up57.80 common/xsst/xss(4000000),n3 *d up57.82 common/xsst/xss(4000000),n3 *d up57.84 common/xsst/xss(4000000),n3 *d up57.86 common/xsst/xss(4000000),n3 *d up57.88 common/xsst/xss(4000000),n3 *d up57.90 common/xsst/xss(4000000),n3 *d up57.92 common/xsst/xss(4000000),n3 *d up57.94 common/xsst/xss(4000000),n3 *d up57.96 common/xsst/xss(4000000),n3 *d up57.98 common/xsst/xss(4000000),n3 *d up57.100 common/xsst/xss(4000000),n3 *d up57.102 common/xsst/xss(4000000),n3 *d up57.104 common/xsst/xss(4000000),n3 *d up57.106 common/xsst/xss(4000000),n3 *d up57.108 common/xsst/xss(4000000),n3 *d up57.110 common/xsst/xss(4000000),n3 *d up57.112 common/xsst/xss(4000000),n3 *d up57.114 common/xsst/xss(4000000),n3 *d up57.116 common/xsst/xss(4000000),n3 *d up57.118 common/xsst/xss(4000000),n3 *d up57.120 common/xsst/xss(4000000),n3 *d up57.122 common/xsst/xss(4000000),n3 *d up57.124 common/xsst/xss(4000000),n3 *d up57.126 common/xsst/xss(4000000),n3 *d up57.128 common/xsst/xss(4000000),n3 *d up57.130 common/xsst/xss(4000000),n3 *d up57.132 common/xsst/xss(4000000),n3 *d up57.134 common/xsst/xss(4000000),n3 *d up57.136 common/xsst/xss(4000000),n3 *d up57.138 common/xsst/xss(4000000),n3 *d up57.140 common/xsst/xss(4000000),n3 *d up57.142 common/xsst/xss(4000000),n3 *d up70.95 common/xsst/xss(4000000),n3 *d up57.144 common/xsst/xss(4000000),n3 *d up70.222 common/xsst/xss(4000000),n3 *d up57.146 common/xsst/xss(4000000),n3 *d up57.148 common/xsst/xss(4000000),n3 *d up57.150 common/xsst/xss(4000000),n3 *ident up109 */ wimsr -- 18aug05 */ Prepare (n,2n) from mt=875-891 to correct absorption */ d.l.aldama, nds/iaea consultant, 2005 *i wimsr.895 jn2n=0 *i wimsr.984 if (mth.eq.16) jn2n=16 *i wimsr.985 if ((mth.ge.875.and.mth.le.891).and.(jn2n.ne.16)) go to 236 *ident up110 */ errorr -- 18aug05 */ several patches prepared by a. trkov and i. kodeli, iaea, feb-2005 */ - Fix fatal error converting code to f90 */ - increase storage arrray (namax:30000->300000,nxmax:150->450) */ - Allow suppression of spikes resulting from lb8 contribution */ - Allow extension for mt 850-891 */ - Activate mt=261 processing */ fatal error - misplaced statement incrementing reserved array index *d errorr.1274 *i errorr.1275 l=l+nw */ increase storage *d errorr.128 common/estore/a(120000) *d errorr.160 namax=120000 *d errorr.192 if (n1h.ne.0.and.n2h.eq.0) then *d errorr.536 data nxmax/450/, irmax/60/ *d errorr.2233 common/estore/a(120000) */ allow suppression of spikes resulting from lb8 contribution *d errorr.126 common/mode/imode,isupp *i errorr.204 c use a negative value of matd to suppress lb=8 by 10.**(-10) isupp=0 if (matd.lt.0) then isupp=-10 matd=-matd endif *d errorr.1090 common/mode/imode,isupp */ allow extension for mt=850-891 *d errorr.294 if (mt.gt.890) go to 121 *d errorr.1022 if (mt1.lt.891) go to 140 *d errorr.1208 if (mt.gt.890) go to 190 *d errorr.1289,1290 if (mt1.lt.891) call rdsig(mat1,mt1,a(ib),a(isig1)) if (mt1.gt.890) call lumpxs(mt1,mtl,a) *d errorr.2307 if (mts(ix).lt.891) go to 250 *i errorr.4327 if (mtd.ge.800.and.mtd.le.899) mt=mtd *d errorr.1348 a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*xcv *10**isupp *d errorr.1827 common/mode/imode,isupp */ activate mt=261 processing *i errorr.4325 if (mtd.eq.261) mt=mtd *ident up111 */ covr -- 18aug05 */ several patches prepared by a. trkov (iaea), feb 2005. */ - Increase storage (iamax 50000->300000, ipat 1000>14000)) */ - Fix energy-truncation of covariance matrix plots for small functions */ (spectra from irdf-2002 dosimetry library) *d covr.100 common/storec/a(300000) *d covr.131 data iamax/300000/, niad/15/, ipr/1/, ntics3/600/ *d covr.1104 common/storec/a(300000) */ needed to process matrices on input energy grid with many groups */ increase to 2000 is sufficient if no subdivisions are requested *d covr.1159 if (ipat.gt.14000) call error('matshd','ipat gt 14000.',' ') */ fix energy-truncation of covariance matrix plots for small functions *i covr.880 c define alternative limit as average/xslim rlimx=0 rlimy=0 ethrx=a(ix) ethry=a(iy) do i=2,ixmax rlimx=rlimx+a(ixx+i-2)*(a(ix+i-1)-a(ix+i-2)) rlimy=rlimy+a(ixy+i-2)*(a(iy+i-1)-a(iy+i-2)) if (a(ixx+i-2).le.0) ethrx=a(ix+i-1) if (a(ixy+i-2).le.0) ethry=a(iy+i-1) end do rlimx=xslim*rlimx/(a(iy+ixmax-1)-ethry) rlimy=xslim*rlimy/(a(ix+ixmax-1)-ethrx) *d covr.884 if (a(ixx-1+i).ge.xslim.or.a(ixx-1+i).ge.rlimx) go to 120 *d covr.892 if (a(ixy-1+i).ge.xslim.or.a(ixy-1+i).ge.rlimy) go to 140 *d covr.898,902 c limit bin width of thermal group to one decade if (ixmin.eq.1) then if (10*a(ix).lt.a(ix+1).and.10*a(iy).lt.a(iy+1)) then ten=10 elo=log10(a(ix+1)/10) ielo=nint(elo) a(ix)=max(a(ix),ten**ielo) elo=log10(a(iy+1)/10) ielo=nint(elo) a(iy)=max(a(iy),ten**ielo) endif endif *i covr.1522 & ,nmeg1 *i covr.1537 data nmeg1/'(spectr.'/ *i covr.1545 if (mt.eq.261) go to 128 *i covr.1562 go to 200 128 lnamel(1)=nmeg1 inamel=8 jloc=10 go to 310 */ alternative subdivision of levels for colour scheme *d covr.124 c data tlev/.2d0,.4d0,.6d0,.8d0,1.0d0/ data tlev/.1d0,.2d0,.3d0,.6d0,1.0d0/ */ cannot explain this one, but one of the irdf-2002 spectra crashed *d covr.319 nwig=2*(2*(ixmax+1)+ntics3) *ident up112 */ acer -- 20oct05 */ increase dimension for nubar tabulations in pn data */ to handle the new lanl am-241 evaluation for endf/b-vii. *d acer.15232 dimension fnubar(300) *ident up113 */ acer -- 15feb06 */ add continuous sampling method for thermal distributions */ energy distributions from thermr are converted to pdf/cdf */ form with some panels that have small cdf contributions */ eliminated. angular distributions are left as discrete */ for later smoothing in mcnp. this method is experimental */ and not standard in mcnp5 as of this date. this patch */ also provides extended plotting capabilities. *d acer.49 c * to extend the sampling to rare events. A new tabulated * c * option uses a continuous tabulated probability distribution * c * (pdf/cdf) (requires a modified version of MCNP) and provides * c * extended plotting. * *d acer.175 c * iwt 0/1/2=variable/constant/tabulated (def=variable) * *d acer.388 & '' weight option (0 var, 1 cons, 2 tab) . '',i10)') *d acer.13061,13062 c convert thermal matrices in njoy mf6 format to various ACE c thermal formats. *i acer.13071 common/nxst/len2,idpni,nil,nieb,idpnc,ncl,ifeng,nxsd(9) *i acer.13077 common/acec/ndp(500) *d up94.7 ninmax=50000 *i acer.13291 c ***if needed *d acer.13304 else if (iwt.eq.1) then *i acer.13310 else write(nsyso,'(/'' tabulated probability distribution''//, & '' original and modified number of secondary energies'')') *i acer.13313 len2=0 *i acer.13333 c ***fix the angular distribution of the first and last points nn=2+nang isn=8 do i=1,nang a(iscr-1+isn+i)=a(iscr-1+isn+i+nn) enddo isn=8+nl*(nep-1) do i=1,nang a(iscr-1+isn+i)=a(iscr-1+isn+i-nn) enddo c ***get cross section *i acer.13336 loc=isix+2 *i acer.13338 nn=0 *d acer.13340,13341 c ***determine equal or variable probable energies if (iwt.le.1) then fract=wt(1) else fract=1 endif *d acer.13355 if (iwt.le.1.and.i.eq.nep.and.j.eq.nbin-1) then *i acer.13359 if (iwt.gt.1.and.i.eq.nep) then xn=x fract=sum+add j=j+1 go to 270 endif if (iwt.gt.1) then if (sum+add.gt.eps/10) fract=sum+add endif *d acer.13360 if (sum+add.ge.fract-fract/10000) go to 260 *d acer.13366 if (sum+add.lt.fract+fract/10000) then xn=x else if (abs(y-yl).gt.(y+yl)/100000) then *d acer.13394,13400 l=2 do xlo=a(is+6+nl1*(l-2)) xhi=a(is+6+nl1*(l-1)) if (l.eq.nep) exit if (xhi.ge.xbar) exit l=l+1 enddo *d acer.13403,13405 *d acer.13406 nn=nn+1 if (iwt.le.1) then a(loc)=xbar do k=1,nang a(k+loc)=a(k+isl)+(a(k+isn)-a(k+isl))*(xbar-xlo)/(xhi-xlo) enddo else a(loc)=xn loc=loc+1 a(loc)=yn loc=loc+1 a(loc)=fract do k=1,nang a(k+loc)=a(k+isl)+(a(k+isn)-a(k+isl))*(xn-xlo)/(xhi-xlo) enddo endif loc=loc+1+nang *d acer.13409 if (iwt.le.1) then fract=wt(j+1) else fract=1 endif *i acer.13416 285 continue c ***check normalization for tabulated distribution if (iwt.gt.1) then area=0 j=3 do i=1,nn area=area+a(isix-1+j+2) a(isix-1+j+2)=area j=j+3+nang enddo j=3 do i=1,nn a(isix-1+j+1)=a(isix-1+j+1)/area a(isix-1+j+2)=a(isix-1+j+2)/area j=j+3+nang enddo write(nsyso,'(6x,3i8)') ie,nep,nn endif *d acer.13419 loc=loc-1 len2=len2+loc-isix-1 ndp(ie)=loc-isix+1 write(nout) (a(i),i=isix,loc) *d acer.13412 if (iwt.le.1.and.j.eq.nbin) go to 285 *i acer.13451 common/lsize/max1,max2,max3 *i acer.13456 common/acec/ndp(500) *i acer.13494 if (iwt.eq.2) ifeng=2 *d acer.13506 if (ifeng.gt.1) len2=len2+2*nie len2=len2+itxe-1 *d acer.13500 nie=ne *d acer.13508 itce=len2+1 *i acer.13516 if (len2.gt.max3) then write(nsyso,'(i10)') len2 call error('thrlod','xss too small',' ') endif *i acer.13555 nei=nie *d acer.13557,13558 if (ifeng.le.1) then nil=nang-1 else nil=nang+1 endif *i acer.13560 if (ifeng.gt.1) indx=indx+2*nei *i acer.13561 nw=ndp(i) if (nw.gt.nwscr) call error('thrlod','scr exceeded',' ') *i acer.13562 nw=nw-2 *i acer.13564 if (ifeng.gt.1) then xss(itxe-1+i)=indx xss(itxe-1+nei+i)=nw/(nang+3) endif *d acer.13566 do while (k.lt.nw-1) *i acer.13568 if (ifeng.gt.1) then k=k+1 xss(indx+k)=a(iscr-1+2+k)*emev k=k+1 xss(indx+k)=a(iscr-1+2+k) endif *i acer.13627 if (ifeng.gt.1) loc=loc+2*nie *d acer.13629,13662 do i=1,ne if (ifeng.le.1) then nang=nil+1 nbini=nieb else nang=nil-1 nbini=nint(xss(itxe-1+ne+i)) endif nln=((nang+7)/8)*nbini if (ifeng.le.1) then lim=nang+1 if (nang.gt.8) lim=9 else lim=nang+3 if (nang.gt.8) lim=11 endif lim1=lim+1 if (i.eq.1) then write(nsyso,'(/ & '' inelastic data - equally probable angles''/ & '' ----------------------------------------''/)') lines=4 else if ((lines+nln+4).gt.58) then write(nsyso,'(''1'')') lines=1 endif endif write(nsyso,'(/6x,''incident energy = '',1p,e12.4,8x, & ''cross section = '',e12.4)') xss(itie+i),xss(itie+ne+i) if (ifeng.le.1) then write(nsyso,'(/ & 9x,''exit energy'',5x,''cosines''/9x,''-----------'', & 2x,8(''----------''))') else write(nsyso,'(/ & 9x,''exit energy'',8x,''pdf'',11x,''cdf'',5x,''cosines''/ & 9x,''-----------'',2x,''---------- '', & 2x,''------------'',2x,8(''----------''))') endif lines=lines+4 do j=1,nbini if (ifeng.le.1) then write(nsyso,'(7x,1p,e12.4,2x,0p,8f10.4)') & (xss(k+loc),k=1,lim) if (nang.gt.8) write(nsyso,'(21x,8f10.4)') & (xss(loc+k),k=lim1,nang+1) else write(nsyso,'(7x,1p,e12.4,e13.4,e15.6,1x,0p,8f10.4)') & (xss(k+loc),k=1,lim) if (nang.gt.8) write(nsyso,'(48x,8f10.4)') & (xss(loc+k),k=lim1,nang+3) endif if (ifeng.le.1) then loc=loc+nang+1 else loc=loc+nang+3 endif enddo lines=lines+nln enddo *d acer.13879 xs=xss(itce+nee+1)/e *i acer.13962 if (ifeng.gt.1) nang=nil-1 *d acer.13964 *i acer.13969 if (ifeng.gt.1) loc=loc+2*nie *i acer.13972 if (ifeng.gt.1) nbini=nint(xss(itxe-1+nie+i)) *d acer.13975,13984 if (ifeng.le.1) then do j=1,nbini if (ifeng.eq.0) then wt=1 else wt=10 if (j.eq.1.or.j.eq.nbini) wt=1 if (j.eq.2.or.j.eq.nbini-1) wt=4 endif do k=2,nang+1 ubar=ubar+wt*xss(loc+k) sum=sum+wt enddo loc=loc+nang+1 enddo else cdl=0 loc=loc+nang+3 do j=2,nbini p=xss(loc+3)-cdl do k=1,nang ubar=ubar+xss(loc+3+k)*p/2 ubar=ubar+xss(loc+3+k-nang-2)*p/2 sum=sum+p enddo cdl=xss(loc+3) loc=loc+nang+3 enddo endif *i acer.14020 if (ifeng.gt.1) loc=loc+2*nie *i acer.14023 if (ifeng.gt.1) nbini=nint(xss(itxe-1+nie+i)) *d acer.14026,14035 if (ifeng.le.1) then do j=1,nbini if (ifeng.eq.0) then wt=1 else wt=10 if (j.eq.1.or.j.eq.nbini) wt=1 if (j.eq.2.or.j.eq.nbini-1) wt=4 endif do k=2,nang+1 ubar=ubar+wt*xss(loc+k) sum=sum+wt enddo loc=loc+nang+1 enddo else cdl=0 loc=loc+nang+3 do j=2,nbini p=xss(loc+3)-cdl do k=1,nang ubar=ubar+xss(loc+3+k)*p/2 ubar=ubar+xss(loc+3+k-nang-2)*p/2 sum=sum+p enddo cdl=xss(loc+3) loc=loc+nang+3 enddo endif *d acer.14040 if (nee.ne.0) then *i acer.14079 if (ifeng.gt.1) nang=nil-1 *i acer.14086 if (ifeng.gt.1) loc=loc+2*nie *i acer.14089 if (ifeng.gt.1) nbini=nint(xss(itxe-1+nie+i)) *d acer.14092,14100 if (ifeng.le.1) then do j=1,nbini eprime=xss(loc+1) if (ifeng.eq.0) then wt=1 else wt=10 if (j.eq.1.or.j.eq.nbini) wt=1 if (j.eq.2.or.j.eq.nbini-1) wt=4 endif ebar=ebar+wt*eprime sum=sum+wt loc=loc+nang+1 enddo else cdl=0 xl=0 pl=0 loc=loc+nang+3 do j=2,nbini x=xss(loc+1) p=xss(loc+2) u=(pl-(p-pl)*xl/(x-xl))*(x**2-xl**2)/2 & +((p-pl)/(x-xl))*(x**3-xl**3)/3 ul=(x-xl)*(p+pl)/2 u=u/ul un=xss(loc+3)-cdl ebar=ebar+u*un sum=sum+un xl=x pl=p cdl=xss(loc+3) loc=loc+nang+3 enddo endif *i acer.14133 if (ifeng.gt.1) loc=loc+2*nie *i acer.14136 if (ifeng.gt.1) nbini=nint(xss(itxe-1+nie+i)) *d acer.14139,14147 if (ifeng.le.1) then do j=1,nbini eprime=xss(loc+1) if (ifeng.eq.0) then wt=1 else wt=10 if (j.eq.1.or.j.eq.nbini) wt=1 if (j.eq.2.or.j.eq.nbini-1) wt=4 endif ebar=ebar+wt*eprime sum=sum+wt loc=loc+nang+1 enddo else cdl=0 xl=0 pl=0 loc=loc+nang+3 do j=2,nbini x=xss(loc+1) p=xss(loc+2) u=(pl-(p-pl)*xl/(x-xl))*(x**2-xl**2)/2 & +((p-pl)/(x-xl))*(x**3-xl**3)/3 ul=(x-xl)*(p+pl)/2 u=u/ul un=xss(loc+3)-cdl ebar=ebar+u*un sum=sum+un xl=x pl=p cdl=xss(loc+3) loc=loc+nang+3 enddo endif *d acer.14152,14153 if (ifeng.le.1) then write(nout,'(''99/'')') return endif !--3-d plots of thermal inelastic distributions !--when continuous probability distribution option is used ! plot energy distributions for low incident energies nang=nil-1 loc=itxe-1 loc=loc+2*nie zmin=1000 zmax=0 xmin=5/scale/100000 xmax=.5/scale ymin=1/scale/100000 ymax=2/scale/100 do ie=1,nie e=xss(itie+ie) nbini=nint(xss(itxe-1+nie+ie)) do j=1,nbini ep=xss(loc+1) if (e.ge.ymin.and.e.le.ymax.and. & ep.gt.xmin.and.ep.lt.xmax) then p=xss(loc+2) if (p.lt.zmin) zmin=p if (p.gt.zmax) zmax=p endif loc=loc+nang+3 enddo enddo zmin=zmax/1000 call ascll(zmin,zmax) write(nout,'(''1'',i3,''/'')') iwcol write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''thermal inelastic'',a,''/'')') qu,qu write(nout,'(''-4 2/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,1. write(nout,'(a,''ec. nergy'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,1. write(nout,'(a,''nergy (e)'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') zmin,zmax,1. write(nout,'(a,''

rob/e'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''10 -15 15 3.5 5.5 2.5/'')') write(nout,'(''1/'')') loc=itxe-1 loc=loc+2*nie do ie=1,nie e=xss(itie+ie) if (e.ge.ymin.and.e.le.ymax) write(nout,'(1p,e14.6,''/'')') e nbini=nint(xss(itxe-1+nie+ie)) do j=1,nbini ep=xss(loc+1) p=xss(loc+2) if (p.lt.zmin) p=zmin if (e.ge.ymin.and.e.le.ymax.and. & ep.gt.xmin.and.ep.le.xmax) then write(nout,'(1p,2e14.6,''/'')') ep,p endif loc=loc+nang+3 enddo if (e.ge.ymin.and.e.le.ymax) write(nout,'(''/'')') enddo write(nout,'(''/'')') ! plot energy distributions for middle incident energies nang=nil-1 loc=itxe-1 loc=loc+2*nie zmin=1000 zmax=0 xmin=2/scale/1000 xmax=5/scale/10 ymin=2/scale/100 ymax=2/scale/10 do ie=1,nie e=xss(itie+ie) nbini=nint(xss(itxe-1+nie+ie)) epl=0 do j=1,nbini ep=xss(loc+1) if (e.ge.ymin.and.e.le.ymax.and. & ep.gt.xmin.and.ep.lt.xmax) then p=xss(loc+2) if (p.lt.zmin) zmin=p if (p.gt.zmax) zmax=p endif loc=loc+nang+3 enddo enddo zmin=zmax/500 call ascll(zmin,zmax) write(nout,'(''1'',i3,''/'')') iwcol write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''thermal inelastic'',a,''/'')') qu,qu write(nout,'(''-4 2/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,1. write(nout,'(a,''ec. nergy'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,1. write(nout,'(a,''nergy (e)'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') zmin,zmax,1. write(nout,'(a,''

rob/e'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''10 -15 15 3.5 5.5 2.5/'')') write(nout,'(''1/'')') loc=itxe-1 loc=loc+2*nie do ie=1,nie e=xss(itie+ie) if (e.ge.ymin.and.e.le.ymax) write(nout,'(1p,e14.6,''/'')') e nbini=nint(xss(itxe-1+nie+ie)) do j=1,nbini ep=xss(loc+1) p=xss(loc+2) if (p.lt.zmin) p=zmin if (e.ge.ymin.and.e.le.ymax.and. & ep.gt.xmin.and.ep.le.xmax) then write(nout,'(1p,2e14.6,''/'')') ep,p endif loc=loc+nang+3 enddo if (e.ge.ymin.and.e.le.ymax) write(nout,'(''/'')') enddo write(nout,'(''/'')') ! plot energy distributions for higher incident energies nang=nil-1 loc=itxe-1 loc=loc+2*nie zmin=1000 zmax=0 xmin=2/scale/100 xmax=2/scale ymin=2/scale/10 ymax=2/scale do ie=1,nie e=xss(itie+ie) nbini=nint(xss(itxe-1+nie+ie)) do j=1,nbini ep=xss(loc+1) if (e.ge.ymin.and.e.le.ymax.and. & ep.gt.xmin.and.ep.lt.xmax) then p=xss(loc+2) if (p.lt.zmin) zmin=p if (p.gt.zmax) zmax=p endif loc=loc+nang+3 enddo enddo zmin=zmax/500 call ascll(zmin,zmax) write(nout,'(''1'',i3,''/'')') iwcol write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''thermal inelastic'',a,''/'')') qu,qu write(nout,'(''-4 2/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,1. write(nout,'(a,''ec. nergy'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,1. write(nout,'(a,''nergy (e)'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') zmin,zmax,1. write(nout,'(a,''

rob/e'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''10 -15 15 3.5 5.5 2.5/'')') write(nout,'(''1/'')') loc=itxe-1 loc=loc+2*nie do ie=1,nie e=xss(itie+ie) if (e.ge.ymin.and.e.le.ymax) write(nout,'(1p,e14.6,''/'')') e nbini=nint(xss(itxe-1+nie+ie)) do j=1,nbini ep=xss(loc+1) p=xss(loc+2) if (p.lt.zmin) p=zmin if (e.ge.ymin.and.e.le.ymax.and. & ep.gt.xmin.and.ep.le.xmax) then write(nout,'(1p,2e14.6,''/'')') ep,p endif loc=loc+nang+3 enddo if (e.ge.ymin.and.e.le.ymax) write(nout,'(''/'')') enddo write(nout,'(''/'')') ! plot energy distributions for highest incident energies nang=nil-1 loc=itxe-1 loc=loc+2*nie zmin=1000 zmax=0 xmin=1/scale/100 xmax=10/scale ymin=2/scale ymax=10/scale do ie=1,nie e=xss(itie+ie) nbini=nint(xss(itxe-1+nie+ie)) do j=1,nbini ep=xss(loc+1) if (e.ge.ymin.and.e.le.ymax.and. & ep.gt.xmin.and.ep.lt.xmax) then p=xss(loc+2) if (p.lt.zmin) zmin=p if (p.gt.zmax) zmax=p endif loc=loc+nang+3 enddo enddo zmin=zmax/500 call ascll(zmin,zmax) write(nout,'(''1'',i3,''/'')') iwcol write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''thermal inelastic'',a,''/'')') qu,qu write(nout,'(''-4 2/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,1. write(nout,'(a,''ec. nergy'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,1. write(nout,'(a,''nergy (e)'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') zmin,zmax,1. write(nout,'(a,''

rob/e'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''10 -15 15 3.5 5.5 2.5/'')') write(nout,'(''1/'')') loc=itxe-1 loc=loc+2*nie do ie=1,nie e=xss(itie+ie) if (e.ge.ymin.and.e.le.ymax) write(nout,'(1p,e14.6,''/'')') e nbini=nint(xss(itxe-1+nie+ie)) do j=1,nbini ep=xss(loc+1) p=xss(loc+2) if (p.lt.zmin) p=zmin if (e.ge.ymin.and.e.le.ymax.and. & ep.gt.xmin.and.ep.le.xmax) then write(nout,'(1p,2e14.6,''/'')') ep,p endif loc=loc+nang+3 enddo if (e.ge.ymin.and.e.le.ymax) write(nout,'(''/'')') enddo write(nout,'(''/'')') ! plot angle-energy distribution for several incident energies ie=19 iskip=(nie-ie)/4 do while (ie.lt.nie) nang=nil-1 loc=nint(xss(itxe-1+ie)) nbini=nint(xss(itxe-1+nie+ie)) zmin=1 zmin=zmin/100 zmax=10 ymin=10 ymax=1/scale/10000000 xmin=-1 xmax=+1 e=xss(itie+ie) epl=0 loc=loc+nang+3 do j=2,nbini-1 ep=(xss(loc+1)+epl)/2 if (xss(loc+1).gt.epl) then if (ep.lt.ymin) ymin=ep if (ep.gt.ymax) ymax=ep epl=xss(loc+1) ul=-1 do k=1,nang u=xss(loc+3+k) if (k.lt.nang) then un=(u+xss(loc+3+k+1))/2 else un=1 endif if (k.eq.1.and.u-ul.gt.5*(un-u)) ul=u-3*(un-u) if (k.eq.nang.and.un-u.gt.5*(u-ul)) un=u+3*(u-ul) p=1 p=p/nang p=p/(un-ul) ul=un enddo endif loc=loc+nang+3 enddo call ascll(ymin,ymax) if (ymin.lt.ymax/1000) ymin=ymax/1000 write(nout,'(''1'',i3,''/'')') iwcol write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''thermal inelastic for e='',1p,e10.3, & '' MeV'',a,''/'')') qu,xss(itie+ie),qu write(nout,'(''-2 2/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,.5 write(nout,'(a,''osine'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,1. write(nout,'(a,''ec. nergy'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') zmin,zmax,1. write(nout,'(a,''

rob/cosine'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''10 -15 15 3.5 5.5 2.5/'')') write(nout,'(''1/'')') loc=nint(xss(itxe-1+ie)) nbini=nint(xss(itxe-1+nie+ie)) skip=1+log10(ymax/ymin)/60 epl=0 loc=loc+nang+3 do j=2,nbini-1 ep=(xss(loc+1)+epl)/2 if (xss(loc+1).gt.epl) then if (j.eq.2.or.ep/epl.gt.skip) then write(nout,'(1p,e14.6,''/'')') ep ul=-1 write(nout,'(1p,2e14.6,''/'')') -1.,zmin do k=1,nang u=xss(loc+3+k) if (k.lt.nang) then un=(u+xss(loc+3+k+1))/2 else un=1 endif if (k.eq.1.and.u-ul.gt.5*(un-u)) & ul=u-3*(un-u) if (k.eq.nang.and.un-u.gt.5*(u-ul)) & un=u+3*(u-ul) p=1 p=p/nang p=p/(un-ul) if (k.eq.1) & write(nout,'(1p,2e14.6,''/'')') ul,zmin write(nout,'(1p,2e14.6,''/'')') u,p if (k.eq.nang) & write(nout,'(1p,2e14.6,''/'')') un,zmin ul=un enddo write(nout,'(1p,2e14.6,''/'')') 1.,zmin write(nout,'(''/'')') epl=xss(loc+1) endif endif loc=loc+nang+3 enddo write(nout,'(''/'')') ie=ie+iskip enddo *d acer.14210,14216 if (ifeng.le.1) then n=ne*nieb*(nil+2) do i=1,n call typen(l,nout,2) l=l+1 enddo else n=2*ne do i=1,ne n=n+nint(xss(l+ne+i-1))*(nil+2) enddo do i=1,n call typen(l,nout,2) l=l+1 enddo endif *ident up114 */ leapr -- 01mar06 */ put out a few more discrete lines at low alpha *d leapr.1264 data small/1.d-8/ *d leapr.1349 if (n.lt.maxdd) then *d leapr.1429 if (wts(i).lt.100*small.and.i.gt.5) idone=1 *i leapr.1655 bminus(i)=0 bplus(i)=0 *i leapr.1669 bminus(i)=0 bplus(i)=0 */ weight is wrong when adding continuum parts for discrete lines *d leapr.1453,1454 st=sint(be,bex,rdbex,sex,nbx,al,tbeta+twt,tbart, & beta,nbeta,maxbb) */ allow for smaller sab numbers in endf file *d leapr.2659 data smin/2.d-75/ */ add skold method for handling intermolecular correlations * as used for d(d2o) by keinert and mattes. *i leapr.103 c * nsk 0 none (default) * c * 1 vinyard * c * 2 skold * *d leapr.148 c * card 17 - pair correlation control (nsk.ne.0 only) * *d leapr.154 c * card 19 - coherent scattering fraction for nsk.eq.2 only * c * cfrac coherent fraction * c * * c * card 20 - file 1 comments, repeat until blank line is read. * *d leapr.218 nsk=0 read(nsysi,*) awr,spr,npr,iel,ncold,nsk *d leapr.224,225 & '' cold moderator option ................ '',i10/ & '' s(kappa) option ...................... '',i10)') & awr,spr,npr,iel,ncold,nsk *d leapr.257 if (nsk.ne.0) call reserv('ssp',nsmax,issp,a) *d leapr.294 if (nsk.gt.0) then *i leapr.298 if (nsk.eq.1) & write(nsyso,'(/'' s(kappa) for vinyard method'')') if (nsk.eq.2) & write(nsyso,'(/'' s(kappa) for skold method'')') do i=1,nka write(nsyso,'(1p,2e12.4)') dka*i,ska(i) enddo *i leapr.299 c c ***read in coherent fraction for skold method if (nsk.eq.2) read(nsysi,*) cfrac c *i leapr.357 c c ***check for skold option for correlations if (nsk.eq.2) call skold(cfrac,itemp,temp,a(issm), & nalpha,nbeta,ntempr) *i leapr.2629 c subroutine skold(cfrac,itemp,temp,ssm,nalpha,nbeta,ntempr) c ****************************************************************** c use skold approximation to add in the effects c of intermolecular coherence. c ****************************************************************** implicit real*8 (a-h,o-z) dimension ssm(nbeta,nalpha,ntempr) common/mainio/nsysi,nsyso,nsyse,ntty common/ee/za,awr,spr,b7,aws,sps,mat,npr,iel,nss,mss common/bkc/bk common/ab/nalpha1,nbeta1,naint,nbint,alpha(200),beta(400) common/sc/tev,deltab,bk0,lat common/se/arat common/sk/ska(500),dka,nka dimension scoh(1000) data angst/1.d-8/ data therm/.0253d0/ data amassn/1.008664904d0/ data amu/1.6605402d-24/ data hbar/1.05457266d-27/ data ev/1.60217733d-12/ c ***apply the skold approximation tev=bk*abs(temp) sc=1 if (lat.eq.1) sc=therm/tev amass=awr*amassn*amu do i=1,nbeta do j=1,nalpha al=alpha(j)*sc/arat waven=angst*sqrt(2*amass*tev*ev*al)/hbar sk=terpk(ska,nka,dka,waven) ap=alpha(j)/sk do k=1,nalpha kk=k if (ap.lt.alpha(k)) exit enddo if (kk.eq.1) kk=2 call terp1(alpha(kk-1),ssm(i,kk-1,itemp), & alpha(kk),ssm(i,kk,itemp),ap,scoh(j),5) scoh(j)=scoh(j)*sk enddo do j=1,nalpha ssm(i,j,itemp)=(1-cfrac)*ssm(i,j,itemp) & +cfrac*scoh(j) enddo enddo c c ***report the results if (iprt.eq.1.and.iprint.eq.2) write(nsyso, & '(/'' results after applying skold approximation'')') do nal=1,nalpha iprt=mod(nal-1,naint)+1 if (nal.eq.nalpha) iprt=1 al=alpha(nal)*sc/arat if (iprt.eq.1.and.iprint.eq.2) write(nsyso, & '(/3x,''alpha='',f10.5)') al if (iprt.eq.1.and.iprint.eq.2) write(nsyso, & '(/4x,'' beta'',7x,''s(alpha,beta)'',7x,''ss(alpha,beta)'', & 5x,''ss(alpha,-beta)'')') do i=1,nbeta be=beta(i)*sc ss=ssm(i,nal,itemp) s1=ss*exp(-be/2) s2=ss*exp(-be) jprt=mod(i-1,nbint)+1 if (i.eq.nbeta) jprt=1 if (iprt.eq.1.and.jprt.eq.1.and.iprint.eq.2) & write(nsyso,'(f10.4,1pe18.5,1p,2e20.5)') & beta(i),s1,s2,ss enddo if (iprt.eq.1) then sum0=0 sum1=0 ff1l=0 ff2l=0 bel=0 do ibeta=1,nbeta be=beta(ibeta) ff2=ssm(ibeta,nal,itemp) ff1=ssm(ibeta,nal,itemp)*exp(-be) if (ibeta.gt.1) then sum0=sum0+(be-bel)*(ff1l+ff2l+ff1+ff2)/2 sum1=sum1+(be-bel) & *(ff2l*bel+ff2*be-ff1l*bel-ff1*be)/2 ff1l=ff1 ff2l=ff2 bel=be else bel=be ff1l=ff1 ff2l=ff2 sum0=0 sum1=0 endif enddo sum1=sum1/al if (iprint.eq.2) then write(nsyso,'('' normalization check ='',f8.4)') sum0 write(nsyso,'('' sum rule check ='',f8.4)') sum1 else if (iprint.eq.1) then write(nsyso,'(1x,f10.4,2f10.4)') al,sum0,sum1 endif endif enddo return end *ident up115 */ heatr -- 3apr06 */ skip over heating calculation when there is no distribution *i heatr.999 if (ebar.lt.zero) go to 291 *d heatr.1291 291 if (j6.ge.n6) go to 296 *d heatr.2490 write(strng,'(''no distribution for mt'',i3,'' particle '',i5)') */ allow for fission distributions in file 6 as in 7beta1 th-232. */ the yld becomes nubar. *d heatr.999 175 nwm=nwmax nwa=na call sixbar(e,ebar,yld,dame,nend6,a(ia),nwa,nscr,a(id),nwm, & n6,j6,irec,jrec) *i heatr.1002 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) q0=q *d heatr.1006 *i heatr.1009 if (icon.lt.0) go to 179 *i heatr.1028 if (irec.gt.0.and.icon.lt.0) izap=100 *d heatr.1131 & call sixbar(e,ebar,yld,dame,nend6,a(ia),nwa,nscr,a(id),nwm, & n6,j6,irec,jrec) *d heatr.1142 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then h=(e+q0-ebar*yld)*y else h=ebar*yld*y endif *i heatr.1151 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) ebal6=0 *d heatr.2418 subroutine sixbar(e,ebar,yld,dame,nin,c,ncmax,nscr,b,nbmax, & n2,j6,irec,jrec) *d heatr.2430 dimension c(ncmax),b(nbmax) *i heatr.2578 if ((mth.ge.18.and.mth.le.21).or.mth.eq.38) then matd=math mf1=1 mt1=452 c delayed neutrons are treated the same as fast neutrons. c this will cause a slight overestimate of en for fission. call hgtyld(e,enext,idis,yld,matd,mf1,mt1,nscr,b,nbmax) endif *i heatr.2660 if ((mth.ge.18.and.mth.le.21).or.mth.eq.38) then matd=math mf1=1 mt1=452 call hgtyld(e,enext,idis,yld,matd,mf1,mt1,nscr,b,nbmax) endif *ident up116 */ groupr -- 05apr06 */ fix reading tab1 record in conver (trkov, iaea) *i groupr.8422 do while (nb.ne.0) call moreio(nin,nout,nscr,a(iscr),nb,nw) enddo *ident up117 */ moder -- 05apr06 */ process compact format representation in mf32 (trkov, iaea) */ see new utility routine intgio in up118 below. *d moder.1277 external contio,listio,moreio,error *d up81.42 else if (lcomp.eq.1) then *b up81.60 else if (lcomp.eq.2) then call listio(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo call contio(nin,nout,nscr,a,nb,nw) nn=n1h do k=1,nn call intgio(nin,nout,nscr,a,nb,nw) end do else call error('file32','illegal value of lcomp',' ') *ident up118 */ njoy -- 05apr06 */ new utility routine to process compact format representation */ for mf32 (trkov, iaea). see also up117 which uses this subroutine. *i njoy.620 subroutine intgio(nin,nout,nscr,a,nb,nw) c ****************************************************************** c utility routine for endf/b coded and blocked binary tapes. c read, write, and/or convert one intg record. c positive units are coded, negative ones are blocked binary. c if any unit is zero, it is not used. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension a(20),ia(20) c c ***input if (nin.lt.0) then inin=iabs(nin) read(inin) math,mfh,mth,nb,nw,(a(j),j=1,nw) else if (nin.gt.0) then read(nin,'(2i5,1x,18i3,1x,i4,i2,i3,i5)') ia,math,mfh,mth,nsp do j=1,20 a(j)=ia(j) end do endif c c ***output nb=0 nw=20 if (nout.eq.0.and.nscr.eq.0) return inout=iabs(nout) if (nout.lt.0) then write(inout) math,mfh,mth,nb,nw,(a(j),j=1,nw) inout=0 endif inscr=iabs(nscr) if (nscr.lt.0) then write(inscr) math,mfh,mth,nb,nw,(a(j),j=1,nw) inscr=0 endif c c ***format the output do j=1,20 ia(j)=nint(a(j)) end do if (nscr.gt.0) then write(nscr,'(2i5,1x,18i3,1x,i4,i2,i3,i5)') ia,math,mfh,mth,nsc nsc=nsc+1 if (nsc.gt.99999) nsc=1 endif if (nout.gt.0) then write(nout,'(2i5,1x,18i3,1x,i4,i2,i3,i5)') ia,math,mfh,mth,nsh nsh=nsh+1 if (nsh.gt.99999) nsh=1 endif return end c *ident up119 */ acer -- 05apr06 */ fix bug that switched off ddx plots (trkov, iaea). *d up70.138,139 nr1=nint(xss(l)) if (nr1.gt.0) l=l+2*nr1 *d up70.191,192 nr1=nint(xss(l)) if (nr1.gt.0) l=l+2*nr1 *ident up120 */ errorr -- 05apr06 */ temporary patch to skip processing unrecognized options */ for mf32 (trkov, iaea). *d errorr.2498,2499 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *d errorr.2505,2506 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *d errorr.2511.2512 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *d errorr.2517,2518 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *d errorr.2526,2527 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *ident up121 */ heatr -- 13apr06 */ add tosend in nheat when the last subsection of file 6 */ section 5 does not include particle distributions. *d up115.7 291 if (j6.ge.n6) then c make sure we're at the end of section (will not be so if c there was no particle distribution for the last subsection c in this section). if (ebar.lt.zero) then call tosend(nin,0,0,a(ib)) call skiprz(nin,-1) endif go to 296 endif *ident up122 */ acer -- 13apr06 */ fix bad message for renormalizing the delayed spectrum */ the undefined index lxx can cause crashes *d up72.34,35 & '' precursor'',i2, & '' norm='',f8.6)') i,sumup *ident up123 */ acer -- 19apr06 */ increase storage limit for preVII thermal evaluations *d up94.13 common/astore/a(180000) *d up94.15 data namax/180000/, nidmax/27/ *d up94.17 common/astore/a(180000) *d up94.19 common/astore/a(180000) *d up94.21 common/astore/a(180000) *d up94.23 common/astore/a(180000) *d up94.25 common/astore/a(180000) *d up94.27 common/astore/a(180000) *d up94.29 common/astore/a(180000) *d up94.31 common/astore/a(180000) *d up94.33 data namax/180000/ *d up94.35 common/astore/a(180000) *d up94.37 common/astore/a(180000) *d up94.39 common/astore/a(180000) *d up94.41 common/astore/a(180000) *d up94.43 common/astore/a(180000) *d up94.45 common/astore/a(180000) *d up94.47 common/astore/a(180000) *d up94.49 common/astore/a(180000) *ident up124 */ thermr -- 19apr06 */ increase storage space for big preVII thermal evaluations *d thermr.134 nwscr=70000 */ allow for up to 32 angle bins as used in tripoli *d thermr.1421 dimension ex(20),x(20),y(33,20),yt(33) *d thermr.1473 data nlmax/33/ *ident up125 */ acer -- 19apr06 */ patch acer to handle the discrete anisotropic mf6 capture */ photon in endf/b-vii h-1. temporarily, the relativistic */ effect will be ignored and it will be treated as a */ simple primary photon. *d acer.4144,4146 egamma=0 if (law.eq.2) then call mess('convr', & 'discrete anisotropic photon', & 'treated as simple primary photon') egamma=c2h endif *i acer.4174 if (egamma.gt.0) then e=c2h a(iscr+8)=1 a(iscr+9)=0 a(iscr+10)=2 a(iscr+11)=1 a(iscr+12)=egamma+awr*e/(awr+1) a(iscr+13)=1 endif *ident up126 */ broadr -- 22apr06 */ watch out for tt(0) *d broadr.503,504 if (llf.gt.0) sf=slf+(tt(llf)-slf)*(enow-elast)/(tt(1)-elast) if (llc.gt.0)sc=slc+(tt(llc)-slc)*(enow-elast)/(tt(1)-elast) *d broadr.506,507 if (llf.gt.0) sf=tt(llf) if (llc.gt.0) sc=tt(llc) *ident up127 */ heatr -- 22apr06 */ the routine getsix doesn't have any coding to handle law 6 */ (phase space distributions). temporarily, we set ebar */ and dame equal to zero. this affects endf h-2 (n,2n). *i heatr.2776 if (law.eq.6) go to 505 *i heatr.2993 c c ***law 6. c ***phase space distribution. c ***temporarily returning zeroes. 505 ebar=0 dame=0 return */ missing save *i heatr.3287 save izat */ fix initialization of df for tabulated distributions *i heatr.2391 zero=0 c c ***initialize if (e.eq.zero) then d=df(e,z,awr,z,awr) return endif *ident up128 */ thermr -- 24apr06 */ fix ending point for coherent scattering, which sometimes */ goes into an infinite loop. *i thermr.1079 if (e.ge.elim) elim=emax *ident up129 */ njoy -- 26apr06 */ restructure do loop so tht bounds checking doesn't fail *d njoy.401,405 do i=1,l if (mess(i:i).ne.' ') then k=k+1 j=i endif enddo */ need large printed fields for storage diagnostics *d njoy.2638 write(nsyso,'(/58x,''storage '',i3,''/'',i8)') nidmax,iamax *d njoy.2753 write(nsyso,'(58x,''id '',a4,1x,i3,''/'',i8)') id,nidtot,ntot *d njoy.2788 write(nsyso,'(58x,''xx '',a4,5x,i8)') id,nwords *d njoy.2841 write(nsyso,'(/56x,''usage'',i8,''/'',i8)') nused,iamax *ident up130 */ acer -- 27apr06 */ increase Legendre array to 65 and add test to avoid array bound overflow *d acer.6952 dimension x(24),y(24),p(65),fl(65) *i acer.6964 data ipmax/65/ *i acer.6969 if ((nord+1).gt.ipmax) then write(strng,'(''nord+1 = '',i3,'' is > ipmax ('',i3,'').'')') & nord+1,ipmax call error('ptleg2',strng,' ') endif */ increase argument value from 100 to 300 to match */ nethr definition in subroutine first. *d acer.4220 if (nethr.gt.1) call aordr(nethr,300,a(iethr)) */ restructure if test since e1 and e2 are only defined */ when ithopt=1. *d acer.1476,1477 itest=0 if (iskp.le.0.or.i.ge.iskp) then itest=1 endif if (itest.eq.0.and.ithopt.eq.1) then if (e.lt.(1-eps)*e1.or.e.gt.(1+eps)*e2) then itest=1 endif endif if (itest.eq.1) then */ move egamma statement to assure it is initialized */ prior to subsequent usage. *i acer.4142 egamma=0 *d up125.8 */ provide a dummy law value so subsequent if statements */ have a defined value to test. *i acer.5343 law=-999 */ a do nothing change to keep the compiler happy. */ existing code logic (ltt3=3) is ok. *i acer.5615 ne1=0 */ make sure pp1 is initialized to zero. *i acer.9333 pp1=0 *ident up131 */ groupr -- 9may06 */ watch out for sed(_,0) *d groupr.8916 do while (ed.le.eg(ig)*(1+eps).and.ig.gt.1) */ save some additional variables. *i groupr.3214 save nq,ng1,ig1 */ this has not been a problem in the past, but its easy to */ include an additional else branch test to abort if an */ invalid quadrature order is ever set. *i groupr.3296 else call error('groupr','bad nq in panel',' ') */ add "save ipd,ird" in getyld so that initial call to */ terpa has all needed info. *i groupr.7785 save ipd,ird */ delete un-needed contio call. This record was read back */ in getmf6 and c(_) has been passed to f6psp. Actually */ as currently coded, nin in the contio argument list is */ undefined here. Most compilers will have set it to zero */ and the contio call does nothing, hence previous processing */ of 2h (the only evaluation using law=6 at this time) is */ probably ok. *d groupr.9367 *ident up132 */ moder --12may06 */ matd is undefined unless loop>0, therefore break if test */ into two pieces. *d moder.275 if (loop.gt.0) then if (mat.ne.matd.and.mat.ne.0) go to 130 endif *ident up133 */ reconr -- 12may06 */ make sure there is a ym to go with this xm. *i reconr.1910 call terp1(a(ix+i-1),a(iy+i-1),a(ix+i-2),a(iy+i-2),xm,ym,2) *ident up134 */ broadr -- 12may06 */ make sure ctev is initialized before subsequent if test */ dealing with thermal g-factor edit. *i broadr.531 ctev=zero *ident up135 */ heatr -- 12may06 */ make sure izap is saved for subsequent use in h6dis and bacha. *i heatr.788 common/projh/awrp,izap */ fix typo (fn should have been f) in this update. *d up55.35 d=d+(xx-xl)*(f+fl)/2 */ make sure tt=0 unless subsequent if clause changes it. *i heatr.3348 tt=0 */ need to save enow for future use by bacha. *i heatr.3287 save enow */ make sure ihi and ilo are initialized prior to subsequent */ if test for output. *i heatr.5082 ihi=0 ilo=0 */ fix the check plots *d heatr.5490 if (x.ge.thin*xlast.and.j.lt.2500) then *d heatr.5559 if (x.ge.xlast+thin.and.j.lt.2500) then *ident up136 */ heatr -- 30aug06 */ change energy dependent fission pseudo-q calculation. the */ coefficient used with the incident neutron energy in previous */ versons of njoy does not agree with the format manual energy */ dependent equations. see the endf7 paper in nuclear data sheets */ for a discussion. *d heatr.799 data fq1,fq2/8.07d6,0.307d0/ */ same as heatr.799, but for single precision code. *d heatr.810 data fq1,fq2/8.07e6,0.307e0/ */ rewrite the energy release equation with a plus sign. this lets */ the sign of the fq1 and fq2 coefficients given in the data */ statement control whether its truly addition or subtraction. *d heatr.1135,1136 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then q0=q00-(yld-yld0)*fq1+fq2*e endif *ident up137 */ heatr -- 31aug06 */ miscellaneous fixes. we are not aware of any issues with the */ heatr output from earlier versions of njoy, but these tweaks */ will make for more robust code: */ initialize this variable in double precision, as done for others. *d heatr.805 data up/1.1d0/ */ make sure nwmax is large enough to handle 239pu prompt */ (or total) nu tab1 array. *d heatr.818 data nwmax/6000/ */ make sure mf1 is defined for the hgtyld call and pass mtd (not mt1) */ for the file type. *d heatr.1921,1922 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then mf1=1 call hgtyld(e,enext,idis,yld,matd,mf1,mtd,nscr,b,nbmax) endif */ make sure the tab1 record fits into the allocated space. *i heatr.2036 loc=loc+nw if (loc.gt.na) call error('hgtyld', & 'storage exceeded.',' ') */ make sure the tab1 record fits into the allocated space. *i heatr.2052 loc=loc+nw if (loc.gt.na) call error('hgtyld', & 'storage exceeded.',' ') */ initialize these variables in double precision, as done for others. *d heatr.3518 data brk1,brk2,half/130.d0,41.d0,0.5d0/ */ eliminate redundant if tests. *d heatr.3553,3561 */ restructure these "if" tests since x is only defined when the */ gety2 call has been made. Needed to keep the compiler happy */ when processing endf/b-viib2 15n. *d heatr.4561,4562 if (mfd.eq.3) then call gety2(e,enext,idis,x,nin,a(ib)) if (x.eq.0.)go to 195 endif *ident up138 */ groupr -- 31aug06 */ tweaks in groupr's bach so that it tests the same list of iza */ possibilities as are tested in heatr's bacha and acer's bachaa. *i groupr.5924 if (iza.eq.28000) iza=28058 if (iza.eq.29000) iza=29063 if (iza.eq.31000) iza=31069 if (iza.eq.40000) iza=40090 if (iza.eq.42000) iza=42096 if (iza.eq.48000) iza=48112 if (iza.eq.49000) iza=49115 *i groupr.5925 if (iza.eq.63000) iza=63151 if (iza.eq.72000) iza=72178 *ident up139 */ acer - 31aug06 */ a tweak in acer's bachaa to make it consistent with heatr's bacha. *d acer.12951,12952 nb=nint(ab-zb) nc=nint(ac-zc) *ident up140 */ groupr -- 31aug06 */ make sure all variables that were changed while processing the */ previous reaction are restored to their defaults before starting */ on the next reaction. *i groupr.3223 nq=0 elast=0.d0 idisc=0 */ de is only defined with (lf.ne.12), therefore only calculate */ xc under the same condition. If not, endf/b-viib2 241,243am will */ abort due to undefined de. *d groupr.9034 if (lf.ne.12) xc=de/theta *ident up141 */ njoy -- 31aug06 */ initialize xold prior to first use. a value of zero means the */ "do while" loop is executed at least once. *i njoy.4662 xold=0 *ident up142 */ moder -- 31aug06 */ add coding to read the new beta-delayed photon data that may */ be found in files 1, 12 and 14, section 460 (beginning with */ endf/b-vii). This coding matches the specifications given */ by brown et al at the nov2004 & 2005 csewg meetings. */ note that no changes are needed for file 14 processing. *i moder.477 c c ***beta-delayed photon spectra else if (mth.eq.460) then if (l1h.eq.1) then ng460=n1h do ng=1,ng460 call tab1io(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo else if (l2h.eq.2) then call listio(nin,nout,nscr,a,nb,nw) else call error('file1','bad LO in mt=460.',' ') endif *i moder.1107 c 9/5/2006 - add logic to read 12/460, otherwise *i moder.1117 if (mf.eq.12 .and. mt.eq.460)then if (l1h.eq.1) then ng460=n1h do ng=1,ng460+1 call tab1io(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo else if (l2h.eq.2) then call listio(nin,nout,nscr,a,nb,nw) else call error('file12','bad LO in mt=460.',' ') endif else *i moder.1134 endif *ident up143 */ acer -- 31aug06 */ (these mods in response to c. broeders, karlsruhe) */ up113 uses "nsyso" in subroutine thrlod, but it was never defined. *i acer.13444 common/mainio/nsysi,nsyso,nsyse,ntty */ add error to the external subprogram list or some compilers will */ complain that our use doesn't conform to the intrinsic error function. *d acer.13467 external reserv,dater,repoz,error *ident up144 */ reconr -- 01sep06 */ already initialized "zero" in up92, delete the redundant up99 code. *d up99.5 *d up99.7 *ident up145 */ broadr -- 01sep06 */ (from "patch_japan_njoy99_112a.txt") */ need to put this if test inside the do loop. *d broadr.1085,1086 if (dn.lt.zero) dl(i)=-1 enddo *ident up146 */ heatr -- 01sep06 */ (from "patch_japan_njoy99_112a.txt") */ current code overloads "nz" and can never update loc. *d heatr.165,169 nz0=0 do j=1,nz if (a(loc+j-1).gt.flag) nz0=j enddo loc=loc+nz0 *ident up147 */ acer -- 01sep06 */ (several corrections, from "patch_japan_njoy99_112a.txt") */ maximum legendre order was changed from 20 to 64 years ago. */ change comment and hardwired do loop terminating constant to "ni". *d acer.2477 c ***the series for the integral of p-sub-n up to order ni. *d acer.2481 do n=1,ni */ need reaction q value when call acelf5 or acelf6. Therefore */ shift location of current code. *i acer.5439 q=xss(lqr+i-1) *d acer.5463 */ 2*nint(spi) is wrong; need nint(2.*spi). Here and line 7299. *d acer.5841 i2s=nint(2.*spi) */ make sure we never try to divide by zero *d acer.6917 if (xss(nexd+3*npep).ne.zero) then renorm=1./xss(nexd+3*npep) else renorm=1. endif */ need a bigger integer field for the error message. *d acer.7045 write(strng,'(i4,'' for mt='',i3,'' e='',1pe10.3)') negs,mt,e */ keep making various arrays larger. Use parameter statement so it */ will be easier the next time. *i acer.7147 parameter idmx=2000 *d acer.7151 dimension aco(idmx),cprob(idmx) *d acer.7205 if (ii.gt.idmx) call error('ptlegc', */ 2*nint(spi) is wrong; need nint(2.*spi). Here and line 5463. *d acer.7299 i2s=nint(2.*spi) *ident up148 */ njoy -- 05sep06 */ change asend, afend amend and atend utility routines to set the */ last section record counter to 99999 or the last file, material */ or tape section record counter to zero. Reset the counter to */ one for the next initial section record. *i njoy.1677 nsh=99999 *d njoy.1679,1680 nsh=1 *i njoy.1686 nsc=99999 *d njoy.1688,1689 nsc=1 *i njoy.1714 nsh=0 *d njoy.1717 *i njoy.1723 nsc=0 *d njoy.1726 *i njoy.1752 nsh=0 *d njoy.1755 *i njoy.1761 nsc=0 *d njoy.1764 *i njoy.1790 nsh=0 *d njoy.1793 *i njoy.1799 nsc=0 *d njoy.1802 *ident up149 */ broadr -- 19sep06 */ use unique variable to allocate nubar space. *d broadr.226,227 nwt=6+2*n1h+2*n2h call reserv('nutot',nwt,inutot,a) *ident up150 */ reconr -- 19sep06 */ update 142 fixed moder to handle the new mt460 beta-delayed */ photon data, but we also need patches so that we don't look for */ a corresponding mf=3, mt=460 when executing other modules. */ In particular, need patches in reconr, heatr, groupr and acer. */ Take care of reconr in this update, then heatr, groupr and */ acer in the next three updates. */ tested with endf/b-viib3 239pu. reconr output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). */ eliminate mf12,mt460 from lunion's output tape, which propagates */ through to recout. Put this test before existing if(mfh.eq.12) */ test to make sure it gets executed. *i reconr.1679 if (mth.eq.460) go to 150 *ident up151 */ heatr -- 20sep06 */ mods needed to skip over mf12, mt460 so that heatr doesn't */ try to find the non-existent mf3, mt460. */ tested with endf/b-viib3 239pu. heatr output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). */ expand test, only true when mtd.ne.460 now. *d heatr.485 if (mfd.eq.12.and.mtd.ne.460) mgam=1 */ omit mt460 as a reaction to include in the sum. *i heatr.4464 if (mf.eq.12.and.mt.eq.460) then call tosend(nscr,0,0,a(iscr)) go to 105 endif */ expand test, only true when mth.ne.460 now. *d heatr.4133 if (mfh.eq.12.and.mth.ne.460) go to 120 */ expand test, only true when mtd.ne.460 now. *d heatr.4614 if (mtd.ne.2.and.mtd.ne.460) h=-y*x*ebar *ident up152 */ groupr -- 21sep06 */ mods needed to skip over mf12, mt460. */ tested with endf/b-viib3 239pu. groupr output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). *i groupr.7988 if (mfh.eq.12.and.mth.eq.460) then call tosend(nin,0,0,a(iscr)) go to 110 endif *ident up153 */ acer -- 21sep06 */ mods needed to skip over mf12, mt460. */ tested with endf/b-viib3 239pu. acer output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). *d acer.675,676 if ((mfd.eq.12.and.mtd.ne.460).or.(mfd.eq.13)) then ngmt=ngmt+1 a(igmt-1+ngmt)=mfd*1000+mtd endif *i acer.3512 if (mf.eq.12.and.mt.eq.460) then call tosend(nf12c,0,0,a(iscr)) go to 150 endif *i acer.3828 if ((mfh.eq.12.and.mth.eq.460) .or. & (mfh.eq.14.and.mth.eq.460) ) then call tosend(nin,0,0,a(iscr)) go to 110 endif *ident up154 */ acer -- 22sep06 */ set nu-bar for neutron multiplicity on MF6 fission (trkov, iaea). */ force lab coordinate system. */ (Th-232 from ENDF/B-VII with anisotropic fission neutron distributions) */ exclude redundant lumped cross sections mt 851-870, if present. */ (not allowed by ENDF rules but needed by ERRORR). *d acer.5401 c set flag for CM system, except fission if (lct.ge.2 .and. mth.ne.18) n=-n *i acer.6432 if(mth.eq.18) ntyr=19 c force lab coordinate system for fission if(mth.eq.18) lct=1 *i acer.1938 & (iverf.ge.6.and.(mt.ge.851.and.mt.le.870)).or. */ initialize unset nxs and jxs elements. */ otherwise there can be problems if multiple acer runs */ are done in one njoy deck. *i acer.4690 do i=1,8 nxsd(i)=0 enddo do i=1,2 jxsd(i)=0 enddo *i up113.23 common/jxst/jxs(32) *i acer.13097 do i=1,9 nxsd(i)=0 enddo do i=1,32 jxs(i)=0 enddo *i acer.14318 do i=1,12 nxsd(i)=0 enddo do i=1,14 jxsd(i)=0 enddo do i=1,10 jxsd2(i)=0 enddo *i acer.14706 do i=1,12 nxsd(i)=0 enddo do i=1,27 jxsd(i)=0 enddo *i acer.15254 do i=1,8 nxsd(i)=0 enddo do i=1,21 jxsd(i)=0 enddo */ allow thermal names as long as six characters (trkov) *d acer.356 if (tscr(i:i).ne.' ') nch=i */ set default values for rkal and akal (kosako) *i acer.9120 rkal=0 akal=0 *ident up155 */ reconr -- 22sep06 */ be more precise in skipping redundant lumped reactions (Ivo Kodeli) *d up54.11 if (mth.gt.850.and.mth.le.870) go to 150 if (mth.gt.891) go to 150 *ident up156 */ leapr -- 22sep06 */ fix problems in recent updates reported by Lahey compiler (A. Trkov) *i up114.73 common/in/twt,c,tbeta,iprint *ident up157 */ groupr -- 22sep06 */ from a.trkov, ijs */ groupr A. Trkov, IJS, June 2006 */ allow processing of lumped reactions defined for covariances */ (problem pointed out by a.bidaud */ processing th-232 from endf/b-vii) *i groupr.3910 character*60 strng *i groupr.3964 c lumped reactions for covariance data if (iverf.ge.6.and.mtd.ge.850.and.mtd.le.874) mt=mtd *d groupr.3968 if (mt.eq.0) then write(strng,'(i4,'' invalid in endf'')') mtd call error('getsig','illegal mt.',strng) endif *ident up158 */ errorr -- 22sep06 */ further updates to process redundant lumped reactions (ivo kodeli) */ fix for si-28 endf/b-vi evaluation - more than 40 mt. (ivo kodeli) *d up110.38 if (mt.gt.850.and.mt.le.870) go to 121 if (mt.gt.891) call error('errorr','illegal mt gt 891.',' ') *d errorr.301 121 continue *d up110.40 if (mt1.lt.851.or.mt1.gt.870) go to 140 *d up110.42 if (mt.gt.850.and.mt.le.870) go to 190 *d up110.44,45 if (mt1.lt.851.or.mt1.gt.870) then call rdsig(mat1,mt1,a(ib),a(isig1)) else call lumpxs(mt1,mtl,a) endif *d up110.47 if (mts(ix).lt.851.or.mts(ix).gt.870) go to 250 *d up110.49 if (mtd.ge.800.and.mtd.le.891) mt=mtd *d errorr.130 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.157 nmtmax=80 *d errorr.529 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.880 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.998 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1093 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1682 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1755 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1831 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2235 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2240 dimension c(6),matp(60) *d errorr.2451 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2679 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2751 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.3000 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.3191 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.3382 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) */ tidy-up for consistency (a.trkov) *d up120.6,9 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.13,16 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.20,23 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.27,30 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.34,37 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) */ make sure l has the right value with multiple ni subsections *i errorr.1273 l=l+nw *d up110.12 *i errorr.1278 l=l+nw *ident up159 */ viewr -- 22sep06 */ a.trkov, IAEA, April 2006 */ fix colour shades in covariance plots *d up95.12 ifg=ishade *d up95.26,28 r=isrgb(1,ifg-40)/rgb g=isrgb(2,ifg-40)/rgb b=isrgb(3,ifg-40)/rgb *ident up160 */ covr -- 22sep06 */ from a.trkov, iaea, April 2006 */ - fix labels for unassigned mt numbers */ - improve trapping of large correaltion coefficients *i covr.1573 write(nmeh1(4:6),'(i3)') mt *d covr.1575,1576 inamel=6 ivl=0 */ move trapping of large correlations from level to matshd *d covr.1107 character*60 strng external reserv,findex,releas,error,mess *i covr.1122 one=1 two=2 eps=1.e-6 *i covr.1137 none=0 ntwo=0 cofm=0 *i covr.1143 cofa=abs(cof)-eps if (cofa.gt.abs(cofm)) then cofm=cof ixmx=i jxmx=j endif if (cofa.gt.two) then ntwo=ntwo+1 else if (cofa.gt.one) then none=none+1 endif if (cof.gt. one) cof= one if (cof.lt.-one) cof=-one *i covr.1146 if (none.gt.0) then write(strng,'(''largest coefficient='',1p,e13.5 & ,'' at index'',2i4)') cofm,ixmx,jxmx call mess('matshd',strng,' ') write(strng,'(i4 '' coefficients > 1'')') none call mess('matshd',strng,'reset and continue.') end if if (ntwo.gt.0) then write(strng,'(i4 '' coefficients > 2'')') ntwo c call error('matshd',strng,'terminate execution') call mess('matshd',strng,'reset and continue') endif *d covr.1365 *d covr.1367,1370 *d covr.1372,1385 zero=0 do i=1,nlev ilev=i if (abs(c).lt.xlev(i)) exit enddo if(c.lt.zero) ilev=-ilev */ fix for si-28 endf/b-vi evaluation - more than 40 mt. (ivo kodeli) */ delete redundant common/fig/ *d covr.44 c * ncase no. cases to be run (maximum=60) * *d covr.62 c * ncase no. cases to be run (maximum=60) * *d covr.112,113 *d covr.119 dimension imat(60),imt(60),imat1(60),imt1(60) *d covr.140 nfigmx=60 *d covr.141 ncamx=60 *d covr.460 nlstm=60 *ident up161 */ groupr -- 22aug06 */ add a capability to handle int=22 */ for evaluations taken from jendl. *i groupr.8751 iraw=l+ne*(ng+1) m=iraw *d groupr.8756,8760 m1=m call tab1io(nin,0,0,c(m),nb,nw) m=m+nw *d groupr.8762 if (m.gt.nc) call error('getsed', *d groupr.8764,8765 call moreio(nin,0,0,c(m),nb,nw) m=m+nw *d groupr.8768 c(l)=c(m1+1) l=l+1 *d groupr.8772 *d groupr.8777 call intega(c(l),e1,e2,c(m1),ip,ir) l=l+1 *d groupr.8779 *i groupr.8791 if (int.ge.11.and.int.le.15) call mess('getsed', & 'corresponding point interpolation not available',' ') *d groupr.8814 l=m *i groupr.8902 if (int.gt.5) then khi=nnow+ne*(ng+1) ehi=c(khi+1) nphi=nint(c(khi+5)) xhi=c(khi+6+2*nphi) do while (nne.lt.ne.and.ed.gt.ehi*(1+small).and. & iout.eq.0) klo=khi elo=ehi nplo=nphi xlo=xhi khi=klo+8+2*nplo ehi=c(khi+1) nphi=nint(c(khi+5)) xhi=c(khi+6+2*nphi) enddo endif *d groupr.8904,8909 c unit base. if (int.ge.21) then xend=xlo+(xhi-xlo)*(ed-elo)/(ehi-elo) do ig=1,ng e1=eg(ig) if (ig.eq.1) e1=0 e1lo=e1*xlo/xend e1hi=e1*xhi/xend e2=eg(ig+1) if (ig.eq.ng) e2=ebig e2lo=e2*xlo/xend e2hi=e2*xhi/xend ip=2 ir=2 call intega(flo,e1lo,e2lo,c(klo),ip,ir) ip=2 ir=2 call intega(fhi,e1hi,e2hi,c(khi),ip,ir) fe=flo+(fhi-flo)*(ed-elo)/(ehi-elo) sed(ikt,ig)=sed(ikt,ig)+pe*fe enddo c corresponding points. not implemented. else if (int.ge.11) then do ig=1,ng sed(ikt,ig)=0 enddo c cartesion. else do ig=1,ng call terp1(elo,c(llo+ig),ehi,c(lhi+ig), & ed,s,int) sed(ikt,ig)=sed(ikt,ig)+s*pe enddo endif *ident up162 */ purr -- 20nov06 */ extend rdf3un logic to handle a file with just mt=1,2,102 */ (endf/b 253Es, for example). Also make "goto 100" test */ more robust (this has not been a problem in the past). *i purr.978 if (mth.eq.mtx(ix)) then ibase=isb+nunr*(ix-1)-1 goto 130 endif *d purr.980 if (ix.le.4) go to 100 goto 200 *d purr.992 200 icx=0 *ident up163 */ acer -- 21nov06 */ in aplots, make sure xlast is defined before appearing in an if test. */ in aplots, re-structure if test to only check iff if nnf>0. */ in aplopp, re-code iimax usage so don't exceed the spect dimension limit. *i acer.18615 xlast=small *d acer.18825 if (nnf.gt.0) then if (i.ge.iif) fiss=xss(kf+2+i-iif) endif *d acer.20985,20987 xmin=delta xmax=delta*(iimax+1) *d acer.21175,21177 xmin=delta xmax=delta*(iimax+1) *ident up164 */ viewr -- 21nov06 */ make sure iskip is defined before appearing in an if test. *i viewr.3488 iskip=0 *ident up165 */ moder -- 21nov06 */ the next two updates clean up some omissions from recent updates, */ noted by A.Trkov, A.Hogenbirk and/or C.Broeders (upijs65 in upnea112). *d moder.1116 external tab1io,moreio,listio,error *ident up166 */ acer -- 21nov06 */ (upijs66 in upnea112) *d up147.31 parameter (idmx=2000) *ident up167 */ groupr -- 29nov06 */ mods from C.Broeders, A.Hebert, A.Trkov & A.C.Kahler */ - add missing dimension statement for flux and sig. */ - initialize a array to zero. */ - fix unit base interpolation, from up161. */ - extend up161 to account for multiple interpolation ranges. */ - make sure elo,xlo are always defined in getsed. */ - save variable, na, in f6cm (ack) */ - advise user of possible abort condition due to faulty */ data from unresr (ack). */ this update includes parts of upnea005 and upnea007 (from upnea12). *i groupr.251 dimension flux(10,10),sig(10,10) *i groupr.277 do i=1,iamax a(i)=zero enddo *d groupr.4136 external findex,terpu,terp1,error *i groupr.4213 if (sl.lt.zero.or.sn.lt.zero) call error('getunr', & ' negative cross sections found - check unresr',' ') *d groupr.5334 save eps,xc,ndnow,npnow,ncnow,elmax,e,epmax,na */ some comments and additional corrections to the unit base */ transformation mods made earlier. *i groupr.8782 c this l points to the p(E) TAB1 function *i groupr.8785 c this l points to the TAB2 function *i up161.27 c lnow points to one of the ne incident energies c followed by spectrum integrals by user energy group *i groupr.8855 c mnow points to the TAB2 function *i groupr.8880 c nnow points to one of the ne incident energies c followed by spectrum integrals by user energy group *d up161.32,35 klo=nnow+(ng+1)*ne elo=c(klo+1) nrlo=nint(c(klo+4)) nplo=nint(c(klo+5)) xlo=c(klo+4+2*nrlo+2*nplo) khi=klo+6+2*nrlo+2*nplo ehi=c(khi+1) nrhi=nint(c(khi+4)) nphi=nint(c(khi+5)) xhi=c(khi+4+2*nrhi+2*nphi) *d up161.40,45 nrlo=nrhi nplo=nphi xlo=xhi khi=klo+6+2*nrlo+2*nplo ehi=c(khi+1) nrhi=nint(c(khi+4)) nphi=nint(c(khi+5)) xhi=c(khi+4+2*nrhi+2*nphi) *d up161.51 jnt=int-20 call terp1(elo,xlo,ehi,xhi,ed,xend,jnt) *d up161.62 ir=1 *d up161.65 ir=1 *d up161.67 call terp1(elo,flo,ehi,fhi,ed,fe,jnt) *b groupr.8910 c c ***upscatter is not allowed in secondary energy *ident up168 */ thermr -- 29nov06 */ make sure sz2 is defined before appearing in subsequent if test. */ edit temperature with more digits. *i thermr.136 sz2=0 *d thermr.2648 & '' wrote thermal data for temp ='',1pe11.4,28x,0pf8.1,''s'')') *d thermr.2651 & '' wrote thermal data for temp ='',1pe11.4,28x,0pf8.1,''s'')') *ident up169 */ matxsr -- 04dec06 */ correct variable (from V.Sinitsa, upnea008 in upnea112). *d matxsr.1108 if (abs(b(loc)).ge.eps) go to 360 *ident up170 */ ccccr -- 04dec06 */ seems like we always need more space, increase array limit */ from 2000 to 8000 (C. Broeders, upnea003 in upnea112). *d ccccr.128 common/enddat/e(8000) *d ccccr.145 maxe=8000 *d ccccr.513 common/enddat/e(8000) *d ccccr.708 common/enddat/e(8000) *d ccccr.1005 common/enddat/e(8000) *d ccccr.1164 common/enddat/e(8000) *d ccccr.1980 common/enddat/e(8000) *d ccccr.2386 common/enddat/e(8000) *d ccccr.2536 common/enddat/e(8000) *d ccccr.3066 common/enddat/e(8000) *ident up171 */ matxsr -- 04dec06 */ more space again (C. Broeders, most of upnea006 in upnea112). */ a,ia from 50,000 to 200,000. */ ha from 25,000 to 100,000. */ b from 2,000 to 80,000. */ hvps, hmtx from 300 to 3,000. */ increase maxw from 5,000 to 50,000 is not included at this */ time since it affects TRANSX. */ add dimension limit test also. *d matxsr.393 common/mstore/a(200000) *d matxsr.405 isiza=200000 *d matxsr.496 common/mstore/a(200000) *d matxsr.505 dimension ia(200000),ha(100000) */ *d matxsr.512 */ maxw=50000 *d matxsr.762 common/mstore/a(200000) *d matxsr.770 dimension ia(200000),ha(100000) *d matxsr.887 common/mstore/a(200000) *d matxsr.906 dimension ia(200000),ha(100000) *d matxsr.1475 character*85 cm2 common/mstore/a(200000) *d matxsr.1482 common/hollr/hvps(3000),hmtx(3000) *d matxsr.1487 dimension ia(200000),ha(100000) *d up88.21 dimension b(8000) *d up88.23 maxb=8000 *i matxsr.1635 if (lout.lt.1.or.lout.gt.isiza) then write(cm2,'(6(a,i8))')' ivdat=',ivdat,' n1i=',n1i,' ning',ning, & ' ig=',ig,' lout=',lout,' isiza=',isiza call error('vector','lout>isiza',cm2) endif lin=lz+nl*(nz+iz-1)+1 if (lin.lt.1.or.lin.gt.maxb) then write(cm2,'(6(a,i8))')' lz=',lz,' nl=',nl,' nz',nz,' iz=',iz, & ' lin=',lin,' maxb=',maxb call error('vector','lin>maxb',cm2) endif *d matxsr.1806 common/mstore/a(200000) *d matxsr.1814 common/hollr/hvps(3000),hmtx(3000) *d matxsr.1821 dimension ia(200000),ha(100000) *d matxsr.1971 common/mstore/a(200000) *d matxsr.1975 dimension ia(200000) *d matxsr.2071 common/mstore/a(200000) *ident up172 */ purr -- 04dec06 */ the original purr coding correctly built the mt153 section except for */ the final heating values. ident up62 corrected this for direct heating */ values but not for heating "factors". This ident correctly computes */ the heating term, direct or factor (H. Trellue, LANL). *d purr.452,478 a(l)=a(l)+(a(k+1)-a(k+2)-a(k+3)-a(k+4)) h=a(k+2) if (lssf.eq.1) then h=h*a(n1+j+2*nbin) else if (sigu(2,1,1).ne.0) then h=h*a(n1+j+2*nbin)/sigu(2,1,1) endif a(l)=a(l)+h h=a(k+3) if (lssf.eq.1) then h=h*a(n1+j+3*nbin) else if (sigu(3,1,1).ne.0) then h=h*a(n1+j+3*nbin)/sigu(3,1,1) endif a(l)=a(l)+h h=a(k+4) if (lssf.eq.1) then h=h*a(n1+j+4*nbin) else if (sigu(4,1,1).ne.0) then h=h*a(n1+j+4*nbin)/sigu(4,1,1) endif a(l)=a(l)+h if (lssf.eq.1) then a(l)=a(l)/a(k+1)/a(n1+j+nbin) else if (a(n1+j+nbin).ne.zero) a(l)=a(l)/a(n1+j+nbin) endif *ident up173 */ acer -- 18dec06 */ check file5 TAB1 secondary spectra when lf=1 for multiple [e,f(e)] */ data where f(e)=0. If found, delete all but the last pair or else */ interpolation can produce a distorted secondary energy distribution. */ Also, if histogram interpolation is used for the secondary spectra, */ eliminate all leading [e,f(e)] data where f(e)=0. This issue noted */ by Sutton and Trumbull (KAPL) and documented in Transactions of the */ American Nuclear Society, volume 93 (2005) 555. *i acer.2124 character*60 string *i acer.2166 nt1w=2500 call reserv('tab1',nt1w,itab1,a) *d acer.2298 c ***for file 5, get mf, mt and tab1 lf. c ***if lf.ne.1, copy as is to nout c ***if lf.eq.1, check secondary spectrum tab1 functions c for multiple [e,f(e)=0.] data pairs. For non-histogram c interpolation, eliminate the lower energy pairs before c writing the function to nout. For histogram interpolation, c eliminate all low energy f(e)=0 data pairs. *d acer.2307 c call tosend(nin,nout,0,a(iscr)) loct1=itab1 c ***read the initial tab1 and get lf. call tab1io(nin,0,0,a(loct1),nb,nw) do while (nb.ne.0) loct1=loct1+nw if(loct1.gt.(itab1+nt1w))then call error('topfil', & 'itab1 allocation is too small1',' ') endif call moreio(nin,0,0,a(loct1),nb,nw) enddo lf=nint(a(itab1+3)) c ***move this tab1 to nout (all the time). call tab1io(0,nout,0,a(itab1),nb,nw) loct1=itab1+nw do while (nb.ne.0) call moreio(0,nout,0,a(loct1),nb,nw) loct1=loct1+nw enddo c ***if not lf=1, write rest of this section to nout. if(lf .ne. 1)then call tosend(nin,nout,0,a(iscr)) else c ***lf=1, read the tab2 function. loct2=itab1 call tab2io(nin,0,0,a(loct2),nb,nw) ne2=nint(a(loct2+5)) c ***move this tab2 to nout (all the time). call tab2io(0,nout,0,a(loct2),nb,nw) c ***check secondary tab1 functions. do nn=1,ne2 loct1=itab1 call tab1io(nin,0,0,a(loct1),nb,nw) do while (nb.ne.0) loct1=loct1+nw if(loct1.gt.(itab1+nt1w))then call error('topfil', & 'itab1 allocation is too small2', & ' ') endif call moreio(nin,0,0,a(loct1),nb,nw) enddo nr=nint(a(itab1+4)) nf=nint(a(itab1+5)) c ***check tab1 for multiple f(e)=0 data. c ***if the first f(e) is non-zero, nothing else to do. c ***if histogram interpolation, check from the first c ***f(e) value, if not check from the second f(e) value loc=itab1+6+2*nr+1 if(a(loc).eq.zero)then if(nint(a(itab1+7)) .ne. 1)loc=loc+2 locmx=itab1+6+2*nr+2*nf npe=0 do while(a(loc).eq.zero) if(loc.gt.locmx)then write(string,'(a,i3,a)')'mf=5,mt=',mt, & ', entire tab1 function is zero.' call error('topfil',string,' ') endif loc=loc+2 npe=npe+1 enddo if(npe.ne.0)then c ***yes multiple zero data found, eliminate them. c ***fix nf; c ***fix the pointer array (interpolation code c array remains the same); c ***shift a array. a(itab1+5)=a(itab1+5)-float(npe) loc=itab1+6 do n=loc,loc+2*nr,2 a(n)=a(n)-float(npe) enddo loc=itab1+6+2*nr-1 do n=1,nint(2*a(itab1+5)) a(loc+n)=a(loc+n+2*npe) enddo endif endif c ***write the tab1 function to nout. call tab1io(0,nout,0,a(itab1),nb,nw) loct1=itab1+nw do while (nb.ne.0) call moreio(0,nout,0,a(loct1),nb,nw) loct1=loct1+nw enddo enddo c ***write section end record to nout. call contio(nin,nout,0,a(iscr),nb,nw) endif *ident up174 */ acer -- 13dec06 */ photon yield tables generated from transition probability arrays by */ convr currently have an upper energy of 20 mev. some new evaluations */ have transitions given for higher energies (e.g., th-232 to 60 mev). */ this patch uses the emax parameter from file 1 for endf-6 format */ evaluations, and leaves the 20 mev limit for the older formats. */ the effect of this problem shows up as gpd mismatch problems in the */ acer consistency checks. *i up63.6 common/acea/elim *i acer.634 elim=ehi if (iver.eq.6) elim=a(iscr+1) *i acer.3736 common/acea/elim *d acer.4072 a(iscr+10)=elim *d acer.4089 a(iscr+10)=elim *ident up175 */ broadr -- 13dec06 */ this patch increases the number of reactions that can be broadened */ simultaneously from 10 to 40 (from kazuaki kosako). it comes into */ effect when thnmax<0 is used to override the default maximum energy */ for broadening (the smallest of 1 mev, the start of the UR range, */ or the first threshold). this can be important for very high */ temperatures (e.g., astropysics). caution: when UR data are present, */ thnmax<0 will broaden them. this is not quite physically correct, */ but it is probably not a significant error at high temperatures (this */ patch also implements the change specified in upnea012 of upnea12). *b broadr.104 parameter (nttmax=40) *d broadr.114 dimension temp2(10),tt(nttmax+1),mtr(nttmax),mti(nttmax) *d broadr.138 ntt=nttmax *d broadr.410 & '' points out='',i6/(9x,''mt'',16i4:))') *b broadr.923 parameter (nttmax=40) *d broadr.927 dimension tt(nttmax+1) *b broadr.1034 parameter (nttmax=40) *d broadr.1038,1039 dimension ks(12),es(12),js(12),ss(nttmax,12) dimension tt(nttmax+1),sn(nttmax),dl(nttmax) *b broadr.1243 parameter (nttmax=40) *d broadr.1249 dimension fzero(5),sbt(nttmax) *b broadr.1409 parameter (nttmax=40) *d broadr.1413 dimension tt(nttmax+1) *ident up176 */ broadr -- 13dec06 */ allow for broadening of the charged particle levels in endf-6 */ format evaluations (e.g., mt800, 801, ...) if thnmax<0 has been */ used to override the default upper limit for broadening. *d broadr.329 if (iverf.lt.6) then if (mth.gt.150) go to 165 else if (mth.gt.150.and.mth.lt.600) go to 165 if (mth.ge.850) go to 165 endif */ increase the memory available to broadr. For reactor applications */ an array size of several hundred thousand is adequate; a value of */ 2,000,000 allows a complex evaluation like endf/b-vii 238u to be */ broadened to stellar temperatures in a single step. *d up58.9 dimension a(2000000) *d up58.11 namax=2000000 *ident up177 */ thermr -- 13dec06 */ improve energy grid for free gas scattering at higher temperatures. */ this method maps the range of egrid (1e-5 to 10 ev) onto a new */ grid running from 1e-5 ev to (10 eV)*temp/293.6. *d thermr.1734 if (temp.gt.break) then tone=therm/bk elo=egrid(1) enow=elo*exp(log(enow/elo)*log((temp/tone)*egrid(ngrid)/elo) & /log(egrid(ngrid)/elo)) endif *ident up178 */ acer -- 18dec06 */ make sure spect(_) index in aplopp is legal; force the */ lowest energy into the first index. *d acer.20889 iii=max0(1,nint(eg/delta)) *d acer.20936 iii=max0(1,nint(ep/delta)) *d acer.21072 iii=max0(1,nint(eg/delta)) *d acer.21120 iii=max0(1,nint(ep/delta)) *ident up179 */ viewr -- 21dec06 */ add a little more information to the .ps output file *i viewr.3696 write(nps,'(''%%Pages: (atend)'')') *i viewr.3713 if(ipage.lt.10)then write(nps,'(''%%Trailer'',/,''%%Pages: '',i1)')ipage elseif(ipage.lt.100)then write(nps,'(''%%Trailer'',/,''%%Pages: '',i2)')ipage else write(nps,'(''%%Trailer'',/,''%%Pages: '',i3)')ipage endif *ident up180 */ njoy -- 05feb07 */ combine with idents 181 (reconr) and 182 (broadr) to allow for */ 8-digit energies in the 0.1 eV to 1.0 eV interval. Previous coding */ assumed 7-digit "e" format was good enough to yield monotonically */ increasing energy in this interval. Issue reported by Lubitz (KAPL). *i njoy.1268 tenth=0.1d0 *i njoy.1279 tenth=0.1e0 *d njoy.1297 100 if (x.gt.tenth.and.x.lt.amil) go to 130 *d njoy.1345,1353 140 f=x s='-' n=-1 *d njoy.1355 if (n.le.0) write(hx,'(f11.8)') f *d njoy.1361 if (n.eq.-1)n=1 if (f.ge.one .and. hx(10:11).eq.'00')write(hx,'(f9.6,a,i1)')f,s,n if (f.gt.tenth .and. f.lt.one .and. hx(11:11).eq.'0') & write(hx,'(1pf9.6,a,i1)')f,s,n *ident up181 */ reconr -- 05feb07 */ combine with idents up180 and up182 to allow an 8-digit f format */ for the energy, when necessary, in lieu of a 7-digit e format in */ the 0.1 eV to 1.0 eV energy interval. *i reconr.2014 data n7,n8,n9/7,8,9/ *d reconr.2019 data tenth,one,ten/0.1d0,1.d0,10.d0/ *d reconr.2025 data tenth,one,ten/0.1e0,1.e0,10.e0/ *d reconr.2110.2111 ndig=n9 if(xm.gt.tenth .and. xm.lt.one)then ndig=n8 endif if(xm.gt.sigfig(a(ix+i-1),ndig,+1) .and. & xm.lt.sigfig(a(ix+i-2),ndig,-1))go to 135 *d reconr.2145 xm=sigfig(xm,ndig,0) *ident up182 */ broadr -- 09feb07 */ combine with idents up180 and up181 to allow an 8-digit f format */ for the energy, when necessary, in lieu of a 7-digit e format in */ the 0.1 eV to 1.0 eV energy interval. *i broadr.1042 data n7,n8,n9/7,8,9/ *i broadr.1044 data ssmall/1.d-6/ data tenth/0.1d0/ *i broadr.1054 data ssmall/1.e-6/ data tenth/0.1e0/ *i broadr.1133 ndig=n9 if(em.gt.tenth .and. em.lt.one)then ndig=n8 endif *d broadr.1138 em=sigfig(em,ndig,0) *d broadr.1141,1142 if (em.lt.sigfig(es(is) ,ndig,+1) .or. & em.gt.sigfig(es(is-1),ndig,-1)) go to 150 */ original issue (from up180) was caused when a very dense */ energy mesh was created for a truly small cross section. */ Insert a threshold test for each partial cross section so */ that small cross sections aren't part of the energy mesh */ generation process. *i broadr.1152 stot=zero do 144 i=1,nreac stot=stot+sn(i) 144 continue *i broadr.1153 if(abs(sn(i)/stot).lt.ssmall)go to 145 *ident up183 */ acer -- 3may07 */ (was called up178 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ fix patching of mf5/law1 records to allow for multiple */ law 1 subsections (for jeff delayed neutrons). *i acer.2306 nk=n1h ik=0 111 ik=ik+1 *i up173.111 if (ik.lt.nk) go to 111 *ident up184 */ heatr -- 3may07 */ (was called up179 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ allow for larger mf1/mt452 sections (for jeff pu-239) *d up137.12 data nwmax/7000/ *ident up185 */ heatr -- 8may07 */ (was called up180 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ an error was made in up115 that incorrectly located a goto */ for file 6 processing. the effect was to add only the elastic */ contribution to the heating and omit the more important */ charged particle heating from sections of file 6. *d up115.21 *i heatr.1005 if (icon.lt.0) go to 179 */ for some extremely forwardly peaked distributions (e.g., mt2 */ at 200 mev in pb204) heatr can calculate mubar values greater */ than one, which leads to small negative elastic kerma */ contributions, and negative damage energy. the quadrature */ used has order 64. with this patch, we prevent mubar from */ become greater than one or damage energy from becoming */ negative. the elastic kerma and damage will not be */ accurate, but they are small, and they won't be negative. *i heatr.1678 if (wbar.gt.qp(64)) wbar=qp(64) *i heatr.1694 if (dame.lt.zero) dame=zero *ident up186 */ acer -- 10may07 */ (was called up181 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ correct the emin values for discrete photons from positive q */ reactions (example is as-74 from endf/b-vii). *d acer.497 call convr(nendf,npend,nscr2,0,nedis,nethr,a) *d acer.3720 subroutine convr(nin,npend,nout,nscr,nedis,nethr,a) *i acer.3740 dimension eeth(350) dimension mtth(350) *i acer.3820 c c ***get thresholds vs mt number call findf(matd,3,0,npend) nnth=0 101 call contio(npend,0,0,a(iscr),nb,nw) if (mfh.eq.0) go to 102 e=0 call gety1(e,enxt,jdis,x,npend,a(iscr)) nnth=nnth+1 eeth(nnth)=enxt mtth(nnth)=mth call tosend(npend,0,0,a(iscr)) go to 101 102 continue *i acer.4060 elow=0 do i=1,nnth if (mtth(i).eq.mth) elow=eeth(i) enddo *d acer.4070 a(iscr+8)=elow *d acer.4087 a(iscr+8)=elow */ zero out the gamma production value at the threshold *i acer.3554 if (i.gt.1.and.e.lt.thresh*(1+eps)) y=0 *ident up187 */ heatr -- 10may07 */ (was called up182 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ fix energy bounds for reconstructing photon yields from */ lo=2 transtion probability arrays to allow for energies */ higher than 20 mev and for positive q values. *i heatr.414 common/lims/ebot,etop *i heatr.447 etop=20000000 ebot=1 ebot=ebot/100000 *i heatr.464 if (iverf.eq.6) etop=c2h *i heatr.4103 common/lims/ebot,etop *d heatr.4279 a(iscr+8)=ebot *d heatr.4296 a(iscr+8)=ebot *ident up188 */ heatr -- 18may07 */ (was called up183 in earlier ack up### files; is re-numbered */ here to keep all updates in calendar order). */ investigate heatr optimization issue; runs ok with zero */ optimization; dies in file6, mt5 with o2 and static. */ solution: add missing variable (na) to save statement *d heatr.3052 save small,xc,ndnow,npnow,ncnow,elmax,e,epmax,na *ident up189 */ heatr -- 21may07 */ (upnea010) */ increase maximum number of lo=2 gammas *d groupr.7957 lmax=500 *ident up190 */ heatr -- 21may07 */ (upnea011) */ increase maximum number of lo=2 gammas (corresponds to */ change in ident189). *d heatr.4120 lmax=500 *ident up191 */ leapr -- 21may07 */ idents 10 and 114 modified some real*8 variables but failed */ to update the corresponding single precision variables. */ Do so here. Also correct a couple of instances where "e" */ format was used when it should have been "d", or vice-versa. *d leapr.1201 data c0/.125e0/ *d leapr.1269 data small/1.e-8/ *d leapr.1695 data small/1.d-9/ *d leapr.1736 data small/1.d-9/ *d leapr.1878 data amassh/3.3465e-24/ *d leapr.1886 data angst/1.e-8/ *d up86.12 data al1,al3,al4/4.04d-8,26.7495d0,1.495d0/ *d up86.17 data al1,al3,al4/4.04e-8,26.7495e0,1.495e0/ */ up114.24 is part of an internal ident114 comment. Delete it */ from the source code. *d up114.24 *i up114.71 *if sw *i up114.72 *endif *i up114.81 *if sw *i up114.87 *else data angst/1.e-8/ data therm/.0253e0/ data amassn/1.008664904e0/ data amu/1.6605402e-24/ data hbar/1.05457266e-27/ data ev/1.60217733e-12/ *endif *d leapr.2666 c --- Warning - single precision compilation on a 32-bit machine c will likely set smin to zero. data smin/2.e-75/ *ident up192 */ covr -- 21may07 */ ident111 changed a real*8 data statement; do the same */ for the corresponding single precision data. *d covr.127 c data tlev/.2e0,.4e0,.6e0,.8e0,1.0e0/ data tlev/.1e0,.2e0,.3e0,.4e0,1.0e0/ *ident up193 */ heatr -- 21may07 */ ident43 changed a real*8 data statement; do the same */ for the corresponding single precision data. *d heatr.429 data rup/1.0000001e0/ *ident up194 */ njoy -- 21may07 */ clean up double precision versus single precision code differences *d up141.6 xold=0.d0 *b njoy.4705 xold=0.e0 */ new intgio routine in ident118 is written for real*8 only. */ include single precision definitions here. *i up118.12 *if sw *i up118.13 *endif *ident up195 */ groupr -- 21may07 */ ident up107 only introduced new group structures for double */ precision NJOY. Add the corresponding single precision data */ here. *b groupr.1634 data eg19/ &1.000010e-05,1.000000e-01,5.400000e-01,4.000000e+00,8.315287e+00, &1.370959e+01,2.260329e+01,4.016900e+01,6.790405e+01,9.166088e+01, &1.486254e+02,3.043248e+02,4.539993e+02,7.485183e+02,1.234098e+03, &2.034684e+03,3.354626e+03,5.530844e+03,9.118820e+03,1.503439e+04, &2.478752e+04,4.086771e+04,6.737947e+04,1.110900e+05,1.831564e+05, &3.019738e+05,4.978707e+05,8.208500e+05,1.353353e+06,2.231302e+06, &3.678794e+06,6.065307e+06,1.000000e+07,1.964033e+07/ data eg20a/ &1.000010e-05,3.000000e-03,5.000000e-03,6.900000e-03,1.000000e-02, &1.500000e-02,2.000000e-02,2.500000e-02,3.000000e-02,3.500000e-02, &4.200000e-02,5.000000e-02,5.800000e-02,6.700000e-02,7.700000e-02, &8.000000e-02,9.500000e-02,1.000000e-01,1.150000e-01,1.340000e-01, &1.400000e-01,1.463700e-01,1.530300e-01,1.600000e-01,1.697100e-01, &1.800000e-01,1.890000e-01,1.988100e-01,2.091400e-01,2.200000e-01, &2.335800e-01,2.480000e-01,2.635100e-01,2.800000e-01,3.000000e-01, &3.145000e-01,3.200000e-01,3.346600e-01,3.500000e-01,3.699300e-01, &3.910000e-01,4.000000e-01,4.139900e-01,4.330000e-01,4.496800e-01, &4.670100e-01,4.850000e-01,5.000000e-01,5.196200e-01,5.315800e-01, &5.400000e-01,5.669600e-01,5.952800e-01,6.250000e-01,6.531500e-01, &6.825600e-01,7.050000e-01,7.415500e-01,7.800000e-01,7.900000e-01, &8.194500e-01,8.500000e-01,8.600000e-01,8.764250e-01,9.100000e-01, &9.300000e-01,9.500000e-01,9.720000e-01,9.860000e-01,9.960000e-01, &1.020000e+00,1.035000e+00,1.045000e+00,1.071000e+00,1.080000e+00, &1.097000e+00,1.110000e+00,1.123000e+00,1.150000e+00,1.170000e+00, &1.202060e+00,1.235000e+00,1.267080e+00,1.300000e+00,1.337500e+00, &1.370000e+00,1.404560e+00,1.440000e+00,1.475000e+00,1.500000e+00, &1.544340e+00,1.590000e+00,1.629510e+00,1.670000e+00,1.711970e+00/ data eg20b/ &1.755000e+00,1.797000e+00,1.840000e+00,1.855390e+00,1.884460e+00, &1.930000e+00,1.974490e+00,2.020000e+00,2.059610e+00,2.100000e+00, &2.130000e+00,2.185310e+00,2.242050e+00,2.300270e+00,2.360000e+00, &2.382370e+00,2.421710e+00,2.485030e+00,2.550000e+00,2.600000e+00, &2.659320e+00,2.720000e+00,2.767920e+00,2.837990e+00,2.909830e+00, &2.983490e+00,3.059020e+00,3.137330e+00,3.217630e+00,3.300000e+00, &3.380750e+00,3.466330e+00,3.554080e+00,3.644050e+00,3.736300e+00, &3.830880e+00,3.927860e+00,4.000000e+00,4.129250e+00,4.233782e+00, &4.340961e+00,4.450853e+00,4.563526e+00,4.679053e+00,4.797503e+00, &4.918953e+00,5.043477e+00,5.085681e+00,5.128239e+00,5.171153e+00, &5.214426e+00,5.258061e+00,5.302061e+00,5.346430e+00,5.391169e+00, &5.436284e+00,5.481775e+00,5.527647e+00,5.573904e+00,5.620547e+00, &5.667581e+00,5.715008e+00,5.762832e+00,5.811056e+00,5.859684e+00, &5.908719e+00,5.958164e+00,6.008022e+00,6.058298e+00,6.108995e+00, &6.160116e+00,6.211665e+00,6.263645e+00,6.316060e+00,6.368914e+00, &6.422210e+00,6.475952e+00,6.530144e+00,6.584789e+00,6.639892e+00, &6.695455e+00,6.751484e+00,6.807981e+00,6.864952e+00,6.922399e+00, &6.980326e+00,7.038739e+00,7.097640e+00,7.157034e+00,7.216925e+00, &7.277317e+00,7.338215e+00,7.399622e+00,7.461544e+00,7.523983e+00/ data eg20c/ &7.586945e+00,7.650434e+00,7.714454e+00,7.779009e+00,7.844105e+00, &7.909746e+00,7.975936e+00,8.042680e+00,8.109982e+00,8.177848e+00, &8.246281e+00,8.315287e+00,8.384871e+00,8.455037e+00,8.525790e+00, &8.597135e+00,8.669077e+00,8.741621e+00,8.814772e+00,8.888536e+00, &8.962916e+00,9.037919e+00,9.113550e+00,9.189814e+00,9.266715e+00, &9.344261e+00,9.422455e+00,9.501303e+00,9.580812e+00,9.660985e+00, &9.741830e+00,9.823351e+00,9.905554e+00,9.988446e+00,1.007203e+01, &1.015631e+01,1.024130e+01,1.032701e+01,1.041342e+01,1.050056e+01, &1.058843e+01,1.067704e+01,1.076639e+01,1.085648e+01,1.094733e+01, &1.103894e+01,1.113132e+01,1.122446e+01,1.131839e+01,1.141311e+01, &1.150861e+01,1.160492e+01,1.170203e+01,1.179995e+01,1.189870e+01, &1.199827e+01,1.209867e+01,1.219991e+01,1.230201e+01,1.240495e+01, &1.250876e+01,1.261343e+01,1.271898e+01,1.282542e+01,1.293274e+01, &1.304097e+01,1.315010e+01,1.326014e+01,1.337110e+01,1.348299e+01, &1.359582e+01,1.370959e+01,1.382431e+01,1.394000e+01,1.405665e+01, &1.417428e+01,1.429289e+01,1.441250e+01,1.453310e+01,1.465472e+01, &1.477735e+01,1.490101e+01,1.502570e+01,1.515144e+01,1.527823e+01, &1.540608e+01,1.553500e+01,1.566500e+01,1.579609e+01,1.592827e+01, &1.606156e+01,1.619597e+01,1.633150e+01,1.646816e+01,1.660597e+01/ data eg20d/ &1.674493e+01,1.688506e+01,1.702635e+01,1.716883e+01,1.731250e+01, &1.745738e+01,1.760346e+01,1.775077e+01,1.789931e+01,1.804910e+01, &1.820013e+01,1.835244e+01,1.850601e+01,1.866087e+01,1.881703e+01, &1.897449e+01,1.913328e+01,1.929339e+01,1.945484e+01,1.961764e+01, &1.978180e+01,1.994734e+01,2.011426e+01,2.028258e+01,2.045231e+01, &2.062345e+01,2.079603e+01,2.097006e+01,2.114554e+01,2.132249e+01, &2.150092e+01,2.168084e+01,2.186227e+01,2.204522e+01,2.222969e+01, &2.241572e+01,2.260329e+01,2.279244e+01,2.298317e+01,2.317550e+01, &2.336944e+01,2.356499e+01,2.376219e+01,2.396104e+01,2.416154e+01, &2.436373e+01,2.456761e+01,2.477320e+01,2.498050e+01,2.518954e+01, &2.540033e+01,2.561289e+01,2.582722e+01,2.604335e+01,2.626128e+01, &2.648104e+01,2.670264e+01,2.692609e+01,2.715141e+01,2.737862e+01, &2.760773e+01,2.783875e+01,2.807171e+01,2.830662e+01,2.854349e+01, &2.878235e+01,2.902320e+01,2.926607e+01,2.951098e+01,2.975793e+01, &3.000695e+01,3.025805e+01,3.051126e+01,3.076658e+01,3.102404e+01, &3.128365e+01,3.154544e+01,3.180942e+01,3.207560e+01,3.234401e+01, &3.261467e+01,3.288760e+01,3.316281e+01,3.344032e+01,3.372015e+01, &3.400233e+01,3.428686e+01,3.457378e+01,3.486310e+01,3.515484e+01, &3.544902e+01,3.574566e+01,3.604479e+01,3.634642e+01,3.665057e+01/ data eg20e/ &3.695727e+01,3.726653e+01,3.757838e+01,3.789285e+01,3.820994e+01, &3.852969e+01,3.885211e+01,3.917723e+01,3.950507e+01,3.983565e+01, &4.016900e+01,4.050514e+01,4.084410e+01,4.118589e+01,4.153054e+01, &4.187807e+01,4.222851e+01,4.258189e+01,4.293822e+01,4.329753e+01, &4.365985e+01,4.402521e+01,4.439361e+01,4.476511e+01,4.513971e+01, &4.551744e+01,4.589834e+01,4.628243e+01,4.666972e+01,4.706026e+01, &4.745407e+01,4.785117e+01,4.825160e+01,4.865538e+01,4.906253e+01, &4.947309e+01,4.988709e+01,5.030456e+01,5.072551e+01,5.114999e+01, &5.157802e+01,5.200963e+01,5.244486e+01,5.288373e+01,5.332626e+01, &5.377251e+01,5.422248e+01,5.467623e+01,5.513376e+01,5.559513e+01, &5.606036e+01,5.652948e+01,5.700253e+01,5.747954e+01,5.796053e+01, &5.844556e+01,5.893464e+01,5.942781e+01,5.992511e+01,6.042657e+01, &6.093223e+01,6.144212e+01,6.195628e+01,6.247474e+01,6.299754e+01, &6.352471e+01,6.405630e+01,6.459233e+01,6.513285e+01,6.567789e+01, &6.622749e+01,6.678169e+01,6.734053e+01,6.790405e+01,6.847228e+01, &6.904527e+01,6.962305e+01,7.020566e+01,7.079316e+01,7.138556e+01, &7.198293e+01,7.258529e+01,7.319270e+01,7.380518e+01,7.442280e+01, &7.504558e+01,7.567357e+01,7.630682e+01,7.694537e+01,7.758926e+01, &7.823854e+01,7.889325e+01,7.955344e+01,8.021915e+01,8.089044e+01/ data eg20f/ &8.156734e+01,8.224991e+01,8.293819e+01,8.363223e+01,8.433208e+01, &8.503778e+01,8.574939e+01,8.646695e+01,8.719052e+01,8.792015e+01, &8.865588e+01,8.939776e+01,9.014586e+01,9.090021e+01,9.166088e+01, &9.242791e+01,9.320136e+01,9.398128e+01,9.476773e+01,9.556076e+01, &9.636043e+01,9.716679e+01,9.797990e+01,9.879981e+01,9.962658e+01, &1.004603e+02,1.013009e+02,1.021486e+02,1.030034e+02,1.038654e+02, &1.047345e+02,1.056110e+02,1.064947e+02,1.073859e+02,1.082845e+02, &1.091907e+02,1.101044e+02,1.110258e+02,1.119548e+02,1.128917e+02, &1.138364e+02,1.147890e+02,1.157496e+02,1.167182e+02,1.176949e+02, &1.186798e+02,1.196729e+02,1.206744e+02,1.216842e+02,1.227024e+02, &1.237292e+02,1.247646e+02,1.258087e+02,1.268615e+02,1.279231e+02, &1.289935e+02,1.300730e+02,1.311615e+02,1.322590e+02,1.333658e+02, &1.344818e+02,1.356072e+02,1.367420e+02,1.378862e+02,1.390401e+02, &1.402036e+02,1.413768e+02,1.425599e+02,1.437529e+02,1.449558e+02, &1.461688e+02,1.473920e+02,1.486254e+02,1.498691e+02,1.511232e+02, &1.523879e+02,1.536631e+02,1.549489e+02,1.562456e+02,1.575531e+02, &1.588715e+02,1.602010e+02,1.615415e+02,1.628933e+02,1.642565e+02, &1.656310e+02,1.670170e+02,1.684146e+02,1.698239e+02,1.712451e+02, &1.726781e+02,1.741231e+02,1.755802e+02,1.770494e+02,1.785310e+02/ data eg20g/ &1.800250e+02,1.815315e+02,1.830505e+02,1.845823e+02,1.861269e+02, &1.876845e+02,1.892551e+02,1.908388e+02,1.924358e+02,1.940461e+02, &1.956699e+02,1.973073e+02,1.989584e+02,2.006233e+02,2.023021e+02, &2.039950e+02,2.057021e+02,2.074234e+02,2.091592e+02,2.109095e+02, &2.126744e+02,2.144541e+02,2.162487e+02,2.180583e+02,2.198830e+02, &2.217230e+02,2.235784e+02,2.254494e+02,2.273360e+02,2.292384e+02, &2.311567e+02,2.330910e+02,2.350416e+02,2.370084e+02,2.389917e+02, &2.409917e+02,2.430083e+02,2.450418e+02,2.470924e+02,2.491601e+02, &2.512451e+02,2.533476e+02,2.554676e+02,2.576054e+02,2.597611e+02, &2.619348e+02,2.641267e+02,2.663370e+02,2.685657e+02,2.708131e+02, &2.730793e+02,2.753645e+02,2.776688e+02,2.799924e+02,2.823354e+02, &2.846980e+02,2.870804e+02,2.894827e+02,2.919052e+02,2.943479e+02, &2.968110e+02,2.992948e+02,3.017993e+02,3.043248e+02,3.068715e+02, &3.094394e+02,3.120288e+02,3.146399e+02,3.172729e+02,3.199279e+02, &3.226051e+02,3.253047e+02,3.280269e+02,3.307719e+02,3.335398e+02, &3.363309e+02,3.391454e+02,3.419834e+02,3.448452e+02,3.477309e+02, &3.506408e+02,3.535750e+02,3.565338e+02,3.595173e+02,3.625258e+02, &3.655595e+02,3.686185e+02,3.717032e+02,3.748137e+02,3.779502e+02, &3.811129e+02,3.843021e+02,3.875180e+02,3.907608e+02,3.940308e+02/ data eg20h/ &3.973281e+02,4.006530e+02,4.040057e+02,4.073865e+02,4.107955e+02, &4.142332e+02,4.176995e+02,4.211949e+02,4.247195e+02,4.282736e+02, &4.318575e+02,4.354713e+02,4.391154e+02,4.427900e+02,4.464953e+02, &4.502317e+02,4.539993e+02,4.577984e+02,4.616294e+02,4.654923e+02, &4.693877e+02,4.733156e+02,4.772763e+02,4.812703e+02,4.852976e+02, &4.893587e+02,4.934537e+02,4.975830e+02,5.017468e+02,5.059455e+02, &5.101793e+02,5.144486e+02,5.187536e+02,5.230946e+02,5.274719e+02, &5.318859e+02,5.363368e+02,5.408249e+02,5.453506e+02,5.499142e+02, &5.545160e+02,5.591563e+02,5.638354e+02,5.685536e+02,5.733114e+02, &5.781089e+02,5.829466e+02,5.878248e+02,5.927438e+02,5.977040e+02, &6.027057e+02,6.077492e+02,6.128350e+02,6.179633e+02,6.231345e+02, &6.283489e+02,6.336071e+02,6.389092e+02,6.442557e+02,6.496469e+02, &6.550832e+02,6.605651e+02,6.660928e+02,6.716668e+02,6.772874e+02, &6.829550e+02,6.886701e+02,6.944330e+02,7.002441e+02,7.061038e+02, &7.120126e+02,7.179709e+02,7.239790e+02,7.300373e+02,7.361464e+02, &7.423066e+02,7.485183e+02,7.547820e+02,7.610981e+02,7.674671e+02, &7.738894e+02,7.803654e+02,7.868957e+02,7.934805e+02,8.001205e+02, &8.068160e+02,8.135676e+02,8.203756e+02,8.272407e+02,8.341631e+02, &8.411435e+02,8.481824e+02,8.552801e+02,8.624372e+02,8.696542e+02/ data eg20i/ &8.769316e+02,8.842699e+02,8.916696e+02,8.991312e+02,9.066553e+02, &9.142423e+02,9.218928e+02,9.296074e+02,9.373865e+02,9.452307e+02, &9.531405e+02,9.611165e+02,9.691593e+02,9.772694e+02,9.854473e+02, &9.936937e+02,1.002009e+03,1.010394e+03,1.018849e+03,1.027375e+03, &1.035972e+03,1.044641e+03,1.053383e+03,1.062198e+03,1.071087e+03, &1.080050e+03,1.089088e+03,1.098201e+03,1.107391e+03,1.116658e+03, &1.126002e+03,1.135425e+03,1.144926e+03,1.154507e+03,1.164168e+03, &1.173910e+03,1.183734e+03,1.193639e+03,1.203628e+03,1.213700e+03, &1.223857e+03,1.234098e+03,1.244425e+03,1.254839e+03,1.265339e+03, &1.275928e+03,1.286605e+03,1.297372e+03,1.308228e+03,1.319176e+03, &1.330215e+03,1.341346e+03,1.352571e+03,1.363889e+03,1.375303e+03, &1.386811e+03,1.398416e+03,1.410118e+03,1.421919e+03,1.433817e+03, &1.445816e+03,1.457915e+03,1.470115e+03,1.482417e+03,1.494822e+03, &1.507331e+03,1.519944e+03,1.532663e+03,1.545489e+03,1.558422e+03, &1.571463e+03,1.584613e+03,1.597874e+03,1.611245e+03,1.624728e+03, &1.638324e+03,1.652034e+03,1.665858e+03,1.679798e+03,1.693855e+03, &1.708030e+03,1.722323e+03,1.736735e+03,1.751268e+03,1.765923e+03, &1.780701e+03,1.795602e+03,1.810628e+03,1.825780e+03,1.841058e+03, &1.856464e+03,1.871999e+03,1.887665e+03,1.903461e+03,1.919389e+03/ data eg20j/ &1.935451e+03,1.951647e+03,1.967979e+03,1.984447e+03,2.001053e+03, &2.017798e+03,2.034684e+03,2.051710e+03,2.068879e+03,2.086192e+03, &2.103650e+03,2.121253e+03,2.139004e+03,2.156904e+03,2.174953e+03, &2.193153e+03,2.211506e+03,2.230012e+03,2.248673e+03,2.267490e+03, &2.286465e+03,2.305599e+03,2.324892e+03,2.344347e+03,2.363965e+03, &2.383747e+03,2.403695e+03,2.423809e+03,2.444092e+03,2.464545e+03, &2.485168e+03,2.505965e+03,2.526935e+03,2.548081e+03,2.569403e+03, &2.590904e+03,2.612586e+03,2.634448e+03,2.656494e+03,2.678723e+03, &2.701139e+03,2.723743e+03,2.746536e+03,2.769519e+03,2.792695e+03, &2.816065e+03,2.839630e+03,2.863392e+03,2.887354e+03,2.911515e+03, &2.935879e+03,2.960447e+03,2.985221e+03,3.010202e+03,3.035391e+03, &3.060792e+03,3.086405e+03,3.112233e+03,3.138276e+03,3.164538e+03, &3.191019e+03,3.217722e+03,3.244649e+03,3.271800e+03,3.299179e+03, &3.326787e+03,3.354626e+03,3.382698e+03,3.411005e+03,3.439549e+03, &3.468332e+03,3.497355e+03,3.526622e+03,3.556133e+03,3.585891e+03, &3.615898e+03,3.646157e+03,3.676668e+03,3.707435e+03,3.738460e+03, &3.769744e+03,3.801290e+03,3.833099e+03,3.865175e+03,3.897520e+03, &3.930135e+03,3.963023e+03,3.996186e+03,4.029627e+03,4.063347e+03, &4.097350e+03,4.131637e+03,4.166211e+03,4.201075e+03,4.236230e+03/ data eg20k/ &4.271679e+03,4.307425e+03,4.343471e+03,4.379817e+03,4.416468e+03, &4.453426e+03,4.490693e+03,4.528272e+03,4.566165e+03,4.604375e+03, &4.642906e+03,4.681758e+03,4.720936e+03,4.760441e+03,4.800277e+03, &4.840447e+03,4.880952e+03,4.921797e+03,4.962983e+03,5.004514e+03, &5.046393e+03,5.088622e+03,5.131204e+03,5.174143e+03,5.217441e+03, &5.261101e+03,5.305127e+03,5.349521e+03,5.394287e+03,5.439427e+03, &5.484945e+03,5.530844e+03,5.577127e+03,5.623797e+03,5.670858e+03, &5.718312e+03,5.766164e+03,5.814416e+03,5.863072e+03,5.912135e+03, &5.961609e+03,6.011496e+03,6.061802e+03,6.112528e+03,6.163678e+03, &6.215257e+03,6.267267e+03,6.319712e+03,6.372597e+03,6.425924e+03, &6.479697e+03,6.533920e+03,6.588597e+03,6.643731e+03,6.699327e+03, &6.755388e+03,6.811918e+03,6.868921e+03,6.926401e+03,6.984362e+03, &7.042809e+03,7.101744e+03,7.161172e+03,7.221098e+03,7.281525e+03, &7.342458e+03,7.403901e+03,7.465858e+03,7.528334e+03,7.591332e+03, &7.654857e+03,7.718914e+03,7.783507e+03,7.848641e+03,7.914319e+03, &7.980548e+03,8.047330e+03,8.114671e+03,8.182576e+03,8.251049e+03, &8.320095e+03,8.389719e+03,8.459926e+03,8.530719e+03,8.602106e+03, &8.674090e+03,8.746676e+03,8.819869e+03,8.893675e+03,8.968099e+03, &9.043145e+03,9.118820e+03,9.195127e+03,9.272074e+03,9.349664e+03/ data eg20l/ &9.427903e+03,9.506797e+03,9.586352e+03,9.666572e+03,9.747463e+03, &9.829031e+03,9.911282e+03,9.994221e+03,1.007785e+04,1.016219e+04, &1.024723e+04,1.033298e+04,1.041944e+04,1.050664e+04,1.059456e+04, &1.068321e+04,1.077261e+04,1.086276e+04,1.095366e+04,1.104532e+04, &1.113775e+04,1.123095e+04,1.132494e+04,1.141970e+04,1.151527e+04, &1.161163e+04,1.170880e+04,1.180678e+04,1.190558e+04,1.200521e+04, &1.210567e+04,1.220697e+04,1.230912e+04,1.241212e+04,1.251599e+04, &1.262073e+04,1.272634e+04,1.283283e+04,1.294022e+04,1.304851e+04, &1.315770e+04,1.326780e+04,1.337883e+04,1.349079e+04,1.360368e+04, &1.371752e+04,1.383231e+04,1.394806e+04,1.406478e+04,1.418247e+04, &1.430116e+04,1.442083e+04,1.454151e+04,1.466319e+04,1.478590e+04, &1.490963e+04,1.503439e+04,1.516020e+04,1.528706e+04,1.541499e+04, &1.554398e+04,1.567406e+04,1.580522e+04,1.593748e+04,1.607085e+04, &1.620533e+04,1.634094e+04,1.647768e+04,1.661557e+04,1.675461e+04, &1.689482e+04,1.703620e+04,1.717876e+04,1.732251e+04,1.746747e+04, &1.761364e+04,1.776104e+04,1.790966e+04,1.805953e+04,1.821066e+04, &1.836305e+04,1.851671e+04,1.867166e+04,1.882791e+04,1.898547e+04, &1.914434e+04,1.930454e+04,1.946608e+04,1.962898e+04,1.979324e+04, &1.995887e+04,2.012589e+04,2.029431e+04,2.046413e+04,2.063538e+04/ data eg20m/ &2.080806e+04,2.098218e+04,2.115777e+04,2.133482e+04,2.151335e+04, &2.169338e+04,2.187491e+04,2.205796e+04,2.224255e+04,2.242868e+04, &2.261636e+04,2.280562e+04,2.299646e+04,2.318890e+04,2.338295e+04, &2.357862e+04,2.377593e+04,2.397489e+04,2.417552e+04,2.437782e+04, &2.458182e+04,2.478752e+04,2.499495e+04,2.520411e+04,2.541502e+04, &2.562770e+04,2.584215e+04,2.605841e+04,2.627647e+04,2.649635e+04, &2.671808e+04,2.694166e+04,2.700000e+04,2.716711e+04,2.739445e+04, &2.762369e+04,2.785485e+04,2.808794e+04,2.832299e+04,2.850000e+04, &2.856000e+04,2.879899e+04,2.903999e+04,2.928300e+04,2.952804e+04, &2.977514e+04,3.002430e+04,3.027555e+04,3.052890e+04,3.078437e+04, &3.104198e+04,3.130174e+04,3.156368e+04,3.182781e+04,3.209415e+04, &3.236272e+04,3.263353e+04,3.290662e+04,3.318198e+04,3.345965e+04, &3.373965e+04,3.402199e+04,3.430669e+04,3.459377e+04,3.488326e+04, &3.517517e+04,3.546952e+04,3.576633e+04,3.606563e+04,3.636743e+04, &3.667176e+04,3.697864e+04,3.728808e+04,3.760011e+04,3.791476e+04, &3.823203e+04,3.855196e+04,3.887457e+04,3.919988e+04,3.952791e+04, &3.985869e+04,4.019223e+04,4.052857e+04,4.086771e+04,4.120970e+04, &4.155455e+04,4.190229e+04,4.225293e+04,4.260651e+04,4.296305e+04, &4.332257e+04,4.368510e+04,4.405066e+04,4.441928e+04,4.479099e+04/ data eg20n/ &4.516581e+04,4.554376e+04,4.592488e+04,4.630919e+04,4.669671e+04, &4.708747e+04,4.748151e+04,4.787884e+04,4.827950e+04,4.868351e+04, &4.909090e+04,4.950170e+04,4.991594e+04,5.033364e+04,5.075484e+04, &5.117957e+04,5.160785e+04,5.203971e+04,5.247518e+04,5.291430e+04, &5.335710e+04,5.380360e+04,5.425384e+04,5.470784e+04,5.516564e+04, &5.562728e+04,5.609278e+04,5.656217e+04,5.703549e+04,5.751277e+04, &5.799405e+04,5.847935e+04,5.896871e+04,5.946217e+04,5.995976e+04, &6.046151e+04,6.096747e+04,6.147765e+04,6.199211e+04,6.251086e+04, &6.303396e+04,6.356144e+04,6.409333e+04,6.462968e+04,6.517051e+04, &6.571586e+04,6.626579e+04,6.682031e+04,6.737947e+04,6.794331e+04, &6.851187e+04,6.908519e+04,6.966330e+04,7.024626e+04,7.083409e+04, &7.142684e+04,7.202455e+04,7.262726e+04,7.323502e+04,7.384786e+04, &7.446583e+04,7.508897e+04,7.571733e+04,7.635094e+04,7.698986e+04, &7.763412e+04,7.828378e+04,7.893887e+04,7.950000e+04,7.959944e+04, &8.026554e+04,8.093721e+04,8.161451e+04,8.229747e+04,8.250000e+04, &8.298615e+04,8.368059e+04,8.438084e+04,8.508695e+04,8.579897e+04, &8.651695e+04,8.724094e+04,8.797098e+04,8.870714e+04,8.944945e+04, &9.019798e+04,9.095277e+04,9.171388e+04,9.248135e+04,9.325525e+04, &9.403563e+04,9.482253e+04,9.561602e+04,9.641615e+04,9.722297e+04/ data eg20o/ &9.803655e+04,9.885694e+04,9.968419e+04,1.005184e+05,1.013595e+05, &1.022077e+05,1.030630e+05,1.039254e+05,1.047951e+05,1.056720e+05, &1.065563e+05,1.074480e+05,1.083471e+05,1.092538e+05,1.101681e+05, &1.110900e+05,1.120196e+05,1.129570e+05,1.139022e+05,1.148554e+05, &1.158165e+05,1.167857e+05,1.177629e+05,1.187484e+05,1.197421e+05, &1.207441e+05,1.217545e+05,1.227734e+05,1.238008e+05,1.248368e+05, &1.258814e+05,1.269348e+05,1.279970e+05,1.290681e+05,1.301482e+05, &1.312373e+05,1.323355e+05,1.334429e+05,1.345596e+05,1.356856e+05, &1.368210e+05,1.379660e+05,1.391205e+05,1.402847e+05,1.414586e+05, &1.426423e+05,1.438360e+05,1.450396e+05,1.462533e+05,1.474772e+05, &1.487113e+05,1.499558e+05,1.512106e+05,1.524760e+05,1.537519e+05, &1.550385e+05,1.563359e+05,1.576442e+05,1.589634e+05,1.602936e+05, &1.616349e+05,1.629875e+05,1.643514e+05,1.657268e+05,1.671136e+05, &1.685120e+05,1.699221e+05,1.713441e+05,1.727779e+05,1.742237e+05, &1.756817e+05,1.771518e+05,1.786342e+05,1.801291e+05,1.816364e+05, &1.831564e+05,1.846891e+05,1.862346e+05,1.877930e+05,1.893645e+05, &1.909491e+05,1.925470e+05,1.941583e+05,1.957830e+05,1.974214e+05, &1.990734e+05,2.007393e+05,2.024191e+05,2.041130e+05,2.058210e+05, &2.075434e+05,2.092801e+05,2.110314e+05,2.127974e+05,2.145781e+05/ data eg20p/ &2.163737e+05,2.181844e+05,2.200102e+05,2.218512e+05,2.237077e+05, &2.255797e+05,2.274674e+05,2.293709e+05,2.312903e+05,2.332258e+05, &2.351775e+05,2.371455e+05,2.391299e+05,2.411310e+05,2.431488e+05, &2.451835e+05,2.472353e+05,2.493042e+05,2.513904e+05,2.534941e+05, &2.556153e+05,2.577544e+05,2.599113e+05,2.620863e+05,2.642794e+05, &2.664910e+05,2.687210e+05,2.709697e+05,2.732372e+05,2.755237e+05, &2.778293e+05,2.801543e+05,2.824986e+05,2.848626e+05,2.872464e+05, &2.896501e+05,2.920740e+05,2.945181e+05,2.969826e+05,2.972000e+05, &2.985000e+05,2.994678e+05,3.019738e+05,3.045008e+05,3.070489e+05, &3.096183e+05,3.122093e+05,3.148219e+05,3.174564e+05,3.201129e+05, &3.227916e+05,3.254928e+05,3.282166e+05,3.309631e+05,3.337327e+05, &3.365254e+05,3.393415e+05,3.421812e+05,3.450446e+05,3.479320e+05, &3.508435e+05,3.537795e+05,3.567399e+05,3.597252e+05,3.627354e+05, &3.657708e+05,3.688317e+05,3.719181e+05,3.750304e+05,3.781687e+05, &3.813333e+05,3.845243e+05,3.877421e+05,3.909868e+05,3.942586e+05, &3.975578e+05,4.008846e+05,4.042393e+05,4.076220e+05,4.110331e+05, &4.144727e+05,4.179410e+05,4.214384e+05,4.249651e+05,4.285213e+05, &4.321072e+05,4.357231e+05,4.393693e+05,4.430460e+05,4.467535e+05, &4.504920e+05,4.542618e+05,4.580631e+05,4.618963e+05,4.657615e+05/ data eg20q/ &4.696591e+05,4.735892e+05,4.775523e+05,4.815485e+05,4.855782e+05, &4.896416e+05,4.937390e+05,4.978707e+05,5.020369e+05,5.062381e+05, &5.104743e+05,5.147461e+05,5.190535e+05,5.233971e+05,5.277769e+05, &5.321934e+05,5.366469e+05,5.411377e+05,5.456660e+05,5.502322e+05, &5.548366e+05,5.594796e+05,5.641614e+05,5.688824e+05,5.736429e+05, &5.784432e+05,5.832837e+05,5.881647e+05,5.930866e+05,5.980496e+05, &6.030542e+05,6.081006e+05,6.131893e+05,6.183206e+05,6.234948e+05, &6.287123e+05,6.339734e+05,6.392786e+05,6.446282e+05,6.500225e+05, &6.554620e+05,6.609470e+05,6.664779e+05,6.720551e+05,6.776790e+05, &6.833499e+05,6.890683e+05,6.948345e+05,7.006490e+05,7.065121e+05, &7.124243e+05,7.183860e+05,7.243976e+05,7.304594e+05,7.365720e+05, &7.427358e+05,7.489511e+05,7.552184e+05,7.615382e+05,7.679109e+05, &7.743369e+05,7.808167e+05,7.873507e+05,7.939393e+05,8.005831e+05, &8.072825e+05,8.140380e+05,8.208500e+05,8.277190e+05,8.346455e+05, &8.416299e+05,8.486728e+05,8.557746e+05,8.629359e+05,8.701570e+05, &8.774387e+05,8.847812e+05,8.921852e+05,8.996511e+05,9.071795e+05, &9.147709e+05,9.224259e+05,9.301449e+05,9.379285e+05,9.457772e+05, &9.536916e+05,9.616723e+05,9.697197e+05,9.778344e+05,9.860171e+05, &9.942682e+05,1.002588e+06,1.010978e+06,1.019438e+06,1.027969e+06/ data eg20r/ &1.036571e+06,1.045245e+06,1.053992e+06,1.062812e+06,1.071706e+06, &1.080674e+06,1.089717e+06,1.098836e+06,1.108032e+06,1.117304e+06, &1.126654e+06,1.136082e+06,1.145588e+06,1.155175e+06,1.164842e+06, &1.174589e+06,1.184418e+06,1.194330e+06,1.204324e+06,1.214402e+06, &1.224564e+06,1.234812e+06,1.245145e+06,1.255564e+06,1.266071e+06, &1.276666e+06,1.287349e+06,1.298122e+06,1.308985e+06,1.319938e+06, &1.330984e+06,1.342122e+06,1.353353e+06,1.364678e+06,1.376098e+06, &1.387613e+06,1.399225e+06,1.410934e+06,1.422741e+06,1.434646e+06, &1.446652e+06,1.458758e+06,1.470965e+06,1.483274e+06,1.495686e+06, &1.508202e+06,1.520823e+06,1.533550e+06,1.546383e+06,1.559323e+06, &1.572372e+06,1.585530e+06,1.598797e+06,1.612176e+06,1.625667e+06, &1.639271e+06,1.652989e+06,1.666821e+06,1.680770e+06,1.694834e+06, &1.709017e+06,1.723318e+06,1.737739e+06,1.752281e+06,1.766944e+06, &1.781731e+06,1.796640e+06,1.811675e+06,1.826835e+06,1.842122e+06, &1.857538e+06,1.873082e+06,1.888756e+06,1.904561e+06,1.920499e+06, &1.936570e+06,1.952776e+06,1.969117e+06,1.985595e+06,2.002210e+06, &2.018965e+06,2.035860e+06,2.052897e+06,2.070076e+06,2.087398e+06, &2.104866e+06,2.122480e+06,2.140241e+06,2.158151e+06,2.176211e+06, &2.194421e+06,2.212785e+06,2.231302e+06,2.249973e+06,2.268802e+06/ data eg20s/ &2.287787e+06,2.306932e+06,2.326237e+06,2.345703e+06,2.365332e+06, &2.385126e+06,2.405085e+06,2.425211e+06,2.445505e+06,2.465970e+06, &2.486605e+06,2.507414e+06,2.528396e+06,2.549554e+06,2.570889e+06, &2.592403e+06,2.614096e+06,2.635971e+06,2.658030e+06,2.680272e+06, &2.702701e+06,2.725318e+06,2.748124e+06,2.771121e+06,2.794310e+06, &2.817693e+06,2.841272e+06,2.865048e+06,2.889023e+06,2.913199e+06, &2.937577e+06,2.962159e+06,2.986947e+06,3.011942e+06,3.037147e+06, &3.062562e+06,3.088190e+06,3.114032e+06,3.140091e+06,3.166368e+06, &3.192864e+06,3.219583e+06,3.246525e+06,3.273692e+06,3.301087e+06, &3.328711e+06,3.356566e+06,3.384654e+06,3.412978e+06,3.441538e+06, &3.470337e+06,3.499377e+06,3.528661e+06,3.558189e+06,3.587965e+06, &3.617989e+06,3.648265e+06,3.678794e+06,3.709579e+06,3.740621e+06, &3.771924e+06,3.803488e+06,3.835316e+06,3.867410e+06,3.899773e+06, &3.932407e+06,3.965314e+06,3.998497e+06,4.031957e+06,4.065697e+06, &4.099719e+06,4.134026e+06,4.168620e+06,4.203504e+06,4.238679e+06, &4.274149e+06,4.309916e+06,4.345982e+06,4.382350e+06,4.419022e+06, &4.456001e+06,4.493290e+06,4.530890e+06,4.568805e+06,4.607038e+06, &4.645590e+06,4.684465e+06,4.723666e+06,4.763194e+06,4.803053e+06, &4.843246e+06,4.883775e+06,4.924643e+06,4.965853e+06,5.007408e+06/ data eg20t/ &5.049311e+06,5.091564e+06,5.134171e+06,5.177135e+06,5.220458e+06, &5.264143e+06,5.308195e+06,5.352614e+06,5.397406e+06,5.442572e+06, &5.488116e+06,5.534042e+06,5.580351e+06,5.627049e+06,5.674137e+06, &5.721619e+06,5.769498e+06,5.817778e+06,5.866462e+06,5.915554e+06, &5.965056e+06,6.014972e+06,6.065307e+06,6.116062e+06,6.167242e+06, &6.218851e+06,6.270891e+06,6.323367e+06,6.376282e+06,6.429639e+06, &6.483443e+06,6.537698e+06,6.592406e+06,6.647573e+06,6.703200e+06, &6.759294e+06,6.815857e+06,6.872893e+06,6.930406e+06,6.988401e+06, &7.046881e+06,7.105850e+06,7.165313e+06,7.225274e+06,7.285736e+06, &7.346704e+06,7.408182e+06,7.470175e+06,7.532687e+06,7.595721e+06, &7.659283e+06,7.723377e+06,7.788008e+06,7.853179e+06,7.918896e+06, &7.985162e+06,8.051983e+06,8.119363e+06,8.187308e+06,8.255820e+06, &8.324906e+06,8.394570e+06,8.464817e+06,8.535652e+06,8.607080e+06, &8.679105e+06,8.751733e+06,8.824969e+06,8.898818e+06,8.973284e+06, &9.048374e+06,9.124092e+06,9.200444e+06,9.277435e+06,9.355070e+06, &9.433354e+06,9.512294e+06,9.591895e+06,9.672161e+06,9.753099e+06, &9.834715e+06,9.917013e+06,1.000000e+07,1.008368e+07,1.016806e+07, &1.025315e+07,1.033895e+07,1.042547e+07,1.051271e+07,1.060068e+07, &1.068939e+07,1.077884e+07,1.086904e+07,1.095999e+07,1.105171e+07/ data eg20u/ &1.114419e+07,1.123745e+07,1.133148e+07,1.142631e+07,1.152193e+07, &1.161834e+07,1.171557e+07,1.181360e+07,1.191246e+07,1.201215e+07, &1.211267e+07,1.221403e+07,1.231624e+07,1.241930e+07,1.252323e+07, &1.262802e+07,1.273370e+07,1.284025e+07,1.294770e+07,1.305605e+07, &1.316531e+07,1.327548e+07,1.338657e+07,1.349859e+07,1.361155e+07, &1.372545e+07,1.384031e+07,1.395612e+07,1.407291e+07,1.419068e+07, &1.430943e+07,1.442917e+07,1.454991e+07,1.467167e+07,1.479444e+07, &1.491825e+07,1.504309e+07,1.516897e+07,1.529590e+07,1.542390e+07, &1.555297e+07,1.568312e+07,1.581436e+07,1.594670e+07,1.608014e+07, &1.621470e+07,1.635039e+07,1.648721e+07,1.662518e+07,1.676430e+07, &1.690459e+07,1.704605e+07,1.718869e+07,1.733253e+07,1.747757e+07, &1.762383e+07,1.777131e+07,1.792002e+07,1.806998e+07,1.822119e+07, &1.837367e+07,1.852742e+07,1.868246e+07,1.883880e+07,1.899644e+07, &1.915541e+07,1.931570e+07,1.947734e+07,1.964033e+07/ data eg21a/ &1.000010e-05,1.100000e-04,3.000000e-03,5.500100e-03,1.000000e-02, &1.500000e-02,2.000000e-02,3.000000e-02,3.200000e-02,3.238000e-02, &4.300000e-02,5.900100e-02,7.700100e-02,9.500000e-02,1.000000e-01, &1.150000e-01,1.340000e-01,1.600000e-01,1.890000e-01,2.200000e-01, &2.480000e-01,2.825000e-01,3.145000e-01,3.520000e-01,3.910100e-01, &4.139900e-01,4.330000e-01,4.850100e-01,5.315800e-01,5.400100e-01, &6.250100e-01,6.825600e-01,7.050000e-01,7.900100e-01,8.600100e-01, &8.764200e-01,9.300100e-01,9.860100e-01,1.010000e+00,1.035000e+00, &1.070000e+00,1.080000e+00,1.090000e+00,1.110000e+00,1.125400e+00, &1.170000e+00,1.235000e+00,1.305000e+00,1.370000e+00,1.440000e+00, &1.445000e+00,1.510000e+00,1.590000e+00,1.670000e+00,1.755000e+00, &1.840000e+00,1.855400e+00,1.930000e+00,2.020000e+00,2.130000e+00, &2.360000e+00,2.372400e+00,2.767900e+00,3.059000e+00,3.380700e+00, &3.927900e+00,4.129200e+00,4.470000e+00,4.670000e+00,5.043500e+00, &5.623000e+00,6.160100e+00,6.476000e+00,7.079000e+00,7.524000e+00, &7.943000e+00,8.315300e+00,8.913000e+00,9.189800e+00,1.000000e+01, &1.067700e+01,1.122400e+01,1.259000e+01,1.371000e+01,1.522700e+01, &1.674500e+01,1.760300e+01,1.902800e+01,2.045200e+01,2.260300e+01, &2.498000e+01,2.791800e+01,2.920300e+01,3.051100e+01,3.388900e+01/ data eg21b/ &3.726700e+01,3.981000e+01,4.551700e+01,4.785100e+01,5.012000e+01, &5.559500e+01,6.144200e+01,6.310000e+01,6.790400e+01,7.079000e+01, &7.889300e+01,8.527700e+01,9.166100e+01,1.013000e+02,1.122000e+02, &1.300700e+02,1.367400e+02,1.585000e+02,1.670200e+02,1.778000e+02, &2.039900e+02,2.144500e+02,2.430100e+02,2.753600e+02,3.043200e+02, &3.535800e+02,3.981000e+02,4.540000e+02,5.144600e+02,5.829500e+02, &6.310000e+02,6.772900e+02,7.079000e+02,7.485200e+02,8.482000e+02, &9.611200e+02,1.010400e+03,1.116700e+03,1.234100e+03,1.363900e+03, &1.507300e+03,1.584600e+03,1.795600e+03,2.034700e+03,2.113000e+03, &2.248700e+03,2.371000e+03,2.485200e+03,2.612600e+03,2.661000e+03, &2.746500e+03,2.818000e+03,3.035400e+03,3.162000e+03,3.354600e+03, &3.548000e+03,3.707400e+03,3.981000e+03,4.307400e+03,4.642900e+03, &5.004500e+03,5.530800e+03,6.267300e+03,7.101700e+03,7.465900e+03, &8.251000e+03,9.118800e+03,1.007800e+04,1.113800e+04,1.170900e+04, &1.272600e+04,1.383200e+04,1.503400e+04,1.585000e+04,1.661600e+04, &1.778000e+04,1.930500e+04,1.995000e+04,2.054000e+04,2.113000e+04, &2.187500e+04,2.239000e+04,2.304000e+04,2.357900e+04,2.417600e+04, &2.441000e+04,2.478800e+04,2.512000e+04,2.585000e+04,2.605800e+04, &2.661000e+04,2.700000e+04,2.738000e+04,2.818000e+04,2.850000e+04/ data eg21c/ &2.901000e+04,2.985000e+04,3.073000e+04,3.162000e+04,3.182800e+04, &3.430700e+04,3.697900e+04,4.086800e+04,4.358900e+04,4.630900e+04, &4.939200e+04,5.247500e+04,5.516600e+04,5.656200e+04,6.172500e+04, &6.737900e+04,7.200000e+04,7.499000e+04,7.950000e+04,8.229700e+04, &8.250000e+04,8.651700e+04,9.803700e+04,1.110900e+05,1.167900e+05, &1.227700e+05,1.290700e+05,1.356900e+05,1.426400e+05,1.499600e+05, &1.576400e+05,1.657300e+05,1.742200e+05,1.831600e+05,1.925500e+05, &2.024200e+05,2.128000e+05,2.237100e+05,2.351800e+05,2.472400e+05, &2.732400e+05,2.872500e+05,2.945200e+05,2.972000e+05,2.985000e+05, &3.019700e+05,3.337300e+05,3.688300e+05,3.877400e+05,4.076200e+05, &4.504900e+05,5.234000e+05,5.502300e+05,5.784400e+05,6.081000e+05, &6.392800e+05,6.720600e+05,7.065100e+05,7.427400e+05,7.808200e+05, &8.208500e+05,8.629400e+05,9.071800e+05,9.616400e+05,1.002600e+06, &1.108000e+06,1.164800e+06,1.224600e+06,1.287300e+06,1.353400e+06, &1.422700e+06,1.495700e+06,1.572400e+06,1.653000e+06,1.737700e+06, &1.826800e+06,1.920500e+06,2.019000e+06,2.122500e+06,2.231300e+06, &2.306900e+06,2.345700e+06,2.365300e+06,2.385200e+06,2.466000e+06, &2.592400e+06,2.725300e+06,2.865000e+06,3.011900e+06,3.166400e+06, &3.328700e+06,3.678800e+06,4.065700e+06,4.493300e+06,4.723700e+06/ data eg21d/ &4.965900e+06,5.220500e+06,5.488100e+06,5.769500e+06,6.065300e+06, &6.376300e+06,6.592400e+06,6.703200e+06,7.046900e+06,7.408200e+06, &7.788000e+06,8.187300e+06,8.607100e+06,9.048400e+06,9.512300e+06, &1.000000e+07,1.051300e+07,1.105200e+07,1.161800e+07,1.221400e+07, &1.284000e+07,1.349900e+07,1.384000e+07,1.419100e+07,1.455000e+07, &1.491800e+07,1.568300e+07,1.648700e+07,1.690500e+07,1.733300e+07, &1.964000e+07/ data eg22a/ &1.000010e-05,3.000000e-03,5.000000e-03,6.900000e-03,1.000000e-02, &1.500000e-02,2.000000e-02,2.500000e-02,3.000000e-02,3.500000e-02, &4.200000e-02,5.000000e-02,5.800000e-02,6.700000e-02,7.700000e-02, &8.000000e-02,9.500000e-02,1.000000e-01,1.150000e-01,1.340000e-01, &1.400000e-01,1.600000e-01,1.800000e-01,1.890000e-01,2.200000e-01, &2.480000e-01,2.800000e-01,3.000000e-01,3.145000e-01,3.200000e-01, &3.500000e-01,3.910000e-01,4.000000e-01,4.330000e-01,4.850000e-01, &5.000000e-01,5.400000e-01,6.250000e-01,7.050000e-01,7.800000e-01, &7.900000e-01,8.500000e-01,8.600000e-01,9.100000e-01,9.300000e-01, &9.500000e-01,9.720000e-01,9.860000e-01,9.960000e-01,1.020000e+00, &1.035000e+00,1.045000e+00,1.071000e+00,1.097000e+00,1.110000e+00, &1.123000e+00,1.150000e+00,1.170000e+00,1.235000e+00,1.300000e+00, &1.337500e+00,1.370000e+00,1.440000e+00,1.475000e+00,1.500000e+00, &1.590000e+00,1.670000e+00,1.755000e+00,1.840000e+00,1.930000e+00, &2.020000e+00,2.100000e+00,2.130000e+00,2.360000e+00,2.550000e+00, &2.600000e+00,2.720000e+00,2.767920e+00,3.300000e+00,3.380750e+00, &4.000000e+00,4.129250e+00,5.043477e+00,5.346430e+00,6.160116e+00, &7.523983e+00,8.315287e+00,9.189814e+00,9.905554e+00,1.122446e+01, &1.370959e+01,1.592827e+01,1.945484e+01,2.260329e+01,2.498050e+01/ data eg22b/ &2.760773e+01,3.051126e+01,3.372015e+01,3.726653e+01,4.016900e+01, &4.551744e+01,4.825160e+01,5.157802e+01,5.559513e+01,6.790405e+01, &7.567357e+01,9.166088e+01,1.367420e+02,1.486254e+02,2.039950e+02, &3.043248e+02,3.717032e+02,4.539993e+02,6.772874e+02,7.485183e+02, &9.142423e+02,1.010394e+03,1.234098e+03,1.433817e+03,1.507331e+03, &2.034684e+03,2.248673e+03,3.354626e+03,3.526622e+03,5.004514e+03, &5.530844e+03,7.465858e+03,9.118820e+03,1.113775e+04,1.503439e+04, &1.661557e+04,2.478752e+04,2.739445e+04,2.928300e+04,3.697864e+04, &4.086771e+04,5.516564e+04,6.737947e+04,8.229747e+04,1.110900e+05, &1.227734e+05,1.831564e+05,2.472353e+05,2.732372e+05,3.019738e+05, &4.076220e+05,4.504920e+05,4.978707e+05,5.502322e+05,6.081006e+05, &8.208500e+05,9.071795e+05,1.002588e+06,1.108032e+06,1.224564e+06, &1.353353e+06,1.652989e+06,2.018965e+06,2.231302e+06,2.465970e+06, &3.011942e+06,3.678794e+06,4.493290e+06,5.488116e+06,6.065307e+06, &6.703200e+06,8.187308e+06,1.000000e+07,1.1618343e+07, &1.3840307e+07,1.4918247e+07,1.733253e+07,1.964033e+07/ data eg23a/ &1.000010e-05,1.000010e-01,4.139940e-01,5.315790e-01,6.825600e-01, &8.764250e-01,1.123000e+00,1.440000e+00,1.855390e+00,2.382370e+00, &3.059020e+00,3.927860e+00,5.043480e+00,6.475950e+00,8.315290e+00, &1.067700e+01,1.370960e+01,1.760350e+01,2.260330e+01,2.902320e+01, &3.726650e+01,4.785120e+01,6.144210e+01,7.889320e+01,1.013010e+02, &1.300730e+02,1.670170e+02,2.144540e+02,2.753640e+02,3.535750e+02, &4.539990e+02,5.829470e+02,7.485180e+02,9.611170e+02,1.234100e+03, &1.584610e+03,2.034680e+03,2.248670e+03,2.485170e+03,2.612590e+03, &2.746540e+03,3.035390e+03,3.354630e+03,3.707440e+03,4.307420e+03, &5.530840e+03,7.101740e+03,9.118820e+03,1.059460e+04,1.170880e+04, &1.503440e+04,1.930450e+04,2.187490e+04,2.357860e+04,2.417550e+04, &2.478750e+04,2.605840e+04,2.700010e+04,2.850110e+04,3.182780e+04, &3.430670e+04,4.086770e+04,4.630920e+04,5.247520e+04,5.656220e+04, &6.737950e+04,7.202450e+04,7.949870e+04,8.250340e+04,8.651700e+04, &9.803650e+04,1.110900e+05,1.167860e+05,1.227730e+05,1.290680e+05, &1.356860e+05,1.426420e+05,1.499560e+05,1.576440e+05,1.657270e+05, &1.742240e+05,1.831560e+05,1.925470e+05,2.024190e+05,2.127970e+05, &2.237080e+05,2.351770e+05,2.472350e+05,2.732370e+05,2.872460e+05, &2.945180e+05,2.972110e+05,2.984910e+05,3.019740e+05,3.337330e+05/ data eg23b/ &3.688320e+05,3.877420e+05,4.076220e+05,4.504920e+05,4.978710e+05, &5.233970e+05,5.502320e+05,5.784430e+05,6.081010e+05,6.392790e+05, &6.720550e+05,7.065120e+05,7.427360e+05,7.808170e+05,8.208500e+05, &8.629360e+05,9.071800e+05,9.616720e+05,1.002590e+06,1.108030e+06, &1.164840e+06,1.224560e+06,1.287350e+06,1.353350e+06,1.422740e+06, &1.495690e+06,1.572370e+06,1.652990e+06,1.737740e+06,1.826840e+06, &1.920500e+06,2.018970e+06,2.122480e+06,2.231300e+06,2.306930e+06, &2.345700e+06,2.365330e+06,2.385130e+06,2.465970e+06,2.592400e+06, &2.725320e+06,2.865050e+06,3.011940e+06,3.166370e+06,3.328710e+06, &3.678790e+06,4.065700e+06,4.493290e+06,4.723670e+06,4.965850e+06, &5.220460e+06,5.488120e+06,5.769500e+06,6.065310e+06,6.376280e+06, &6.592410e+06,6.703200e+06,7.046880e+06,7.408180e+06,7.788010e+06, &8.187310e+06,8.607080e+06,9.048370e+06,9.512290e+06,1.000000e+07, &1.051270e+07,1.105170e+07,1.161830e+07,1.221400e+07,1.252320e+07, &1.284030e+07,1.349860e+07,1.384030e+07,1.419070e+07,1.454990e+07, &1.491820e+07,1.568310e+07,1.648720e+07,1.690460e+07,1.733250e+07, &1.964030e+07/ */ a comment and parameter (mxlg=65) statement were mistakenly */ placed within the *set sw construct several times in ident105. */ We need this parameter all of the time and move it out of */ the *set sw construct here. *d up105.11,up105.12 *b groupr.4758 c maximum legendre coefficients parameter (mxlg=65) *d up105.16,up105.17 *b groupr.5211 c maximum legendre coefficients parameter (mxlg=65) *d up105.40,up105.41 *b groupr.5994 c maximum legendre coefficients parameter (mxlg=65) *d up105.45,up105.46 *b groupr.6132 c maximum legendre coefficients parameter (mxlg=65) *d up105.51,up105.52 *b groupr.6735 c maximum legendre coefficients parameter (mxlg=65) *d up105.56,up105.57 *b groupr.7316 c maximum legendre coefficients parameter (mxlg=65) *d up105.61,up105.62 *b groupr.7931 c maximum legendre coefficients parameter (mxlg=65) *ident up196 */ acer -- 22may07 */ clean up single precision versus double precision issues; *b acer.2535 c --- Warning - single precision compilation on a 32-bit machine c will likely set tiny to zero. */ also set aside more scratch space to "a" in fix6 and increase */ an old 20 element Legendre array to 65 elements (altiparmakov, */ aecd). *d up108.27 dimension a(9000) *d acer.3249 dimension p(65) *d up108.29 namax=9000 */ a parameter idmx=2000 statement was mistakenly placed within */ the *set sw construct in ident147. It was corrected to read */ parameter (idmx=2000) in ident166, but is still incorrectly */ located within the *set sw block. We need this parameter all */ of the time and move it out of the *set sw construct here. *d up166.5 *b acer.7149 parameter (idmx=2000) */ move the common block out of *set sw. *d up143.6 *b acer.13446 common/mainio/nsysi,nsyso,nsyse,ntty *ident up197 */ broadr -- 22may07 */ change a double to a single in the single precision code *d broadr.128 therm=.0253e0 *ident up198 */ gaminr -- 22may07 */ change double to single in the single precision code *d gaminr.574 data eg3/.01e0,.10e0,.50e0,1.0e0,2.0e0,3.0e0,4.0e0,5.0e0,6.0e0, *ident up199 */ errorr -- 22may07 */ change single to double in the double precision code *d errorr.3493 data ezero/1.d7/ *ident up200 */ thermr -- 22may07 */ sz2, added in up168, needs both double and single precision definitions. *d up168.6 *b thermr.140 sz2=zero */ add double precision exponent to selected variables *d thermr.873 & 5.8052d0,6.9068d0,0.d0,0.d0/ *ident up201 */ acer -- 30may07 */ the block of coding designed to handle charged-particle production */ from isotropic sections of file 4 is being triggered incorrectly. */ one result of this is a double counting of the charged-particle */ heating represented by discrete levels in file 4. this can make */ the charged-particle heating larger than the total heating in some */ cases. this problem would affect coupled neutron-proton transport */ problems with mcnp or mcnpx. detected by little and trellue (lanl). *d acer.8950 ltt=l2h *ident up202 */ errorr -- 30may07 */ fix an error in the lethargies for the anl 27-group structure *d errorr.3431 data gl4/14.5d0,13.0d0,12.5d0,12.0d0,11.5d0,11.0d0,10.5d0, *d errorr.3534 data gl4/14.5e0,13.0e0,12.5e0,12.0e0,11.5e0,11.0e0,10.5e0, *ident up203 */ njoy -- 30may07 */ more double-single precision consistency problems *d njoy.3390,3391 save ae10cs,ae11cs,ae12cs,e11cs,e12cs,ae13cs,ae14cs, & ntae10,ntae11,ntae12,nte11,nte12,ntae13,ntae14,xmax,first *d njoy.4636 if (t.gt.alneps) then *d njoy.5194 if (m.ne.0) then *ident up204 */ heatr -- 30may07 */ the section of this routine that plots the photon energy-balance */ tests fails if the user didn't ask for mt303. noted by Dimitar */ Altiparmakov. one really should ask for mt303 when doing detailed */ energy-balance testing to get complete results. *i heatr.5429 if (mt303.eq.0) go to 490 *i heatr.5570 490 continue *ident up205 */ groupr -- 6jun07 */ fix a couple of single precision qp8 array values in getdis to */ exactly match the correctly specified double precision values. *d groupr.6461 & -.1834346425e0,.1834346425e0,.5255324099e0,.7966664774e0, *ident up206 */ acer -- 6jun07 */ add explicit definition for lttn to keep the intel compiler happy */ with zero optimization. *i acer.2222 lttn=0 *ident up207 */ groupr -- 6jun07 */ need to stop the ie loop one iteration sooner to avoid array */ bound underflow in groupr's flux calculator (altiparmakov, aecl). *d groupr.2819 do while (ie.gt.1.and.elim.gt.ej) *ident up208 */ heatr -- 11jun07 */ add a treatment for the relativistic discrete gamma in the */ incident neutron evaluation for h-1 for endf/b-vii. for */ now, we approximate this with a simple isotropic discrete */ primary photon. *d heatr.628 if (zap.eq.zero.and.(ik.gt.1.or.nk.eq.1)) then *d up115.16 & n6,j6,irec,jrec,iflag) *d up115.26 & n6,j6,irec,jrec,iflag) *d up115.37 & n2,j6,irec,jrec,iflag) *d heatr.1297 if (iprint.eq.1.and.i6g.gt.0.and.izap.ne.0.and.iflag.eq.0) *i heatr.2437 save disc102,zp,ap,zt,at *d heatr.2484 iflag=0 disc102=zero if (zap.eq.zero) then iflag=1 disc102=awp awp=0 endif *d heatr.2503 210 continue zp=int(zap/1000) zt=int(zat/1000) if (irec.gt.0) zp=zt-zp ap=awp if (irec.gt.0) ap=awr+1-awp at=awr if (zap.eq.zero) then ap=awr+1 zp=zt endif dame=df(e,zp,ap,zt,at) if (disc102.gt.zero) go to 295 if (law.ne.3.and.law.ne.6) then *d heatr.2515,2521 *i up115.48 return c 295 continue yld=1 call skip6(nin,0,0,c(l),law) *i heatr.2530 l=l+nw *i heatr.2582 if (disc102.gt.zero) go to 430 *i heatr.2663 c c ***discrete relativistic capture gamma 430 call hgam102(e,ebar,dame,disc102,c,irec,zp,ap,zt,at) yld=1 return *i heatr.4387 c subroutine hgam102(e,ebar,dame,disc102,c,irec,zp,ap,zt,at) c ****************************************************************** c process the relativistic discrete gamma or its recoil as c given in mf6/mt102 for endf/b-vii neutron + h-1. c ****************************************************************** implicit real*8 (a-h,o-z) common/kinim6/q,zat,awr,zap,awp,lct dimension c(*) c c ***approximate using discrete gamma for now if (irec.eq.0) then ebar=disc102+e*awr/(1+awr) dame=0 else ebar=e/(awr+1) dame=df(e,zp,ap,zt,at) endif return end *ident up209 */ acer -- 18jun07 */ we are double counting the recoil heating represented using */ file 6, law 4. example is li6(n,t)alpha where alpha heating */ is too big. reported by trellue and little (lanl). *i acer.9219 if (law.ne.4) then *i up40.19 endif *ident up210 */ groupr -- 18jun07 */ when weight function energies are 7 or more significant digits, the */ sigfig call can cause an infinite loop unless the new 6 digit enext */ is larger than its original value (Broeders). *d groupr.2596 enext=sigfig(enext,6,1) *ident up211 */ heatr - 19jun07 */ fix up phase-space calculations as used in endf/b-vii h-2. *d up127.7 *i heatr.2781 if (law.eq.6) lang=0 *d up127.9,15 *d heatr.3648 *ident up212 */ groupr - 19jun07 */ implement proper processing for the relativistic discrete */ gamma ray as given in mf6/mt102 for the endf/b-vii evaluation */ for incident neutrons on h-1. we are approximating it using */ a discrete primary photon for now. *i groupr.4772 save disc102 *i groupr.4831 disc102=0 *i groupr.4836 if (jzap.eq.0.and.law.eq.2) then disc102=awp awp=0 endif *d groupr.4869 140 if (disc102.gt.zero) go to 195 if (law.ge.2.and.law.le.5) go to 194 *i groupr.5062 if (disc102.gt.zero) go to 600 *i groupr.5172 c c ***discrete relativistic capture gamma 600 continue call gam102(ans,ed,enext,disc102,law,nl,iglo,ng2,nq) return *i groupr.7920 c subroutine gam102(ans,ed,enext,disc102,law,nl,iglo,ng2,nq) c ****************************************************************** c process the relativistic discrete gamma or its recoil as c given in mf6/mt102 for endf/b-vii neutron + h-1. c ****************************************************************** implicit real*8 (a-h,o-z) common/groupn/ign,ngn,egn(15000) common/groupg/igg,ngg,egg(400) common/kinim/awr,q,thresh,alpha,lrflag dimension ans(nl,*) c ***approximate using discrete gamma for now if (law.eq.2) then edis=disc102+ed*awr/(awr+1) do i=1,ngg if (edis.ge.egg(i).and.edis.lt.egg(i+1)) iglo=i enddo ng2=1 do i=1,nl ans(i,1)=0 enddo ans(1,1)=1 nq=0 if (ed.lt.egg(iglo+1)) then enext=egg(iglo+1) else if (ed.lt.egg(iglo)) then enext=egg(iglo) else enext=1e10 endif else if (law.eq.4) then edis=ed/(awr+1) do i=1,ngg if (edis.ge.egn(i).and.edis.lt.egn(i+1)) iglo=i enddo ng2=1 do i=1,nl ans(i,1)=1 enddo nq=0 if (ed.lt.egn(iglo+1)) then enext=egn(iglo+1) else if (ed.lt.egn(iglo)) then enext=egn(iglo) else enext=1e10 endif endif return end *ident up213 */ acer -- 19jun07 */ modify the vertical axes for the lin-lin principals *d acer.19127,19134 xmin=big xmax=0 ymin=big ymax=-big do i=1,nes e=xss(esz-1+i) if (e.gt.2) then tot=xss(esz+nes-1+i) abs=xss(esz+2*nes-1+i) elas=xss(esz+3*nes-1+i) if (e.lt.xmin) xmin=e if (e.gt.xmax) xmax=e if (tot.lt.ymin) ymin=tot if (tot.gt.ymax) ymax=tot if (abs.lt.ymin) ymin=abs if (abs.gt.ymax) ymax=abs if (elas.lt.ymin) ymin=elas if (elas.gt.ymax) ymax=elas if (gpd.ne.0) then gprod=xss(gpd-1+i) if (gprod.lt.ymin) ymin=gprod if (gprod.gt.ymax) ymax=gprod endif endif enddo ymin=0 */ allow negative kermas on the linear plot. *d acer.19260 *d acer.19298 */ add a linear plots of the recoil part of the heating; */ that is, the normal heating minus the charged-particle */ heating. this is a sensitive test of the energy-balance, */ showing when negative kermas might occur in coupled neutron */ and charged-particle transport calculations. *i acer.21362 c c ***plot lin-lin recoil heating xmin=big xmax=0 ymin=big ymax=-big do i=1,nes e=xss(esz-1+i) heat=xss(esz+4*nes-1+i) do j=1,ntyph ipt=nint(xss(ptype+j-1)) hpd=nint(xss(ploct+10*(j-1))) iaa=nint(xss(hpd)) naa=nint(xss(hpd+1)) ie=i-iaa-1 if (ie.ge.1.and.ie.le.naa) & heat=heat-xss(hpd+1+naa+ie) enddo if (e.lt.xmin) xmin=e if (e.gt.xmax) xmax=e if (heat.lt.ymin) ymin=heat if (heat.gt.ymax) ymax=heat enddo if (ymin.ne.zero.or.ymax.ne.zero) then if (ymin.lt.zero.and.ymax.lt.-ymin/2) ymax=-ymin/2 call ascle(4,xmin,xmax,major,minor) xstep=(xmax-xmin)/major call ascle(4,ymin,ymax,major,minor) ystep=(ymax-ymin)/major write(nout,'(''1'',i3,''/'')') iwcol it=1 do i=1,70 if (hk(i:i).ne.' ') it=i enddo write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''ecoil eating'',a,''/'')') qu,qu write(nout,'(''1 0 2 1/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,xstep write(nout,'(a,''nergy (e)'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,ystep write(nout,'(a,''eating (e/reaction)'',a,''/'')') & qu,qu write(nout,'(''/'')') write(nout,'(''/'')') write(nout,'(a,''recoil heating'',a,''/'')') qu,qu write(nout,'(''0/'')') thin=(xmax-xmin)/nden xlast=small j=0 do i=1,nes e=xss(esz-1+i) test=1 test=test/5 if (e.ge.test) then if (nes.le.nden.or.e.ge.xlast+thin.or.i.eq.nes) then heat=xss(esz+4*nes-1+i) do k=1,ntyph ipt=nint(xss(ptype+k-1)) hpd=nint(xss(ploct+10*(k-1))) iaa=nint(xss(hpd)) naa=nint(xss(hpd+1)) ie=i-iaa-1 if (ie.ge.1.and.ie.le.naa) & heat=heat-xss(hpd+1+naa+ie) enddo j=j+1 write(nout,'(1p,2e14.6,''/'')') e,heat xlast=e endif endif enddo write(nout,'(''/'')') endif *ident up214 */ powr -- 19jun07 */ fill in missing format (g95 compiler warning). *d powr.787 & '' -----------------------'',(1p,6e12.4))') *ident up215 */ reconr -- 20jun07 */ modify lunion and recout to process photonuclear files *d reconr.1704 if (mfh.ne.23.and.awin.ne.zero) awrx=c2h/awin *d reconr.1709 if (awin.ne.0) then thrx=-qx*(awrx+1)/awrx else thrx=-qx endif */ force mt=3 into the dictionary total xs when photonuclear *d reconr.4481 if (int(a(imfs+i-1)).eq.3.and.mtr(imtr).eq.1 & .and.awin.ne.0) then a(j+4)=mtr(imtr) else a(j+4)=3 endif */ force mth=3 for total xs when photonuclear *i reconr.4563 if (awin.eq.0) then mth=3 endif *ident up216 */ acer -- 21jun07 */ modify the photonuclear section of acer to use both endf and pendf */ in order to handle the russian actinide evaluations properly. the */ endf input is used for the distributions, and the pendf input is used */ for the cross sections. if reconr reconstruction is not required for */ a given material, the endf and pendf inputs can be the same. *d acer.432 call acephn(nendf,npend,awr) *d acer.15198 subroutine acephn(nendf,npend,awr) *i acer.15262 nin=nendf *i acer.15263 call openz(npend,0) *i acer.15331 c ***using the pendf input nin=npend *i acer.15443 nin=nendf *ident up217 */ heatr -- 26jun07 */ increase selected arrays in getsix, h6cm and h6dis. These arrays */ contain data by Legendre order and should have been increased long */ ago. Use a parameter statement so future mods will be easy to make. *b heatr.2681 parameter (mxlg=65) *d heatr.2684,2686 dimension x(10),y(10,mxlg) dimension term(mxlg) dimension p(mxlg),qp(64),qw(64) *d heatr.3048,3049 parameter (mxlg=65) dimension cnow(*),term(*),p(mxlg) dimension x(10),y(10,mxlg),yt(mxlg) *d heatr.3426 parameter (mxlg=65) dimension cnow(*),p(mxlg) *ident up218 */ acer -- 26jun07 */ need a larger integer format when the energy mesh has more than 100K points. *d acer.10858 & '(6x,''i'',5x,''energy'',9x,a10,5(5x,a10))') *d acer.10860 write(nsyso,'(1x,''------'',3x,''------------'', *d acer.10877 write(nsyso,'(1x,i6,1p,e15.6,6a15)') *ident up219 */ acer -- 26jun07 */ smoothing options for secondary-energy distributions. */ these options are turned off by default, but they can */ be enabled by changing ismooth to 1. *i acer.232 common/ism/ismooth *i acer.244 c c ***smoothing of energy distributions is off by default ismooth=0 */ add additional histogram bins at low energies to neutron */ distributions to better represent the sqrt(e) dependence. */ the low-energy histogram bins are checked to see how many */ seem to follow a sqrt(e) rule, then this energy range is */ recursively subdivided into smaller bins and extended to */ lower energies. *i acer.6324 common/ism/ismooth *i acer.6696 c ***extend low bins as sqrt(e) using log energy scale if (ismooth.gt.0.and.lep.eq.1.and.zap.eq.1) then fx=.8409 ex=40 cx=a(iscr+6+ncyc)*a(iscr+7) nx=nint(a(iscr+4)) do while (n.gt.2) cxx=cx+a(iscr+7+ncyc)*(a(iscr+6+2*ncyc) & -a(iscr+6+ncyc)) if (abs(cxx/a(iscr+6+2*ncyc)**1.5 & -cx/a(iscr+6+ncyc)**1.5) & .gt.cx/a(iscr+6+ncyc)**1.5/50) exit a(iscr+7)=(a(iscr+7)*a(iscr+6+ncyc) & +a(iscr+7+ncyc)*(a(iscr+6+2*ncyc) & -a(iscr+6+ncyc)))/a(iscr+6+2*ncyc) do ix=1,nx-2*ncyc a(iscr+5+ix+ncyc)=a(iscr+5+ix+2*ncyc) enddo cx=cxx nx=nx-ncyc n=n-1 enddo write(nsyso,'('' extending as sqrt(E) below'', & 1p,e10.2,'' MeV for E='',e10.2,'' MeV'')') & a(iscr+6+ncyc)/emev,ee do while (a(iscr+6+ncyc).gt.ex) do ix=nx,1,-1 a(iscr+5+ncyc+ix)=a(iscr+5+ix) enddo a(iscr+6+ncyc)=fx*a(iscr+6+2*ncyc) val=a(iscr+7) a(iscr+7)=sqrt(fx)*val a(iscr+7+ncyc)=(1-fx*sqrt(fx))*val/(1-fx) nx=nx+ncyc n=n+1 enddo endif */ extend lowest delayed neutron bin using sqrt(e) shape *i acer.4670 common/ism/ismooth *i up63.205 c extend lowest delayed bin using sqrt(e) shape if (ismooth.gt.0.and.nint(a(iscr+7)).eq.1) then ex=40 fx=.8409 write(nsyso, & '('' extending lowest delayed bin using sqrt(E)'')') do while (a(iscr+10).gt.ex) do ix=2*mm,1,-1 a(iscr+9+ix)=a(iscr+7+ix) enddo a(iscr+10)=fx*a(iscr+12) val=a(iscr+9) a(iscr+9)=sqrt(fx)*val a(iscr+11)=(1-fx*sqrt(fx))*val/(1-fx) mm=mm+1 enddo endif */ use a finer energy grid for mf5 fission spectra above 10 mev */ when relatively coarse lin-lin steps are using for the exponential */ shape which really should be interpolated using lin-log *i acer.5949 common/ism/ismooth *i acer.6060 if (mt.eq.18.and.jnt.eq.2) then write(nsyso,'('' supplementing fission spectrum'', & '' grid above 10 MeV using exponential shape'')') ix=1 do while (ix.lt.n) jscr=iscr+4+2*m+2*ix if (a(jscr).lt.9.99e6) then ix=ix+1 else dele=a(jscr+2)-a(jscr) do ixx=n,ix+1,-1 a(iscr+5+2*m+2*ixx+8)=a(iscr+5+2*m+2*ixx) a(iscr+4+2*m+2*ixx+8)=a(iscr+4+2*m+2*ixx) enddo do ixx=1,4 a(jscr+2*ixx)=a(jscr)+ixx*dele/5 call terp1(a(jscr),a(jscr+1),a(jscr+10), & a(jscr+11),a(jscr+2*ixx),a(jscr+2*ixx+1),4) enddo n=n+4 ix=ix+5 endif enddo endif *ident up220 */ acer -- 27jun07 */ ident up70 added a total nubar plot to acer, but didn't give */ all the necessary info when nubar is defined as a polynomial. *i up70.130 xmin=e xmax=emax *d up70.134 ymax=ymax+xss(l+i)*emax**(i-1) *ident up221 */ acer --28jun07 */ all of up219 should have been turned off, but the coding to add spectra */ above 10 MeV was (i) always active, and (ii) could call terp1 */ with "y2" equal zero and interpolation code=4. Mods here include */ (i) expand the if test to add the missing "ismooth.ne.0" clause; */ (ii) check the value of dele - if it is less than 200 keV, don't do */ anything; and (iii) if "y2" is zero, temporarily reset it to a small, */ non-zero value before calling terp1. *d up219.85 if (ismooth.gt.0.and.mt.eq.18.and.jnt.eq.2) then *d up219.86,87 write(nsyso,'('' may supplement the fission '', & ''grid above 10 MeV using exponential shape '', & ''if delta-E exceeds 200 keV.'')') *d up219.95,105 if (dele.gt.2.e5) then do ixx=n,ix+1,-1 a(iscr+5+2*m+2*ixx+8)=a(iscr+5+2*m+2*ixx) a(iscr+4+2*m+2*ixx+8)=a(iscr+4+2*m+2*ixx) enddo ta11=zero if (a(jscr+11).eq.zero) then ta11=a(jscr+11) a(jscr+11)=1.e-6*a(jscr+1) endif do ixx=1,4 a(jscr+2*ixx)=a(jscr)+ixx*dele/5 call terp1(a(jscr),a(jscr+1), & a(jscr+10),a(jscr+11), & a(jscr+2*ixx),a(jscr+2*ixx+1), & 4) enddo if (ta11.ne.zero) a(jscr+11)=ta11 n=n+4 ix=ix+5 else ix=ix+1 endif *ident up222 */ viewr -- 29jun07 */ need to allow an i3 format where we currently only have i1 or i2. *d viewr.2397,2403 if ((nscale.gt.-10.and.nscale.lt.0).or.nscale.ge.10) then write(num,'(''*10#EH.8<'',i2,''#HXEX<'')') nscale lnum=17 else if (nscale.le.-10) then write(num,'(''*10#EH.8<'',i3,''#HXEX<'')') nscale lnum=18 else write(num,'(''*10#EH.8<'',i1,''#HXEX<'')') nscale lnum=16 endif *ident up223 */ reconr -- 2jul07 */ photonuclear processing revisions in up215 corrupt the dictionary */ for neutron and photon jobs (trkov). do it right here. */ first, force mt=3 (rather than mt=1) into the dictionary for the */ total xs when processing photonuclear files. The up215 if test */ could force a(j+4)=3 too often; this one is correct. *d up215.14,19 if (nint(a(imfs+i-1)).eq.3.and.mtr(imtr).eq.1 & .and.awin.eq.0) then a(j+4)=3 else a(j+4)=mtr(imtr) endif */ second, force mth=3 for total xs when processing photonuclear files */ (do this before testing for mfh=23 so that mth retains the correct */ value when processing photo-atomic files). The location of this */ test in up215 was wrong (trkov). *i reconr.4562 if (awin.eq.0) then mth=3 endif *d up215.22,24 *ident up224 */ plotr -- 3jul07 */ initialize nin2 all of the time (this variable was introduced in */ up77, but is not always initialized - not a problem if the compiler */ defaults uninitialized variables to zero). *b up77.16 nin2=0 *d up77.17 */ also initialize ee1 and ee2 before the if test at plotr.1002 */ (g95 run-time error). *i plotr.999 ee1=0 ee2=0 *d plotr.1004,1005 *ident up225 */ heatr -- 3jul07 */ up187 assumed we could get the maximum file energy from the */ third record in 1/451 if this was an endfb6 file. That's not */ always true. Therefore restructure this if test so that etop */ defaults to 20 MeV unless there is data in the file to define */ it larger. *d up187.15 if (iverf.eq.6.and.c2h.gt.etop) etop=c2h */ delete an unneeded data statement (etop is now initialized */ either in hinit or from the input data (up187), also trkov, */ lahey compiler warning). *d heatr.4110,4114 *ident up226 */ acer -- 4jul07 */ up174 is fixed as in up225 *d up174.14 if (iver.eq.6.and.a(iscr+1).gt.ehi) elim=a(iscr+1) *ident up227 */ groupr -- 4jul07 */ make same fix in upper limit for photon production from */ discrete levels that was made in up174 for acer and up187 */ for heatr, and then corrected in up225 and up226. *i groupr.247 common/maxx/emaxx *i groupr.310 if (iverf.le.4) then emaxx=15000000 else if (iverf.eq.5) then emaxx=20000000 else call contio(nendf,0,0,a(iscr),nb,nw) emaxx=20000000 if (c2h.gt.zero) emaxx=c2h endif *i groupr.7937 common/maxx/emaxx *d groupr.7947 *d groupr.7950 *i groupr.8279 etop=emaxx *ident up228 */ viewr -- 6jul07 */ initialize backgr in tagit prior to calling poly2 (not an */ issue if the compiler initializes undefined variables to zero). *i viewr.1224 backgr=zero *ident up229 */ thermr -- 9jul07 */ need more space when printing (Broeders, upfzk12). *d thermr.1614 & f8.3,'' ev.'')') tmax *d thermr.1620 & f8.3,'' ev.'')') tmax *ident up230 */ groupr -- 9jul07 */ need to define ehi to go with the already defined elo. */ ehi has previously been undefined (and likely set to zero */ by the compiler). *i groupr.4819 ehi=zero *i groupr.4892 if (c(l+1).gt.ehi) ehi=c(l+1) *i groupr.4987 if (c(l+1).gt.ehi) ehi=c(l+1) */ fix incorrect initialization. *d groupr.5067 ir=1 */ add missing save, similar to what was done in up135 for heatr. *b groupr.5589 save enow *ident up231 */ gaminr -- 9jul07 */ need to save some variables (similar to up131 in groupr). *i gaminr.866 save ng1,ig1 *ident up232 */ plotr -- 9jul07 */ make sure law is initialized (not an issue if the compiler */ presets undefined integers to zero). *i plotr.1175 law=zero *ident up233 */ errorr -- 10jul07 */ restructure this if test since nmd and/or nmt1d might only */ be defined when isd.eq.1 is true. *d errorr.1992 if (isd.eq.1)then if (nmd.ge.nmt1d) go to 390 endif *ident up234 */ acer -- 10jul07 */ need to initialize lt and lr flags to zero when dealing with */ charged particle files (not an issue if the compiler presets */ undefined integers to zero). *i acer.1751 lt=0 lr=0 */ initialize all isotropic angular distribution flag (not an */ issue if the compiler presets undefined integers to zero). *i acer.5341 iso=0 *ident up235 */ njoy -- 17jul07 */ revise if tests introduced in up180 to avoid machine */ roundoff errors (up180 sometimes makes 1.000000+n print */ as 10.000000+n) *i up180.8 onem=9.99999999d-1 *i up180.10 onem=9.99999999e-1 *d njoy.1337 if (abs(x).lt.onem) go to 140 *d up180.21,23 if (f.gt.onem.and.hx(10:11).eq.'00')write(hx,'(f9.6,a,i1)')f,s,n if (f.gt.tenth.and.f.lt.onem.and.hx(11:11).eq.'0') & write(hx,'(1pf9.6,a,i1)')f,s,n *ident up236 */ ccccr -- 17jul07 */ upgrade dldata to handle a variable number of delayed neutron */ groups, up to a maximum of ndmax. endf/b files typically have */ 6 delayed groups, modern jeff files typically have 8. also, */ warn user if too much data are found or if delayed data were */ requested but not found on the input tape. *i ccccr.132 common/delay/iso,nfam *d ccccr.208 if (lprint.eq.1.and.iso.ne.0)call pdlyxs(ndlay) *d ccccr.3049 c (there are typically nisod*ndg families, where ndg is the c number of delayed neutron groups for this isotope). *i ccccr.3067 parameter (ndmax=8) *d ccccr.3069 dimension fract(ndmax) */ read mf5, mt455 from the groupr tape to get the number of */ delayed neutron groups for this isotope. *i ccccr.3072 external contio *d ccccr.3074,3076 c c *** get the number of delayed neutron groups for this nuclide c from groupr's mf5, mt455 head record. call repoz(nin) call tpidio(nin,0,0,e(1),nb,nw) do while (mf.lt.5) call contio(nin,0,0,e(1),nb,nw) enddo if (mt.eq.455) then ndg=nint(e(3)) elseif (mt.lt.455) then do while (mf.eq.5.and.mt.lt.455) call contio(nin,0,0,e(1),nb,nw) enddo if (mf.eq.5)then ndg=nint(e(3)) else iso=0 return endif else iso=0 return endif if (ndg.eq.0) then iso=0 return elseif (ndg.gt.ndmax) then call mess ('dldata','too many delayed neutron groups', & 'dlayxs request ignored') iso=0 return endif c c *** assign storage (depends on number of delayed groups) nfam=ndg*nisod *d ccccr.3166,3168 do i=1,ndg ifam=ndg*(iso-1)+i loca=l8+ngn-ig+ngn*(ifam-1)+ndg*(iso-1) *d ccccr.3184 ifam=ndg*(iso-1)-1+l2 *d ccccr.3190 ifam=ndg*(iso-1)+i *d ccccr.3201,3202 ifam=i+ndg*(iso-1) loca=l8+ngn+ngn*(ifam-1)+ndg*(iso-1) *d ccccr.3204 locb=l8-1+ndg*ngn*iso+ndg*(iso-1)+i *ident up237 */ heatr -- 23jul07 */ include *set sw construct in subroutine hgam102 (introduced in */ up208) for correct single precision compilation with g95). *d up208.66 *if sw implicit real*8 (a-h,o-z) *endif */ define epn as the next energy in the stack. *i heatr.2808 epn=x(i) *ident up238 */ groupr -- 23jul07 */ move character definition for strng (from up157) out of the *set sw */ block (Absoft fatal error with single precision compilation) *d up157.9 *i groupr.3919 character*60 strng */ define epn as the next energy in the stack. *i groupr.5261 epn=x(i) */ include *set sw construct in subroutine gam102 (introduced in */ up212) for correct single precision compilation with g95). *d up212.34 *if sw implicit real*8 (a-h,o-z) *endif *ident up239 */ acer -- 24jul07 */ fix several locations where implicit real*8 is declared regardless */ of whether *set sw is part of the upn deck (g95). *d up69.58 *if sw implicit real*8 (a-h,o-z) *endif *d acer.18494 *if sw implicit real*8 (a-h,o-z) *endif *d acer.21212 *if sw implicit real*8 (a-h,o-z) *endif *ident up240 */ broadr -- 30jul07 */ up176 extended doppler broadening to partial charged particle */ reactions, but make sure we don't double count these cross */ sections when reconstructing the total (Daily, KAPL). If mt103 */ through mt107 are not present but the partials are they are used */ for the reconstruction. If any of mt103 through mt107 are present */ and are non-threshold cross sections they will be doppler broadened */ as always. We do not attempt to reconstruct them from the newly */ broadened partial cross sections. *i broadr.310 mt103=0 mt104=0 mt105=0 mt106=0 mt107=0 if (iverf .ge. 6) then mpmin=600 mpmax=649 mdmin=650 mdmax=699 mtmin=700 mtmax=749 m3min=750 m3max=799 m4min=800 m4max=849 else mpmin=700 mpmax=718 mdmin=720 mdmax=738 mtmin=740 mtmax=758 m3min=760 m3max=768 m4min=780 m4max=798 endif *i broadr.346 if (mth.eq.103)mt103=1 if (mth.eq.104)mt104=1 if (mth.eq.105)mt105=1 if (mth.eq.106)mt106=1 if (mth.eq.107)mt107=1 *i broadr.724 c ***Don't include partial xs if its sum is already available if (mt103.eq.1.and.mtr(i).ge.mpmin.and.mtr(i).le.mpmax) & iflag=1 if (mt104.eq.1.and.mtr(i).ge.mdmin.and.mtr(i).le.mdmax) & iflag=1 if (mt105.eq.1.and.mtr(i).ge.mtmin.and.mtr(i).le.mtmax) & iflag=1 if (mt106.eq.1.and.mtr(i).ge.m3min.and.mtr(i).le.m3max) & iflag=1 if (mt107.eq.1.and.mtr(i).ge.m4max.and.mtr(i).le.m4max) & iflag=1 *ident up241 */ thermr -- 30jul07 */ The evaluations for liquid hydrogen and deuterium are stored in */ ENDF-6 format with LASYM=1 and LAT=1. Need to make sure beta */ is scaled properly for this option combination when comparing */ against the endf file mesh (upnea015 by M.Mattes). *d thermr.1977,1978 bbm=bb if (lat.eq.1) bbm=bb*tev/tevz if (bbm.gt.beta(nbeta)) go to 170 if (bbm.lt.beta(1)) go to 170 *ident up242 */ reconr -- 31jul07 */ Expand total cross section reconstruction to include partial */ charged particle cross sections if they are present and the */ corresponding mt103,...,mt107 are not. This affects seven */ endf/b-vii nuclides (7Be,74,75As,90Y,232Th,231Pa,233Pa). *i reconr.385 common/util/npage,iverf *i reconr.388 common/recon4/mt103,mt104,mt105,mt106,mt107, & mpmin,mpmax,mdmin,mdmax,mtmin,mtmax, & m3min,m3max,m4min,m4max *i reconr.402 mt103=0 mt104=0 mt105=0 mt106=0 mt107=0 if (iverf .ge. 6) then mpmin=600 mpmax=649 mdmin=650 mdmax=699 mtmin=700 mtmax=749 m3min=750 m3max=799 m4min=800 m4max=849 else mpmin=700 mpmax=718 mdmin=720 mdmax=738 mtmin=740 mtmax=758 m3min=760 m3max=768 m4min=780 m4max=798 endif *i reconr.418 if (mti.eq.103) mt103=1 if (mti.eq.104) mt104=1 if (mti.eq.105) mt105=1 if (mti.eq.106) mt106=1 if (mti.eq.107) mt107=1 *i reconr.4118 common/recon4/mt103,mt104,mt105,mt106,mt107, & mpmin,mpmax,mdmin,mdmax,mtmin,mtmax, & m3min,m3max,m4min,m4max *d reconr.4274 if (mth.ge.151.and.mth.lt.mpmin) go to 440 if (mt103.eq.1.and.mth.ge.mpmin.and.mth.le.mpmax) go to 440 if (mt104.eq.1.and.mth.ge.mdmin.and.mth.le.mdmax) go to 440 if (mt105.eq.1.and.mth.ge.mtmin.and.mth.le.mtmax) go to 440 if (mt106.eq.1.and.mth.ge.m3min.and.mth.le.m3max) go to 440 if (mt107.eq.1.and.mth.ge.m4min.and.mth.le.m4max) go to 440 *ident up243 */ acer -- 31jul07 */ same change as made in up242 for reconr. *i acer.1283 common/ace10/mt103,mt104,mt105,mt106,mt107, & mpmin,mpmax,mdmin,mdmax,mtmin,mtmax, & m3min,m3max,m4min,m4max *i acer.1346 mt103=0 mt104=0 mt105=0 mt106=0 mt107=0 if (iverf .ge. 6) then mpmin=600 mpmax=649 mdmin=650 mdmax=699 mtmin=700 mtmax=749 m3min=750 m3max=799 m4min=800 m4max=849 else mpmin=700 mpmax=718 mdmin=720 mdmax=738 mtmin=740 mtmax=758 m3min=760 m3max=768 m4min=780 m4max=798 endif *i acer.1950 if (mt.eq.103) mt103=1 if (mt.eq.104) mt104=1 if (mt.eq.105) mt105=1 if (mt.eq.106) mt106=1 if (mt.eq.107) mt107=1 *d acer.1987 if ((mt.le.120) & .or.(mt103.eq.0.and.mt.ge.mpmin.and.mt.le.mpmax) & .or.(mt104.eq.0.and.mt.ge.mdmin.and.mt.le.mdmax) & .or.(mt105.eq.0.and.mt.ge.mtmin.and.mt.le.mtmax) & .or.(mt106.eq.0.and.mt.ge.m3min.and.mt.le.m3max) & .or.(mt107.eq.0.and.mt.ge.m4min.and.mt.le.m4max)) & then *i up63.12 common/ace10/mt103,mt104,mt105,mt106,mt107, & mpmin,mpmax,mdmin,mdmax,mtmin,mtmax, & m3min,m3max,m4min,m4max *d acer.5212 if ((mth.ge.102.and.mth.le.150) & .or.(mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax) & .or.(mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax) & .or.(mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax) & .or.(mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max) & .or.(mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max)) & then *d acer.5223 if ((mth.ge.5.and.mth.le.150) & .or.(mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax) & .or.(mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax) & .or.(mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax) & .or.(mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max) & .or.(mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max)) & then *ident up244 */ gaspr -- 1aug07 */ same change as made for acer (up243) and reconr (up242). *i gaspr.10 c * if the input pendf tape omits mt103-mt107, but does have the * c * partial charged particle cross sections they are processed and * c * will appear in the appropriate mt20x section. * *i gaspr.63 c ***also set flags for absence or presence of charged c ***particle reactions and the endf version dependent c ***partial cross sections mt ranges. *i gaspr.98 mt103=0 mt104=0 mt105=0 mt106=0 mt107=0 mt600=0 mt650=0 mt700=0 mt750=0 mt800=0 if (iverf .ge. 6) then mpmin=600 mpmax=649 mdmin=650 mdmax=699 mtmin=700 mtmax=749 m3min=750 m3max=799 m4min=800 m4max=849 else mpmin=700 mpmax=718 mdmin=720 mdmax=738 mtmin=740 mtmax=758 m3min=760 m3max=768 m4min=780 m4max=798 endif *i gaspr.101 if (mfi.eq.3.and.mti.eq.103) mt103=1 if (mfi.eq.3.and.mti.eq.104) mt104=1 if (mfi.eq.3.and.mti.eq.105) mt105=1 if (mfi.eq.3.and.mti.eq.106) mt106=1 if (mfi.eq.3.and.mti.eq.107) mt107=1 if (mfi.eq.3.and.mti.ge.mpmin.and.mti.le.mpmax) mt600=1 if (mfi.eq.3.and.mti.ge.mdmin.and.mti.le.mdmax) mt650=1 if (mfi.eq.3.and.mti.ge.mtmin.and.mti.le.mtmax) mt700=1 if (mfi.eq.3.and.mti.ge.m3min.and.mti.le.m3max) mt750=1 if (mfi.eq.3.and.mti.ge.m4min.and.mti.le.m4max) mt800=1 *d gaspr.200 c ***copy data through file 3, including any partial charged c ***particle cross sections *d gaspr.209,210 mtb=mth if (mth.gt.m4max.or.mth.eq.0) then *i gaspr.217 c c ***reposition npend to the location where gas production c ***cross sections would go. call repoz(npend) call tpidio(npend,0,0,a(1),nb,nw) call tofend(npend,0,0,a(1)) call tofend(npend,0,0,a(1)) idone=0 do while (idone.eq.0) call contio(npend,0,0,b(1),nb,nw) if (mth.gt.117.or.mfh.eq.0) then idone=1 else call tosend(npend,0,0,a(1)) endif enddo *d gaspr.225 if (mth.gt.117.and.mth.lt.mpmin) go to 245 if (mth.gt.m4max.or.mth.eq.0) go to 250 *d gaspr.286,291 if ((mth.ge.103.and.mth.le.117).or. & (mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax).or. & (mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax).or. & (mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax).or. & (mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max).or. & (mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max)) izg=1 if ((mth.eq.103).or. & (mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax))izr=izr-1001 if (mt103.eq.1.and.mth.ge.mpmin.and.mth.le.mpmax) go to 245 if ((mth.eq.104).or. & (mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax))izr=izr-1002 if (mt104.eq.1.and.mth.ge.mdmin.and.mth.le.mdmax) go to 245 if ((mth.eq.105).or. & (mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax))izr=izr-1003 if (mt105.eq.1.and.mth.ge.mtmin.and.mth.le.mtmax) go to 245 if ((mth.eq.106).or. & (mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max))izr=izr-2003 if (mt106.eq.1.and.mth.ge.m3min.and.mth.le.m3max) go to 245 if ((mth.eq.107).or. & (mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max))izr=izr-2004 if (mt107.eq.1.and.mth.ge.m4min.and.mth.le.m4max) go to 245 *d gaspr.301 *d gaspr.347 if (mth.gt.117.and.mth.lt.mpmin) go to 310 if (mth.gt.m4max.or.mth.eq.0) go to 330 *d gaspr.356 if (mt103.eq.1.and.mth.ge.mpmin.and.mth.le.mpmax) go to 310 if (mt104.eq.1.and.mth.ge.mdmin.and.mth.le.mdmax) go to 310 if (mt105.eq.1.and.mth.ge.mtmin.and.mth.le.mtmax) go to 310 if (mt106.eq.1.and.mth.ge.m3min.and.mth.le.m3max) go to 310 if (mt107.eq.1.and.mth.ge.m4min.and.mth.le.m4max) go to 310 *d gaspr.477 else if ((mth.eq.103).or. & (mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax)) then *d gaspr.480 else if ((mth.eq.104).or. & (mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax)) then *d gaspr.483 else if ((mth.eq.105).or. & (mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax)) then *d gaspr.486 else if ((mth.eq.106).or. & (mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max)) then *d gaspr.489 else if ((mth.eq.107).or. & (mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max)) then *ident up245 */ purr -- 6aug07 */ unresolved evalutions with narrow widely spaced resonances */ (kev dbar values) don't get sampled very well by purr, and */ the probability tables end up with total cross section bins */ with zero width around the potential scattering cross section. */ in this patch, we slightly increase the sampling density for */ cases with dbar in the kev range, and we make sure that total */ cross sections bins of the probability table are monotonically */ increasing (no zero width bins). *d purr.1782 dmin=500 *i up84.56 if (i.gt.1) then if (tval(i,itemp).le.tval(i-1,itemp)) & tval(i,itemp)=tval(i-1,itemp)+tval(i-1,itemp)/20 endif *ident up246 */ broadr -- 22aug07 */ fix typo in up240 that affects nuclides such as 10B that have */ both mt107 plus threshold mt800 and above reactions (Daily, KAPL). *d up240.56 if (mt107.eq.1.and.mtr(i).ge.m4min.and.mtr(i).le.m4max) *ident up247 */ gaspr -- 22aug07 */ revise up244 logic when repositioning an npend tape that contains data */ for multiple temperatures (Trellue, LANL). up244 coding only works */ for a single temperature npend tape. *i up244.68 if(itemp.gt.1)then do i=2,itemp call tomend(npend,0,0,a(1)) enddo endif */ fix a typo to be consistent with earlier coding, although the */ previous variable, mfh, actually works in this context. *d up244.74 if (mth.gt.117.or.mth.eq.0) then *ident up248 */ reconr -- 22aug07 */ hard to believe that an "i6" format is needed, but it is for */ jendl-3.3 239pu. *d reconr.1988,1991 & '' number of user and resonance nodes = '',i6,/ & '' points in initial unionized grid = '',i6,/ & '' points added by linearization = '',i6,19x,f8.1, & ''s'')')nodes,ngpos,ngneg,time *d reconr.4353 & '' number of points in final unionized grid = '',i6)')ngo *ident up249 */ acer -- 23aug07 */ expand from "i2" to "i3" format to handle all possible mt numbers. *d acer.6070 & 6x,''mt='',i3,'' e='',1p,e12.4,'' ep='',e12.4/ *d acer.6710 & 6x,''mt='',i3,'' e='',1p,e12.4,'' ep='',e12.4/ *d up106.15 & 6x,''mt='',i3,'' e='',1p,e12.4,'' ep='',e12.4/ *d acer.6717 & 6x,''mt='',i3,'' e='',1p,e12.4,'' ep='',e12.4/ *ident up250 */ viewr -- 23aug07 */ expand foreground color array from 8 to 9. This allows for */ a border plus up to eight curves (as needed, for example, to */ plot eight delayed neutron groups). *d viewr.221 c * 7=purple * c * 8=orange * *d viewr.3786 common/plot12/ibrgb(3,8),ifrgb(3,9),isrgb(3,40) *d viewr.3891 common/plot12/ibrgb(3,8),ifrgb(3,9),isrgb(3,40) *d viewr.4462 common/plot12/ibrgb(3,8),ifrgb(3,9),isrgb(3,40) *d viewr.4616 & 160, 32,240, ! purple & 225, 80, 20/ ! orange *ident up251 */ reconr -- 27aug07 */ need to include file 10 sections when determining how much space */ to set aside for the dictionary. Nuclides with 6 or more file 10 */ sections, such as jeff-3.1 99Tc, 103Rh and 127,129I have had bad */ dictionary data in pendf tapes produced by reconr in the past. *b reconr.419 else if (mfi.eq.10) then nxn=nxn+1 *ident up252 */ heatr -- 30aug07 */ need to shade the initial and final energies when passing through */ a discontinuity that doesn't specify histogram interpolation or */ terp1 may divide by zero. *i heatr.4863 if (elo.eq.ehi) then elo=sigfig(elo,7,-1) ehi=sigfig(ehi,7,+1) endif *ident up253 */ heatr -- 6sep07 */ in the initialization phases of disbar and hgtfle make sure enext */ is defined (and points to the maximum energy for this evaluation) */ when isotropy is assumed or specified for the angular distributions. *i heatr.1507 common/lims/ebot,etop *i heatr.1608 enext=etop *b heatr.3774 common/lims/ebot,etop *d heatr.3844,3845 if (iso.eq.1)then nle=1 enext=etop else enext=elo endif *d heatr.3920 enext=etop */ clean up an obsolete error message. Actually, current coding is */ never true for this if test, but someday it may be and then we */ should be ready to test for legal values. *d heatr.2029 if (lnd.ne.6.and.lnd.ne.8) & call error('hgtyld','illegal lnd, must be 6 or 8',' ') *ident up254 */ groupr -- 12sep07 */ remove some old coding that makes analytic fission spectra */ come out as histograms. Also correct the subroutine name */ used in an error message. *d up131.14 call error('panel','bad nq in panel',' ') *d groupr.8648 save nktot,nupm,loc *d groupr.8651,8652 *d groupr.8660,8661 *d groupr.8820 *d groupr.8827 *d groupr.8942,8947 return *ident up255 */ leapr -- 13sep07 */ several corrections and additions are needed, as noted below */ (altiparmakov, aecl). */ */ print warning to the terminal and to standard output when the user */ selects the isabt=1 option since thermr can not correctly process */ this file. *i leapr.177 external mess *i leapr.213 if (isabt.ne.0)write(nsyso,'(/ & ''*** Warning. isabt=1 pendf tapes CANNOT be processed '', & ''by the NJOY THERMR module ***'')') if (isabt.ne.0)call mess('leapr','isabt=1 pendf tapes CANNOT be', & 'processed by thermr.') */ add ilog (LLN in the endf manual) flag to the pendf tape. *i leapr.2973 if (ilog.ne.0)scr(3)=1 */ moreio coding was added to handle large alpha and beta mesh back */ in up98, but we missed one. It hasn't been needed yet, but if */ more than "npage" alpha mesh values are present and we're writing */ data for two or more temperatures it will. *i leapr.3233 ll=1 do while (nb.ne.0) ll=ll+nw call moreio(0,nout,nprnt,scr(ll),nb,nw) enddo *ident up256 */ thermr -- 13sep07 */ add long overdue coding so that thermr recognizes when S(a,b) */ data are given as ln(S(a,b)). Also test if leapr was run with */ the isabt=1 option. If so, we can't process this file. This */ is inferred in LA-12639-MS (ENDF-356), but is not well known */ nor has it been well publicized previously (altiparmakov, aecl). *i thermr.1517 c c ***lasym= 0 or 1 = traditional endf definitions. c ***lasym= 2 or 3 = traditional lasym + 2 c = leapr's isabt=1 option was used. if (lasym.gt.1) call error ('calcem','isabt=1 pendf tape found', & 'thermr cannot process this format') *i thermr.1519 ilog=l1h *d thermr.1588,1592 if (ilog.eq.0) then if (a(l).gt.sabmin) a(isab+ia-1+nalpha*(ib-1))=log(a(l)) if (a(l).le.sabmin) then if (a(l).gt.zero) itrunc=1 a(isab+ia-1+nalpha*(ib-1))=sabflg endif else a(isab+ia-1+nalpha*(ib-1))=a(l) endif *ident up257 */ groupr -- 17sep07 */ up227 fixed the upper bound for reconstructing photon yields, */ but we need to set the lower bound to the file 3 non-zero */ cross section threshold when converting from transition */ probabilities (this is similar to what we did in up186 for */ acer, and is a change that we should have made in groupr at */ that time). *i groupr.259 data ebeg/1.d-5/ *i groupr.261 data ebeg/1.e-5/ *d up227.7 common/maxx/ebeg,emaxx *d up227.19 common/maxx/ebeg,emaxx *b groupr.7931 parameter (mxnnth=350) *i groupr.7940 dimension mtth(mxnnth),eeth(mxnnth) *i groupr.7983 nnth=0 *i groupr.7988 c c ***get thresholds vs mt number if (mfh.eq.3.and.mth.ne.0) then e=0 call gety1(e,enxt,jdis,x,nin,a(iscr)) nnth=nnth+1 if (nnth.gt.mxnnth) call error('conver','nnth too large',' ') eeth(nnth)=enxt mtth(nnth)=mth call contio(0,nout,nscr,a(iscr),nb,nw) call tosend(nin,nout,nscr,a(iscr)) go to 110 endif c *d groupr.8289 a(iscr+8)=elow *d groupr.8306 a(iscr+8)=elow *b groupr.8280 elow=ebeg do i=1,nnth if (mtth(i).eq.mth) elow=eeth(i) enddo */ override cartesion interpolation for mf6/law1 distributions */ with unit base interpolation to get smoother scattering */ source functions. mcnp does this, so we will ignore the */ strict endf rule for better consistency between mg and mc. *i groupr.4880 c force unit base interpolation for smoother scattering source if (int.eq.2) int=22 *i groupr.5095 c force unit base interpolation for smoother scattering source if (int.eq.2) int=22 */ the hnab routine used in the calculation of the energy-dependent */ watt fission spectrum for very large outgoing energies gives */ answers that are too small by a factor of 2. this affects */ ENDF/B-VII U-233 above 15 MeV. *d groupr.9327 hh(n+1)=2*con*s*sgn */ correct the subroutine name passed to mess *d up16.22 call mess('f6ddx', *d up16.37 call mess('f6ddx', *d up16.55 call mess('f6ddx', */ correct the subroutine name passed to error *d groupr.8236 if (l.gt.lmax) call error('conver', */ do some minor cleaning up in anased. *d groupr.9019,9021 de=e-u *d up140.14 if (lf.ne.12) xc=de/theta *d groupr.9109 */ the shape of the fission spectrum above 10 MeV is nearly */ exponential, but the endf tabulated fission spectra for */ important isotopes like U-235 and Pu-239 specify linear */ interpolation on a fairly coarse energy grid. this patch */ forces the use of linear-E, log-probability interpolation */ above 10 MeV for tabulated fission spectra. see up219 for */ a corresponding change for mcnp data. note that this */ option in normally turned off. change ismooth to enable it. *i groupr.8639 common/mainio/nsysi,nsyso,nsyse,ntty *i groupr.8668 c change ismooth to 1 to force lin-log interpolation c of tabulated fission spectra above 10 MeV data ismooth/0/ *i groupr.8766 c change to lin-log interpolation above 10 MeV c for tabulated fission spectra with one c interpolation range if (ismooth.gt.0.and.mtd.eq.18) then brk=10000000 nr=nint(c(m1+4)) if (nr.eq.1) then if (nne.eq.0) write(nsyso, & '(/,'' forcing lin-log for mt18'', & '' above 10 MeV'')') np=nint(c(m1+5)) j=m1+6 do i=1,np if (c(j+2*i).lt.brk) ii=i enddo do i=1,2*np c(m-i+2)=c(m-i) if (i.eq.3) c(m+1)=c(m-i+2)/10 enddo c(m1+4)=2 c(m1+6)=ii c(m1+8)=np c(m1+9)=4 endif endif */ adjust mf6,law1 distributions by adding more histogram segments */ at low outgoing energies using log spacing to more closely */ approximate a sqrt(e) shape. this is an option that is normally */ turned off. change ismooth to 1 to enable it. using this option */ will give smoother flux curves in the 1 kev to 100 kev range for */ assemblies like godiva or jezebel, but the effect on criticality */ is small. *i groupr.4788 c change ismooth to 1 to enable sqrt(e) smoothing for c histogram emission spectra at low energies and for c histogram delayed neutron spectra at low energies. data ismooth/0/ *i groupr.4908 if (ismooth.gt.0) then fx=.8409 ex=40 ncyc=nint(c(ilo+3))+2 cx=c(ilo+6+ncyc)*c(ilo+7) nx=nint(c(ilo+4)) n=nint(c(ilo+5)) do while (n.gt.2) cxx=cx+c(ilo+7+ncyc)*(c(ilo+6+2*ncyc) & -c(ilo+6+ncyc)) if (abs(cxx/c(ilo+6+2*ncyc)**1.5 & -cx/c(ilo+6+ncyc)**1.5) & .gt.cx/c(ilo+6+ncyc)**1.5/50) exit c(ilo+7)=(c(ilo+7)*c(ilo+6+ncyc) & +c(ilo+7+ncyc)*(c(ilo+6+2*ncyc) & -c(ilo+6+ncyc)))/c(ilo+6+2*ncyc) do ix=1,nx-2*ncyc c(ilo+5+ix+ncyc)=c(ilo+5+ix+2*ncyc) enddo cx=cxx nx=nx-ncyc n=n-1 enddo write(nsyso,'('' extending as sqrt(E) below'', & 1p,e10.2,'' eV for E='',e10.2,'' eV'')') & c(ilo+6+ncyc),c(ilo+1) do while (c(ilo+6+ncyc).gt.ex) do ix=nx,1,-1 c(ilo+5+ncyc+ix)=c(ilo+5+ix) enddo c(ilo+6+ncyc)=fx*c(ilo+6+2*ncyc) val=c(ilo+7) c(ilo+7)=sqrt(fx)*val c(ilo+7+ncyc)=(1-fx*sqrt(fx))*val/(1-fx) nx=nx+ncyc n=n+1 c(ilo+4)=nx c(ilo+5)=n enddo l=ilo+6+nx endif */ extend lowest delayed neutron bin using sqrt(e) shape *i groupr.8720 l1=l *i groupr.8729 c extend lowest delayed bin using sqrt(e) shape if (ismooth.gt.0.and.mtd.eq.455.and. & nint(c(l1+7)).eq.1) then ex=40 fx=.8409 write(nsyso,'('' extending lowest delayed bin'', & '' using sqrt(E)'')') mm=nint(c(l1+5)) do while (c(l1+10).gt.ex) do ix=2*mm,1,-1 c(l1+9+ix)=c(l1+7+ix) enddo c(l1+10)=fx*c(l1+12) val=c(l1+9) c(l1+9)=sqrt(fx)*val c(l1+11)=(1-fx*sqrt(fx))*val/(1-fx) mm=mm+1 enddo c(l1+5)=mm c(l1+6)=mm l=l1+8+2*mm endif *i groupr.8766 c extend lowest delayed bin using sqrt(e) shape if (ismooth.gt.0.and.mtd.eq.455.and. & nint(c(m1+7)).eq.1) then ex=40 fx=.8409 write(nsyso,'('' extending lowest delayed bin'', & '' using sqrt(E)'')') mm=nint(c(m1+5)) do while (c(m1+10).gt.ex) do ix=2*mm,1,-1 c(m1+9+ix)=c(m1+7+ix) enddo c(m1+10)=fx*c(m1+12) val=c(m1+9) c(m1+9)=sqrt(fx)*val c(m1+11)=(1-fx*sqrt(fx))*val/(1-fx) mm=mm+1 enddo c(m1+5)=mm c(m1+6)=mm endif *ident errorj */ (ident up258) */ errorr -- 25sep07 */ replace with "errorj" by Go Chiba. See further comments below. *d errorr.2,errorr.4345 c subroutine errorr c ****************************************************************** c * * c * modifed errorr module based on the errorj code * c * * c * From errorr: egtflx, egtsig, grist, lumpmt, lumpxs, merge, * c * rdsig, stand * c * From errorr with modifications: * c * errorr, covcal, covout, egngpn, epanel, grpav, * c * rdgout, sigc, uniong, colaps, gridd, resprp, * c * rescon, egnwtf, wgtwtf * c * From reconr with modifications: * c * ggrmat, ggmlbw, ssmlbw, ssslbw, ggunr1 * c * From errorj: resprx, Resprx_XXX, grpav4, alsigc, egtlgc, * c * musigc, matrixin, rdlgnd, fssigc, rdchi * c * * c ****************************************************************** c * * c * Further adapted for njoy99 by Skip Kahler (9/25+/2007) * c * - include ggrmat changes specified by Go Chiba in his "Bug- * c * fix for ERRORJ-2.3" memo, dated October 3, 2007 (his ggmlbw * c * correction has already been made and noted below). * c * - change "implicit double precision" to "implicit real*8" to * c * match historical njoy coding practice. * c * - change (or add) real number exponents from "e" to "d". * c * - make sure routines duplicated from other modules contain * c * the latest updates (through njoy99.257 currently). * c * - for consistency and future maintenance, replace assignments * c * for pi and physical constants with values defined or * c * calculated from main program common blocks. * c * - eliminate the "H" edit descriptor in format statements. * c * - changed "write(6,..." to "write(*,...". * c * - fix typo, "cwave" -> "cwaven" in ggmlbw. * c * - move "mprint=0" out of the if block in errorj so that this * c * variable is always properly initialized. * c * - add "mxlru2" to ggunr1 call list for proper amu dimension * c * declaration (g95 compiler). * c * - change b(1),alp(1) to b(*),alp(*) in rdlgnd dimension * c * declaration (g95 compiler). * c * - restructure a number of multiple condition "if" tests to * c * avoid run-time (undefined variables or array bounds under/ * c * overflow) errors from code compiled without optimization. * c * - change b(10) to b(*) in musigc and fssigc. * c * - delete "return" that cannot be reached in ggunr1 (absoft * c * compiler). * c * - miscellaneous text formatting changes to make the source * c * code flow more readable. * c * * c ****************************************************************** c * * c * produce cross section covariances from error files in endf/b * c * format * c * * c * first, the union energy grid of the users group structure * c * and the endf covariance energies is determined. the array * c * of coefficients for derived cross sections is also constructed.* c * then multigroup cross sections are computed on the union * c * grid (see grpav), or they are read from a multigroup cross * c * section library and then collapsed to the union grid. the * c * methods of groupr are used for cross section averaging. endf * c * covariances and the group cross sections are then combined * c * to get the basic covariance matrices (see covcal). finally, * c * the basic matrices are combined to get covariances for * c * derived reactions, the matrices are collapsed to the user-s * c * group structure, and the results are printed and/or written * c * onto an output gendf tape for later use (see covout). * c * * c *---input specifications (free format)---------------------------* c * * c * card 1 * c * nendf unit for endf/b tape * c * npend unit for pendf tape * c * ngout unit for input group xsec (gendf) tape * c * (if zero, group xsecs will be calculated) * c * (if iread eq 2 or if mfcov eq 31 (see card 7), * c * ngout cannot be zero) * c * (if mfcov eq 35 (see card 7), * c * ngout cannot be zero) * c * (default=0) * c * nout unit for output covariance tape (default=0) * c * nin unit for input covariance tape (default=0) * c * (nin and nout must be both coded or both binary) * c * nstan unit for ratio-to-standard tape (default=0) * c * card 2 * c * matd material to be processed * c * ign neutron group option * c * (ign definition same as groupr, except ign=19, * c * which means read in an energy grid, as in ign=1, * c * and supplement this with the endf covariance grid * c * within the range of the user-specified energies) * c * (default=1) * c * iwt weight function option (default=6) * c * iprint print option (0/1=minimum/maximum) (default=1) * c * irelco covariance form (0/1=absolute/relative) (default=1) * c * (if mfcov=34, irelco must be 1) * c * card 3 (omit if ngout.ne.0) * c * mprint print option for group averaging (0=min., 1=max.) * c * tempin temperature (default=300) * c * * c *---for endf/b version 4 (iverf=4) only--------------------------* c * * c * card 4 * c * nek number of derived xsec energy ranges * c * (if zero, all xsecs are independent) * c * card 5 (omit if nek=0) * c * ek nek+1 derived xsec energy bounds * c * card 6 (omit if nek=0) * c * akxy derived cross section coefficients, one row/line * c * * c *---for endf/b version 5 or 6 (iverf=5 or 6) only----------------* c * * c * card 7 * c * iread 0/1/2=program calculated mts/input mts and eks/ * c * calculated mts plus extra mat1-mt1 pairs from input * c * (default=0) * c * mfcov endf covariance file (31, 33, 34 or 35) to be * c * processed (default=33). * c * note--contribution to group cross section * c * covariances from resonance-parameter uncertainties * c * (mf=32) is included when mfcov=33 is specified. * c * (mf=-33) high speed Calc. for test case * c * (mf=333) high speed Calc. for test case(faster) * c * irespr processing option of resonance parameter covariance * c * (mf=32) (default=1) * c * 0 = area sensitivity method * c * 1 = 1% sensitivity method * c * legord legendre order calculating covariance (default=1) * c * (if mfcov is not 34, legord is ignored) * c * ifissp processing energy range number of fission energy * c * spectrum (default=-1) * c * (if mfcov is not 35, ifissp is ignored) * c * n>0 = energy range number * c * -1 = fast neutron reactor (average energy = 2 MeV) * c * * c * following cards only if iread eq 1 * c * card 8 * c * nmt no. mts to be processed * c * nek no. derived cross section energy ranges * c * (if zero, all xsecs are independent) * c * card 8a * c * mts nmt mts * c * card 8b (omit if nek=0) * c * ek nek+1 derived cross section energy bounds * c * card 9 (omit if nek=0) * c * akxy derived cross section coefficients, one row/line * c * * c * following card only if iread eq 2 * c * card 10 * c * mat1 cross-material reaction to be added to * c * mt1 covariance reaction list. * c * repeat for all mat1-mt1 pairs desired * c * terminate with mat1=0. * c * * c * following card only if nstan ne 0 * c * card 11 * c * matb standards reaction referenced * c * mtb in matd. * c * matc standards reaction to be * c * mtc used instead. * c * repeat for all standard reactions to be redefined. * c * terminate with matb=0. * c * note. if matb(1) and mtb(1) are negative, then matc(1) and * c * mtc(1) identify a third reaction, correlated with matd thru * c * the use of the same standard. covariances of all reactions * c * in matd (which reference the standard) with the reaction * c * matc(1)-mtc(1) will be produced. the standard reaction * c * must be identified on card 10 and repeated as the negative * c * entries on card 11. the group xsec tape ngout must include * c * all covariance reactions in matd, plus matc(1)-mtc(1). * c *----------------------------------------------------------------* c * * c * card 12a (for ign eq 1 or ign eq 19) * c * ngn number of groups * c * (if negative, group bounds is decending order) * c * card 12b * c * egn ngn+1 group bounds (ev) * c * card 13a tabulated (iwt=1 only) * c * wght weight function as a tab1 record * c * card 13b analytic flux parameters (iwt=4 only) * c * eb thermal break (ev) * c * tb thermal temperature (ev) * c * ec fission break (ev) * c * tc fission temperature (ev) * c * * c *---options for input variables----------------------------------* c * * c * ign meaning * c * --- ------- * c * 1 arbitrary structure (read in) * c * 2 csewg 239-group structure * c * 3 lanl 30-group structure * c * 4 anl 27-group structure * c * 5 rrd 50-group structure * c * 6 gam-i 68-group structure * c * 7 gam-ii 100-group structure * c * 8 laser-thermos 35-group structure * c * 9 epri-cpm 69-group structure * c * 10 lanl 187-group structure * c * 11 lanl 70-group structure * c * 12 sand-ii 620-group structure * c * 13 lanl 80-group structure * c * 14 eurlib 100-group structure * c * 15 sand-iia 640-group structure * c * 16 vitamin-e 174-group structure * c * 17 vitamin-j 175-group structure * c * 18 xmas 172-group structure * c * 19 read in, supplemented with endf covariance grid* c * * c * iwt meaning * c * --- ------- * c * 1 read in smooth weight function * c * 2 constant * c * 3 1/e * c * 4 1/e + fission spectrum + thermal maxwellian * c * 5 epri-cell lwr * c * 6 (thermal) -- (1/e) -- (fission + fusion) * c * 7 same with t-dep thermal part * c * 8 thermal--1/e--fast reactor--fission + fusion * c * 9 claw weight function * c * 10 claw with t-dependent thermal part * c * 11 vitamin-e weight function (ornl-5505) * c * 12 vit-e with t-dep thermal part * c * * c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr1,nscr2,nscr3 common/mode/imode common/mainio/nsysi,nsyso,nsyse,ntty common/estore/a(8500000) common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/grpn/ign,ngn,egn(901),iprint common/ewght/iwt common/redef/nas,matb(5),mtb(5),matc(5),mtc(5) common/amnc/amassn common/amuc/amu common/hbarc/hbar common/evc/ev common/cwav/cwaven c common/eunits34/nscr4 common/irspd/eskip1,eskip2,eskip3 common/err4/legord,irespr,ifissp c character*60 strng dimension b(17) dimension z(10) c dimension iaddmt(5) data eps/1.d-9/ data small/1.d-10/ data big/1.d10/ data elo/1.d-5/ data ipr/0/ c cwaven=sqrt(2.d0*amassn*amu*ev)*1.d-12/hbar c c ***read user input and write header. nkmax=50 nmtmax=60 nenimx=1000 nidmax=30 namax=8500000 c nlmt=50 imode=-1 iread=0 mfcov=33 iwt=0 ndig=6 do i=1,namax a(i)=0 enddo nasmax=5 nas=0 call timer(time) write(nsyso,'(/, & '' errorr...produce cross section covariances'', & 26x,f8.1,''s'')') time write(nsyse,'(/,'' errorr...'',59x,f8.1,''s'')') time ngout=0 nout=0 nin=0 nstan=0 read(nsysi,*) nendf,npend,ngout,nout,nin,nstan c if(nendf.eq.999)then read(nsysi,*)nitape,notape iadd=0 1000 continue read(nsysi,*)ii if(ii.ne.0)then iadd=iadd+1 if(iadd.gt.5)then write(nsyso,*)'error in errorr999.' stop endif iaddmt(iadd)=ii goto 1000 else call covadd(iadd,iaddmt,5,nitape,notape) return endif write(nsyso,*)'error in errorr999.' stop endif c cej if(nendf.eq.nstan) & call error('errorr','nstan should be different from nendf','') c call openz(nendf,0) call openz(npend,0) call openz(ngout,0) call openz(nout,1) call openz(nin,0) call openz(nstan,0) call repoz(nendf) call tpidio(nendf,0,0,b,nb,nw) call contio(nendf,0,0,b,nb,nw) call contio(nendf,0,0,b,nb,nw) if (n1h.ne.0) then iverf=4 else if (n2h.eq.0) then iverf=5 else iverf=6 endif nmt=0 nmt1=0 ign=1 iwt=6 iprint=1 irelco=1 read(nsysi,*) matd,ign,iwt,iprint,irelco call storag(namax,nidmax,ipr,a) tempin=0 mprint=0 if (ngout.eq.0) then tempin=300 read(nsysi,*) mprint,tempin endif call reserv('eni',nenimx,ie,a) write(nsyso,'(/, & '' unit for endf/b tape ................. '',i10,/, & '' unit for pendf tape .................. '',i10,/, & '' unit for input gendf tape ............ '',i10,/, & '' unit for output covariance tape ...... '',i10,/, & '' unit for input covariance tape ....... '',i10,/, & '' unit for ratio-to-standard tape ...... '',i10)') & nendf,npend,ngout,nout,nin,nstan write(nsyso,'( & '' material to be processed ............. '',i10,/, & '' neutron group option ................. '',i10,/, & '' print option (0 min, 1 max) .......... '',i10,/, & '' rel. cov. option (0 abs, 1 rel) ...... '',i10)') & matd,ign,iprint,irelco cej write(nsyso,'( & '' group averaging weight option ........ '',i10)') & iwt if (ngout.eq.0) write(nsyso,'( & '' group av. print option (0 min, 1 max) '',i10)') & mprint c if (ngout.eq.0.and.tempin.eq.0.) write(nsyso,'( & '' temperature .......................... '',6x,''zero'')') if (ngout.eq.0.and.tempin.ne.0.) write(nsyso,'( & '' temperature .......................... '',f10.0)') tempin if (iverf.ne.4) then iread=0 mfcov=33 cej irespr=1 legord=1 ifissp=-1 read(nsysi,*)iread,mfcov,irespr,legord,ifissp c if (iread.lt.0.or.iread.gt.2) then write(strng,'(''illegal iread='',i3)') iread call error('errorr',strng,' ') endif cej if (mfcov.eq.31.and.ngout.eq.0) then write(strng,'('' when mfcov=31, you should set ngout<>0'')') call error('errorr',strng,' ') endif if (mfcov.eq.35.and.ngout.eq.0) then write(strng,'('' when mfcov=35, you should set ngout<>0'')') call error('errorr',strng,' ') endif eskip1=1.00002 eskip2=1.0003 eskip3=1.005 if(mfcov.eq.-33)then eskip1=1.0002 eskip2=1.0003 eskip3=1.005 mfcov=33 endif if(mfcov.eq.333)then eskip1=1.002 eskip2=1.003 eskip3=1.005 mfcov=33 endif c write(nsyso,'( & '' read option (0 calc, 1 read, 2 combo) '',i10,/, & '' endf covariance file to be processed . '',i10)') & iread,mfcov c write(nsyso,19) irespr,legord,ifissp c if(mfcov.ne.31.and.mfcov.ne.33.and.mfcov.ne.34.and.mfcov.ne.35) & then write(strng,'(''not coded for mfcov='',i3)') mfcov call error('errorr',strng,' ') endif write(nsyso,'(/,'' using endf-'',i1,'' format'')') iverf endif c c ***read covariance reaction types from end/b dictionary c ***and set file 32 flag nscr2=0 nwi=17 call reserv('id',nwi,iid,a) nwi=-1 call reserv('dict',nwi,idict,a) call repoz(nendf) call tpidio (nendf,0,0,a(idict),nb,nw) call findf(matd,1,451,nendf) call contio(nendf,0,0,a(idict),nb,nw) nx=nint(a(idict+5)) if (iverf.gt.4) call contio(nendf,0,0,a(idict),nb,nw) if (iverf.gt.5) call contio(nendf,0,0,a(idict),nb,nw) call hdatio(nendf,0,0,a(idict),nb,nw) if (iverf.gt.4) nx=nint(a(idict+5)) do i=1,17 a(iid-1+i)=a(i+5+idict) enddo do while (nb.ne.0) call moreio(nendf,0,0,a(idict),nb,nw) enddo ndictm=6*nx call releas('dict',ndictm,a) nw=nx call dictio(nendf,0,0,a(idict),nb,nw) nmt=0 mf32=0 nga=0 nwi=200 c if (ngout.eq.0.or.mfcov.eq.34) call reserv('ga',nwi,iga,a) c nlump=0 nwl=nlmt*2 call reserv('lump',nwl,ilump,a) do 130 ix=1,nx l=idict+6*ix-4 mf=nint(a(l)) if (mf.eq.32) mf32=1 mt=nint(a(l+1)) if (mf.ne.mfcov) go to 130 if (mt.gt.850) go to 121 c if (ngout.ne.0.and.mfcov.ne.34) go to 125 c nga=nga+1 if (nmt.gt.nmtmax) & call error('errorr','too many reaction types.',' ') a(iga+nga-1)=mt go to 125 121 if (mt.gt.870) call error('errorr','illegal mt gt 870.',' ') nlump=nlump+1 a(ilump+2*(nlump-1))=mt a(ilump+2*(nlump-1)+1)=0 125 continue if (iverf.le.4) then nmt=nmt+1 if (nmt.gt.nmtmax) & call error('errorr','too many reaction types.',' ') nmt1=nmt mats(nmt)=0 mts(nmt)=mt endif 130 continue if (ngout.eq.0) call releas('ga',nga,a) nwl=nlump*2 call releas('lump',nwl,a) call releas('dict',0,a) if (iverf.gt.4) go to 200 c c ***set up coefficients for derived cross sections. read(nsysi,*)neki if (neki.gt.nkmax) then write(strng,'(''only'',i3,'' ek energies allowed'')') nkmax call error('errorr',strng,' ') endif write(nsyso,'( & '' no. of derived xsec energy ranges .... '',i10)') neki nek=neki if (neki.eq.0) nek=1 nmt2=nmt*nmt nw=nek*nmt2 call reserv('kxy',nw,ikxy,a) if (neki.gt.0) go to 150 ek(1)=small ek(2)=big do i=1,nmt do j=1,nmt ja=ikxy+j-1+nmt*(i-1) a(ja)=0 if (i.eq.j) a(ja)=1 enddo enddo go to 305 150 nek1=nek+1 read(nsysi,*) (ek(i),i=1,neki) do i=1,nek1 ek(i)=sigfig(ek(i),ndig,0) enddo do i=1,nek do j=1,nmt nw=nmt do k=1,nw z(k)=0 enddo ja=ikxy+nmt2*(i-1)+nmt*(j-1)-1 read(nsysi,*) (z(k),k=1,nw) do k=1,nmt a(k+ja)=z(k) enddo enddo enddo go to 280 200 if (iread.eq.2) go to 245 if (iread.eq.0) go to 260 c c ***read user-supplied mts and eks nek=0 read(nsysi,*) nmt,nek if (nmt.gt.nmtmax) & call error('errorr','too many reaction types.',' ') nmt1=nmt neki=nek if (nek.eq.0) nek=1 nek1=nek+1 write(nsyso,'( & '' no. of mts to be processed ........... '',i10)') nmt write(nsyso,'( & '' no. of derived xsec energy ranges .... '',i10)') nek nmt2=nmt*nmt nw=nek*nmt2 call reserv('kxy',nw,ikxy,a) nw=nmtmax call reserv('temp',nw,itemp,a) call findex('kxy',ikxy,a) read(nsysi,*) (a(itemp+i-1),i=1,nmt) do i=1,nmt mats(i)=0 mts(i)=nint(a(i-1+itemp)) enddo ek(1)=small ek(2)=big do j=1,nmt do k=1,nmt ja=ikxy+k-1+nmt*(j-1) a(ja)=0 if (j.eq.k) a(ja)=1 enddo enddo if (neki.eq.0) go to 215 read(nsysi,*) (ek(i),i=1,nek1) do i=1,nek1 ek(i)=sigfig(ek(i),ndig,0) enddo do i=1,nek do j=1,nmt ja=ikxy-1+nmt2*(i-1)+nmt*(j-1) read(nsysi,*) (a(ja+k),k=1,nmt) enddo enddo 215 continue call releas('temp',0,a) go to 260 c c ***read additional user-supplied mat1-mt1 pairs 245 continue 255 ii1=0 read(nsysi,*) ii1,ii2 if (ii1.eq.0) go to 260 nmt1=nmt1+1 mats(nmt1)=ii1 mts(nmt1)=ii2 go to 255 c c ***read input for redefining the standard 260 if (nstan.eq.0) go to 270 265 ii1=0 read(nsysi,*) ii1,ii2,ii3,ii4 if (ii1.eq.0.) go to 270 nas=nas+1 if (nas.gt.nasmax) & call error('errorr','too many standards redefined.',' ') matb(nas)=ii1 mtb(nas)=ii2 matc(nas)=ii3 mtc(nas)=ii4 go to 265 270 continue c call gridd(neki,a) if (nlump.gt.0) call lumpmt(a) if (iread.eq.1) go to 280 nmt2=nmt1*nmt1 if (neki.eq.0) go to 305 c c ***print the akxy array 280 continue write(nsyso,'(/,'' coefficients for derived cross sections'')') call findex('kxy',ikxy,a) lim=nmt if (nmt.gt.10) lim=10 do i=1,nek write(nsyso,'(/,'' for'',1p,e12.4,'' to '',e12.4,'' ev'',/)') & ek(i),ek(i+1) write(nsyso,'(3x,''mt -'',10(4x,i3))') (mts(ii),ii=1,lim) if (nmt.gt.lim) write(nsyso,'(7x,10i7)') (mts(ii),ii=11,nmt) write(nsyso,'('' --- -'',10(4x,a3))') ('---',ii=1,lim) do j=1,nmt ja=ikxy+nmt2*(i-1)+nmt1*(j-1)-1 write(nsyso,'(2x,i3,'' -'',10f7.1,/,(5x,'' -'',10f7.1))') & mts(j),(a(ja+k),k=1,nmt) enddo enddo 305 continue c c ***compute group constants on union grid, either from c ***pointwise input (npend) or fine-group input (ngout). ntape=-10 call openz(ntape,1) call egngpn(a) if (ngout.eq.0) then call grpav(mprint,tempin,a) else call colaps(a) endif cej 320 if (mfcov.eq.34) then if (iwt.eq.1.or.iwt.eq.4.or.iwt.eq.5.or.iwt.ge.7) & call releas('wght',0,a) call grpav4(mprint,a) endif c call findex('id',iid,a) write(nsyso,'(/, & '' processing mat '',i4,/, & '' ---------------------'',/, & 1x,17a4)') matd,(a(iid-1+i),i=1,17) write(nsyse,'(/, & '' processing mat '',i4,/, & '' ---------------------'',/, & 1x,17a4)') matd,(a(iid-1+i),i=1,17) call releas('id',0,a) c c ***compute covariance matrices ek(1)=sigfig(ek(1),ndig,0) if (abs(egn(1)-elo).le.eps) egn(1)=elo call covcal(a) c c ***write output tape. call covout(a) c c ***errorr is finished. call atend(nout,0) call repoz(nout) call repoz(nin) call repoz(nendf) call repoz(ngout) call repoz(npend) call repoz(nstan) call closz(nstan) call closz(nendf) call closz(npend) call closz(ngout) call closz(nin) call closz(nout) call usag(a) call timer(time) write(nsyso,'(69x,f8.1,''s'',/,1x,77(''*''))') time return c cej 19 format(' processing option for mf=32 .......... ',i10,/, & ' legendre order for mf=34 ............. ',i10,/, & ' energy range number for mf=35 ........ ',i10) c end c subroutine covcal(a) c ****************************************************************** c calculate absolute covariances in the union-group structure. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/util/npage,iverf common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/mode/imode common/mainio/nsysi,nsyso,nsyse,ntty common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/redef/nas,matb(5),mtb(5),matc(5),mtc(5) common/ety/ety1,ety2 cej common/eunits34/nscr4 common/err4/legord,irespr,ifissp c character*60 strng dimension a(*) dimension loc(30) data locm/30/, nmax/2000/ data small/1.d-10/ zero=0 c c ***initialize nscrg=13 if (ngout.lt.0) nscrg=-nscrg nscr=11*imode call openz(nscr,1) call openz(nscrg,1) call repoz(nscr) nmts=0 za=0 nw=npage+50 call reserv('b',nw,ib,a) nwi=1000 call reserv('egt',nwi,iegt,a) mfd=1 mtd=451 c ***skip over energy group bounds on ngout call rdgout(ngout,matd,mfd,mtd,a(ib),a(iegt)) if (mtd.gt.nmax) & call error('covcal','storage exceeded in egt.',' ') call releas('egt',0,a) c ***assign storage. call reserv('flx',nunion,iflx,a) call reserv('sig',nunion,isig,a) call reserv('cov',nunion,icov,a) call reserv('sig1',nunion,isig1,a) cej call reserv('alp1',nunion,ialp1,a) call reserv('alp2',nunion,ialp2,a) c call reserv('scr2',nunion,iscr2,a) namx=-1 call reserv('scr',namx,iscr,a) call findex('b',ib,a) jc=ib call findex('un',iun,a) call findex('flx',iflx,a) call findex('sig',isig,a) call findex('cov',icov,a) call findex('sig1',isig1,a) cej call findex('alp1',ialp1,a) call findex('alp2',ialp2,a) c if (nlump.gt.0) call findex('lump',ilump,a) if (nlump.gt.0) call findex('lmt',ilmt,a) mfd=3 mtd=-1 c ***store flux array for later use call rdgout(ngout,matd,mfd,mtd,a(ib),a(iflx)) nsc=0 call rdsig(matd,0,a(ib),a(iscr)) c c ***if the total cross section is absent, estimate the c ***fine-group fluxes in the sub-threshold energy region c ***by assuming dn/de is constant if (mtd.ne.-2) go to 130 dne=small do is=1,nunion isr=nunion+1-is flux=a(iflx+isr-1) de=a(iun+isr)-a(iun+isr-1) if (flux.ne.0.and.de.ne.0) then dne=flux/de else a(iflx-1+isr)=dne*de endif enddo mtd=-1 130 continue kmtb=0 c c ***loop over reactions in mfcov call findf(matd,mfcov,0,nendf) 140 call contio(nendf,0,0,a(iscr),nb,nw) if (mat.lt.1) go to 700 if (mat.ne.matd) go to 700 if (mt.eq.0) go to 140 if (mf.lt.mfcov) go to 140 if (mf.gt.mfcov) go to 700 c ***ignore components of a lumped reaction cej if (mfcov.eq.34) then nl=1 elseif (mfcov.eq.35) then nl=n1h elseif (iverf.eq.4) then nl=l2h elseif (iverf.gt.4) then nl=n2h endif c if (nl.eq.0) go to 140 if (iread.ne.1) go to 170 do 150 i=1,nmt if (mt.eq.mts(i)) go to 170 150 continue call tosend(nendf,0,0,a(iscr)) go to 140 170 if (za.eq.zero) then za=c1h awr=c2h endif nmts=nmts+1 if (mts(nmts).ne.mt) & call error('covcal', & 'mfcov mt found not equal to input mt.',' ') cej if (mfcov.eq.34) then call contio(nendf,0,0,a(iscr),nb,nw) mat2=l1h mt2=l2h nlg1=min(n1h,legord) nlg2=min(n2h,legord) nl=nlg1*(nlg2+1)/2 a(jc)=za a(jc+1)=awr a(jc+2)=nlg1 a(jc+3)=nlg2 a(jc+4)=nl a(jc+5)=nunion nl=n1h*(n2h+1)/2 else a(jc)=za a(jc+1)=awr a(jc+2)=0 a(jc+3)=nl a(jc+4)=0 a(jc+5)=nunion endif c call contio(0,0,nscr,a(jc),nb,nw) mtl=mt if (mt.gt.850) go to 190 c ***find sigma for this mt on ngout cej if (mfcov.eq.35) then call rdchi(mat,a(ib),a(isig)) else call rdsig(mat,mt,a(ib),a(isig)) endif c go to 200 190 call lumpxs(mtl,mtl,a) c c ***loop over different covariance matrices for this reaction 200 do 650 il=1,nl cej if (mfcov.eq.35) then mat1=0 mt1=mt nc=0 ni=1 go to 205 else call contio(nendf,0,0,a(iscr),nb,nw) endif if (mfcov.eq.34.and.mt.eq.0) go to 660 if (mfcov.eq.34) then mat1=mat2 mt1=mt2 ld=l1h ld1=l2h else mat1=l1h mt1=l2h endif c if (mt1.eq.0) call error('covcal','illegal mt1=0.',' ') nc=n1h ni=n2h cej 205 continue if (ni.gt.locm) & call error('covcal','storage exceeded in loc.',' ') iok=1 do 210 i=1,nmt1 kmt1=i if (mt1.eq.mts(i).and.mat1.eq.mats(i)) go to 220 210 continue c ***covariance matrix for mat1-mt1 is present in mfcov, but is c ***not wanted by user. flag this by setting iok=0, and later c ***write a null matrix on the output file. iok=0 c c ***if necessary, redefine mat1 and mt1 220 if (nas.eq.0) go to 230 if (mat1.ne.-matb(1).or.mt1.ne.-mtb(1)) go to 230 if (iok.eq.0) then write(strng, & '(''must request mat1='',i3,'' and mt1='',i3)') mat1,mt1 call error('covcal',strng,'on card 10.') endif mat1=matc(1) mt1=mtc(1) kmtb=kmt1 c c ***read in all sub-subsections for this matrix. 230 li=0 l=1 if (nc.eq.0) go to 280 lty=0 do ic=1,nc if (iverf.gt.4) call contio(nendf,0,0,a(iscr+l-1),nb,nw) if (iverf.gt.4) lty=l2h call listio(nendf,0,0,a(iscr+l-1),nb,nw) do while (nb.ne.0) call moreio(nendf,0,0,a(iscr+l-1),nb,nw) enddo if (iok.ne.0) then cej if (mfcov.eq.34) then if (ld.gt.legord.or.ld1.gt.legord) goto 270 endif if (lty.gt.0.and.lty.lt.4) call stand(li,l,loc,lty,a) endif cej 270 continue enddo 280 if (ni.eq.0.and.li.eq.0) go to 600 if (ni.gt.0) go to 285 ni=li go to 320 285 ltyi=0 ni=ni+li 290 li=li+1 loc(li)=iscr+l-1 call listio(nendf,0,0,a(iscr+l-1),nb,nw) np=n1h if (l2h.eq.6) a(iscr+l+1)=(n1h-1)/n2h a(iscr+l+3)=ltyi l=l+nw do while (nb.ne.0) if (l.gt.namx) call error('covcal', & 'storage exceeded in a.',' ') call moreio(nendf,0,0,a(iscr+l-1),nb,nw) l=l+nw enddo locli=loc(li)+5 do i=1,np a(i+locli)=sigfig(a(i+locli),ndig,0) enddo if (li.lt.ni) go to 290 320 if (iok.eq.0) go to 600 cej if (mfcov.eq.34) then if (ld.gt.legord.or.ld1.gt.legord) go to 650 endif c c ***retrieve sigma for mt1, either from ngout or a(isig). if (kmt1.ne.nmts) then if (mt1.lt.851) call rdsig(mat1,mt1,a(ib),a(isig1)) if (mt1.gt.850) call lumpxs(mt1,mtl,a) else do jg=1,nunion a(jg-1+isig1)=a(jg-1+isig) enddo endif cej if (mfcov.eq.34) then call rdlgnd(nscr4,matd,mt,ld,a(ib),a(ialp1)) call rdlgnd(nscr4,matd,mt1,ld1,a(ib),a(ialp2)) endif c c ***generate covariance matrix using specified laws. do 570 jg=1,nunion eg=a(iun+jg-1) do 520 jh=1,nunion eh=a(iun+jh-1) a(icov+jh-1)=0. do 510 i=1,ni loci=loc(i) lt=nint(a(loci+2)) lb=nint(a(loci+3)) ltyi=nint(a(loci+4)) np=nint(a(loci+5)) cej if (mfcov.eq.34.and. & (lb.lt.0.or.lb.eq.3.or.lb.eq.4.or.lb.eq.7.or. & lb.gt.8)) then write(strng,'(''unpermitted for lb='',i2)') lb call error('covcal',strng,'in mf=34.') elseif (mfcov.eq.35.and.lb.ne.7) then write(strng,'("unpermitted for lb=",i2)') lb call error('covcal',strng,'in mf=35.') endif c if (ltyi.eq.0) go to 345 if (ltyi.lt.1.or.ltyi.gt.3.or. & a(loci).le.0..or.a(loci+1).le.a(loci)) & call error('covcal','data in a(loci) is illegal.', & ' ') if (ltyi.eq.3) go to 340 c ***for lty = 1 and 2, apply energy window to mt groups if (eg.lt.a(loci).or.eg.ge.a(loci+1)) go to 510 if (ltyi.eq.2) go to 345 c ***for lty = 1 and 3, apply energy window to mt1 groups 340 if (eh.lt.a(loci).or.eh.ge.a(loci+1)) go to 510 go to 346 c ***if necessary, apply ety energy window to mt1 groups 345 if (nas.eq.0) go to 346 if (matb(1).ge.0) go to 346 if (mat1.ne.matc(1).or.mt1.ne.mtc(1)) go to 346 if (eh.lt.ety1.or.eh.ge.ety2) go to 510 346 if (lb.eq.7.or.lb.gt.8) then if (mfcov.eq.35.and.lb.eq.7) go to 347 write(strng,'(''not coded for lb='',i2)') lb call error('covcal',strng,' ') endif if (lb.lt.3.and.lt.gt.0) then write(strng,'(''lb='',i2,'' when lt='',i2)') lb,lt call error('covcal',strng,' ') endif 347 continue locip4=loci+4 locip6=loci+6 nk1=np-1 if (lb.ne.8) go to 880 c c ***separate treatment for lb=8 if (jh.ne.jg) go to 510 k=0 860 k=k+1 k2=k*2 if (eg.ge.a(locip4+k2).and.eg.lt.a(locip6+k2)) & go to 870 if (k.lt.nk1) go to 860 go to 510 c ***assume flux is constant within a union group 870 xcv=(a(locip6+k2)-a(locip4+k2))/ & (a(iun+jg)-a(iun+jg-1)) a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*xcv go to 510 cej 880 if (lb.ne.7) go to 800 c c ***separate treatment for lb=7 (mf=35) k=0 890 k=k+1 if (eg.ge.a(locip6+k-1).and.eg.lt.a(locip6+k)) & go to 900 if (k.lt.nk1) go to 890 go to 510 900 l=0 910 l=l+1 if (eh.ge.a(locip6+l-1).and.eh.lt.a(locip6+l)) & go to 920 if (l.lt.nk1) go to 910 go to 510 920 if (l.ge.k) then ifloc=locip6+nk1*np/2-(np-k+1)*(np-k)/2+l-k else ifloc=locip6+nk1*np/2-(np-l+1)*(np-l)/2+k-l endif a(icov+jh-1)=a(icov+jh-1)+a(ifloc+np) go to 510 800 if (lb.ne.6) go to 850 c c ***separate treatment for lb=6 k=0 810 k=k+1 if (eg.ge.a(locip6+k-1).and.eg.lt.a(locip6+k)) & go to 820 if (k.lt.nk1) go to 810 go to 510 820 locnec=locip6+np nl1=lt-1 l=0 830 l=l+1 if (eh.ge.a(locnec+l-1).and.eh.lt.a(locnec+l)) & go to 840 if (l.lt.nl1) go to 830 go to 510 840 ifloc=locnec+lt+(k-1)*nl1+l-1 cej if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(ifloc)*a(ialp1+jg-1)* & a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(ifloc)*a(isig+jg-1)* & a(isig1+jh-1) endif c go to 510 850 if (lb.ne.5) go to 410 c c ***separate treatment for lb=5. k=0 350 k=k+1 if (eg.ge.a(locip6+k-1).and.eg.lt.a(locip6+k)) & go to 360 if (k.lt.nk1) go to 350 go to 510 360 l=0 370 l=l+1 if (eh.ge.a(locip6+l-1).and.eh.lt.a(locip6+l)) & go to 380 if (l.lt.nk1) go to 370 go to 510 380 if (lt.eq.1) go to 390 ifloc=locip6+(k-1)*nk1+l-1 go to 400 390 ifloc=locip6+nk1*np/2-(np-l+1)*(np-l)/2+k-l if(l.ge.k)ifloc=locip6+nk1*np/2-(np-k+1)*(np-k)/2+l-k cej 400 if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(ifloc+np)*a(ialp1+jg-1) & *a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(ifloc+np)*a(isig+jg-1) & *a(isig1+jh-1) endif c go to 510 c c ***integrated treatment for lb=0 thru lb=4. 410 continue nlt=lt nk=np-nlt nk1=nk-1 nlt1=nlt-1 k=0 420 k=k+1 k2=k*2 if (eg.lt.a(locip4+k2).or.eg.ge.a(locip6+k2)) & go to 430 if (lb.eq.2.or.lb.eq.3) go to 440 if (eh.ge.a(locip4+k2).and.eh.lt.a(locip6+k2)) & go to 490 go to 510 430 if (k.lt.nk1) go to 420 go to 510 440 if (lb.gt.2) go to 450 locl=loci lend=nk1 go to 460 450 locl=loci+nk*2 lend=nlt1 460 loclp4=locl+4 loclp6=locl+6 l=0 470 l=l+1 l2=l*2 if (eh.ge.a(loclp4+l2).and.eh.lt.a(loclp6+l2)) & go to 480 if (l.lt.lend) go to 470 go to 510 480 if (lb.ne.4) go to 486 m=0 482 m=m+1 m2=m*2 if (eg.ge.a(loclp4+m2).and.eh.lt.a(loclp6+m2)) & go to 484 if (m.lt.lend) go to 482 go to 510 cej 484 if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(locl+5+m2) & *a(locl+5+l2)*a(ialp1+jg-1)*a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(locl+5+m2) & *a(locl+5+l2)*a(isig+jg-1)*a(isig1+jh-1) endif c go to 510 cej 486 if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(locl+5+l2) & *a(ialp1+jg-1)*a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(locl+5+l2) & *a(isig+jg-1)*a(isig1+jh-1) endif c go to 510 490 if (lb.eq.4) go to 450 if (lb.eq.0) go to 500 cej if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)* & a(ialp1+jg-1)*a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(isig+jg-1) & *a(isig1+jh-1) endif c go to 510 500 a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2) 510 continue 520 continue c c ***write one row of the covariance matrix on scratch tape. jgend=0 do ih=1,nunion if (a(icov+ih-1).ne.zero) jgend=ih enddo if (jgend.gt.0) go to 540 if (jg.lt.nunion) go to 570 jgend=1 540 mf=mfcov mat=matd mt=mts(nmts) cej if (mfcov.eq.34) then a(jc)=ld a(jc+1)=ld1 else a(jc)=0 a(jc+1)=0 endif c a(jc+2)=mat1 a(jc+3)=mt1 a(jc+4)=jgend a(jc+5)=jg ibase=6 ic=ibase do ij=1,jgend ic=ic+1 cej if (mfcov.eq.34) then a(jc+ic-1)=a(icov+ij-1)*(a(isig+jg-1)*a(iflx+jg-1)) & *(a(isig1+ij-1)*a(iflx+ij-1)) else a(jc+ic-1)=a(icov+ij-1)*a(iflx+jg-1)*a(iflx+ij-1) endif c if ((ic-ibase).ge.npage.or.ij.eq.jgend) then if (ibase.ne.0) then call listio(0,0,nscr,a(jc),nb,ic) ibase=0 ic=0 else call moreio(0,0,nscr,a(jc),nb,ic) ic=0 endif endif enddo 570 continue go to 650 c c ***write a null covariance matrix on scratch tape. 600 mt=mts(nmts) mat=matd mf=mfcov a(jc)=0 a(jc+1)=0 a(jc+2)=mat1 a(jc+3)=mt1 a(jc+4)=1 a(jc+5)=nunion a(jc+6)=0 nw=7 call listio(0,0,nscr,a(jc),nb,nw) c c ***close loop over subsections of mfcov 650 continue cej 660 continue call asend(0,nscr) c c ***close loop over sections of mfcov go to 140 700 continue c ***if necessary, redefine one mats(i)-mts(i) pair if (kmtb.gt.0) then mats(kmtb)=matc(1) mts(kmtb)=mtc(1) endif c c ***covcal is finished call afend(0,nscr) call amend(0,nscr) call atend(0,nscr) call timer(time) write(nsyso,'(/, & '' covariances calculated for '',i2,'' reactions and '', & i3,'' groups'',14x,f8.1,''s'')') nmts,nunion,time write(nsyse,'(/, & '' covariances calculated for '',i2,'' reactions and '', & i3,'' groups'',14x,f8.1,''s'')') nmts,nunion,time call releas('sig1',-1,a) return end c subroutine covout(a) c ****************************************************************** c compute output covariances for all requested reactions (whether c evaluated or derived) in the user-specified group structure. c output covariances are listed and/or written to a gendf tape. c c input union-group absolute covariances are read from unit nscr c (see subroutine covcal). any non-zero input covariances for c derived cross sections are ignored. coefficients relating c derived and evaluated data reside in core at location a(ikxy). c fine-group energy bounds (iun), fluxes (iflx), and cross sections c (isig) also reside in core. except for the trivial derivation case c where both reactions ix and ixp are evaluated (isd=1), the entire c nscr tape is read and a contribution to the output covariance is c computed for each input reaction-pair. c c ix,ixp = reaction indices (see array mts) of output reaction- c pair (max. values = nmt,nmts) c ig,igp = group indices of output reaction-pair (max. value = c ngn) c iy,iyp = reaction indices of current input reaction-pair (max. c values = nmt,nmts) c jg,jgp = group indices of current input reaction-pair (max. c value = nunion) c c ***************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/mode/imode common/mainio/nsysi,nsyso,nsyse,ntty common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/grpn/ign,ngn,egn(901),iprint common/ewght/iwt cej common/err3/ifresr,ifunrs common/err4/legord,irespr,ifissp c dimension a(*) character strng*60 data eps/1.d-20/ data zero/0.d0/ c c ***allocate storage. nmts=nmt1 nmt2=nmts*nmts c ***foru-233 endf-7 nwds=8000000 nngn=ngn*(ngn+1)/2 ngn2=ngn*ngn c call reserv('scr',nwds,iscr,a) call reserv('cff',nngn,icff,a) call reserv('cfg',ngn2,icfg,a) call reserv('cgg',nngn,icgg,a) cej call reserv('cee',nngn,icee,a) call reserv('cef',ngn2,icef,a) call reserv('ceg',ngn2,iceg,a) call reserv('ctt',nngn,ictt,a) call reserv('ufg',ngn2,iufg,a) call reserv('uef',ngn2,iufg,a) call reserv('ueg',ngn2,iufg,a) call reserv('uff',nngn,iuff,a) call reserv('ugg',nngn,iugg,a) call reserv('uee',nngn,iuee,a) call reserv('utt',nngn,iutt,a) c call reserv('cflx',ngn*2,icflx,a) call reserv('sg',nunion,isg,a) cej if (mfcov.eq.34) then call reserv('xmu',ngn,ixmu,a) endif if (nlump.gt.0) then call reserv('lmt1',nmtmax,ilmt1,a) call reserv('lmt2',nmtmax,ilmt2,a) endif call reserv('alp',nunion,ialp,a) c nsumx=-1 call reserv('sum',nsumx,isum,a) cej if (nsumx.lt.max(ngn*nmt1,ngn*2)) & call error('covout','storage exceeded in sum.',' ') call findex('un',iun,a) call findex('flx',iflx,a) call findex('scr',iscr,a) call findex('sum',isum,a) call findex('cflx',icflx,a) call findex('sig',isig,a) do i=1,nsumx a(i-1+isum)=0 enddo cej if (nlump.gt.0) then call findex('lump',ilump,a) call findex('lmt',ilmt,a) call findex('lmt1',ilmt1,a) call findex('lmt2',ilmt2,a) do i=1,nmtmax a(ilmt1+i-1)=0 a(ilmt2+i-1)=0 enddo k=0 do i=1,nlump mtl=nint(a(ilump+2*(i-1))) n=nint(a(ilump+2*(i-1)+1)) loc=ilmt+nlmt*(i-1)-1 do j=1,n k=k+1 mtd=nint(a(loc+j)) a(ilmt1+k-1)=mtd a(ilmt2+k-1)=mtl enddo enddo lmtold=nint(a(ilmt1)) nmtold=0 a(ilmt1+k)=1000. else lmtold=1000 endif c c c ***position new gout tape (if any) for output. call repoz(nscr) if (nout.eq.0) go to 120 call repoz(nout) call repoz(ngout) nsh=0 call repoz(nin) ntape=nin if (nin.eq.0) ntape=ngout c ***write a tape id on nout call tpidio(ntape,0,0,a(iscr),nb,nw) mat=1 mf=0 mt=0 call tpidio(0,nout,0,a(iscr),nb,nw) if (nin.eq.0) go to 120 c ***copy input covariance tape to nout call contio(nin,nout,0,a(iscr),nb,nw) 110 call tomend(nin,nout,0,a(iscr)) call contio(nin,0,0,a(iscr),nb,nw) if (mat.eq.-1) go to 120 call contio(0,nout,0,a(iscr),nb,nw) go to 110 c c ***compute coarse-group cross sections. cej 120 ngnp1=ngn+1 if (mfcov.eq.31.or.mfcov.eq.33) then call sigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx),a(isig)) if (irespr.eq.0) then call resprp(nwds,a) elseif (irespr.eq.1) then call resprx(nwds,a) endif elseif (mfcov.eq.34) then call musigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx), & a(isig),a(ialp)) call findex('xmu',ixmu,a) do ijk = 1 , ngn a(ixmu+ijk-1) = a(isum+ijk-1) enddo elseif (mfcov.eq.35) then call fssigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx), & a(isig)) endif if (iwt.eq.1.or.iwt.eq.4.or.iwt.eq.5.or.iwt.ge.7) & call releas('wght',0,a) c nwds=2*npage+50 if (nwds.lt.ngn+6) nwds=ngn+6 call releas('scr',nwds,a) c ***pack storage npack=-1 call reserv('pack',npack,ipack,a) call releas('pack',0,a) nsumx=nsumx+npack call findex('sum',isum,a) call findex('cflx',icflx,a) call findex('scr',iscr,a) call findex('un',iun,a) call findex('flx',iflx,a) call findex('sig',isig,a) call findex('kxy',ikxy,a) call findex('cov',icov,a) cej if (nlump.gt.0) then call findex('lmt1',ilmt1,a) call findex('lmt2',ilmt2,a) endif if (mf32.ne.0.and.mfcov.eq.33) then call findex('cff',icff,a) call findex('cfg',icfg,a) call findex('cgg',icgg,a) call findex('cee',icee,a) call findex('cef',icef,a) call findex('ceg',iceg,a) call findex('ctt',ictt,a) call findex('uff',iuff,a) call findex('ufg',iufg,a) call findex('ugg',iugg,a) call findex('uee',iuee,a) call findex('uef',iuef,a) call findex('ueg',iueg,a) call findex('utt',iutt,a) endif call findex('alp',ialp,a) c isuma=isum cej if (irelco.eq.1) then if (mfcov.eq.34) then isuma=isum+ngn*2 nsumx=nsumx-ngn*2 else isuma=isum+ngn*nmts nsumx=nsumx-ngn*nmts endif endif c c ***determine whether all coarse groups will fit in core irange=ngn if ((ngn*ngn).gt.nsumx) irange=nsumx/ngn c c ***make a second copy of the fine-group covariance scratch tape nscr2=12*imode call openz(nscr2,1) call repoz(nscr) call repoz(nscr2) nsc=0 call totend(nscr,0,nscr2,a(iscr)) call repoz(nscr) call repoz(nscr2) c c ***loop over all reactions c ***if full matrix will not fit in core, c ***process by ranges of first group index. do 170 ix=1,nmt iabort=0 cej mtd=mts(ix) c c ***write the head record for this section on nout mat=matd mf=mfcov if (mf.eq.31) mf=33 cej if (nlump.gt.0.and.lmtold.lt.mts(ix)) then 175 mt=lmtold a(iscr)=za a(iscr+1)=awr a(iscr+2)=0. a(iscr+3)=a(ilmt2+nmtold) a(iscr+4)=0. a(iscr+5)=0. call contio(0,nout,0,a(iscr),nb,nw) call asend(nout,0) nmtold=nmtold+1 lmtold=nint(a(ilmt1+nmtold)) if (lmtold.lt.mts(ix)) go to 175 endif c mt=mts(ix) a(iscr)=za a(iscr+1)=awr a(iscr+2)=0 a(iscr+3)=0 a(iscr+4)=0 a(iscr+5)=nmts-ix+1 cej if (mfcov.eq.34) then mt=251 a(iscr+3)=irelco a(iscr+4)=legord a(iscr+5)=legord endif c call contio(0,nout,0,a(iscr),nb,nw) do 180 ixp=ix,nmts izero=0 igmin=1 igmax=irange c c ***check for the trivial derivation case where both ix and ixp c ***are directly evaluated. if it is, set isd=1. isd=0 if (iabort.eq.1) go to 185 if (irange.ne.ngn) go to 185 do 182 k=1,nek if (a(ikxy+(k-1)*nmt2+nmts*(ix-1)+ix-1).eq.0.) & go to 185 if (a(ikxy+(k-1)*nmt2+nmts*(ixp-1)+ixp-1).eq.0.) & go to 185 182 continue isd=1 185 continue nscr=(11+isd)*imode if (isd.ne.1) call repoz(nscr) do i=1,nsumx a(i-1+isuma)=0 enddo c c ***accumulate contributions to this matrix c ***and this range of coarse groups c ***from all matrices and fine groups on tape. 200 continue if (isd.eq.1) then if (ix.ne.ixp) go to 210 endif call contio(nscr,0,0,a(iscr),nb,nw) if (mf.eq.0) go to 390 if (mt.eq.0) go to 200 cej if (mfcov.eq.34) then nlg1=l1h nlg2=l2h nmt1h=n1h else nmt1h=l2h endif c if (isd.ne.1) go to 205 cej nmt1d=nmt1h nmd=0 if (mt.eq.mts(ix)) go to 205 c ***skip empty covariance matrices for the derived mts call tosend(nscr,0,0,a(iscr)) go to 200 205 continue mt1lst=1000 mt1old=mt1lst nm=0 cej if (mfcov.eq.34) then ldlst=-1 ldold=-1 endif c 210 continue if (isd.eq.1) then if (nmd.ge.nmt1d) go to 390 endif 220 call listio(nscr,0,0,a(iscr),nb,nwds) cej if (mfcov.eq.35) then if (ifissp-1.ne.nm) then jg=n2h go to 380 endif endif c mat1=l1h mt1=l2h mta=mt1+1000*mat1 cej if (mfcov.eq.34) then if (mt.eq.0) go to 180 ld=nint(c1h) ld1=nint(c2h) ld0=ld*100+ld1 if (ld0.ne.ldlst) k=1 if (isd.ne.1) go to 225 if (ld0.ne.ldlst) nmd=nmd+1 if (mt1.eq.mts(ixp).and.mat1.eq.mats(ixp)) go to 225 write(strng,'(''ld='',i3,'' ld1='',i3,'' mt1='',i3)') & ld,ld1,mt1 call error('covout','illegal condition for sad.',strng) endif c if (mta.ne.mt1lst) k=1 if (isd.ne.1) go to 225 if (mta.ne.mt1lst) nmd=nmd+1 if (mt1.eq.mts(ixp).and.mat1.eq.mats(ixp)) go to 225 c ***skip empty covariance matrices for the derived and c ***non-requested mt1-s if (nmd.lt.nmt1d) go to 220 c c ***desired mt1 missing. write empty matrix and abort c ***speed-up logic for this mt. iabort=1 go to 390 225 continue cej if (mfcov.eq.34) then if (ld0.ne.ldlst) nm=nm+1 ldlst=ld0 elseif (mfcov.ne.35) then if (mta.ne.mt1lst) nm=nm+1 endif c mt1lst=mta nw=n1h jg=n2h if (nw.eq.1.and.a(iscr+6).eq.0.) go to 380 c ***index first coarse group egtjg=a(iun+jg-1) do 230 i=1,ngn ig=i if (egtjg.ge.egn(i).and.egtjg.lt.egn(i+1)) go to 240 230 continue c ***read in rest of data for this group 240 ibase=6 ia=0 do i=1,nw ia=ia+1 a(icov+i-1)=a(iscr+ibase+ia-1) if (nb.gt.0.and.ibase+ia.ge.nwds) then call moreio(nscr,0,0,a(iscr),nb,nwds) ibase=0 ia=0 endif enddo if (egtjg.ge.egn(ngn+1)) go to 380 c ***index reactions if (mfcov.eq.34) then if (ld0.eq.ldold) go to 280 else if (mta.eq.mt1old) go to 280 endif iy=0 do i=1,nmt if (mt.eq.mts(i)) iy=i enddo iyp=0 do i=1,nmts if (mt1.eq.mts(i).and.mat1.eq.mats(i)) iyp=i enddo if (iy.eq.0.or.iyp.eq.0) & call error('covout', & 'unable to find iy or iyp from mts array.',' ') mt1old=mta cej if (mfcov.eq.34) ldold=ld0 c ***index derived energy range for jg 280 if (egtjg.ge.ek(k).and.egtjg.lt.ek(k+1)) go to 300 if (k.eq.nek) go to 380 k=k+1 go to 280 300 igp=1 kp=1 do 310 jgp=1,nw if (a(icov+jgp-1).eq.0.) go to 310 egtjgp=a(iun+jgp-1) c ***index derived energy range for jgp 320 if (egtjgp.ge.ek(kp).and.egtjgp.lt.ek(kp+1)) go to 330 if (kp.eq.nek) go to 310 kp=kp+1 go to 320 c ***index second coarse group 330 if (egtjgp.ge.egn(igp).and.egtjgp.lt.egn(igp+1)) & go to 350 if (igp.eq.ngn) go to 310 igp=igp+1 go to 330 c ***add this contribution 350 if (iyp.ne.iy) go to 360 if (ig.lt.igmin.or.ig.gt.igmax) go to 310 ipos=ngn*(ig-igmin)+igp a(isuma+ipos-1)=a(isuma+ipos-1)+ & a(ikxy+nmt2*(k-1)+nmts*(ix-1)+iy-1)* & a(ikxy+nmt2*(kp-1)+nmts*(ixp-1)+iyp-1)* & a(icov+jgp-1) if (a(isuma+ipos-1).ne.0.) izero=1 go to 310 360 if (ig.lt.igmin.or.ig.gt.igmax) go to 370 ipos=ngn*(ig-igmin)+igp a(isuma+ipos-1)=a(isuma+ipos-1)+ & a(ikxy+nmt2*(k-1)+nmts*(ix-1)+iy-1)* & a(ikxy+nmt2*(kp-1)+nmts*(ixp-1)+iyp-1)* & a(icov+jgp-1) if (a(isuma+ipos-1).ne.0.) izero=1 370 if (igp.lt.igmin.or.igp.gt.igmax) go to 310 ipos=ngn*(igp-igmin)+ig a(isuma+ipos-1)=a(isuma+ipos-1)+ & a(ikxy+nmt2*(k-1)+nmts*(ix-1)+iyp-1)* & a(ikxy+nmt2*(kp-1)+nmts*(ixp-1)+iy-1)* & a(icov+jgp-1) if (a(isuma+ipos-1).ne.0.) izero=1 310 continue c ***close loops over groups and covariance matrices. 380 if (jg.lt.nunion) go to 220 cej if (mfcov.eq.35) then nm=nm+1 if (nm.eq.ifissp) go to 390 go to 383 endif c if (isd.ne.1) go to 385 if (izero.eq.0) go to 390 if (ix.ne.iy.or.ixp.ne.iyp) call error('covout', & 'unexpectedly, ix ne iy or ixp ne iyp.',' ') c ***in the trivial derivation case, terminate loops over mt and mt1 cej 383 if (nmt1h.gt.1.and.nm.lt.nmt1h) go to 220 go to 390 385 continue cej if (mfcov.eq.34) call error('covout','please check isd=1', & ' ') if (nm.lt.nmt1h) go to 220 go to 200 390 continue cej if (mfcov.eq.34.or.mfcov.eq.35) go to 395 c c ***add contribution from resonance-parameter uncertainty call rescon(ix,ixp,igmin,igmax,isuma,izero,a) cej 395 continue c c ***write out covariance matrix elements for this c ***range of coarse groups. mat=matd mf=mfcov if (mf.eq.31) mf=33 mt=mts(ix) if (igmin.gt.1) go to 420 a(iscr)=0 a(iscr+1)=0 c a(iscr+2)=mats(ixp) if (mats(ixp).eq.0) then a(iscr+2)=mat else a(iscr+2)=mats(ixp) endif a(iscr+3)=mts(ixp) a(iscr+4)=0 a(iscr+5)=ngn cej if (mfcov.eq.34) then mt=251 a(iscr+2)=mt a(iscr+3)=ld a(iscr+4)=ld1 endif c nwds=6 call contio(0,nout,0,a(iscr),nb,nwds) call timer(time) if (mats(ixp).eq.0) then c if(irelco.eq.0)write(nsyso,40) mt,mats(ixp),mts(ixp),time c if(irelco.eq.1)write(nsyso,45) mt,mats(ixp),mts(ixp),time if(irelco.eq.0)write(nsyso,40) mt,mat,mts(ixp),time if(irelco.eq.1)write(nsyso,45) mt,mat,mts(ixp),time else if (mfcov.eq.31.or.mfcov.eq.33.or.mfcov.eq.35) then if (irelco.eq.0) write(nsyso,30) mt,mts(ixp),time if (irelco.eq.1) write(nsyso,35) mt,mts(ixp),time elseif (mfcov.eq.34) then if (irelco.eq.0) write(nsyso,31) mts(ix),mts(ixp),time & ,251,25 if (irelco.eq.1) write(nsyso,36) mts(ix),mts(ixp),time & ,251,25 endif endif if (mfcov.eq.34) write(nsyso,50) ld,ld1 if (igmax.lt.ngn) izero=1 if (iprint.ne.0) then if (izero.eq.1) write(nsyso,20) if (izero.eq.0) write(nsyso,25) endif 420 if (mfcov.eq.34) then call alsigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx), & a(isig),a(ialp),ld,ld1,mtd,mt1) mt=251 endif c do 430 ig=igmin,igmax ig2lo=0 ng2=0 ip=0 ibase=6 do 440 igp=1,ngn ip=ip+1 ipos=ngn*(ig-igmin)+igp c ***calculate absolute covariances if (mfcov.eq.34) then a(iscr+ibase+ip-1)=a(isuma+ipos-1)/(a(icflx+ig-1)* & a(icflx+ngn+igp-1)) else a(iscr+ibase+ip-1)=a(isuma+ipos-1)/(a(icflx+ig-1)* & a(icflx+igp-1)) endif if (a(iscr+ibase+ip-1).eq.0) go to 425 if (irelco.eq.0) go to 425 c ***calculate relative covariances if (mfcov.eq.34) then call findex('xmu',ixmu,a) denom=a(ixmu+igp-1)*a(ixmu+ig-1) else denom=a(isum+ngn*(ix-1)+ig-1)* & a(isum+ngn*(ixp-1)+igp-1) endif if (denom.eq.zero) denom=eps if (mfcov.eq.35) then a(iscr+ibase+ip-1)=a(iscr+ibase+ip-1)/denom* & (egn(ig+1)-egn(ig))*(egn(igp+1)-egn(igp)) else a(iscr+ibase+ip-1)=a(iscr+ibase+ip-1)/denom endif 425 if (abs(a(iscr+ibase+ip-1)).le.eps) then if (ig2lo.eq.0) ip=ip-1 else if (ig2lo.eq.0) ig2lo=igp ng2=igp endif 440 continue if (ng2.eq.0.and.ig.lt.ngn) go to 430 if (ng2.eq.0) ig2lo=ig if (ng2.eq.0) ng2=ig a(iscr)=0 a(iscr+1)=0 a(iscr+2)=ng2-ig2lo+1 a(iscr+3)=ig2lo a(iscr+4)=ng2-ig2lo+1 a(iscr+5)=ig ip=ng2-ig2lo+1 istart=iscr if (mfcov.eq.34) mf=mfcov call listio(0,nout,0,a(istart),nb,nw) do while (nb.ne.0) istart=istart+nw call moreio(0,nout,0,a(istart),nb,nw) enddo if (izero.eq.0) go to 430 if (iprint.eq.0) go to 430 ibase=6 nw=ip 460 nc=nw if (nc.gt.6) nc=6 write(nsyso,'(i4,i6,1p,6e11.3)') & ig,ig2lo,(a(iscr+ibase+i-1),i=1,nc) ibase=ibase+nc ig2lo=ig2lo+nc nw=nw-nc if (nw.gt.0) go to 460 430 continue c cej c ***write out diagonal covariance matrix elements of resonance c ***parameters. if (mfcov.eq.33.and.mf32.ne.0) then itp=0 irpc=0 iupc=0 if (mt.eq.18) then if(mts(ixp).eq.18) then itp=1 irpc=icff iupc=iuff else if(mts(ixp).eq.102) then itp=1 irpc=icfg iupc=iufg endif else if (mt.eq.102.and.mts(ixp).eq.102) then itp=1 irpc=icgg iupc=iugg else if (mt.eq.2) then if (mts(ixp).eq.2) then itp=1 irpc=icee iupc=iuee else if (mts(ixp).eq.18) then itp=1 irpc=icef else if (mts(ixp).eq.102) then itp=1 irpc=iceg endif else if(mt.eq.1.and.mts(ixp).eq.1) then itp=1 irpc=ictt iupc=iutt endif if (itp.eq.0) go to 590 do ig1=igmin,igmax ig2=igmax*(ig1-1)-(ig1-1)*(ig1-2)/2+1 if (a(irpc+ig2-1).gt.0) go to 510 if (ifunrs.gt.0.and.iupc.gt.0) then if ((iupc+ig2-1).gt.0) then if (a(iupc+ig2-1).gt.0.) go to 510 endif endif enddo go to 590 510 continue if (ifresr.gt.0.and.(ifunrs.gt.0.and.iupc.gt.0)) then write(nsyso,62) elseif (ifresr.gt.0) then write(nsyso,60) elseif (ifunrs.gt.0.and.iupc.gt.0) then write(nsyso,63) endif jscr=iscr+ngn do i=1,ngn a(iscr+i-1)=0 a(jscr+i-1)=0 enddo do ig=ig1,igmax ig2=igmax*(ig-1)-(ig-1)*(ig-2)/2+1 a(iscr+ig-1)=a(irpc+ig2-1)/a(icflx+ig-1)**2 enddo if (ifunrs.gt.0.and.iupc.gt.0) then do ig=ig1,igmax ig2=igmax*(ig-1)-(ig-1)*(ig-2)/2+1 a(jscr+ig-1)=a(iupc+ig2-1)/a(icflx+ig-1)**2 enddo endif if (irelco.eq.1) then do ig=ig1,igmax a(iscr+ig-1)=a(iscr+ig-1)/(a(isum+ngn*(ix-1)+ig-1)* & a(isum+ngn*(ixp-1)+ig-1)) enddo if (ifunrs.gt.0.and.iupc.gt.0) then do ig=ig1,igmax a(jscr+ig-1)=a(jscr+ig-1)/ & (a(isum+ngn*(ix-1)+ig-1)* & a(isum+ngn*(ixp-1)+ig-1)) enddo endif endif if (ifresr.gt.0.and.(ifunrs.gt.0.and.iupc.gt.0)) then do ig=ig1,igmax if (a(iscr+ig-1).gt.0.or.a(jscr+ig-1).gt.0) then write(nsyso,61) ig,ig,a(iscr+ig-1),a(jscr+ig-1) endif enddo elseif (ifresr.gt.0) then do ig=ig1,igmax if (a(iscr+ig-1).gt.0) then write(nsyso,61) ig,ig,a(iscr+ig-1) endif enddo elseif (ifunrs.gt.0.and.iupc.gt.0) then do ig=ig1,igmax if (a(jscr+ig-1).gt.0.) then write(nsyso,61) ig,ig,a(jscr+ig-1) endif enddo endif 590 continue endif c c ***close loop over ranges of source groups (if any). if (igmax.eq.ngn) go to 470 igmin=igmax+1 igmax=igmin+irange-1 if (igmax.gt.ngn) igmax=ngn go to 185 470 continue cej if (mfcov.eq.34) then if (nm.lt.nmt1h) then do i=1,nsumx a(isuma+i-1)=0 enddo go to 220 endif endif c c ***close loops over reaction types. nscr=11*imode mt1lst=1000 180 continue call asend (nout,0) 170 continue cej if (nlump.gt.0) then call releas('lmt1',0,a) call releas('lmt2',0,a) endif c c ***covout is finished. if (nout.eq.0) return call afend(nout,0) call amend(nout,0) call closz(nscr) call closz(nscr2) call closz(nscrg) return c 15 format(i4,i6,1p,6e11.3) 20 format(' ig igp +0 +1 +2',/, & ' --- --- ---- ---- ----') 25 format(' zero') 30 format(/,' absolute covariance ( mt',i3,' , ig , mt',i3, & ' , igp )',19x,f9.1,'s',/) 31 format(/,' absolute covariance ( mt',i3,' , ig , mt',i3, & ' , igp )',19x,f9.1,'s', & /,' same as ( mt',i3,' , ig , mt',i3, & ' , igp )') 35 format(/,' relative covariance ( mt',i3,' , ig , mt',i3, & ' , igp )',19x,f9.1,'s',/) 36 format(/,' relative covariance ( mt',i3,' , ig , mt',i3, & ' , igp )',19x,f9.1,'s', & /,' same as ( mt',i3,' , ig , mt',i3, & ' , igp )') 40 format(/,' absolute covariance ( mt',i3,' , ig , mat',i5, & ' /mt',i3,' , igp )',9x,f9.1,'s',/) 45 format(/,' relative covariance ( mt',i3,' , ig , mat',i5, & ' /mt',i3,' , igp )',9x,f9.1,'s',/) 50 format(' for legendre component: ',i2,' and ',i2) 60 format(/,5x,'...contribution from resonance parameters (mf=32)...' & ,/,5x,' ig igp resolved' & ,/,5x,' --- --- --------') 61 format(5x,i4,i6,1p,6e11.3) 62 format(/,5x,'...contribution from resonance parameters (mf=32)...' & ,/,5x,' ig igp resolved unresolve' & ,/,5x,' --- --- -------- ---------') 63 format(/,5x,'...contribution from resonance parameters (mf=32)...' & ,/,5x,' ig igp unresolve' & ,/,5x,' --- --- ---------') end c subroutine egngpn(a) c ****************************************************************** c generate requested neutron group structure or read in from c the system input file in the form of an endf/b list record c c ign meaning c --- --------------------------------------- c 1 arbitrary structure (read in) c 2 csewg 239 group structure c 3 lanl 30 group structure c 4 anl 27 group structure c 5 rrd 50 group structure c 6 gam-i 68 group structure c 7 gam-ii 100 group structure c 8 laser-thermos 35 group c 9 epri-cpm 69 group structure c 10 lanl 187-group structure c 11 lanl 70-group structure c 12 sand-ii 620-group structure c 13 lanl 80-group structure c 14 eurlib 100-group structure c 15 sand-iia 640-group structure c 16 vitamin-e 174-group structure c 17 vitamin-j 175-group structure c 18 xmas 172-group structure cej c 19 read in, supplemented with endf covariance grid c c ****************************************************************** implicit real*8 (a-h,o-z) common/mainio/nsysi,nsyso,nsyse,ntty common/grpn/ign,ng,eg(901),iprint cej common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr(3) dimension a(*) c dimension gl2(241),eg3(31),gl4(28),gl5(51),eg6(36),eg9(70) dimension eg10a(48),eg10b(13) dimension gl2a(111),gl2b(104),gl2c(26) dimension eg11(71),u80(80) dimension deltl(8),ndelta(9) dimension ig14(19),gl14(19) dimension eg15a(84), eg15b(91) dimension eg18(173) dimension eg20n(20) equivalence(gl2a(1),gl2(1)),(gl2b(1),gl2(112)),(gl2c(1),gl2(216)) external error,uniong,findex,sigfig data gl2a/ & 27.631d0,17.0d0,16.75d0,16.588d0,16.5d0,16.3d0,16.25d0,16.0d0, & 15.75d0,15.5d0,15.25d0,15.d0,14.75d0,14.5d0,14.25d0,14.d0, & 13.75d0,13.5d0,13.25d0,13.d0,12.75d0,12.5d0,12.25d0,12.d0, & 11.75d0,11.5d0,11.25d0,11.d0,10.75d0,10.5d0,10.25d0,10.d0, & 9.75d0,9.5d0,9.25d0,9.d0,8.9d0,8.8d0,8.75d0,8.7d0,8.6d0,8.5d0, & 8.4d0,8.3d0,8.25d0,8.2d0,8.1583d0,8.1d0,8.d0,7.9d0,7.8d0, & 7.75d0,7.7d0,7.6d0,7.5d0,7.375d0,7.25d0,7.125d0,7.d0,6.875d0, & 6.75d0,6.625d0,6.5d0,6.375d0,6.25d0,6.15d0,6.125d0,6.05d0, & 6.025d0,6.d0,5.95d0,5.875d0,5.75d0,5.675d0,5.65d0,5.625d0, & 5.5d0,5.375d0,5.25d0,5.175d0,5.125d0,5.075d0,5.d0,4.875d0, & 4.75d0,4.625d0,4.5d0,4.45d0,4.4d0,4.35d0,4.3d0,4.25d0,4.2d0, & 4.15d0,4.125d0,4.1d0,4.075d0,4.05d0,4.d0,3.95d0,3.9d0,3.85d0, & 3.8d0,3.75d0,3.7d0,3.65d0,3.6d0,3.575d0,3.55d0,3.525d0,3.5d0/ data gl2b/ & 3.475d0,3.45d0,3.4d0,3.35d0,3.3d0,3.25d0,3.2d0,3.15d0,3.1d0, & 3.05d0,3.d0,2.975d0,2.95d0,2.925d0,2.9d0,2.85d0,2.8d0,2.75d0, & 2.7d0,2.65d0,2.6d0,2.55d0,2.5d0,2.45d0,2.4d0,2.35d0,2.3417d0, & 2.325d0,2.3d0,2.25d0,2.2d0,2.15d0,2.125d0,2.1d0,2.05d0,2.d0, & 1.95d0,1.9d0,1.875d0,1.85d0,1.825d0,1.8d0,1.75d0,1.7d0, & 1.675d0,1.65d0,1.625d0,1.6d0,1.55d0,1.5d0,1.4833d0,1.4667d0, & 1.45d0,1.4417d0,1.4333d0,1.4167d0,1.4d0,1.35d0,1.3d0,1.25d0, & 1.2d0,1.175d0,1.15d0,1.125d0,1.1d0,1.05d0,1.d0,.95d0,.9d0, & .85d0,.8d0,.775d0,.75d0,.725d0,.7d0,.65d0,.6d0,.55d0,.525d0, & .5d0,.475d0,.45d0,.425d0,.41667d0,.40833d0,.4d0,.375d0, & .35d0,.325d0,.3d0,.275d0,.25d0,.225d0,.2d0,.175d0,.15d0, & .125d0,.1d0,.075d0,.05d0,.025d0,0.d0,-.025d0,-.05d0/ data gl2c/ & -.075d0,-.1d0,-.125d0,-.15d0,-.175d0,-.2d0,-.225d0,-.25d0, & -.275d0,-.3d0,-.325d0,-.35d0,-.375d0,-.4d0,-.425d0,-.45d0, & -.475d0,-.5d0,-.525d0,-.55d0,-.575d0,-.6d0,-.625d0,-.65d0, & -.675d0,-.69167d0/ data eg3/1.39d-4,1.52d-1,4.14d-1,1.13d0,3.06d0,8.32d0,2.26d1, & 6.14d1,1.67d2,4.54d2,1.235d3,3.35d3,9.12d3,2.48d4,6.76d4, & 1.84d5,3.03d5,5.00d5,8.23d5,1.353d6,1.738d6,2.232d6,2.865d6, & 3.68d6,6.07d6,7.79d6,1.00d7,1.20d7,1.35d7,1.50d7,1.70d7/ data gl4/14.5d0,13.0d0,12.5d0,12.0d0,11.5d0,11.0d0,10.5d0, & 10.0d0,9.5d0,9.0d0,8.5d0,8.0d0,7.5d0,7.0d0,6.5d0,6.0d0, & 5.5d0,5.0d0,4.5d0,4.0d0,3.5d0,3.0d0,2.5d0,2.0d0,1.5d0,1.0d0, & 0.5d0,0.0d0/ data gl5/27.631d0,16.5d0,16.d0,15.5d0,15.d0,14.5d0,14.d0, & 13.5d0,13.d0,12.5d0,12.d0,11.5d0,11.d0,10.5d0,10.25d0,10.d0, & 9.75d0,9.5d0,9.25d0,9.d0,8.75d0,8.5d0,8.25d0,8.d0,7.75d0, & 7.5d0,7.25d0,7.d0,6.75d0,6.5d0,6.25d0,6.d0,5.75d0,5.5d0, & 5.25d0,5.d0,4.75d0,4.5d0,4.25d0,4.d0,3.75d0,3.5d0,3.25d0, & 3.d0,2.5d0,2.d0,1.5d0,1.d0,.5d0,0.d0,-.6917d0/ data eg6/.253d-3,.2277d-2,.6325d-2,.12397d-1,.20493d-1,.30613d-1, & .42757d-1,.56925d-1,.81972d-1,.11159d0,.14573d0,.18444d0, & .2277d0,.25104d0,.27053d0,.29075d0,.30113d0,.32064d0,.35768d0, & .41704d0,.50326d0,.62493d0,.78211d0,.95070d0,.10137d+1, & .10428d+1,.10525d+1,.10624d+1,.10722d+1,.10987d+1,.11664d+1, & .13079d+1,.14575d+1,.1595d+1,.17262d+1,.1855d+1/ data eg9/1.d-5,.005d0,.01d0,.015d0,.02d0,.025d0,.03d0,.035d0, & .042d0,.05d0,.058d0,.067d0,.08d0,.1d0,.14d0,.18d0,.22d0,.25d0, & .28d0,.3d0,.32d0,.35d0,.4d0,.5d0,.625d0,.78d0,.85d0,.91d0,.95d0, & .972d0,.996d0,1.02d0,1.045d0,1.071d0,1.097d0,1.123d0,1.15d0, & 1.3d0,1.5d0,2.1d0,2.6d0,3.3d0,4.d0,9.877d0,15.968d0,27.7d0, & 48.052d0,75.501d0,148.728d0,367.262d0,906.898d0,1425.1d0, & 2239.45d0,3519.1d0,5530.d0,9118.d0,1.503d4,2.478d4,4.085d4, & 6.734d4,1.11d5,1.83d5,3.025d5,5.d5,8.21d5,1.353d6,2.231d6, & 3.679d6,6.0655d6,1.d7/ data eg10a/1.d-5,2.5399d-4,7.6022d-4,2.2769d-3,6.3247d-3, & .012396d0,.020492d0,.0255d0,.030612d0,.0355d0,.042755d0,.05d0, & .056922d0,.067d0,.081968d0,.11157d0,.14572d0,.1523d0,.18443d0, & .22769d0,.25103d0,.27052d0,.29074d0,.30112d0,.32063d0,.35767d0, & .41499d0,.50323d0,.62506d0,.78208d0,.83368d0,.87642d0,.91d0, & .95065d0,.971d0,.992d0,1.0137d0,1.0427d0,1.0525d0,1.0623d0, & 1.0722d0,1.0987d0,1.1254d0,1.1664d0,1.3079d0,1.4574d0,1.5949d0, & 1.7261d0/ data eg10b/1.1d7,1.2d7,1.3d7,1.35d7,1.375d7,1.394d7,1.42d7, & 1.442d7,1.464d7,1.5d7,1.6d7,1.7d7,2.d7/ data eg11/10.677d0,61.4421d0,101.301d0,130.073d0,167.017d0, & 214.454d0,275.365d0,353.575d0,453.999d0,582.947d0,748.518d0, & 961.117d0,1089.09d0,1234.1d0,1398.42d0,1584.61d0,1795.6d0, & 2034.68d0,2305.6d0,2612.59d0,2960.45d0,3354.63d0,3801.29d0, & 4307.43d0,4880.95d0,5530.84d0,6267.27d0,7101.74d0,8047.33d0, & 9118.82d0,10333.3d0,11708.8d0,13267.8d0,15034.4d0,17036.2d0, & 19304.5d0,21874.9d0,24787.5d0,28087.9d0,31827.8d0,40867.7d0, & 52475.2d0,67379.5d0,86517.d0,111090.d0,142642.d0,183156.d0, & 235178.d0,301974.d0,387742.d0,439369.d0,497871.d0,564161.d0, & 639279.d0,724398.d0,820850.d0,930145.d0,1053990.d0, & 1194330.d0,1353350.d0,1737740.d0,2231300.d0,2865050.d0, & 3678790.d0,4723670.d0,6065310.d0,7788010.d0,1.d7,1.28403d7, & 1.64872d7,2.d7/ data deltl/5.d0,7.5d0,10.d0,15.d0,20.d0,25.d0,30.d0,40.d0/ data ndelta/2,6,10,19,23,28,36,40,46/ data u80/.1681472d0,.125d0,.1d0,.125d0,.175,8*.25d0,10*.125d0, & 10*.25d0,.125d0,.075d0,.05d0,26*.125d0,5*.25d0,9*.5d0,3*1.,7.d0/ data ig14/2,9,13,15,17,23,25,55,60,61,63,64,65,93,94,95,99,100, & 101/ data gl14/.1d0,.05d0,.1d0,.05d0,.1d0,.05d0,.1d0,.25d0,.2d0,.05d0, & .075d0,.125d0,.25d0,.5d0,.25d0,.5d0,.588d0,.412d0,10.631d0/ data eg15a/ & 1.0d-5,1.0d-1,4.1399d-1,5.3158d-1,6.8256d-1,8.7642d-1,1.1254d0, & 1.4450d0,1.8554d0,2.3824d0,3.0590d0,3.9279d0,5.0435d0,6.4760d0, & 8.3153d0,1.0677d1,1.3710d1,1.7603d1,2.2603d1,2.9023d1,3.7267d1, & 4.7851d1,6.1442d1,7.8893d1,1.0130d2,1.3007d2,1.6702d2,2.1445d2, & 2.7536d2,3.5358d2,4.5400d2,5.8295d2,7.4852d2,9.6112d2,1.2341d3, & 1.5846d3,2.0347d3,2.2487d3,2.4852d3,2.6126d3,2.7465d3,3.0354d3, & 3.3546d3,3.7074d3,4.3074d3,5.5308d3,7.1017d3,9.1188d3,1.0595d4, & 1.1709d4,1.5034d4,1.9305d4,2.1875d4,2.3579d4,2.4176d4,2.4788d4, & 2.6058d4,2.7000d4,2.8500d4,3.1828d4,3.4307d4,4.0868d4,4.6309d4, & 5.2475d4,5.6562d4,6.7379d4,7.2000d4,7.9500d4,8.2500d4,8.6517d4, & 9.8037d4,1.1109d5,1.1679d5,1.2277d5,1.2907d5,1.3569d5,1.4264d5, & 1.4996d5,1.5764d5,1.6573d5,1.7422d5,1.8316d5,1.9255d5,2.0242d5/ data eg15b/ & 2.1280d5,2.2371d5,2.3518d5,2.4724d5,2.7324d5,2.8725d5,2.9452d5, & 2.9720d5,2.9850d5,3.0197d5,3.3373d5,3.6883d5,3.8774d5,4.0762d5, & 4.5049d5,4.9787d5,5.2340d5,5.5023d5,5.7844d5,6.0810d5,6.3928d5, & 6.7206d5,7.0651d5,7.4274d5,7.8082d5,8.2085d5,8.6294d5,9.0718d5, & 9.6164d5,1.0026d6,1.1080d6,1.1648d6,1.2246d6,1.2873d6,1.3534d6, & 1.4227d6,1.4957d6,1.5724d6,1.6530d6,1.7377d6,1.8268d6,1.9205d6, & 2.0190d6,2.1225d6,2.2313d6,2.3069d6,2.3457d6,2.3653d6,2.3852d6, & 2.4660d6,2.5924d6,2.7253d6,2.8650d6,3.0119d6,3.1664d6,3.3287d6, & 3.6788d6,4.0657d6,4.4933d6,4.7237d6,4.9659d6,5.2205d6,5.4881d6, & 5.7695d6,6.0653d6,6.3763d6,6.5924d6,6.7032d6,7.0469d6,7.4082d6, & 7.7880d6,8.1873d6,8.6071d6,9.0484d6,9.5123d6,1.0000d7,1.0513d7, & 1.1052d7,1.1618d7,1.2214d7,1.2523d7,1.3499d7,1.3840d7,1.4191d7, & 1.4550d7,1.4918d7,1.5683d7,1.6487d7,1.6905d7,1.7333d7,1.9640d7/ data eg18/ & 1.96403d+7,1.73325d+7,1.49182d+7,1.38403d+7,1.16183d+7, & 1.00000d+7,8.18731d+6,6.70320d+6,6.06531d+6,5.48812d+6, & 4.49329d+6,3.67879d+6,3.01194d+6,2.46597d+6,2.23130d+6, & 2.01897d+6,1.65299d+6,1.35335d+6,1.22456d+6,1.10803d+6, & 1.00259d+6,9.07180d+5,8.20850d+5,6.08101d+5,5.50232d+5, & 4.97871d+5,4.50492d+5,4.07622d+5,3.01974d+5,2.73237d+5, & 2.47235d+5,1.83156d+5,1.22773d+5,1.11090d+5,8.22975d+4, & 6.73795d+4,5.51656d+4,4.08677d+4,3.69786d+4,2.92830d+4, & 2.73944d+4,2.47875d+4,1.66156d+4,1.50344d+4,1.11378d+4, & 9.11882d+3,7.46586d+3,5.53084d+3,5.00451d+3,3.52662d+3, & 3.35463d+3,2.24867d+3,2.03468d+3,1.50733d+3,1.43382d+3, & 1.23410d+3,1.01039d+3,9.14242d+2,7.48518d+2,6.77287d+2, & 4.53999d+2,3.71703d+2,3.04325d+2,2.03995d+2,1.48625d+2, & 1.36742d+2,9.16609d+1,7.56736d+1,6.79041d+1,5.55951d+1, & 5.15780d+1,4.82516d+1,4.55174d+1,4.01690d+1,3.72665d+1, & 3.37201d+1,3.05113d+1,2.76077d+1,2.49805d+1,2.26033d+1, & 1.94548d+1,1.59283d+1,1.37096d+1,1.12245d+1,9.90555d+0, & 9.18981d+0,8.31529d+0,7.52398d+0,6.16012d+0,5.34643d+0, & 5.04348d+0,4.12925d+0,4.00000d+0,3.38075d+0,3.30000d+0, & 2.76792d+0,2.72000d+0,2.60000d+0,2.55000d+0,2.36000d+0, & 2.13000d+0,2.10000d+0,2.02000d+0,1.93000d+0,1.84000d+0, & 1.75500d+0,1.67000d+0,1.59000d+0,1.50000d+0,1.47500d+0, & 1.44498d+0,1.37000d+0,1.33750d+0,1.30000d+0,1.23500d+0, & 1.17000d+0,1.15000d+0,1.12535d+0,1.11000d+0,1.09700d+0, & 1.07100d+0,1.04500d+0,1.03500d+0,1.02000d+0,9.96000d-1, & 9.86000d-1,9.72000d-1,9.50000d-1,9.30000d-1,9.10000d-1, & 8.60000d-1,8.50000d-1,7.90000d-1,7.80000d-1,7.05000d-1, & 6.25000d-1,5.40000d-1,5.00000d-1,4.85000d-1,4.33000d-1, & 4.00000d-1,3.91000d-1,3.50000d-1,3.20000d-1,3.14500d-1, & 3.00000d-1,2.80000d-1,2.48000d-1,2.20000d-1,1.89000d-1, & 1.80000d-1,1.60000d-1,1.40000d-1,1.34000d-1,1.15000d-1, & 1.00001d-1,9.50000d-2,8.00000d-2,7.70000d-2,6.70000d-2, & 5.80000d-2,5.00000d-2,4.20000d-2,3.50000d-2,3.00000d-2, & 2.50000d-2,2.00000d-2,1.50000d-2,1.00000d-2,6.90000d-3, & 5.00000d-3,3.00000d-3,1.00001d-5/ data ezero/1.d7/ data tenth,eighth,quart/0.10d0,0.125d0,0.25d0/ data bgam2,tgam2/27.631021d0,-0.53062825d0/ data u187a,u187b,u187c,e187d,e187e/-15.5d0,-14.125d0,-5.875d0, & 2.6058d4,6.868d0/ data sanda,sandb,sandc,sandd,sande/1.d-4,1.d-6,2.8d-4,1.d6,1.d5/ data uu80/.6931472d0/ data e175/1.284d7/ cej data (eg20n(i),i=1,20) & / 1.0000d-5, 1.0130d+2, 2.1445d+2, 4.5400d+2, 9.6112d+2, & 2.0347d+3, 4.3074d+3, 9.1188d+3, 1.9305d+4, 4.0868d+4, & 8.6517d+4, 1.8316d+5, 3.8774d+5, 8.2085d+5, 1.3534d+6, & 2.2313d+6, 3.6788d+6, 6.0653d+6, 1.0000d+7, 2.0000d+7 / c data ngmax/901/ c c ***choose option according to ign lflag=0 c c ***group structure is read in (free format) cej if (ign.eq.1.or.ign.eq.19) then read(nsysi,*) ng ngp=ng+1 cej if (ngp.gt.ngmax) call error('egngpn','too many groups.',' ') read(nsysi,*) (eg(i),i=1,ngp) cej do i=1,ngp eg(i)=sigfig(eg(i),5,0) enddo c do i=1,ng if (eg(i).gt.eg(i+1)) cej & call error('egngpn', & 'read-in group structure is out of order.',' ') enddo c c ***csewg 239 group structure else if (ign.eq.2) then ng=240 do ig=1,241 eg(ig)=gl2(ig) enddo lflag=1 c c ***lanl 30 group structure else if (ign.eq.3) then ng=30 do ig=1,31 eg(ig)=eg3(ig) enddo c c ***anl 27 group structure else if (ign.eq.4) then ng=27 do ig=1,28 eg(ig)=gl4(ig) enddo lflag=1 c c ***rrd 50 group structure else if (ign.eq.5) then ng=50 do ig=1,51 eg(ig)=gl5(ig) enddo lflag=1 c c ***gam-i 68 group structure else if (ign.eq.6) then ng=68 u=-quart du=quart do ig=1,69 u=u+du eg(70-ig)=u enddo lflag=1 c c ***gam-ii 100 group structure else if (ign.eq.7) then ng=100 u=-4*tenth du=tenth do ig=1,99 u=u+du eg(101-ig)=u if (ig.eq.49) du=quart enddo eg(1)=bgam2 c ***upper limit changed to 17 mev. eg(101)=tgam2 lflag=1 c c ***laser-thermos 35 group structure else if (ign.eq.8) then ng=35 do ig=1,36 eg(ig)=eg6(ig) enddo c c ***epri-cpm 69 group structure else if (ign.eq.9) then ng=69 do ig=1,70 eg(ig)=eg9(ig) enddo c c ***lanl 187-group structure else if (ign.eq.10) then ng=187 do ig=1,48 eg(ig)=eg10a(ig) enddo u=u187a do ig=49,59 eg(ig)=ezero*exp(u) u=u+eighth enddo eg(60)=e187e u=u187b do ig=61,126 eg(ig)=ezero*exp(u) u=u+eighth enddo eg(127)=e187d u=u187c do ig=128,175 eg(ig)=ezero*exp(u) u=u+eighth enddo do ig=176,188 eg(ig)=eg10b(ig-175) enddo c c ***lanl 70 group structure else if (ign.eq.11) then ng=70 do ig=1,71 eg(ig)=eg11(ig) enddo c c ***sand-ii 620- and 640-group structures else if (ign.eq.12.or.ign.eq.15) then ng=620 if (ign.eq.15) ng=640 ngp=ng+1 eg(1)=sanda c ***generate the first 45 boundaries do i=1,8 delta=deltl(i)*sandb n1=ndelta(i) n2=ndelta(i+1)-1 do n=n1,n2 eg(n)=eg(n-1)+delta enddo enddo c ***correct group 21 eg(21)=sandc c ***groups 46 to 450 are multiples of previous groups do i=46,450 eg(i)=eg(i-45)*10 enddo c ***groups 451 through 620 have constant spacing of 1.e5 eg(451)=sandd do i=452,ngp eg(i)=eg(i-1)+sande enddo c c ***lanl 80-group structure else if (ign.eq.13) then ng=80 u=uu80 do ig=1,81 eg(82-ig)=ezero*exp(u) u=u-u80(ig) enddo eg(81)=2*ezero c c ***eurlib 100-group structure else if (ign.eq.14) then ng=100 eg(101)=-4 eg(101)=eg(101)/10 ic=0 do ig=2,101 if (ig.eq.ig14(ic+1)) ic=ic+1 eg(102-ig)=eg(103-ig)+gl14(ic) enddo lflag=1 c c ***vitamin-e 174- and vitamin-j 175-group structures (ornl-5510) else if (ign.eq.16.or.ign.eq.17) then ng=174 do ig=1,84 eg(ig)=eg15a(ig) enddo do ig=85,175 eg(ig)=eg15b(ig-84) enddo if (ign.ne.16) then ng=175 eg(166)=e175 do ig=167,176 eg(ig)=eg15b(ig-85) enddo endif c c ***xmas 172-group structure else if (ign.eq.18) then ng=172 do ig=1,173 eg(ig)=eg18(174-ig) enddo c c ***illegal ign cej else if (ign.eq.20) then ng=18 do ig=1,ng+1 eg(ig)=eg20n(ig) enddo else if (ign.eq.21) then ng=19 do ig=1,ng+1 eg(ig)=eg20n(ig) enddo else call error('egngpn','illegal group structure requested.',' ') endif c c ***convert lethargy grid to energies if (lflag.eq.1) then lim=ng+1 do ig=1,lim eg(ig)=sigfig(ezero*exp(-eg(ig)),7,0) enddo endif c c ***display group structure cej if (ign.ne.19) then if (ign.eq.1) write(nsyso,'(/, & '' neutron group structure......read in'')') if (ign.eq.2) write(nsyso,'(/, & '' neutron group structure......csewg 240 group'')') if (ign.eq.3) write(nsyso,'(/, & '' neutron group structure......lanl 30 group'')') if (ign.eq.4) write(nsyso,'(/, & '' neutron group structure......anl 27 group'')') if (ign.eq.5) write(nsyso,'(/, & '' neutron group structure......rrd 50 group'')') if (ign.eq.6) write(nsyso,'(/, & '' neutron group structure......gam-i 68 group'')') if (ign.eq.7) write(nsyso,'(/, & '' neutron group structure......gam-ii 100 group'')') if (ign.eq.8) write(nsyso,'(/, & '' neutron group structure......laser-thermos 35 group'')') if (ign.eq.9) write(nsyso,'(/, & '' neutron group structure......epri-cpm 69 group'')') if (ign.eq.10) write(nsyso,'(/, & '' neutron group structure......lanl 187-group'')') if (ign.eq.11) write(nsyso,'(/, & '' neutron group structure......lanl 70-group'')') if (ign.eq.12) write(nsyso,'(/, & '' neutron group structure......sand-ii 620 group'')') if (ign.eq.13) write(nsyso,'(/, & '' neutron group structure......lanl 80-group'')') if (ign.eq.14) write(nsyso,'(/, & '' neutron group structure......eurlib 100-group'')') if (ign.eq.15) write(nsyso,'(/, & '' neutron group structure......sand-iia 640-group'')') if (ign.eq.16) write(nsyso,'(/, & '' neutron group structure......vitamin-e 174-group'')') if (ign.eq.17) write(nsyso,'(/, & '' neutron group structure......vitamin-j 175-group'')') if (ign.eq.18) write(nsyso,'(/, & '' neutron group structure......xmas 172-group'')') do ig=1,ng write(nsyso,'(1x,i5,2x,1p,e12.5,'' - '',e12.5)') & ig,eg(ig),eg(ig+1) enddo endif c cej c ***prepare union of users grid with endf covariance grid. ngp=ng+1 do i=1,ngp eg(i)=sigfig(eg(i),ndig,0) enddo call uniong(nendf,a) call findex('un',iun,a) if (ign.eq.19) then write(nsyso,'(/, & '' union structure (= user structure) has'',i4, & '' groups'',/)') nunion do ig=1,nunion eg(ig)=a(ig-1+iun) enddo eg(nunion+1)=a(iun+nunion) ng=nunion else write(nsyso,'(/,'' union structure has'',i4,'' groups'',/)') & nunion endif do ig=1,nunion write(nsyso,'(1x,i5,6x,1p,e11.5,'' - '',e11.5)') & ig,a(iun+ig-1),a(iun+ig) enddo c return end cej subroutine epanel(elo,ehi,ans,nl,nz,iglo,mfcov,a) c ****************************************************************** c perform generalized group constant integrals for one panel. c the upper boundary of the panel is chosen to be the smallest c of ehi, the next cross section point, and the next flux point. c ****************************************************************** implicit real*8 (a-h,o-z) dimension sig(65),slst(65),flux(10,10),flst(10,10) dimension a(*),ans(nl,nz,*) data idisc,elast/0,0.d0/ cej data delta/0.999999999995d0/ save enext,flst,slst c c ***retrieve factors in integrands at lower boundary. il=1 iz=1 iglo=1 if (idisc.ne.0.or.elo.ne.elast) then elast=elo cej if (mfcov.eq.34) then call egtlgc(elo,enext,idisc,slst,a) else call egtsig(elo,enext,idisc,slst,a) endif c call egtflx(elo,en,idiscf,flst,nl,nz,a) if (en.eq.enext.and.idiscf.gt.idisc) idisc=idiscf if (en.lt.enext) idisc=idiscf if (en.lt.enext) enext=en endif c c ***retrieve cross section and flux at upper boundary. if (enext.lt.ehi) ehi=enext ehigh=ehi if (idisc.gt.0) ehigh=ehi*delta cej if (mfcov.eq.34) then call egtlgc(ehigh,enext,idisc,sig,a) else call egtsig(ehigh,enext,idisc,sig,a) endif c call egtflx(ehigh,en,idiscf,flux,nl,nz,a) if (en.eq.enext.and.idiscf.gt.idisc) idisc=idiscf if (en.lt.enext) idisc=idiscf if (en.lt.enext) enext=en c c ***compute group cross sections and fluxes. bq=(ehigh-elo)/2 ans(il,iz,1)=ans(il,iz,1)+(flux(iz,il)+flst(iz,il))*bq c cej do n=1,nl rr=(sig(n)*flux(iz,il)+slst(n)*flst(iz,il))*bq ans(n,iz,2)=ans(n,iz,2)+rr enddo c c ***save last values. elast=ehi cej do n=1,nl slst(n)=sig(n) enddo c flst(1,1)=flux(1,1) if (en.eq.enext.and.idiscf.gt.idisc) idisc=idiscf if (en.lt.enext) idisc=idiscf if (en.lt.enext) enext=en return end c subroutine grpav(mprint,tempin,a) c ****************************************************************** c compute multigroup cross sections for reactions needed in the c calculation of the covariance matrices. calculation uses the c union of the user specified group structure and the energy c grid found in mfcov. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/sigzer/sigz(10),nsigz common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,ntot,nunit(1) common/mainio/nsysi,nsyso,nsyse,ntty common/util/npage,iverf common/argcom/matl,mfd,mtd common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) character*60 strng character*66 text dimension mtname(17),b(8),z(20),ans(2) dimension a(*) data nt/1/, nz/1/, ngg/0/ data eps/1.d-9/ data big/1.d10/ data elow/1.d-5/ zero=0 c c ***initialize if (iread.eq.2) call error('grpav', & 'not coded for multimaterial group averaging.',' ') call timer(sec) write(nsyso,'(/,'' computing multigroup cross sections'', & 33x,f8.1,''s'')') sec call egnwtf(a) nwds=npage+50 call reserv('scr',nwds,iscr,a) iscr1=iscr-1 nsigz=1 sigz(1)=big ntot=11 ngout=-10 call repoz(ngout) math=1 mfh=0 mth=0 text=' ' nw=17 read(text,'(16a4,a2)') (z(i),i=1,nw) call tpidio(0,ngout,0,z,nb,nw) call findex('un',iun,a) iun1=iun-1 if (abs(egn(1)-elow).le.eps) egn(1)=elow etop=a(iun+nunion) c c ***search for desired mat and temperatures on pendf tape call repoz(npend) call findf(matd,1,0,npend) call contio(npend,0,0,a(iscr),nb,nw) 121 za=c1h awr=c2h if (iverf.ge.5) call contio(npend,0,0,a(iscr),nb,nw) if (iverf.ge.6) call contio(npend,0,0,a(iscr),nb,nw) call hdatio(npend,0,0,a(iscr),nb,nw) if (abs(c1h-tempin).le.tempin/10000) go to 130 if (c1h.gt.tempin) go to 125 call tomend(npend,0,0,a(iscr)) call contio(npend,0,0,a(iscr),nb,nw) if (math.ne.matd) go to 125 go to 121 125 write(strng,'(''unable to find temp='',1p,e11.3)') tempin call error('grpav',strng,' ') c c ***write head record for this material on gout tape. 130 nsh=1 math=matd mfh=1 mth=451 a(iscr)=za a(iscr+1)=awr a(iscr+2)=0 a(iscr+3)=nz a(iscr+4)=-11 a(iscr+5)=nt call contio(0,ngout,0,a(iscr),nb,nw) a(iscr)=tempin a(iscr+1)=0 a(iscr+2)=nunion a(iscr+3)=ngg a(iscr+4)=0 a(iscr+5)=0 nw=7 a(iscr+nw-1)=0 nw=nw+1 a(iscr+nw-1)=sigz(1) np1=nunion+1 do i=1,np1 a(i+nw+iscr1)=a(i+iun1) enddo nw=nw+np1 nl=1 a(iscr+4)=nw indx=iscr call listio(0,ngout,0,a(iscr),nb,nwds) do while (nb.ne.0) indx=indx+nwds call moreio(0,ngout,0,a(indx),nb,nwds) enddo mfold=1 mtold=451 nshold=nsh call asend(ngout,0) c c ***store total cross section from pendf tape for later use c c ***if this is an infinite dilution calculation, c ***omit the reading and storing of mt=1 do 165 nsz=1,nsigz if (sigz(nsz).lt.1.e8) go to 170 165 continue ntot=0 go to 175 170 call findf(matd,3,1,npend) if (npend.lt.0) ntot=-ntot call repoz(ntot) nsh=1 math=1 call afend(ntot,0) call contio(npend,ntot,0,a(iscr),nb,nw) call tosend(npend,ntot,0,a(iscr)) call amend(ntot,0) call atend(ntot,0) call repoz(ntot) 175 nsh=nshold c c ***main loop over reactions call findex('ga',iga,a) matl=matd mfd=3 do 290 imt=1,nga mtd=nint(a(iga+imt-1)) if (mtd.eq.452.or.mtd.eq.455.or.mtd.eq.456) then write(strng,'(''cannot group average mt='',i3)') mtd call error('grpav',strng, & 'use groupr first, then error with ngout.ne.0') endif if (mtd.eq.3) call mess('grpav', & 'mt3 cross sections are constucted', & ' from total minus elastic') if (mtd.eq.3) go to 290 text=' ' read(text,'(15a4)') (mtname(i),i=1,15) call timer(time) c c ***initialize ng2=2 nl=1 e=0 call egtsig(e,thresh,idis,sig,a) if (thresh.gt.etop) go to 270 call egtflx(e,enext,idis,flux,nl,nz,a) if (mprint.ne.0) then if (tempin.eq.zero) write(nsyso,'(/, & '' group constants at t=zero deg k'',37x,f8.1,''s'')')time if (tempin.ne.zero) write(nsyso,'(/, & '' group constants at t='',1p,e9.3,'' deg k'', & 32x,0p,f8.1,''s'')') tempin,time write(nsyso,'('' for mf'',i2,'' and mt'',i3,1x,15a4)') & mfd,mtd,(mtname(ii),ii=1,15) write(nsyso,'(15x,''group'',5x,''constant'')') endif call findex('un',iun,a) c c ***loop over initial energy groups do 210 ig=1,nunion elo=a(iun+ig-1) ehi=a(iun+ig) ig2lo=0 if (ehi.le.thresh) go to 210 enext=ehi ans(1)=0 ans(2)=0 cej 230 call epanel(elo,enext,ans,nl,nz,ig2lo,33,a) if (enext.eq.ehi) go to 240 elo=enext enext=ehi go to 230 240 continue c c ***write this group on gout tape. nw=nl*nz*ng2 ans(2)=ans(2)/ans(1) if (mprint.ne.0)write(nsyso,'(14x,i4,5x,1p,e11.4)')ig,ans(2) mfh=mfd mth=mtd if (mfh.ne.mfold) then call afend(ngout,0) mfh=mfd mth=mtd endif if (mth.ne.mtold) then b(1)=za b(2)=awr b(3)=nl b(4)=nz b(5)=0 b(6)=nunion nwds=6 call contio(0,ngout,0,b,nb,nwds) mfold=mfd mtold=mtd endif if (ans(2).ne.zero.or.ig.eq.nunion) then b(1)=tempin b(2)=0 b(3)=ng2 b(4)=ig2lo b(5)=nw b(6)=ig b(7)=ans(1) b(8)=ans(2) nwds=8 call listio(0,ngout,0,b,nb,nwds) endif 210 continue call asend(ngout,0) go to 280 c ***write message if mt has threshold gt highest union energy 270 write(strng,'(''mf '',i2,'' mt '',i3)') mfd,mtd call mess('grpav',strng, & 'has threshold gt highest union energy.') 280 call releas('sig',-1,a) 290 continue c c ***grpav is finished. 300 call afend(ngout,0) call amend(ngout,0) call atend(ngout,0) call releas('scr',-1,a) cej if (mfcov.ne.34) call releas('ga',0,a) call timer(sec) write(nsyso,'(/,'' group averaging completed'', & 43x,f8.1,''s'',/)') sec return end c subroutine rdgout(ngout,matd,mfd,mti,b,sig) c ****************************************************************** c find the desired information from a groupr-type output tape. c mti=-1 is used to retrieve flux from mt=1 records. c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nunit(7),nscrg,nscrt common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc character*60 strng dimension b(*),sig(*) cej dimension mtsig0(100) save mtlast,ngt,iz data mtsig0,mtsig / 100*0, 0 / c mtd=iabs(mti) if (mfd.gt.1) go to 200 c c ***copy rest of this mat to a scratch file. call repoz(nscrg) call repoz(ngout) call tpidio(ngout,0,0,b,nb,nwds) 100 call contio(ngout,0,0,b,nb,nwds) if (mat.eq.matd) go to 120 if (mat.lt.matd.and.mat.ne.-1) go to 110 write(strng,'(''mat'',i4,'' not found.'')') matd call error('rdgout',strng,' ') 110 call tomend(ngout,0,0,b) go to 100 120 if (mf.ne.mfd.or.mt.ne.mtd) then write(strng,'(''mf'',i2,'' mt'',i3,'' not found.'')') mfd,mtd call error('rdgout',strng,' ') endif nz=l2h ntw=n2h call listio(ngout,0,0,b,nb,nwds) ngt=l1h ngtp1=ngt+1 ibase=ntw+nz+6 isave=0 do i=1,ngtp1 isave=isave+1 sig(i)=b(ibase+isave) if (nb.gt.0 .and.ibase+isave.ge.nwds) then call moreio(ngout,0,0,b,nb,nwds) ibase=0 isave=0 endif enddo mti=ngt iz=1 nsc=0 call tofend(ngout,0,0,b) c ***copy rest of material to scratch tape call contio(ngout,0,nscrg,b,nb,nwds) call tomend(ngout,0,nscrg,b) call atend(0,nscrg) mtlast=1000 return c c ***retrieve desired cross section or flux. c ***construct mt=3 from total minus elastic 200 if (mtd.le.mtlast) call repoz(nscrg) if (mtd.eq.3) call repoz(nscrg) mtlast=mtd if (mtd.eq.3) mtd=1 do is=1,ngt sig(is)=0. enddo 210 call contio(nscrg,0,0,b,nb,nwds) if (mat.ge.1) go to 215 if (mti.ne.-2) then cej if (mtsig.gt.0) then do 211 i=1,mtsig if (mtd.eq.mtsig0(i)) go to 212 211 continue mtsig=mtsig+1 mtsig0(mtsig)=mtd else mtsig0(1)=mtd mtsig=1 endif write(strng,'(''mf'',i2,'' mt'',i3,'' not found.'')') mfd,mtd call mess('rdgout',strng, & 'calculation is continued by sigma=0.0.') 212 continue c endif call repoz(nscrg) return 215 continue if (mf.eq.0.or.mt.eq.0) go to 210 if (mf.eq.mfd.and.mt.eq.mtd) go to 230 if (mf.eq.mfd.and.mt.gt.mtd.and.mti.lt.0) go to 220 call tosend(nscrg,0,0,b) go to 210 c c ***if the total cross-section is absent, construct the c ***flux vector as the union of the fluxes c ***from all partials present 220 mti=-2 mtd=mt 230 nl=l1h nz=l2h 240 call listio(nscrg,0,0,b,nb,nwds) jg=n2h if=1+nl*(iz-1) is=nl*nz+1+nl*(iz-1) ib=is if (mti.lt.0) ib=if if ((ib+6).gt.nwds) go to 250 if (mtd.eq.1.or.mtlast.ne.3) sig(jg)=b(ib+6) if (mtd.eq.2.and.mtlast.eq.3) sig(jg)=sig(jg)-b(ib+6) go to 270 250 if (nb.eq.0) call error('rdgout', & 'bad index for b equivalent to sig(ig).', & ' ') call moreio(nscrg,0,0,b,nb,nwds2) ibn=ib+6-nwds if (ibn.le.nwds2) go to 260 nwds=nwds+nwds2 go to 250 260 if (mtd.eq.1.or.mtlast.ne.3) sig(jg)=b(ibn) if (mtd.eq.2.and.mtlast.eq.3) sig(jg)=sig(jg)-b(ibn) 270 do while (nb.ne.0) call moreio(nscrg,0,0,b,nb,nwds) enddo if (jg.lt.ngt) go to 240 if (mti.eq.-2) go to 210 if (mtlast.eq.3.and.mtd.eq.2) mtd=3 if (mtlast.ne.3.or.mtd.eq.3) return mtd=2 go to 210 end c subroutine sigc(ncg,csig,cflx,b,egt,flux,sig) c ****************************************************************** c calculate the coarse group cross sections. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/eunits/nendf,nin,nout,ninc,ngout,nstan,nunit(2),nscr common/mainio/nsysi,nsyso,nsyse,ntty common/estore/a(8500000) common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) character*60 strng character*2 hmt dimension csig(ncg,*),cflx(*),b(*),egt(*),flux(*),sig(*) dimension c(6),matp(60) data hmt/'mt'/ cej logical lmf8 data lmf8/.false./ c c ***put the coarse group structure on nout, ala groupr if (nlump.ne.0) then call findex('sg',isg,a) call findex('lump',ilump,a) call findex('lmt',ilmt,a) call repoz(nscr) call closz(nscr) endif if (nout.ne.0) then mat=matd mf=1 mt=451 b(1)=za b(2)=awr b(3)=0 b(4)=0 b(5)=-11 b(6)=0 call contio (0,nout,0,b,nb,nw) b(1)=0 b(2)=0 b(3)=ngn nw=6 ngnp1=ngn+1 do i=1,ngnp1 nw=nw+1 b(nw)=egn(i) enddo np=nw-6 b(5)=np loc=1 call listio (0,nout,0,b(loc),nb,nw) do while (nb.ne.0) loc=loc+nw call moreio(0,nout,0,b(loc),nb,nw) enddo call asend(nout,0) call afend(nout,0) endif c c ***initialize nun1=nunion+1 do i=1,nun1 egt(i)=sigfig(egt(i),ndig,0) enddo ngn1=ngn+1 do i=1,ngn1 egn(i)=sigfig(egn(i),ndig,0) enddo c ***calculate coarse group flux do ig=1,ngn cflx(ig)=0 do jg=1,nunion if (egt(jg).ge.egn(ig).and.egt(jg).lt.egn(ig+1)) then cflx(ig)=cflx(ig)+flux(jg) endif enddo enddo c c ***loop over all reaction types. c ***compute cross-group cross sections and write on output tape. do 210 ix=1,nmt1 if (mts(ix).lt.851) go to 250 do 220 il=1,nlump l=il mtl=nint(a(ilump+2*(l-1))) if (mtl.eq.mts(ix)) go to 230 220 continue write(strng,'(''covariance reaction'',i4)') mts(ix) call error('sigc',strng,'missing from lumping table.)') 230 nmtl=nint(a(ilump+2*(l-1)+1)) do jg=1,nunion sig(jg)=0 enddo do k=1,nmtl mtd=nint(a(ilmt-1+nlmt*(l-1)+k)) call rdsig(mats(ix),mtd,b,a(isg)) do jg=1,nunion sig(jg)=sig(jg)+a(jg-1+isg) enddo enddo go to 260 250 call rdsig(mats(ix),mts(ix),b,sig) 260 continue do ig=1,ngn csig(ig,ix)=0 do jg=1,nunion if (egt(jg).ge.egn(ig).and.egt(jg).lt.egn(ig+1)) then csig(ig,ix)=csig(ig,ix)+sig(jg)*flux(jg) endif enddo csig(ig,ix)=csig(ig,ix)/cflx(ig) enddo if (nout.eq.0) go to 320 cej if (mats(ix).ne.0) go to 330 mat=matd mf=3 mt=mts(ix) b(1)=0 b(2)=0 b(3)=0 b(4)=0 b(5)=ngn b(6)=0 ibase=6 ip=0 do ig=1,ngn ip=ip+1 b(ibase+ip)=csig(ig,ix) if (ip.ge.npage.or.ig.ge.ngn) then if (ibase.ne.0) then call listio(0,nout,0,b,nb,nwds) ibase=0 ip=0 else call moreio(0,nout,0,b,nb,ip) ip=0 endif endif enddo call asend(nout,0) 320 continue go to 210 cej 330 continue if (.not.lmf8) then call afend(nout,0) lmf8=.true. endif mat=matd mf=8 mt=5 b(1)=0.d0 b(2)=0.d0 b(3)=mats(ix) b(4)=mts(ix) b(5)=ngn b(6)=0 ibase=6 ip=0 do 350 ig=1,ngn ip=ip+1 b(ibase+ip)=csig(ig,ix) if (ip.lt.npage.and.ig.lt.ngn) go to 350 if (ibase.eq.0) go to 340 call listio(0,nout,0,b,nb,nwds) ibase=0 ip=0 go to 350 340 call moreio(0,nout,0,b,nb,ip) ip=0 350 continue 210 continue if (lmf8) call asend(nout,0) c mat=matd c c ***print cross sections in columns. nmtend=nmt1 if (nmtend.gt.4) nmtend=4 ic=0 do i=1,nmt1 matp(i)=matd if (mats(i).ne.0) then ic=ic+1 matp(i)=mats(i) endif enddo if (ic.eq.0) write(nsyso,'(/, & '' table of multigroup cross sections'',//, & '' group lower group cross section'',/, & '' no. energy flux '',4x,4(a2,i3,7x))') & (hmt,mts(i),i=1,nmtend) if (ic.gt.0) write(nsyso,'(/, & '' table of multigroup cross sections'',//, & '' group lower group cross section'',/, & '' no. energy flux '',4x,4(i4,''/'',i3,4x))') & (matp(i),mts(i),i=1,nmtend) nline=2*nmtend write(nsyso,'( & '' ----- ------ ----- '',4x,4(2a5,2x))') & ('-----',i=1,nline) do ig=1,ngn do ia=1,nmtend c(ia)=csig(ig,ia) enddo write(nsyso,'(i5,1p,6e12.4)') & ig,egn(ig),cflx(ig),(c(i),i=1,nmtend) enddo go to 510 460 if (ic.eq.0) write(nsyso,'(/, & '' group cross section'',/,'' no. '',6(a2,i3,7x))') & (hmt,mts(i),i=nmtst,nmtend) if (ic.gt.0) write(nsyso,'(/, & '' group cross section'',/, & '' no. '',6(i4,''/'',i3,4x))') & (matp(i),mts(i),i=nmtst,nmtend) nline=2*(nmtend-nmtst+1) write(nsyso,'('' ----- '',6(2a5,2x))') ('-----',i=1,nline) do ig=1,ngn izero=0 do ia=1,ndiff c(ia)=csig(ig,ia-1+nmtst) if (c(ia).ne.0.) izero=1 enddo if (izero.ne.0) then write(nsyso,'(i5,1p,6e12.4)') ig,(c(i),i=1,ndiff) endif enddo 510 if (nmt1.eq.nmtend) go to 550 nmtst=nmtend+1 ndiff=nmt1-nmtst+1 if (ndiff.gt.6) ndiff=6 nmtend=nmtst+ndiff-1 go to 460 550 if (nout.ne.0) call afend(nout,0) if (nlump.eq.0) go to 560 call releas('lump',0,a) call releas('lmt',0,a) call releas('sg',0,a) 560 return end c subroutine uniong(nendf,a) c ****************************************************************** c form union of user-s energy mesh with mfcov energy mesh. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/grpn/ign,ngn,egn(901),iprint common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) character*60 strng dimension a(*) external reserv,findex,findf,contio,listio,moreio,error,releas external sigfig c c ***initialize. nw=npage+50 call reserv('scr2',nw,iscr,a) nunmax=-1 call reserv('un',nunmax,iun,a) call findex('scr2',iscr,a) call findex('eni',ie,a) if (iverf.gt.4) go to 120 c c ***read energy mesh from mfcov. call findf(matd,mfcov,0,nendf) call contio(nendf,0,0,a(iscr),nb,nw) call contio(nendf,0,0,a(iscr),nb,nw) call listio(nendf,0,0,a(iscr),nb,nw) istart=iscr+6 neni=0 100 iend=iscr+nw-1 do i=istart,iend,2 neni=neni+1 if (neni.gt.nenimx) call error('uniong', & 'exceeded storage in mfcov energy grid.',' ') a(ie+neni-1)=a(i) enddo if (nb.eq.0) go to 110 call moreio(nendf,0,0,a(iscr),nb,nw) istart=iscr go to 100 110 do i=1,neni a(i-1+ie)=sigfig(a(i-1+ie),ndig,0) enddo c c ***unionize energy mesh. 120 j=1 ngnp1=ngn+1 k=0 do 130 i=1,ngnp1 140 if (a(ie+j-1).lt.egn(1)) go to 160 if (a(ie+j-1).le.egn(i)) go to 150 k=k+1 if (k.gt.nunmax) call error('uniong', & 'exceeded storage in union energy grid.',' ') a(iun+k-1)=egn(i) go to 130 150 k=k+1 if (k.gt.nunmax) call error('uniong', & 'exceeded storage in union energy grid.',' ') a(iun+k-1)=a(ie+j-1) j=j+1 if (j.le.neni.and.egn(i).ne.a(ie+j-2)) go to 140 if (j.le.neni.and.egn(i).eq.a(ie+j-2)) go to 130 c c ***finished with endf energies in=i go to 170 c c ***treat endf energies below first group boundary 160 if (j.eq.neni) go to 130 j=j+1 go to 140 130 continue c c ***finished if all ngn energies are used, as higher mfcov c ***energies are not of interest. go to 200 c c ***all mfcov energies used, some ngn energies left. 170 do i=in,ngnp1 if (egn(i).ne.a(iun+k-1)) then k=k+1 if (k.gt.nunmax) call error('uniong', & 'exceeded storage in union energy grid.',' ') a(iun+k-1)=egn(i) endif enddo 200 nunion=k-1 do i=2,k if (a(iun+i-1).le.a(iun+i-2)) then write(strng,'(1p,e12.4,'' le '',1p,e12.4)') & a(iun+i-1),a(iun+i-2) call error('uniong','union energies out of order',strng) endif enddo call releas('scr2',0,a) call releas('un',k,a) c ***release endf/b grid call releas('eni',0,a) return end c subroutine colaps(a) c ****************************************************************** c collapse (or expand) all mts on unit ngout to the union grid, c and write the new data onto a new gout tape (ngout=-10). c method assumes the cross section and the flux are constant c in energy within an input group. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/eunits/ntape(4),ngout,nstan,nscr(3) cej common/ewght/iwt character*60 strng common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension a(*) data nz/1/, nt/1/, nl/1/, ngg/0/ data big/1.d10/ zero=0 c cej if (iwt.ne.0) call egnwtf(a) ntp=-10 matn=0 nun1=nunion+1 call repoz(ngout) call repoz(ntp) nwscr=2*npage+50 call reserv('scr',nwscr,iscr,a) call findex('un',iun,a) nsh=0 call tpidio(ngout,ntp,0,a(iscr),nb,nw) c c ***loop over tape 110 call contio(ngout,0,0,a(iscr),nb,nw) if (math.eq.-1) go to 400 if (mfh.ne.1.or.mth.ne.451) & call error('colaps','did not find expected mf1, mt451.',' ') if (math.ne.matn) go to 120 c ***skip later temperatures for this material call tomend(ngout,0,0,a(iscr)) go to 110 120 ntw=n2h a(iscr+5)=1 call contio(0,ntp,0,a(iscr),nb,nw) if (matn.ne.0) call releas('ela',-1,a) matn=math nsigz=l2h call listio(ngout,0,0,a(iscr),nb,nw) is=iscr ng=l1h do while (nb.ne.0) is=is+nw if (is-iscr+1.gt.nwscr) & call error('colaps','storage exceeded.',' ') call moreio(ngout,0,0,a(is),nb,nw) enddo ng1=ng+1 call reserv('ela',ng1,iela,a) is=iscr+5+ntw+nsigz do i=1,ng1 a(i-1+iela)=sigfig(a(i+is),ndig,0) enddo if (iread.eq.1) go to 155 cej etop=sigfig(2.d7,ndig,0) c if (a(iela+ng).eq.etop) go to 155 a(iela+ng)=etop write(strng,'(''since iread='',i2)') iread call mess('colaps', & 'resetting top ngout group bound to 2.000e+07',strng) 155 continue cej if (a(iela).gt.a(iun).or.a(iela+ng).lt.a(iun+nunion)) & call error('colaps', & 'ngout group structure does not span union grid.',' ') a(iscr+2)=nunion a(iscr+3)=ngg a(iscr+4)=nt+nz+nun1+1 a(iscr+5)=0 a(iscr+6)=0 a(iscr+7)=big do i=1,nun1 a(i+7+iscr)=a(i-1+iun) enddo a(iscr+8+nun1)=0 nw=3+nun1 call listio(0,ntp,0,a(iscr),nb,nw) is=iscr do while (nb.ne.0) is=is+nw if (is-iscr+1.gt.nwscr) & call error('colaps','storage exceeded.',' ') call moreio(0,ntp,0,a(is),nb,nw) enddo call afend(ntp,0) call tofend(ngout,0,0,a(iscr)) c c ***loop over all sections of this mat 210 call contio(ngout,0,0,a(iscr),nb,nw) if (math.eq.0) go to 390 cej if (mfh.eq.5.and.mth.eq.18) go to 300 cej if (mfh.ge.4) go to 380 if (mfh.eq.0.or.mth.eq.0) go to 210 a(iscr+5)=nunion call contio(0,ntp,0,a(iscr),nb,nw) nl=nint(a(iscr+2)) nz=nint(a(iscr+3)) if (nl.ne.1.or.nz.ne.1) call error('colaps', & 'not coded for multiple sigma zeroes or legendre orders.',' ') ib=0 inuf=0 if (mth.eq.452.or.mth.eq.455.or.mth.eq.456) inuf=1 c c ***skip over low energy groups in input grid. ea3=0 220 call listio(ngout,0,0,a(iscr),nb,nw) jg=n2h flxa=a(iscr+6) xnua=a(iscr+7) siga=a(iscr+7+inuf) ea1=ea3 ea2=a(iela-1+jg) ea3=a(iela+jg) if (ea3.le.a(iun)) go to 220 c c ***loop over output groups 230 ib=ib+1 xnub=0 sigb=0 flxb=0 el=a(iun-1+ib) 250 if (ea2.gt.a(iun+ib)) go to 280 if (ea2.gt.el) el=ea2 er=a(iun+ib) if (ea3.lt.er) er=ea3 flux=flxa*(er-el)/(ea3-ea2) xnub=xnub+siga*xnua*flux sigb=sigb+siga*flux flxb=flxb+flux if (ea3.gt.a(iun+ib)) go to 280 if (ea3.eq.a(iun+ib).and.ib.ge.nunion) go to 280 call listio(ngout,0,0,a(iscr),nb,nw) jg=n2h flxa=a(iscr+6) xnua=a(iscr+7) siga=a(iscr+7+inuf) ea1=ea3 ea2=a(iela-1+jg) ea3=a(iela+jg) el=ea1 if (ea1.eq.a(iun+ib)) go to 280 go to 250 c c ***write results for this group 280 if (sigb.eq.zero.and.ib.lt.nunion) go to 230 nw=2+inuf temp=0 a(iscr)=temp a(iscr+1)=0 a(iscr+2)=nw a(iscr+3)=1 a(iscr+4)=nw a(iscr+5)=ib a(iscr+6)=flxb a(iscr+7)=0 a(iscr+7+inuf)=0 if (sigb.ne.zero.and.flxb.ne.zero) then a(iscr+7)=xnub/sigb a(iscr+7+inuf)=sigb/flxb endif call listio(0,ntp,0,a(iscr),nb,nw) if (ib.lt.nunion) go to 230 call tosend(ngout,0,0,a(iscr)) call asend(ntp,0) cej go to 210 cej c ***fission spectrum (chi) 300 continue call repoz(ngout) call findf(matd,3,18,ngout) iscr18=iscr iscr=iscr+ng1 do i=iscr18,iscr18+ng1-1 a(i)=0.d0 enddo call contio(ngout,0,0,a(iscr),nb,nw) 310 call listio(ngout,0,0,a(iscr),nb,nw) jg=n2h a(iscr18+jg-1)=a(iscr+6) if (jg.lt.ng) go to 310 call findf(matd,5,18,ngout) call contio(ngout,0,0,a(iscr),nb,nw) a(iscr+5)=nunion call contio(0,ntp,0,a(iscr),nb,nw) ib=0 jg=0 ea3=0.d0 call listio(ngout,0,0,a(iscr),nb,nw) iscr0=iscr+nw 320 jg=jg+1 flxa=a(iscr18+jg-1) chia=a(iscr+5+jg) ea1=ea3 ea2=a(iela-1+jg) ea3=a(iela+jg) if (ib.eq.0) then if (ea3.le.a(iun)) go to 320 else el=ea1 if (ea1.eq.a(iun+ib)) go to 350 go to 340 endif 330 ib=ib+1 flxb=0.d0 chib=0.d0 el=a(iun-1+ib) 340 if (ea2.gt.a(iun+ib)) go to 350 if (ea2.gt.el) el=ea2 er=a(iun+ib) if (ea3.lt.er) er=ea3 flux=flxa*(er-el)/(ea3-ea2) chib=chib+chia*flux flxb=flxb+flux if (ea3.gt.a(iun+ib)) go to 350 if (ea3.eq.a(iun+ib).and.ib.ge.nunion) go to 350 go to 320 350 if (chib.eq.0.and.ib.lt.nunion) go to 330 nw=2 nwl=8 temp=0.d0 a(iscr0)=temp a(iscr0+1)=0.d0 a(iscr0+2)=nw a(iscr0+3)=1 a(iscr0+4)=nw a(iscr0+5)=ib a(iscr0+6)=flxb a(iscr0+7)=0.d0 if (chib.gt.0.and.flxb.gt.0) a(iscr0+7)=chib/flxb call listio(0,ntp,0,a(iscr0),nb,nw) if (ib.lt.nunion) go to 330 call tosend(ngout,0,0,a(iscr)) call asend(ntp,0) 380 call tomend(ngout,0,0,a(iscr)) call afend(ntp,0) 390 call amend(ntp,0) go to 110 c c ***finished 400 call atend(ntp,0) call repoz(ngout) call closz(ngout) c c ***now redefine ngout to be the colaps output tape ngout=ntp call repoz(ngout) call releas('scr',-1,a) return end c subroutine gridd(neki,a) c ****************************************************************** c read through mfcov in version 5 or 6 format and extract the union c energy grid for the derivation relations (nc-type sub-subsections c with lty=0), construct the matrix of derivation coefficients c and extract the union energy grid from ni-type sub-subsections c for fine-group covariance calculations. c ****************************************************************** implicit real*8 (a-h,o-z) common/mainio/nsysi,nsyso,nsyse,ntty common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr(3) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/util/npage,iverf common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) cej common/err4/legord,irespr,ifissp character*60 strng1,strng2 dimension a(*) dimension el(50),eh(50),nmtr(60),imtr(60),jak(60) data nxmax/250/, irmax/60/ c external merge data small/1.d-10/ data big/1.d10/ zero=0 c c ***allocate storage and initialize. if (iread.ne.1) then nwak=irmax*nmtmax*2 call reserv('ak',nwak,iak,a) endif nwscr=2*npage+50 call reserv('scr',nwscr,iscr,a) call reserv('x',nxmax,ix,a) call findex('eni',ieni,a) if (iread.eq.0) call findex('ak',iak,a) call findex('scr',iscr,a) call findex('x',ix,a) ix1=ix-1 neki=0 neni=0 ir=0 nmtt=nmt1 call repoz(nendf) call tpidio(nendf,0,0,a(iscr),nb,nw) call findf(matd,mfcov,0,nendf) c c ***loop over sections. 110 call contio(nendf,0,0,a(iscr),nb,nw) if (mf.eq.0.and.iread.eq.1) go to 610 if (mf.eq.0) go to 450 c ***ignore components of a lumped reaction cej if (mfcov.eq.35) then nsub=n1h else nsub=n2h endif c if (nsub.eq.0) go to 410 if (iread.ne.1) go to 130 do 120 i=1,nmt if (mt.eq.mts(i)) go to 160 120 continue go to 420 130 nmt=nmt+1 nmt1=nmt1+1 if (nmt1.gt.nmtmax) call error('gridd', & 'too many reaction types.',' ') if (iread.eq.2) then do i=1,nmtt mats(nmt+nmtt+1-i)=mats(nmt+nmtt-i) mts(nmt+nmtt+1-i)=mts(nmt+nmtt-i) enddo endif mats(nmt)=0 mts(nmt)=mt 160 continue cej if (mfcov.eq.34) then if (nsub.gt.1) call error('gridd', & 'not coded for nmt1>1 of mf=34',' ') ltt=l2h call contio(nendf,0,0,a(iscr),nb,nw) mat2=l1h mt2=l2h nl=n1h nl1=n2h nsub=nl*nl1 if (mt.eq.mt2) nsub=nl*(nl+1)/2 endif c c ***loop over subsections. do 300 isub=1,nsub cej if (mfcov.ne.35) call contio(nendf,0,0,a(iscr),nb,nw) if (mfcov.eq.34.and.mt.eq.0) go to 110 if (mfcov.eq.34) then mat1=mat2 mt1=mt2 ld=l1h ld1=l2h elseif (mfcov.eq.35) then mat1=0 mt1=mt else mat1=l1h mt1=l2h endif c if (mt1.eq.0) call error('grid','illegal mt1=0.',' ') iok=1 if (iread.gt.0) go to 161 if (mat1.gt.0) go to 175 go to 180 161 if (iread.gt.1) go to 165 if (mat1.gt.0) go to 175 do 162 i=1,nmt if (mt1.eq.mts(i)) go to 180 162 continue go to 175 165 if (mat1.eq.0) go to 180 nmtp=nmt+1 do 170 i=nmtp,nmt1 if (mat1.eq.mats(i).and.mt1.eq.mts(i)) go to 180 170 continue c ***covariance matrix for mat1-mt1 is present in mfcov , but is c ***not wanted by user. flag this case by setting iok=0, in order c ***to avoid adding unnecessary points to the union energy grid. 175 iok=0 180 continue cej if (mfcov.eq.35) then nc=0 ni=1 else nc=n1h ni=n2h endif c if (nc.eq.0) go to 290 c c ***loop over nc sub-subsections do 210 ic=1,nc call contio(nendf,0,0,a(iscr),nb,nw) lty=l2h if (lty.gt.3) go to 960 call listio(nendf,0,0,a(iscr),nb,nw) l=iscr 220 do while (nb.ne.0) l=l+nw call moreio(nendf,0,0,a(l),nb,nw) enddo continue if (iok.eq.0) go to 210 cej if (mfcov.eq.34) then if (ld.gt.legord.or.ld1.gt.legord) go to 210 endif nt=2 call merge(a(iscr),nt,nxmax,a(ieni),neni,nenimx,ndig,zero,zero) elh=sigfig(c1h,ndig,0) ehh=sigfig(c2h,ndig,0) if (lty.eq.0) go to 260 matstd=l1h mtstd=l2h if (nstan.eq.0) go to 950 if (lty.eq.1) call grist(matstd,mtstd,nxmax,elh,ehh,a) zero=0 if (lty.eq.2) call grist(matstd,mtstd,nxmax,zero,zero,a) go to 210 260 continue if (iread.eq.1) go to 210 ir=ir+1 if (ir.gt.irmax) call error('grid', & 'too many formulas in nc-type sub-subsections with lty=0.', & ' ') imtr(ir)=nmt el(ir)=elh eh(ir)=ehh nmtr(ir)=n2h if (n2h.gt.nmtmax) call error('grid', & 'too many mt-numbers in nc-type subsections with lty=0.', & ' ') c c ***save the derivation formula for later processing. jtop=n1h jmax=2*nmtmax jaki=iak+jmax*(ir-1)-1 do j=1,jtop a(j+jaki)=a(j+5+iscr) enddo nt=2 call merge(a(iscr),nt,nxmax,ek,neki,nkmax,ndig,zero,zero) 210 continue 290 if (ni.eq.0) go to 300 c c ***loop over ni sub-subsections do 350 ii=1,ni call listio(nendf,0,0,a(iscr),nb,nw) l=iscr do while (nb.ne.0) l=l+nw call moreio(nendf,0,0,a(l),nb,nw) enddo continue cej if (mfcov.eq.35.and.ifissp.eq.-1) then if (c1h.le.2.d+5.and.c2h.ge.2.d+5) ifissp=isub endif c if (iok.eq.0) go to 350 cej if (mfcov.eq.34) then if (ld.gt.legord.or.ld1.gt.legord) go to 350 endif nx=n2h lb=l2h if (lb.lt.5.or.lb.eq.8) go to 325 call merge(a(iscr+6),nx,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) if (lb.eq.5) go to 350 if (mfcov.eq.35.and.lb.eq.7) go to 350 nec=(n1h-1)/nx iloc=iscr+6+nx call merge(a(iloc),nec,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) go to 350 325 continue do i=1,nx a(i+ix1)=a(2*i+4+iscr) enddo nl=l1h nx=nx-nl 340 call merge(a(ix),nx,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) call merge(a(ix+nx),nl,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) 350 continue 300 continue 410 call contio(nendf,0,0,a(iscr),nb,nw) go to 110 420 call tosend(nendf,0,0,a(iscr)) go to 110 c c ***set up coefficients for derived cross sections. 450 continue call releas('eni',neni,a) call repoz(nendf) call tpidio (nendf,0,0,a(iscr),nb,nw) nek=neki-1 if (neki.eq.0) nek=1 nmt2=nmt1*nmt1 nw=nek*nmt2 call reserv('kxy',nw,ikxy,a) do ik=1,nek do i=1,nmt1 do j=1,nmt1 ja=ikxy+j-1+nmt1*(i-1)+nmt2*(ik-1) a(ja)=0 if (i.eq.j) a(ja)=1 enddo enddo enddo if (neki.gt.0) go to 500 ek(1)=small ek(2)=big go to 600 c c ***reconstruct full akxy table. 500 nr=ir do 590 ir=1,nr irs=ir ilo=0 510 ilo=ilo+1 if (el(ir).eq.ek(ilo)) go to 520 go to 510 520 ihi=ilo 530 ihi=ihi+1 if (eh(ir).eq.ek(ihi)) go to 540 go to 530 540 ihi=ihi-1 ntr=nmtr(ir) do 560 nim=1,ntr ixm=nint(a(iak+jmax*(ir-1)+2*nim-1)) do 550 i=1,nmt jak(nim)=i if (ixm.eq.mts(i)) go to 560 550 continue write(strng1, & '(''mt'',i4,'' referenced in derivation formula'')') ixm write(strng2, & '(''for range '',i2,'' does not appear in mfcov'')') irs call error('gridd',strng1,strng2) call findex('ak',iak,a) 560 continue ider=imtr(ir) nder=nmtr(ir) do i=ilo,ihi ja=ikxy+nmt2*(i-1)+nmt1*(ider-1)-1 ka=iak-2+jmax*(ir-1) do j=1,nder jakj=jak(j) a(jakj+ja)=a(2*j+ka) enddo a(ider+ja)=0 enddo 590 continue 600 call releas('ak',0,a) 610 call releas('scr',0,a) call releas('x',0,a) return c c ***error messages. 950 write(nsyso,50) mt,mt1,matstd,mtstd write(nsyse,50) mt,mt1,matstd,mtstd 50 format(/,' ***error in grid***cannot calculate covariances of ', & 'reaction mt=',i3,' with',/,4x,'mt1=',i3, & ' because nstan=0. to proceed, mount an endf tape ', & 'containing',/,4x,'the standard', & ' reaction (matstd=',i4,', mtstd=',i3,') on unit nstan.',/, & 4x,'if necessary matstd and mtstd can be redefined on input ', & 'card 11.') call error('gridd',' ',' ') 960 write(nsyso,60) mt,mat1,mt1,lty write(nsyse,60) mt,mat1,mt1,lty 60 format(/,' ***error in grid***covariances of reaction mt=',i3, & ' with (mat1=',i4,' mt1=',i3,')',/, & 4x,'cannot be calculated. not coded for lty=',i3) call error('gridd',' ',' ') return end c subroutine resprp(nwscr,a) c ****************************************************************** c prepare tables containing the resonance-parameter contributions c to coarse-group covariances. c ****************************************************************** c (ERRORJ) c Many parts are modefied. c ****************************************************************** implicit real*8 (a-h,o-z) cej parameter (nparmx=60,igumax=20) common/err0/nresg cej common/err3/ifresr,ifunrs common/eunits/nendf,nunit(8) common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/grpn/ign,ngn,egn(901),iprint common/ewght/iwt common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/util/npage,iverf common/pic/pi common/cwav/cwaven common/amnc/amassn character*60 strng1,strng2 dimension a(*) dimension s(3,5),cov(5,5),rcov(nparmx,nparmx),us(3,nparmx,igumax) equivalence (cov,rcov),(s,us) zero=0 c nresg=0 cej ifresr=0 ifunrs=0 if (mfcov.ne.33.and.mfcov.ne.34) return c if (mf32.eq.0) return call findex('cff',icff,a) call findex('cfg',icfg,a) call findex('cgg',icgg,a) call findex('cee',icee,a) call findex('cef',icef,a) call findex('ceg',iceg,a) call findex('ctt',ictt,a) call findex('uff',iuff,a) call findex('ufg',iufg,a) call findex('ugg',iugg,a) call findex('uee',iuee,a) call findex('scr',iscr,a) call findex('cflx',icflx,a) c c ***initialize call repoz(nendf) call tpidio(nendf,0,0,a(iscr),nb,nw) do 100 ig=1,ngn a(icff-1+ig)=0. a(icfg-1+ig)=0. a(icgg-1+ig)=0. a(icef-1+ig)=0. a(iceg-1+ig)=0. a(icee-1+ig)=0. a(ictt-1+ig)=0. a(iuff-1+ig)=0. a(iufg-1+ig)=0. a(iugg-1+ig)=0. a(iuee-1+ig)=0. 100 continue call findf(matd,32,151,nendf) call contio(nendf,0,0,a(iscr),nb,nw) nis=n1h c c ***loop over isotopes do 110 is=1,nis call contio(nendf,0,0,a(iscr),nb,nw) abn=c2h ner=n1h lfw=0 if (iverf.eq.6) lfw=n1h c c ***loop over energy ranges do 115 ie=1,ner call contio(nendf,0,0,a(iscr),nb,nw) el=c1h eh=c2h lru=l1h lrf=l2h if (lru.eq.1.and.lrf.ge.1.and.lrf.le.2) go to 116 if (lru.eq.2.and.lrf.ge.1.and.lrf.le.2) go to 116 write(strng2,'(''lrf='',i4,'' lru='',i4)') lrf,lru call error('resprp', & 'illegal or unrecognized data structure in mf32',strng2) 116 continue if (lru.eq.1.and.lrf.eq.1) call mess('resprp', & 'for resolved resonance of single level breit-wigner,', & 'contributions to total and elastic was not coded.') nro=n1h if (nro.ne.0) then write(strng2,'(''nro='',i4)') nro call error('resprp', & 'illegal or unrecognized data structure in mf32', & strng2) endif naps=n2h call contio(nendf,0,0,a(iscr),nb,nw) spi=c1h spifac=1/(2*spi+1) ap=c2h lcomp=l2h if (lcomp.ne.0) then write(strng2,'(''lcomp='',i4)') lcomp call error('resprp', & 'illegal or unrecognized data structure in mf32', & strng2) endif nls=n1h if (lru.eq.2) go to 400 c c ***resolved resonance parameters c c ***process all resonance parameters for this isotope do 120 nl=1,nls c ***read parameters for this l-value call listio(nendf,0,0,a(iscr),nb,nw) l=iscr 130 if (nb.eq.0) go to 140 l=l+nw call moreio(nendf,0,0,a(l),nb,nw) if ((l+nw-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') & l+nw+nb-iscr,nwscr call error('resprp','storage exceeded.',strng2) endif go to 130 140 awri=a(iscr) l=nint(a(iscr+2)) nrs=nint(a(iscr+5)) xk=cwaven*awri/(awri+1.d+0) x2=2.*(pi/xk)**2 aw=amassn*awri ra=0.123d+0*aw**(1./3.)+0.08d+0 if (naps.eq.1) ra=ap iloc=iscr+6 c c ***loop over resonances do 150 nr=1,nrs er=a(iloc) aj=a(iloc+1) gt=a(iloc+2) rgt=1/gt gn=a(iloc+3) gg=a(iloc+4) gf=a(iloc+5) c ***index energy group if (er.lt.egn(1)) go to 155 if (er.ge.egn(ngn+1)) go to 120 do 160 i=1,ngn ig=i if (er.lt.egn(i+1)) go to 170 160 continue c c ***calculate fission and capture covariances in group ig c ***due to this resonance 170 if (ig.gt.nresg) nresg=ig if (iwt.eq.0) go to 180 c ***retrieve user's weight function at er lord=0 call egtwtf(er,enext,idis,lord,wt,a) go to 190 c ***if weight function is unavailable, flat weight the resonance 180 wt=a(icflx-1+ig)/(egn(ig+1)-egn(ig)) 190 g=(aj+.5)*spifac c=abn*wt*x2*g/er c ***estimate fission and capture cross section contributions c ***from this resonance sf=c*gn*gf*rgt sg=c*gn*gg*rgt se=c*gn*gn*rgt c ***calculate sensitivity of sf, sg and se to resonance parameters s(1,1)=-sf/er s(2,1)=-sg/er s(3,1)=-se/er s(1,2)=sf*(1./gn-rgt) s(2,2)=sg*(1./gn-rgt) s(3,2)=se*(2./gn-rgt) s(1,3)=-sf*rgt s(2,3)=sg*(1./gg-rgt) s(3,3)=-se*rgt s(1,4)=0. if (gf.gt.0.) s(1,4)=sf*(1./gf-rgt) s(2,4)=-sg*rgt s(3,4)=-se*rgt s(1,5)=sf/(aj+.5) s(2,5)=sg/(aj+.5) s(3,5)=se/(aj+.5) c ***retrieve resonance parameter covariances from the list record do 200 i=1,5 do 200 j=1,5 200 cov(i,j)=0. iloc=iloc+6 cov(1,1)=a(iloc) do 210 i=2,5 do 210 j=2,i iloc=iloc+1 cov(i,j)=a(iloc) 210 cov(j,i)=a(iloc) c ***check covariance matrix for validity if (iverf.lt.6) go to 214 do 212 i=1,5 id=i jd=5 if (cov(i,5).ne.0.) go to 235 212 continue 214 continue do 220 i=1,5 id=i jd=i if (cov(i,i).lt.0.) go to 235 220 continue do 230 i=1,5 id=i do 230 j=1,5 jd=j if (cov(i,i).gt.0.and.cov(j,j).gt.0.) go to 240 if (cov(i,j).ne.0.) go to 235 go to 230 240 corr=cov(i,j)/sqrt(cov(i,i)*cov(j,j)) if (abs(corr).lt.1.0001) go to 230 if (abs(corr).gt.2.) go to 235 write(strng1,'(''correlation coeff='',f8.4)') & corr write(strng2, & '(''for res parameters '',i1,'' and '',i1, & ''at er='',1p,e12.4)')i,j,er call mess('resprp',strng1,strng2) 230 continue go to 236 235 write(strng2, & '(''res parameters '',i1,'' and '',i1, & '' at er='',1p,e12.4)')id,jd,er call error('resprp','bad covariance data for',strng2) c c ***calculate cross section covariances by propagation of errors 236 continue do 250 i=1,5 do 250 j=1,5 a(icff-1+ig)=a(icff-1+ig)+s(1,i)*s(1,j)*cov(i,j) a(icfg-1+ig)=a(icfg-1+ig)+s(1,i)*s(2,j)*cov(i,j) a(icgg-1+ig)=a(icgg-1+ig)+s(2,i)*s(2,j)*cov(i,j) a(icef-1+ig)=a(icef-1+ig)+s(1,i)*s(3,j)*cov(i,j) a(iceg-1+ig)=a(iceg-1+ig)+s(2,i)*s(3,j)*cov(i,j) a(icee-1+ig)=a(icee-1+ig)+s(3,i)*s(3,j)*cov(i,j) 250 continue a(ictt-1+ig)=a(icee-1+ig)+a(icff-1+ig)+a(icgg-1+ig) go to 150 155 iloc=iloc+16 150 iloc=iloc+2 120 continue ifresr=1 go to 115 c c ***unresolved average breit-wigner resonance parameter c c ***process averaged l- and j-states resonance parameters for this c ***isotope 400 continue emid=exp(log(el*eh)/2.d+0) do 410 i=1,ngn igmin=i 410 if (el.lt.egn(i+1)) go to 411 write(strng2,'(''el='',1pe12.5)') el call error('resprp','unresolved energy range was illegal.', & strng2) 411 do 412 i=igmin,ngn igmax=i 412 if (eh.lt.egn(i+1)) go to 413 write(strng2,'(''eh='',1pe12.5)') eh call error('resprp','unresolved energy range was illegal.', & strng2) 413 continue if (igmax.gt.nresg) nresg=igmax c ***read resonance parameters for each l-value iscr01=iscr do 420 nl=1,nls call listio(nendf,0,0,a(iscr01),nb,nw) 425 iscr01=iscr01+nw if (nb.eq.0) go to 420 call moreio(nendf,0,0,a(iscr01),nb,nw) if ((iscr01+nw-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') & iscr01+nw+nb-iscr,nwscr call error('resprp','storage exceeded (lru=2).', & strng2) endif go to 425 420 continue c ***read relative covariance from list record call listio(nendf,0,0,a(iscr01),nb,nw) l=iscr01 430 if (nb.eq.0) go to 435 l=l+nw call moreio(nendf,0,0,a(l),nb,nw) if ((l+nw-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') & l+nw+nb-iscr,nwscr call error('resprp','storage exceeded (lru=2).',strng2) endif go to 430 435 continue c ***retrieve relative covariance mpar=nint(a(iscr01+2)) nw=nint(a(iscr01+4)) npar=nint(a(iscr01+5)) jpar=npar/mpar if (mpar.lt.3.or.mpar.gt.5) then write(strng1,'(''mpar='',i2,'' was not coded.'')') mpar call error('resprp',strng1,' ') endif if (npar.gt.nparmx) then write(strng2,'(''npar='',i5,'' maximum='',i5)') & npar,nparmx call error('resprp', & 'storage exceeded for rel.covariance.', & strng2) endif iloc=iscr01+5 do i=1,npar do j=i,npar iloc=iloc+1 rcov(i,j)=a(iloc) rcov(j,i)=a(iloc) enddo enddo c ***check covariance matrix for validity do i=1,npar id=i jd=i if (rcov(i,i).lt.0.) go to 440 enddo go to 445 440 write(strng2,'(''res parameters '',i1,'' and '',i1)')id,jd call error('resprp','bad rel.covariance data for',strng2) 445 continue c c ***loop over l-state jscr=iscr nj0=0 do 450 nl=1,nls awri=a(jscr) l=nint(a(jscr+2)) njs6=nint(a(jscr+4)) njs=nint(a(jscr+5)) xk=cwaven*awri/(awri+1.d+0) x2=2.*(pi/xk)**2 aw=amassn*awri ra=0.123d+0*aw**(1./3.)+0.08d+0 if (naps.eq.1) ra=ap iloc=jscr+6 c c ***loop over j-states do 460 nj=1,njs d=a(iloc) aj=a(iloc+1) gnox=a(iloc+2) gg=a(iloc+3) gf=a(iloc+4) gx=a(iloc+5) iloc=iloc+6 nj0=nj0+1 nj1=mpar*(nj0-1) g=(aj+0.5d+0)*spifac cc=abn*g*x2/d c0=abn*x2 do 470 ig=igmin,igmax e1=egn(ig) e2=egn(ig+1) if (ig.eq.igmin.and.ig.eq.igmax) then f=(eh-el)/(egn(ig+1)-egn(ig)) e1=el e2=eh elseif (ig.eq.igmin) then f=(egn(ig+1)-el)/(egn(ig+1)-egn(ig)) e1=el elseif (ig.eq.igmax) then f=(eh-egn(ig))/(egn(ig+1)-egn(ig)) e2=eh else f=1.d+0 endif em=(e2+e1)*0.5d+0 if (iwt.eq.0) then wt=a(icflx-1+ig)/emid else lord=0 call egtwtf(em,enext,idis,lord,wt,a) endif wt=wt*f rhoc=xk*sqrt(e1)*ap call facphi(l,rhoc,phi1) rhoc=xk*sqrt(e2)*ap call facphi(l,rhoc,phi2) phi=(phi1+phi2)*0.5d+0 c ***correction of penetrability for reduced neutron width if (l.eq.0) then gno=gnox*sqrt(em) elseif (l.eq.1) then rho=xk*sqrt(em)*ra gno=gnox*rho**2/(1.d+0+rho**2)*sqrt(em) elseif (l.eq.2) then rho=xk*sqrt(em)*ra gno=gnox*rho**4/(9.d+0+3.d+0*rho**2+rho**4)* & sqrt(em) endif gt=gno+gg+gf+gx rgn=1.d+0/gno rgt=1.d+0/gt c=cc*gno/gt/emid c ***estimate cross section contributions sf=c*wt*gf sg=c*wt*gg se=c*wt*gno se1=c0*wt*2.d+0*gno*sin(phi)**2/emid c ***calculate sensitivity, s(i,j) c i=1/2/3=fission/capture/elastic c j=1/2/3/4/5=d/gn/gf/gg/gx igu=ig-igmin+1 if (igu.gt.igumax) then write(strng2,'(''igu='',i5,'' maximum='',i5)') & igu,igumax call error('resprp', & 'storage exceeded for sensitivities.' & ,strng2) endif us(1,nj1+1,igu)=-sf/d us(2,nj1+1,igu)=-sg/d us(3,nj1+1,igu)=-se/d if (mpar.eq.1) go to 470 us(1,nj1+2,igu)=sf*(rgn-rgt) us(2,nj1+2,igu)=sg*(rgn-rgt) us(3,nj1+2,igu)=se*(2.d+0*rgn-rgt) if (mpar.eq.2) go to 470 us(1,nj1+3,igu)=-sf*rgt us(2,nj1+3,igu)=sg*(1.d+0/gg-rgt) us(3,nj1+3,igu)=-se*rgt if (mpar.eq.3) go to 470 if (mpar.eq.4.and.lfw.eq.0) then us(1,nj1+4,igu)=-sf*rgt us(2,nj1+4,igu)=-sg*rgt us(3,nj1+4,igu)=-se*rgt go to 470 endif us(1,nj1+4,igu)=0.d+0 if (gf.gt.0.) us(1,nj1+4,igu)=sf*(1.d+0/gf-rgt) us(2,nj1+4,igu)=-sg*rgt us(3,nj1+4,igu)=-se*rgt if (mpar.eq.4) go to 470 us(1,nj1+5,igu)=-sf*rgt us(2,nj1+5,igu)=-sg*rgt us(3,nj1+5,igu)=-se*rgt 470 continue 460 continue jscr=jscr+njs6+6 450 continue c c ***calculate relative covariance cross sections do 480 ig=igmin,igmax igu=ig-igmin+1 do 490 i=1,npar do 490 j=1,npar a(iuff-1+ig)=a(iuff-1+ig) + & us(1,i,igu)*us(1,j,igu)*rcov(i,j) a(iufg-1+ig)=a(iufg-1+ig) + & us(1,i,igu)*us(2,j,igu)*rcov(i,j) a(iugg-1+ig)=a(iugg-1+ig) + & us(2,i,igu)*us(2,j,igu)*rcov(i,j) a(iuee-1+ig)=a(iuee-1+ig) + & us(3,i,igu)*us(3,j,igu)*rcov(i,j) 490 continue 480 continue ifunrs=1 c c ***finished with this material 115 continue 110 continue return end c subroutine rescon(ix,ixp,igmin,igmax,isuma,izero,a) c ****************************************************************** c add the contributions from file 32 (see subroutine resprp) c to the covariance previously calculated from file 33 c for this range of coarse groups. c increment diagonal term only (igp=ig). c ****************************************************************** c (ERRORJ) c Many parts were revised from original routine in ERRORR. c ****************************************************************** implicit real*8 (a-h,o-z) common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err0/nresg common/grpn/ign,ngn,egn(901),iprint cej common/err3/ifresr,ifunrs common/err4/legord,irespr,ifissp c dimension a(*) zero=0 c if (mats(ixp).ne.0) return if (igmin.gt.nresg) return call findex('cff',icff,a) call findex('cfg',icfg,a) call findex('cgg',icgg,a) cej call findex('cee',icee,a) call findex('cef',icef,a) call findex('ceg',iceg,a) call findex('ctt',ictt,a) call findex('uff',iuff,a) call findex('ufg',iufg,a) call findex('ugg',iugg,a) call findex('uee',iuee,a) call findex('uef',iuef,a) call findex('ueg',iueg,a) call findex('utt',iutt,a) call findex('sum',isum,a) c itp=0 if (mts(ix).eq.18 .and.mts(ixp).eq.18 ) itp=1 if (mts(ix).eq.18 .and.mts(ixp).eq.102) itp=2 if (mts(ix).eq.102.and.mts(ixp).eq.102) itp=3 cej if (mts(ix).eq.2 .and.mts(ixp).eq.2 ) itp=4 if (mts(ix).eq.2 .and.mts(ixp).eq.18 ) itp=5 if (mts(ix).eq.2 .and.mts(ixp).eq.102) itp=6 if (mts(ix).eq.1 .and.mts(ixp).eq.1 ) itp=7 c if (itp.eq.0) return iglast=igmax if (iglast.gt.nresg) iglast=nresg jpos=-ngn*igmin cej if (ifresr.eq.0) go to 1000 go to (100,200,300,400,500,600,700),itp c c ***fission/fission 100 igind=0 do 110 ig =1,iglast do 110 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto110 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(icff-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(icff-1+igind) endif 110 continue go to 1000 c c ***fission/capture 200 do 210 ig =1,ngn do 210 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 210 a(isuma+ipos)=a(isuma+ipos)+a(icfg+igd) go to 1000 c c ***capture/capture 300 igind=0 do 310 ig =1,iglast do 310 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto310 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(icgg-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(icgg-1+igind) endif 310 continue go to 1000 c c ***elastic/elastic 400 igind=0 do 410 ig =1,iglast do 410 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto410 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(icee-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(icee-1+igind) endif 410 continue go to 1000 c c ***elastic/fission 500 do 510 ig =1,ngn do 510 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 510 a(isuma+ipos)=a(isuma+ipos)+a(icef+igd) go to 1000 c c ***elastic/capture 600 do 610 ig =1,ngn do 610 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 610 a(isuma+ipos)=a(isuma+ipos)+a(iceg+igd) go to 1000 c c ***total/total 700 igind=0 do 710 ig =1,iglast do 710 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto710 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(ictt-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(ictt-1+igind) endif 710 continue go to 1000 c c ***unresolved resonance contribution 1000 continue if (ifunrs.eq.0) go to 2000 if (irespr.eq.1) go to 1090 c ***convert to absolute covariance from relative if (ifunrs.eq.1) then ifunrs=2 iif=0 iig=0 do i=1,nmt if (mts(i).eq.2) go to 1010 enddo go to 1020 1010 ii=isum+ngn*(i-1) igind=0 do ig=1,ngn do ig2=ig,ngn igind=igind+1 if (a(ii+ig-1).le.0.) then a(iuee-1+igind)=0.d+0 else a(iuee-1+igind)=a(iuee-1+igind) & *a(ii+ig-1)*a(ii+ig2-1) endif enddo enddo 1020 do i=1,nmt if (mts(i).eq.18) go to 1030 enddo go to 1040 1030 ii=isum+ngn*(i-1) iif=ii igind=0 do ig=1,ngn do ig2=ig,ngn igind=igind+1 if (a(ii+ig-1).le.0.) then a(iuff-1+igind)=0.d+0 else a(iuff-1+igind)=a(iuff-1+igind) & *a(ii+ig-1)*a(ii+ig2-1) endif enddo enddo 1040 do i=1,nmt if (mts(i).eq.102) go to 1050 enddo go to 1060 1050 ii=isum+ngn*(i-1) iig=ii igind=0 do ig=1,ngn do ig2=1,ngn if (a(ii+ig-1).le.0.) then a(iugg-1+igind)=0.d+0 else a(iugg-1+igind)=a(iugg-1+igind) & *a(ii+ig-1)*a(ii+ig2-1) endif enddo enddo 1060 if (iig.gt.0.and.iif.gt.0) then do ig=1,ngn if (a(iig+ig-1).le.0..or.a(iif+ig-1).le.0.) then a(iufg-1+ig)=0.d+0 else a(iufg-1+ig)=a(iufg-1+ig)*a(iig+ig-1)*a(iif+ig-1) endif enddo else do ig=1,ngn a(iufg-1+ig)=0.d+0 enddo endif endif 1090 continue go to (1100,1200,1300,1400,1500,1600,1700),itp c c ***fission/fission 1100 igind=0 do 1110 ig=1,iglast do 1110 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1110 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iuff-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iuff-1+igind) endif 1110 continue go to 2000 c c ***fission/capture 1200 do 1210 ig =1,ngn do 1210 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 1210 a(isuma+ipos)=a(isuma+ipos)+a(iufg+igd) go to 2000 c c ***capture/capture 1300 igind=0 do 1310 ig=1,iglast do 1310 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1310 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iugg-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iugg-1+igind) endif 1310 continue go to 2000 c c ***elastic/elastic 1400 igind=0 do 1410 ig=1,iglast do 1410 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1410 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iuee-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iuee-1+igind) endif 1410 continue go to 2000 c c ***elastic/fission 1500 do 1510 ig =1,ngn do 1510 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 1510 a(isuma+ipos)=a(isuma+ipos)+a(iuef+igd) go to 2000 c c ***elastic/capture 1600 do 1610 ig =1,ngn do 1610 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 1610 a(isuma+ipos)=a(isuma+ipos)+a(iueg+igd) go to 2000 c c ***total/total 1700 continue if (irespr.eq.0) then igind=0 do 1710 ig=1,iglast do 1710 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1710 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iuee-1+igind) & +a(iugg-1+igind) & +a(iuff-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iuee-1+igind) & +a(iugg-1+igind) & +a(iuff-1+igind) endif 1710 continue elseif (irespr.eq.1) then igind=0 do 1720 ig=1,iglast do 1720 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1720 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iutt-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iutt-1+igind) endif 1720 continue endif go to 2000 c c ***check for nonzero array 2000 do 2010 ig=igmin,igmax ipos=jpos+ig*(ngn+1) if (a(isuma-1+ipos).ne.0) izero=1 if (izero.eq.1) go to 2100 2010 continue c c ***finished 2100 continue return end subroutine egtflx(e,enext,idis,flux,nl,nz,a) c ****************************************************************** c retrieve or compute weighting fluxes c ****************************************************************** implicit real*8 (a-h,o-z) dimension flux(10,10) dimension tot(10) common/util/npage,iverf common/argcom/matd,mfd,mtd common/eunits/nunit(7),ntot,nscrt common/sigzer/sigz(10),nsigz dimension a(*) external egtwtf,findf,reserv,contio,gety2 data big/1.d10/ zero=0 c c ***initialize. c ***test for infinite dilution (i.e., ntot=0) if (e.gt.zero.and.ntot.eq.0) go to 120 if (e.gt.zero) go to 100 call egtwtf(e,en,idis,l,wtf,a) if (ntot.eq.0) return call findf(matd,3,1,ntot) nw=npage+50 call reserv('tot',nw,itot,a) call contio(ntot,0,0,a(itot),nb,nw) call gety2(e,enext,idis,t,ntot,a(itot)) return c c ***compute self-shielded point flux assuming flux c ***is proportional to the inverse total cross section. 100 call findex('tot',itot,a) call gety2(e,enext,idis,t,ntot,a(itot)) do iz=1,nz tot(iz)=t enddo go to 130 120 enext=big 130 do il=1,nl l=il-1 call egtwtf(e,en,idisc,l,wtf,a) if (en.lt.enext) idis=idisc if (en.lt.enext) enext=en do iz=1,nz flux(iz,il)=wtf if (ntot.ne.0) then tmin=1 tmin=tmin/1000 if (tot(iz).le.zero) tot(iz)=tmin if (il.eq.1) then flux(iz,1)=flux(iz,1)/(1+tot(iz)/sigz(iz)) else flux(iz,il)=flux(iz,il-1)/(1+tot(iz)/sigz(iz)) endif endif enddo enddo return end c subroutine egtsig(e,enext,idis,sig,a) c ****************************************************************** c retrieve the reaction cross-section defined by mfd and mtd. c remove discontinuities by moving second point up by eps. c initialize if e=0. c ****************************************************************** implicit real*8 (a-h,o-z) dimension sig(*) common/eunits/nendf,npend,nunit(7) common/argcom/matd,mfd,mtd common/sigzer/sigz(10),nsigz common/util/npage,iverf dimension a(*) external error,findf,reserv,contio,gety1,findex save nsig zero=0 c c ***initialize if (e.eq.zero) then nsig=npend mf=3 if (mfd.eq.13.or.mfd.eq.17) mf=13 mt=0 if (mtd.le.150) mt=mtd if (mtd.eq.207) mt=mtd if (mtd.ge.600.and.mtd.le.899) mt=mtd if (mtd.eq.251.or.mtd.eq.252.or.mtd.eq.253) mt=2 if (mt.eq.0) call error('egtsig','mt=0.',' ') call findf(matd,mf,mt,nsig) nw=npage+50 call reserv('sig',nw,isig,a) call contio(nsig,0,0,a(isig),nb,nw) call gety1(e,enext,idis,s,nsig,a(isig)) c c ***retrieve point cross sections. else call findex('sig',isig,a) call gety1(e,enext,idis,s,nsig,a(isig)) do iz=1,nsigz sig(iz)=s enddo endif return end c subroutine grist(matstd,mtstd,nxmax,el,eh,a) c ****************************************************************** c merge the energy grid from the standard tape nstan into the union c energy grid from nendf. c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr1,nscr2,nscr3 common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/redef/nas,matb(5),mtb(5),matc(5),mtc(5) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/ety/ety1,ety2 character*60 strng dimension a(*) external findex,repoz,tpidio,mess,findf,contio,error external listio,moreio,sigfig,merge data small/1.d-10/ c call findex('scr',iscr,a) call findex('eni',ieni,a) call findex('x',ix,a) call repoz(nstan) call tpidio(nstan,0,0,a(iscr),nb,nw) c c ***redefine standard if necessary if (nas.eq.0) go to 110 do 100 i=1,nas if (matstd.ne.matb(i).or.mtstd.ne.mtb(i)) go to 100 write(strng,'(''standards reaction (,'',i4,'','',i3, & '') replaced by ('',i4,'','',i3,'')'')') & matstd,mtstd,matc(i),mtc(i) call mess('grist',strng,' ') matstd=matc(i) mtstd=mtc(i) go to 110 100 continue 110 call findf(matstd,mfcov,mtstd,nstan) call contio(nstan,0,0,a(iscr),nb,nw) nsub=n2h if (nsub.le.0) call error('grist','standards tape bad.',' ') c c ***loop over subsections do 200 il=1,nsub call contio(nstan,0,0,a(iscr),nb,nw) mat1=l1h mt1=l2h nc=n1h ni=n2h if (nc.eq.0) go to 140 c c ***read and merge energies from the nc-type sub-subsections do ic=1,nc call contio(nstan,0,0,a(iscr),nb,nw) lty=l2h call listio(nstan,0,0,a(iscr),nb,nw) do while (nb.ne.0) call moreio(nstan,0,0,a(iscr+2),nb,nw) enddo if (il.ne.1) then if (mat1.eq.matc(1).and.mt1.eq.mtc(1).and.lty.eq.3) then ety1=sigfig(c1h,ndig,0) ety2=sigfig(c2h,ndig,0) nt=2 zero=0 call merge(a(iscr),nt,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) endif endif enddo c c ***read and merge the energies from the ni sub-subsections 140 if (ni.eq.0.and.il.eq.1) then write(strng,'(''matstd='',i4,'', mtstd='',i3)') matstd,mtstd call error('grist','illegal ni=0 in the standard',strng) endif if (ni.eq.0) go to 200 do 150 ii=1,ni call listio(nstan,0,0,a(iscr),nb,nw) l=iscr do while (nb.ne.0) l=l+nw call moreio(nstan,0,0,a(l),nb,nw) enddo continue if (il.gt.1) go to 150 lb=l2h nx=n2h if (lb.eq.0) call error('grist','illegal lb=0.',' ') if (lb.lt.5.or.lb.eq.8) go to 175 call merge(a(iscr+6),nx,nxmax,a(ieni),neni,nenimx,ndig, & el,eh) if (lb.eq.5) go to 150 nec=(n1h-1)/nx iloc=iscr+6+nx call merge(a(iloc),nec,nxmax,a(ieni),neni,nenimx,ndig,el,eh) go to 150 175 continue do i=1,nx a(i-1+ix)=a(2*i+4+iscr) enddo nl=l1h nx=nx-nl call merge(a(ix),nx,nxmax,a(ieni),neni,nenimx,ndig,el,eh) call merge(a(ix+nx),nl,nxmax,a(ieni),neni,nenimx,ndig,el,eh) 150 continue if (el.gt.small) go to 210 if (nas.eq.0) go to 210 if (matb(1).ge.0) go to 210 if (matstd.ne.-matb(1).or.mtstd.ne.-mtb(1)) go to 210 200 continue 210 return end c subroutine lumpmt(a) c ****************************************************************** c read through the file 33 mts and store the list of component mts c making up the lumped mts. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/eunits/nendf,nunit(7),nscr common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension a(*) character*4 bl external reserv,findex,findf,contio,error,tosend,releas external openz,repoz,tpidio,tofend,amend,atend data bl/' '/ c nwl=nlump*nlmt call reserv('lmt',nwl,ilmt,a) nw=2*npage+50 call reserv('scr',nw,iscr,a) call findex('lump',ilump,a) do i=1,nwl a(i-1+ilmt)=0 enddo call findf(matd,mfcov,0,nendf) max=0 c c ***loop over mts 110 call contio(nendf,0,0,a(iscr),nb,nw) if (mfh.eq.0) go to 200 mt1=l2h if (mt1.lt.851) go to 140 do 120 l=1,nlump mtl=nint(a(ilump+2*(l-1))) if (mt1.ne.mtl) go to 120 a(ilump+2*(l-1)+1)=a(ilump+2*(l-1)+1)+1 k=nint(a(ilump+2*(l-1)+1)) if (k.gt.nlmt) call error('lumpmt','storage exceeded.',' ') if (k.gt.max) max=k a(ilmt-1+nlmt*(l-1)+k)=mth c ***set this mth in mts negative do 130 j=1,nmt if (mts(j).ne.mth) go to 130 mts(j)=-mts(j) if (mats(j).eq.0) mats(j)=-1 if (mats(j).gt.0) mats(j)=-mats(j) go to 140 130 continue 120 continue 140 call tosend(nendf,0,0,a(iscr)) go to 110 c c ***determine the maximum no. of words needed 200 if (max.eq.nlmt) go to 230 c ***squeeze storage loc1=ilmt-1+max do l=2,nlump loc=ilmt+nlmt*(l-1)-1 do j=1,max a(j+loc1)=a(j+loc) enddo loc1=loc1+max enddo nwl=max*nlump call releas('lmt',nwl,a) nlmt=max c ***copy mfcov to nscr for use in lumpxs 230 nscr=15 if (nendf.lt.0) nscr=-nscr call openz(nscr,1) call repoz(nscr) do i=1,17 read(bl,'(a4)') a(i-1+iscr) enddo math=1 mfh=0 mth=0 nsc=0 call tpidio(0,0,nscr,a(iscr),nb,nw) call findf(matd,mfcov,0,nendf) call contio(nendf,0,nscr,a(iscr),nb,nw) call tofend(nendf,0,nscr,a(iscr)) call amend(0,nscr) call atend(0,nscr) call repoz(nscr) call releas('scr',0,a) return end c subroutine lumpxs(mti,mtk,a) c ****************************************************************** c read the cross sections of the component mts for a lumped c covariance mt. c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr1,nscr2,nscr common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) dimension a(*) external findex,findf,contio,rdsig c call findex('lump',ilump,a) call findex('lmt',ilmt,a) call findex('scr',iscr,a) call findex('scr2',iscr2,a) call findex('sig',isig,a) call findex('sig1',isig1,a) call findex('b',ib,a) do 130 i=1,nlump l=i mtl=nint(a(ilump+2*(l-1))) if (mtl.eq.mti) go to 140 130 continue 140 nmtl=nint(a(ilump+2*(l-1)+1)) is=isig if (mti.ne.mtk) is=isig1 do i=1,nunion a(is-1+i)=0 enddo c c ***loop over component mts loc=ilmt+nlmt*(l-1)-1 do i=1,nmtl mtd=nint(a(i+loc)) call findf(matd,mfcov,mtd,nscr) call contio(nscr,0,0,a(iscr2),nb,nw) za=c1h awr=c2h call rdsig(matd,mtd,a(ib),a(iscr2)) c ***add scr2 to a(is) do j=1,nunion a(is-1+j)=a(is-1+j)+a(iscr2-1+j) enddo enddo return end c subroutine merge(x,nx,nxmax,y,ny,nymax,ndig,e1,e2) c ****************************************************************** c merge an energy grid in x with a previously existing one in y. c both grids are assumed to be in increasing order. c ****************************************************************** implicit real*8 (a-h,o-z) character*60 strng dimension x(*),y(*) external error,sigfig data eps/1.d-5/ zero=0 c if (nx.eq.0) return j=0 do 100 i=1,nx x(i)=sigfig(x(i),ndig,0) if (e1.eq.zero.and.e2.eq.zero) go to 110 if (x(i).le.e1) go to 100 if (x(i).ge.e2) go to 120 110 j=j+1 x(j)=x(i) 100 continue 120 nx=j if (ny.gt.0) go to 140 if (nx.gt.nxmax) call error('merge','storage exceeded.',' ') do i=1,nx y(i)=x(i) enddo ny=nx go to 200 c 140 j=0 do 180 i=1,nx 150 j=j+1 if (j.gt.ny) go to 170 if (y(j).lt.x(i)) go to 150 if (y(j).eq.x(i)) go to 180 if (abs(y(j)-x(i)).le.eps*y(j)) go to 180 c ***insert x(i) in the y array. if (ny.eq.nymax) call error('merge','storage exceeded.',' ') do k=j,ny loc=ny+j-k y(loc+1)=y(loc) enddo 170 ny=ny+1 y(j)=x(i) 180 continue c c ***check grid for data inconsistencies 200 ny1=ny-1 do i=1,ny1 isave=i do j=i,ny jsave=j if (y(i).gt.y(j)) then write(strng, & '(''y('',i4,'')='',1p,e12.4,'' lt y('',i4,'')='', & 1p,e12.4)') jsave,y(jsave),isave,y(isave) call error('merge',strng,' ') endif enddo enddo return end c subroutine rdsig(mat,mt,b,sig) c ****************************************************************** c read cross sections from ngout tape using subroutine rdgout, c re-initializing that subroutine for each new value of mat. c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr(3) dimension b(*),sig(*) external rdgout save matd,mfrd,matlst c if (mt.eq.0) then matd=mat mfrd=3 matlst=10000 else matrd=mat if (mat.eq.0) matrd=matd mtrd=mt if (mat.ne.matlst) then mfri=1 mtri=451 call rdgout(ngout,matrd,mfri,mtri,b,sig) matlst=mat endif call rdgout(ngout,matrd,mfrd,mtrd,b,sig) endif return end c subroutine egnwtf(a) c ****************************************************************** c set up calculation of weight functions or read in arbitary c function in the form of an endf/b tab1 record or c read in parameters for an analytic weight function. c c iwt meaning c --- ------- c 1 read in c 2 constant c 3 1/e c 4 1/e + fission spectrum + thermal maxwellian c 5 epri-cell lwr c 6 (thermal) -- (1/e) -- (fission + fusion) c 7 same with t-dep thermal part c 8 thermal--1/e--fast reactor--fission + fusion c 9 claw weight function c 10 claw with t-dependent thermal part c 11 vitamin-e weight function (ornl-5505) c 12 vit-e with t-dep thermal part c c ****************************************************************** implicit real*8 (a-h,o-z) common/mainio/nsysi,nsyso,nsyse,ntty cej common/ewght/iwt common/iwt4/eb,tb,ab,ec,tc,ac dimension a(*) dimension w1(92),w2(92),w3(8) dimension w8(66) dimension w9(102) data w1/0.d0,0.d0,0.d0,0.d0,1.d0,92.d0,92.d0,5.d0, & 1.d-5,5.25d-4,.009d0,.355d0,.016d0,.552d0,.024d0,.712d0, & .029d0,.785d0,.033d0,.829d0,.043d0,.898d0,.05d0,.918d0,.054d0, & .921d0,.059d0,.918d0,.07d0,.892d0,.09d0,.799d0,.112d0,.686d0, & .14d0,.52d0,.17d0,.383d0,.21d0,.252d0,.3d0,.108d0,.4d0,.0687d0, & .49d0,.051d0,.57d0,.0437d0,.6d0,.0413d0,1.d0,.024914d0,1.01d3, & 3.7829d-5,2.d4,2.2257d-6,3.07d4,1.5571d-6,6.07d4,9.1595d-7, & 1.2d5,5.7934d-7,2.01d5,4.3645d-7,2.83d5,3.8309d-7,3.56d5, & 3.6926d-7,3.77d5,3.4027d-7,3.99d5,2.7387d-7,4.42d5,1.0075d-7, & 4.74d5,2.1754d-7,5.02d5,2.6333d-7,5.4d5,3.0501d-7,6.5d5, & 2.9493d-7,7.7d5,2.5005d-7,9.d5,2.1479d-7,9.41d5,1.7861d-7, & 1.d6,9.1595d-8,1.05d6,1.1518d-7/ data w2/ & 1.12d6,1.3648d-7,1.19d6,1.5479d-7,1.21d6,1.5022d-7,1.31d6, & 6.8696d-8,1.4d6,1.2182d-7,2.22d6,5.9033d-8,2.35d6,9.1595d-8, & 2.63d6,3.9981d-8,3.d6,3.1142d-8,4.d6,1.7073e-8,5.d6,9.0679d-9, & 6.d6,4.7153d-9,8.d6,1.2276d-9,1.d7,3.0953d-10,1.257d7,2.4619d-10, & 1.26d7,3.4731d-10,1.27d7,1.0357d-9,1.28d7,2.8436d-9,1.29d7, & 7.191d-9,1.3d7,1.6776d-8,1.31d7,3.6122d-8,1.32d7,7.1864d-8, & 1.33d7,1.3222d-7,1.34d7,2.2511d-7,1.35d7,3.5512d-7,1.36d7, & 5.1946d-7,1.37d7,7.0478d-7,1.38d7,8.8825d-7,1.39d7,1.0408d-6, & 1.407d7,1.154d-6,1.42d7,1.087d-6,1.43d7,9.5757d-7,1.44d7, & 7.7804d-7,1.45d7,6.0403d-7,1.46d7,4.3317d-7,1.47d7,2.9041d-7, & 1.48d7,1.8213d-7,1.49d7,1.0699d-7,1.5d7,5.8832d-8,1.51d7, & 3.0354d-8,1.52d7,1.4687d-8,1.53d7,6.6688d-9,1.54d7,2.845d-9, & 1.55d7,1.1406d-9,1.5676d7,1.978d-10,2.d7,1.5477d-10/ data w3/3.d7,1.0318d-10,5.d7,6.1908d-10,1.d8,3.0954d-11, & 1.5d8,2.0636d-11/ data w8/4*0.d0,1.d0,29.d0,29.d0,5.d0, & .139000d-03, .751516d-03, .100000d-01, .497360d-01, & .200000d-01, .754488d-01, .400000d-01, .107756d+00, & .600000d-01, .110520d+00, .800000d-01, .101542d+00, & .100000d+00, .884511d-01, .614000d+02, .144057d-03, & .788930d+02, .217504d-03, .312030d+03, .127278d-02, & .179560d+04, .236546d-02, .804730d+04, .114311d-02, & .463090d+05, .387734d-03, .161630d+06, .125319d-03, & .639280d+06, .207541d-04, .286500d+07, .216111d-05, & .472370d+07, .748998d-06, .100000d+08, .573163d-07, & .127900d+08, .940528d-08, .129000d+08, .973648d-08, & .135500d+08, .985038d-07, .137500d+08, .176388d-06, & .139500d+08, .239801d-06, .140700d+08, .251963d-06, & .141900d+08, .239298d-06, .143900d+08, .176226d-06, & .145900d+08, .992422d-07, .155500d+08, .150737d-08, & .200000d+08, .725000d-10/ data w9/4*0d0,1d0,47d0,47d0,5d0, & 1.39d-4, 3.019d6, 5.d-4, 1.07d7, 1.d-3, 2.098d7, & 5.d-3, 8.939d7, 1.d-2, 1.4638d8, 2.5d-2, 2.008d8, & 4.d-2, 1.7635d8, 5.d-2, 1.478d8, 1.d-1, 4.d7, & 1.4d-1, 1.13d7, 1.5d-1, 7.6d6, 4.14d-1, 2.79d6, & 1.13d0, 1.02d6, 3.06d0, 3.77d5, 8.32d0, 1.39d5, & 2.26d1, 5.11d4, 6.14d1, 1.88d4, 1.67d2, 6.91d3, & 4.54d2, 2.54d3, 1.235d3, 9.35d2, 3.35d3, 3.45d2, & 9.12d3, 1.266d2, 2.48d4, 4.65d1, 6.76d4, 1.71d1, & 1.84d5, 6.27d0, 3.03d5, 3.88d0, 5.d5, 3.6d0, & 8.23d5, 2.87d0, 1.353d6, 1.75d0, 1.738d6, 1.13d0, & 2.232d6, 0.73d0, 2.865d6, 0.4d0, 3.68d6, 2.05d-1, & 6.07d6, 3.9d-2, 7.79d6, 1.63d-2, 1.d7, 6.5d-3, & 1.2d7, 7.6d-3, 1.3d7, 1.23d-2, 1.35d7, 2.64d-2, & 1.4d7, 1.14d-1, 1.41d7, 1.14d-1, 1.42d7, 1.01d-1, & 1.43d7, 6.5d-2, 1.46d7, 1.49d-2, 1.5d7, 4.d-3, & 1.6d7, 1.54d-3, 1.7d7, 0.85d-3/ data small/1.d-10/ data zero/0.d0/ data onep5/1.5d0/ c c ***read flux calculator input, if any. iwtt=iabs(iwt) nflmax=0 cej if (iwt.le.0) then ninwt=0 jsigz=0 read(nsysi,*) ehi,sigpot,nflmax,ninwt,jsigz call openz(ninwt,0) write(nsyso,'(/, & '' compute flux...ehi, sigpot, nflmax ='',f9.1,f9.2,i8)') & ehi,sigpot,nflmax,ninwt,jsigz endif c c ***arbitary if (iwtt.eq.1) then write(nsyso,'(/,'' weight function......read in'')') iw=-1 call reserv('wght',iw,iwght,a) read(nsysi,*) (a(iwght+i-1),i=1,iw) nr=nint(a(iwght+4)) np=nint(a(iwght+5)) iw=6+2*nr+2*np call releas('wght',iw,a) c c ***constant else if (iwtt.eq.2) then write(nsyso,'(/,'' weight function......constant for all l'')') c c ***1/e else if (iwtt.eq.3) then write(nsyso,'(/,'' weight function......1/e for all l'')') c c ***1/e+fission+thermal else if (iwtt.eq.4) then read(nsysi,*) eb,tb,ec,tc if (eb.gt.50*tb) then ab=1 ac=0 else ab=1/(exp(-eb/tb)*eb**2) ac=1/(exp(-ec/tc)*ec**onep5) endif iw=6 call reserv('wght',iw,iwght,a) a(iwght)=eb a(iwght+1)=tb a(iwght+2)=ab a(iwght+3)=ec a(iwght+4)=tc a(iwght+5)=ac write(nsyso,'(/, & '' weight function......thermal + 1/e + fission'',/, & '' thermal breakpoint and temperature '',1p,2e12.4,/, & '' fission breakpoint and temperature '',2e12.4)') & eb,tb,ec,tc c c ***epri-cell light water reactor weight. else if (iwtt.eq.5) then write(nsyso,'(/,'' weight function......epri-cell lwr'')') iw=192 call reserv('wght',iw,iwght,a) do i=1,92 a(i-1+iwght)=w1(i) enddo do i=1,92 a(i+91+iwght)=w2(i) enddo do i=1,8 a(i+183+iwght)=w3(i) enddo c c ***(thermal) -- (1/e) -- (fission + fusion) else if (iwtt.eq.6.or.iwtt.eq.7) then write(nsyso,'(/, & '' weight function......(thermal) -- (1/e) -- '', & ''(fission + fusion)'')') if (iwtt.gt.6) write(nsyso,'(22x,''temperature dependent'')') c c ***thermal--1/e--fast reactor--fission + fusion else if (iwtt.eq.8) then write(nsyso,'(/, & '' weight function...thermal--1/e--fast reactor--'', & ''fission + fusion'')') iw=66 call reserv('wght',iw,iwght,a) do i=1,66 a(i-1+iwght)=w8(i) enddo c c ***claw weight function else if (iwtt.eq.9.or.iwtt.eq.10) then write(nsyso, & '(/,'' weight function......claw weight function'')') if (iwtt.gt.9) then write(nsyso,'(22x,''temperature dependent'')') endif iw=102 call reserv('wght',iw,iwght,a) do i=1,102 a(i-1+iwght)=w9(i) enddo c c ***vitamin-e weight function else if (iwtt.eq.11.or.iwtt.eq.12) then write(nsyso,'(/,'' weight function......vitamin-e'')') if (iwtt.gt.11) write(nsyso,'(22x,''temperature dependent'')') c c ***illegal iwt else call error('egnwtf','illegal weight function requested.',' ') endif return end c subroutine egtwtf(e,enext,idis,lord,wtf,a) c ****************************************************************** c retrieve or compute required legendre component of the c weight function constructed or read in by egnwtf. c ****************************************************************** implicit real*8 (a-h,o-z) common/bkc/bk common/ewght/iwt common/temper/temp(10),ntemp common/iwt4/eb,tb,ab,ec,tc,ac dimension a(*) external findex,terpa save ip,ir,ipl,step data con1,con2,con3/7.45824d+07,1.d0,1.44934d-09/ data con4,con5,con6/3.90797d-02,2.64052d-05,6.76517d-02/ data en1,en2,en3,en4,en5/.414d0,2.12d6,1.d7,1.252d7,1.568d7/ data therm,theta,fusion,ep/.0253d0,1.415d6,2.5d4,1.407d7/ data emax/1.d10/ data s110,s101,s1002,s1005,s10001/1.10d0,1.01d0,1.002d0, & 1.005d0,1.0001d0/ data tenth,half,two/0.1d0,0.5d0,2.d0/ data veb/5.d5/ data wt6a,wt6b,wt6c,wt6d,wt6e,wt6f,wt6g,wt6h,wt6i,wt6j/ & .054d0,1.578551d-3,2.1d6,2.32472d-12,1.4d6,2.5d4, & 1.407d7,2.51697d-11,1.6d6,3.3d5/ data wt10a,wt10b,wt10c/.15d0,300.d0,1.15d6/ data exmin/-89.d0/ data zero/0.d0/ c c ***initialize iwtt=iabs(iwt) if (iwtt.eq.1.or.iwtt.eq.4.or.iwtt.eq.5.or.iwtt.eq.8. & or.iwtt.eq.9.or.iwtt.eq.10) & call findex('wght',iwght,a) idis=0 if (e.eq.0) then ip=2 ir=1 ipl=0 enext=emax step=s110 return endif c c ***branch to desired method iwtt=iabs(iwt) c c ***tabulated if (iwtt.eq.1.or.iwtt.eq.5.or.iwtt.eq.8.or.iwtt.eq.9) then call terpa(wtf,e,enext,idis,a(iwght),ip,ir) if (wtf.ne.zero) then if (ip.ne.ipl) then step=s10001*(enext/e)**tenth ipl=ip endif enxt=step*e if (enxt.gt.s101*e) enxt=s101*e if (enext.gt.enxt) idis=0 if (enext.gt.enxt) enext=enxt endif c c ***constant for all orders else if (iwtt.eq.2) then wtf=1 enext=emax c c ***1/e for all orders else if (iwtt.eq.3) then wtf=1/e enext=s101*e c c ***thermal + 1/e + fission c ***wght(1) to wght(6) are eb, tb, ab, ec, tc, ac else if (iwtt.eq.4) then if (e.le.eb) then wtf=ab*e*exp(-e/tb) enext=s101*e if (e.lt.eb.and.enext.gt.eb) enext=eb else if (e.le.ec) then wtf=1/e enext=s101*e if (e.lt.eb.and.enext.gt.eb) & enext=eb else wtf=ac*sqrt(e)*exp(-e/tc) enext=s101*e endif c c ***(thermal) -- (1/e) -- (fission + fusion) c ***with optional t dependence else if (iwtt.eq.6.or.iwtt.eq.7) then tt=wt6a if (iwtt.gt.6) tt=temp(jtemp)*bk bb=2*tt cc=1 if (iwtt.gt.6) cc=wt6b*exp(two)/bb**2 if (e.le.bb) then wtf=cc*e*exp(-e/tt) enext=s101*e else if (e.le.wt6c) then wtf=wt6b/e enext=s101*e else wtf=wt6d*sqrt(e)*exp(-e/wt6e) pow=-(sqrt(e/wt6f)-sqrt(wt6g/wt6f))**2/2 if (pow.gt.exmin) wtf=wtf+wt6h*exp(pow) enext=s101*e test=wt6i if (abs(e-wt6g).le.test) enext=s1005*e test=wt6j if (abs(e-wt6g).le.test) enext=s1002*e endif c c ***temperature-dependent thermal part else if (iwtt.eq.10) then ea=bk*temp(jtemp) eb=wt10a*temp(jtemp)/wt10b if (e.lt.eb) then wtf=wt10c*(e/eb**2)*exp(-(e-eb)/ea) enext=s101*e if (enext.gt.eb) enext=eb else call terpa(wtf,e,enext,idis,a(iwght),ip,ir) if (wtf.eq.zero) then enext=emax else if (ip.ne.ipl) then step=s10001*(enext/e)**tenth ipl=ip endif enxt=step*e if (enxt.gt.s101*e) enxt=s101*e if (enext.gt.enxt) idis=0 if (enext.gt.enxt) enext=enxt endif endif c c ***vitamin-e weight function (ornl-5510) c ***with optional t dependence else if (iwtt.eq.11.or.iwtt.eq.12) then enext=s101*e if (e.lt.en1) then tt=therm if (iwtt.gt.11) tt=temp(jtemp)*bk cc=con1 if (iwtt.gt.11) cc=con2*exp(en1/tt)/en1**2 wtf=cc*e*exp(-e/tt) if (enext.gt.en1) enext=en1 else if (e.lt.en2) then wtf=con2/e if (enext.gt.en2) enext=en2 else if (e.lt.en3) then wtf=con3*e**half*exp(-e/theta) if (enext.gt.en3) enext=en3 else if (e.lt.en4) then wtf=con4/e if (enext.gt.en4) enext=en4 else if (e.lt.en5) then wtf=con5*exp(-5*(e**half-ep**half)**2/fusion) if (abs(e-ep).le.veb) enext=s1002*e if (enext.gt.en5) enext=en5 else wtf=con6/e endif endif c c ***return enext on an even grid enext=sigfig(enext,7,0) return end c subroutine stand(li,l,loc,lty,a) c ****************************************************************** c read and store the appropriate data from nstan. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr1,nscr2,nscr3 common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/redef/nas,matb(5),mtb(5),matc(5),mtc(5) dimension a(*) dimension loc(*) external findex,sigfig,findf,contio,listio,moreio c call findex('scr',iscr,a) el=sigfig(c1h,ndig,0) eh=sigfig(c2h,ndig,0) matstd=l1h mtstd=l2h c c ***redefine standard if necessary if (nas.le.0) go to 110 do 100 i=1,nas if (matstd.ne.matb(i).or.mtstd.ne.mtb(i)) go to 100 matstd=matc(i) mtstd=mtc(i) go to 110 100 continue 110 call findf(matstd,mfcov,mtstd,nstan) call contio(nstan,0,0,a(iscr+l-1),nb,nw) c c ***first subsection is the one we want call contio(nstan,0,0,a(iscr+l-1),nb,nw) nc=n1h ni=n2h c c ***skip over nc sub-subsections if (nc.ne.0) then do ic=1,nc call contio(nstan,0,0,a(iscr+l-1),nb,nw) call listio(nstan,0,0,a(iscr+l-1),nb,nw) do while (nb.ne.0) call moreio(nstan,0,0,a(iscr+l-1),nb,nw) enddo enddo endif c c ***loop over ni sub-subsections do ii=1,ni call listio(nstan,0,0,a(iscr+l-1),nb,nw) li=li+1 loc(li)=iscr+l-1 a(iscr+l-1)=el a(iscr+l)=eh if (l2h.eq.6) a(iscr+l+1)=int((n1h-1)/n2h) a(iscr+l+3)=lty np=n1h l=l+nw do while (nb.ne.0) call moreio(nstan,0,0,a(iscr+l-1),nb,nw) l=l+nw enddo locli=loc(li)+5 do i=1,np a(i+locli)=sigfig(a(i+locli),ndig,0) enddo enddo return end c subroutine resprx(nwscr,a) c ****************************************************************** c prepare tables containing the resonance-parameter contributions c to coarse-group covariances. c ****************************************************************** implicit real*8 (a-h,o-z) parameter (mxlru2=100) common/err0/nresg common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/err3/ifresr,ifunrs common/reson1/ap,arat,ra,spifac,ll common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/grpn/ign,ngn,egn(901),iprint common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 character*60 strng1,strng2 dimension a(*) dimension amu(3,mxlru2) c ***initialize nresg=0 ifresr=0 ifunrs=0 if (mfcov.eq.33.and.mf32.ne.0) then call findex('cff',icff,a) call findex('cfg',icfg,a) call findex('cgg',icgg,a) call findex('cee',icee,a) call findex('cef',icef,a) call findex('ceg',iceg,a) call findex('ctt',ictt,a) call findex('uff',iuff,a) call findex('ufg',iufg,a) call findex('ugg',iugg,a) call findex('uee',iuee,a) call findex('uef',iuef,a) call findex('ueg',iueg,a) call findex('utt',iutt,a) call findex('scr',iscr,a) call findex('cflx',icflx,a) c call repoz(nendf) call tpidio(nendf,0,0,a(iscr),nb,nw) do ig=1,ngn a(iufg-1+ig)=0.d0 enddo nngn=ngn*(ngn+1)/2 do ig=1,nngn a(icff-1+ig)=0.d0 a(icee-1+ig)=0.d0 a(icgg-1+ig)=0.d0 a(ictt-1+ig)=0.d0 a(iuff-1+ig)=0.d0 a(iugg-1+ig)=0.d0 a(iuee-1+ig)=0.d0 a(iutt-1+ig)=0.d0 enddo nngn=ngn*ngn do ig=1,nngn a(icfg-1+ig)=0.d0 a(icef-1+ig)=0.d0 a(iceg-1+ig)=0.d0 a(iufg-1+ig)=0.d0 a(iuef-1+ig)=0.d0 a(iueg-1+ig)=0.d0 enddo nscr6=16 if (nendf.lt.0) nscr6=-nscr6 call openz(nscr6,1) call repoz(nscr6) call Resprx_dumrd2(matd,nendf,nscr6,a(iscr),amu,mxlru2) call findf(matd,32,151,nendf) call contio(nendf,0,0,a(iscr),nb,nw) za=c1h awr=c2h nis=n1h endif c c ***loop over isotopes do 110 is=1,nis call contio(nendf,0,0,a(iscr),nb,nw) abn=c2h lfw=l2h ner=n1h c c ***loop over energy ranges do 120 ie=1,ner write (*,10000) ie, ner 10000 format ('Energy range : ',I5,'/',I5) call contio(nendf,0,0,a(iscr),nb,nw) el=c1h eh=c2h ehg=eh elg=el ip1=0 ip2=0 do i=2,ngn+1 ee=egn(i) if(ip1.eq.0.and.ee.gt.el)then ip1=1 elg=egn(i-1) iest=i-1 endif if(ip2.eq.0.and.ee.gt.eh)then ip2=1 ehg=egn(i) ieed=i endif enddo lru=l1h lrf=l2h nro=n1h naps=n2h if (lru.eq.1.and.lrf.ge.1.and.lrf.le.3) go to 130 if (lru.eq.2.and.lrf.ge.1.and.lrf.le.2) go to 130 write(strng2,'(''lrf='',i4,'' lru='',i4)') lrf,lru call error('resprx', & 'illegal or no coding data structure in mf32', & strng2) 130 if (nro.ne.0) then write(strng2,'(''nro='',i4)') nro call error('resprx', & 'illegal or unrecognized data structure in mf32', & strng2) endif c call contio(nendf,0,0,a(iscr),nb,nw) spi=c1h spifac=1/(2*spi+1) ap=c2h lcomp=l2h nls=n1h l=iscr+6 c if (lru.eq.2) then c ***Unresolved call Resprx_Unr(a,amu,mxlru2,iest,ieed) else c ***Resolved if (lcomp.eq.0) then call Resprx_RRR_Lcomp0(nwscr,a) elseif (lcomp.eq.1 .or. lcomp.eq.2) then call Resprx_RRR_Lcomp12(nwscr,a,iest,ieed) else endif endif c c ***finished of this material or a section 120 continue 110 continue call closz(nscr6) c return end c subroutine Resprx_RRR_Lcomp0(nwscr,a) c ****************************************************************** c lru = 1, lcomp = 0 c ****************************************************************** implicit real*8 (a-h,o-z) parameter (maxnls=10,maxe=400000) common/err0/nresg common/err3/ifresr,ifunrs common/reson1/ap,arat,ra,spifac,ll common/reson2/ajmin,gj(10),diff,nj common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/grpn/ign,ngn,egn(901),iprint common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/util/npage,iverf common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common/cwav/cwaven common/amnc/amassn character*60 strng1,strng2 dimension a(*) dimension istloc(maxnls) dimension sig(maxe,5), gsig(4,901,6), sig1(4) dimension sens(4,6,901) dimension cov(5,5) dimension ag(6), aa(3), aa2(3) logical lneger data rc1,rc2,third/0.123d0,0.08d0,0.333333333d0/ data Zero /0.0d0/, half/0.5d0/ c c ***resolved resonance parameters (lru=1) c ***compatible resolved resonance subsection format (lcomp=0) if (nls.gt.maxnls) then write(strng2,'(''nls='',i8,'' maxnls='',i8)') nls,maxnls call error('resprx','storage exceeded.',strng2) endif do nl=1,nls istloc(nl)=l call listio(nendf,0,0,a(l),nb,nw) 140 continue if (nb.ne.0) then l=l+nw call moreio(nendf,0,0,a(l),nb,nw) go to 140 else l=l+nw if ((l+nw-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') l+nw-iscr,nwscr call error('resprx','storage exceeded.',strng2) endif endif enddo c c ***loop over l states do 160 nl=1,nls iloc=istloc(nl) awri=a(iloc) ll=nint(a(iloc+2)) nrs=nint(a(iloc+5)) arat=awri/(awri+1) aw=amassn*awri ra=rc1*aw**third+rc2 ral=ra apl=ap if (naps.eq.1) then ral=apl ra=ap endif if (lrf.eq.2) then sum=0.d0 den=4*spi+2 fl=ll ajmin=abs(abs(spi-fl)-half) ajmax=spi+fl+half nj=ajmax-ajmin+1.001d0 aj=ajmin do i=1,min(10,nj) gj(i)=(2*aj+1)/den aj=aj+1 sum=sum+gj(i) enddo diff=2*fl+1-sum endif inow=iloc+6 c c ***loop over all resonances do 170 nr=1,nrs er=abs(a(inow)) rho=cwaven*arat*sqrt(er)*ral call facts(ll,rho,ser,per) aa(1)=ser aa(2)=per aa(3)=0.d0 rgt=1/a(inow+2) c do ig=1,ngn do j=1,6 do i=1,4 gsig(i,ig,j)=0.d0 sens(i,j,ig)=0.d0 enddo enddo enddo c do 180 loop=1,6 do j=1,6 ag(j)=a(inow+j-1) enddo do j=1,3 aa2(j)=aa(j) enddo if (loop.eq.2) then if (ag(1).lt.zero) then ag(1)=ag(1)*1.0001d0 lneger=.false. else do ig1=1,ngn if (ag(1).ge.egn(ig1).and. & ag(1).lt.egn(ig1+1)) go to 190 enddo 190 continue e1=ag(1)*1.0001d0 do ig2=ig1,ngn if (e1.ge.egn(ig2).and. & e1.lt.egn(ig2+1)) go to 200 enddo 200 continue if (ig1.eq.ig2) then ag(1)=e1 lneger=.false. else ag(1)=ag(1)*0.9999d0 lneger=.true. endif endif rho=cwaven*arat*sqrt(abs(ag(1)))*ral call facts(ll,rho,ser,per) aa2(1)=ser aa2(2)=per elseif (loop.eq.3) then go to 180 elseif (loop.ge.4.and.loop.le.6) then if (ag(loop).eq.0.) go to 180 ag(loop)=ag(loop)*1.01d0 ag(3)=ag(4)+ag(5)+ag(6) endif e1=elg ii=0 if (nr.eq.1) then er1=er/10.d0 er2=er*10.d0 elseif (er.le.1.d+2) then er1=er/4.d0 er2=er*4.d0 else er1=er/2.5d0 er2=er*2.5d0 endif if (loop.eq.2) then er3=abs(ag(1))*0.995d0 er4=abs(ag(1))*1.005d0 er5=abs(ag(1))*0.9992d0 er6=abs(ag(1))*1.0008d0 else er3=er*0.995d0 er4=er*1.005d0 er5=er*0.9992d0 er6=er*1.0008d0 endif go to 220 c 210 continue if (e1.ge.er5.and.e1.le.er6) then ekp=1.000001d0 elseif (e1.ge.er3.and.e1.le.er4) then ekp=1.00001d0 elseif (e1.ge.er1.and.e1.le.er2) then ekp=1.0018d0 else ekp=1.02d0 endif e1=e1*ekp ebc=e1/ekp if(ebc.lt.el.and.e1.gt.el)e1=el if(ebc.lt.eh.and.e1.gt.eh)e1=eh c 220 continue if (e1.gt.ehg) e1=ehg if (e1.ge.el.and.e1.le.eh)then if (lrf.eq.1) then call ssslbw(e1,sig1,ag,aa2) elseif (lrf.eq.2) then call ssmlbw(e1,sig1,ag,aa2) else write(strng2,'(''lrf='',i4, & '' for lcomp=0'')')lrf call error('resprx','not allowed lrf.',strng2) endif else do i=1,4 sig1(i)=0.0 enddo endif ii=ii+1 if (ii.gt.maxe) call error('resprx', & 'number of pointwise xsec of resonance exceeded.', & 'please increase the maxe parameter.') do i=1,4 sig(ii,i)=sig1(i) enddo sig(ii,5)=e1 if (e1.ge.ehg) go to 230 go to 210 c 230 continue call Resprx_grping(ngn,egn,sig,ii,gsig(1,1,loop),a) 180 continue c do ig=1,ngn if (gsig(1,ig,1).le.zero) go to 255 do j=1,4 do i=1,5 if (gsig(j,ig,i+1).le.zero) go to 250 S = Gsig(J,Ig,I+1) - Gsig(J,Ig,1) if (i.eq.1) then c ***Parameter is resonance energy IF (Lneger) S = - S S = 10000.0d0 * S / Er ij=1 elseif (i.eq.2) then c ***Parameter is total width (irrelevant) ij=5 else c ***Parameter is width if (a(inow+i).eq.zero) go to 250 S = 100.0D0 * S / A(Inow+I) ij=i-1 endif if (abs(s).ge.1.d-10) sens(j,ij,ig)= & s*a(icflx-1+ig)*abn 250 continue enddo enddo 255 continue enddo do J=1,5 do I=1,5 cov(i,j)=0.d0 enddo enddo c inow=inow+6 cov(1,1)=a(inow) do i=2,5 do j=2,i inow=inow+1 cov(i,j)=a(inow) cov(j,i)=a(inow) enddo enddo c inow=inow+2 if (iverf.eq.6) then c ***For ENDFB/6 only four parameters per resonance jd=5 do i=1,5 id=i if (cov(i,5).ne.zero) go to 260 enddo endif do i=1,5 id=i jd=i if (cov(i,i).lt.zero) go to 260 enddo do i=1,5 id=i do j=1,5 jd=j if (cov(i,i).gt.zero.and.cov(j,j).gt.zero) then corr=cov(i,j)/sqrt(cov(i,i)*cov(j,j)) if (abs(corr).ge.1.0001d0) then if (abs(corr).gt.2.) go to 260 write(strng1,'(''correlation coeff.='', & f8.4)') corr write(strng2, & '(''for resonance parameters '',i1, & '' and '',i1,'' at er='',1pe12.4)') & i,j,er call mess('resprx',strng1,strng2) endif else if (cov(i,j).ne.zero) go to 260 endif enddo enddo go to 270 c 260 continue write(strng2, & '('' resonance parameters '',i1,'' and '',i1, & '' at er='',1pe12.4)') id,jd,er call error('resprx','bad covariance data for',strng2) c 270 continue c igind=0 do ig=1,ngn if (gsig(1,ig,1).le.zero) then igind=igind+(ngn-ig+1) go to 285 endif do ig2=ig,ngn igind=igind+1 do i=1,5 if (sens(1,i,ig).eq.zero.and.sens(2,i,ig).eq.zero & .and.sens(3,i,ig).eq.zero.and.sens(4,i,ig).eq.zero) & go to 282 do j=1,5 if (abs(cov(i,j)).le.zero) go to 280 a(icff-1+igind)=a(icff-1+igind)+ & cov(i,j)*sens(3,i,ig)*sens(3,j,ig2) a(icgg-1+igind)=a(icgg-1+igind)+ & cov(i,j)*sens(4,i,ig)*sens(4,j,ig2) a(icee-1+igind)=a(icee-1+igind)+ & cov(i,j)*sens(2,i,ig)*sens(2,j,ig2) a(ictt-1+igind)=a(ictt-1+igind)+ & cov(i,j)*sens(1,i,ig)*sens(1,j,ig2) 280 continue enddo 282 continue enddo enddo if (ig.gt.nresg) nresg=ig 285 continue enddo c igind=0 do ig=1,ngn do ig2=1,ngn igind=igind+1 do i=1,5 if (sens(1,i,ig).eq.zero.and.sens(2,i,ig).eq.zero & .and.sens(3,i,ig).eq.zero.and.sens(4,i,ig).eq.zero) & go to 292 do j=1,5 if (abs(cov(i,j)).le.zero) go to 290 a(icef-1+igind)=a(icef-1+igind)+ & cov(i,j)*sens(2,i,ig)*sens(3,j,ig2) a(iceg-1+igind)=a(iceg-1+igind)+ & cov(i,j)*sens(2,i,ig)*sens(4,j,ig2) a(icfg-1+igind)=a(icfg-1+igind)+ & cov(i,j)*sens(3,i,ig)*sens(4,j,ig2) 290 continue enddo 292 continue enddo enddo enddo c 170 continue 160 continue c c ***End of Do-Loops ifresr=1 c return end c subroutine Resprx_RRR_Lcomp12(nwscr,a,iest,ieed) c ****************************************************************** c lru = 1, lcomp = 1 or 2 c ****************************************************************** implicit real*8 (a-h,o-z) parameter (maxe=400000,mxnpar=4000,maxb=20000) common/mainio/nsysi,nsyso,nsyse,ntty common/err0/nresg common/err3/ifresr,ifunrs common/reson1/ap,arat,ra,spifac,ll common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/grpn/ign,ngn,egn(901),iprint common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common/cwav/cwaven common/amnc/amassn character*60 strng1,strng2 dimension a(*) dimension b(maxb) dimension sigr(maxe,5),sigp(maxe,5), gsig(4,901) dimension sens(4,mxnpar,901) dimension cov(mxnpar,mxnpar) dimension llmat(5), innls(5) data Zero /0.0d0/ data rc1,rc2,third/0.123d0,0.08d0,0.333333333d0/ c c ***general resolved resonance subsection formats (lcomp=1) c ***compact resolved resonance subsection formats (lcomp=2) IF (lcomp.eq.1) then call contio(nendf,0,0,a(l),nb,nw) awri=c1h nsrs=n1h nlrs=n2h if (nsrs.gt.0) then arat=awri/(awri+1) aw=amassn*awri ra=rc1*aw**third+rc2 ral=ra apl=ap endif if (nsrs.le.0) go to 600 else call Resprx_RRR_Lcomp2(nwscr,cov,mxnpar,a) endif c c ***write MF=2 data on b array c call Resprx_skiprp(nscr6,b,is,ie) call contio(nscr6,0,0,b,nb,nw) lru1=l1h lrf1=l2h lb=7 call contio(nscr6,0,0,b(lb),nb,nw) nls1=n1h spi1=c1h if (lru.ne.lru1.or.lrf.ne.lrf1) then write(strng2,'(''lru/lrf(mf=32)='',i3,''/'',i3, & '' vs. lru/lrf(mf=2)='',i3,''/'',i3)')lru,lrf,lru1,lrf1 call error('resprx', & 'different type of resonance for lcomp=1',strng2) endif lb=lb+6 l2=lb c do il=1,nls1 itmp=l2 call listio(nscr6,0,0,b(l2),nb,nw) l2=l2+nw 430 continue if (nb.eq.0) go to 440 call moreio(nscr6,0,0,b(l2),nb,nw) l2=l2+nw if (l2.gt.maxb) then write(strng2,'(''l2='',i8,'' maxb='',i8)')l2,maxb call error('resprx','storage exceeded.',strng2) endif go to 430 440 continue c ind=itmp if (lrf1.eq.3) then apl=b(ind+1) if (apl.eq.0.) apl=ap endif if (naps.eq.1) then ral=apl ra=ap endif ll=nint(b(ind+2)) llmat(il)=ll nrs1=nint(b(ind+5)) do nr=1,nrs1 rho=cwaven*arat*sqrt(abs(b(ind+6*nr)))*ral call facts(ll,rho,ser,per) b(l2)=ser b(l2+1)=per b(l2+2)=0 l2=l2+3 enddo enddo c lb2=l2 l3=lb2 c c ***end of writing MF=2 data to b array c if (lcomp.eq.1) then L = L + 6 nsmax = nsrs else nsmax = 1 endif c c ***loop over the number of "sections" of covariance matrix c ***store that information in array "a" do ns=1,nsmax if (lcomp.eq.1) then l1=l call listio(nendf,0,0,a(l1),nb,nw) l1=l1+nw 410 continue if (nb.eq.0) go to 420 call moreio(nendf,0,0,a(l1),nb,nw) l1=l1+nw go to 410 420 continue if ((l1-iscr).gt.nwscr) then write(strng2,'(''require='',i8, & '' supply='',i8, & '' for nwds given in s.covout'')') & l1-iscr,nwscr call error('resprx', & 'storage exceeded in lcomp=1.',strng2) endif mpar=nint(a(l+2)) nrb=nint(a(l+5)) nvs1=6*nrb nvs2=nint(a(l+4))-nvs1 npar=mpar*nrb if (npar+1.gt.mxnpar) then write(strng2,'(''npar='',i8, '' +1 > mxnpar='',i8)') & npar,mxnpar call error('resprx','storage exceeded.', strng2) endif endif c if (mpar.gt.4 .and. lrf.le.2) then write(nsyso,*)'Not coded' stop endif if (lrf.le.0 .or. lrf.gt.3) then write(strng2,'(''lrf='',i3,'' is no coding.'')') lrf call error('resprx','lcomp=1 general form.',strng2) endif c ipos=0 loop=0 do loopm=1,nrb do loopn=1,mpar loop=loop+1 if (loopn.eq.1) then write (*,10200) loopm, nrb 10200 format & ('Resonance number',I5,'(/',I5,') Resonance energy') else write (*,10300) loopm, nrb, loopn-1 10300 format & ('Resonance number',I5,'(/',I5,') Width number', I2) endif c ***search aimed mf32 resonance in mf=2 if(loopn.eq.1)then eres =a(l+6*loopm) ajres=a(l+6*loopm+1) il2=lb do il=1,nls1 itmp=il2 ipara=b(il2+5) if(ipara.ne.0)then do ipp=1,ipara il2=il2+6 eres2 =b(il2) ajres2=b(il2+1) if(eres*eres2.gt.0)then rr=abs(eres/eres2-1.) rr2=abs(ajres-ajres2) if(rr.lt.1d-6.and.rr2.lt.1d-4)then ipos=itmp+6+ipara*6+(ipp-1)*3 goto 461 endif endif enddo il2=il2+6 il2=il2+ipara*3 endif enddo write(*,*)'error in resprx_Lcomp_12' write(*,*)'E:',eres write(*,*)'ajres',ajres stop 461 continue ilnum=il endif c ***perturbed(-) if(loopn.eq.1)then il3=il2 backdt=b(il2) b(il2)=backdt*0.9999 gwidth=backdt*0.0001 backdt2=b(ipos) backdt3=b(ipos+1) rho=cwaven*arat*sqrt(abs(b(il2)))*ral lldum=llmat(il) call facts(lldum,rho,ser,per) b(ipos)=ser b(ipos+1)=per else if (lrf.eq.1 .or. lrf.eq.2) then il3 = il2 + Loopn + 1 elseif (lrf.eq.3) then il3 = il2 + Loopn endif backdt=b(il3) gwidth=backdt*0.01d0 b(il3)=backdt*0.99d0 endif if(gwidth.ne.zero) & call resprx_cal_pendf(ii,ilnum,ajres,a,sigr,eres,b,maxb) c b(il3)=backdt if(loopn.eq.1)then b(ipos)=backdt2 b(ipos+1)=backdt3 endif c ***perturbed(+) if(loopn.eq.1)then il3=il2 b(il2)=backdt*1.0001 rho=cwaven*arat*sqrt(abs(b(il2)))*ral lldum=llmat(il) call facts(lldum,rho,ser,per) b(ipos)=ser b(ipos+1)=per else b(il3)=backdt*1.01d0 endif if(gwidth.ne.zero) & call resprx_cal_pendf(ii,ilnum,ajres,a,sigp,eres,b,maxb) c b(il3)=backdt if(loopn.eq.1)then b(ipos)=backdt2 b(ipos+1)=backdt3 endif if(gwidth.ne.zero)then c ***differencing do ii1=1,4 do ii2=1,ii tmp=(sigp(ii2,ii1)-sigr(ii2,ii1))/(gwidth*2) sigp(ii2,ii1)=tmp enddo enddo c ***integration call Resprx_grping(ngn,egn,sigp,ii,gsig(1,1),a) c ***sensitivity calculation do ig=iest,ieed tmp=a(icflx-1+ig)*abn do j=1,4 sens(j,Loop,ig)=gsig(j,ig)*tmp enddo enddo else do ig=iest,ieed do j=1,4 sens(j,Loop,ig)=0. enddo enddo endif c enddo c ***end of do-loop over number of parameters per resonance enddo c ***end of do-loop over number of resonances if(lcomp.eq.1)then l3=l+5+nvs1 do i=1,npar do j=i,npar l3=l3+1 tmp=a(l3) cov(i,j)=tmp cov(j,i)=tmp enddo enddo endif c igind=0 do ig=1,ieed do ig2=ig,ngn igind=igind+1 if(ig.ge.iest.and.ig.le.ieed.and. & ig2.ge.iest.and.ig2.le.ieed)then itmp1=icff+igind-1 itmp2=icgg+igind-1 itmp3=icee+igind-1 itmp4=ictt+igind-1 do i=1,npar do j=i,npar tmp=cov(i,j) if (tmp.ne.zero) then a(itmp1)=a(itmp1)+tmp*sens(3,i,ig)*sens(3,j,ig2) a(itmp2)=a(itmp2)+tmp*sens(4,i,ig)*sens(4,j,ig2) a(itmp3)=a(itmp3)+tmp*sens(2,i,ig)*sens(2,j,ig2) a(itmp4)=a(itmp4)+tmp*sens(1,i,ig)*sens(1,j,ig2) if(i.ne.j)then a(itmp1)=a(itmp1)+tmp*sens(3,j,ig)*sens(3,i,ig2) a(itmp2)=a(itmp2)+tmp*sens(4,j,ig)*sens(4,i,ig2) a(itmp3)=a(itmp3)+tmp*sens(2,j,ig)*sens(2,i,ig2) a(itmp4)=a(itmp4)+tmp*sens(1,j,ig)*sens(1,i,ig2) endif endif enddo enddo endif enddo if (ig.gt.nresg) nresg=ig enddo c igind=0 do ig=1,ieed do ig2=1,ngn igind=igind+1 if(ig.ge.iest.and.ig.le.ieed.and. & ig2.ge.iest.and.ig2.le.ieed)then itmp1=icef+igind-1 itmp2=iceg+igind-1 itmp3=icfg+igind-1 do i=1,npar do j=i,npar tmp=cov(i,j) if (tmp.ne.zero) then a(itmp1)=a(itmp1)+tmp*sens(2,i,ig)*sens(3,j,ig2) a(itmp2)=a(itmp2)+tmp*sens(2,i,ig)*sens(4,j,ig2) a(itmp3)=a(itmp3)+tmp*sens(3,i,ig)*sens(4,j,ig2) if(i.ne.j)then a(itmp1)=a(itmp1)+tmp*sens(2,j,ig)*sens(3,i,ig2) a(itmp2)=a(itmp2)+tmp*sens(2,j,ig)*sens(4,i,ig2) a(itmp3)=a(itmp3)+tmp*sens(3,j,ig)*sens(4,i,ig2) endif endif enddo enddo endif enddo enddo enddo c ***end of "sections of covariance matrix" from ENDF File32 c 600 continue if (nlrs.gt.0) then do ns=1,nlrs call listio(nendf,0,0,a(l),nb,nw) idp=nint(a(l+2)) lb=nint(a(l+3)) nt=nint(a(l+4)) np=nint(a(l+5)) l1=l+nw 610 continue if (nb.eq.0) go to 620 call moreio(nendf,0,0,a(l1),nb,nw) l1=l1+nw go to 610 620 continue stop 'no coding of nlrs>0' enddo endif ifresr=1 return end c subroutine Resprx_RRR_Lcomp2(nwscr,cov,mxnpar,a) c ****************************************************************** c lru = 1, lcomp = 2 Generate covariance matrix for point-wise xs c ****************************************************************** implicit real*8 (a-h,o-z) common/reson1/ap,arat,ra,spifac,ll common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common/amnc/amassn character*60 strng1,strng2 dimension a(*) dimension kk(18) dimension cov(mxnpar,mxnpar) data rc1,rc2,third/0.123d0,0.08d0,0.333333333d0/ c do i1=1,mxnpar do i2=1,mxnpar cov(i1,i2)=0 enddo enddo nrb=0 nind=1 lbg=l do nn=1,nls l1=l call listio(nendf,0,0,a(l1),nb,nw) l1=l1+nw 414 if (nb.eq.0) go to 415 call moreio(nendf,0,0,a(l1),nb,nw) l1=l1+nw go to 414 415 continue if ((l1-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') l1-iscr,nwscr call error('resprx','storage exceeded in lcomp=1.', & strng2) endif if(nn.eq.1)then awri=a(l) arat=awri/(awri+1) aw=amassn*awri ra=rc1*aw**third+rc2 ral=ra apl=ap endif mpar=nint(a(l+2)) nrb=nrb+nint(a(l+5)) l3=l do n2=1,nint(a(l+5)) l3=l3+12 cov(nind,nind)=a(l3) cov(nind+1,nind+1)=a(l3+2) cov(nind+2,nind+2)=a(l3+3) nind=nind+3 enddo l3=lbg+(nrb-nint(a(l+5))+1)*6 l2=l+6 do n2=1,nint(a(l+5)) do n3=1,6 a(l3+n3-1)=a(l2+n3-1) enddo l3=l3+6 l2=l2+12 enddo l=l1 enddo c *** read correlation matrix read(nendf,411)nnn,nm,nx 411 format(33x,3i11) do n2=1,nm read(nendf,412)nn1,nn2,(kk(nn3),nn3=1,18) 412 format(i5,i5,1x,18i3) nn2p=nn2-1 do n3=1,18 nn2p=nn2p+1 if(nn2p.ge.nn1) goto 413 if(kk(n3).gt.0)then cov(nn2p,nn1)=((kk(n3)+0.5)/100.0)* & cov(nn2p,nn2p)*cov(nn1,nn1) cov(nn1,nn2p)=cov(nn2p,nn1) else IF (Kk(N3).LT.0) THEN cov(nn2p,nn1)=(-(-kk(n3)+0.5)/100.0)* & cov(nn2p,nn2p)*cov(nn1,nn1) cov(nn1,nn2p)=cov(nn2p,nn1) endif enddo 413 continue enddo c if(mpar.ne.3)then write(*,"('mpar=',i5)")mpar mpar=3 endif c npar=nrb*mpar if (npar+1.gt.mxnpar) then write(strng2,'(''npar='',i8, '' +1 > mxnpar='',i8)') & npar,mxnpar call error('resprx','storage exceeded.', strng2) endif do n1=1,npar cov(n1,n1)=cov(n1,n1)*cov(n1,n1) enddo l=lbg c return end c subroutine Resprx_Unr(a,amu,mxlru2,iest,ieed) c ****************************************************************** c Unresolved resonance region (lru=2) c ****************************************************************** implicit real*8 (a-h,o-z) parameter(maxb=4000,mxnpar=100,maxe=400000) common/mainio/nsysi,nsyso,nsyse,ntty common/err0/nresg common/err3/ifresr,ifunrs common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/grpn/ign,ngn,egn(901),iprint common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral character*60 strng1,strng2 dimension a(*) dimension sig(maxe,5), sig1(4) dimension gsigr(4,901), gsigp(4,901) dimension sens(4,mxnpar,901) dimension cov(mxnpar,mxnpar) dimension amu(3,mxlru2) dimension b(maxb) data Zero /0.0d0/ c write(*,*)'Unresolved resonance energy range.' l=iscr l1=l+6 do nl=1,nls call listio(nendf,0,0,a(l1),nb,nw) l1=l1+nw 810 continue if (nb.eq.0) go to 820 call moreio(nendf,0,0,a(l1),nb,nw) l1=l1+nw go to 810 820 continue enddo call listio(nendf,0,0,a(l1),nb,nw) l2=l1+nw 830 continue if (nb.eq.0) go to 840 call moreio(nendf,0,0,a(l2),nb,nw) l2=l2+nw go to 830 840 continue c mpar=nint(a(l1+2)) npar=nint(a(l1+5)) if (npar+1.gt.mxnpar) then write(strng2,'(''npar='',i8,'' +1 > mxnpar='',i8)') & npar,mxnpar call error('resprx','storage exceeded (lru=2).',strng2) endif c do ig=1,ngn do i=1,npar do j=1,4 sens(j,i,ig)=0 enddo enddo enddo c njs=0 inow=6 l0=l1-l l2=l0+1 c do 850 loop=1,npar+1 do i=1,l0 b(i)=a(l+i-1) enddo if (loop.eq.1) go to 860 loopm=(loop-2)/mpar loopn=mod(loop-1,mpar) if (loopn.eq.1.or.mpar.eq.1) then if (njs.eq.0) then njs=nint(b(inow+6)) else njs=njs-1 endif inow=inow+6 l2=l2+1 b(l2)=b(inow+1) b(inow+1)=b(inow+1)*1.01d0 elseif (loopn.eq.2.or.(mpar.eq.2.and.loopn.eq.0)) then l2=l2+1 b(l2)=b(inow+3) b(inow+3)=b(inow+3)*1.01d0 elseif (loopn.eq.3.or.(mpar.eq.3.and.loopn.eq.0)) then l2=l2+1 b(l2)=b(inow+4) b(inow+4)=b(inow+4)*1.01d0 elseif (loopn.eq.4.or.(mpar.eq.4.and.loopn.eq.0)) then if (lfw.eq.1) then l2=l2+1 b(l2)=b(inow+5) b(inow+5)=b(inow+5)*1.01d0 elseif (lfw.eq.0) then l2=l2+1 b(l2)=b(inow+6) b(inow+6)=b(inow+6)*1.01d0 endif elseif (loopn.eq.5.or.(mpar.eq.5.and.loopn.eq.0)) then l2=l2+1 b(l2)=b(inow+6) b(inow+6)=b(inow+6)*1.01d0 endif if (loopn.eq.0.and.njs.eq.1) then inow=inow+6 njs=0 endif 860 continue e1=elg ii=0 go to 880 c 870 continue e1=e1*1.015d0 ebc=e1/1.015d0 if(ebc.lt.el.and.e1.gt.el)e1=el if(ebc.lt.eh.and.e1.gt.eh)e1=eh 880 continue if (e1.gt.ehg) e1=ehg if(e1.GE.el.and.e1.LE.eh)then call ggunr1(e1,sig1,b,amu,mxlru2) else do i=1,4 sig1(i)=0.0 enddo endif ii=ii+1 if (ii.gt.maxe) call error('resprx', & 'number of pointwise xsec of resonance exceeded.', & 'please increase the maxe parameter.') do i=1,4 sig(ii,i)=sig1(i) enddo sig(ii,5)=e1 if (e1.ge.ehg) go to 890 go to 870 890 continue if(loop.eq.1)then call Resprx_grping(ngn,egn,sig,ii,gsigr,a) else call Resprx_grping(ngn,egn,sig,ii,gsigp,a) c ***sensitivity calculation do ig=iest,ieed do j=1,4 sfac=gsigr(j,ig) i=loop-1 if (b(l0+1+i).ne.zero) then s=gsigp(j,ig)-sfac s=100*s/b(l0+1+i) if (abs(s).ge.1.d-10) then sens(j,i,ig)=s*a(icflx-1+ig)*abn endif endif enddo enddo c endif 850 continue c l2=l0+1 l3=l1+5 do i=1,npar do j=i,npar l3=l3+1 bb=b(l2+i)*b(l2+j) tmp=a(l3)*bb cov(i,j)=tmp cov(j,i)=tmp enddo enddo c igind=0 do ig=1,ngn do ig2=ig,ngn igind=igind+1 if(ig.ge.iest.and.ig.le.ieed.and. & ig2.ge.iest.and.ig2.le.ieed)then do i=1,npar do j=1,npar if (cov(i,j).eq.zero) go to 910 a(iuff-1+igind)=a(iuff-1+igind)+ & cov(i,j)*sens(3,i,ig)*sens(3,j,ig2) a(iugg-1+igind)=a(iugg-1+igind)+ & cov(i,j)*sens(4,i,ig)*sens(4,j,ig2) a(iuee-1+igind)=a(iuee-1+igind)+ & cov(i,j)*sens(2,i,ig)*sens(2,j,ig2) a(iutt-1+igind)=a(iutt-1+igind)+ & cov(i,j)*sens(1,i,ig)*sens(1,j,ig2) 910 continue enddo enddo endif if (ig.gt.nresg) nresg=ig enddo 915 continue enddo c igind=0 do ig =1,ngn do ig2=1,ngn igind=igind+1 do i=1,npar if(sens(1,i,ig).eq.zero. and. & sens(2,i,ig).eq.zero. and. & sens(3,i,ig).eq.zero. and. & sens(4,i,ig).eq.zero) go to 920 do j=1,npar if (cov(i,j).eq.zero) go to 925 a(iuef+igind-1)=a(iuef+igind-1)+ & cov(i,j)*sens(2,i,ig)*sens(3,j,ig2) a(iueg+igind-1)=a(iueg+igind-1)+ & cov(i,j)*sens(2,i,ig)*sens(4,j,ig2) a(iufg+igind-1)=a(iufg+igind-1)+ & cov(i,j)*sens(3,i,ig)*sens(4,j,ig2) 925 continue enddo 920 continue enddo enddo enddo c ifunrs=1 write(*,*)'... ended.' return end c subroutine Resprx_cal_pendf(ii,npnls,valspi,a,sig,eres,b,maxb) c ****************************************************************** c Calculation of point-wise cross section in Lcomp1 or 2 c ****************************************************************** implicit real*8 (a-h,o-z) parameter(maxe=400000) common/mainio/nsysi,nsyso,nsyse,ntty common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common/irspd/eskip1,eskip2,eskip3 dimension b(maxb) dimension sig(maxe,5), sig1(4) dimension a(*) c e1=elg ii=0 c elb1=0.9*eres elu1=1.1*eres elb2=0.8*eres elu2=1.2*eres elb3=0.7*eres elu3=1.3*eres c 520 continue if (e1.gt.ehg) e1=ehg if (e1.ge.el.and.e1.le.eh)then if (lrf.eq.3) then call ggrmat(e1,sig1,b(1),npnls,valspi) elseif (lrf.eq.2) then call ggmlbw(e1,sig1,b(1)) endif else do i=1,4 sig1(i)=0 enddo endif c ii=ii+1 if (ii.gt.maxe) call error('resprx', & 'number of pointwise xsec of resonance exceeded.', & 'please increase the maxe parameter.') c do i=1,4 sig(ii,i)=sig1(i) enddo sig(ii,5)=e1 c if (e1.lt.ehg) then if(e1.lt.0.1)then e2=1.05 else if(e1.gt.elb1.and.e1.lt.elu1)then e2=eskip1 else if(e1.gt.elb2.and.e1.lt.elu2)then e2=eskip2 else if(e1.gt.elb3.and.e1.lt.elu3)then e2=eskip3 else e2=1.02 endif ebc=e1 e1=e1*e2 if(ebc.lt.el.and.e1.gt.el)e1=el if(ebc.lt.eh.and.e1.gt.eh)e1=eh go to 520 endif c return end c subroutine Resprx_dumrd2(matd,nendf,nscr6,a,amu,mxlru2) c ****************************************************************** c dummy read the resonance parameters (mf=2). c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension a(*),amu(3,mxlru2) character strng*60 data nscr16/0/ c c ***read mf=2 (resonance parameters) call findf(matd,2,151,nendf) call contio(nendf,nscr6,0,a,nb,nw) nis=n1h nlru2=0 c c ***loop over all isotopes do ni=1,nis call contio(nendf,nscr6,0,a,nb,nw) lfw=l2h ner=n1h c c ***loop over all energy ranges do ne=1,ner call contio(nendf,nscr6,0,a,nb,nw) lru=l1h lrf=l2h nro=n1h if (nro.gt.0) call tab1io(nendf,nscr6,0,a,nb,nw) c c ***breit-wigner if (lru.eq.1.and.(lrf.eq.1.or.lrf.eq.2)) then call contio(nendf,nscr6,0,a,nb,nw) nls=n1h do nl=1,nls call listio(nendf,nscr6,0,a,nb,nw) 110 if (nb.eq.0) go to 120 call moreio(nendf,nscr6,0,a,nb,nw) go to 110 120 continue enddo c c ***reich-moore elseif (lru.eq.1.and.lrf.eq.3) then call contio(nendf,nscr6,0,a,nb,nw) nls=n1h do nl=1,nls call listio(nendf,nscr6,0,a,nb,nw) 130 if (nb.eq.0) go to 140 call moreio(nendf,nscr6,0,a,nb,nw) go to 130 140 continue enddo c c ***unresolved resonance (lrf=1,lfw=0) elseif (lru.eq.2.and.lrf.eq.1.and.lfw.eq.0) then call contio(nendf,nscr6,0,a,nb,nw) nls=n1h do nl=1,nls call listio(nendf,nscr6,0,a,nb,nw) 150 if (nb.eq.0) go to 160 call moreio(nendf,nscr6,0,a,nb,nw) go to 150 160 continue enddo call error('dumrd2','lru=2/lrf=1/lfw=0: amu? no coding', & ' ') c c ***unresolved resonance (lrf=1,lfw=1) elseif (lru.eq.2.and.lrf.eq.1.and.lfw.eq.1) then call listio(nendf,nscr6,0,a,nb,nw) nls=nint(a(6)) do nl=1,nls call contio(nendf,nscr6,0,a,nb,nw) njs=n1h do nj=1,njs call listio(nendf,nscr6,0,a,nb,nw) 170 if (nb.eq.0) go to 180 call moreio(nendf,nscr6,0,a,nb,nw) go to 170 180 continue enddo enddo call error('dumrd2','lru=2/lrf=1/lfw=1: amu? no coding', & ' ') c c ***unresolved resonance (lrf=2) elseif (lru.eq.2.and.lrf.eq.2) then call contio(nendf,nscr6,0,a,nb,nw) nls=n1h do nl=1,nls call contio(nendf,nscr6,0,a,nb,nw) njs=n1h do nj=1,njs call listio(nendf,nscr6,0,a,nb,nw) nlru2=nlru2+1 amu(1,nlru2)=a(10) amu(2,nlru2)=a(12) amu(3,nlru2)=a(9) 190 if (nb.eq.0) go to 200 call moreio(nendf,nscr6,0,a,nb,nw) go to 190 200 continue enddo enddo c else write(strng,'('' *** lru='',i3,'' lrf='',i3, & '' no coding.'')') lru,lrf call error('dumrd2',strng,' ') endif if (nlru2.gt.mxlru2) call error('dumrd2', & 'nlru2 was exceeded mxlru2',' ') enddo enddo c return end c subroutine Resprx_grping(igx,egn,sig,ipoint,gsig,a) c ****************************************************************** c convert pointwise cross sections to simplistic groupwise ones. c ****************************************************************** implicit real*8 (a-h,o-z) parameter(maxe=400000) common/ewght/iwt dimension a(*),egn(*),sig(maxe,5),gsig(4,901) data half,zero/0.5d0,0.d0/ data two, three, six /2.0d0, 3.0d0, 6.0d0 / c do k=1,igx do i=2,4 gsig(i,k)=0 enddo enddo c sumde=0 lord=0 i0=1 100 continue do ig=1,igx if (sig(i0,5).ge.egn(ig).and.sig(i0,5).lt.egn(ig+1)) go to 110 enddo if (i0.lt.ipoint) then i0=i0+1 go to 100 else stop 'grping: no coding for i0>ipoint' endif 110 continue c x1=sig(i0,5) call egtwtf(x1,enext,idis,lord,wt1,a) c ***loop over all pointwise cross sections in a range do i=i0+1,ipoint c wt2 = wt1 x2 = x1 x1 = sig(i,5) x12 = x1-x2 egnt = egn(ig) egnt1= egn(ig+1) call egtwtf(x1,enext,idis,lord,wt1,a) if (x1.ge.egnt.and.x1.le.egnt1) then de = half * (x1-x2) * (wt1+wt2) sumde=sumde+de z1 = (two*wt1+wt2)*x12/six z2 = (two*wt2+wt1)*x12/six do j=2,4 y1=sig(i,j) y2=sig(i-1,j) if (y1.ne.zero .or. y2.ne.zero) then xx = y1*z1 + y2*z2 gsig(j,ig)=gsig(j,ig)+xx endif enddo if (x1.eq.egnt1) then do j=2,4 gsig(j,ig)=gsig(j,ig)/sumde enddo ig=ig+1 sumde=0 endif else if (x1.gt.egnt1) then ebb=egnt1 Ebx = Ebb - X2 Wt12 = Wt1 - Wt2 De = Half*Wt12*Ebx/x12 + Wt2 De = Ebx * Wt2 sumde=sumde+de Ebx2 = Ebx**2 Z1 = (Ebx /x12) * Wt12/Three + wt2/Two Z1 = (Ebx2/x12) * Z1 Z2 =-(Ebx /x12) * Wt12/Three + (wt1/Two-wt2) Z2 = (Ebx /x12) * Z2 + wt2 Z2 = Ebx * Z2 do j=2,4 y1=sig(i,j) y2=sig(i-1,j) if (y1.ne.zero .or. y2.ne.zero) then Xx = Y1*Z1 + Y2*Z2 gsig(j,ig)=gsig(j,ig)+xx endif enddo do j=2,4 gsig(j,ig)=gsig(j,ig)/sumde enddo ig=ig+1 Ebx = X1 - Ebb De = - Half*Wt12*Ebx/x12 + Wt2 De = Ebx * Wt2 sumde=de Ebx2 = Ebx**2 Z1 = (Ebx /x12) * Wt12/Three + (wt2/Two-wt1) Z1 = (Ebx /x12) * Z1 + wt1 Z1 = Ebx * Z1 Z2 =-(Ebx /x12) * Wt12/Three + wt1/Two Z2 = (Ebx2/x12) * Z2 do j=2,4 y1=sig(i,j) y2=sig(i-1,j) if (y1.ne.zero .or. y2.ne.zero) then Xx = Y1*Z1 + Y2*Z2 gsig(j,ig)=gsig(j,ig)+xx endif enddo endif enddo c c ***calculate group total cross section do k=1,igx gsig(1,k)=gsig(2,k)+gsig(3,k)+gsig(4,k) enddo c return end c subroutine Resprx_skiprp(iu,adim,ni,ne) c ****************************************************************** c skip to the resonance parameter of subsection requested by ni & ne c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension adim(*) character strng*60 c call repoz(iu) call contio(iu,0,0,adim,nb,nw) nis1=n1h do ni1=1,nis1 call contio(iu,0,0,adim,nb,nw) ner1=n1h do ne1=1,ner1 if (ni1.eq.ni.and.ne1.eq.ne) go to 130 call contio(iu,0,0,adim,nb,nw) lrf1=l2h if (lrf1.ge.4) then write(strng,'(''lrf='',i3)') lrf1 call error('skiprp','no coding type',strng) endif call contio(iu,0,0,adim,nb,nw) nls1=n1h do nl1=1,nls1 call listio(iu,0,0,adim,nb,nw) 110 if (nb.eq.0) go to 120 call moreio(iu,0,0,adim,nb,nw) go to 110 120 continue enddo enddo enddo 130 continue c return end c subroutine grpav4(mprint,a) c ****************************************************************** c compute multigroup legendre coefficients for reaction needed in c the calculation of the covariance matrices. calculation uses the c union of the user specified group structure and the energy c grid found in mfcov. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,ntot,nscr3 common/eunits34/nscr4 common/mainio/nsysi,nsyso,nsyse,ntty common/util/npage,iverf common/argcom/matl,mfd,mtd common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/err4/legord,irespr,ifissp common/tramat/u1lele(10),plele(901,10) character*60 strng character*66 text dimension a(*),ans(10,2),z(26) data eps/1.d-9/ data big/1.d10/ data elow/1.d-5/ zero=0 c c ***initialize if (iread.eq.2) call error('grpav4', & 'not coded for multimaterial group averaging.',' ') call timer(sec) write(nsyso,'(/,'' computing multigroup legendre coef.'', & 33x,f8.1,''s'')') sec call egnwtf(a) nwds=npage+50 call reserv('scr',nwds,iscr,a) nscr4=14 if (nendf.lt.0) nscr4=-nscr4 call openz(nscr4,1) call repoz(nscr4) math=1 mfh=0 mth=0 text=' ' nw=17 read(text,'(16a4,a2)') (z(i),i=1,nw) call tpidio(0,nscr4,0,z,nb,nw) call findex('un',iun,a) iun1=iun-1 if (abs(egn(1)-elow).le.eps) egn(1)=elow etop=a(iun+nunion) c c ***search for desired mat on nendf tape call repoz(nendf) call findf(matd,1,0,nendf) call contio(nendf,0,0,a(iscr),nb,nw) za=c1h awr=c2h c c ***main loop over reactions call findex('ga',iga,a) matl=matd mfd=4 math=matd mfh=4 mtold=0 il=10 iz=1 nw=legord*iz+1 do 300 imt=1,nga mtd=nint(a(iga+imt-1)) call timer(time) mth=mtd z(1)=za z(2)=awr z(3)=1 z(4)=legord z(5)=0 z(6)=nunion call contio(0,nscr4,0,z,nb,nwds) c c ***initialize ng2=2 e=0 call egtlgc(e,thresh,idis,al,a) if (thresh.gt.etop) go to 270 call egtflx(e,enext,idis,flux,nl,nz,a) if (mprint.ne.0) then write(nsyso,30) legord,time if (ntty.gt.0) write(ntty,31) legord,time write(nsyso,32) u1lele(2) write(nsyso,45) mfd,mtd,' (same as mf=3/mt=251)' if (ntty.gt.0) write(ntty,45) mfd,mtd, & ' (same as mf=3/mt=251)' write(nsyso,10) endif call findex('un',iun,a) c c ***loop over initial energy groups do 260 ig=1,nunion elo=a(iun+ig-1) ehi=a(iun+ig) ig2lo=0 enext=ehi do j=1,2 do i=1,il ans(i,j)=0 enddo enddo c 220 call epanel(elo,enext,ans,il,iz,ig2lo,34,a) if (abs(enext/ehi-1.).lt.eps) goto 230 elo=enext enext=ehi go to 220 230 continue c c ***write this group on nscr4 tape do i=1,9 ans(i,2)=ans(i,2)/ans(1,1) plele(ig,i)=ans(i,2) c ***legendre coefficient a_i in center mass system enddo ans(1,2)=ans(1,2)*u1lele(2) c if (mprint.ne.0) write(nsyso,70) ig,(ans(i,2),i=1,legord) if (ig.ne.nunion) then do 245 i=1,legord 245 if (ans(i,2).ne.0.) go to 250 go to 260 endif 250 mfh=mfd mth=mtd z(1)=0. z(2)=0. z(3)=ng2 z(4)=ig2lo z(5)=nw z(6)=ig z(7)=ans(1,1) do 255 i=1,legord 255 z(i+7)=ans(i,2) nwds=legord+7 call listio(0,nscr4,0,z,nb,nwds) 260 continue call asend(nscr4,0) go to 280 c ***write message if mt has threshold gt highest union energy 270 write(strng,'(''mf '',i2,'' mt '',i3)') mfd,mtd call mess('grpav4',strng, & 'has threshold gt highest union energy.') 280 call releas('alnr',-1,a) 300 continue c c ***grpav4 is finished. call afend(nscr4,0) call amend(nscr4,0) call atend(nscr4,0) call releas('scr',-1,a) call releas('ga',0,a) call timer(sec) write(nsyso,40) sec if (ntty.gt.0) write(ntty,41) sec return c 10 format(5x,'group',5x,'legendre constant') 30 format(/,' legendre group constants: pl-order 1 to ',i2,26x,f8.1, & 's') 31 format(1x,'pl=',i2,3x,f8.1,'s') 32 format(' u(1,1) element of transformation matrix (cm -> lab)=', & 1pe12.5) 40 format(/,' legendre group averaging completed',34x,f8.1,'s',/) 41 format(/,' legendre group averaging completed',/,1x,f8.1,'s') 45 format(' for mf',i2,' and mt',i3,a) 70 format(4x,i4,5x,1p,6e11.3:/(13x,6e11.3)) end c c subroutine alsigc(ncg,alsig,cflx,b,egt,flux,sig,alp,ld,ld1,mt1, & mt2) c ****************************************************************** c calculate the coarse group legendre*sigma. c ****************************************************************** implicit real*8 (a-h,o-z) common/grpn/ign,ngn,egn(901),iprint common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/eunits/nendf,npend,nout,nin,ngout,nstan,nunit(3) common/eunits34/nscr4 common/tramat/u1lele(10),plele(901,10) dimension alsig(ncg,*),cflx(ncg,*),b(*),egt(*),flux(*),sig(*), & alp(*) data mfinit/0/ c c ***initialize if (nlump.gt.0) call error('alsigc','no coded lump xsec.',' ') if (mfinit.ne.0) go to 200 mfinit=34 c ***call sigfig to cure the bit-dropping problem do 110 i=1,nunion+1 110 egt(i)=sigfig(egt(i),ndig,0) do 120 i=1,ngn+1 120 egn(i)=sigfig(egn(i),ndig,0) c c ***compute cross-group legendre*sigma*flux and sigma*flux 200 call rdsig(matd,mt1,b,sig) call rdlgnd(nscr4,matd,mt1,ld,b,alp) do 220 ig=1,ngn alsig(ig,1)=0. cflx(ig,1)=0. do 210 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 210 alsig(ig,1)=alsig(ig,1)+alp(jg)*sig(jg)*flux(jg) cflx(ig,1)=cflx(ig,1)+sig(jg)*flux(jg) 210 continue 220 alsig(ig,1)=alsig(ig,1)/cflx(ig,1) call rdsig(matd,mt2,b,sig) call rdlgnd(nscr4,matd,mt2,ld1,b,alp) do 240 ig=1,ngn alsig(ig,2)=0. cflx(ig,2)=0. do 230 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 230 alsig(ig,2)=alsig(ig,2)+alp(jg)*sig(jg)*flux(jg) cflx(ig,2)=cflx(ig,2)+sig(jg)*flux(jg) 230 continue 240 alsig(ig,2)=alsig(ig,2)/cflx(ig,2) return end c subroutine egtlgc(e,enext,idis,al,a) c ****************************************************************** c retrieve the legendre coefficient defined by mfd and mtd. c initialize if e=0. c ****************************************************************** implicit real*8 (a-h,o-z) parameter (maxleg=64) common/eunits/nendf,npend,nunit(7) common/argcom/matd,mfd,mtd common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/tabl/nr,nbt(20),jnt(20) common/util/npage,iverf common/tramat/u1lele(10),plele(901,10) dimension al(*),a(*),al1(maxleg),al2(maxleg) save nsig,int,nnr,ne,nne,nl1,nl2,e1,e2,al1,al2 c c ***initialize idis=0 if (e.gt.0.) go to 200 nsig=nendf mf=4 mt=mtd call findf(matd,mf,mt,nsig) nw=46 call reserv('alnr',nw,ialnr,a) nw=70 call reserv('alg',nw,ialg,a) call contio(nsig,0,0,a(ialnr),nb,nw) aww=c2h lvt=l1h ltt=l2h if (lvt.eq.1) then nw=(maxleg+1)**2+6 call reserv('alv',nw,ialv,a) call listio(nsig,0,0,a(ialv),nb,nw) ialv1=ialv 105 if (nb.eq.0) go to 106 ialv1=ialv1+nw call moreio(nsig,0,0,a(ialv1),nb,nw) go to 105 106 continue nm=nint(a(ialv+5)) do 107 ij = 1 , 10 u1lele(ij)=a(ialv+6+(nm+1)+ij-1) 107 continue call releas('alv',0,a) else call contio(nsig,0,0,a(ialnr),nb,nw) call matrixin(aww,u1lele) endif if (ltt.eq.2) call error('egtlgc','no coded for ltt=2.',' ') call tab2io(nsig,0,0,a(ialnr),nb,nw) nr=n1h ne=n2h if (nsig.lt.0) then do 110 i=1,nr nbt(i)=nint(a(ialnr+i*2+4)) 110 jnt(i)=nint(a(ialnr+i*2+5)) endif int=jnt(1) call listio(nsig,0,0,a(ialg),nb,nw) e1=c2h nl1=n1h do 120 i=1,nl1 120 al1(i)=a(ialg+5+i) if (nl1.lt.maxleg) then do 125 i=nl1+1,maxleg 125 al1(i)=0. endif call listio(nsig,0,0,a(ialg),nb,nw) e2=c2h nl2=n1h do 130 i=1,nl2 130 al2(i)=a(ialg+5+i) if (nl2.lt.maxleg) then do 135 i=nl2+1,maxleg 135 al2(i)=0. endif nnr=1 nne=2 enext=e2 return c c ***retrieve legendre coefficient 200 call findex('alg',ialg,a) do 205 i=1,maxleg 205 al(i)=0. if (e.ge.e2) then if (nne.eq.ne.and.e.le.e2*1.00001) go to 300 if (nne.ge.ne) go to 400 do 210 i=1,nl2 210 al1(i)=al2(i) if (nl2.lt.maxleg) then do 215 i=nl2+1,maxleg 215 al1(i)=0. endif nl1=nl2 e1=e2 call listio(nsig,0,0,a(ialg),nb,nw) e2=c2h nl2=n1h do 220 i=1,nl2 220 al2(i)=a(ialg+5+i) if (nl2.lt.maxleg) then do 225 i=nl2+1,maxleg 225 al2(i)=0. endif nne=nne+1 endif c 300 n=max(nl1,nl2) if (nne.gt.nbt(nnr)) then nnr=nnr+1 int=jnt(nnr) endif do 310 i=1,n 310 call terp1(e1,al1(i),e2,al2(i),e,al(i),int) c 400 continue enext=e2 return end c subroutine musigc(ncg,csig,cflx,b,egt,flux,sig,alp) c ****************************************************************** c calculate the coarse group mubar. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/eunits/nendf,nin,nout,ninc,ngout,nstan,nunit(2),nscr common/eunits34/nscr4 common/mainio/nsysi,nsyso,nsyse,ntty common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/tramat/u1lele(10),plele(901,10) dimension csig(ncg,*),cflx(*),b(*),egt(*),flux(*),sig(*),alp(*) dimension c(6) data hmt/2hmt/, uline/5h-----/ c c ***put the coarse group structure on nout, ala groupr if (nout.eq.0) go to 140 mat=matd mf=1 mt=451 b(1)=za b(2)=awr b(3)=0 b(4)=0 b(5)=-11 b(6)=0 call contio(0,nout,0,b,nb,nw) b(1)=0.d0 b(2)=0.d0 b(3)=ngn nw=6 ngnp1=ngn+1 do 110 i=1,ngnp1 nw=nw+1 110 b(nw)=egn(i) np=nw-6 b(5)=np loc=1 call listio(0,nout,0,b(loc),nb,nw) 120 if (nb.eq.0) go to 130 loc=loc+nw call moreio(0,nout,0,b(loc),nb,nw) go to 120 130 continue call asend(nout,0) call afend(nout,0) 140 continue c c ***initialize mfd=3 c ***call sigfig to cure the bit-dropping problem. nun1=nunion+1 do 150 i=1,nun1 150 egt(i)=sigfig(egt(i),ndig,0) ngn1=ngn+1 do 160 i=1,ngn1 160 egn(i)=sigfig(egn(i),ndig,0) c ***calculate coarse group flux do 180 ig=1,ngn cflx(ig)=0.d0 do 170 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 170 cflx(ig)=cflx(ig)+flux(jg) 170 continue 180 continue c c ***mt=251, mubar: average cosine of the scattering angle c ***(laboratory system) for elastic scattering. c ***compute cross-group cross sections and write on output tape. mat=matd mf=3 mt=2 call rdsig(mat,mt,b,sig) ld=1 call rdlgnd(nscr4,mat,mt,ld,b,alp) ix=1 do 280 ig=1,ngn csig(ig,ix)=0. abit=0. do 270 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 270 sss0=0.0 do 271 ij = 2 , 9 sss0=sss0+plele(jg,ij)*u1lele(ij+1) 271 continue csig(ig,ix)=csig(ig,ix)+sig(jg)*flux(jg)* & (alp(jg)+u1lele(1)+sss0) abit=abit+sig(jg)*flux(jg) 270 continue csig(ig,ix)= csig(ig,ix)/abit 280 continue mf=3 mt=251 if (nout.eq.0) go to 320 b(1)=0.d0 b(2)=0.d0 b(3)=0 b(4)=0 b(5)=ngn b(6)=0 ibase=6 ip=0 do 310 ig=1,ngn ip=ip+1 b(ibase+ip)=csig(ig,ix) if (ip.lt.npage.and.ig.lt.ngn) go to 310 if (ibase.eq.0) go to 300 call listio(0,nout,0,b,nb,nwds) ibase=0 ip=0 go to 310 300 call moreio(0,nout,0,b,nb,ip) ip=0 310 continue call asend(nout,0) 320 continue 210 continue c c ***print cross sections in columns. mt=251 write(nsyso,10) hmt,mt write(nsyso,15) (uline,i=1,2) do 450 ig=1,ngn c(1)=csig(ig,1) write(nsyso,20) ig,egn(ig),cflx(ig),c(1) 450 continue if (nout.ne.0) call afend(nout,0) return c 10 format(/,' table of multigroup data',//, & ' group lower group cosine',/, & ' no. energy flux ',4x,4(a2,i3,7x)) 15 format( ' ----- ------ ----- ',4x,4(2a5,2x)) 20 format(i5,1p,6e12.4) end c c ***Transformation Matrix c subroutine matrixin(awr,res) c c ***This routine was given by T.Nakagawa of JAEA. c implicit real*8 (a-h,o-z) dimension bc(800),res(10) c nlmax=20 c c ***the transformation matrix c call matrixej(awr,nlmax,bc,res) c return end c FUNCTION CLEB(I1,I2,I3) c*********************************************************************** c* CLEB = CLEBSCH-GORDAN COEFFICIENT * c* THIS FUNCTION WAS TAKEN FROM THE PROGRAM MATRIX. * c*********************************************************************** implicit real*8 (a-h,o-z) DIMENSION FAC(101),NFAC(101) DATA FAC /1.0d0,1.0d0,2.0d0,6.0d0,2.4d0,1.2d0, & 7.2d0,5.04d0,4.032d0,3.6288d0,3.6288d0,3.99168d0,4.790016d0, & 6.2270208d0,8.7178291d0,1.3076744d0,2.0922790d0,3.5568743d0, & 6.4023737d0,1.2164510d0,2.4329020d0,5.1090942d0,1.1240007d0, & 2.5852017d0,6.2044840d0,1.5511210d0,4.0329146d0,1.0888869d0, & 3.0488834d0,8.8417620d0,2.6525286d0,8.2228387d0,2.6313084d0, & 8.6833176d0,2.9523280d0,1.0333148d0,3.7199333d0,1.3763753d0, & 5.2302262d0,2.0397882d0,8.1591528d0,3.3452527d0,1.4050061d0, & 6.0415263d0,2.6582716d0,1.1962222d0,5.5026222d0,2.5862324d0, & 1.2413916d0,6.0828186d0,3.0414093d0,1.5511188d0,8.0658175d0, & 4.2748833d0,2.3084370d0,1.2696403d0,7.1099859d0,4.0526920d0, & 2.3505613d0,1.3868312d0,8.3209871d0,5.0758021d0,3.1469973d0, & 1.9826083d0,1.2688693d0,8.2476506d0,5.4434494d0,3.6471111d0, & 2.4800355d0,1.7112245d0,1.1978572d0,8.5047859d0,6.1234458d0, & 4.4701155d0,3.3078854d0,2.4809141d0,1.8854947d0,1.4518309d0, & 1.1324281d0,8.9461821d0,7.1569457d0,5.7971260d0,4.7536433d0, & 3.9455240d0,3.3142401d0,2.8171041d0,2.4227095d0,2.1077573d0, & 1.8548264d0,1.6507955d0,1.4857160d0,1.3520015d0,1.2438414d0, & 1.1567725d0,1.0873662d0,1.0329978d0,9.9167793d0,9.6192760d0, & 9.4268904d0,9.3326215d0,9.3326215d0/ DATA NFAC /4*0,1,2,2,3,4,5,6,7,8,9,10,12,13,14, &15,17,18,19,21,22,23,25,26,28,29,30,32,33,35,36,38,40,41,43,44,46, &47,49,51,52,54,56,57,59,61,62,64,66,67,69,71,73,74,76,78,80,81,83, &85,87,89,90,92,94,96,98,100,101,103,105,107,109,111,113,115,116, &118,120,122,124,126,128,130,132,134,136,138,140,142,144,146,148, &149,151,153,155,157/ c CLEB=0.0 N1=I1+I2-I3+1 IF(N1.LE.0) GO TO 99 N2=I1-I2+I3+1 IF(N2.LE.0) GO TO 99 N3=-I1+I2+I3+1 IF(N3.LE.0) GO TO 99 IT=I1+I2+I3 IF(MOD(IT,2).NE.0) GO TO 99 N4=IT+2 NEPT=NFAC(N1)+NFAC(N2)+NFAC(N3)-NFAC(N4) IF(NEPT.LT.33) GO TO 50 WRITE(6,1000) NEPT 1000 FORMAT(35H0NEPT IS GREATER THAN 32 AND EQUALS,I5) GO TO 99 50 ARG=FAC(N1)*FAC(N2)*FAC(N3)/FAC(N4) Z1=ARG*10.0**NEPT D123=SQRT(Z1) IS=IT/2 SIGNX=1 IF(MOD(IS+I3,2).EQ.1) SIGNX=-1 IA=IS+1 IB=IS-I1+1 IC=IS-I2+1 ID=IS-I3+1 NEPT=NFAC(IA)-NFAC(IB)-NFAC(IC)-NFAC(ID) ARG=FAC(IA)/(FAC(IB)*FAC(IC)*FAC(ID)) Z1=2*I3+1 CLEB=SIGNX*SQRT(Z1)*D123*ARG*10.0**NEPT 99 RETURN END c SUBROUTINE MATRIXEJ(AWR,NM,BC,res) c*********************************************************************** c* CALCULATES A TRANSFORMATION MATRIX. THIS SUBROUTINE WAS TAKEN * c* FROM THE PROGRAM MATRIX. * c*********************************************************************** implicit real*8 (a-h,o-z) DIMENSION BC(*) DIMENSION T(65,65),res(10) c M=NM+1 A=AWR G=1.0/A 16 MM=MIN0(2*M,30) DO 20 I=1,MM DO 20 L=1,M T(L,I)=0.0 20 CONTINUE T(1,1)=1.0 100 T(2,1)=2.0*G/3.0 T(2,2)=1.0-.6*G**2 MUP=0 DO 110 I=3,MM I1=I-1 Z1=I1 Z2=I1+2 Z3=2*I1-1 Z4=2*I1+3 I2=I1-1 X1=(Z1/Z3-Z2*G**2/Z4)*(-G)**I2 T(2,I)=X1 IF(MUP.NE.0) GO TO 105 IF(ABS(X1).GE.1.0E-16) GO TO 110 MUP=I1 105 IF(ABS(X1).LT.1.0E-32) GO TO 120 110 CONTINUE IF(MUP.EQ.0) MUP=M 120 ILO=1 DO 160 L=3,M L1=L-2 Z1=2*L1+1 Z2=L1+1 Z3=L1 ILOW=ILO DO 150 I=ILOW,MM I1=I-1 SUM=-Z3*T(L1,I)/Z2 DO 140 N1=1,MUP X2=T(2,N1) IF(ABS(X2).EQ.0.0) GO TO 140 N2=N1-1 MAX=N2+I1+1 IF(MAX.GT.MM) MAX=MM MIN=IABS(N2-I1)+1 SUM1=0.0 DO 130 M1=MIN,MAX,2 X1=T(L1+1,M1) IF(ABS(X1).LT.1.0E-16) GO TO 130 M2=M1-1 SUM1=SUM1+CLEB(N2,M2,I1)**2*X1 130 CONTINUE SUM=SUM+Z1*X2*SUM1/Z2 140 CONTINUE 145 IF(I.GE.L) GO TO 147 IF(ABS(SUM).GE.ABS(T(L-1,I))) GO TO 148 147 T(L,I)=SUM GO TO 150 148 ILO=I+1 150 CONTINUE 160 CONTINUE 200 CONTINUE DO 300 I=1,M DO 300 L=1,M II=I-1 LL=L+M*II BC(LL)=T(L,I) IF(ABS(BC(LL)).LT.1.0E-20) BC(LL)=0.0 300 CONTINUE cej do 310 i=1,10 res(i)=t(2,i) 310 continue c return end c subroutine rdlgnd(nscr4,matd,mtd,npl,b,alp) c ****************************************************************** c read legendre coefficients from nscr4 tape produced subroutine c grpav4. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension b(*),alp(*) c c ***set up header record call repoz(nscr4) call findf(matd,4,mtd,nscr4) call contio(nscr4,0,0,b,nb,nwds) nl=l2h ngt=n2h do 110 i=1,ngt 110 alp(i)=0. if (npl.gt.nl) go to 200 il=npl+7 c c ***retrieve desired legendre coefficient 120 call listio(nscr4,0,0,b,nb,nwds) nw=n1h jg=n2h alp(jg)=b(il) if (jg.lt.ngt) go to 120 200 continue return end c subroutine fssigc(ncg,csig,cflx,b,egt,flux,sig) c ****************************************************************** c calculate the coarse group fission spectrum chi. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/eunits/nendf,nin,nout,ninc,ngout,nstan,nunit(2),nscr common/mainio/nsysi,nsyso,nsyse,ntty common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) dimension csig(ncg,*),cflx(*),b(*),egt(*),flux(*),sig(*) dimension c(6) data hmt/2hmt/, uline/5h-----/ c c ***put the coarse group structure on nout, ala groupr if (nout.eq.0) go to 140 mat=matd mf=1 mt=451 b(1)=za b(2)=awr b(3)=0 b(4)=0 b(5)=-12 b(6)=0 call contio(0,nout,0,b,nb,nw) b(1)=0.d0 b(2)=0.d0 b(3)=ngn nw=6 ngnp1=ngn+1 do 110 i=1,ngnp1 nw=nw+1 110 b(nw)=egn(i) np=nw-6 b(5)=np loc=1 call listio(0,nout,0,b(loc),nb,nw) 120 if (nb.eq.0) go to 130 loc=loc+nw call moreio(0,nout,0,b(loc),nb,nw) go to 120 130 continue call asend(nout,0) call afend(nout,0) 140 continue c c ***initialize c ***call sigfig to cure the bit-dropping problem. nun1=nunion+1 do 150 i=1,nun1 150 egt(i)=sigfig(egt(i),ndig,0) ngn1=ngn+1 do 160 i=1,ngn1 160 egn(i)=sigfig(egn(i),ndig,0) c ***calculate coarse group flux do 180 ig=1,ngn cflx(ig)=0.d0 do 170 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 170 cflx(ig)=cflx(ig)+flux(jg) 170 continue 180 continue c c ***mt=18, chi: fission spectrum (mf=5/mt=18) c ***compute cross-group cross sections and write on output tape. mat=matd mf=5 mt=18 call rdchi(mat,b,sig) ix=1 do 280 ig=1,ngn csig(ig,ix)=0.d0 do 270 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 270 csig(ig,ix)=csig(ig,ix)+sig(jg)*flux(jg) 270 continue 280 csig(ig,ix)=csig(ig,ix)/cflx(ig) if (nout.eq.0) go to 320 b(1)=0.d0 b(2)=0.d0 b(3)=0 b(4)=0 b(5)=ngn b(6)=0 ibase=6 ip=0 do 310 ig=1,ngn ip=ip+1 b(ibase+ip)=csig(ig,ix) if (ip.lt.npage.and.ig.lt.ngn) go to 310 if (ibase.eq.0) go to 300 call listio(0,nout,0,b,nb,nwds) ibase=0 ip=0 go to 310 300 call moreio(0,nout,0,b,nb,ip) ip=0 310 continue call asend(nout,0) 320 continue 210 continue c c ***print data in columns. mt=18 write(nsyso,10) hmt,mt write(nsyso,15) (uline,i=1,2) do 450 ig=1,ngn c(1)=csig(ig,1) write(nsyso,20) ig,egn(ig),cflx(ig),c(1) 450 continue if (nout.ne.0) call afend(nout,0) return c 10 format(/,' table of multigroup data',//, & ' group lower group chi ',/, & ' no. energy flux ',4x,4(a2,i3,7x)) 15 format( ' ----- ------ ----- ',4x,4(2a5,2x)) 20 format(i5,1p,6e12.4) end c subroutine rdchi(matd,b,chi) c ****************************************************************** c read the fission energy spectrum (chi). c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr(3) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension b(*),chi(*) c c ***set up header record call repoz(ngout) call findf(matd,5,18,ngout) call contio(ngout,0,0,b,nb,nwds) nl=l2h ngt=n2h do i=1,ngt chi(i)=0.d0 enddo c c ***retrieve desired chi 120 call listio(ngout,0,0,b,nb,nwds) nw=n1h jg=n2h chi(jg)=b(8) if (jg.lt.ngt) go to 120 c return end c subroutine ggrmat(e,sigp,a,npnls,valspi) c ****************************************************************** c calculates r-matrix(reich-moore) cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This subroutine is based on 'csrmat' routine in reconr. c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/pic/pi common/cwav/cwaven common/amnc/amassn dimension sigp(4),a(*) dimension r(3,3),s(3,3),ri(3,3),si(3,3) external error,facts,facphi,frobns data rc1,rc2,third/.123d0,.08d0,.333333333d0/ data quar,haf,uno,two,four/0.25d0,0.50d0,1.0d0,2.0d0,4.0d0/ c zero=0 c c ***compute cross sections at this energy do i=1,4 sigp(i)=0.d0 enddo c ***retrieve starting location for data in a cej inow=1 c ***retrieve nuclide information naps=nint(a(inow+5)) awri=a(inow+12) ap=a(inow+7) aw=amassn*awri ra=rc1*aw**third+rc2 if (naps.eq.1) ra=ap spi=a(inow+6) gjd=2*(2*spi+1) nls=nint(a(inow+10)) c ***calculate wave number(k),rho and rhocap at energy (e) arat=awri/(awri+1) k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap gfa=0 gfb=0 gf=0 inow=inow+12 c c ***loop over l states c ***with Go Chiba 10/3/2007 mods nlsmax=nls if (npnls.lt.nlsmax) nlsmax=npnls do l=1,nlsmax inowb=inow nrs=nint(a(inow+5)) ncyc=nint(a(inow+4))/nrs ll=nint(a(inow+2)) apl=a(inow+1) rhoc=k*ap rho=k*ra if (apl.ne.zero) rhoc=k*apl if (apl.ne.zero.and.naps.eq.1) rho=k*apl c ***calculate shift and penetration factors at cross section energy call facts(ll,rho,se,dum1) pe=dum1 call facphi(ll,rhoc,phi) c ***constants independent of res. energy phid=phi p1=cos(2*phid) p2=sin(2*phid) c ***loop over possible j values fl=ll ajmin=abs(abs(spi-fl)-haf) ajmax=spi+fl+haf numj=nint(ajmax-ajmin+1) ajc=ajmin-1 if (ll.ne.0.and.(fl.gt.spi-haf.and.fl.le.spi)) then jjl=0 else jjl=1 endif c do jj=1,numj inow=inowb ajc=ajc+1 cej, with 10/3/2007 mod if (abs(ajc-valspi).gt.0.01.or.l.ne.npnls) then in=(inow+6)+nrs*6+nrs*3 go to 180 endif gj=(2*ajc+1)/gjd c ***initialize matrix do j=1,3 do i=1,3 s(j,i)=0 r(j,i)=0 enddo enddo c c ***loop over resonances inow=inow+6 in=inow+nrs*6 do i=1,nrs aj=abs(a(inow+1)) c ***select only resonances with current j value if (abs(aj-ajc).le.quar) then c ***retrieve parameters er=a(inow) gn=a(inow+2) gg=a(inow+3) gfa=a(inow+4) gfb=a(inow+5) per=a(in+1) a1=sqrt(gn*pe/per) a2=0 if (gfa.ne.zero) a2=sqrt(abs(gfa)) if (gfa.lt.zero) a2=-a2 a3=0 if (gfb.ne.zero) a3=sqrt(abs(gfb)) if (gfb.lt.zero) a3=-a3 c ***compute energy factors diff=er-e den=diff*diff+quar*gg*gg de2=haf*diff/den gg4=quar*gg/den c ***calculate r-function, or c ***calculate upper triangular matrix terms r(1,1)=r(1,1)+gg4*a1*a1 s(1,1)=s(1,1)-de2*a1*a1 if (gfa.ne.zero.or.gfb.ne.zero) then r(1,2)=r(1,2)+gg4*a1*a2 s(1,2)=s(1,2)-de2*a1*a2 r(1,3)=r(1,3)+gg4*a1*a3 s(1,3)=s(1,3)-de2*a1*a3 r(2,2)=r(2,2)+gg4*a2*a2 s(2,2)=s(2,2)-de2*a2*a2 r(3,3)=r(3,3)+gg4*a3*a3 s(3,3)=s(3,3)-de2*a3*a3 r(2,3)=r(2,3)+gg4*a2*a3 s(2,3)=s(2,3)-de2*a2*a3 gf=1 endif endif inow=inow+ncyc in=in+3 enddo c ***r-matrix path -- make symmetric matrix if (gf.ne.zero) then r(1,1)=uno+r(1,1) r(2,2)=uno+r(2,2) r(3,3)=uno+r(3,3) r(2,1)=r(1,2) s(2,1)=s(1,2) r(3,1)=r(1,3) s(3,1)=s(1,3) r(3,2)=r(2,3) s(3,2)=s(2,3) c ***invert the complex matrix call frobns(r,s,ri,si) c ***fission term for r-matrix path t1=ri(1,2) t2=si(1,2) t3=ri(1,3) t4=si(1,3) termf=four*gj*(t1*t1+t2*t2+t3*t3+t4*t4) u11r=p1*(two*ri(1,1)-uno)+two*p2*si(1,1) u11i=p2*(uno-two*ri(1,1))+two*p1*si(1,1) termt=two*gj*(uno-u11r) termn=gj*((uno-u11r)**2+u11i**2) c c ***r-function path else dd=r(1,1) rr=uno+dd ss=s(1,1) amag=rr**2+ss**2 rri=rr/amag ssi=-ss/amag uur=p1*(two*rri-uno)+two*p2*ssi uui=p2*(uno-two*rri)+two*p1*ssi if (abs(dd).lt.small.and. & abs(phid).lt.small) then xx=2*dd xx=xx+2*(dd*dd+ss*ss+phid*phid+p2*ss) xx=xx-2*phid*phid*(dd*dd+ss*ss) xx=xx/amag termt=two*gj*xx termn=gj*(xx**2+uui**2) else termt=two*gj*(uno-uur) termn=gj*((uno-uur)**2+uui**2) endif termf=0 endif c ***cross sections contributions if (jj.gt.jjl.and.jj.lt.numj) then termn=termn+two*gj*(1-p1) termt=termt+two*gj*(1-p1) endif termg=termt-termf-termn sigp(2)=sigp(2)+termn sigp(4)=sigp(4)+termg sigp(3)=sigp(3)+termf sigp(1)=sigp(1)+termt c 180 continue enddo inow=in 200 continue c ***continue the loop over l values enddo c c ***calculate final cross sections and store for return sigp(1)=pifac*sigp(1) sigp(2)=pifac*sigp(2) sigp(3)=pifac*sigp(3) sigp(4)=pifac*sigp(4) return end c c subroutine ggrmatorg(e,sigp,a,npnls,valspi) c ****************************************************************** c calculates r-matrix(reich-moore) cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This subroutine is based on 'csrmat' routine in reconr. c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/pic/pi common/cwav/cwaven common/amnc/amassn dimension sigp(4),a(*) dimension r(3,3),s(3,3),ri(3,3),si(3,3) external error,facts,facphi,frobns data rc1,rc2,third/.123d0,.08d0,.333333333d0/ data quar,haf,uno,two,four/0.25d0,0.50d0,1.0d0,2.0d0,4.0d0/ c zero=0 c c ***compute cross sections at this energy do i=1,4 sigp(i)=0.d0 enddo c ***retrieve starting location for data in a cej inow=1 c ***retrieve nuclide information naps=nint(a(inow+5)) awri=a(inow+12) ap=a(inow+7) aw=amassn*awri ra=rc1*aw**third+rc2 if (naps.eq.1) ra=ap spi=a(inow+6) gjd=2*(2*spi+1) nls=nint(a(inow+10)) c ***calculate wave number(k),rho and rhocap at energy (e) arat=awri/(awri+1) k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap gfa=0 gfb=0 gf=0 inow=inow+12 c c ***loop over l states do l=1,nls if (l.ne.npnls) goto 200 inowb=inow nrs=nint(a(inow+5)) ncyc=nint(a(inow+4))/nrs ll=nint(a(inow+2)) apl=a(inow+1) rhoc=k*ap rho=k*ra if (apl.ne.zero) then rhoc=k*apl if (naps.eq.1) rho=k*apl endif c ***calculate shift and penetration factors at cross section energy call facts(ll,rho,se,dum1) pe=dum1 call facphi(ll,rhoc,phi) c ***constants independent of res. energy phid=phi p1=cos(2*phid) p2=sin(2*phid) c c ***loop over possible j values fl=ll ajmin=abs(abs(spi-fl)-haf) ajmax=spi+fl+haf numj=nint(ajmax-ajmin+1) ajc=ajmin-1 if (ll.ne.0.and.(fl.gt.spi-haf.and.fl.le.spi)) then jjl=0 else jjl=1 endif c do jj=1,numj inow=inowb ajc=ajc+1 cej if (abs(ajc-valspi).gt.0.01) go to 180 gj=(2*ajc+1)/gjd c ***initialize matrix do j=1,3 do i=1,3 s(j,i)=0. r(j,i)=0. enddo enddo c c ***loop over resonances inow=inow+6 in=inow+nrs*6 do i=1,nrs aj=abs(a(inow+1)) c ***select only resonances with current j value if (abs(aj-ajc).le.quar) then c ***retrieve parameters er=a(inow) gn=a(inow+2) gg=a(inow+3) gfa=a(inow+4) gfb=a(inow+5) per=a(in+1) a12=gn*pe/per a1=sqrt(a12) if (gfa.ne.zero) then a22=abs(gfa) a2=sqrt(a22) else a22=0 a2=0 endif if (gfa.lt.zero) a2=-a2 if (gfb.ne.zero) then a32=abs(gfb) a3=sqrt(a32) else a32=0 a3=0 endif if (gfb.lt.zero) a3=-a3 c ***compute energy factors diff=er-e den=diff*diff+quar*gg*gg de2=haf*diff/den gg4=quar*gg/den c ***calculate r-function, or c ***calculate upper triangular matrix terms r(1,1)=r(1,1)+gg4*a12 s(1,1)=s(1,1)-de2*a12 if (gfa.ne.zero.or.gfb.ne.zero) then a1a2=a1*a2 a1a3=a1*a3 a2a3=a2*a3 r(1,2)=r(1,2)+gg4*a1a2 s(1,2)=s(1,2)-de2*a1a2 r(1,3)=r(1,3)+gg4*a1a3 s(1,3)=s(1,3)-de2*a1a3 r(2,2)=r(2,2)+gg4*a22 s(2,2)=s(2,2)-de2*a22 r(3,3)=r(3,3)+gg4*a33 s(3,3)=s(3,3)-de2*a33 r(2,3)=r(2,3)+gg4*a2a3 s(2,3)=s(2,3)-de2*a2a3 gf=1 endif endif inow=inow+ncyc in=in+3 enddo c ***r-matrix path -- make symmetric matrix if (gf.ne.zero) then r(1,1)=uno+r(1,1) r(2,2)=uno+r(2,2) r(3,3)=uno+r(3,3) r(2,1)=r(1,2) s(2,1)=s(1,2) r(3,1)=r(1,3) s(3,1)=s(1,3) r(3,2)=r(2,3) s(3,2)=s(2,3) c ***invert the complex matrix call frobns(r,s,ri,si) c ***fission term for r-matrix path t1=ri(1,2) t2=si(1,2) t3=ri(1,3) t4=si(1,3) termf=four*gj*(t1*t1+t2*t2+t3*t3+t4*t4) u11r=p1*(two*ri(1,1)-uno)+two*p2*si(1,1) u11i=p2*(uno-two*ri(1,1))+two*p1*si(1,1) termt=two*gj*(uno-u11r) termn=gj*((uno-u11r)**2+u11i**2) c ***r-function path else dd=r(1,1) rr=uno+dd ss=s(1,1) amag=rr**2+ss**2 rri=rr/amag ssi=-ss/amag uur=p1*(two*rri-uno)+two*p2*ssi uui=p2*(uno-two*rri)+two*p1*ssi if (abs(dd).lt.small.and. & abs(phid).lt.small) then xx=2*dd dd2ss2=dd*dd+ss*ss phi2=phid*phid xx=xx+2*(dd2ss2+phi2+p2*ss) xx=xx-2*phi2*dd2ss2 xx=xx/amag termt=two*gj*xx termn=gj*(xx**2+uui**2) else termt=two*gj*(uno-uur) termn=gj*((uno-uur)**2+uui**2) endif termf=0 endif c ***cross sections contributions if (jj.gt.jjl.and.jj.lt.numj) then tmp=two*gj*(1-p1) termn=termn+tmp termt=termt+tmp endif sigp(2)=sigp(2)+termn sigp(4)=sigp(4)+termt-termf-termn sigp(3)=sigp(3)+termf sigp(1)=sigp(1)+termt c 180 continue enddo inow=in 200 continue c ***continue the loop over l values enddo c c ***calculate final cross sections and store for return sigp(1)=pifac*sigp(1) sigp(2)=pifac*sigp(2) sigp(3)=pifac*sigp(3) sigp(4)=pifac*sigp(4) return end c subroutine ggmlbw(e,sigp,a) c ****************************************************************** c calculates multilevel breit-wigner cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This routine is based on 'csmlbw' routine in reconr c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/pic/pi common/cwav/cwaven common/amnc/amassn dimension sigp(4),sigj(10,2),gj(10),a(*) external facts,facphi c data rc1,rc2,third/.123d0,.08d0,.333333333d0/ data half/.5d0/ zero=0 c c ***compute cross sections for this energy do i=1,4 sigp(i)=0.d0 enddo c ***retrieve starting location for data in a cej inow=1 c ***retrieve nuclide information naps=nint(a(inow+5)) awri=a(inow+12) ap=a(inow+7) aw=amassn*awri ra=rc1*aw**third+rc2 if (naps.eq.1) ra=ap spi=a(inow+6) den=4*spi+2 nls=nint(a(inow+10)) c ***calculate wave number(k),rho and rhocap at energy (e) arat=awri/(awri+1) k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap inow=inow+12 c c ***loop over l states do l=1,nls nrs=nint(a(inow+5)) ll=nint(a(inow+2)) qx=a(inow+1) lrx=nint(a(inow+3)) call facts(ll,rho,se,pe) pec=0 if (lrx.ne.0) then rhop=cwaven*arat*sqrt(abs(e+qx))*ra call facts(ll,rhop,sec,pec) endif call facphi(ll,rhoc,phi) cos2p=1-cos(2*phi) sin2p=sin(2*phi) sum=0 fl=ll ajmin=abs(abs(spi-fl)-half) ajmax=spi+fl+half nj=nint(ajmax-ajmin+1) aj=ajmin do i=1,nj gj(i)=(2*aj+1)/den aj=aj+1 sum=sum+gj(i) enddo diff=2*fl+1-sum do ii=1,2 do i=1,nj sigj(i,ii)=0 enddo enddo inow=inow+6 in=inow+nrs*6 c c ***loop over all resonances do i=1,nrs er=a(inow) j=a(inow+1)-ajmin+1.001 gn=a(inow+3) gg=a(inow+4) gf=a(inow+5) ser=a(in) per=a(in+1) rper=1/per gc=a(in+2) in=in+3 inow=inow+6 erp=er+gn*(ser-se)*rper/2 edelt=e-erp gne=gn*pe*rper gx=gg+gf gtt=gne+gx gtt=gtt+gc*pec x=2*edelt/gtt comfac=2*gne/gtt/(1+x*x) sigj(j,1)=sigj(j,1)+comfac sigj(j,2)=sigj(j,2)+comfac*x comfac=comfac*gj(j)/gtt sigp(3)=sigp(3)+comfac*gf sigp(4)=sigp(4)+comfac*gg enddo do j=1,nj add=gj(j)*((cos2p-sigj(j,1))**2+(sin2p+sigj(j,2))**2) sigp(2)=sigp(2)+add enddo sigp(2)=sigp(2)+2*diff*cos2p inow=in enddo c c ***construct the final cross sections sigp(2)=sigp(2)*pifac sigp(3)=sigp(3)*2*pifac sigp(4)=sigp(4)*2*pifac sigp(1)=sigp(2)+sigp(3)+sigp(4) c return end c subroutine ssmlbw(e,sigp,a,aa) c ****************************************************************** c calculates multilevel breit-wigner cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This routine is based on 'csmlbw' routine in reconr? c For one resonance? c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/reson1/ap,arat,ra,spifac,ll common/reson2/ajmin,gj(10),diff,nj common/pic/pi common/cwav/cwaven dimension sigp(4),sigj(10,2),a(6),aa(3) external facts,facphi c c ***initialize do 10 i=1,4 sigp(i)=0.d0 10 continue c c ***compute cross sections for this energy k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap c ***calculate shift and penetration factors at cross section energy call facts(ll,rho,se,pe) pec=0.d+0 call facphi(ll,rhoc,phi) cos2p=1-cos(2*phi) sin2p=sin(2*phi) do 21 ii=1,2 do 20 i=1,10 sigj(i,ii)=0.d0 20 continue 21 continue c er=a(1) j=a(2)-ajmin+1.001 gn=a(4) gg=a(5) gf=a(6) ser=aa(1) per=aa(2) rper=1/per gc=aa(3) erp=er+gn*(ser-se)*rper/2 edelt=e-erp c ***calculate the neutron width at e gne=gn*pe*rper gx=gg+gf gtt=gne+gx gtt=gtt+gc*pec x=2*edelt/gtt c ***cross section calculations= c ***common calculational factor comfac=2*gne/gtt/(1+x*x) c ***elastic components sigj(j,1)=sigj(j,1)+comfac sigj(j,2)=sigj(j,2)+comfac*x comfac=comfac*gj(j)/gtt c ***fission sigp(3)=sigp(3)+comfac*gf c ***capture sigp(4)=sigp(4)+comfac*gg c do 45 j=1,nj sigp(2)=sigp(2)+gj(j)* & ((cos2p-sigj(j,1))**2+(sin2p+sigj(j,2))**2) 45 continue sigp(2)=sigp(2)+2*diff*cos2p sigp(2)=sigp(2)*pifac sigp(3)=sigp(3)*2*pifac sigp(4)=sigp(4)*2*pifac c ***total sigp(1)=sigp(2)+sigp(3)+sigp(4) return end c subroutine ssslbw(e,sigp,a,aa) c ****************************************************************** c calculates single level breit-wigner cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This routine is based on 'csslbw' in reconr? c For one resonance? c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/reson1/ap,arat,ra,spifac,ll common/pic/pi common/cwav/cwaven dimension sigp(4),a(6),aa(3) external facphi,facts c c ***initialize do 10 i=1,4 sigp(i)=0.d0 10 continue c c ***compute cross sections for this energy k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap call facts(ll,rho,se,pe) pec=0.d+0 call facphi(ll,rhoc,phi) cos2p=cos(2*phi) sin2p=sin(2*phi) sinsq=(sin(phi))**2 spot=4*(2*ll+1)*pifac*sinsq c er=a(1) aj=a(2) gn=a(4) gg=a(5) gf=a(6) ser=aa(1) per=aa(2) rper=1/per gc=aa(3) gx=gg+gf c ***spin factor gj=(2*aj+1)*spifac/2 erp=er+gn*(ser-se)*rper/2 edelt=e-erp gne=gn*pe*rper gtt=gne+gx gtt=gtt+gc*pec c ***cross sections for temp=0. c ***elastic comfac=pifac*gj*gne/(edelt**2+gtt*gtt/4) sigp(2)=sigp(2)+ & comfac*(gne*cos2p-2*gx*sinsq+2*edelt*sin2p) c ***fission sigp(3)=sigp(3)+comfac*gf c ***capture sigp(4)=sigp(4)+comfac*gg c sigp(2)=sigp(2)+spot c ***total sigp(1)=sigp(2)+sigp(3)+sigp(4) c return end c subroutine ggunr1(e,sigp,a,amu,mxlru2) c ****************************************************************** c unresolved resonance region (format 1) c single level breit wigner formalism c energy independent parameters c parameter interpolation is always used. c ****************************************************************** c (ERRORJ) c This routine is for calculation of unresolved R.P. with MF=32 c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/pic/pi common/cwav/cwaven common/amnc/amassn dimension a(*),sigp(4),amu(3,mxlru2) external unfac,gnrl data rc1,rc2,third/.123d0,.08d0,.333333333d0/ zero=0 c c ***compute unresolved cross sections do i=2,4 sigp(i)=0.d0 enddo spi=a(1) ap=a(2) nls=nint(a(5)) nlru2=0 inow=7 c c ***compute unresolved cross sections c ***do loop over all l states do 190 l=1,nls awri=a(inow) ll=nint(a(inow+2)) njs=nint(a(inow+5)) arat=awri/(awri+1) aw=awri*amassn ra=rc1*aw**third+rc2 const=(2*pi**2)/(cwaven*arat)**2 inow=inow+6 c c ***do loop over all j states do 180 j=1,njs dx=a(inow) aj=a(inow+1) gnox=a(inow+2) ggx=a(inow+3) gfx=a(inow+4) gxx=a(inow+5) nlru2=nlru2+1 amun=amu(1,nlru2) mu=nint(amu(1,nlru2)) nu=nint(amu(2,nlru2)) lamda=nint(amu(3,nlru2)) gj=(2*aj+1)/(4*spi+2) e2=sqrt(e) k=arat*e2*cwaven rho=k*ra rhoc=k*ap c ***calculate penetrability (vl) and phase shift(ps) call unfac(ll,rho,rhoc,amun,vl,ps) vl=vl*e2 c ***calculate potential scattering if (j.eq.1) spot=4*pi*(2*ll+1)*(sin(ps)/k)**2 c ***compute cross section contributions gnx=gnox*vl diff=gxx den=e*dx temp=const*gj*gnx/den terg=temp*ggx ters=temp*gnx terf=temp*gfx c ***calculate fluctuation integrals call gnrl(gnx,gfx,ggx,mu,nu,lamda,gs ,diff,1) call gnrl(gnx,gfx,ggx,mu,nu,lamda,gc ,diff,2) call gnrl(gnx,gfx,ggx,mu,nu,lamda,gff,diff,3) gc=gc*terg gff=gff*terf gs=gs*ters c ***add interference correction add=const*gj*2*gnx*sin(ps)**2 add=add/(e*dx) gs=gs-add c ***cross sections sigp(2)=sigp(2)+gs sigp(3)=sigp(3)+gff sigp(4)=sigp(4)+gc inow=inow+6 180 continue sigp(2)=sigp(2)+spot 190 continue sigp(1)=sigp(2)+sigp(3)+sigp(4) c return end c subroutine covadd(iadd,imt,imtmax,ntape,nout) dimension imt(imtmax) character*66 dat character*44 dat2 c call openz(ntape,0) call openz(nout,1) c do i=1,4 read(ntape,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii write(nout,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii enddo c read(ntape,'(a44,i11,i11,i4,i2,i3,i5)')dat2,i1,i2,mat,mf,mt,ii write(nout,'(a44,i11,i11,i4,i2,i3,i5)') & dat2,i1,i2+iadd,mat,mf,mt,ii c do i=1,i1+i2 read(ntape,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii write(nout,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii enddo c do i=1,iadd write(nout,'(22x,4i11,i4,i2,i3,i5)') & 33,imt(i),4,0,mat,mf,mt,ii+i enddo c 1000 continue read(ntape,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii write(nout,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii c if(mf.eq.32.and.mt.eq.0)then write(nout,'(66x,i4,i2,i3,i5)')mat,0,0,99999 do i=1,iadd write(nout,'(6i11,i4,i2,i3,i5)') & 0,0,0,0,0,1,mat,33,imt(i),1 write(nout,'(6i11,i4,i2,i3,i5)') & 0,0,0,imt(i),0,1,mat,33,imt(i),2 write(nout,'(6i11,i4,i2,i3,i5)') & 0,0,1,5,3,2,mat,33,imt(i),3 write(nout,'(a33,33x,i4,i2,i3,i5)') & ' 1.000000-5 2.000000+7 0.000000+0',mat,33,imt(i),4 write(nout,'(66x,i4,i2,i3,i5)')mat,33,0,99999 enddo endif c if(mat.eq.-1)return goto 1000 c end *ident up259 */ groupr -- 16Oct07 */ use prompt nu-bar for the neutron multiplicity when processing */ mf6 fission (Sinitsa). *i groupr.4616 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then call getyld(e,en,idis,yld,matd,1,456,nend3,a) do ig=1,ng do il=1,nl ff(il,ig)=ff(il,ig)*yld enddo enddo if (en.lt.enext*(1-small)) then enext=en idisc=idis endif endif *ident vers */ update the version name and date */ to reflect the date of the latest modifications *d njoy.8,9 c * version 99.259 * c * 16 Oct 2007 * *d njoy.307 data vers/'99.259 '/ */ *ident x86lf9 */ ---------------------------------------- */ machine-dependent changes to njoy99 */ for x86 machines using */ Lahey LF95 with f77-style fixed lines */ be sure to use "*set sw" */ ---------------------------------------- *d njoy.308,309 data lab/'lanl t-2'/ data mx/'x86lf95'/ */ provide machine-specific fatal error exit *d njoy.365,366 stop 77 */ elapsed time *d njoy.514 call cpu_time(time) */ date *d njoy.524 character date*8,time*10,zone*5 integer values(8) intrinsic date_and_time call date_and_time(date,time,zone,values) write(hdate,'(i2,''/'',i2,''/'',i2)') & values(2),values(3),mod(values(1),100) */ wall clock time *d njoy.537 character date*8,time*10,zone*5 integer values(8) intrinsic date_and_time call date_and_time(date,time,zone,values) write(htime,'(i2,'':'',i2,'':'',i2)') & values(5),values(6),values(7) */ random numbers *d njoy.6161 call random_number(rr) rann=rr */ machine constants for slatec functions *d njoy.5323,5334 *d njoy.5338,5746 c for absoft f90 using f90 intrinsics dmach(1)=tiny(1.d0) dmach(2)=huge(1.d0) dmach(3)=2.d0**(-digits(1.d0)) dmach(4)=2.d0**(1-digits(1.d0)) dmach(5)=0.30103001d+0 */ */ OECD/NEA compilation of NJOY updates */ compatible with the official patch distribution up259 */ *ident upnea001 */ njoy - C. Broeders, 6-Oct-2006 */ Open scratch files in local disc area */ Ref.: Comments by D.E. Cullen in PrePro-2004 (Scratcha.f) on p.19 of: */ "http://www-nds.iaea.org/ndspub/endf/prepro/DOCUMENT/PDF/Overview.pdf" */ Status "scratch" does not work with Lahey compiler on Linux, */ therefore 'age" is set "unknown" *d njoy.470 age='unknown' *d njoy.471 write(fn,'(a,i2.2)') 'temp',nun open(nun,file=fn,form=for,status=age) */ *ident upnea004 */ groupr - C. Broeders, 6-Oct-2006 */ extend IWT=5 spectrum definition up to 200MeV */ ------------------------------------------- *d groupr.2145 dimension w1(92),w2(92),w3(10) *d groupr.2150 data w1/0d0,0d0,0d0,0d0,1.d0,93.d0,93.d0,5.d0, *i groupr.2175 data w3/3.d7,1.0318d-10,5.d7,6.1908d-11,1.d8,3.0954d-11, &1.5d8,2.0636d-11,2.d8,1.5477d-11/ *d groupr.2358 iw=194 *i groupr.2365 do i=1,10 a(i+183+iwght)=w3(i) enddo */ *ident upnea019 */ groupr A. Trkov, 24 July 2007 */ For backward compatibility change error stop to a warning message *d up167.22,23 if (sl.lt.zero.or.sn.lt.zero) call mess('getunr', & ' negative cross sections found - check unresr',' ') */ */ ident upnea020 is included in up235 */ *ident upnea021 */ groupr A. Trkov 30 Oct 2007 */ Lahey compiler does not like initialisation of variables in */ common with a data statement. *d up257.10 ebeg=1.d-5 *d up257.12 ebeg=1.e-5 */ *ident upnea022 */ errorr A. Trkov 30 Oct 2007 */ Lahey compiler identified several errors and warnings: */ - Subroutine "error" must be declared external in several routines. */ - Extend common "ewght" similar to common "weight" in groupr, */ introduce dummy common "temper", initialize with temperature "tempin", */ both needen in subroutine "egtwtf" (a more sophisticated patch */ might be needed). */ - Replace Hollerith constants "hmt" and "uline" with character. */ - Define constant "small" in two subroutines. */ - Define constant "a33" (PLEASE CHECK)! *i errorj.258 external error *i errorj.731 external error *i errorj.1362 external error *i errorj.2758 external error *i errorj.2996 external error *i errorj.3138 external error *i errorj.3487 external error *i errorj.3757 external error *i errorj.4099 external error *i errorj.5380 external error *i errorj.5825 external error *i errorj.5990 external error *i errorj.6360 external error *i errorj.6733 external error *i errorj.6853 external error *i errorj.7077 external error *i errorj.7142 external error *i errorj.7379 external error *i errorj.7433 external error *i errorj.7603 external error *i errorj.7655 external error *i errorj.7781 external error */ extend common "ewght" similar to common "weight" in groupr */ introduce dummy common "temper", initialize with temperature "tempin" */ both needen in subroutine "egtwtf" *d errorj.242 common/ewght/iwt,jsigz,jtemp common/temper/temp(10),ntemp *i errorj.351 ntemp=1 jtemp=1 temp(1)=tempin *d errorj.1356 common/ewght/iwt,jsigz,jtemp *d errorj.3484 common/ewght/iwt,jsigz,jtemp *d errorj.4090 common/ewght/iwt,jsigz,jtemp *d errorj.5375 common/ewght/iwt,jsigz,jtemp *d errorj.5568 common/ewght/iwt,jsigz,jtemp *d errorj.7260 common/ewght/iwt,jsigz,jtemp */ Replace Hollerith constants with character *i errorj.7769 character*2 hmt character*5 uline *d errorj.7782 data hmt/'mt'/, uline/'-----'/ *i errorj.8108 character*2 hmt character*5 uline *d errorj.8119 data hmt/'mt'/, uline/'-----'/ */ define constant small (please, check !!!!!) *i errorj.8275 data small/1.d-10/ *i errorj.8497 data small/1.d-10/ */ define constant a33 (please, check !!!!!) *i errorj.8622 a33 =a3*a3 *ident upnea023 */ errorr A. Trkov 04 Dec 2007 */ - Insufficientlength for the array at index iscr was reserved, */ causing the next block of data to be corrupted. */ All cases are affected where union grid>654 energy points. */ - Increase array size from 8M to 12M to process covariance */ matrices in 640 groups (external reference spectra for */ dosimetry). *d errorj.237 common/estore/a(12500000) *d errorj.272 namax=12500000 *d errorj.3131 common/estore/a(12500000) *d errorj.2772 nwds=max(npage+50,nunion+1+8) *d errorj.3499 nwscr=max(2*npage+50,nun1+8) *i errorj.3520 if (nw.gt.nwscr) & call error('colaps','storage exceeded.',' ') *d errorj.3758 data nxmax/800/, irmax/60/ *ident upnea024 */ covr A. Trkov 04 Dec 2007 */ Increase array size from 300k to 900k to process covariance */ matrices in 640 groups (external reference spectra for */ dosimetry). *d up111.12 common/storec/a(900000) *d up111.8 common/storec/a(900000) *d up111.10 data iamax/900000/, niad/15/, ipr/1/, ntics3/600/ *ident upnea025 */ reconr A. Trkov 09 Dec 2007 */ Allow processing of MT261, usen in the dosimetry library IRDF */ to store reference neutron fields (spectra). */ The patch has no impact on cross section processing. *d reconr.1689 if ((mth.ge.251.and.mth.le.300).and.mth.ne.261) go to 150 *ident upnea026 */ groupr A. Trkov 09 Dec 2007 */ Allow processing of MT261, usen in the dosimetry library IRDF */ to store reference neutron fields (spectra). */ The patch has no impact on cross section processing. *i groupr.3967 if (mtd.eq.261) mt=261 */ *ident upnea027 */ acer A. Trkov 14 Jan 2008 */ Implement enhancements that allow processing of dosimetry data */ including metastable nuclide excitation functions in MF10. */ Internally the ace MT numbers were extended according to the */ following convention: */ MT* = MT + 1000*(10+LFS) */ where LFS is the final state of the nuclide. *i acer.11525 c strip the leading digits from MT in dosimetry reactions if (i.gt.999) i=i-1000*(i/1000) *d acer.14319 c reserve all available space for scratch nwscr=-1 *d acer.14357 do while (mfh.ne.3 .and. mfh.ne.10) call tofend(nin,0,0,a(iscr)) call contio(nin,0,0,a(iscr),nb,nw) if (mfh.gt.10 .or. math.le.0) & call error('acedos','no x-sect. data for desired mat.',' ') end do *d acer.14367 if(mfh.gt.3) go to 110 *d acer.14371 */ guard against array overflow *i acer.14380 if(jscr.gt.nwscr) & call error('acedos','aray storage exceeded' & ,' Execution terminated') *i acer.14383 if(jscr.gt.nwscr) & call error('acedos','aray storage exceeded' & ,' Execution terminated') *i acer.14409 call contio(nin,0,0,a(iscr),nb,nw) *i acer.14411 c ***locate first reaction in file 10 call contio(nin,0,0,a(iscr),nb,nw) if (mfh.gt.10 .or. math.le.0) goto 120 do while (mfh.ne.10) call tofend(nin,0,0,a(iscr)) call contio(nin,0,0,a(iscr),nb,nw) if (mfh.gt.10 .or. math.le.0) goto 120 end do 110 continue c ***loop over reactions on nin do while (mfh.ne.0) ns=max(1,n1h) xss(lsig-1+j)=l if (mfh.ne.0) then if (mth.ne.1) then do is=1,ns jscr=iscr call tab1io(nin,0,0,a(jscr),nb,nw) lfs=l2h xss(mtr-1+j)=mth+1000*(10+lfs) nr=nint(a(iscr+4)) ne=nint(a(iscr+5)) intr=nint(a(iscr+7)) jscr=jscr+nw if(jscr.gt.nwscr) & call error('acedos','aray storage exceeded' & ,' Execution terminated') do while (nb.ne.0) call moreio(nin,0,0,a(jscr),nb,nw) jscr=jscr+nw if(jscr.gt.nwscr) & call error('acedos','aray storage exceeded' & ,' Execution terminated') enddo if (nr.ne.1.or.intr.ne.2) then xss(l)=nr l=l+1 do i=1,nr xss(l+2*i-2)=a(iscr+4+2*i) xss(l+2*i-1)=a(iscr+5+2*i) enddo l=l+2*nr else xss(l)=0 l=l+1 endif xss(l)=ne k=iscr+6+2*nr l=l+1 do i=1,ne xss(l)=a(k)/emev xss(l+ne)=a(k+1) l=l+1 k=k+2 enddo l=l+ne j=j+1 enddo endif call tosend(nin,0,0,a(iscr)) call contio(nin,0,0,a(iscr),nb,nw) endif enddo 120 continue */ allow more digits for dosimetry mt's *d acer.14496 & '' reaction mt = '',i6,3x,a10/'' interpolation: '',12i6)') *d acer.14501 & '' reaction mt = '',i6,3x,a10/'' linear interpolation'')') */ allow processing of dosimetry files *d acer.407 else if (iopt.lt.7.or.iopt.gt.9) then *d acer.435 else if (iopt.ge.7.and.iopt.le.9) then *i acer.17639 c c ***read type 3 ace format file else if (itype.eq.2) then if (mcnpx.eq.0) then read(nin) hz(1:10),aw0,tz,hd,hko,hm,(izo(i),awo(i),i=1,16), & (nxs(i),i=1,16),(jxs(i),i=1,32) else read(nin) hz(1:13),aw0,tz,hd,hko,hm,(izo(i),awo(i),i=1,16), & (nxs(i),i=1,16),(jxs(i),i=1,32) endif len2=nxs(1) n=(len2+ner-1)/ner l=0 do i=1,n max=len2-l if (max.gt.ner) max=ner read (nin) (xss(l+j),j=1,max) l=l+max enddo call closz(-nin) c flag incident particle "undefined" izai=-1 awi =-1 *d acer.17692 else if (ht.eq.'d'.or.ht.eq.'y') then */ *ident upnea028 */ acer A. Trkov 22 Jan 2008 */ Increase the size of the work array from 180000 to 510000 */ to process U-238 and Gd-nat from IRDF-2002. *d up123.5 common/astore/a(510000) *d up123.7 data namax/510000/, nidmax/27/ *d up123.9 common/astore/a(510000) *d up123.11 common/astore/a(510000) *d up123.13 common/astore/a(510000) *d up123.15 common/astore/a(510000) *d up123.17 common/astore/a(510000) *d up123.19 common/astore/a(510000) *d up123.21 common/astore/a(510000) *d up123.23 common/astore/a(510000) *d up123.25 data namax/510000/ *d up123.27 common/astore/a(510000) *d up123.29 common/astore/a(510000) *d up123.31 common/astore/a(510000) *d up123.33 common/astore/a(510000) *d up123.35 common/astore/a(510000) *d up123.37 common/astore/a(510000) *d up123.39 common/astore/a(510000) *d up123.41 common/astore/a(510000) */ *ident ads01 */ matxsr - D. L. Aldama, NDS/IAEA Consultant, May 2008 */ Need more space (for processing ORNL 421 energy group structure) */ subroutine vector *d up171.37 dimension b(30000) *d up171.39 maxb=30000 */ */*ident ads02 */*/ acer - D. L. Aldama, NDS/IAEA Consultant, May 2008 */*/ subroutine tabize called by first */*/ correct memory allocation problem for multiple */*/ ACER runs */*i acer.238 */ do i=1,namax */ a(i)=0 */ enddo */*d acer.789 */ call tabize(mt,ln,nendf,nout,b,a,itab) */*d acer.1005 */ subroutine tabize(mti,ln,nin,nout,b,a,itab) */*d acer.1035 */ if (itab.le.0) then */*/