*cpl all *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 bounds */ 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