*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 bound overflow *d acer.6952 dimension x(24),y(24),p(65),fl(65) *i acer.6964 data ipmax/65/ *i acer.6969 if ((nord+1).gt.ipmax) then write(strng,'(''nord+1 = '',i3,'' is > ipmax ('',i3,'').'')') & nord+1,ipmax call error('ptleg2',strng,' ') endif */ increase argument value from 100 to 300 to match */ nethr definition in subroutine first. *d acer.4220 if (nethr.gt.1) call aordr(nethr,300,a(iethr)) */ restructure if test since e1 and e2 are only defined */ when ithopt=1. *d acer.1476,1477 itest=0 if (iskp.le.0.or.i.ge.iskp) then itest=1 endif if (itest.eq.0.and.ithopt.eq.1) then if (e.lt.(1-eps)*e1.or.e.gt.(1+eps)*e2) then itest=1 endif endif if (itest.eq.1) then */ move egamma statement to assure it is initialized */ prior to subsequent usage. *i acer.4142 egamma=0 *d up125.8 */ provide a dummy law value so subsequent if statements */ have a defined value to test. *i acer.5343 law=-999 */ a do nothing change to keep the compiler happy. */ existing code logic (ltt3=3) is ok. *i acer.5615 ne1=0 */ make sure pp1 is initialized to zero. *i acer.9333 pp1=0 *ident up131 */ groupr -- 9may06 */ watch out for sed(_,0) *d groupr.8916 do while (ed.le.eg(ig)*(1+eps).and.ig.gt.1) */ save some additional variables. *i groupr.3214 save nq,ng1,ig1 */ this has not been a problem in the past, but its easy to */ include an additional else branch test to abort if an */ invalid quadrature order is ever set. *i groupr.3296 else call error('groupr','bad nq in panel',' ') */ add "save ipd,ird" in getyld so that initial call to */ terpa has all needed info. *i groupr.7785 save ipd,ird */ delete un-needed contio call. This record was read back */ in getmf6 and c(_) has been passed to f6psp. Actually */ as currently coded, nin in the contio argument list is */ undefined here. Most compilers will have set it to zero */ and the contio call does nothing, hence previous processing */ of 2h (the only evaluation using law=6 at this time) is */ probably ok. *d groupr.9367 *ident up132 */ moder --12may06 */ matd is undefined unless loop>0, therefore break if test */ into two pieces. *d moder.275 if (loop.gt.0) then if (mat.ne.matd.and.mat.ne.0) go to 130 endif *ident up133 */ reconr -- 12may06 */ make sure there is a ym to go with this xm. *i reconr.1910 call terp1(a(ix+i-1),a(iy+i-1),a(ix+i-2),a(iy+i-2),xm,ym,2) *ident up134 */ broadr -- 12may06 */ make sure ctev is initialized before subsequent if test */ dealing with thermal g-factor edit. *i broadr.531 ctev=zero *ident up135 */ heatr -- 12may06 */ make sure izap is saved for subsequent use in h6dis and bacha. *i heatr.788 common/projh/awrp,izap */ fix typo (fn should have been f) in this update. *d up55.35 d=d+(xx-xl)*(f+fl)/2 */ make sure tt=0 unless subsequent if clause changes it. *i heatr.3348 tt=0 */ need to save enow for future use by bacha. *i heatr.3287 save enow */ make sure ihi and ilo are initialized prior to subsequent */ if test for output. *i heatr.5082 ihi=0 ilo=0 */ fix the check plots *d heatr.5490 if (x.ge.thin*xlast.and.j.lt.2500) then *d heatr.5559 if (x.ge.xlast+thin.and.j.lt.2500) then *ident up136 */ heatr -- 30aug06 */ change energy dependent fission pseudo-q calculation. the */ coefficient used with the incident neutron energy in previous */ versons of njoy does not agree with the format manual energy */ dependent equations. see the endf7 paper in nuclear data sheets */ for a discussion. *d heatr.799 data fq1,fq2/8.07d6,0.307d0/ */ same as heatr.799, but for single precision code. *d heatr.810 data fq1,fq2/8.07e6,0.307e0/ */ rewrite the energy release equation with a plus sign. this lets */ the sign of the fq1 and fq2 coefficients given in the data */ statement control whether its truly addition or subtraction. *d heatr.1135,1136 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then q0=q00-(yld-yld0)*fq1+fq2*e endif *ident up137 */ heatr -- 31aug06 */ miscellaneous fixes. we are not aware of any issues with the */ heatr output from earlier versions of njoy, but these tweaks */ will make for more robust code: */ initialize this variable in double precision, as done for others. *d heatr.805 data up/1.1d0/ */ make sure nwmax is large enough to handle 239pu prompt */ (or total) nu tab1 array. *d heatr.818 data nwmax/6000/ */ make sure mf1 is defined for the hgtyld call and pass mtd (not mt1) */ for the file type. *d heatr.1921,1922 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then mf1=1 call hgtyld(e,enext,idis,yld,matd,mf1,mtd,nscr,b,nbmax) endif */ make sure the tab1 record fits into the allocated space. *i heatr.2036 loc=loc+nw if (loc.gt.na) call error('hgtyld', & 'storage exceeded.',' ') */ make sure the tab1 record fits into the allocated space. *i heatr.2052 loc=loc+nw if (loc.gt.na) call error('hgtyld', & 'storage exceeded.',' ') */ initialize these variables in double precision, as done for others. *d heatr.3518 data brk1,brk2,half/130.d0,41.d0,0.5d0/ */ eliminate redundant if tests. *d heatr.3553,3561 */ restructure these "if" tests since x is only defined when the */ gety2 call has been made. Needed to keep the compiler happy */ when processing endf/b-viib2 15n. *d heatr.4561,4562 if (mfd.eq.3) then call gety2(e,enext,idis,x,nin,a(ib)) if (x.eq.0.)go to 195 endif *ident up138 */ groupr -- 31aug06 */ tweaks in groupr's bach so that it tests the same list of iza */ possibilities as are tested in heatr's bacha and acer's bachaa. *i groupr.5924 if (iza.eq.28000) iza=28058 if (iza.eq.29000) iza=29063 if (iza.eq.31000) iza=31069 if (iza.eq.40000) iza=40090 if (iza.eq.42000) iza=42096 if (iza.eq.48000) iza=48112 if (iza.eq.49000) iza=49115 *i groupr.5925 if (iza.eq.63000) iza=63151 if (iza.eq.72000) iza=72178 *ident up139 */ acer - 31aug06 */ a tweak in acer's bachaa to make it consistent with heatr's bacha. *d acer.12951,12952 nb=nint(ab-zb) nc=nint(ac-zc) *ident up140 */ groupr -- 31aug06 */ make sure all variables that were changed while processing the */ previous reaction are restored to their defaults before starting */ on the next reaction. *i groupr.3223 nq=0 elast=0.d0 idisc=0 */ de is only defined with (lf.ne.12), therefore only calculate */ xc under the same condition. If not, endf/b-viib2 241,243am will */ abort due to undefined de. *d groupr.9034 if (lf.ne.12) xc=de/theta *ident up141 */ njoy -- 31aug06 */ initialize xold prior to first use. a value of zero means the */ "do while" loop is executed at least once. *i njoy.4662 xold=0 *ident up142 */ moder -- 31aug06 */ add coding to read the new beta-delayed photon data that may */ be found in files 1, 12 and 14, section 460 (beginning with */ endf/b-vii). This coding matches the specifications given */ by brown et al at the nov2004 & 2005 csewg meetings. */ note that no changes are needed for file 14 processing. *i moder.477 c c ***beta-delayed photon spectra else if (mth.eq.460) then if (l1h.eq.1) then ng460=n1h do ng=1,ng460 call tab1io(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo else if (l2h.eq.2) then call listio(nin,nout,nscr,a,nb,nw) else call error('file1','bad LO in mt=460.',' ') endif *i moder.1107 c 9/5/2006 - add logic to read 12/460, otherwise *i moder.1117 if (mf.eq.12 .and. mt.eq.460)then if (l1h.eq.1) then ng460=n1h do ng=1,ng460+1 call tab1io(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo else if (l2h.eq.2) then call listio(nin,nout,nscr,a,nb,nw) else call error('file12','bad LO in mt=460.',' ') endif else *i moder.1134 endif *ident up143 */ acer -- 31aug06 */ (these mods in response to c. broeders, karlsruhe) */ up113 uses "nsyso" in subroutine thrlod, but it was never defined. *i acer.13444 common/mainio/nsysi,nsyso,nsyse,ntty */ add error to the external subprogram list or some compilers will */ complain that our use doesn't conform to the intrinsic error function. *d acer.13467 external reserv,dater,repoz,error *ident up144 */ reconr -- 01sep06 */ already initialized "zero" in up92, delete the redundant up99 code. *d up99.5 *d up99.7 *ident up145 */ broadr -- 01sep06 */ (from "patch_japan_njoy99_112a.txt") */ need to put this if test inside the do loop. *d broadr.1085,1086 if (dn.lt.zero) dl(i)=-1 enddo *ident up146 */ heatr -- 01sep06 */ (from "patch_japan_njoy99_112a.txt") */ current code overloads "nz" and can never update loc. *d heatr.165,169 nz0=0 do j=1,nz if (a(loc+j-1).gt.flag) nz0=j enddo loc=loc+nz0 *ident up147 */ acer -- 01sep06 */ (several corrections, from "patch_japan_njoy99_112a.txt") */ maximum legendre order was changed from 20 to 64 years ago. */ change comment and hardwired do loop terminating constant to "ni". *d acer.2477 c ***the series for the integral of p-sub-n up to order ni. *d acer.2481 do n=1,ni */ need reaction q value when call acelf5 or acelf6. Therefore */ shift location of current code. *i acer.5439 q=xss(lqr+i-1) *d acer.5463 */ 2*nint(spi) is wrong; need nint(2.*spi). Here and line 7299. *d acer.5841 i2s=nint(2.*spi) */ make sure we never try to divide by zero *d acer.6917 if (xss(nexd+3*npep).ne.zero) then renorm=1./xss(nexd+3*npep) else renorm=1. endif */ need a bigger integer field for the error message. *d acer.7045 write(strng,'(i4,'' for mt='',i3,'' e='',1pe10.3)') negs,mt,e */ keep making various arrays larger. Use parameter statement so it */ will be easier the next time. *i acer.7147 parameter idmx=2000 *d acer.7151 dimension aco(idmx),cprob(idmx) *d acer.7205 if (ii.gt.idmx) call error('ptlegc', */ 2*nint(spi) is wrong; need nint(2.*spi). Here and line 5463. *d acer.7299 i2s=nint(2.*spi) *ident up148 */ njoy -- 05sep06 */ change asend, afend amend and atend utility routines to set the */ last section record counter to 99999 or the last file, material */ or tape section record counter to zero. Reset the counter to */ one for the next initial section record. *i njoy.1677 nsh=99999 *d njoy.1679,1680 nsh=1 *i njoy.1686 nsc=99999 *d njoy.1688,1689 nsc=1 *i njoy.1714 nsh=0 *d njoy.1717 *i njoy.1723 nsc=0 *d njoy.1726 *i njoy.1752 nsh=0 *d njoy.1755 *i njoy.1761 nsc=0 *d njoy.1764 *i njoy.1790 nsh=0 *d njoy.1793 *i njoy.1799 nsc=0 *d njoy.1802 *ident up149 */ broadr -- 19sep06 */ use unique variable to allocate nubar space. *d broadr.226,227 nwt=6+2*n1h+2*n2h call reserv('nutot',nwt,inutot,a) *ident up150 */ reconr -- 19sep06 */ update 142 fixed moder to handle the new mt460 beta-delayed */ photon data, but we also need patches so that we don't look for */ a corresponding mf=3, mt=460 when executing other modules. */ In particular, need patches in reconr, heatr, groupr and acer. */ Take care of reconr in this update, then heatr, groupr and */ acer in the next three updates. */ tested with endf/b-viib3 239pu. reconr output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). */ eliminate mf12,mt460 from lunion's output tape, which propagates */ through to recout. Put this test before existing if(mfh.eq.12) */ test to make sure it gets executed. *i reconr.1679 if (mth.eq.460) go to 150 *ident up151 */ heatr -- 20sep06 */ mods needed to skip over mf12, mt460 so that heatr doesn't */ try to find the non-existent mf3, mt460. */ tested with endf/b-viib3 239pu. heatr output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). */ expand test, only true when mtd.ne.460 now. *d heatr.485 if (mfd.eq.12.and.mtd.ne.460) mgam=1 */ omit mt460 as a reaction to include in the sum. *i heatr.4464 if (mf.eq.12.and.mt.eq.460) then call tosend(nscr,0,0,a(iscr)) go to 105 endif */ expand test, only true when mth.ne.460 now. *d heatr.4133 if (mfh.eq.12.and.mth.ne.460) go to 120 */ expand test, only true when mtd.ne.460 now. *d heatr.4614 if (mtd.ne.2.and.mtd.ne.460) h=-y*x*ebar *ident up152 */ groupr -- 21sep06 */ mods needed to skip over mf12, mt460. */ tested with endf/b-viib3 239pu. groupr output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). *i groupr.7988 if (mfh.eq.12.and.mth.eq.460) then call tosend(nin,0,0,a(iscr)) go to 110 endif *ident up153 */ acer -- 21sep06 */ mods needed to skip over mf12, mt460. */ tested with endf/b-viib3 239pu. acer output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). *d acer.675,676 if ((mfd.eq.12.and.mtd.ne.460).or.(mfd.eq.13)) then ngmt=ngmt+1 a(igmt-1+ngmt)=mfd*1000+mtd endif *i acer.3512 if (mf.eq.12.and.mt.eq.460) then call tosend(nf12c,0,0,a(iscr)) go to 150 endif *i acer.3828 if ((mfh.eq.12.and.mth.eq.460) .or. & (mfh.eq.14.and.mth.eq.460) ) then call tosend(nin,0,0,a(iscr)) go to 110 endif *ident up154 */ acer -- 22sep06 */ set nu-bar for neutron multiplicity on MF6 fission (trkov, iaea). */ force lab coordinate system. */ (Th-232 from ENDF/B-VII with anisotropic fission neutron distributions) */ exclude redundant lumped cross sections mt 851-870, if present. */ (not allowed by ENDF rules but needed by ERRORR). *d acer.5401 c set flag for CM system, except fission if (lct.ge.2 .and. mth.ne.18) n=-n *i acer.6432 if(mth.eq.18) ntyr=19 c force lab coordinate system for fission if(mth.eq.18) lct=1 *i acer.1938 & (iverf.ge.6.and.(mt.ge.851.and.mt.le.870)).or. */ initialize unset nxs and jxs elements. */ otherwise there can be problems if multiple acer runs */ are done in one njoy deck. *i acer.4690 do i=1,8 nxsd(i)=0 enddo do i=1,2 jxsd(i)=0 enddo *i up113.23 common/jxst/jxs(32) *i acer.13097 do i=1,9 nxsd(i)=0 enddo do i=1,32 jxs(i)=0 enddo *i acer.14318 do i=1,12 nxsd(i)=0 enddo do i=1,14 jxsd(i)=0 enddo do i=1,10 jxsd2(i)=0 enddo *i acer.14706 do i=1,12 nxsd(i)=0 enddo do i=1,27 jxsd(i)=0 enddo *i acer.15254 do i=1,8 nxsd(i)=0 enddo do i=1,21 jxsd(i)=0 enddo */ allow thermal names as long as six characters (trkov) *d acer.356 if (tscr(i:i).ne.' ') nch=i */ set default values for rkal and akal (kosako) *i acer.9120 rkal=0 akal=0 *ident up155 */ reconr -- 22sep06 */ be more precise in skipping redundant lumped reactions (Ivo Kodeli) *d up54.11 if (mth.gt.850.and.mth.le.870) go to 150 if (mth.gt.891) go to 150 *ident up156 */ leapr -- 22sep06 */ fix problems in recent updates reported by Lahey compiler (A. Trkov) *i up114.73 common/in/twt,c,tbeta,iprint *ident up157 */ groupr -- 22sep06 */ from a.trkov, ijs */ groupr A. Trkov, IJS, June 2006 */ allow processing of lumped reactions defined for covariances */ (problem pointed out by a.bidaud */ processing th-232 from endf/b-vii) *i groupr.3910 character*60 strng *i groupr.3964 c lumped reactions for covariance data if (iverf.ge.6.and.mtd.ge.850.and.mtd.le.874) mt=mtd *d groupr.3968 if (mt.eq.0) then write(strng,'(i4,'' invalid in endf'')') mtd call error('getsig','illegal mt.',strng) endif *ident up158 */ errorr -- 22sep06 */ further updates to process redundant lumped reactions (ivo kodeli) */ fix for si-28 endf/b-vi evaluation - more than 40 mt. (ivo kodeli) *d up110.38 if (mt.gt.850.and.mt.le.870) go to 121 if (mt.gt.891) call error('errorr','illegal mt gt 891.',' ') *d errorr.301 121 continue *d up110.40 if (mt1.lt.851.or.mt1.gt.870) go to 140 *d up110.42 if (mt.gt.850.and.mt.le.870) go to 190 *d up110.44,45 if (mt1.lt.851.or.mt1.gt.870) then call rdsig(mat1,mt1,a(ib),a(isig1)) else call lumpxs(mt1,mtl,a) endif *d up110.47 if (mts(ix).lt.851.or.mts(ix).gt.870) go to 250 *d up110.49 if (mtd.ge.800.and.mtd.le.891) mt=mtd *d errorr.130 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.157 nmtmax=80 *d errorr.529 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.880 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.998 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1093 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1682 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1755 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1831 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2235 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2240 dimension c(6),matp(60) *d errorr.2451 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2679 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2751 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.3000 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.3191 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.3382 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) */ tidy-up for consistency (a.trkov) *d up120.6,9 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.13,16 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.20,23 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.27,30 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.34,37 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) */ make sure l has the right value with multiple ni subsections *i errorr.1273 l=l+nw *d up110.12 *i errorr.1278 l=l+nw *ident up159 */ viewr -- 22sep06 */ a.trkov, IAEA, April 2006 */ fix colour shades in covariance plots *d up95.12 ifg=ishade *d up95.26,28 r=isrgb(1,ifg-40)/rgb g=isrgb(2,ifg-40)/rgb b=isrgb(3,ifg-40)/rgb *ident up160 */ covr -- 22sep06 */ from a.trkov, iaea, April 2006 */ - fix labels for unassigned mt numbers */ - improve trapping of large correaltion coefficients *i covr.1573 write(nmeh1(4:6),'(i3)') mt *d covr.1575,1576 inamel=6 ivl=0 */ move trapping of large correlations from level to matshd *d covr.1107 character*60 strng external reserv,findex,releas,error,mess *i covr.1122 one=1 two=2 eps=1.e-6 *i covr.1137 none=0 ntwo=0 cofm=0 *i covr.1143 cofa=abs(cof)-eps if (cofa.gt.abs(cofm)) then cofm=cof ixmx=i jxmx=j endif if (cofa.gt.two) then ntwo=ntwo+1 else if (cofa.gt.one) then none=none+1 endif if (cof.gt. one) cof= one if (cof.lt.-one) cof=-one *i covr.1146 if (none.gt.0) then write(strng,'(''largest coefficient='',1p,e13.5 & ,'' at index'',2i4)') cofm,ixmx,jxmx call mess('matshd',strng,' ') write(strng,'(i4 '' coefficients > 1'')') none call mess('matshd',strng,'reset and continue.') end if if (ntwo.gt.0) then write(strng,'(i4 '' coefficients > 2'')') ntwo c call error('matshd',strng,'terminate execution') call mess('matshd',strng,'reset and continue') endif *d covr.1365 *d covr.1367,1370 *d covr.1372,1385 zero=0 do i=1,nlev ilev=i if (abs(c).lt.xlev(i)) exit enddo if(c.lt.zero) ilev=-ilev */ fix for si-28 endf/b-vi evaluation - more than 40 mt. (ivo kodeli) */ delete redundant common/fig/ *d covr.44 c * ncase no. cases to be run (maximum=60) * *d covr.62 c * ncase no. cases to be run (maximum=60) * *d covr.112,113 *d covr.119 dimension imat(60),imt(60),imat1(60),imt1(60) *d covr.140 nfigmx=60 *d covr.141 ncamx=60 *d covr.460 nlstm=60 *ident up161 */ groupr -- 22aug06 */ add a capability to handle int=22 */ for evaluations taken from jendl. *i groupr.8751 iraw=l+ne*(ng+1) m=iraw *d groupr.8756,8760 m1=m call tab1io(nin,0,0,c(m),nb,nw) m=m+nw *d groupr.8762 if (m.gt.nc) call error('getsed', *d groupr.8764,8765 call moreio(nin,0,0,c(m),nb,nw) m=m+nw *d groupr.8768 c(l)=c(m1+1) l=l+1 *d groupr.8772 *d groupr.8777 call intega(c(l),e1,e2,c(m1),ip,ir) l=l+1 *d groupr.8779 *i groupr.8791 if (int.ge.11.and.int.le.15) call mess('getsed', & 'corresponding point interpolation not available',' ') *d groupr.8814 l=m *i groupr.8902 if (int.gt.5) then khi=nnow+ne*(ng+1) ehi=c(khi+1) nphi=nint(c(khi+5)) xhi=c(khi+6+2*nphi) do while (nne.lt.ne.and.ed.gt.ehi*(1+small).and. & iout.eq.0) klo=khi elo=ehi nplo=nphi xlo=xhi khi=klo+8+2*nplo ehi=c(khi+1) nphi=nint(c(khi+5)) xhi=c(khi+6+2*nphi) enddo endif *d groupr.8904,8909 c unit base. if (int.ge.21) then xend=xlo+(xhi-xlo)*(ed-elo)/(ehi-elo) do ig=1,ng e1=eg(ig) if (ig.eq.1) e1=0 e1lo=e1*xlo/xend e1hi=e1*xhi/xend e2=eg(ig+1) if (ig.eq.ng) e2=ebig e2lo=e2*xlo/xend e2hi=e2*xhi/xend ip=2 ir=2 call intega(flo,e1lo,e2lo,c(klo),ip,ir) ip=2 ir=2 call intega(fhi,e1hi,e2hi,c(khi),ip,ir) fe=flo+(fhi-flo)*(ed-elo)/(ehi-elo) sed(ikt,ig)=sed(ikt,ig)+pe*fe enddo c corresponding points. not implemented. else if (int.ge.11) then do ig=1,ng sed(ikt,ig)=0 enddo c cartesion. else do ig=1,ng call terp1(elo,c(llo+ig),ehi,c(lhi+ig), & ed,s,int) sed(ikt,ig)=sed(ikt,ig)+s*pe enddo endif *ident vers */ update the version name and date */ to reflect the date of the latest modifications *d njoy.8,9 c * 22 Sep 06 * *d njoy.307 data vers/'99.161 '/