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

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

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

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

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

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

rob/cosine'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''10 -15 15 3.5 5.5 2.5/'')') write(nout,'(''1/'')') loc=nint(xss(itxe-1+ie)) nbini=nint(xss(itxe-1+nie+ie)) skip=1+log10(ymax/ymin)/60 epl=0 loc=loc+nang+3 do j=2,nbini-1 ep=(xss(loc+1)+epl)/2 if (xss(loc+1).gt.epl) then if (j.eq.2.or.ep/epl.gt.skip) then write(nout,'(1p,e14.6,''/'')') ep ul=-1 write(nout,'(1p,2e14.6,''/'')') -1.,zmin do k=1,nang u=xss(loc+3+k) if (k.lt.nang) then un=(u+xss(loc+3+k+1))/2 else un=1 endif if (k.eq.1.and.u-ul.gt.5*(un-u)) & ul=u-3*(un-u) if (k.eq.nang.and.un-u.gt.5*(u-ul)) & un=u+3*(u-ul) p=1 p=p/nang p=p/(un-ul) if (k.eq.1) & write(nout,'(1p,2e14.6,''/'')') ul,zmin write(nout,'(1p,2e14.6,''/'')') u,p if (k.eq.nang) & write(nout,'(1p,2e14.6,''/'')') un,zmin ul=un enddo write(nout,'(1p,2e14.6,''/'')') 1.,zmin write(nout,'(''/'')') epl=xss(loc+1) endif endif loc=loc+nang+3 enddo write(nout,'(''/'')') ie=ie+iskip enddo *d acer.14210,14216 if (ifeng.le.1) then n=ne*nieb*(nil+2) do i=1,n call typen(l,nout,2) l=l+1 enddo else n=2*ne do i=1,ne n=n+nint(xss(l+ne+i-1))*(nil+2) enddo do i=1,n call typen(l,nout,2) l=l+1 enddo endif *ident up114 */ leapr -- 01mar06 */ put out a few more discrete lines at low alpha *d leapr.1264 data small/1.d-8/ *d leapr.1349 if (n.lt.maxdd) then *d leapr.1429 if (wts(i).lt.100*small.and.i.gt.5) idone=1 *i leapr.1655 bminus(i)=0 bplus(i)=0 *i leapr.1669 bminus(i)=0 bplus(i)=0 */ weight is wrong when adding continuum parts for discrete lines *d leapr.1453,1454 st=sint(be,bex,rdbex,sex,nbx,al,tbeta+twt,tbart, & beta,nbeta,maxbb) */ allow for smaller sab numbers in endf file *d leapr.2659 data smin/2.d-75/ */ add skold method for handling intermolecular correlations * as used for d(d2o) by keinert and mattes. *i leapr.103 c * nsk 0 none (default) * c * 1 vinyard * c * 2 skold * *d leapr.148 c * card 17 - pair correlation control (nsk.ne.0 only) * *d leapr.154 c * card 19 - coherent scattering fraction for nsk.eq.2 only * c * cfrac coherent fraction * c * * c * card 20 - file 1 comments, repeat until blank line is read. * *d leapr.218 nsk=0 read(nsysi,*) awr,spr,npr,iel,ncold,nsk *d leapr.224,225 & '' cold moderator option ................ '',i10/ & '' s(kappa) option ...................... '',i10)') & awr,spr,npr,iel,ncold,nsk *d leapr.257 if (nsk.ne.0) call reserv('ssp',nsmax,issp,a) *d leapr.294 if (nsk.gt.0) then *i leapr.298 if (nsk.eq.1) & write(nsyso,'(/'' s(kappa) for vinyard method'')') if (nsk.eq.2) & write(nsyso,'(/'' s(kappa) for skold method'')') do i=1,nka write(nsyso,'(1p,2e12.4)') dka*i,ska(i) enddo *i leapr.299 c c ***read in coherent fraction for skold method if (nsk.eq.2) read(nsysi,*) cfrac c *i leapr.357 c c ***check for skold option for correlations if (nsk.eq.2) call skold(cfrac,itemp,temp,a(issm), & nalpha,nbeta,ntempr) *i leapr.2629 c subroutine skold(cfrac,itemp,temp,ssm,nalpha,nbeta,ntempr) c ****************************************************************** c use skold approximation to add in the effects c of intermolecular coherence. c ****************************************************************** implicit real*8 (a-h,o-z) dimension ssm(nbeta,nalpha,ntempr) common/mainio/nsysi,nsyso,nsyse,ntty common/ee/za,awr,spr,b7,aws,sps,mat,npr,iel,nss,mss common/bkc/bk common/ab/nalpha1,nbeta1,naint,nbint,alpha(200),beta(400) common/sc/tev,deltab,bk0,lat common/se/arat common/sk/ska(500),dka,nka dimension scoh(1000) data angst/1.d-8/ data therm/.0253d0/ data amassn/1.008664904d0/ data amu/1.6605402d-24/ data hbar/1.05457266d-27/ data ev/1.60217733d-12/ c ***apply the skold approximation tev=bk*abs(temp) sc=1 if (lat.eq.1) sc=therm/tev amass=awr*amassn*amu do i=1,nbeta do j=1,nalpha al=alpha(j)*sc/arat waven=angst*sqrt(2*amass*tev*ev*al)/hbar sk=terpk(ska,nka,dka,waven) ap=alpha(j)/sk do k=1,nalpha kk=k if (ap.lt.alpha(k)) exit enddo if (kk.eq.1) kk=2 call terp1(alpha(kk-1),ssm(i,kk-1,itemp), & alpha(kk),ssm(i,kk,itemp),ap,scoh(j),5) scoh(j)=scoh(j)*sk enddo do j=1,nalpha ssm(i,j,itemp)=(1-cfrac)*ssm(i,j,itemp) & +cfrac*scoh(j) enddo enddo c c ***report the results if (iprt.eq.1.and.iprint.eq.2) write(nsyso, & '(/'' results after applying skold approximation'')') do nal=1,nalpha iprt=mod(nal-1,naint)+1 if (nal.eq.nalpha) iprt=1 al=alpha(nal)*sc/arat if (iprt.eq.1.and.iprint.eq.2) write(nsyso, & '(/3x,''alpha='',f10.5)') al if (iprt.eq.1.and.iprint.eq.2) write(nsyso, & '(/4x,'' beta'',7x,''s(alpha,beta)'',7x,''ss(alpha,beta)'', & 5x,''ss(alpha,-beta)'')') do i=1,nbeta be=beta(i)*sc ss=ssm(i,nal,itemp) s1=ss*exp(-be/2) s2=ss*exp(-be) jprt=mod(i-1,nbint)+1 if (i.eq.nbeta) jprt=1 if (iprt.eq.1.and.jprt.eq.1.and.iprint.eq.2) & write(nsyso,'(f10.4,1pe18.5,1p,2e20.5)') & beta(i),s1,s2,ss enddo if (iprt.eq.1) then sum0=0 sum1=0 ff1l=0 ff2l=0 bel=0 do ibeta=1,nbeta be=beta(ibeta) ff2=ssm(ibeta,nal,itemp) ff1=ssm(ibeta,nal,itemp)*exp(-be) if (ibeta.gt.1) then sum0=sum0+(be-bel)*(ff1l+ff2l+ff1+ff2)/2 sum1=sum1+(be-bel) & *(ff2l*bel+ff2*be-ff1l*bel-ff1*be)/2 ff1l=ff1 ff2l=ff2 bel=be else bel=be ff1l=ff1 ff2l=ff2 sum0=0 sum1=0 endif enddo sum1=sum1/al if (iprint.eq.2) then write(nsyso,'('' normalization check ='',f8.4)') sum0 write(nsyso,'('' sum rule check ='',f8.4)') sum1 else if (iprint.eq.1) then write(nsyso,'(1x,f10.4,2f10.4)') al,sum0,sum1 endif endif enddo return end *ident up115 */ heatr -- 3apr06 */ skip over heating calculation when there is no distribution *i heatr.999 if (ebar.lt.zero) go to 291 *d heatr.1291 291 if (j6.ge.n6) go to 296 *d heatr.2490 write(strng,'(''no distribution for mt'',i3,'' particle '',i5)') */ allow for fission distributions in file 6 as in 7beta1 th-232. */ the yld becomes nubar. *d heatr.999 175 nwm=nwmax nwa=na call sixbar(e,ebar,yld,dame,nend6,a(ia),nwa,nscr,a(id),nwm, & n6,j6,irec,jrec) *i heatr.1002 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) q0=q *d heatr.1006 *i heatr.1009 if (icon.lt.0) go to 179 *i heatr.1028 if (irec.gt.0.and.icon.lt.0) izap=100 *d heatr.1131 & call sixbar(e,ebar,yld,dame,nend6,a(ia),nwa,nscr,a(id),nwm, & n6,j6,irec,jrec) *d heatr.1142 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then h=(e+q0-ebar*yld)*y else h=ebar*yld*y endif *i heatr.1151 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) ebal6=0 *d heatr.2418 subroutine sixbar(e,ebar,yld,dame,nin,c,ncmax,nscr,b,nbmax, & n2,j6,irec,jrec) *d heatr.2430 dimension c(ncmax),b(nbmax) *i heatr.2578 if ((mth.ge.18.and.mth.le.21).or.mth.eq.38) then matd=math mf1=1 mt1=452 c delayed neutrons are treated the same as fast neutrons. c this will cause a slight overestimate of en for fission. call hgtyld(e,enext,idis,yld,matd,mf1,mt1,nscr,b,nbmax) endif *i heatr.2660 if ((mth.ge.18.and.mth.le.21).or.mth.eq.38) then matd=math mf1=1 mt1=452 call hgtyld(e,enext,idis,yld,matd,mf1,mt1,nscr,b,nbmax) endif *ident up116 */ groupr -- 05apr06 */ fix reading tab1 record in conver (trkov, iaea) *i groupr.8422 do while (nb.ne.0) call moreio(nin,nout,nscr,a(iscr),nb,nw) enddo *ident up117 */ moder -- 05apr06 */ process compact format representation in mf32 (trkov, iaea) */ see new utility routine intgio in up118 below. *d moder.1277 external contio,listio,moreio,error *d up81.42 else if (lcomp.eq.1) then *b up81.60 else if (lcomp.eq.2) then call listio(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo call contio(nin,nout,nscr,a,nb,nw) nn=n1h do k=1,nn call intgio(nin,nout,nscr,a,nb,nw) end do else call error('file32','illegal value of lcomp',' ') *ident up118 */ njoy -- 05apr06 */ new utility routine to process compact format representation */ for mf32 (trkov, iaea). see also up117 which uses this subroutine. *i njoy.620 subroutine intgio(nin,nout,nscr,a,nb,nw) c ****************************************************************** c utility routine for endf/b coded and blocked binary tapes. c read, write, and/or convert one intg record. c positive units are coded, negative ones are blocked binary. c if any unit is zero, it is not used. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension a(20),ia(20) c c ***input if (nin.lt.0) then inin=iabs(nin) read(inin) math,mfh,mth,nb,nw,(a(j),j=1,nw) else if (nin.gt.0) then read(nin,'(2i5,1x,18i3,1x,i4,i2,i3,i5)') ia,math,mfh,mth,nsp do j=1,20 a(j)=ia(j) end do endif c c ***output nb=0 nw=20 if (nout.eq.0.and.nscr.eq.0) return inout=iabs(nout) if (nout.lt.0) then write(inout) math,mfh,mth,nb,nw,(a(j),j=1,nw) inout=0 endif inscr=iabs(nscr) if (nscr.lt.0) then write(inscr) math,mfh,mth,nb,nw,(a(j),j=1,nw) inscr=0 endif c c ***format the output do j=1,20 ia(j)=nint(a(j)) end do if (nscr.gt.0) then write(nscr,'(2i5,1x,18i3,1x,i4,i2,i3,i5)') ia,math,mfh,mth,nsc nsc=nsc+1 if (nsc.gt.99999) nsc=1 endif if (nout.gt.0) then write(nout,'(2i5,1x,18i3,1x,i4,i2,i3,i5)') ia,math,mfh,mth,nsh nsh=nsh+1 if (nsh.gt.99999) nsh=1 endif return end c *ident up119 */ acer -- 05apr06 */ fix bug that switched off ddx plots (trkov, iaea). *d up70.138,139 nr1=nint(xss(l)) if (nr1.gt.0) l=l+2*nr1 *d up70.191,192 nr1=nint(xss(l)) if (nr1.gt.0) l=l+2*nr1 *ident up120 */ errorr -- 05apr06 */ temporary patch to skip processing unrecognized options */ for mf32 (trkov, iaea). *d errorr.2498,2499 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *d errorr.2505,2506 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *d errorr.2511.2512 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *d errorr.2517,2518 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *d errorr.2526,2527 c call error('resprp', c & 'illegal or unrecognized data structure in mf32',strng2) print *,'WARNING - resprp', & ' illegal or unrecognized data structure in mf32:',strng2 mf32=0 return *ident up121 */ heatr -- 13apr06 */ add tosend in nheat when the last subsection of file 6 */ section 5 does not include particle distributions. *d up115.7 291 if (j6.ge.n6) then c make sure we're at the end of section (will not be so if c there was no particle distribution for the last subsection c in this section). if (ebar.lt.zero) then call tosend(nin,0,0,a(ib)) call skiprz(nin,-1) endif go to 296 endif *ident up122 */ acer -- 13apr06 */ fix bad message for renormalizing the delayed spectrum */ the undefined index lxx can cause crashes *d up72.34,35 & '' precursor'',i2, & '' norm='',f8.6)') i,sumup *ident up123 */ acer -- 19apr06 */ increase storage limit for preVII thermal evaluations *d up94.13 common/astore/a(180000) *d up94.15 data namax/180000/, nidmax/27/ *d up94.17 common/astore/a(180000) *d up94.19 common/astore/a(180000) *d up94.21 common/astore/a(180000) *d up94.23 common/astore/a(180000) *d up94.25 common/astore/a(180000) *d up94.27 common/astore/a(180000) *d up94.29 common/astore/a(180000) *d up94.31 common/astore/a(180000) *d up94.33 data namax/180000/ *d up94.35 common/astore/a(180000) *d up94.37 common/astore/a(180000) *d up94.39 common/astore/a(180000) *d up94.41 common/astore/a(180000) *d up94.43 common/astore/a(180000) *d up94.45 common/astore/a(180000) *d up94.47 common/astore/a(180000) *d up94.49 common/astore/a(180000) *ident up124 */ thermr -- 19apr06 */ increase storage space for big preVII thermal evaluations *d thermr.134 nwscr=70000 */ allow for up to 32 angle bins as used in tripoli *d thermr.1421 dimension ex(20),x(20),y(33,20),yt(33) *d thermr.1473 data nlmax/33/ *ident up125 */ acer -- 19apr06 */ patch acer to handle the discrete anisotropic mf6 capture */ photon in endf/b-vii h-1. temporarily, the relativistic */ effect will be ignored and it will be treated as a */ simple primary photon. *d acer.4144,4146 egamma=0 if (law.eq.2) then call mess('convr', & 'discrete anisotropic photon', & 'treated as simple primary photon') egamma=c2h endif *i acer.4174 if (egamma.gt.0) then e=c2h a(iscr+8)=1 a(iscr+9)=0 a(iscr+10)=2 a(iscr+11)=1 a(iscr+12)=egamma+awr*e/(awr+1) a(iscr+13)=1 endif *ident up126 */ broadr -- 22apr06 */ watch out for tt(0) *d broadr.503,504 if (llf.gt.0) sf=slf+(tt(llf)-slf)*(enow-elast)/(tt(1)-elast) if (llc.gt.0)sc=slc+(tt(llc)-slc)*(enow-elast)/(tt(1)-elast) *d broadr.506,507 if (llf.gt.0) sf=tt(llf) if (llc.gt.0) sc=tt(llc) *ident up127 */ heatr -- 22apr06 */ the routine getsix doesn't have any coding to handle law 6 */ (phase space distributions). temporarily, we set ebar */ and dame equal to zero. this affects endf h-2 (n,2n). *i heatr.2776 if (law.eq.6) go to 505 *i heatr.2993 c c ***law 6. c ***phase space distribution. c ***temporarily returning zeroes. 505 ebar=0 dame=0 return */ missing save *i heatr.3287 save izat */ fix initialization of df for tabulated distributions *i heatr.2391 zero=0 c c ***initialize if (e.eq.zero) then d=df(e,z,awr,z,awr) return endif *ident up128 */ thermr -- 24apr06 */ fix ending point for coherent scattering, which sometimes */ goes into an infinite loop. *i thermr.1079 if (e.ge.elim) elim=emax *ident up129 */ njoy -- 26apr06 */ restructure do loop so tht bounds checking doesn't fail *d njoy.401,405 do i=1,l if (mess(i:i).ne.' ') then k=k+1 j=i endif enddo */ need large printed fields for storage diagnostics *d njoy.2638 write(nsyso,'(/58x,''storage '',i3,''/'',i8)') nidmax,iamax *d njoy.2753 write(nsyso,'(58x,''id '',a4,1x,i3,''/'',i8)') id,nidtot,ntot *d njoy.2788 write(nsyso,'(58x,''xx '',a4,5x,i8)') id,nwords *d njoy.2841 write(nsyso,'(/56x,''usage'',i8,''/'',i8)') nused,iamax *ident up130 */ acer -- 27apr06 */ increase Legendre array to 65 and add test to avoid array bounds */ overflow. *d acer.6952 dimension x(24),y(24),p(65),fl(65) *i acer.6964 data ipmax/65/ *i acer.6969 if ((nord+1).gt.ipmax) then write(strng,'(''nord+1 = '',i3,'' is > ipmax ('',i3,'').'')') & nord+1,ipmax call error('ptleg2',strng,' ') endif */ increase argument value from 100 to 300 to match */ nethr definition in subroutine first. *d acer.4220 if (nethr.gt.1) call aordr(nethr,300,a(iethr)) */ restructure if test since e1 and e2 are only defined */ when ithopt=1. *d acer.1476,1477 itest=0 if (iskp.le.0.or.i.ge.iskp) then itest=1 endif if (itest.eq.0.and.ithopt.eq.1) then if (e.lt.(1-eps)*e1.or.e.gt.(1+eps)*e2) then itest=1 endif endif if (itest.eq.1) then */ move egamma statement to assure it is initialized */ prior to subsequent usage. *i acer.4142 egamma=0 *d up125.8 */ provide a dummy law value so subsequent if statements */ have a defined value to test. *i acer.5343 law=-999 */ a do nothing change to keep the compiler happy. */ existing code logic (ltt3=3) is ok. *i acer.5615 ne1=0 */ make sure pp1 is initialized to zero. *i acer.9333 pp1=0 *ident up131 */ groupr -- 9may06 */ watch out for sed(_,0) *d groupr.8916 do while (ed.le.eg(ig)*(1+eps).and.ig.gt.1) */ save some additional variables. *i groupr.3214 save nq,ng1,ig1 */ this has not been a problem in the past, but its easy to */ include an additional else branch test to abort if an */ invalid quadrature order is ever set. *i groupr.3296 else call error('groupr','bad nq in panel',' ') */ add "save ipd,ird" in getyld so that initial call to */ terpa has all needed info. *i groupr.7785 save ipd,ird */ delete un-needed contio call. This record was read back */ in getmf6 and c(_) has been passed to f6psp. Actually */ as currently coded, nin in the contio argument list is */ undefined here. Most compilers will have set it to zero */ and the contio call does nothing, hence previous processing */ of 2h (the only evaluation using law=6 at this time) is */ probably ok. *d groupr.9367 *ident up132 */ moder --12may06 */ matd is undefined unless loop>0, therefore break if test */ into two pieces. *d moder.275 if (loop.gt.0) then if (mat.ne.matd.and.mat.ne.0) go to 130 endif *ident up133 */ reconr -- 12may06 */ make sure there is a ym to go with this xm. *i reconr.1910 call terp1(a(ix+i-1),a(iy+i-1),a(ix+i-2),a(iy+i-2),xm,ym,2) *ident up134 */ broadr -- 12may06 */ make sure ctev is initialized before subsequent if test */ dealing with thermal g-factor edit. *i broadr.531 ctev=zero *ident up135 */ heatr -- 12may06 */ make sure izap is saved for subsequent use in h6dis and bacha. *i heatr.788 common/projh/awrp,izap */ fix typo (fn should have been f) in this update. *d up55.35 d=d+(xx-xl)*(f+fl)/2 */ make sure tt=0 unless subsequent if clause changes it. *i heatr.3348 tt=0 */ need to save enow for future use by bacha. *i heatr.3287 save enow */ make sure ihi and ilo are initialized prior to subsequent */ if test for output. *i heatr.5082 ihi=0 ilo=0 */ fix the check plots *d heatr.5490 if (x.ge.thin*xlast.and.j.lt.2500) then *d heatr.5559 if (x.ge.xlast+thin.and.j.lt.2500) then *ident up136 */ heatr -- 30aug06 */ change energy dependent fission pseudo-q calculation. the */ coefficient used with the incident neutron energy in previous */ versons of njoy does not agree with the format manual energy */ dependent equations. see the endf7 paper in nuclear data sheets */ for a discussion. *d heatr.799 data fq1,fq2/8.07d6,0.307d0/ */ same as heatr.799, but for single precision code. *d heatr.810 data fq1,fq2/8.07e6,0.307e0/ */ rewrite the energy release equation with a plus sign. this lets */ the sign of the fq1 and fq2 coefficients given in the data */ statement control whether its truly addition or subtraction. *d heatr.1135,1136 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then q0=q00-(yld-yld0)*fq1+fq2*e endif *ident up137 */ heatr -- 31aug06 */ miscellaneous fixes. we are not aware of any issues with the */ heatr output from earlier versions of njoy, but these tweaks */ will make for more robust code: */ initialize this variable in double precision, as done for others. *d heatr.805 data up/1.1d0/ */ make sure nwmax is large enough to handle 239pu prompt */ (or total) nu tab1 array. *d heatr.818 data nwmax/6000/ */ make sure mf1 is defined for the hgtyld call and pass mtd (not mt1) */ for the file type. *d heatr.1921,1922 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then mf1=1 call hgtyld(e,enext,idis,yld,matd,mf1,mtd,nscr,b,nbmax) endif */ make sure the tab1 record fits into the allocated space. *i heatr.2036 loc=loc+nw if (loc.gt.na) call error('hgtyld', & 'storage exceeded.',' ') */ make sure the tab1 record fits into the allocated space. *i heatr.2052 loc=loc+nw if (loc.gt.na) call error('hgtyld', & 'storage exceeded.',' ') */ initialize these variables in double precision, as done for others. *d heatr.3518 data brk1,brk2,half/130.d0,41.d0,0.5d0/ */ eliminate redundant if tests. *d heatr.3553,3561 */ restructure these "if" tests since x is only defined when the */ gety2 call has been made. Needed to keep the compiler happy */ when processing endf/b-viib2 15n. *d heatr.4561,4562 if (mfd.eq.3) then call gety2(e,enext,idis,x,nin,a(ib)) if (x.eq.0.)go to 195 endif *ident up138 */ groupr -- 31aug06 */ tweaks in groupr's bach so that it tests the same list of iza */ possibilities as are tested in heatr's bacha and acer's bachaa. *i groupr.5924 if (iza.eq.28000) iza=28058 if (iza.eq.29000) iza=29063 if (iza.eq.31000) iza=31069 if (iza.eq.40000) iza=40090 if (iza.eq.42000) iza=42096 if (iza.eq.48000) iza=48112 if (iza.eq.49000) iza=49115 *i groupr.5925 if (iza.eq.63000) iza=63151 if (iza.eq.72000) iza=72178 *ident up139 */ acer - 31aug06 */ a tweak in acer's bachaa to make it consistent with heatr's bacha. *d acer.12951,12952 nb=nint(ab-zb) nc=nint(ac-zc) *ident up140 */ groupr -- 31aug06 */ make sure all variables that were changed while processing the */ previous reaction are restored to their defaults before starting */ on the next reaction. *i groupr.3223 nq=0 elast=0.d0 idisc=0 */ de is only defined with (lf.ne.12), therefore only calculate */ xc under the same condition. If not, endf/b-viib2 241,243am will */ abort due to undefined de. *d groupr.9034 if (lf.ne.12) xc=de/theta *ident up141 */ njoy -- 31aug06 */ initialize xold prior to first use. a value of zero means the */ "do while" loop is executed at least once. *i njoy.4662 xold=0 *ident up142 */ moder -- 31aug06 */ add coding to read the new beta-delayed photon data that may */ be found in files 1, 12 and 14, section 460 (beginning with */ endf/b-vii). This coding matches the specifications given */ by brown et al at the nov2004 & 2005 csewg meetings. */ note that no changes are needed for file 14 processing. *i moder.477 c c ***beta-delayed photon spectra else if (mth.eq.460) then if (l1h.eq.1) then ng460=n1h do ng=1,ng460 call tab1io(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo else if (l2h.eq.2) then call listio(nin,nout,nscr,a,nb,nw) else call error('file1','bad LO in mt=460.',' ') endif *i moder.1107 c 9/5/2006 - add logic to read 12/460, otherwise *i moder.1117 if (mf.eq.12 .and. mt.eq.460)then if (l1h.eq.1) then ng460=n1h do ng=1,ng460+1 call tab1io(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo else if (l2h.eq.2) then call listio(nin,nout,nscr,a,nb,nw) else call error('file12','bad LO in mt=460.',' ') endif else *i moder.1134 endif *ident up143 */ acer -- 31aug06 */ (these mods in response to c. broeders, karlsruhe) */ up113 uses "nsyso" in subroutine thrlod, but it was never defined. *i acer.13444 common/mainio/nsysi,nsyso,nsyse,ntty */ add error to the external subprogram list or some compilers will */ complain that our use doesn't conform to the intrinsic error */ function. *d acer.13467 external reserv,dater,repoz,error *ident up144 */ reconr -- 01sep06 */ already initialized "zero" in up92, delete the redundant up99 code. *d up99.5 *d up99.7 *ident up145 */ broadr -- 01sep06 */ (from "patch_japan_njoy99_112a.txt") */ need to put this if test inside the do loop. *d broadr.1085,1086 if (dn.lt.zero) dl(i)=-1 enddo *ident up146 */ heatr -- 01sep06 */ (from "patch_japan_njoy99_112a.txt") */ current code overloads "nz" and can never update loc. *d heatr.165,169 nz0=0 do j=1,nz if (a(loc+j-1).gt.flag) nz0=j enddo loc=loc+nz0 *ident up147 */ acer -- 01sep06 */ (several corrections, from "patch_japan_njoy99_112a.txt") */ maximum legendre order was changed from 20 to 64 years ago. */ change comment and hardwired do loop terminating constant to "ni". *d acer.2477 c ***the series for the integral of p-sub-n up to order ni. *d acer.2481 do n=1,ni */ need reaction q value when call acelf5 or acelf6. Therefore */ shift location of current code. *i acer.5439 q=xss(lqr+i-1) *d acer.5463 */ 2*nint(spi) is wrong; need nint(2.*spi). Here and line 7299. *d acer.5841 i2s=nint(2.*spi) */ make sure we never try to divide by zero *d acer.6917 if (xss(nexd+3*npep).ne.zero) then renorm=1./xss(nexd+3*npep) else renorm=1. endif */ need a bigger integer field for the error message. *d acer.7045 write(strng,'(i4,'' for mt='',i3,'' e='',1pe10.3)') negs,mt,e */ keep making various arrays larger. Use parameter statement so it */ will be easier the next time. *i acer.7147 parameter idmx=2000 *d acer.7151 dimension aco(idmx),cprob(idmx) *d acer.7205 if (ii.gt.idmx) call error('ptlegc', */ 2*nint(spi) is wrong; need nint(2.*spi). Here and line 5463. *d acer.7299 i2s=nint(2.*spi) *ident up148 */ njoy -- 05sep06 */ change asend, afend amend and atend utility routines to set the */ last section record counter to 99999 or the last file, material */ or tape section record counter to zero. Reset the counter to */ one for the next initial section record. *i njoy.1677 nsh=99999 *d njoy.1679,1680 nsh=1 *i njoy.1686 nsc=99999 *d njoy.1688,1689 nsc=1 *i njoy.1714 nsh=0 *d njoy.1717 *i njoy.1723 nsc=0 *d njoy.1726 *i njoy.1752 nsh=0 *d njoy.1755 *i njoy.1761 nsc=0 *d njoy.1764 *i njoy.1790 nsh=0 *d njoy.1793 *i njoy.1799 nsc=0 *d njoy.1802 *ident up149 */ broadr -- 19sep06 */ use unique variable to allocate nubar space. *d broadr.226,227 nwt=6+2*n1h+2*n2h call reserv('nutot',nwt,inutot,a) *ident up150 */ reconr -- 19sep06 */ update 142 fixed moder to handle the new mt460 beta-delayed */ photon data, but we also need patches so that we don't look for */ a corresponding mf=3, mt=460 when executing other modules. */ In particular, need patches in reconr, heatr, groupr and acer. */ Take care of reconr in this update, then heatr, groupr and */ acer in the next three updates. */ tested with endf/b-viib3 239pu. reconr output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). */ eliminate mf12,mt460 from lunion's output tape, which propagates */ through to recout. Put this test before existing if(mfh.eq.12) */ test to make sure it gets executed. *i reconr.1679 if (mth.eq.460) go to 150 *ident up151 */ heatr -- 20sep06 */ mods needed to skip over mf12, mt460 so that heatr doesn't */ try to find the non-existent mf3, mt460. */ tested with endf/b-viib3 239pu. heatr output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). */ expand test, only true when mtd.ne.460 now. *d heatr.485 if (mfd.eq.12.and.mtd.ne.460) mgam=1 */ omit mt460 as a reaction to include in the sum. *i heatr.4464 if (mf.eq.12.and.mt.eq.460) then call tosend(nscr,0,0,a(iscr)) go to 105 endif */ expand test, only true when mth.ne.460 now. *d heatr.4133 if (mfh.eq.12.and.mth.ne.460) go to 120 */ expand test, only true when mtd.ne.460 now. *d heatr.4614 if (mtd.ne.2.and.mtd.ne.460) h=-y*x*ebar *ident up152 */ groupr -- 21sep06 */ mods needed to skip over mf12, mt460. */ tested with endf/b-viib3 239pu. groupr output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). *i groupr.7988 if (mfh.eq.12.and.mth.eq.460) then call tosend(nin,0,0,a(iscr)) go to 110 endif *ident up153 */ acer -- 21sep06 */ mods needed to skip over mf12, mt460. */ tested with endf/b-viib3 239pu. acer output files are */ identical whether mf1, mf12 & mf14, mt460 are present or */ not in the endf input file (21sep06). *d acer.675,676 if ((mfd.eq.12.and.mtd.ne.460).or.(mfd.eq.13)) then ngmt=ngmt+1 a(igmt-1+ngmt)=mfd*1000+mtd endif *i acer.3512 if (mf.eq.12.and.mt.eq.460) then call tosend(nf12c,0,0,a(iscr)) go to 150 endif *i acer.3828 if ((mfh.eq.12.and.mth.eq.460) .or. & (mfh.eq.14.and.mth.eq.460) ) then call tosend(nin,0,0,a(iscr)) go to 110 endif *ident up154 */ acer -- 22sep06 */ set nu-bar for neutron multiplicity on MF6 fission (trkov, iaea). */ force lab coordinate system. */ (Th-232 from ENDF/B-VII with anisotropic fission neutron distributions) */ exclude redundant lumped cross sections mt 851-870, if present. */ (not allowed by ENDF rules but needed by ERRORR). *d acer.5401 c set flag for CM system, except fission if (lct.ge.2 .and. mth.ne.18) n=-n *i acer.6432 if(mth.eq.18) ntyr=19 c force lab coordinate system for fission if(mth.eq.18) lct=1 *i acer.1938 & (iverf.ge.6.and.(mt.ge.851.and.mt.le.870)).or. */ initialize unset nxs and jxs elements. */ otherwise there can be problems if multiple acer runs */ are done in one njoy deck. *i acer.4690 do i=1,8 nxsd(i)=0 enddo do i=1,2 jxsd(i)=0 enddo *i up113.23 common/jxst/jxs(32) *i acer.13097 do i=1,9 nxsd(i)=0 enddo do i=1,32 jxs(i)=0 enddo *i acer.14318 do i=1,12 nxsd(i)=0 enddo do i=1,14 jxsd(i)=0 enddo do i=1,10 jxsd2(i)=0 enddo *i acer.14706 do i=1,12 nxsd(i)=0 enddo do i=1,27 jxsd(i)=0 enddo *i acer.15254 do i=1,8 nxsd(i)=0 enddo do i=1,21 jxsd(i)=0 enddo */ allow thermal names as long as six characters (trkov) *d acer.356 if (tscr(i:i).ne.' ') nch=i */ set default values for rkal and akal (kosako) *i acer.9120 rkal=0 akal=0 *ident up155 */ reconr -- 22sep06 */ be more precise in skipping redundant lumped reactions (Ivo Kodeli) *d up54.11 if (mth.gt.850.and.mth.le.870) go to 150 if (mth.gt.891) go to 150 *ident up156 */ leapr -- 22sep06 */ fix problems in recent updates reported by Lahey compiler (A. Trkov) *i up114.73 common/in/twt,c,tbeta,iprint *ident up157 */ groupr -- 22sep06 */ from a.trkov, ijs */ groupr A. Trkov, IJS, June 2006 */ allow processing of lumped reactions defined for covariances */ (problem pointed out by a.bidaud */ processing th-232 from endf/b-vii) *i groupr.3910 character*60 strng *i groupr.3964 c lumped reactions for covariance data if (iverf.ge.6.and.mtd.ge.850.and.mtd.le.874) mt=mtd *d groupr.3968 if (mt.eq.0) then write(strng,'(i4,'' invalid in endf'')') mtd call error('getsig','illegal mt.',strng) endif *ident up158 */ errorr -- 22sep06 */ further updates to process redundant lumped reactions (ivo kodeli) */ fix for si-28 endf/b-vi evaluation - more than 40 mt. (ivo kodeli) *d up110.38 if (mt.gt.850.and.mt.le.870) go to 121 if (mt.gt.891) call error('errorr','illegal mt gt 891.',' ') *d errorr.301 121 continue *d up110.40 if (mt1.lt.851.or.mt1.gt.870) go to 140 *d up110.42 if (mt.gt.850.and.mt.le.870) go to 190 *d up110.44,45 if (mt1.lt.851.or.mt1.gt.870) then call rdsig(mat1,mt1,a(ib),a(isig1)) else call lumpxs(mt1,mtl,a) endif *d up110.47 if (mts(ix).lt.851.or.mts(ix).gt.870) go to 250 *d up110.49 if (mtd.ge.800.and.mtd.le.891) mt=mtd *d errorr.130 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.157 nmtmax=80 *d errorr.529 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.880 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.998 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1093 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1682 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1755 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.1831 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2235 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2240 dimension c(6),matp(60) *d errorr.2451 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2679 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.2751 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.3000 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.3191 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorr.3382 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) */ tidy-up for consistency (a.trkov) *d up120.6,9 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.13,16 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.20,23 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.27,30 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) *d up120.34,37 call mess('resprp', & ' illegal or unrecognized data structure in mf32:',strng2) */ make sure l has the right value with multiple ni subsections *i errorr.1273 l=l+nw *d up110.12 *i errorr.1278 l=l+nw *ident up159 */ viewr -- 22sep06 */ a.trkov, IAEA, April 2006 */ fix colour shades in covariance plots *d up95.12 ifg=ishade *d up95.26,28 r=isrgb(1,ifg-40)/rgb g=isrgb(2,ifg-40)/rgb b=isrgb(3,ifg-40)/rgb *ident up160 */ covr -- 22sep06 */ from a.trkov, iaea, April 2006 */ - fix labels for unassigned mt numbers */ - improve trapping of large correaltion coefficients *i covr.1573 write(nmeh1(4:6),'(i3)') mt *d covr.1575,1576 inamel=6 ivl=0 */ move trapping of large correlations from level to matshd *d covr.1107 character*60 strng external reserv,findex,releas,error,mess *i covr.1122 one=1 two=2 eps=1.e-6 *i covr.1137 none=0 ntwo=0 cofm=0 *i covr.1143 cofa=abs(cof)-eps if (cofa.gt.abs(cofm)) then cofm=cof ixmx=i jxmx=j endif if (cofa.gt.two) then ntwo=ntwo+1 else if (cofa.gt.one) then none=none+1 endif if (cof.gt. one) cof= one if (cof.lt.-one) cof=-one *i covr.1146 if (none.gt.0) then write(strng,'(''largest coefficient='',1p,e13.5 & ,'' at index'',2i4)') cofm,ixmx,jxmx call mess('matshd',strng,' ') write(strng,'(i4 '' coefficients > 1'')') none call mess('matshd',strng,'reset and continue.') end if if (ntwo.gt.0) then write(strng,'(i4 '' coefficients > 2'')') ntwo c call error('matshd',strng,'terminate execution') call mess('matshd',strng,'reset and continue') endif *d covr.1365 *d covr.1367,1370 *d covr.1372,1385 zero=0 do i=1,nlev ilev=i if (abs(c).lt.xlev(i)) exit enddo if(c.lt.zero) ilev=-ilev */ fix for si-28 endf/b-vi evaluation - more than 40 mt. (ivo kodeli) */ delete redundant common/fig/ *d covr.44 c * ncase no. cases to be run (maximum=60) * *d covr.62 c * ncase no. cases to be run (maximum=60) * *d covr.112,113 *d covr.119 dimension imat(60),imt(60),imat1(60),imt1(60) *d covr.140 nfigmx=60 *d covr.141 ncamx=60 *d covr.460 nlstm=60 *ident up161 */ groupr -- 22aug06 */ add a capability to handle int=22 */ for evaluations taken from jendl. *i groupr.8751 iraw=l+ne*(ng+1) m=iraw *d groupr.8756,8760 m1=m call tab1io(nin,0,0,c(m),nb,nw) m=m+nw *d groupr.8762 if (m.gt.nc) call error('getsed', *d groupr.8764,8765 call moreio(nin,0,0,c(m),nb,nw) m=m+nw *d groupr.8768 c(l)=c(m1+1) l=l+1 *d groupr.8772 *d groupr.8777 call intega(c(l),e1,e2,c(m1),ip,ir) l=l+1 *d groupr.8779 *i groupr.8791 if (int.ge.11.and.int.le.15) call mess('getsed', & 'corresponding point interpolation not available',' ') *d groupr.8814 l=m *i groupr.8902 if (int.gt.5) then khi=nnow+ne*(ng+1) ehi=c(khi+1) nphi=nint(c(khi+5)) xhi=c(khi+6+2*nphi) do while (nne.lt.ne.and.ed.gt.ehi*(1+small).and. & iout.eq.0) klo=khi elo=ehi nplo=nphi xlo=xhi khi=klo+8+2*nplo ehi=c(khi+1) nphi=nint(c(khi+5)) xhi=c(khi+6+2*nphi) enddo endif *d groupr.8904,8909 c unit base. if (int.ge.21) then xend=xlo+(xhi-xlo)*(ed-elo)/(ehi-elo) do ig=1,ng e1=eg(ig) if (ig.eq.1) e1=0 e1lo=e1*xlo/xend e1hi=e1*xhi/xend e2=eg(ig+1) if (ig.eq.ng) e2=ebig e2lo=e2*xlo/xend e2hi=e2*xhi/xend ip=2 ir=2 call intega(flo,e1lo,e2lo,c(klo),ip,ir) ip=2 ir=2 call intega(fhi,e1hi,e2hi,c(khi),ip,ir) fe=flo+(fhi-flo)*(ed-elo)/(ehi-elo) sed(ikt,ig)=sed(ikt,ig)+pe*fe enddo c corresponding points. not implemented. else if (int.ge.11) then do ig=1,ng sed(ikt,ig)=0 enddo c cartesion. else do ig=1,ng call terp1(elo,c(llo+ig),ehi,c(lhi+ig), & ed,s,int) sed(ikt,ig)=sed(ikt,ig)+s*pe enddo endif *ident up162 */ purr -- 20nov06 */ extend rdf3un logic to handle a file with just mt=1,2,102 */ (endf/b 253Es, for example). Also make "goto 100" test */ more robust (this has not been a problem in the past). *i purr.978 if (mth.eq.mtx(ix)) then ibase=isb+nunr*(ix-1)-1 goto 130 endif *d purr.980 if (ix.le.4) go to 100 goto 200 *d purr.992 200 icx=0 *ident up163 */ acer -- 21nov06 */ in aplots, make sure xlast is defined before appearing in an if test. */ in aplots, re-structure if test to only check iff if nnf>0. */ in aplopp, re-code iimax usage so don't exceed the spect dimension limit. *i acer.18615 xlast=small *d acer.18825 if (nnf.gt.0) then if (i.ge.iif) fiss=xss(kf+2+i-iif) endif *d acer.20985,20987 xmin=delta xmax=delta*(iimax+1) *d acer.21175,21177 xmin=delta xmax=delta*(iimax+1) *ident up164 */ viewr -- 21nov06 */ make sure iskip is defined before appearing in an if test. *i viewr.3488 iskip=0 *ident up165 */ moder -- 21nov06 */ the next two updates clean up some omissions from recent updates, */ noted by A.Trkov, A.Hogenbirk and/or C.Broeders (upijs65 in upnea112). *d moder.1116 external tab1io,moreio,listio,error *ident up166 */ acer -- 21nov06 */ (upijs66 in upnea112) *d up147.31 parameter (idmx=2000) *ident up167 */ groupr -- 29nov06 */ mods from C.Broeders, A.Hebert, A.Trkov & A.C.Kahler */ - add missing dimension statement for flux and sig. */ - initialize a array to zero. */ - fix unit base interpolation, from up161. */ - extend up161 to account for multiple interpolation ranges. */ - make sure elo,xlo are always defined in getsed. */ - save variable, na, in f6cm (ack) */ - advise user of possible abort condition due to faulty */ data from unresr (ack). */ this update includes parts of upnea005 and upnea007 (from upnea12). *i groupr.251 dimension flux(10,10),sig(10,10) *i groupr.277 do i=1,iamax a(i)=zero enddo *d groupr.4136 external findex,terpu,terp1,error *i groupr.4213 if (sl.lt.zero.or.sn.lt.zero) call error('getunr', & ' negative cross sections found - check unresr',' ') *d groupr.5334 save eps,xc,ndnow,npnow,ncnow,elmax,e,epmax,na */ some comments and additional corrections to the unit base */ transformation mods made earlier. *i groupr.8782 c this l points to the p(E) TAB1 function *i groupr.8785 c this l points to the TAB2 function *i up161.27 c lnow points to one of the ne incident energies c followed by spectrum integrals by user energy group *i groupr.8855 c mnow points to the TAB2 function *i groupr.8880 c nnow points to one of the ne incident energies c followed by spectrum integrals by user energy group *d up161.32,35 klo=nnow+(ng+1)*ne elo=c(klo+1) nrlo=nint(c(klo+4)) nplo=nint(c(klo+5)) xlo=c(klo+4+2*nrlo+2*nplo) khi=klo+6+2*nrlo+2*nplo ehi=c(khi+1) nrhi=nint(c(khi+4)) nphi=nint(c(khi+5)) xhi=c(khi+4+2*nrhi+2*nphi) *d up161.40,45 nrlo=nrhi nplo=nphi xlo=xhi khi=klo+6+2*nrlo+2*nplo ehi=c(khi+1) nrhi=nint(c(khi+4)) nphi=nint(c(khi+5)) xhi=c(khi+4+2*nrhi+2*nphi) *d up161.51 jnt=int-20 call terp1(elo,xlo,ehi,xhi,ed,xend,jnt) *d up161.62 ir=1 *d up161.65 ir=1 *d up161.67 call terp1(elo,flo,ehi,fhi,ed,fe,jnt) *b groupr.8910 c c ***upscatter is not allowed in secondary energy *ident up168 */ thermr -- 29nov06 */ make sure sz2 is defined before appearing in subsequent if test. */ edit temperature with more digits. *i thermr.136 sz2=0 *d thermr.2648 & '' wrote thermal data for temp ='',1pe11.4,28x,0pf8.1,''s'')') *d thermr.2651 & '' wrote thermal data for temp ='',1pe11.4,28x,0pf8.1,''s'')') *ident up169 */ matxsr -- 04dec06 */ correct variable (from V.Sinitsa, upnea008 in upnea112). *d matxsr.1108 if (abs(b(loc)).ge.eps) go to 360 *ident up170 */ ccccr -- 04dec06 */ seems like we always need more space, increase array limit */ from 2000 to 8000 (C. Broeders, upnea003 in upnea112). *d ccccr.128 common/enddat/e(8000) *d ccccr.145 maxe=8000 *d ccccr.513 common/enddat/e(8000) *d ccccr.708 common/enddat/e(8000) *d ccccr.1005 common/enddat/e(8000) *d ccccr.1164 common/enddat/e(8000) *d ccccr.1980 common/enddat/e(8000) *d ccccr.2386 common/enddat/e(8000) *d ccccr.2536 common/enddat/e(8000) *d ccccr.3066 common/enddat/e(8000) *ident up171 */ matxsr -- 04dec06 */ more space again (C. Broeders, most of upnea006 in upnea112). */ a,ia from 50,000 to 200,000. */ ha from 25,000 to 100,000. */ b from 2,000 to 80,000. */ hvps, hmtx from 300 to 3,000. */ increase maxw from 5,000 to 50,000 is not included at this */ time since it affects TRANSX. */ add dimension limit test also. *d matxsr.393 common/mstore/a(200000) *d matxsr.405 isiza=200000 *d matxsr.496 common/mstore/a(200000) *d matxsr.505 dimension ia(200000),ha(100000) */ *d matxsr.512 */ maxw=50000 *d matxsr.762 common/mstore/a(200000) *d matxsr.770 dimension ia(200000),ha(100000) *d matxsr.887 common/mstore/a(200000) *d matxsr.906 dimension ia(200000),ha(100000) *d matxsr.1475 character*85 cm2 common/mstore/a(200000) *d matxsr.1482 common/hollr/hvps(3000),hmtx(3000) *d matxsr.1487 dimension ia(200000),ha(100000) *d up88.21 dimension b(8000) *d up88.23 maxb=8000 *i matxsr.1635 if (lout.lt.1.or.lout.gt.isiza) then write(cm2,'(6(a,i8))')' ivdat=',ivdat,' n1i=',n1i,' ning',ning, & ' ig=',ig,' lout=',lout,' isiza=',isiza call error('vector','lout>isiza',cm2) endif lin=lz+nl*(nz+iz-1)+1 if (lin.lt.1.or.lin.gt.maxb) then write(cm2,'(6(a,i8))')' lz=',lz,' nl=',nl,' nz',nz,' iz=',iz, & ' lin=',lin,' maxb=',maxb call error('vector','lin>maxb',cm2) endif *d matxsr.1806 common/mstore/a(200000) *d matxsr.1814 common/hollr/hvps(3000),hmtx(3000) *d matxsr.1821 dimension ia(200000),ha(100000) *d matxsr.1971 common/mstore/a(200000) *d matxsr.1975 dimension ia(200000) *d matxsr.2071 common/mstore/a(200000) *ident up172 */ purr -- 04dec06 */ the original purr coding correctly built the mt153 section except */ for the final heating values. ident up62 corrected this for direct */ heating values but not for heating "factors". This ident correctly */ computes the heating term, direct or factor (H. Trellue, LANL). *d purr.452,478 a(l)=a(l)+(a(k+1)-a(k+2)-a(k+3)-a(k+4)) h=a(k+2) if (lssf.eq.1) then h=h*a(n1+j+2*nbin) else if (sigu(2,1,1).ne.0) then h=h*a(n1+j+2*nbin)/sigu(2,1,1) endif a(l)=a(l)+h h=a(k+3) if (lssf.eq.1) then h=h*a(n1+j+3*nbin) else if (sigu(3,1,1).ne.0) then h=h*a(n1+j+3*nbin)/sigu(3,1,1) endif a(l)=a(l)+h h=a(k+4) if (lssf.eq.1) then h=h*a(n1+j+4*nbin) else if (sigu(4,1,1).ne.0) then h=h*a(n1+j+4*nbin)/sigu(4,1,1) endif a(l)=a(l)+h if (lssf.eq.1) then a(l)=a(l)/a(k+1)/a(n1+j+nbin) else if (a(n1+j+nbin).ne.zero) a(l)=a(l)/a(n1+j+nbin) endif *ident up173 */ acer -- 18dec06 */ check file5 TAB1 secondary spectra when lf=1 for multiple [e,f(e)] */ data where f(e)=0. If found, delete all but the last pair or else */ interpolation can produce a distorted secondary energy distribution. */ Also, if histogram interpolation is used for the secondary spectra, */ eliminate all leading [e,f(e)] data where f(e)=0. This issue noted */ by Sutton and Trumbull (KAPL) and documented in Transactions of the */ American Nuclear Society, volume 93 (2005) 555. *i acer.2124 character*60 string *i acer.2166 nt1w=2500 call reserv('tab1',nt1w,itab1,a) *d acer.2298 c ***for file 5, get mf, mt and tab1 lf. c ***if lf.ne.1, copy as is to nout c ***if lf.eq.1, check secondary spectrum tab1 functions c for multiple [e,f(e)=0.] data pairs. For non-histogram c interpolation, eliminate the lower energy pairs before c writing the function to nout. For histogram interpolation, c eliminate all low energy f(e)=0 data pairs. *d acer.2307 c call tosend(nin,nout,0,a(iscr)) loct1=itab1 c ***read the initial tab1 and get lf. call tab1io(nin,0,0,a(loct1),nb,nw) do while (nb.ne.0) loct1=loct1+nw if(loct1.gt.(itab1+nt1w))then call error('topfil', & 'itab1 allocation is too small1',' ') endif call moreio(nin,0,0,a(loct1),nb,nw) enddo lf=nint(a(itab1+3)) c ***move this tab1 to nout (all the time). call tab1io(0,nout,0,a(itab1),nb,nw) loct1=itab1+nw do while (nb.ne.0) call moreio(0,nout,0,a(loct1),nb,nw) loct1=loct1+nw enddo c ***if not lf=1, write rest of this section to nout. if(lf .ne. 1)then call tosend(nin,nout,0,a(iscr)) else c ***lf=1, read the tab2 function. loct2=itab1 call tab2io(nin,0,0,a(loct2),nb,nw) ne2=nint(a(loct2+5)) c ***move this tab2 to nout (all the time). call tab2io(0,nout,0,a(loct2),nb,nw) c ***check secondary tab1 functions. do nn=1,ne2 loct1=itab1 call tab1io(nin,0,0,a(loct1),nb,nw) do while (nb.ne.0) loct1=loct1+nw if(loct1.gt.(itab1+nt1w))then call error('topfil', & 'itab1 allocation is too small2', & ' ') endif call moreio(nin,0,0,a(loct1),nb,nw) enddo nr=nint(a(itab1+4)) nf=nint(a(itab1+5)) c ***check tab1 for multiple f(e)=0 data. c ***if the first f(e) is non-zero, nothing else to do. c ***if histogram interpolation, check from the first c ***f(e) value, if not check from the second f(e) value loc=itab1+6+2*nr+1 if(a(loc).eq.zero)then if(nint(a(itab1+7)) .ne. 1)loc=loc+2 locmx=itab1+6+2*nr+2*nf npe=0 do while(a(loc).eq.zero) if(loc.gt.locmx)then write(string,'(a,i3,a)')'mf=5,mt=',mt, & ', entire tab1 function is zero.' call error('topfil',string,' ') endif loc=loc+2 npe=npe+1 enddo if(npe.ne.0)then c ***yes multiple zero data found, eliminate them. c ***fix nf; c ***fix the pointer array (interpolation code c array remains the same); c ***shift a array. a(itab1+5)=a(itab1+5)-float(npe) loc=itab1+6 do n=loc,loc+2*nr,2 a(n)=a(n)-float(npe) enddo loc=itab1+6+2*nr-1 do n=1,nint(2*a(itab1+5)) a(loc+n)=a(loc+n+2*npe) enddo endif endif c ***write the tab1 function to nout. call tab1io(0,nout,0,a(itab1),nb,nw) loct1=itab1+nw do while (nb.ne.0) call moreio(0,nout,0,a(loct1),nb,nw) loct1=loct1+nw enddo enddo c ***write section end record to nout. call contio(nin,nout,0,a(iscr),nb,nw) endif *ident up174 */ acer -- 13dec06 */ photon yield tables generated from transition probability arrays by */ convr currently have an upper energy of 20 mev. some new evaluations */ have transitions given for higher energies (e.g., th-232 to 60 mev). */ this patch uses the emax parameter from file 1 for endf-6 format */ evaluations, and leaves the 20 mev limit for the older formats. */ the effect of this problem shows up as gpd mismatch problems in the */ acer consistency checks. *i up63.6 common/acea/elim *i acer.634 elim=ehi if (iver.eq.6) elim=a(iscr+1) *i acer.3736 common/acea/elim *d acer.4072 a(iscr+10)=elim *d acer.4089 a(iscr+10)=elim *ident up175 */ broadr -- 13dec06 */ this patch increases the number of reactions that can be broadened */ simultaneously from 10 to 40 (from kazuaki kosako). it comes into */ effect when thnmax<0 is used to override the default maximum energy */ for broadening (the smallest of 1 mev, the start of the UR range, */ or the first threshold). this can be important for very high */ temperatures (e.g., astropysics). caution: when UR data are present, */ thnmax<0 will broaden them. this is not quite physically correct, */ but it is probably not a significant error at high temperatures (this */ patch also implements the change specified in upnea012 of upnea12). *b broadr.104 parameter (nttmax=40) *d broadr.114 dimension temp2(10),tt(nttmax+1),mtr(nttmax),mti(nttmax) *d broadr.138 ntt=nttmax *d broadr.410 & '' points out='',i6/(9x,''mt'',16i4:))') *b broadr.923 parameter (nttmax=40) *d broadr.927 dimension tt(nttmax+1) *b broadr.1034 parameter (nttmax=40) *d broadr.1038,1039 dimension ks(12),es(12),js(12),ss(nttmax,12) dimension tt(nttmax+1),sn(nttmax),dl(nttmax) *b broadr.1243 parameter (nttmax=40) *d broadr.1249 dimension fzero(5),sbt(nttmax) *b broadr.1409 parameter (nttmax=40) *d broadr.1413 dimension tt(nttmax+1) *ident up176 */ broadr -- 13dec06 */ allow for broadening of the charged particle levels in endf-6 */ format evaluations (e.g., mt800, 801, ...) if thnmax<0 has been */ used to override the default upper limit for broadening. *d broadr.329 if (iverf.lt.6) then if (mth.gt.150) go to 165 else if (mth.gt.150.and.mth.lt.600) go to 165 if (mth.ge.850) go to 165 endif */ increase the memory available to broadr. For reactor applications */ an array size of several hundred thousand is adequate; a value of */ 2,000,000 allows a complex evaluation like endf/b-vii 238u to be */ broadened to stellar temperatures in a single step. *d up58.9 dimension a(2000000) *d up58.11 namax=2000000 *ident up177 */ thermr -- 13dec06 */ improve energy grid for free gas scattering at higher temperatures. */ this method maps the range of egrid (1e-5 to 10 ev) onto a new */ grid running from 1e-5 ev to (10 eV)*temp/293.6. *d thermr.1734 if (temp.gt.break) then tone=therm/bk elo=egrid(1) enow=elo*exp(log(enow/elo)*log((temp/tone)*egrid(ngrid)/elo) & /log(egrid(ngrid)/elo)) endif *ident up178 */ acer -- 18dec06 */ make sure spect(_) index in aplopp is legal; force the */ lowest energy into the first index. *d acer.20889 iii=max0(1,nint(eg/delta)) *d acer.20936 iii=max0(1,nint(ep/delta)) *d acer.21072 iii=max0(1,nint(eg/delta)) *d acer.21120 iii=max0(1,nint(ep/delta)) *ident up179 */ viewr -- 21dec06 */ add a little more information to the .ps output file *i viewr.3696 write(nps,'(''%%Pages: (atend)'')') *i viewr.3713 if(ipage.lt.10)then write(nps,'(''%%Trailer'',/,''%%Pages: '',i1)')ipage elseif(ipage.lt.100)then write(nps,'(''%%Trailer'',/,''%%Pages: '',i2)')ipage else write(nps,'(''%%Trailer'',/,''%%Pages: '',i3)')ipage endif *ident up180 */ njoy -- 05feb07 */ combine with idents 181 (reconr) and 182 (broadr) to allow for */ 8-digit energies in the 0.1 eV to 1.0 eV interval. Previous coding */ assumed 7-digit "e" format was good enough to yield monotonically */ increasing energy in this interval. Issue reported by Lubitz, KAPL. *i njoy.1268 tenth=0.1d0 *i njoy.1279 tenth=0.1e0 *d njoy.1297 100 if (x.gt.tenth.and.x.lt.amil) go to 130 *d njoy.1345,1353 140 f=x s='-' n=-1 *d njoy.1355 if (n.le.0) write(hx,'(f11.8)') f *d njoy.1361 if (n.eq.-1)n=1 if (f.ge.one .and. hx(10:11).eq.'00')write(hx,'(f9.6,a,i1)')f,s,n if (f.gt.tenth .and. f.lt.one .and. hx(11:11).eq.'0') & write(hx,'(1pf9.6,a,i1)')f,s,n *ident up181 */ reconr -- 05feb07 */ combine with idents up180 and up182 to allow an 8-digit f format */ for the energy, when necessary, in lieu of a 7-digit e format in */ the 0.1 eV to 1.0 eV energy interval. *i reconr.2014 data n7,n8,n9/7,8,9/ *d reconr.2019 data tenth,one,ten/0.1d0,1.d0,10.d0/ *d reconr.2025 data tenth,one,ten/0.1e0,1.e0,10.e0/ *d reconr.2110.2111 ndig=n9 if(xm.gt.tenth .and. xm.lt.one)then ndig=n8 endif if(xm.gt.sigfig(a(ix+i-1),ndig,+1) .and. & xm.lt.sigfig(a(ix+i-2),ndig,-1))go to 135 *d reconr.2145 xm=sigfig(xm,ndig,0) *ident up182 */ broadr -- 09feb07 */ combine with idents up180 and up181 to allow an 8-digit f format */ for the energy, when necessary, in lieu of a 7-digit e format in */ the 0.1 eV to 1.0 eV energy interval. *i broadr.1042 data n7,n8,n9/7,8,9/ *i broadr.1044 data ssmall/1.d-6/ data tenth/0.1d0/ *i broadr.1054 data ssmall/1.e-6/ data tenth/0.1e0/ *i broadr.1133 ndig=n9 if(em.gt.tenth .and. em.lt.one)then ndig=n8 endif *d broadr.1138 em=sigfig(em,ndig,0) *d broadr.1141,1142 if (em.lt.sigfig(es(is) ,ndig,+1) .or. & em.gt.sigfig(es(is-1),ndig,-1)) go to 150 */ original issue (from up180) was caused when a very dense */ energy mesh was created for a truly small cross section. */ Insert a threshold test for each partial cross section so */ that small cross sections aren't part of the energy mesh */ generation process. *i broadr.1152 stot=zero do 144 i=1,nreac stot=stot+sn(i) 144 continue *i broadr.1153 if(abs(sn(i)/stot).lt.ssmall)go to 145 *ident up183 */ acer -- 3may07 */ (was called up178 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ fix patching of mf5/law1 records to allow for multiple */ law 1 subsections (for jeff delayed neutrons). *i acer.2306 nk=n1h ik=0 111 ik=ik+1 *i up173.111 if (ik.lt.nk) go to 111 *ident up184 */ heatr -- 3may07 */ (was called up179 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ allow for larger mf1/mt452 sections (for jeff pu-239) *d up137.12 data nwmax/7000/ *ident up185 */ heatr -- 8may07 */ (was called up180 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ an error was made in up115 that incorrectly located a goto */ for file 6 processing. the effect was to add only the elastic */ contribution to the heating and omit the more important */ charged particle heating from sections of file 6. *d up115.21 *i heatr.1005 if (icon.lt.0) go to 179 */ for some extremely forwardly peaked distributions (e.g., mt2 */ at 200 mev in pb204) heatr can calculate mubar values greater */ than one, which leads to small negative elastic kerma */ contributions, and negative damage energy. the quadrature */ used has order 64. with this patch, we prevent mubar from */ become greater than one or damage energy from becoming */ negative. the elastic kerma and damage will not be */ accurate, but they are small, and they won't be negative. *i heatr.1678 if (wbar.gt.qp(64)) wbar=qp(64) *i heatr.1694 if (dame.lt.zero) dame=zero *ident up186 */ acer -- 10may07 */ (was called up181 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ correct the emin values for discrete photons from positive q */ reactions (example is as-74 from endf/b-vii). *d acer.497 call convr(nendf,npend,nscr2,0,nedis,nethr,a) *d acer.3720 subroutine convr(nin,npend,nout,nscr,nedis,nethr,a) *i acer.3740 dimension eeth(350) dimension mtth(350) *i acer.3820 c c ***get thresholds vs mt number call findf(matd,3,0,npend) nnth=0 101 call contio(npend,0,0,a(iscr),nb,nw) if (mfh.eq.0) go to 102 e=0 call gety1(e,enxt,jdis,x,npend,a(iscr)) nnth=nnth+1 eeth(nnth)=enxt mtth(nnth)=mth call tosend(npend,0,0,a(iscr)) go to 101 102 continue *i acer.4060 elow=0 do i=1,nnth if (mtth(i).eq.mth) elow=eeth(i) enddo *d acer.4070 a(iscr+8)=elow *d acer.4087 a(iscr+8)=elow */ zero out the gamma production value at the threshold *i acer.3554 if (i.gt.1.and.e.lt.thresh*(1+eps)) y=0 *ident up187 */ heatr -- 10may07 */ (was called up182 in earlier rem upn.dat files; is re-numbered */ here to keep all updates in calendar order). */ fix energy bounds for reconstructing photon yields from */ lo=2 transtion probability arrays to allow for energies */ higher than 20 mev and for positive q values. *i heatr.414 common/lims/ebot,etop *i heatr.447 etop=20000000 ebot=1 ebot=ebot/100000 *i heatr.464 if (iverf.eq.6) etop=c2h *i heatr.4103 common/lims/ebot,etop *d heatr.4279 a(iscr+8)=ebot *d heatr.4296 a(iscr+8)=ebot *ident up188 */ heatr -- 18may07 */ (was called up183 in earlier ack up### files; is re-numbered */ here to keep all updates in calendar order). */ investigate heatr optimization issue; runs ok with zero */ optimization; dies in file6, mt5 with o2 and static. */ solution: add missing variable (na) to save statement *d heatr.3052 save small,xc,ndnow,npnow,ncnow,elmax,e,epmax,na *ident up189 */ heatr -- 21may07 */ (upnea010) */ increase maximum number of lo=2 gammas *d groupr.7957 lmax=500 *ident up190 */ heatr -- 21may07 */ (upnea011) */ increase maximum number of lo=2 gammas (corresponds to */ change in ident189). *d heatr.4120 lmax=500 *ident up191 */ leapr -- 21may07 */ idents 10 and 114 modified some real*8 variables but failed */ to update the corresponding single precision variables. */ Do so here. Also correct a couple of instances where "e" */ format was used when it should have been "d", or vice-versa. *d leapr.1201 data c0/.125e0/ *d leapr.1269 data small/1.e-8/ *d leapr.1695 data small/1.d-9/ *d leapr.1736 data small/1.d-9/ *d leapr.1878 data amassh/3.3465e-24/ *d leapr.1886 data angst/1.e-8/ *d up86.12 data al1,al3,al4/4.04d-8,26.7495d0,1.495d0/ *d up86.17 data al1,al3,al4/4.04e-8,26.7495e0,1.495e0/ */ up114.24 is part of an internal ident114 comment. Delete it */ from the source code. *d up114.24 *i up114.71 *if sw *i up114.72 *endif *i up114.81 *if sw *i up114.87 *else data angst/1.e-8/ data therm/.0253e0/ data amassn/1.008664904e0/ data amu/1.6605402e-24/ data hbar/1.05457266e-27/ data ev/1.60217733e-12/ *endif *d leapr.2666 c --- Warning - single precision compilation on a 32-bit machine c will likely set smin to zero. data smin/2.e-75/ *ident up192 */ covr -- 21may07 */ ident111 changed a real*8 data statement; do the same */ for the corresponding single precision data. *d covr.127 c data tlev/.2e0,.4e0,.6e0,.8e0,1.0e0/ data tlev/.1e0,.2e0,.3e0,.4e0,1.0e0/ *ident up193 */ heatr -- 21may07 */ ident43 changed a real*8 data statement; do the same */ for the corresponding single precision data. *d heatr.429 data rup/1.0000001e0/ *ident up194 */ njoy -- 21may07 */ clean up double precision versus single precision code differences *d up141.6 xold=0.d0 *b njoy.4705 xold=0.e0 */ new intgio routine in ident118 is written for real*8 only. */ include single precision definitions here. *i up118.12 *if sw *i up118.13 *endif *ident up195 */ groupr -- 21may07 */ ident up107 only introduced new group structures for double */ precision NJOY. Add the corresponding single precision data */ here. *b groupr.1634 data eg19/ &1.000010e-05,1.000000e-01,5.400000e-01,4.000000e+00,8.315287e+00, &1.370959e+01,2.260329e+01,4.016900e+01,6.790405e+01,9.166088e+01, &1.486254e+02,3.043248e+02,4.539993e+02,7.485183e+02,1.234098e+03, &2.034684e+03,3.354626e+03,5.530844e+03,9.118820e+03,1.503439e+04, &2.478752e+04,4.086771e+04,6.737947e+04,1.110900e+05,1.831564e+05, &3.019738e+05,4.978707e+05,8.208500e+05,1.353353e+06,2.231302e+06, &3.678794e+06,6.065307e+06,1.000000e+07,1.964033e+07/ data eg20a/ &1.000010e-05,3.000000e-03,5.000000e-03,6.900000e-03,1.000000e-02, &1.500000e-02,2.000000e-02,2.500000e-02,3.000000e-02,3.500000e-02, &4.200000e-02,5.000000e-02,5.800000e-02,6.700000e-02,7.700000e-02, &8.000000e-02,9.500000e-02,1.000000e-01,1.150000e-01,1.340000e-01, &1.400000e-01,1.463700e-01,1.530300e-01,1.600000e-01,1.697100e-01, &1.800000e-01,1.890000e-01,1.988100e-01,2.091400e-01,2.200000e-01, &2.335800e-01,2.480000e-01,2.635100e-01,2.800000e-01,3.000000e-01, &3.145000e-01,3.200000e-01,3.346600e-01,3.500000e-01,3.699300e-01, &3.910000e-01,4.000000e-01,4.139900e-01,4.330000e-01,4.496800e-01, &4.670100e-01,4.850000e-01,5.000000e-01,5.196200e-01,5.315800e-01, &5.400000e-01,5.669600e-01,5.952800e-01,6.250000e-01,6.531500e-01, &6.825600e-01,7.050000e-01,7.415500e-01,7.800000e-01,7.900000e-01, &8.194500e-01,8.500000e-01,8.600000e-01,8.764250e-01,9.100000e-01, &9.300000e-01,9.500000e-01,9.720000e-01,9.860000e-01,9.960000e-01, &1.020000e+00,1.035000e+00,1.045000e+00,1.071000e+00,1.080000e+00, &1.097000e+00,1.110000e+00,1.123000e+00,1.150000e+00,1.170000e+00, &1.202060e+00,1.235000e+00,1.267080e+00,1.300000e+00,1.337500e+00, &1.370000e+00,1.404560e+00,1.440000e+00,1.475000e+00,1.500000e+00, &1.544340e+00,1.590000e+00,1.629510e+00,1.670000e+00,1.711970e+00/ data eg20b/ &1.755000e+00,1.797000e+00,1.840000e+00,1.855390e+00,1.884460e+00, &1.930000e+00,1.974490e+00,2.020000e+00,2.059610e+00,2.100000e+00, &2.130000e+00,2.185310e+00,2.242050e+00,2.300270e+00,2.360000e+00, &2.382370e+00,2.421710e+00,2.485030e+00,2.550000e+00,2.600000e+00, &2.659320e+00,2.720000e+00,2.767920e+00,2.837990e+00,2.909830e+00, &2.983490e+00,3.059020e+00,3.137330e+00,3.217630e+00,3.300000e+00, &3.380750e+00,3.466330e+00,3.554080e+00,3.644050e+00,3.736300e+00, &3.830880e+00,3.927860e+00,4.000000e+00,4.129250e+00,4.233782e+00, &4.340961e+00,4.450853e+00,4.563526e+00,4.679053e+00,4.797503e+00, &4.918953e+00,5.043477e+00,5.085681e+00,5.128239e+00,5.171153e+00, &5.214426e+00,5.258061e+00,5.302061e+00,5.346430e+00,5.391169e+00, &5.436284e+00,5.481775e+00,5.527647e+00,5.573904e+00,5.620547e+00, &5.667581e+00,5.715008e+00,5.762832e+00,5.811056e+00,5.859684e+00, &5.908719e+00,5.958164e+00,6.008022e+00,6.058298e+00,6.108995e+00, &6.160116e+00,6.211665e+00,6.263645e+00,6.316060e+00,6.368914e+00, &6.422210e+00,6.475952e+00,6.530144e+00,6.584789e+00,6.639892e+00, &6.695455e+00,6.751484e+00,6.807981e+00,6.864952e+00,6.922399e+00, &6.980326e+00,7.038739e+00,7.097640e+00,7.157034e+00,7.216925e+00, &7.277317e+00,7.338215e+00,7.399622e+00,7.461544e+00,7.523983e+00/ data eg20c/ &7.586945e+00,7.650434e+00,7.714454e+00,7.779009e+00,7.844105e+00, &7.909746e+00,7.975936e+00,8.042680e+00,8.109982e+00,8.177848e+00, &8.246281e+00,8.315287e+00,8.384871e+00,8.455037e+00,8.525790e+00, &8.597135e+00,8.669077e+00,8.741621e+00,8.814772e+00,8.888536e+00, &8.962916e+00,9.037919e+00,9.113550e+00,9.189814e+00,9.266715e+00, &9.344261e+00,9.422455e+00,9.501303e+00,9.580812e+00,9.660985e+00, &9.741830e+00,9.823351e+00,9.905554e+00,9.988446e+00,1.007203e+01, &1.015631e+01,1.024130e+01,1.032701e+01,1.041342e+01,1.050056e+01, &1.058843e+01,1.067704e+01,1.076639e+01,1.085648e+01,1.094733e+01, &1.103894e+01,1.113132e+01,1.122446e+01,1.131839e+01,1.141311e+01, &1.150861e+01,1.160492e+01,1.170203e+01,1.179995e+01,1.189870e+01, &1.199827e+01,1.209867e+01,1.219991e+01,1.230201e+01,1.240495e+01, &1.250876e+01,1.261343e+01,1.271898e+01,1.282542e+01,1.293274e+01, &1.304097e+01,1.315010e+01,1.326014e+01,1.337110e+01,1.348299e+01, &1.359582e+01,1.370959e+01,1.382431e+01,1.394000e+01,1.405665e+01, &1.417428e+01,1.429289e+01,1.441250e+01,1.453310e+01,1.465472e+01, &1.477735e+01,1.490101e+01,1.502570e+01,1.515144e+01,1.527823e+01, &1.540608e+01,1.553500e+01,1.566500e+01,1.579609e+01,1.592827e+01, &1.606156e+01,1.619597e+01,1.633150e+01,1.646816e+01,1.660597e+01/ data eg20d/ &1.674493e+01,1.688506e+01,1.702635e+01,1.716883e+01,1.731250e+01, &1.745738e+01,1.760346e+01,1.775077e+01,1.789931e+01,1.804910e+01, &1.820013e+01,1.835244e+01,1.850601e+01,1.866087e+01,1.881703e+01, &1.897449e+01,1.913328e+01,1.929339e+01,1.945484e+01,1.961764e+01, &1.978180e+01,1.994734e+01,2.011426e+01,2.028258e+01,2.045231e+01, &2.062345e+01,2.079603e+01,2.097006e+01,2.114554e+01,2.132249e+01, &2.150092e+01,2.168084e+01,2.186227e+01,2.204522e+01,2.222969e+01, &2.241572e+01,2.260329e+01,2.279244e+01,2.298317e+01,2.317550e+01, &2.336944e+01,2.356499e+01,2.376219e+01,2.396104e+01,2.416154e+01, &2.436373e+01,2.456761e+01,2.477320e+01,2.498050e+01,2.518954e+01, &2.540033e+01,2.561289e+01,2.582722e+01,2.604335e+01,2.626128e+01, &2.648104e+01,2.670264e+01,2.692609e+01,2.715141e+01,2.737862e+01, &2.760773e+01,2.783875e+01,2.807171e+01,2.830662e+01,2.854349e+01, &2.878235e+01,2.902320e+01,2.926607e+01,2.951098e+01,2.975793e+01, &3.000695e+01,3.025805e+01,3.051126e+01,3.076658e+01,3.102404e+01, &3.128365e+01,3.154544e+01,3.180942e+01,3.207560e+01,3.234401e+01, &3.261467e+01,3.288760e+01,3.316281e+01,3.344032e+01,3.372015e+01, &3.400233e+01,3.428686e+01,3.457378e+01,3.486310e+01,3.515484e+01, &3.544902e+01,3.574566e+01,3.604479e+01,3.634642e+01,3.665057e+01/ data eg20e/ &3.695727e+01,3.726653e+01,3.757838e+01,3.789285e+01,3.820994e+01, &3.852969e+01,3.885211e+01,3.917723e+01,3.950507e+01,3.983565e+01, &4.016900e+01,4.050514e+01,4.084410e+01,4.118589e+01,4.153054e+01, &4.187807e+01,4.222851e+01,4.258189e+01,4.293822e+01,4.329753e+01, &4.365985e+01,4.402521e+01,4.439361e+01,4.476511e+01,4.513971e+01, &4.551744e+01,4.589834e+01,4.628243e+01,4.666972e+01,4.706026e+01, &4.745407e+01,4.785117e+01,4.825160e+01,4.865538e+01,4.906253e+01, &4.947309e+01,4.988709e+01,5.030456e+01,5.072551e+01,5.114999e+01, &5.157802e+01,5.200963e+01,5.244486e+01,5.288373e+01,5.332626e+01, &5.377251e+01,5.422248e+01,5.467623e+01,5.513376e+01,5.559513e+01, &5.606036e+01,5.652948e+01,5.700253e+01,5.747954e+01,5.796053e+01, &5.844556e+01,5.893464e+01,5.942781e+01,5.992511e+01,6.042657e+01, &6.093223e+01,6.144212e+01,6.195628e+01,6.247474e+01,6.299754e+01, &6.352471e+01,6.405630e+01,6.459233e+01,6.513285e+01,6.567789e+01, &6.622749e+01,6.678169e+01,6.734053e+01,6.790405e+01,6.847228e+01, &6.904527e+01,6.962305e+01,7.020566e+01,7.079316e+01,7.138556e+01, &7.198293e+01,7.258529e+01,7.319270e+01,7.380518e+01,7.442280e+01, &7.504558e+01,7.567357e+01,7.630682e+01,7.694537e+01,7.758926e+01, &7.823854e+01,7.889325e+01,7.955344e+01,8.021915e+01,8.089044e+01/ data eg20f/ &8.156734e+01,8.224991e+01,8.293819e+01,8.363223e+01,8.433208e+01, &8.503778e+01,8.574939e+01,8.646695e+01,8.719052e+01,8.792015e+01, &8.865588e+01,8.939776e+01,9.014586e+01,9.090021e+01,9.166088e+01, &9.242791e+01,9.320136e+01,9.398128e+01,9.476773e+01,9.556076e+01, &9.636043e+01,9.716679e+01,9.797990e+01,9.879981e+01,9.962658e+01, &1.004603e+02,1.013009e+02,1.021486e+02,1.030034e+02,1.038654e+02, &1.047345e+02,1.056110e+02,1.064947e+02,1.073859e+02,1.082845e+02, &1.091907e+02,1.101044e+02,1.110258e+02,1.119548e+02,1.128917e+02, &1.138364e+02,1.147890e+02,1.157496e+02,1.167182e+02,1.176949e+02, &1.186798e+02,1.196729e+02,1.206744e+02,1.216842e+02,1.227024e+02, &1.237292e+02,1.247646e+02,1.258087e+02,1.268615e+02,1.279231e+02, &1.289935e+02,1.300730e+02,1.311615e+02,1.322590e+02,1.333658e+02, &1.344818e+02,1.356072e+02,1.367420e+02,1.378862e+02,1.390401e+02, &1.402036e+02,1.413768e+02,1.425599e+02,1.437529e+02,1.449558e+02, &1.461688e+02,1.473920e+02,1.486254e+02,1.498691e+02,1.511232e+02, &1.523879e+02,1.536631e+02,1.549489e+02,1.562456e+02,1.575531e+02, &1.588715e+02,1.602010e+02,1.615415e+02,1.628933e+02,1.642565e+02, &1.656310e+02,1.670170e+02,1.684146e+02,1.698239e+02,1.712451e+02, &1.726781e+02,1.741231e+02,1.755802e+02,1.770494e+02,1.785310e+02/ data eg20g/ &1.800250e+02,1.815315e+02,1.830505e+02,1.845823e+02,1.861269e+02, &1.876845e+02,1.892551e+02,1.908388e+02,1.924358e+02,1.940461e+02, &1.956699e+02,1.973073e+02,1.989584e+02,2.006233e+02,2.023021e+02, &2.039950e+02,2.057021e+02,2.074234e+02,2.091592e+02,2.109095e+02, &2.126744e+02,2.144541e+02,2.162487e+02,2.180583e+02,2.198830e+02, &2.217230e+02,2.235784e+02,2.254494e+02,2.273360e+02,2.292384e+02, &2.311567e+02,2.330910e+02,2.350416e+02,2.370084e+02,2.389917e+02, &2.409917e+02,2.430083e+02,2.450418e+02,2.470924e+02,2.491601e+02, &2.512451e+02,2.533476e+02,2.554676e+02,2.576054e+02,2.597611e+02, &2.619348e+02,2.641267e+02,2.663370e+02,2.685657e+02,2.708131e+02, &2.730793e+02,2.753645e+02,2.776688e+02,2.799924e+02,2.823354e+02, &2.846980e+02,2.870804e+02,2.894827e+02,2.919052e+02,2.943479e+02, &2.968110e+02,2.992948e+02,3.017993e+02,3.043248e+02,3.068715e+02, &3.094394e+02,3.120288e+02,3.146399e+02,3.172729e+02,3.199279e+02, &3.226051e+02,3.253047e+02,3.280269e+02,3.307719e+02,3.335398e+02, &3.363309e+02,3.391454e+02,3.419834e+02,3.448452e+02,3.477309e+02, &3.506408e+02,3.535750e+02,3.565338e+02,3.595173e+02,3.625258e+02, &3.655595e+02,3.686185e+02,3.717032e+02,3.748137e+02,3.779502e+02, &3.811129e+02,3.843021e+02,3.875180e+02,3.907608e+02,3.940308e+02/ data eg20h/ &3.973281e+02,4.006530e+02,4.040057e+02,4.073865e+02,4.107955e+02, &4.142332e+02,4.176995e+02,4.211949e+02,4.247195e+02,4.282736e+02, &4.318575e+02,4.354713e+02,4.391154e+02,4.427900e+02,4.464953e+02, &4.502317e+02,4.539993e+02,4.577984e+02,4.616294e+02,4.654923e+02, &4.693877e+02,4.733156e+02,4.772763e+02,4.812703e+02,4.852976e+02, &4.893587e+02,4.934537e+02,4.975830e+02,5.017468e+02,5.059455e+02, &5.101793e+02,5.144486e+02,5.187536e+02,5.230946e+02,5.274719e+02, &5.318859e+02,5.363368e+02,5.408249e+02,5.453506e+02,5.499142e+02, &5.545160e+02,5.591563e+02,5.638354e+02,5.685536e+02,5.733114e+02, &5.781089e+02,5.829466e+02,5.878248e+02,5.927438e+02,5.977040e+02, &6.027057e+02,6.077492e+02,6.128350e+02,6.179633e+02,6.231345e+02, &6.283489e+02,6.336071e+02,6.389092e+02,6.442557e+02,6.496469e+02, &6.550832e+02,6.605651e+02,6.660928e+02,6.716668e+02,6.772874e+02, &6.829550e+02,6.886701e+02,6.944330e+02,7.002441e+02,7.061038e+02, &7.120126e+02,7.179709e+02,7.239790e+02,7.300373e+02,7.361464e+02, &7.423066e+02,7.485183e+02,7.547820e+02,7.610981e+02,7.674671e+02, &7.738894e+02,7.803654e+02,7.868957e+02,7.934805e+02,8.001205e+02, &8.068160e+02,8.135676e+02,8.203756e+02,8.272407e+02,8.341631e+02, &8.411435e+02,8.481824e+02,8.552801e+02,8.624372e+02,8.696542e+02/ data eg20i/ &8.769316e+02,8.842699e+02,8.916696e+02,8.991312e+02,9.066553e+02, &9.142423e+02,9.218928e+02,9.296074e+02,9.373865e+02,9.452307e+02, &9.531405e+02,9.611165e+02,9.691593e+02,9.772694e+02,9.854473e+02, &9.936937e+02,1.002009e+03,1.010394e+03,1.018849e+03,1.027375e+03, &1.035972e+03,1.044641e+03,1.053383e+03,1.062198e+03,1.071087e+03, &1.080050e+03,1.089088e+03,1.098201e+03,1.107391e+03,1.116658e+03, &1.126002e+03,1.135425e+03,1.144926e+03,1.154507e+03,1.164168e+03, &1.173910e+03,1.183734e+03,1.193639e+03,1.203628e+03,1.213700e+03, &1.223857e+03,1.234098e+03,1.244425e+03,1.254839e+03,1.265339e+03, &1.275928e+03,1.286605e+03,1.297372e+03,1.308228e+03,1.319176e+03, &1.330215e+03,1.341346e+03,1.352571e+03,1.363889e+03,1.375303e+03, &1.386811e+03,1.398416e+03,1.410118e+03,1.421919e+03,1.433817e+03, &1.445816e+03,1.457915e+03,1.470115e+03,1.482417e+03,1.494822e+03, &1.507331e+03,1.519944e+03,1.532663e+03,1.545489e+03,1.558422e+03, &1.571463e+03,1.584613e+03,1.597874e+03,1.611245e+03,1.624728e+03, &1.638324e+03,1.652034e+03,1.665858e+03,1.679798e+03,1.693855e+03, &1.708030e+03,1.722323e+03,1.736735e+03,1.751268e+03,1.765923e+03, &1.780701e+03,1.795602e+03,1.810628e+03,1.825780e+03,1.841058e+03, &1.856464e+03,1.871999e+03,1.887665e+03,1.903461e+03,1.919389e+03/ data eg20j/ &1.935451e+03,1.951647e+03,1.967979e+03,1.984447e+03,2.001053e+03, &2.017798e+03,2.034684e+03,2.051710e+03,2.068879e+03,2.086192e+03, &2.103650e+03,2.121253e+03,2.139004e+03,2.156904e+03,2.174953e+03, &2.193153e+03,2.211506e+03,2.230012e+03,2.248673e+03,2.267490e+03, &2.286465e+03,2.305599e+03,2.324892e+03,2.344347e+03,2.363965e+03, &2.383747e+03,2.403695e+03,2.423809e+03,2.444092e+03,2.464545e+03, &2.485168e+03,2.505965e+03,2.526935e+03,2.548081e+03,2.569403e+03, &2.590904e+03,2.612586e+03,2.634448e+03,2.656494e+03,2.678723e+03, &2.701139e+03,2.723743e+03,2.746536e+03,2.769519e+03,2.792695e+03, &2.816065e+03,2.839630e+03,2.863392e+03,2.887354e+03,2.911515e+03, &2.935879e+03,2.960447e+03,2.985221e+03,3.010202e+03,3.035391e+03, &3.060792e+03,3.086405e+03,3.112233e+03,3.138276e+03,3.164538e+03, &3.191019e+03,3.217722e+03,3.244649e+03,3.271800e+03,3.299179e+03, &3.326787e+03,3.354626e+03,3.382698e+03,3.411005e+03,3.439549e+03, &3.468332e+03,3.497355e+03,3.526622e+03,3.556133e+03,3.585891e+03, &3.615898e+03,3.646157e+03,3.676668e+03,3.707435e+03,3.738460e+03, &3.769744e+03,3.801290e+03,3.833099e+03,3.865175e+03,3.897520e+03, &3.930135e+03,3.963023e+03,3.996186e+03,4.029627e+03,4.063347e+03, &4.097350e+03,4.131637e+03,4.166211e+03,4.201075e+03,4.236230e+03/ data eg20k/ &4.271679e+03,4.307425e+03,4.343471e+03,4.379817e+03,4.416468e+03, &4.453426e+03,4.490693e+03,4.528272e+03,4.566165e+03,4.604375e+03, &4.642906e+03,4.681758e+03,4.720936e+03,4.760441e+03,4.800277e+03, &4.840447e+03,4.880952e+03,4.921797e+03,4.962983e+03,5.004514e+03, &5.046393e+03,5.088622e+03,5.131204e+03,5.174143e+03,5.217441e+03, &5.261101e+03,5.305127e+03,5.349521e+03,5.394287e+03,5.439427e+03, &5.484945e+03,5.530844e+03,5.577127e+03,5.623797e+03,5.670858e+03, &5.718312e+03,5.766164e+03,5.814416e+03,5.863072e+03,5.912135e+03, &5.961609e+03,6.011496e+03,6.061802e+03,6.112528e+03,6.163678e+03, &6.215257e+03,6.267267e+03,6.319712e+03,6.372597e+03,6.425924e+03, &6.479697e+03,6.533920e+03,6.588597e+03,6.643731e+03,6.699327e+03, &6.755388e+03,6.811918e+03,6.868921e+03,6.926401e+03,6.984362e+03, &7.042809e+03,7.101744e+03,7.161172e+03,7.221098e+03,7.281525e+03, &7.342458e+03,7.403901e+03,7.465858e+03,7.528334e+03,7.591332e+03, &7.654857e+03,7.718914e+03,7.783507e+03,7.848641e+03,7.914319e+03, &7.980548e+03,8.047330e+03,8.114671e+03,8.182576e+03,8.251049e+03, &8.320095e+03,8.389719e+03,8.459926e+03,8.530719e+03,8.602106e+03, &8.674090e+03,8.746676e+03,8.819869e+03,8.893675e+03,8.968099e+03, &9.043145e+03,9.118820e+03,9.195127e+03,9.272074e+03,9.349664e+03/ data eg20l/ &9.427903e+03,9.506797e+03,9.586352e+03,9.666572e+03,9.747463e+03, &9.829031e+03,9.911282e+03,9.994221e+03,1.007785e+04,1.016219e+04, &1.024723e+04,1.033298e+04,1.041944e+04,1.050664e+04,1.059456e+04, &1.068321e+04,1.077261e+04,1.086276e+04,1.095366e+04,1.104532e+04, &1.113775e+04,1.123095e+04,1.132494e+04,1.141970e+04,1.151527e+04, &1.161163e+04,1.170880e+04,1.180678e+04,1.190558e+04,1.200521e+04, &1.210567e+04,1.220697e+04,1.230912e+04,1.241212e+04,1.251599e+04, &1.262073e+04,1.272634e+04,1.283283e+04,1.294022e+04,1.304851e+04, &1.315770e+04,1.326780e+04,1.337883e+04,1.349079e+04,1.360368e+04, &1.371752e+04,1.383231e+04,1.394806e+04,1.406478e+04,1.418247e+04, &1.430116e+04,1.442083e+04,1.454151e+04,1.466319e+04,1.478590e+04, &1.490963e+04,1.503439e+04,1.516020e+04,1.528706e+04,1.541499e+04, &1.554398e+04,1.567406e+04,1.580522e+04,1.593748e+04,1.607085e+04, &1.620533e+04,1.634094e+04,1.647768e+04,1.661557e+04,1.675461e+04, &1.689482e+04,1.703620e+04,1.717876e+04,1.732251e+04,1.746747e+04, &1.761364e+04,1.776104e+04,1.790966e+04,1.805953e+04,1.821066e+04, &1.836305e+04,1.851671e+04,1.867166e+04,1.882791e+04,1.898547e+04, &1.914434e+04,1.930454e+04,1.946608e+04,1.962898e+04,1.979324e+04, &1.995887e+04,2.012589e+04,2.029431e+04,2.046413e+04,2.063538e+04/ data eg20m/ &2.080806e+04,2.098218e+04,2.115777e+04,2.133482e+04,2.151335e+04, &2.169338e+04,2.187491e+04,2.205796e+04,2.224255e+04,2.242868e+04, &2.261636e+04,2.280562e+04,2.299646e+04,2.318890e+04,2.338295e+04, &2.357862e+04,2.377593e+04,2.397489e+04,2.417552e+04,2.437782e+04, &2.458182e+04,2.478752e+04,2.499495e+04,2.520411e+04,2.541502e+04, &2.562770e+04,2.584215e+04,2.605841e+04,2.627647e+04,2.649635e+04, &2.671808e+04,2.694166e+04,2.700000e+04,2.716711e+04,2.739445e+04, &2.762369e+04,2.785485e+04,2.808794e+04,2.832299e+04,2.850000e+04, &2.856000e+04,2.879899e+04,2.903999e+04,2.928300e+04,2.952804e+04, &2.977514e+04,3.002430e+04,3.027555e+04,3.052890e+04,3.078437e+04, &3.104198e+04,3.130174e+04,3.156368e+04,3.182781e+04,3.209415e+04, &3.236272e+04,3.263353e+04,3.290662e+04,3.318198e+04,3.345965e+04, &3.373965e+04,3.402199e+04,3.430669e+04,3.459377e+04,3.488326e+04, &3.517517e+04,3.546952e+04,3.576633e+04,3.606563e+04,3.636743e+04, &3.667176e+04,3.697864e+04,3.728808e+04,3.760011e+04,3.791476e+04, &3.823203e+04,3.855196e+04,3.887457e+04,3.919988e+04,3.952791e+04, &3.985869e+04,4.019223e+04,4.052857e+04,4.086771e+04,4.120970e+04, &4.155455e+04,4.190229e+04,4.225293e+04,4.260651e+04,4.296305e+04, &4.332257e+04,4.368510e+04,4.405066e+04,4.441928e+04,4.479099e+04/ data eg20n/ &4.516581e+04,4.554376e+04,4.592488e+04,4.630919e+04,4.669671e+04, &4.708747e+04,4.748151e+04,4.787884e+04,4.827950e+04,4.868351e+04, &4.909090e+04,4.950170e+04,4.991594e+04,5.033364e+04,5.075484e+04, &5.117957e+04,5.160785e+04,5.203971e+04,5.247518e+04,5.291430e+04, &5.335710e+04,5.380360e+04,5.425384e+04,5.470784e+04,5.516564e+04, &5.562728e+04,5.609278e+04,5.656217e+04,5.703549e+04,5.751277e+04, &5.799405e+04,5.847935e+04,5.896871e+04,5.946217e+04,5.995976e+04, &6.046151e+04,6.096747e+04,6.147765e+04,6.199211e+04,6.251086e+04, &6.303396e+04,6.356144e+04,6.409333e+04,6.462968e+04,6.517051e+04, &6.571586e+04,6.626579e+04,6.682031e+04,6.737947e+04,6.794331e+04, &6.851187e+04,6.908519e+04,6.966330e+04,7.024626e+04,7.083409e+04, &7.142684e+04,7.202455e+04,7.262726e+04,7.323502e+04,7.384786e+04, &7.446583e+04,7.508897e+04,7.571733e+04,7.635094e+04,7.698986e+04, &7.763412e+04,7.828378e+04,7.893887e+04,7.950000e+04,7.959944e+04, &8.026554e+04,8.093721e+04,8.161451e+04,8.229747e+04,8.250000e+04, &8.298615e+04,8.368059e+04,8.438084e+04,8.508695e+04,8.579897e+04, &8.651695e+04,8.724094e+04,8.797098e+04,8.870714e+04,8.944945e+04, &9.019798e+04,9.095277e+04,9.171388e+04,9.248135e+04,9.325525e+04, &9.403563e+04,9.482253e+04,9.561602e+04,9.641615e+04,9.722297e+04/ data eg20o/ &9.803655e+04,9.885694e+04,9.968419e+04,1.005184e+05,1.013595e+05, &1.022077e+05,1.030630e+05,1.039254e+05,1.047951e+05,1.056720e+05, &1.065563e+05,1.074480e+05,1.083471e+05,1.092538e+05,1.101681e+05, &1.110900e+05,1.120196e+05,1.129570e+05,1.139022e+05,1.148554e+05, &1.158165e+05,1.167857e+05,1.177629e+05,1.187484e+05,1.197421e+05, &1.207441e+05,1.217545e+05,1.227734e+05,1.238008e+05,1.248368e+05, &1.258814e+05,1.269348e+05,1.279970e+05,1.290681e+05,1.301482e+05, &1.312373e+05,1.323355e+05,1.334429e+05,1.345596e+05,1.356856e+05, &1.368210e+05,1.379660e+05,1.391205e+05,1.402847e+05,1.414586e+05, &1.426423e+05,1.438360e+05,1.450396e+05,1.462533e+05,1.474772e+05, &1.487113e+05,1.499558e+05,1.512106e+05,1.524760e+05,1.537519e+05, &1.550385e+05,1.563359e+05,1.576442e+05,1.589634e+05,1.602936e+05, &1.616349e+05,1.629875e+05,1.643514e+05,1.657268e+05,1.671136e+05, &1.685120e+05,1.699221e+05,1.713441e+05,1.727779e+05,1.742237e+05, &1.756817e+05,1.771518e+05,1.786342e+05,1.801291e+05,1.816364e+05, &1.831564e+05,1.846891e+05,1.862346e+05,1.877930e+05,1.893645e+05, &1.909491e+05,1.925470e+05,1.941583e+05,1.957830e+05,1.974214e+05, &1.990734e+05,2.007393e+05,2.024191e+05,2.041130e+05,2.058210e+05, &2.075434e+05,2.092801e+05,2.110314e+05,2.127974e+05,2.145781e+05/ data eg20p/ &2.163737e+05,2.181844e+05,2.200102e+05,2.218512e+05,2.237077e+05, &2.255797e+05,2.274674e+05,2.293709e+05,2.312903e+05,2.332258e+05, &2.351775e+05,2.371455e+05,2.391299e+05,2.411310e+05,2.431488e+05, &2.451835e+05,2.472353e+05,2.493042e+05,2.513904e+05,2.534941e+05, &2.556153e+05,2.577544e+05,2.599113e+05,2.620863e+05,2.642794e+05, &2.664910e+05,2.687210e+05,2.709697e+05,2.732372e+05,2.755237e+05, &2.778293e+05,2.801543e+05,2.824986e+05,2.848626e+05,2.872464e+05, &2.896501e+05,2.920740e+05,2.945181e+05,2.969826e+05,2.972000e+05, &2.985000e+05,2.994678e+05,3.019738e+05,3.045008e+05,3.070489e+05, &3.096183e+05,3.122093e+05,3.148219e+05,3.174564e+05,3.201129e+05, &3.227916e+05,3.254928e+05,3.282166e+05,3.309631e+05,3.337327e+05, &3.365254e+05,3.393415e+05,3.421812e+05,3.450446e+05,3.479320e+05, &3.508435e+05,3.537795e+05,3.567399e+05,3.597252e+05,3.627354e+05, &3.657708e+05,3.688317e+05,3.719181e+05,3.750304e+05,3.781687e+05, &3.813333e+05,3.845243e+05,3.877421e+05,3.909868e+05,3.942586e+05, &3.975578e+05,4.008846e+05,4.042393e+05,4.076220e+05,4.110331e+05, &4.144727e+05,4.179410e+05,4.214384e+05,4.249651e+05,4.285213e+05, &4.321072e+05,4.357231e+05,4.393693e+05,4.430460e+05,4.467535e+05, &4.504920e+05,4.542618e+05,4.580631e+05,4.618963e+05,4.657615e+05/ data eg20q/ &4.696591e+05,4.735892e+05,4.775523e+05,4.815485e+05,4.855782e+05, &4.896416e+05,4.937390e+05,4.978707e+05,5.020369e+05,5.062381e+05, &5.104743e+05,5.147461e+05,5.190535e+05,5.233971e+05,5.277769e+05, &5.321934e+05,5.366469e+05,5.411377e+05,5.456660e+05,5.502322e+05, &5.548366e+05,5.594796e+05,5.641614e+05,5.688824e+05,5.736429e+05, &5.784432e+05,5.832837e+05,5.881647e+05,5.930866e+05,5.980496e+05, &6.030542e+05,6.081006e+05,6.131893e+05,6.183206e+05,6.234948e+05, &6.287123e+05,6.339734e+05,6.392786e+05,6.446282e+05,6.500225e+05, &6.554620e+05,6.609470e+05,6.664779e+05,6.720551e+05,6.776790e+05, &6.833499e+05,6.890683e+05,6.948345e+05,7.006490e+05,7.065121e+05, &7.124243e+05,7.183860e+05,7.243976e+05,7.304594e+05,7.365720e+05, &7.427358e+05,7.489511e+05,7.552184e+05,7.615382e+05,7.679109e+05, &7.743369e+05,7.808167e+05,7.873507e+05,7.939393e+05,8.005831e+05, &8.072825e+05,8.140380e+05,8.208500e+05,8.277190e+05,8.346455e+05, &8.416299e+05,8.486728e+05,8.557746e+05,8.629359e+05,8.701570e+05, &8.774387e+05,8.847812e+05,8.921852e+05,8.996511e+05,9.071795e+05, &9.147709e+05,9.224259e+05,9.301449e+05,9.379285e+05,9.457772e+05, &9.536916e+05,9.616723e+05,9.697197e+05,9.778344e+05,9.860171e+05, &9.942682e+05,1.002588e+06,1.010978e+06,1.019438e+06,1.027969e+06/ data eg20r/ &1.036571e+06,1.045245e+06,1.053992e+06,1.062812e+06,1.071706e+06, &1.080674e+06,1.089717e+06,1.098836e+06,1.108032e+06,1.117304e+06, &1.126654e+06,1.136082e+06,1.145588e+06,1.155175e+06,1.164842e+06, &1.174589e+06,1.184418e+06,1.194330e+06,1.204324e+06,1.214402e+06, &1.224564e+06,1.234812e+06,1.245145e+06,1.255564e+06,1.266071e+06, &1.276666e+06,1.287349e+06,1.298122e+06,1.308985e+06,1.319938e+06, &1.330984e+06,1.342122e+06,1.353353e+06,1.364678e+06,1.376098e+06, &1.387613e+06,1.399225e+06,1.410934e+06,1.422741e+06,1.434646e+06, &1.446652e+06,1.458758e+06,1.470965e+06,1.483274e+06,1.495686e+06, &1.508202e+06,1.520823e+06,1.533550e+06,1.546383e+06,1.559323e+06, &1.572372e+06,1.585530e+06,1.598797e+06,1.612176e+06,1.625667e+06, &1.639271e+06,1.652989e+06,1.666821e+06,1.680770e+06,1.694834e+06, &1.709017e+06,1.723318e+06,1.737739e+06,1.752281e+06,1.766944e+06, &1.781731e+06,1.796640e+06,1.811675e+06,1.826835e+06,1.842122e+06, &1.857538e+06,1.873082e+06,1.888756e+06,1.904561e+06,1.920499e+06, &1.936570e+06,1.952776e+06,1.969117e+06,1.985595e+06,2.002210e+06, &2.018965e+06,2.035860e+06,2.052897e+06,2.070076e+06,2.087398e+06, &2.104866e+06,2.122480e+06,2.140241e+06,2.158151e+06,2.176211e+06, &2.194421e+06,2.212785e+06,2.231302e+06,2.249973e+06,2.268802e+06/ data eg20s/ &2.287787e+06,2.306932e+06,2.326237e+06,2.345703e+06,2.365332e+06, &2.385126e+06,2.405085e+06,2.425211e+06,2.445505e+06,2.465970e+06, &2.486605e+06,2.507414e+06,2.528396e+06,2.549554e+06,2.570889e+06, &2.592403e+06,2.614096e+06,2.635971e+06,2.658030e+06,2.680272e+06, &2.702701e+06,2.725318e+06,2.748124e+06,2.771121e+06,2.794310e+06, &2.817693e+06,2.841272e+06,2.865048e+06,2.889023e+06,2.913199e+06, &2.937577e+06,2.962159e+06,2.986947e+06,3.011942e+06,3.037147e+06, &3.062562e+06,3.088190e+06,3.114032e+06,3.140091e+06,3.166368e+06, &3.192864e+06,3.219583e+06,3.246525e+06,3.273692e+06,3.301087e+06, &3.328711e+06,3.356566e+06,3.384654e+06,3.412978e+06,3.441538e+06, &3.470337e+06,3.499377e+06,3.528661e+06,3.558189e+06,3.587965e+06, &3.617989e+06,3.648265e+06,3.678794e+06,3.709579e+06,3.740621e+06, &3.771924e+06,3.803488e+06,3.835316e+06,3.867410e+06,3.899773e+06, &3.932407e+06,3.965314e+06,3.998497e+06,4.031957e+06,4.065697e+06, &4.099719e+06,4.134026e+06,4.168620e+06,4.203504e+06,4.238679e+06, &4.274149e+06,4.309916e+06,4.345982e+06,4.382350e+06,4.419022e+06, &4.456001e+06,4.493290e+06,4.530890e+06,4.568805e+06,4.607038e+06, &4.645590e+06,4.684465e+06,4.723666e+06,4.763194e+06,4.803053e+06, &4.843246e+06,4.883775e+06,4.924643e+06,4.965853e+06,5.007408e+06/ data eg20t/ &5.049311e+06,5.091564e+06,5.134171e+06,5.177135e+06,5.220458e+06, &5.264143e+06,5.308195e+06,5.352614e+06,5.397406e+06,5.442572e+06, &5.488116e+06,5.534042e+06,5.580351e+06,5.627049e+06,5.674137e+06, &5.721619e+06,5.769498e+06,5.817778e+06,5.866462e+06,5.915554e+06, &5.965056e+06,6.014972e+06,6.065307e+06,6.116062e+06,6.167242e+06, &6.218851e+06,6.270891e+06,6.323367e+06,6.376282e+06,6.429639e+06, &6.483443e+06,6.537698e+06,6.592406e+06,6.647573e+06,6.703200e+06, &6.759294e+06,6.815857e+06,6.872893e+06,6.930406e+06,6.988401e+06, &7.046881e+06,7.105850e+06,7.165313e+06,7.225274e+06,7.285736e+06, &7.346704e+06,7.408182e+06,7.470175e+06,7.532687e+06,7.595721e+06, &7.659283e+06,7.723377e+06,7.788008e+06,7.853179e+06,7.918896e+06, &7.985162e+06,8.051983e+06,8.119363e+06,8.187308e+06,8.255820e+06, &8.324906e+06,8.394570e+06,8.464817e+06,8.535652e+06,8.607080e+06, &8.679105e+06,8.751733e+06,8.824969e+06,8.898818e+06,8.973284e+06, &9.048374e+06,9.124092e+06,9.200444e+06,9.277435e+06,9.355070e+06, &9.433354e+06,9.512294e+06,9.591895e+06,9.672161e+06,9.753099e+06, &9.834715e+06,9.917013e+06,1.000000e+07,1.008368e+07,1.016806e+07, &1.025315e+07,1.033895e+07,1.042547e+07,1.051271e+07,1.060068e+07, &1.068939e+07,1.077884e+07,1.086904e+07,1.095999e+07,1.105171e+07/ data eg20u/ &1.114419e+07,1.123745e+07,1.133148e+07,1.142631e+07,1.152193e+07, &1.161834e+07,1.171557e+07,1.181360e+07,1.191246e+07,1.201215e+07, &1.211267e+07,1.221403e+07,1.231624e+07,1.241930e+07,1.252323e+07, &1.262802e+07,1.273370e+07,1.284025e+07,1.294770e+07,1.305605e+07, &1.316531e+07,1.327548e+07,1.338657e+07,1.349859e+07,1.361155e+07, &1.372545e+07,1.384031e+07,1.395612e+07,1.407291e+07,1.419068e+07, &1.430943e+07,1.442917e+07,1.454991e+07,1.467167e+07,1.479444e+07, &1.491825e+07,1.504309e+07,1.516897e+07,1.529590e+07,1.542390e+07, &1.555297e+07,1.568312e+07,1.581436e+07,1.594670e+07,1.608014e+07, &1.621470e+07,1.635039e+07,1.648721e+07,1.662518e+07,1.676430e+07, &1.690459e+07,1.704605e+07,1.718869e+07,1.733253e+07,1.747757e+07, &1.762383e+07,1.777131e+07,1.792002e+07,1.806998e+07,1.822119e+07, &1.837367e+07,1.852742e+07,1.868246e+07,1.883880e+07,1.899644e+07, &1.915541e+07,1.931570e+07,1.947734e+07,1.964033e+07/ data eg21a/ &1.000010e-05,1.100000e-04,3.000000e-03,5.500100e-03,1.000000e-02, &1.500000e-02,2.000000e-02,3.000000e-02,3.200000e-02,3.238000e-02, &4.300000e-02,5.900100e-02,7.700100e-02,9.500000e-02,1.000000e-01, &1.150000e-01,1.340000e-01,1.600000e-01,1.890000e-01,2.200000e-01, &2.480000e-01,2.825000e-01,3.145000e-01,3.520000e-01,3.910100e-01, &4.139900e-01,4.330000e-01,4.850100e-01,5.315800e-01,5.400100e-01, &6.250100e-01,6.825600e-01,7.050000e-01,7.900100e-01,8.600100e-01, &8.764200e-01,9.300100e-01,9.860100e-01,1.010000e+00,1.035000e+00, &1.070000e+00,1.080000e+00,1.090000e+00,1.110000e+00,1.125400e+00, &1.170000e+00,1.235000e+00,1.305000e+00,1.370000e+00,1.440000e+00, &1.445000e+00,1.510000e+00,1.590000e+00,1.670000e+00,1.755000e+00, &1.840000e+00,1.855400e+00,1.930000e+00,2.020000e+00,2.130000e+00, &2.360000e+00,2.372400e+00,2.767900e+00,3.059000e+00,3.380700e+00, &3.927900e+00,4.129200e+00,4.470000e+00,4.670000e+00,5.043500e+00, &5.623000e+00,6.160100e+00,6.476000e+00,7.079000e+00,7.524000e+00, &7.943000e+00,8.315300e+00,8.913000e+00,9.189800e+00,1.000000e+01, &1.067700e+01,1.122400e+01,1.259000e+01,1.371000e+01,1.522700e+01, &1.674500e+01,1.760300e+01,1.902800e+01,2.045200e+01,2.260300e+01, &2.498000e+01,2.791800e+01,2.920300e+01,3.051100e+01,3.388900e+01/ data eg21b/ &3.726700e+01,3.981000e+01,4.551700e+01,4.785100e+01,5.012000e+01, &5.559500e+01,6.144200e+01,6.310000e+01,6.790400e+01,7.079000e+01, &7.889300e+01,8.527700e+01,9.166100e+01,1.013000e+02,1.122000e+02, &1.300700e+02,1.367400e+02,1.585000e+02,1.670200e+02,1.778000e+02, &2.039900e+02,2.144500e+02,2.430100e+02,2.753600e+02,3.043200e+02, &3.535800e+02,3.981000e+02,4.540000e+02,5.144600e+02,5.829500e+02, &6.310000e+02,6.772900e+02,7.079000e+02,7.485200e+02,8.482000e+02, &9.611200e+02,1.010400e+03,1.116700e+03,1.234100e+03,1.363900e+03, &1.507300e+03,1.584600e+03,1.795600e+03,2.034700e+03,2.113000e+03, &2.248700e+03,2.371000e+03,2.485200e+03,2.612600e+03,2.661000e+03, &2.746500e+03,2.818000e+03,3.035400e+03,3.162000e+03,3.354600e+03, &3.548000e+03,3.707400e+03,3.981000e+03,4.307400e+03,4.642900e+03, &5.004500e+03,5.530800e+03,6.267300e+03,7.101700e+03,7.465900e+03, &8.251000e+03,9.118800e+03,1.007800e+04,1.113800e+04,1.170900e+04, &1.272600e+04,1.383200e+04,1.503400e+04,1.585000e+04,1.661600e+04, &1.778000e+04,1.930500e+04,1.995000e+04,2.054000e+04,2.113000e+04, &2.187500e+04,2.239000e+04,2.304000e+04,2.357900e+04,2.417600e+04, &2.441000e+04,2.478800e+04,2.512000e+04,2.585000e+04,2.605800e+04, &2.661000e+04,2.700000e+04,2.738000e+04,2.818000e+04,2.850000e+04/ data eg21c/ &2.901000e+04,2.985000e+04,3.073000e+04,3.162000e+04,3.182800e+04, &3.430700e+04,3.697900e+04,4.086800e+04,4.358900e+04,4.630900e+04, &4.939200e+04,5.247500e+04,5.516600e+04,5.656200e+04,6.172500e+04, &6.737900e+04,7.200000e+04,7.499000e+04,7.950000e+04,8.229700e+04, &8.250000e+04,8.651700e+04,9.803700e+04,1.110900e+05,1.167900e+05, &1.227700e+05,1.290700e+05,1.356900e+05,1.426400e+05,1.499600e+05, &1.576400e+05,1.657300e+05,1.742200e+05,1.831600e+05,1.925500e+05, &2.024200e+05,2.128000e+05,2.237100e+05,2.351800e+05,2.472400e+05, &2.732400e+05,2.872500e+05,2.945200e+05,2.972000e+05,2.985000e+05, &3.019700e+05,3.337300e+05,3.688300e+05,3.877400e+05,4.076200e+05, &4.504900e+05,5.234000e+05,5.502300e+05,5.784400e+05,6.081000e+05, &6.392800e+05,6.720600e+05,7.065100e+05,7.427400e+05,7.808200e+05, &8.208500e+05,8.629400e+05,9.071800e+05,9.616400e+05,1.002600e+06, &1.108000e+06,1.164800e+06,1.224600e+06,1.287300e+06,1.353400e+06, &1.422700e+06,1.495700e+06,1.572400e+06,1.653000e+06,1.737700e+06, &1.826800e+06,1.920500e+06,2.019000e+06,2.122500e+06,2.231300e+06, &2.306900e+06,2.345700e+06,2.365300e+06,2.385200e+06,2.466000e+06, &2.592400e+06,2.725300e+06,2.865000e+06,3.011900e+06,3.166400e+06, &3.328700e+06,3.678800e+06,4.065700e+06,4.493300e+06,4.723700e+06/ data eg21d/ &4.965900e+06,5.220500e+06,5.488100e+06,5.769500e+06,6.065300e+06, &6.376300e+06,6.592400e+06,6.703200e+06,7.046900e+06,7.408200e+06, &7.788000e+06,8.187300e+06,8.607100e+06,9.048400e+06,9.512300e+06, &1.000000e+07,1.051300e+07,1.105200e+07,1.161800e+07,1.221400e+07, &1.284000e+07,1.349900e+07,1.384000e+07,1.419100e+07,1.455000e+07, &1.491800e+07,1.568300e+07,1.648700e+07,1.690500e+07,1.733300e+07, &1.964000e+07/ data eg22a/ &1.000010e-05,3.000000e-03,5.000000e-03,6.900000e-03,1.000000e-02, &1.500000e-02,2.000000e-02,2.500000e-02,3.000000e-02,3.500000e-02, &4.200000e-02,5.000000e-02,5.800000e-02,6.700000e-02,7.700000e-02, &8.000000e-02,9.500000e-02,1.000000e-01,1.150000e-01,1.340000e-01, &1.400000e-01,1.600000e-01,1.800000e-01,1.890000e-01,2.200000e-01, &2.480000e-01,2.800000e-01,3.000000e-01,3.145000e-01,3.200000e-01, &3.500000e-01,3.910000e-01,4.000000e-01,4.330000e-01,4.850000e-01, &5.000000e-01,5.400000e-01,6.250000e-01,7.050000e-01,7.800000e-01, &7.900000e-01,8.500000e-01,8.600000e-01,9.100000e-01,9.300000e-01, &9.500000e-01,9.720000e-01,9.860000e-01,9.960000e-01,1.020000e+00, &1.035000e+00,1.045000e+00,1.071000e+00,1.097000e+00,1.110000e+00, &1.123000e+00,1.150000e+00,1.170000e+00,1.235000e+00,1.300000e+00, &1.337500e+00,1.370000e+00,1.440000e+00,1.475000e+00,1.500000e+00, &1.590000e+00,1.670000e+00,1.755000e+00,1.840000e+00,1.930000e+00, &2.020000e+00,2.100000e+00,2.130000e+00,2.360000e+00,2.550000e+00, &2.600000e+00,2.720000e+00,2.767920e+00,3.300000e+00,3.380750e+00, &4.000000e+00,4.129250e+00,5.043477e+00,5.346430e+00,6.160116e+00, &7.523983e+00,8.315287e+00,9.189814e+00,9.905554e+00,1.122446e+01, &1.370959e+01,1.592827e+01,1.945484e+01,2.260329e+01,2.498050e+01/ data eg22b/ &2.760773e+01,3.051126e+01,3.372015e+01,3.726653e+01,4.016900e+01, &4.551744e+01,4.825160e+01,5.157802e+01,5.559513e+01,6.790405e+01, &7.567357e+01,9.166088e+01,1.367420e+02,1.486254e+02,2.039950e+02, &3.043248e+02,3.717032e+02,4.539993e+02,6.772874e+02,7.485183e+02, &9.142423e+02,1.010394e+03,1.234098e+03,1.433817e+03,1.507331e+03, &2.034684e+03,2.248673e+03,3.354626e+03,3.526622e+03,5.004514e+03, &5.530844e+03,7.465858e+03,9.118820e+03,1.113775e+04,1.503439e+04, &1.661557e+04,2.478752e+04,2.739445e+04,2.928300e+04,3.697864e+04, &4.086771e+04,5.516564e+04,6.737947e+04,8.229747e+04,1.110900e+05, &1.227734e+05,1.831564e+05,2.472353e+05,2.732372e+05,3.019738e+05, &4.076220e+05,4.504920e+05,4.978707e+05,5.502322e+05,6.081006e+05, &8.208500e+05,9.071795e+05,1.002588e+06,1.108032e+06,1.224564e+06, &1.353353e+06,1.652989e+06,2.018965e+06,2.231302e+06,2.465970e+06, &3.011942e+06,3.678794e+06,4.493290e+06,5.488116e+06,6.065307e+06, &6.703200e+06,8.187308e+06,1.000000e+07,1.1618343e+07, &1.3840307e+07,1.4918247e+07,1.733253e+07,1.964033e+07/ data eg23a/ &1.000010e-05,1.000010e-01,4.139940e-01,5.315790e-01,6.825600e-01, &8.764250e-01,1.123000e+00,1.440000e+00,1.855390e+00,2.382370e+00, &3.059020e+00,3.927860e+00,5.043480e+00,6.475950e+00,8.315290e+00, &1.067700e+01,1.370960e+01,1.760350e+01,2.260330e+01,2.902320e+01, &3.726650e+01,4.785120e+01,6.144210e+01,7.889320e+01,1.013010e+02, &1.300730e+02,1.670170e+02,2.144540e+02,2.753640e+02,3.535750e+02, &4.539990e+02,5.829470e+02,7.485180e+02,9.611170e+02,1.234100e+03, &1.584610e+03,2.034680e+03,2.248670e+03,2.485170e+03,2.612590e+03, &2.746540e+03,3.035390e+03,3.354630e+03,3.707440e+03,4.307420e+03, &5.530840e+03,7.101740e+03,9.118820e+03,1.059460e+04,1.170880e+04, &1.503440e+04,1.930450e+04,2.187490e+04,2.357860e+04,2.417550e+04, &2.478750e+04,2.605840e+04,2.700010e+04,2.850110e+04,3.182780e+04, &3.430670e+04,4.086770e+04,4.630920e+04,5.247520e+04,5.656220e+04, &6.737950e+04,7.202450e+04,7.949870e+04,8.250340e+04,8.651700e+04, &9.803650e+04,1.110900e+05,1.167860e+05,1.227730e+05,1.290680e+05, &1.356860e+05,1.426420e+05,1.499560e+05,1.576440e+05,1.657270e+05, &1.742240e+05,1.831560e+05,1.925470e+05,2.024190e+05,2.127970e+05, &2.237080e+05,2.351770e+05,2.472350e+05,2.732370e+05,2.872460e+05, &2.945180e+05,2.972110e+05,2.984910e+05,3.019740e+05,3.337330e+05/ data eg23b/ &3.688320e+05,3.877420e+05,4.076220e+05,4.504920e+05,4.978710e+05, &5.233970e+05,5.502320e+05,5.784430e+05,6.081010e+05,6.392790e+05, &6.720550e+05,7.065120e+05,7.427360e+05,7.808170e+05,8.208500e+05, &8.629360e+05,9.071800e+05,9.616720e+05,1.002590e+06,1.108030e+06, &1.164840e+06,1.224560e+06,1.287350e+06,1.353350e+06,1.422740e+06, &1.495690e+06,1.572370e+06,1.652990e+06,1.737740e+06,1.826840e+06, &1.920500e+06,2.018970e+06,2.122480e+06,2.231300e+06,2.306930e+06, &2.345700e+06,2.365330e+06,2.385130e+06,2.465970e+06,2.592400e+06, &2.725320e+06,2.865050e+06,3.011940e+06,3.166370e+06,3.328710e+06, &3.678790e+06,4.065700e+06,4.493290e+06,4.723670e+06,4.965850e+06, &5.220460e+06,5.488120e+06,5.769500e+06,6.065310e+06,6.376280e+06, &6.592410e+06,6.703200e+06,7.046880e+06,7.408180e+06,7.788010e+06, &8.187310e+06,8.607080e+06,9.048370e+06,9.512290e+06,1.000000e+07, &1.051270e+07,1.105170e+07,1.161830e+07,1.221400e+07,1.252320e+07, &1.284030e+07,1.349860e+07,1.384030e+07,1.419070e+07,1.454990e+07, &1.491820e+07,1.568310e+07,1.648720e+07,1.690460e+07,1.733250e+07, &1.964030e+07/ */ a comment and parameter (mxlg=65) statement were mistakenly */ placed within the *set sw construct several times in ident105. */ We need this parameter all of the time and move it out of */ the *set sw construct here. *d up105.11,up105.12 *b groupr.4758 c maximum legendre coefficients parameter (mxlg=65) *d up105.16,up105.17 *b groupr.5211 c maximum legendre coefficients parameter (mxlg=65) *d up105.40,up105.41 *b groupr.5994 c maximum legendre coefficients parameter (mxlg=65) *d up105.45,up105.46 *b groupr.6132 c maximum legendre coefficients parameter (mxlg=65) *d up105.51,up105.52 *b groupr.6735 c maximum legendre coefficients parameter (mxlg=65) *d up105.56,up105.57 *b groupr.7316 c maximum legendre coefficients parameter (mxlg=65) *d up105.61,up105.62 *b groupr.7931 c maximum legendre coefficients parameter (mxlg=65) *ident up196 */ acer -- 22may07 */ clean up single precision versus double precision issues; *b acer.2535 c --- Warning - single precision compilation on a 32-bit machine c will likely set tiny to zero. */ also set aside more scratch space to "a" in fix6 and increase */ an old 20 element Legendre array to 65 elements (altiparmakov, */ aecd). *d up108.27 dimension a(9000) *d acer.3249 dimension p(65) *d up108.29 namax=9000 */ a parameter idmx=2000 statement was mistakenly placed within */ the *set sw construct in ident147. It was corrected to read */ parameter (idmx=2000) in ident166, but is still incorrectly */ located within the *set sw block. We need this parameter all */ of the time and move it out of the *set sw construct here. *d up166.5 *b acer.7149 parameter (idmx=2000) */ move the common block out of *set sw. *d up143.6 *b acer.13446 common/mainio/nsysi,nsyso,nsyse,ntty *ident up197 */ broadr -- 22may07 */ change a double to a single in the single precision code *d broadr.128 therm=.0253e0 *ident up198 */ gaminr -- 22may07 */ change double to single in the single precision code *d gaminr.574 data eg3/.01e0,.10e0,.50e0,1.0e0,2.0e0,3.0e0,4.0e0,5.0e0,6.0e0, *ident up199 */ errorr -- 22may07 */ change single to double in the double precision code *d errorr.3493 data ezero/1.d7/ *ident up200 */ thermr -- 22may07 */ sz2, added in up168, needs both double and single precision definitions. *d up168.6 *b thermr.140 sz2=zero */ add double precision exponent to selected variables *d thermr.873 & 5.8052d0,6.9068d0,0.d0,0.d0/ *ident up201 */ acer -- 30may07 */ the block of coding designed to handle charged-particle production */ from isotropic sections of file 4 is being triggered incorrectly. */ one result of this is a double counting of the charged-particle */ heating represented by discrete levels in file 4. this can make */ the charged-particle heating larger than the total heating in some */ cases. this problem would affect coupled neutron-proton transport */ problems with mcnp or mcnpx. detected by little and trellue (lanl). *d acer.8950 ltt=l2h *ident up202 */ errorr -- 30may07 */ fix an error in the lethargies for the anl 27-group structure *d errorr.3431 data gl4/14.5d0,13.0d0,12.5d0,12.0d0,11.5d0,11.0d0,10.5d0, *d errorr.3534 data gl4/14.5e0,13.0e0,12.5e0,12.0e0,11.5e0,11.0e0,10.5e0, *ident up203 */ njoy -- 30may07 */ more double-single precision consistency problems *d njoy.3390,3391 save ae10cs,ae11cs,ae12cs,e11cs,e12cs,ae13cs,ae14cs, & ntae10,ntae11,ntae12,nte11,nte12,ntae13,ntae14,xmax,first *d njoy.4636 if (t.gt.alneps) then *d njoy.5194 if (m.ne.0) then *ident up204 */ heatr -- 30may07 */ the section of this routine that plots the photon energy-balance */ tests fails if the user didn't ask for mt303. noted by Dimitar */ Altiparmakov. one really should ask for mt303 when doing detailed */ energy-balance testing to get complete results. *i heatr.5429 if (mt303.eq.0) go to 490 *i heatr.5570 490 continue *ident up205 */ groupr -- 6jun07 */ fix a couple of single precision qp8 array values in getdis to */ exactly match the correctly specified double precision values. *d groupr.6461 & -.1834346425e0,.1834346425e0,.5255324099e0,.7966664774e0, *ident up206 */ acer -- 6jun07 */ add explicit definition for lttn to keep the intel compiler happy */ with zero optimization. *i acer.2222 lttn=0 *ident up207 */ groupr -- 6jun07 */ need to stop the ie loop one iteration sooner to avoid array */ bound underflow in groupr's flux calculator (altiparmakov, aecl). *d groupr.2819 do while (ie.gt.1.and.elim.gt.ej) *ident up208 */ heatr -- 11jun07 */ add a treatment for the relativistic discrete gamma in the */ incident neutron evaluation for h-1 for endf/b-vii. for */ now, we approximate this with a simple isotropic discrete */ primary photon. *d heatr.628 if (zap.eq.zero.and.(ik.gt.1.or.nk.eq.1)) then *d up115.16 & n6,j6,irec,jrec,iflag) *d up115.26 & n6,j6,irec,jrec,iflag) *d up115.37 & n2,j6,irec,jrec,iflag) *d heatr.1297 if (iprint.eq.1.and.i6g.gt.0.and.izap.ne.0.and.iflag.eq.0) *i heatr.2437 save disc102,zp,ap,zt,at *d heatr.2484 iflag=0 disc102=zero if (zap.eq.zero) then iflag=1 disc102=awp awp=0 endif *d heatr.2503 210 continue zp=int(zap/1000) zt=int(zat/1000) if (irec.gt.0) zp=zt-zp ap=awp if (irec.gt.0) ap=awr+1-awp at=awr if (zap.eq.zero) then ap=awr+1 zp=zt endif dame=df(e,zp,ap,zt,at) if (disc102.gt.zero) go to 295 if (law.ne.3.and.law.ne.6) then *d heatr.2515,2521 *i up115.48 return c 295 continue yld=1 call skip6(nin,0,0,c(l),law) *i heatr.2530 l=l+nw *i heatr.2582 if (disc102.gt.zero) go to 430 *i heatr.2663 c c ***discrete relativistic capture gamma 430 call hgam102(e,ebar,dame,disc102,c,irec,zp,ap,zt,at) yld=1 return *i heatr.4387 c subroutine hgam102(e,ebar,dame,disc102,c,irec,zp,ap,zt,at) c ****************************************************************** c process the relativistic discrete gamma or its recoil as c given in mf6/mt102 for endf/b-vii neutron + h-1. c ****************************************************************** implicit real*8 (a-h,o-z) common/kinim6/q,zat,awr,zap,awp,lct dimension c(*) c c ***approximate using discrete gamma for now if (irec.eq.0) then ebar=disc102+e*awr/(1+awr) dame=0 else ebar=e/(awr+1) dame=df(e,zp,ap,zt,at) endif return end *ident up209 */ acer -- 18jun07 */ we are double counting the recoil heating represented using */ file 6, law 4. example is li6(n,t)alpha where alpha heating */ is too big. reported by trellue and little (lanl). *i acer.9219 if (law.ne.4) then *i up40.19 endif *ident up210 */ groupr -- 18jun07 */ when weight function energies are 7 or more significant digits, the */ sigfig call can cause an infinite loop unless the new 6 digit enext */ is larger than its original value (Broeders). *d groupr.2596 enext=sigfig(enext,6,1) *ident up211 */ heatr - 19jun07 */ fix up phase-space calculations as used in endf/b-vii h-2. *d up127.7 *i heatr.2781 if (law.eq.6) lang=0 *d up127.9,15 *d heatr.3648 *ident up212 */ groupr - 19jun07 */ implement proper processing for the relativistic discrete */ gamma ray as given in mf6/mt102 for the endf/b-vii evaluation */ for incident neutrons on h-1. we are approximating it using */ a discrete primary photon for now. *i groupr.4772 save disc102 *i groupr.4831 disc102=0 *i groupr.4836 if (jzap.eq.0.and.law.eq.2) then disc102=awp awp=0 endif *d groupr.4869 140 if (disc102.gt.zero) go to 195 if (law.ge.2.and.law.le.5) go to 194 *i groupr.5062 if (disc102.gt.zero) go to 600 *i groupr.5172 c c ***discrete relativistic capture gamma 600 continue call gam102(ans,ed,enext,disc102,law,nl,iglo,ng2,nq) return *i groupr.7920 c subroutine gam102(ans,ed,enext,disc102,law,nl,iglo,ng2,nq) c ****************************************************************** c process the relativistic discrete gamma or its recoil as c given in mf6/mt102 for endf/b-vii neutron + h-1. c ****************************************************************** implicit real*8 (a-h,o-z) common/groupn/ign,ngn,egn(15000) common/groupg/igg,ngg,egg(400) common/kinim/awr,q,thresh,alpha,lrflag dimension ans(nl,*) c ***approximate using discrete gamma for now if (law.eq.2) then edis=disc102+ed*awr/(awr+1) do i=1,ngg if (edis.ge.egg(i).and.edis.lt.egg(i+1)) iglo=i enddo ng2=1 do i=1,nl ans(i,1)=0 enddo ans(1,1)=1 nq=0 if (ed.lt.egg(iglo+1)) then enext=egg(iglo+1) else if (ed.lt.egg(iglo)) then enext=egg(iglo) else enext=1e10 endif else if (law.eq.4) then edis=ed/(awr+1) do i=1,ngg if (edis.ge.egn(i).and.edis.lt.egn(i+1)) iglo=i enddo ng2=1 do i=1,nl ans(i,1)=1 enddo nq=0 if (ed.lt.egn(iglo+1)) then enext=egn(iglo+1) else if (ed.lt.egn(iglo)) then enext=egn(iglo) else enext=1e10 endif endif return end *ident up213 */ acer -- 19jun07 */ modify the vertical axes for the lin-lin principals *d acer.19127,19134 xmin=big xmax=0 ymin=big ymax=-big do i=1,nes e=xss(esz-1+i) if (e.gt.2) then tot=xss(esz+nes-1+i) abs=xss(esz+2*nes-1+i) elas=xss(esz+3*nes-1+i) if (e.lt.xmin) xmin=e if (e.gt.xmax) xmax=e if (tot.lt.ymin) ymin=tot if (tot.gt.ymax) ymax=tot if (abs.lt.ymin) ymin=abs if (abs.gt.ymax) ymax=abs if (elas.lt.ymin) ymin=elas if (elas.gt.ymax) ymax=elas if (gpd.ne.0) then gprod=xss(gpd-1+i) if (gprod.lt.ymin) ymin=gprod if (gprod.gt.ymax) ymax=gprod endif endif enddo ymin=0 */ allow negative kermas on the linear plot. *d acer.19260 *d acer.19298 */ add a linear plots of the recoil part of the heating; */ that is, the normal heating minus the charged-particle */ heating. this is a sensitive test of the energy-balance, */ showing when negative kermas might occur in coupled neutron */ and charged-particle transport calculations. *i acer.21362 c c ***plot lin-lin recoil heating xmin=big xmax=0 ymin=big ymax=-big do i=1,nes e=xss(esz-1+i) heat=xss(esz+4*nes-1+i) do j=1,ntyph ipt=nint(xss(ptype+j-1)) hpd=nint(xss(ploct+10*(j-1))) iaa=nint(xss(hpd)) naa=nint(xss(hpd+1)) ie=i-iaa-1 if (ie.ge.1.and.ie.le.naa) & heat=heat-xss(hpd+1+naa+ie) enddo if (e.lt.xmin) xmin=e if (e.gt.xmax) xmax=e if (heat.lt.ymin) ymin=heat if (heat.gt.ymax) ymax=heat enddo if (ymin.ne.zero.or.ymax.ne.zero) then if (ymin.lt.zero.and.ymax.lt.-ymin/2) ymax=-ymin/2 call ascle(4,xmin,xmax,major,minor) xstep=(xmax-xmin)/major call ascle(4,ymin,ymax,major,minor) ystep=(ymax-ymin)/major write(nout,'(''1'',i3,''/'')') iwcol it=1 do i=1,70 if (hk(i:i).ne.' ') it=i enddo write(nout,'(a,''<'',a,''>'',a,''/'')') qu,hk(1:it),qu write(nout,'(a,''ecoil eating'',a,''/'')') qu,qu write(nout,'(''1 0 2 1/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,xstep write(nout,'(a,''nergy (e)'',a,''/'')') qu,qu write(nout,'(1p,3e12.3,''/'')') ymin,ymax,ystep write(nout,'(a,''eating (e/reaction)'',a,''/'')') & qu,qu write(nout,'(''/'')') write(nout,'(''/'')') write(nout,'(a,''recoil heating'',a,''/'')') qu,qu write(nout,'(''0/'')') thin=(xmax-xmin)/nden xlast=small j=0 do i=1,nes e=xss(esz-1+i) test=1 test=test/5 if (e.ge.test) then if (nes.le.nden.or.e.ge.xlast+thin.or.i.eq.nes) then heat=xss(esz+4*nes-1+i) do k=1,ntyph ipt=nint(xss(ptype+k-1)) hpd=nint(xss(ploct+10*(k-1))) iaa=nint(xss(hpd)) naa=nint(xss(hpd+1)) ie=i-iaa-1 if (ie.ge.1.and.ie.le.naa) & heat=heat-xss(hpd+1+naa+ie) enddo j=j+1 write(nout,'(1p,2e14.6,''/'')') e,heat xlast=e endif endif enddo write(nout,'(''/'')') endif *ident up214 */ powr -- 19jun07 */ fill in missing format (g95 compiler warning). *d powr.787 & '' -----------------------'',(1p,6e12.4))') *ident up215 */ reconr -- 20jun07 */ modify lunion and recout to process photonuclear files *d reconr.1704 if (mfh.ne.23.and.awin.ne.zero) awrx=c2h/awin *d reconr.1709 if (awin.ne.0) then thrx=-qx*(awrx+1)/awrx else thrx=-qx endif */ force mt=3 into the dictionary total xs when photonuclear *d reconr.4481 if (int(a(imfs+i-1)).eq.3.and.mtr(imtr).eq.1 & .and.awin.ne.0) then a(j+4)=mtr(imtr) else a(j+4)=3 endif */ force mth=3 for total xs when photonuclear *i reconr.4563 if (awin.eq.0) then mth=3 endif *ident up216 */ acer -- 21jun07 */ modify the photonuclear section of acer to use both endf and pendf */ in order to handle the russian actinide evaluations properly. the */ endf input is used for the distributions, and the pendf input is used */ for the cross sections. if reconr reconstruction is not required for */ a given material, the endf and pendf inputs can be the same. *d acer.432 call acephn(nendf,npend,awr) *d acer.15198 subroutine acephn(nendf,npend,awr) *i acer.15262 nin=nendf *i acer.15263 call openz(npend,0) *i acer.15331 c ***using the pendf input nin=npend *i acer.15443 nin=nendf *ident up217 */ heatr -- 26jun07 */ increase selected arrays in getsix, h6cm and h6dis. These arrays */ contain data by Legendre order and should have been increased long */ ago. Use a parameter statement so future mods will be easy to make. *b heatr.2681 parameter (mxlg=65) *d heatr.2684,2686 dimension x(10),y(10,mxlg) dimension term(mxlg) dimension p(mxlg),qp(64),qw(64) *d heatr.3048,3049 parameter (mxlg=65) dimension cnow(*),term(*),p(mxlg) dimension x(10),y(10,mxlg),yt(mxlg) *d heatr.3426 parameter (mxlg=65) dimension cnow(*),p(mxlg) *ident up218 */ acer -- 26jun07 */ need a larger integer format when the energy mesh has more than */ 100K points. *d acer.10858 & '(6x,''i'',5x,''energy'',9x,a10,5(5x,a10))') *d acer.10860 write(nsyso,'(1x,''------'',3x,''------------'', *d acer.10877 write(nsyso,'(1x,i6,1p,e15.6,6a15)') *ident up219 */ acer -- 26jun07 */ smoothing options for secondary-energy distributions. */ these options are turned off by default, but they can */ be enabled by changing ismooth to 1. *i acer.232 common/ism/ismooth *i acer.244 c c ***smoothing of energy distributions is off by default ismooth=0 */ add additional histogram bins at low energies to neutron */ distributions to better represent the sqrt(e) dependence. */ the low-energy histogram bins are checked to see how many */ seem to follow a sqrt(e) rule, then this energy range is */ recursively subdivided into smaller bins and extended to */ lower energies. *i acer.6324 common/ism/ismooth *i acer.6696 c ***extend low bins as sqrt(e) using log energy scale if (ismooth.gt.0.and.lep.eq.1.and.zap.eq.1) then fx=.8409 ex=40 cx=a(iscr+6+ncyc)*a(iscr+7) nx=nint(a(iscr+4)) do while (n.gt.2) cxx=cx+a(iscr+7+ncyc)*(a(iscr+6+2*ncyc) & -a(iscr+6+ncyc)) if (abs(cxx/a(iscr+6+2*ncyc)**1.5 & -cx/a(iscr+6+ncyc)**1.5) & .gt.cx/a(iscr+6+ncyc)**1.5/50) exit a(iscr+7)=(a(iscr+7)*a(iscr+6+ncyc) & +a(iscr+7+ncyc)*(a(iscr+6+2*ncyc) & -a(iscr+6+ncyc)))/a(iscr+6+2*ncyc) do ix=1,nx-2*ncyc a(iscr+5+ix+ncyc)=a(iscr+5+ix+2*ncyc) enddo cx=cxx nx=nx-ncyc n=n-1 enddo write(nsyso,'('' extending as sqrt(E) below'', & 1p,e10.2,'' MeV for E='',e10.2,'' MeV'')') & a(iscr+6+ncyc)/emev,ee do while (a(iscr+6+ncyc).gt.ex) do ix=nx,1,-1 a(iscr+5+ncyc+ix)=a(iscr+5+ix) enddo a(iscr+6+ncyc)=fx*a(iscr+6+2*ncyc) val=a(iscr+7) a(iscr+7)=sqrt(fx)*val a(iscr+7+ncyc)=(1-fx*sqrt(fx))*val/(1-fx) nx=nx+ncyc n=n+1 enddo endif */ extend lowest delayed neutron bin using sqrt(e) shape *i acer.4670 common/ism/ismooth *i up63.205 c extend lowest delayed bin using sqrt(e) shape if (ismooth.gt.0.and.nint(a(iscr+7)).eq.1) then ex=40 fx=.8409 write(nsyso, & '('' extending lowest delayed bin using sqrt(E)'')') do while (a(iscr+10).gt.ex) do ix=2*mm,1,-1 a(iscr+9+ix)=a(iscr+7+ix) enddo a(iscr+10)=fx*a(iscr+12) val=a(iscr+9) a(iscr+9)=sqrt(fx)*val a(iscr+11)=(1-fx*sqrt(fx))*val/(1-fx) mm=mm+1 enddo endif */ use a finer energy grid for mf5 fission spectra above 10 mev */ when relatively coarse lin-lin steps are using for the exponential */ shape which really should be interpolated using lin-log *i acer.5949 common/ism/ismooth *i acer.6060 if (mt.eq.18.and.jnt.eq.2) then write(nsyso,'('' supplementing fission spectrum'', & '' grid above 10 MeV using exponential shape'')') ix=1 do while (ix.lt.n) jscr=iscr+4+2*m+2*ix if (a(jscr).lt.9.99e6) then ix=ix+1 else dele=a(jscr+2)-a(jscr) do ixx=n,ix+1,-1 a(iscr+5+2*m+2*ixx+8)=a(iscr+5+2*m+2*ixx) a(iscr+4+2*m+2*ixx+8)=a(iscr+4+2*m+2*ixx) enddo do ixx=1,4 a(jscr+2*ixx)=a(jscr)+ixx*dele/5 call terp1(a(jscr),a(jscr+1),a(jscr+10), & a(jscr+11),a(jscr+2*ixx),a(jscr+2*ixx+1),4) enddo n=n+4 ix=ix+5 endif enddo endif *ident up220 */ acer -- 27jun07 */ ident up70 added a total nubar plot to acer, but didn't give */ all the necessary info when nubar is defined as a polynomial. *i up70.130 xmin=e xmax=emax *d up70.134 ymax=ymax+xss(l+i)*emax**(i-1) *ident up221 */ acer --28jun07 */ all of up219 should have been turned off, but the coding to add spectra */ above 10 MeV was (i) always active, and (ii) could call terp1 */ with "y2" equal zero and interpolation code=4. Mods here include */ (i) expand the if test to add the missing "ismooth.ne.0" clause; */ (ii) check the value of dele - if it is less than 200 keV, don't do */ anything; and (iii) if "y2" is zero, temporarily reset it to a small, */ non-zero value before calling terp1. *d up219.85 if (ismooth.gt.0.and.mt.eq.18.and.jnt.eq.2) then *d up219.86,87 write(nsyso,'('' may supplement the fission '', & ''grid above 10 MeV using exponential shape '', & ''if delta-E exceeds 200 keV.'')') *d up219.95,105 if (dele.gt.2.e5) then do ixx=n,ix+1,-1 a(iscr+5+2*m+2*ixx+8)=a(iscr+5+2*m+2*ixx) a(iscr+4+2*m+2*ixx+8)=a(iscr+4+2*m+2*ixx) enddo ta11=zero if (a(jscr+11).eq.zero) then ta11=a(jscr+11) a(jscr+11)=1.e-6*a(jscr+1) endif do ixx=1,4 a(jscr+2*ixx)=a(jscr)+ixx*dele/5 call terp1(a(jscr),a(jscr+1), & a(jscr+10),a(jscr+11), & a(jscr+2*ixx),a(jscr+2*ixx+1), & 4) enddo if (ta11.ne.zero) a(jscr+11)=ta11 n=n+4 ix=ix+5 else ix=ix+1 endif *ident up222 */ viewr -- 29jun07 */ need to allow an i3 format where we currently only have i1 or i2. *d viewr.2397,2403 if ((nscale.gt.-10.and.nscale.lt.0).or.nscale.ge.10) then write(num,'(''*10#EH.8<'',i2,''#HXEX<'')') nscale lnum=17 else if (nscale.le.-10) then write(num,'(''*10#EH.8<'',i3,''#HXEX<'')') nscale lnum=18 else write(num,'(''*10#EH.8<'',i1,''#HXEX<'')') nscale lnum=16 endif *ident up223 */ reconr -- 2jul07 */ photonuclear processing revisions in up215 corrupt the dictionary */ for neutron and photon jobs (trkov). do it right here. */ first, force mt=3 (rather than mt=1) into the dictionary for the */ total xs when processing photonuclear files. The up215 if test */ could force a(j+4)=3 too often; this one is correct. *d up215.14,19 if (nint(a(imfs+i-1)).eq.3.and.mtr(imtr).eq.1 & .and.awin.eq.0) then a(j+4)=3 else a(j+4)=mtr(imtr) endif */ second, force mth=3 for total xs when processing photonuclear files */ (do this before testing for mfh=23 so that mth retains the correct */ value when processing photo-atomic files). The location of this */ test in up215 was wrong (trkov). *i reconr.4562 if (awin.eq.0) then mth=3 endif *d up215.22,24 *ident up224 */ plotr -- 3jul07 */ initialize nin2 all of the time (this variable was introduced in */ up77, but is not always initialized - not a problem if the compiler */ defaults uninitialized variables to zero). *b up77.16 nin2=0 *d up77.17 */ also initialize ee1 and ee2 before the if test at plotr.1002 */ (g95 run-time error). *i plotr.999 ee1=0 ee2=0 *d plotr.1004,1005 *ident up225 */ heatr -- 3jul07 */ up187 assumed we could get the maximum file energy from the */ third record in 1/451 if this was an endfb6 file. That's not */ always true. Therefore restructure this if test so that etop */ defaults to 20 MeV unless there is data in the file to define */ it larger. *d up187.15 if (iverf.eq.6.and.c2h.gt.etop) etop=c2h */ delete an unneeded data statement (etop is now initialized */ either in hinit or from the input data (up187), also trkov, */ lahey compiler warning). *d heatr.4110,4114 *ident up226 */ acer -- 4jul07 */ up174 is fixed as in up225 *d up174.14 if (iver.eq.6.and.a(iscr+1).gt.ehi) elim=a(iscr+1) *ident up227 */ groupr -- 4jul07 */ make same fix in upper limit for photon production from */ discrete levels that was made in up174 for acer and up187 */ for heatr, and then corrected in up225 and up226. *i groupr.247 common/maxx/emaxx *i groupr.310 if (iverf.le.4) then emaxx=15000000 else if (iverf.eq.5) then emaxx=20000000 else call contio(nendf,0,0,a(iscr),nb,nw) emaxx=20000000 if (c2h.gt.zero) emaxx=c2h endif *i groupr.7937 common/maxx/emaxx *d groupr.7947 *d groupr.7950 *i groupr.8279 etop=emaxx *ident up228 */ viewr -- 6jul07 */ initialize backgr in tagit prior to calling poly2 (not an */ issue if the compiler initializes undefined variables to zero). *i viewr.1224 backgr=zero *ident up229 */ thermr -- 9jul07 */ need more space when printing (Broeders, upfzk12). *d thermr.1614 & f8.3,'' ev.'')') tmax *d thermr.1620 & f8.3,'' ev.'')') tmax *ident up230 */ groupr -- 9jul07 */ need to define ehi to go with the already defined elo. */ ehi has previously been undefined (and likely set to zero */ by the compiler). *i groupr.4819 ehi=zero *i groupr.4892 if (c(l+1).gt.ehi) ehi=c(l+1) *i groupr.4987 if (c(l+1).gt.ehi) ehi=c(l+1) */ fix incorrect initialization. *d groupr.5067 ir=1 */ add missing save, similar to what was done in up135 for heatr. *b groupr.5589 save enow *ident up231 */ gaminr -- 9jul07 */ need to save some variables (similar to up131 in groupr). *i gaminr.866 save ng1,ig1 *ident up232 */ plotr -- 9jul07 */ make sure law is initialized (not an issue if the compiler */ presets undefined integers to zero). *i plotr.1175 law=zero *ident up233 */ errorr -- 10jul07 */ restructure this if test since nmd and/or nmt1d might only */ be defined when isd.eq.1 is true. *d errorr.1992 if (isd.eq.1)then if (nmd.ge.nmt1d) go to 390 endif *ident up234 */ acer -- 10jul07 */ need to initialize lt and lr flags to zero when dealing with */ charged particle files (not an issue if the compiler presets */ undefined integers to zero). *i acer.1751 lt=0 lr=0 */ initialize all isotropic angular distribution flag (not an */ issue if the compiler presets undefined integers to zero). *i acer.5341 iso=0 *ident up235 */ njoy -- 17jul07 */ revise if tests introduced in up180 to avoid machine */ roundoff errors (up180 sometimes makes 1.000000+n print */ as 10.000000+n) *i up180.8 onem=9.99999999d-1 *i up180.10 onem=9.99999999e-1 *d njoy.1337 if (abs(x).lt.onem) go to 140 *d up180.21,23 if (f.gt.onem.and.hx(10:11).eq.'00')write(hx,'(f9.6,a,i1)')f,s,n if (f.gt.tenth.and.f.lt.onem.and.hx(11:11).eq.'0') & write(hx,'(1pf9.6,a,i1)')f,s,n *ident up236 */ ccccr -- 17jul07 */ upgrade dldata to handle a variable number of delayed neutron */ groups, up to a maximum of ndmax. endf/b files typically have */ 6 delayed groups, modern jeff files typically have 8. also, */ warn user if too much data are found or if delayed data were */ requested but not found on the input tape. *i ccccr.132 common/delay/iso,nfam *d ccccr.208 if (lprint.eq.1.and.iso.ne.0)call pdlyxs(ndlay) *d ccccr.3049 c (there are typically nisod*ndg families, where ndg is the c number of delayed neutron groups for this isotope). *i ccccr.3067 parameter (ndmax=8) *d ccccr.3069 dimension fract(ndmax) */ read mf5, mt455 from the groupr tape to get the number of */ delayed neutron groups for this isotope. *i ccccr.3072 external contio *d ccccr.3074,3076 c c *** get the number of delayed neutron groups for this nuclide c from groupr's mf5, mt455 head record. call repoz(nin) call tpidio(nin,0,0,e(1),nb,nw) do while (mf.lt.5) call contio(nin,0,0,e(1),nb,nw) enddo if (mt.eq.455) then ndg=nint(e(3)) elseif (mt.lt.455) then do while (mf.eq.5.and.mt.lt.455) call contio(nin,0,0,e(1),nb,nw) enddo if (mf.eq.5)then ndg=nint(e(3)) else iso=0 return endif else iso=0 return endif if (ndg.eq.0) then iso=0 return elseif (ndg.gt.ndmax) then call mess ('dldata','too many delayed neutron groups', & 'dlayxs request ignored') iso=0 return endif c c *** assign storage (depends on number of delayed groups) nfam=ndg*nisod *d ccccr.3166,3168 do i=1,ndg ifam=ndg*(iso-1)+i loca=l8+ngn-ig+ngn*(ifam-1)+ndg*(iso-1) *d ccccr.3184 ifam=ndg*(iso-1)-1+l2 *d ccccr.3190 ifam=ndg*(iso-1)+i *d ccccr.3201,3202 ifam=i+ndg*(iso-1) loca=l8+ngn+ngn*(ifam-1)+ndg*(iso-1) *d ccccr.3204 locb=l8-1+ndg*ngn*iso+ndg*(iso-1)+i *ident up237 */ heatr -- 23jul07 */ include *set sw construct in subroutine hgam102 (introduced in */ up208) for correct single precision compilation with g95). *d up208.66 *if sw implicit real*8 (a-h,o-z) *endif */ define epn as the next energy in the stack. *i heatr.2808 epn=x(i) *ident up238 */ groupr -- 23jul07 */ move character definition for strng (from up157) out of the *set sw */ block (Absoft fatal error with single precision compilation) *d up157.9 *i groupr.3919 character*60 strng */ define epn as the next energy in the stack. *i groupr.5261 epn=x(i) */ include *set sw construct in subroutine gam102 (introduced in */ up212) for correct single precision compilation with g95). *d up212.34 *if sw implicit real*8 (a-h,o-z) *endif *ident up239 */ acer -- 24jul07 */ fix several locations where implicit real*8 is declared regardless */ of whether *set sw is part of the upn deck (g95). *d up69.58 *if sw implicit real*8 (a-h,o-z) *endif *d acer.18494 *if sw implicit real*8 (a-h,o-z) *endif *d acer.21212 *if sw implicit real*8 (a-h,o-z) *endif *ident up240 */ broadr -- 30jul07 */ up176 extended doppler broadening to partial charged particle */ reactions, but make sure we don't double count these cross */ sections when reconstructing the total (Daily, KAPL). If mt103 */ through mt107 are not present but the partials are they are used */ for the reconstruction. If any of mt103 through mt107 are present */ and are non-threshold cross sections they will be doppler broadened */ as always. We do not attempt to reconstruct them from the newly */ broadened partial cross sections. *i broadr.310 mt103=0 mt104=0 mt105=0 mt106=0 mt107=0 if (iverf .ge. 6) then mpmin=600 mpmax=649 mdmin=650 mdmax=699 mtmin=700 mtmax=749 m3min=750 m3max=799 m4min=800 m4max=849 else mpmin=700 mpmax=718 mdmin=720 mdmax=738 mtmin=740 mtmax=758 m3min=760 m3max=768 m4min=780 m4max=798 endif *i broadr.346 if (mth.eq.103)mt103=1 if (mth.eq.104)mt104=1 if (mth.eq.105)mt105=1 if (mth.eq.106)mt106=1 if (mth.eq.107)mt107=1 *i broadr.724 c ***Don't include partial xs if its sum is already available if (mt103.eq.1.and.mtr(i).ge.mpmin.and.mtr(i).le.mpmax) & iflag=1 if (mt104.eq.1.and.mtr(i).ge.mdmin.and.mtr(i).le.mdmax) & iflag=1 if (mt105.eq.1.and.mtr(i).ge.mtmin.and.mtr(i).le.mtmax) & iflag=1 if (mt106.eq.1.and.mtr(i).ge.m3min.and.mtr(i).le.m3max) & iflag=1 if (mt107.eq.1.and.mtr(i).ge.m4max.and.mtr(i).le.m4max) & iflag=1 *ident up241 */ thermr -- 30jul07 */ The evaluations for liquid hydrogen and deuterium are stored in */ ENDF-6 format with LASYM=1 and LAT=1. Need to make sure beta */ is scaled properly for this option combination when comparing */ against the endf file mesh (upnea015 by M.Mattes). *d thermr.1977,1978 bbm=bb if (lat.eq.1) bbm=bb*tev/tevz if (bbm.gt.beta(nbeta)) go to 170 if (bbm.lt.beta(1)) go to 170 *ident up242 */ reconr -- 31jul07 */ Expand total cross section reconstruction to include partial */ charged particle cross sections if they are present and the */ corresponding mt103,...,mt107 are not. This affects seven */ endf/b-vii nuclides (7Be,74,75As,90Y,232Th,231Pa,233Pa). *i reconr.385 common/util/npage,iverf *i reconr.388 common/recon4/mt103,mt104,mt105,mt106,mt107, & mpmin,mpmax,mdmin,mdmax,mtmin,mtmax, & m3min,m3max,m4min,m4max *i reconr.402 mt103=0 mt104=0 mt105=0 mt106=0 mt107=0 if (iverf .ge. 6) then mpmin=600 mpmax=649 mdmin=650 mdmax=699 mtmin=700 mtmax=749 m3min=750 m3max=799 m4min=800 m4max=849 else mpmin=700 mpmax=718 mdmin=720 mdmax=738 mtmin=740 mtmax=758 m3min=760 m3max=768 m4min=780 m4max=798 endif *i reconr.418 if (mti.eq.103) mt103=1 if (mti.eq.104) mt104=1 if (mti.eq.105) mt105=1 if (mti.eq.106) mt106=1 if (mti.eq.107) mt107=1 *i reconr.4118 common/recon4/mt103,mt104,mt105,mt106,mt107, & mpmin,mpmax,mdmin,mdmax,mtmin,mtmax, & m3min,m3max,m4min,m4max *d reconr.4274 if (mth.ge.151.and.mth.lt.mpmin) go to 440 if (mt103.eq.1.and.mth.ge.mpmin.and.mth.le.mpmax) go to 440 if (mt104.eq.1.and.mth.ge.mdmin.and.mth.le.mdmax) go to 440 if (mt105.eq.1.and.mth.ge.mtmin.and.mth.le.mtmax) go to 440 if (mt106.eq.1.and.mth.ge.m3min.and.mth.le.m3max) go to 440 if (mt107.eq.1.and.mth.ge.m4min.and.mth.le.m4max) go to 440 *ident up243 */ acer -- 31jul07 */ same change as made in up242 for reconr. *i acer.1283 common/ace10/mt103,mt104,mt105,mt106,mt107, & mpmin,mpmax,mdmin,mdmax,mtmin,mtmax, & m3min,m3max,m4min,m4max *i acer.1346 mt103=0 mt104=0 mt105=0 mt106=0 mt107=0 if (iverf .ge. 6) then mpmin=600 mpmax=649 mdmin=650 mdmax=699 mtmin=700 mtmax=749 m3min=750 m3max=799 m4min=800 m4max=849 else mpmin=700 mpmax=718 mdmin=720 mdmax=738 mtmin=740 mtmax=758 m3min=760 m3max=768 m4min=780 m4max=798 endif *i acer.1950 if (mt.eq.103) mt103=1 if (mt.eq.104) mt104=1 if (mt.eq.105) mt105=1 if (mt.eq.106) mt106=1 if (mt.eq.107) mt107=1 *d acer.1987 if ((mt.le.120) & .or.(mt103.eq.0.and.mt.ge.mpmin.and.mt.le.mpmax) & .or.(mt104.eq.0.and.mt.ge.mdmin.and.mt.le.mdmax) & .or.(mt105.eq.0.and.mt.ge.mtmin.and.mt.le.mtmax) & .or.(mt106.eq.0.and.mt.ge.m3min.and.mt.le.m3max) & .or.(mt107.eq.0.and.mt.ge.m4min.and.mt.le.m4max)) & then *i up63.12 common/ace10/mt103,mt104,mt105,mt106,mt107, & mpmin,mpmax,mdmin,mdmax,mtmin,mtmax, & m3min,m3max,m4min,m4max *d acer.5212 if ((mth.ge.102.and.mth.le.150) & .or.(mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax) & .or.(mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax) & .or.(mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax) & .or.(mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max) & .or.(mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max)) & then *d acer.5223 if ((mth.ge.5.and.mth.le.150) & .or.(mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax) & .or.(mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax) & .or.(mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax) & .or.(mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max) & .or.(mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max)) & then *ident up244 */ gaspr -- 1aug07 */ same change as made for acer (up243) and reconr (up242). *i gaspr.10 c * if the input pendf tape omits mt103-mt107, but does have the * c * partial charged particle cross sections they are processed and * c * will appear in the appropriate mt20x section. * *i gaspr.63 c ***also set flags for absence or presence of charged c ***particle reactions and the endf version dependent c ***partial cross sections mt ranges. *i gaspr.98 mt103=0 mt104=0 mt105=0 mt106=0 mt107=0 mt600=0 mt650=0 mt700=0 mt750=0 mt800=0 if (iverf .ge. 6) then mpmin=600 mpmax=649 mdmin=650 mdmax=699 mtmin=700 mtmax=749 m3min=750 m3max=799 m4min=800 m4max=849 else mpmin=700 mpmax=718 mdmin=720 mdmax=738 mtmin=740 mtmax=758 m3min=760 m3max=768 m4min=780 m4max=798 endif *i gaspr.101 if (mfi.eq.3.and.mti.eq.103) mt103=1 if (mfi.eq.3.and.mti.eq.104) mt104=1 if (mfi.eq.3.and.mti.eq.105) mt105=1 if (mfi.eq.3.and.mti.eq.106) mt106=1 if (mfi.eq.3.and.mti.eq.107) mt107=1 if (mfi.eq.3.and.mti.ge.mpmin.and.mti.le.mpmax) mt600=1 if (mfi.eq.3.and.mti.ge.mdmin.and.mti.le.mdmax) mt650=1 if (mfi.eq.3.and.mti.ge.mtmin.and.mti.le.mtmax) mt700=1 if (mfi.eq.3.and.mti.ge.m3min.and.mti.le.m3max) mt750=1 if (mfi.eq.3.and.mti.ge.m4min.and.mti.le.m4max) mt800=1 *d gaspr.200 c ***copy data through file 3, including any partial charged c ***particle cross sections *d gaspr.209,210 mtb=mth if (mth.gt.m4max.or.mth.eq.0) then *i gaspr.217 c c ***reposition npend to the location where gas production c ***cross sections would go. call repoz(npend) call tpidio(npend,0,0,a(1),nb,nw) call tofend(npend,0,0,a(1)) call tofend(npend,0,0,a(1)) idone=0 do while (idone.eq.0) call contio(npend,0,0,b(1),nb,nw) if (mth.gt.117.or.mfh.eq.0) then idone=1 else call tosend(npend,0,0,a(1)) endif enddo *d gaspr.225 if (mth.gt.117.and.mth.lt.mpmin) go to 245 if (mth.gt.m4max.or.mth.eq.0) go to 250 *d gaspr.286,291 if ((mth.ge.103.and.mth.le.117).or. & (mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax).or. & (mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax).or. & (mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax).or. & (mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max).or. & (mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max)) izg=1 if ((mth.eq.103).or. & (mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax))izr=izr-1001 if (mt103.eq.1.and.mth.ge.mpmin.and.mth.le.mpmax) go to 245 if ((mth.eq.104).or. & (mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax))izr=izr-1002 if (mt104.eq.1.and.mth.ge.mdmin.and.mth.le.mdmax) go to 245 if ((mth.eq.105).or. & (mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax))izr=izr-1003 if (mt105.eq.1.and.mth.ge.mtmin.and.mth.le.mtmax) go to 245 if ((mth.eq.106).or. & (mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max))izr=izr-2003 if (mt106.eq.1.and.mth.ge.m3min.and.mth.le.m3max) go to 245 if ((mth.eq.107).or. & (mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max))izr=izr-2004 if (mt107.eq.1.and.mth.ge.m4min.and.mth.le.m4max) go to 245 *d gaspr.301 *d gaspr.347 if (mth.gt.117.and.mth.lt.mpmin) go to 310 if (mth.gt.m4max.or.mth.eq.0) go to 330 *d gaspr.356 if (mt103.eq.1.and.mth.ge.mpmin.and.mth.le.mpmax) go to 310 if (mt104.eq.1.and.mth.ge.mdmin.and.mth.le.mdmax) go to 310 if (mt105.eq.1.and.mth.ge.mtmin.and.mth.le.mtmax) go to 310 if (mt106.eq.1.and.mth.ge.m3min.and.mth.le.m3max) go to 310 if (mt107.eq.1.and.mth.ge.m4min.and.mth.le.m4max) go to 310 *d gaspr.477 else if ((mth.eq.103).or. & (mt103.eq.0.and.mth.ge.mpmin.and.mth.le.mpmax)) then *d gaspr.480 else if ((mth.eq.104).or. & (mt104.eq.0.and.mth.ge.mdmin.and.mth.le.mdmax)) then *d gaspr.483 else if ((mth.eq.105).or. & (mt105.eq.0.and.mth.ge.mtmin.and.mth.le.mtmax)) then *d gaspr.486 else if ((mth.eq.106).or. & (mt106.eq.0.and.mth.ge.m3min.and.mth.le.m3max)) then *d gaspr.489 else if ((mth.eq.107).or. & (mt107.eq.0.and.mth.ge.m4min.and.mth.le.m4max)) then *ident up245 */ purr -- 6aug07 */ unresolved evalutions with narrow widely spaced resonances */ (kev dbar values) don't get sampled very well by purr, and */ the probability tables end up with total cross section bins */ with zero width around the potential scattering cross section. */ in this patch, we slightly increase the sampling density for */ cases with dbar in the kev range, and we make sure that total */ cross sections bins of the probability table are monotonically */ increasing (no zero width bins). *d purr.1782 dmin=500 *i up84.56 if (i.gt.1) then if (tval(i,itemp).le.tval(i-1,itemp)) & tval(i,itemp)=tval(i-1,itemp)+tval(i-1,itemp)/20 endif *ident up246 */ broadr -- 22aug07 */ fix typo in up240 that affects nuclides such as 10B that have */ both mt107 plus threshold mt800 and above reactions (Daily, KAPL). *d up240.56 if (mt107.eq.1.and.mtr(i).ge.m4min.and.mtr(i).le.m4max) *ident up247 */ gaspr -- 22aug07 */ revise up244 logic when repositioning an npend tape that contains data */ for multiple temperatures (Trellue, LANL). up244 coding only works */ for a single temperature npend tape. *i up244.68 if(itemp.gt.1)then do i=2,itemp call tomend(npend,0,0,a(1)) enddo endif */ fix a typo to be consistent with earlier coding, although the */ previous variable, mfh, actually works in this context. *d up244.74 if (mth.gt.117.or.mth.eq.0) then *ident up248 */ reconr -- 22aug07 */ hard to believe that an "i6" format is needed, but it is for */ jendl-3.3 239pu. *d reconr.1988,1991 & '' number of user and resonance nodes = '',i6,/ & '' points in initial unionized grid = '',i6,/ & '' points added by linearization = '',i6,19x,f8.1, & ''s'')')nodes,ngpos,ngneg,time *d reconr.4353 & '' number of points in final unionized grid = '',i6)')ngo *ident up249 */ acer -- 23aug07 */ expand from "i2" to "i3" format to handle all possible mt numbers. *d acer.6070 & 6x,''mt='',i3,'' e='',1p,e12.4,'' ep='',e12.4/ *d acer.6710 & 6x,''mt='',i3,'' e='',1p,e12.4,'' ep='',e12.4/ *d up106.15 & 6x,''mt='',i3,'' e='',1p,e12.4,'' ep='',e12.4/ *d acer.6717 & 6x,''mt='',i3,'' e='',1p,e12.4,'' ep='',e12.4/ *ident up250 */ viewr -- 23aug07 */ expand foreground color array from 8 to 9. This allows for */ a border plus up to eight curves (as needed, for example, to */ plot eight delayed neutron groups). *d viewr.221 c * 7=purple * c * 8=orange * *d viewr.3786 common/plot12/ibrgb(3,8),ifrgb(3,9),isrgb(3,40) *d viewr.3891 common/plot12/ibrgb(3,8),ifrgb(3,9),isrgb(3,40) *d viewr.4462 common/plot12/ibrgb(3,8),ifrgb(3,9),isrgb(3,40) *d viewr.4616 & 160, 32,240, ! purple & 225, 80, 20/ ! orange *ident up251 */ reconr -- 27aug07 */ need to include file 10 sections when determining how much space */ to set aside for the dictionary. Nuclides with 6 or more file 10 */ sections, such as jeff-3.1 99Tc, 103Rh and 127,129I have had bad */ dictionary data in pendf tapes produced by reconr in the past. *b reconr.419 else if (mfi.eq.10) then nxn=nxn+1 *ident up252 */ heatr -- 30aug07 */ need to shade the initial and final energies when passing through */ a discontinuity that doesn't specify histogram interpolation or */ terp1 may divide by zero. *i heatr.4863 if (elo.eq.ehi) then elo=sigfig(elo,7,-1) ehi=sigfig(ehi,7,+1) endif *ident up253 */ heatr -- 6sep07 */ in the initialization phases of disbar and hgtfle make sure enext */ is defined (and points to the maximum energy for this evaluation) */ when isotropy is assumed or specified for the angular distributions. *i heatr.1507 common/lims/ebot,etop *i heatr.1608 enext=etop *b heatr.3774 common/lims/ebot,etop *d heatr.3844,3845 if (iso.eq.1)then nle=1 enext=etop else enext=elo endif *d heatr.3920 enext=etop */ clean up an obsolete error message. Actually, current coding is */ never true for this if test, but someday it may be and then we */ should be ready to test for legal values. *d heatr.2029 if (lnd.ne.6.and.lnd.ne.8) & call error('hgtyld','illegal lnd, must be 6 or 8',' ') *ident up254 */ groupr -- 12sep07 */ remove some old coding that makes analytic fission spectra */ come out as histograms. Also correct the subroutine name */ used in an error message. *d up131.14 call error('panel','bad nq in panel',' ') *d groupr.8648 save nktot,nupm,loc *d groupr.8651,8652 *d groupr.8660,8661 *d groupr.8820 *d groupr.8827 *d groupr.8942,8947 return *ident up255 */ leapr -- 13sep07 */ several corrections and additions are needed, as noted below */ (altiparmakov, aecl). */ */ print warning to the terminal and to standard output when the user */ selects the isabt=1 option since thermr can not correctly process */ this file. *i leapr.177 external mess *i leapr.213 if (isabt.ne.0)write(nsyso,'(/ & ''*** Warning. isabt=1 pendf tapes CANNOT be processed '', & ''by the NJOY THERMR module ***'')') if (isabt.ne.0)call mess('leapr','isabt=1 pendf tapes CANNOT be', & 'processed by thermr.') */ add ilog (LLN in the endf manual) flag to the pendf tape. *i leapr.2973 if (ilog.ne.0)scr(3)=1 */ moreio coding was added to handle large alpha and beta mesh back */ in up98, but we missed one. It hasn't been needed yet, but if */ more than "npage" alpha mesh values are present and we're writing */ data for two or more temperatures it will. *i leapr.3233 ll=1 do while (nb.ne.0) ll=ll+nw call moreio(0,nout,nprnt,scr(ll),nb,nw) enddo *ident up256 */ thermr -- 13sep07 */ add long overdue coding so that thermr recognizes when S(a,b) */ data are given as ln(S(a,b)). Also test if leapr was run with */ the isabt=1 option. If so, we can't process this file. This */ is inferred in LA-12639-MS (ENDF-356), but is not well known */ nor has it been well publicized previously (altiparmakov, aecl). *i thermr.1517 c c ***lasym= 0 or 1 = traditional endf definitions. c ***lasym= 2 or 3 = traditional lasym + 2 c = leapr's isabt=1 option was used. if (lasym.gt.1) call error ('calcem','isabt=1 pendf tape found', & 'thermr cannot process this format') *i thermr.1519 ilog=l1h *d thermr.1588,1592 if (ilog.eq.0) then if (a(l).gt.sabmin) a(isab+ia-1+nalpha*(ib-1))=log(a(l)) if (a(l).le.sabmin) then if (a(l).gt.zero) itrunc=1 a(isab+ia-1+nalpha*(ib-1))=sabflg endif else a(isab+ia-1+nalpha*(ib-1))=a(l) endif *ident up257 */ groupr -- 17sep07 */ up227 fixed the upper bound for reconstructing photon yields, */ but we need to set the lower bound to the file 3 non-zero */ cross section threshold when converting from transition */ probabilities (this is similar to what we did in up186 for */ acer, and is a change that we should have made in groupr at */ that time). *i groupr.259 data ebeg/1.d-5/ *i groupr.261 data ebeg/1.e-5/ *d up227.7 common/maxx/ebeg,emaxx *d up227.19 common/maxx/ebeg,emaxx *b groupr.7931 parameter (mxnnth=350) *i groupr.7940 dimension mtth(mxnnth),eeth(mxnnth) *i groupr.7983 nnth=0 *i groupr.7988 c c ***get thresholds vs mt number if (mfh.eq.3.and.mth.ne.0) then e=0 call gety1(e,enxt,jdis,x,nin,a(iscr)) nnth=nnth+1 if (nnth.gt.mxnnth) call error('conver','nnth too large',' ') eeth(nnth)=enxt mtth(nnth)=mth call contio(0,nout,nscr,a(iscr),nb,nw) call tosend(nin,nout,nscr,a(iscr)) go to 110 endif c *d groupr.8289 a(iscr+8)=elow *d groupr.8306 a(iscr+8)=elow *b groupr.8280 elow=ebeg do i=1,nnth if (mtth(i).eq.mth) elow=eeth(i) enddo */ override cartesion interpolation for mf6/law1 distributions */ with unit base interpolation to get smoother scattering */ source functions. mcnp does this, so we will ignore the */ strict endf rule for better consistency between mg and mc. *i groupr.4880 c force unit base interpolation for smoother scattering source if (int.eq.2) int=22 *i groupr.5095 c force unit base interpolation for smoother scattering source if (int.eq.2) int=22 */ the hnab routine used in the calculation of the energy-dependent */ watt fission spectrum for very large outgoing energies gives */ answers that are too small by a factor of 2. this affects */ ENDF/B-VII U-233 above 15 MeV. *d groupr.9327 hh(n+1)=2*con*s*sgn */ correct the subroutine name passed to mess *d up16.22 call mess('f6ddx', *d up16.37 call mess('f6ddx', *d up16.55 call mess('f6ddx', */ correct the subroutine name passed to error *d groupr.8236 if (l.gt.lmax) call error('conver', */ do some minor cleaning up in anased. *d groupr.9019,9021 de=e-u *d up140.14 if (lf.ne.12) xc=de/theta *d groupr.9109 */ the shape of the fission spectrum above 10 MeV is nearly */ exponential, but the endf tabulated fission spectra for */ important isotopes like U-235 and Pu-239 specify linear */ interpolation on a fairly coarse energy grid. this patch */ forces the use of linear-E, log-probability interpolation */ above 10 MeV for tabulated fission spectra. see up219 for */ a corresponding change for mcnp data. note that this */ option in normally turned off. change ismooth to enable it. *i groupr.8639 common/mainio/nsysi,nsyso,nsyse,ntty *i groupr.8668 c change ismooth to 1 to force lin-log interpolation c of tabulated fission spectra above 10 MeV data ismooth/0/ *i groupr.8766 c change to lin-log interpolation above 10 MeV c for tabulated fission spectra with one c interpolation range if (ismooth.gt.0.and.mtd.eq.18) then brk=10000000 nr=nint(c(m1+4)) if (nr.eq.1) then if (nne.eq.0) write(nsyso, & '(/,'' forcing lin-log for mt18'', & '' above 10 MeV'')') np=nint(c(m1+5)) j=m1+6 do i=1,np if (c(j+2*i).lt.brk) ii=i enddo do i=1,2*np c(m-i+2)=c(m-i) if (i.eq.3) c(m+1)=c(m-i+2)/10 enddo c(m1+4)=2 c(m1+6)=ii c(m1+8)=np c(m1+9)=4 endif endif */ adjust mf6,law1 distributions by adding more histogram segments */ at low outgoing energies using log spacing to more closely */ approximate a sqrt(e) shape. this is an option that is normally */ turned off. change ismooth to 1 to enable it. using this option */ will give smoother flux curves in the 1 kev to 100 kev range for */ assemblies like godiva or jezebel, but the effect on criticality */ is small. *i groupr.4788 c change ismooth to 1 to enable sqrt(e) smoothing for c histogram emission spectra at low energies and for c histogram delayed neutron spectra at low energies. data ismooth/0/ *i groupr.4908 if (ismooth.gt.0) then fx=.8409 ex=40 ncyc=nint(c(ilo+3))+2 cx=c(ilo+6+ncyc)*c(ilo+7) nx=nint(c(ilo+4)) n=nint(c(ilo+5)) do while (n.gt.2) cxx=cx+c(ilo+7+ncyc)*(c(ilo+6+2*ncyc) & -c(ilo+6+ncyc)) if (abs(cxx/c(ilo+6+2*ncyc)**1.5 & -cx/c(ilo+6+ncyc)**1.5) & .gt.cx/c(ilo+6+ncyc)**1.5/50) exit c(ilo+7)=(c(ilo+7)*c(ilo+6+ncyc) & +c(ilo+7+ncyc)*(c(ilo+6+2*ncyc) & -c(ilo+6+ncyc)))/c(ilo+6+2*ncyc) do ix=1,nx-2*ncyc c(ilo+5+ix+ncyc)=c(ilo+5+ix+2*ncyc) enddo cx=cxx nx=nx-ncyc n=n-1 enddo write(nsyso,'('' extending as sqrt(E) below'', & 1p,e10.2,'' eV for E='',e10.2,'' eV'')') & c(ilo+6+ncyc),c(ilo+1) do while (c(ilo+6+ncyc).gt.ex) do ix=nx,1,-1 c(ilo+5+ncyc+ix)=c(ilo+5+ix) enddo c(ilo+6+ncyc)=fx*c(ilo+6+2*ncyc) val=c(ilo+7) c(ilo+7)=sqrt(fx)*val c(ilo+7+ncyc)=(1-fx*sqrt(fx))*val/(1-fx) nx=nx+ncyc n=n+1 c(ilo+4)=nx c(ilo+5)=n enddo l=ilo+6+nx endif */ extend lowest delayed neutron bin using sqrt(e) shape *i groupr.8720 l1=l *i groupr.8729 c extend lowest delayed bin using sqrt(e) shape if (ismooth.gt.0.and.mtd.eq.455.and. & nint(c(l1+7)).eq.1) then ex=40 fx=.8409 write(nsyso,'('' extending lowest delayed bin'', & '' using sqrt(E)'')') mm=nint(c(l1+5)) do while (c(l1+10).gt.ex) do ix=2*mm,1,-1 c(l1+9+ix)=c(l1+7+ix) enddo c(l1+10)=fx*c(l1+12) val=c(l1+9) c(l1+9)=sqrt(fx)*val c(l1+11)=(1-fx*sqrt(fx))*val/(1-fx) mm=mm+1 enddo c(l1+5)=mm c(l1+6)=mm l=l1+8+2*mm endif *i groupr.8766 c extend lowest delayed bin using sqrt(e) shape if (ismooth.gt.0.and.mtd.eq.455.and. & nint(c(m1+7)).eq.1) then ex=40 fx=.8409 write(nsyso,'('' extending lowest delayed bin'', & '' using sqrt(E)'')') mm=nint(c(m1+5)) do while (c(m1+10).gt.ex) do ix=2*mm,1,-1 c(m1+9+ix)=c(m1+7+ix) enddo c(m1+10)=fx*c(m1+12) val=c(m1+9) c(m1+9)=sqrt(fx)*val c(m1+11)=(1-fx*sqrt(fx))*val/(1-fx) mm=mm+1 enddo c(m1+5)=mm c(m1+6)=mm endif *ident errorj */ (ident up258) */ errorr -- 25sep07 */ replace with "errorj" by Go Chiba. See further comments below. *d errorr.2,errorr.4345 c subroutine errorr c ****************************************************************** c * * c * modifed errorr module based on the errorj code * c * * c * From errorr: egtflx, egtsig, grist, lumpmt, lumpxs, merge, * c * rdsig, stand * c * From errorr with modifications: * c * errorr, covcal, covout, egngpn, epanel, grpav, * c * rdgout, sigc, uniong, colaps, gridd, resprp, * c * rescon, egnwtf, wgtwtf * c * From reconr with modifications: * c * ggrmat, ggmlbw, ssmlbw, ssslbw, ggunr1 * c * From errorj: resprx, Resprx_XXX, grpav4, alsigc, egtlgc, * c * musigc, matrixin, rdlgnd, fssigc, rdchi * c * * c ****************************************************************** c * * c * Further adapted for njoy99 by Skip Kahler (9/25+/2007) * c * - include ggrmat changes specified by Go Chiba in his "Bug- * c * fix for ERRORJ-2.3" memo, dated October 3, 2007 (his ggmlbw * c * correction has already been made and noted below). * c * - change "implicit double precision" to "implicit real*8" to * c * match historical njoy coding practice. * c * - change (or add) real number exponents from "e" to "d". * c * - make sure routines duplicated from other modules contain * c * the latest updates (through njoy99.257 currently). * c * - for consistency and future maintenance, replace assignments * c * for pi and physical constants with values defined or * c * calculated from main program common blocks. * c * - eliminate the "H" edit descriptor in format statements. * c * - changed "write(6,..." to "write(*,...". * c * - fix typo, "cwave" -> "cwaven" in ggmlbw. * c * - move "mprint=0" out of the if block in errorj so that this * c * variable is always properly initialized. * c * - add "mxlru2" to ggunr1 call list for proper amu dimension * c * declaration (g95 compiler). * c * - change b(1),alp(1) to b(*),alp(*) in rdlgnd dimension * c * declaration (g95 compiler). * c * - restructure a number of multiple condition "if" tests to * c * avoid run-time (undefined variables or array bounds under/ * c * overflow) errors from code compiled without optimization. * c * - change b(10) to b(*) in musigc and fssigc. * c * - delete "return" that cannot be reached in ggunr1 (absoft * c * compiler). * c * - miscellaneous text formatting changes to make the source * c * code flow more readable. * c * * c ****************************************************************** c * * c * produce cross section covariances from error files in endf/b * c * format * c * * c * first, the union energy grid of the users group structure * c * and the endf covariance energies is determined. the array * c * of coefficients for derived cross sections is also constructed.* c * then multigroup cross sections are computed on the union * c * grid (see grpav), or they are read from a multigroup cross * c * section library and then collapsed to the union grid. the * c * methods of groupr are used for cross section averaging. endf * c * covariances and the group cross sections are then combined * c * to get the basic covariance matrices (see covcal). finally, * c * the basic matrices are combined to get covariances for * c * derived reactions, the matrices are collapsed to the user-s * c * group structure, and the results are printed and/or written * c * onto an output gendf tape for later use (see covout). * c * * c *---input specifications (free format)---------------------------* c * * c * card 1 * c * nendf unit for endf/b tape * c * npend unit for pendf tape * c * ngout unit for input group xsec (gendf) tape * c * (if zero, group xsecs will be calculated) * c * (if iread eq 2 or if mfcov eq 31 (see card 7), * c * ngout cannot be zero) * c * (if mfcov eq 35 (see card 7), * c * ngout cannot be zero) * c * (default=0) * c * nout unit for output covariance tape (default=0) * c * nin unit for input covariance tape (default=0) * c * (nin and nout must be both coded or both binary) * c * nstan unit for ratio-to-standard tape (default=0) * c * card 2 * c * matd material to be processed * c * ign neutron group option * c * (ign definition same as groupr, except ign=19, * c * which means read in an energy grid, as in ign=1, * c * and supplement this with the endf covariance grid * c * within the range of the user-specified energies) * c * (default=1) * c * iwt weight function option (default=6) * c * iprint print option (0/1=minimum/maximum) (default=1) * c * irelco covariance form (0/1=absolute/relative) (default=1) * c * (if mfcov=34, irelco must be 1) * c * card 3 (omit if ngout.ne.0) * c * mprint print option for group averaging (0=min., 1=max.) * c * tempin temperature (default=300) * c * * c *---for endf/b version 4 (iverf=4) only--------------------------* c * * c * card 4 * c * nek number of derived xsec energy ranges * c * (if zero, all xsecs are independent) * c * card 5 (omit if nek=0) * c * ek nek+1 derived xsec energy bounds * c * card 6 (omit if nek=0) * c * akxy derived cross section coefficients, one row/line * c * * c *---for endf/b version 5 or 6 (iverf=5 or 6) only----------------* c * * c * card 7 * c * iread 0/1/2=program calculated mts/input mts and eks/ * c * calculated mts plus extra mat1-mt1 pairs from input * c * (default=0) * c * mfcov endf covariance file (31, 33, 34 or 35) to be * c * processed (default=33). * c * note--contribution to group cross section * c * covariances from resonance-parameter uncertainties * c * (mf=32) is included when mfcov=33 is specified. * c * (mf=-33) high speed Calc. for test case * c * (mf=333) high speed Calc. for test case(faster) * c * irespr processing option of resonance parameter covariance * c * (mf=32) (default=1) * c * 0 = area sensitivity method * c * 1 = 1% sensitivity method * c * legord legendre order calculating covariance (default=1) * c * (if mfcov is not 34, legord is ignored) * c * ifissp processing energy range number of fission energy * c * spectrum (default=-1) * c * (if mfcov is not 35, ifissp is ignored) * c * n>0 = energy range number * c * -1 = fast neutron reactor (average energy = 2 MeV) * c * * c * following cards only if iread eq 1 * c * card 8 * c * nmt no. mts to be processed * c * nek no. derived cross section energy ranges * c * (if zero, all xsecs are independent) * c * card 8a * c * mts nmt mts * c * card 8b (omit if nek=0) * c * ek nek+1 derived cross section energy bounds * c * card 9 (omit if nek=0) * c * akxy derived cross section coefficients, one row/line * c * * c * following card only if iread eq 2 * c * card 10 * c * mat1 cross-material reaction to be added to * c * mt1 covariance reaction list. * c * repeat for all mat1-mt1 pairs desired * c * terminate with mat1=0. * c * * c * following card only if nstan ne 0 * c * card 11 * c * matb standards reaction referenced * c * mtb in matd. * c * matc standards reaction to be * c * mtc used instead. * c * repeat for all standard reactions to be redefined. * c * terminate with matb=0. * c * note. if matb(1) and mtb(1) are negative, then matc(1) and * c * mtc(1) identify a third reaction, correlated with matd thru * c * the use of the same standard. covariances of all reactions * c * in matd (which reference the standard) with the reaction * c * matc(1)-mtc(1) will be produced. the standard reaction * c * must be identified on card 10 and repeated as the negative * c * entries on card 11. the group xsec tape ngout must include * c * all covariance reactions in matd, plus matc(1)-mtc(1). * c *----------------------------------------------------------------* c * * c * card 12a (for ign eq 1 or ign eq 19) * c * ngn number of groups * c * (if negative, group bounds is decending order) * c * card 12b * c * egn ngn+1 group bounds (ev) * c * card 13a tabulated (iwt=1 only) * c * wght weight function as a tab1 record * c * card 13b analytic flux parameters (iwt=4 only) * c * eb thermal break (ev) * c * tb thermal temperature (ev) * c * ec fission break (ev) * c * tc fission temperature (ev) * c * * c *---options for input variables----------------------------------* c * * c * ign meaning * c * --- ------- * c * 1 arbitrary structure (read in) * c * 2 csewg 239-group structure * c * 3 lanl 30-group structure * c * 4 anl 27-group structure * c * 5 rrd 50-group structure * c * 6 gam-i 68-group structure * c * 7 gam-ii 100-group structure * c * 8 laser-thermos 35-group structure * c * 9 epri-cpm 69-group structure * c * 10 lanl 187-group structure * c * 11 lanl 70-group structure * c * 12 sand-ii 620-group structure * c * 13 lanl 80-group structure * c * 14 eurlib 100-group structure * c * 15 sand-iia 640-group structure * c * 16 vitamin-e 174-group structure * c * 17 vitamin-j 175-group structure * c * 18 xmas 172-group structure * c * 19 read in, supplemented with endf covariance grid* c * * c * iwt meaning * c * --- ------- * c * 1 read in smooth weight function * c * 2 constant * c * 3 1/e * c * 4 1/e + fission spectrum + thermal maxwellian * c * 5 epri-cell lwr * c * 6 (thermal) -- (1/e) -- (fission + fusion) * c * 7 same with t-dep thermal part * c * 8 thermal--1/e--fast reactor--fission + fusion * c * 9 claw weight function * c * 10 claw with t-dependent thermal part * c * 11 vitamin-e weight function (ornl-5505) * c * 12 vit-e with t-dep thermal part * c * * c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr1,nscr2,nscr3 common/mode/imode common/mainio/nsysi,nsyso,nsyse,ntty common/estore/a(8500000) common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/grpn/ign,ngn,egn(901),iprint common/ewght/iwt common/redef/nas,matb(5),mtb(5),matc(5),mtc(5) common/amnc/amassn common/amuc/amu common/hbarc/hbar common/evc/ev common/cwav/cwaven c common/eunits34/nscr4 common/irspd/eskip1,eskip2,eskip3 common/err4/legord,irespr,ifissp c character*60 strng dimension b(17) dimension z(10) c dimension iaddmt(5) data eps/1.d-9/ data small/1.d-10/ data big/1.d10/ data elo/1.d-5/ data ipr/0/ c cwaven=sqrt(2.d0*amassn*amu*ev)*1.d-12/hbar c c ***read user input and write header. nkmax=50 nmtmax=60 nenimx=1000 nidmax=30 namax=8500000 c nlmt=50 imode=-1 iread=0 mfcov=33 iwt=0 ndig=6 do i=1,namax a(i)=0 enddo nasmax=5 nas=0 call timer(time) write(nsyso,'(/, & '' errorr...produce cross section covariances'', & 26x,f8.1,''s'')') time write(nsyse,'(/,'' errorr...'',59x,f8.1,''s'')') time ngout=0 nout=0 nin=0 nstan=0 read(nsysi,*) nendf,npend,ngout,nout,nin,nstan c if(nendf.eq.999)then read(nsysi,*)nitape,notape iadd=0 1000 continue read(nsysi,*)ii if(ii.ne.0)then iadd=iadd+1 if(iadd.gt.5)then write(nsyso,*)'error in errorr999.' stop endif iaddmt(iadd)=ii goto 1000 else call covadd(iadd,iaddmt,5,nitape,notape) return endif write(nsyso,*)'error in errorr999.' stop endif c cej if(nendf.eq.nstan) & call error('errorr','nstan should be different from nendf','') c call openz(nendf,0) call openz(npend,0) call openz(ngout,0) call openz(nout,1) call openz(nin,0) call openz(nstan,0) call repoz(nendf) call tpidio(nendf,0,0,b,nb,nw) call contio(nendf,0,0,b,nb,nw) call contio(nendf,0,0,b,nb,nw) if (n1h.ne.0) then iverf=4 else if (n2h.eq.0) then iverf=5 else iverf=6 endif nmt=0 nmt1=0 ign=1 iwt=6 iprint=1 irelco=1 read(nsysi,*) matd,ign,iwt,iprint,irelco call storag(namax,nidmax,ipr,a) tempin=0 mprint=0 if (ngout.eq.0) then tempin=300 read(nsysi,*) mprint,tempin endif call reserv('eni',nenimx,ie,a) write(nsyso,'(/, & '' unit for endf/b tape ................. '',i10,/, & '' unit for pendf tape .................. '',i10,/, & '' unit for input gendf tape ............ '',i10,/, & '' unit for output covariance tape ...... '',i10,/, & '' unit for input covariance tape ....... '',i10,/, & '' unit for ratio-to-standard tape ...... '',i10)') & nendf,npend,ngout,nout,nin,nstan write(nsyso,'( & '' material to be processed ............. '',i10,/, & '' neutron group option ................. '',i10,/, & '' print option (0 min, 1 max) .......... '',i10,/, & '' rel. cov. option (0 abs, 1 rel) ...... '',i10)') & matd,ign,iprint,irelco cej write(nsyso,'( & '' group averaging weight option ........ '',i10)') & iwt if (ngout.eq.0) write(nsyso,'( & '' group av. print option (0 min, 1 max) '',i10)') & mprint c if (ngout.eq.0.and.tempin.eq.0.) write(nsyso,'( & '' temperature .......................... '',6x,''zero'')') if (ngout.eq.0.and.tempin.ne.0.) write(nsyso,'( & '' temperature .......................... '',f10.0)') tempin if (iverf.ne.4) then iread=0 mfcov=33 cej irespr=1 legord=1 ifissp=-1 read(nsysi,*)iread,mfcov,irespr,legord,ifissp c if (iread.lt.0.or.iread.gt.2) then write(strng,'(''illegal iread='',i3)') iread call error('errorr',strng,' ') endif cej if (mfcov.eq.31.and.ngout.eq.0) then write(strng,'('' when mfcov=31, you should set ngout<>0'')') call error('errorr',strng,' ') endif if (mfcov.eq.35.and.ngout.eq.0) then write(strng,'('' when mfcov=35, you should set ngout<>0'')') call error('errorr',strng,' ') endif eskip1=1.00002 eskip2=1.0003 eskip3=1.005 if(mfcov.eq.-33)then eskip1=1.0002 eskip2=1.0003 eskip3=1.005 mfcov=33 endif if(mfcov.eq.333)then eskip1=1.002 eskip2=1.003 eskip3=1.005 mfcov=33 endif c write(nsyso,'( & '' read option (0 calc, 1 read, 2 combo) '',i10,/, & '' endf covariance file to be processed . '',i10)') & iread,mfcov c write(nsyso,19) irespr,legord,ifissp c if(mfcov.ne.31.and.mfcov.ne.33.and.mfcov.ne.34.and.mfcov.ne.35) & then write(strng,'(''not coded for mfcov='',i3)') mfcov call error('errorr',strng,' ') endif write(nsyso,'(/,'' using endf-'',i1,'' format'')') iverf endif c c ***read covariance reaction types from end/b dictionary c ***and set file 32 flag nscr2=0 nwi=17 call reserv('id',nwi,iid,a) nwi=-1 call reserv('dict',nwi,idict,a) call repoz(nendf) call tpidio (nendf,0,0,a(idict),nb,nw) call findf(matd,1,451,nendf) call contio(nendf,0,0,a(idict),nb,nw) nx=nint(a(idict+5)) if (iverf.gt.4) call contio(nendf,0,0,a(idict),nb,nw) if (iverf.gt.5) call contio(nendf,0,0,a(idict),nb,nw) call hdatio(nendf,0,0,a(idict),nb,nw) if (iverf.gt.4) nx=nint(a(idict+5)) do i=1,17 a(iid-1+i)=a(i+5+idict) enddo do while (nb.ne.0) call moreio(nendf,0,0,a(idict),nb,nw) enddo ndictm=6*nx call releas('dict',ndictm,a) nw=nx call dictio(nendf,0,0,a(idict),nb,nw) nmt=0 mf32=0 nga=0 nwi=200 c if (ngout.eq.0.or.mfcov.eq.34) call reserv('ga',nwi,iga,a) c nlump=0 nwl=nlmt*2 call reserv('lump',nwl,ilump,a) do 130 ix=1,nx l=idict+6*ix-4 mf=nint(a(l)) if (mf.eq.32) mf32=1 mt=nint(a(l+1)) if (mf.ne.mfcov) go to 130 if (mt.gt.850) go to 121 c if (ngout.ne.0.and.mfcov.ne.34) go to 125 c nga=nga+1 if (nmt.gt.nmtmax) & call error('errorr','too many reaction types.',' ') a(iga+nga-1)=mt go to 125 121 if (mt.gt.870) call error('errorr','illegal mt gt 870.',' ') nlump=nlump+1 a(ilump+2*(nlump-1))=mt a(ilump+2*(nlump-1)+1)=0 125 continue if (iverf.le.4) then nmt=nmt+1 if (nmt.gt.nmtmax) & call error('errorr','too many reaction types.',' ') nmt1=nmt mats(nmt)=0 mts(nmt)=mt endif 130 continue if (ngout.eq.0) call releas('ga',nga,a) nwl=nlump*2 call releas('lump',nwl,a) call releas('dict',0,a) if (iverf.gt.4) go to 200 c c ***set up coefficients for derived cross sections. read(nsysi,*)neki if (neki.gt.nkmax) then write(strng,'(''only'',i3,'' ek energies allowed'')') nkmax call error('errorr',strng,' ') endif write(nsyso,'( & '' no. of derived xsec energy ranges .... '',i10)') neki nek=neki if (neki.eq.0) nek=1 nmt2=nmt*nmt nw=nek*nmt2 call reserv('kxy',nw,ikxy,a) if (neki.gt.0) go to 150 ek(1)=small ek(2)=big do i=1,nmt do j=1,nmt ja=ikxy+j-1+nmt*(i-1) a(ja)=0 if (i.eq.j) a(ja)=1 enddo enddo go to 305 150 nek1=nek+1 read(nsysi,*) (ek(i),i=1,neki) do i=1,nek1 ek(i)=sigfig(ek(i),ndig,0) enddo do i=1,nek do j=1,nmt nw=nmt do k=1,nw z(k)=0 enddo ja=ikxy+nmt2*(i-1)+nmt*(j-1)-1 read(nsysi,*) (z(k),k=1,nw) do k=1,nmt a(k+ja)=z(k) enddo enddo enddo go to 280 200 if (iread.eq.2) go to 245 if (iread.eq.0) go to 260 c c ***read user-supplied mts and eks nek=0 read(nsysi,*) nmt,nek if (nmt.gt.nmtmax) & call error('errorr','too many reaction types.',' ') nmt1=nmt neki=nek if (nek.eq.0) nek=1 nek1=nek+1 write(nsyso,'( & '' no. of mts to be processed ........... '',i10)') nmt write(nsyso,'( & '' no. of derived xsec energy ranges .... '',i10)') nek nmt2=nmt*nmt nw=nek*nmt2 call reserv('kxy',nw,ikxy,a) nw=nmtmax call reserv('temp',nw,itemp,a) call findex('kxy',ikxy,a) read(nsysi,*) (a(itemp+i-1),i=1,nmt) do i=1,nmt mats(i)=0 mts(i)=nint(a(i-1+itemp)) enddo ek(1)=small ek(2)=big do j=1,nmt do k=1,nmt ja=ikxy+k-1+nmt*(j-1) a(ja)=0 if (j.eq.k) a(ja)=1 enddo enddo if (neki.eq.0) go to 215 read(nsysi,*) (ek(i),i=1,nek1) do i=1,nek1 ek(i)=sigfig(ek(i),ndig,0) enddo do i=1,nek do j=1,nmt ja=ikxy-1+nmt2*(i-1)+nmt*(j-1) read(nsysi,*) (a(ja+k),k=1,nmt) enddo enddo 215 continue call releas('temp',0,a) go to 260 c c ***read additional user-supplied mat1-mt1 pairs 245 continue 255 ii1=0 read(nsysi,*) ii1,ii2 if (ii1.eq.0) go to 260 nmt1=nmt1+1 mats(nmt1)=ii1 mts(nmt1)=ii2 go to 255 c c ***read input for redefining the standard 260 if (nstan.eq.0) go to 270 265 ii1=0 read(nsysi,*) ii1,ii2,ii3,ii4 if (ii1.eq.0.) go to 270 nas=nas+1 if (nas.gt.nasmax) & call error('errorr','too many standards redefined.',' ') matb(nas)=ii1 mtb(nas)=ii2 matc(nas)=ii3 mtc(nas)=ii4 go to 265 270 continue c call gridd(neki,a) if (nlump.gt.0) call lumpmt(a) if (iread.eq.1) go to 280 nmt2=nmt1*nmt1 if (neki.eq.0) go to 305 c c ***print the akxy array 280 continue write(nsyso,'(/,'' coefficients for derived cross sections'')') call findex('kxy',ikxy,a) lim=nmt if (nmt.gt.10) lim=10 do i=1,nek write(nsyso,'(/,'' for'',1p,e12.4,'' to '',e12.4,'' ev'',/)') & ek(i),ek(i+1) write(nsyso,'(3x,''mt -'',10(4x,i3))') (mts(ii),ii=1,lim) if (nmt.gt.lim) write(nsyso,'(7x,10i7)') (mts(ii),ii=11,nmt) write(nsyso,'('' --- -'',10(4x,a3))') ('---',ii=1,lim) do j=1,nmt ja=ikxy+nmt2*(i-1)+nmt1*(j-1)-1 write(nsyso,'(2x,i3,'' -'',10f7.1,/,(5x,'' -'',10f7.1))') & mts(j),(a(ja+k),k=1,nmt) enddo enddo 305 continue c c ***compute group constants on union grid, either from c ***pointwise input (npend) or fine-group input (ngout). ntape=-10 call openz(ntape,1) call egngpn(a) if (ngout.eq.0) then call grpav(mprint,tempin,a) else call colaps(a) endif cej 320 if (mfcov.eq.34) then if (iwt.eq.1.or.iwt.eq.4.or.iwt.eq.5.or.iwt.ge.7) & call releas('wght',0,a) call grpav4(mprint,a) endif c call findex('id',iid,a) write(nsyso,'(/, & '' processing mat '',i4,/, & '' ---------------------'',/, & 1x,17a4)') matd,(a(iid-1+i),i=1,17) write(nsyse,'(/, & '' processing mat '',i4,/, & '' ---------------------'',/, & 1x,17a4)') matd,(a(iid-1+i),i=1,17) call releas('id',0,a) c c ***compute covariance matrices ek(1)=sigfig(ek(1),ndig,0) if (abs(egn(1)-elo).le.eps) egn(1)=elo call covcal(a) c c ***write output tape. call covout(a) c c ***errorr is finished. call atend(nout,0) call repoz(nout) call repoz(nin) call repoz(nendf) call repoz(ngout) call repoz(npend) call repoz(nstan) call closz(nstan) call closz(nendf) call closz(npend) call closz(ngout) call closz(nin) call closz(nout) call usag(a) call timer(time) write(nsyso,'(69x,f8.1,''s'',/,1x,77(''*''))') time return c cej 19 format(' processing option for mf=32 .......... ',i10,/, & ' legendre order for mf=34 ............. ',i10,/, & ' energy range number for mf=35 ........ ',i10) c end c subroutine covcal(a) c ****************************************************************** c calculate absolute covariances in the union-group structure. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/util/npage,iverf common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/mode/imode common/mainio/nsysi,nsyso,nsyse,ntty common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/redef/nas,matb(5),mtb(5),matc(5),mtc(5) common/ety/ety1,ety2 cej common/eunits34/nscr4 common/err4/legord,irespr,ifissp c character*60 strng dimension a(*) dimension loc(30) data locm/30/, nmax/2000/ data small/1.d-10/ zero=0 c c ***initialize nscrg=13 if (ngout.lt.0) nscrg=-nscrg nscr=11*imode call openz(nscr,1) call openz(nscrg,1) call repoz(nscr) nmts=0 za=0 nw=npage+50 call reserv('b',nw,ib,a) nwi=1000 call reserv('egt',nwi,iegt,a) mfd=1 mtd=451 c ***skip over energy group bounds on ngout call rdgout(ngout,matd,mfd,mtd,a(ib),a(iegt)) if (mtd.gt.nmax) & call error('covcal','storage exceeded in egt.',' ') call releas('egt',0,a) c ***assign storage. call reserv('flx',nunion,iflx,a) call reserv('sig',nunion,isig,a) call reserv('cov',nunion,icov,a) call reserv('sig1',nunion,isig1,a) cej call reserv('alp1',nunion,ialp1,a) call reserv('alp2',nunion,ialp2,a) c call reserv('scr2',nunion,iscr2,a) namx=-1 call reserv('scr',namx,iscr,a) call findex('b',ib,a) jc=ib call findex('un',iun,a) call findex('flx',iflx,a) call findex('sig',isig,a) call findex('cov',icov,a) call findex('sig1',isig1,a) cej call findex('alp1',ialp1,a) call findex('alp2',ialp2,a) c if (nlump.gt.0) call findex('lump',ilump,a) if (nlump.gt.0) call findex('lmt',ilmt,a) mfd=3 mtd=-1 c ***store flux array for later use call rdgout(ngout,matd,mfd,mtd,a(ib),a(iflx)) nsc=0 call rdsig(matd,0,a(ib),a(iscr)) c c ***if the total cross section is absent, estimate the c ***fine-group fluxes in the sub-threshold energy region c ***by assuming dn/de is constant if (mtd.ne.-2) go to 130 dne=small do is=1,nunion isr=nunion+1-is flux=a(iflx+isr-1) de=a(iun+isr)-a(iun+isr-1) if (flux.ne.0.and.de.ne.0) then dne=flux/de else a(iflx-1+isr)=dne*de endif enddo mtd=-1 130 continue kmtb=0 c c ***loop over reactions in mfcov call findf(matd,mfcov,0,nendf) 140 call contio(nendf,0,0,a(iscr),nb,nw) if (mat.lt.1) go to 700 if (mat.ne.matd) go to 700 if (mt.eq.0) go to 140 if (mf.lt.mfcov) go to 140 if (mf.gt.mfcov) go to 700 c ***ignore components of a lumped reaction cej if (mfcov.eq.34) then nl=1 elseif (mfcov.eq.35) then nl=n1h elseif (iverf.eq.4) then nl=l2h elseif (iverf.gt.4) then nl=n2h endif c if (nl.eq.0) go to 140 if (iread.ne.1) go to 170 do 150 i=1,nmt if (mt.eq.mts(i)) go to 170 150 continue call tosend(nendf,0,0,a(iscr)) go to 140 170 if (za.eq.zero) then za=c1h awr=c2h endif nmts=nmts+1 if (mts(nmts).ne.mt) & call error('covcal', & 'mfcov mt found not equal to input mt.',' ') cej if (mfcov.eq.34) then call contio(nendf,0,0,a(iscr),nb,nw) mat2=l1h mt2=l2h nlg1=min(n1h,legord) nlg2=min(n2h,legord) nl=nlg1*(nlg2+1)/2 a(jc)=za a(jc+1)=awr a(jc+2)=nlg1 a(jc+3)=nlg2 a(jc+4)=nl a(jc+5)=nunion nl=n1h*(n2h+1)/2 else a(jc)=za a(jc+1)=awr a(jc+2)=0 a(jc+3)=nl a(jc+4)=0 a(jc+5)=nunion endif c call contio(0,0,nscr,a(jc),nb,nw) mtl=mt if (mt.gt.850) go to 190 c ***find sigma for this mt on ngout cej if (mfcov.eq.35) then call rdchi(mat,a(ib),a(isig)) else call rdsig(mat,mt,a(ib),a(isig)) endif c go to 200 190 call lumpxs(mtl,mtl,a) c c ***loop over different covariance matrices for this reaction 200 do 650 il=1,nl cej if (mfcov.eq.35) then mat1=0 mt1=mt nc=0 ni=1 go to 205 else call contio(nendf,0,0,a(iscr),nb,nw) endif if (mfcov.eq.34.and.mt.eq.0) go to 660 if (mfcov.eq.34) then mat1=mat2 mt1=mt2 ld=l1h ld1=l2h else mat1=l1h mt1=l2h endif c if (mt1.eq.0) call error('covcal','illegal mt1=0.',' ') nc=n1h ni=n2h cej 205 continue if (ni.gt.locm) & call error('covcal','storage exceeded in loc.',' ') iok=1 do 210 i=1,nmt1 kmt1=i if (mt1.eq.mts(i).and.mat1.eq.mats(i)) go to 220 210 continue c ***covariance matrix for mat1-mt1 is present in mfcov, but is c ***not wanted by user. flag this by setting iok=0, and later c ***write a null matrix on the output file. iok=0 c c ***if necessary, redefine mat1 and mt1 220 if (nas.eq.0) go to 230 if (mat1.ne.-matb(1).or.mt1.ne.-mtb(1)) go to 230 if (iok.eq.0) then write(strng, & '(''must request mat1='',i3,'' and mt1='',i3)') mat1,mt1 call error('covcal',strng,'on card 10.') endif mat1=matc(1) mt1=mtc(1) kmtb=kmt1 c c ***read in all sub-subsections for this matrix. 230 li=0 l=1 if (nc.eq.0) go to 280 lty=0 do ic=1,nc if (iverf.gt.4) call contio(nendf,0,0,a(iscr+l-1),nb,nw) if (iverf.gt.4) lty=l2h call listio(nendf,0,0,a(iscr+l-1),nb,nw) do while (nb.ne.0) call moreio(nendf,0,0,a(iscr+l-1),nb,nw) enddo if (iok.ne.0) then cej if (mfcov.eq.34) then if (ld.gt.legord.or.ld1.gt.legord) goto 270 endif if (lty.gt.0.and.lty.lt.4) call stand(li,l,loc,lty,a) endif cej 270 continue enddo 280 if (ni.eq.0.and.li.eq.0) go to 600 if (ni.gt.0) go to 285 ni=li go to 320 285 ltyi=0 ni=ni+li 290 li=li+1 loc(li)=iscr+l-1 call listio(nendf,0,0,a(iscr+l-1),nb,nw) np=n1h if (l2h.eq.6) a(iscr+l+1)=(n1h-1)/n2h a(iscr+l+3)=ltyi l=l+nw do while (nb.ne.0) if (l.gt.namx) call error('covcal', & 'storage exceeded in a.',' ') call moreio(nendf,0,0,a(iscr+l-1),nb,nw) l=l+nw enddo locli=loc(li)+5 do i=1,np a(i+locli)=sigfig(a(i+locli),ndig,0) enddo if (li.lt.ni) go to 290 320 if (iok.eq.0) go to 600 cej if (mfcov.eq.34) then if (ld.gt.legord.or.ld1.gt.legord) go to 650 endif c c ***retrieve sigma for mt1, either from ngout or a(isig). if (kmt1.ne.nmts) then if (mt1.lt.851) call rdsig(mat1,mt1,a(ib),a(isig1)) if (mt1.gt.850) call lumpxs(mt1,mtl,a) else do jg=1,nunion a(jg-1+isig1)=a(jg-1+isig) enddo endif cej if (mfcov.eq.34) then call rdlgnd(nscr4,matd,mt,ld,a(ib),a(ialp1)) call rdlgnd(nscr4,matd,mt1,ld1,a(ib),a(ialp2)) endif c c ***generate covariance matrix using specified laws. do 570 jg=1,nunion eg=a(iun+jg-1) do 520 jh=1,nunion eh=a(iun+jh-1) a(icov+jh-1)=0. do 510 i=1,ni loci=loc(i) lt=nint(a(loci+2)) lb=nint(a(loci+3)) ltyi=nint(a(loci+4)) np=nint(a(loci+5)) cej if (mfcov.eq.34.and. & (lb.lt.0.or.lb.eq.3.or.lb.eq.4.or.lb.eq.7.or. & lb.gt.8)) then write(strng,'(''unpermitted for lb='',i2)') lb call error('covcal',strng,'in mf=34.') elseif (mfcov.eq.35.and.lb.ne.7) then write(strng,'("unpermitted for lb=",i2)') lb call error('covcal',strng,'in mf=35.') endif c if (ltyi.eq.0) go to 345 if (ltyi.lt.1.or.ltyi.gt.3.or. & a(loci).le.0..or.a(loci+1).le.a(loci)) & call error('covcal','data in a(loci) is illegal.', & ' ') if (ltyi.eq.3) go to 340 c ***for lty = 1 and 2, apply energy window to mt groups if (eg.lt.a(loci).or.eg.ge.a(loci+1)) go to 510 if (ltyi.eq.2) go to 345 c ***for lty = 1 and 3, apply energy window to mt1 groups 340 if (eh.lt.a(loci).or.eh.ge.a(loci+1)) go to 510 go to 346 c ***if necessary, apply ety energy window to mt1 groups 345 if (nas.eq.0) go to 346 if (matb(1).ge.0) go to 346 if (mat1.ne.matc(1).or.mt1.ne.mtc(1)) go to 346 if (eh.lt.ety1.or.eh.ge.ety2) go to 510 346 if (lb.eq.7.or.lb.gt.8) then if (mfcov.eq.35.and.lb.eq.7) go to 347 write(strng,'(''not coded for lb='',i2)') lb call error('covcal',strng,' ') endif if (lb.lt.3.and.lt.gt.0) then write(strng,'(''lb='',i2,'' when lt='',i2)') lb,lt call error('covcal',strng,' ') endif 347 continue locip4=loci+4 locip6=loci+6 nk1=np-1 if (lb.ne.8) go to 880 c c ***separate treatment for lb=8 if (jh.ne.jg) go to 510 k=0 860 k=k+1 k2=k*2 if (eg.ge.a(locip4+k2).and.eg.lt.a(locip6+k2)) & go to 870 if (k.lt.nk1) go to 860 go to 510 c ***assume flux is constant within a union group 870 xcv=(a(locip6+k2)-a(locip4+k2))/ & (a(iun+jg)-a(iun+jg-1)) a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*xcv go to 510 cej 880 if (lb.ne.7) go to 800 c c ***separate treatment for lb=7 (mf=35) k=0 890 k=k+1 if (eg.ge.a(locip6+k-1).and.eg.lt.a(locip6+k)) & go to 900 if (k.lt.nk1) go to 890 go to 510 900 l=0 910 l=l+1 if (eh.ge.a(locip6+l-1).and.eh.lt.a(locip6+l)) & go to 920 if (l.lt.nk1) go to 910 go to 510 920 if (l.ge.k) then ifloc=locip6+nk1*np/2-(np-k+1)*(np-k)/2+l-k else ifloc=locip6+nk1*np/2-(np-l+1)*(np-l)/2+k-l endif a(icov+jh-1)=a(icov+jh-1)+a(ifloc+np) go to 510 800 if (lb.ne.6) go to 850 c c ***separate treatment for lb=6 k=0 810 k=k+1 if (eg.ge.a(locip6+k-1).and.eg.lt.a(locip6+k)) & go to 820 if (k.lt.nk1) go to 810 go to 510 820 locnec=locip6+np nl1=lt-1 l=0 830 l=l+1 if (eh.ge.a(locnec+l-1).and.eh.lt.a(locnec+l)) & go to 840 if (l.lt.nl1) go to 830 go to 510 840 ifloc=locnec+lt+(k-1)*nl1+l-1 cej if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(ifloc)*a(ialp1+jg-1)* & a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(ifloc)*a(isig+jg-1)* & a(isig1+jh-1) endif c go to 510 850 if (lb.ne.5) go to 410 c c ***separate treatment for lb=5. k=0 350 k=k+1 if (eg.ge.a(locip6+k-1).and.eg.lt.a(locip6+k)) & go to 360 if (k.lt.nk1) go to 350 go to 510 360 l=0 370 l=l+1 if (eh.ge.a(locip6+l-1).and.eh.lt.a(locip6+l)) & go to 380 if (l.lt.nk1) go to 370 go to 510 380 if (lt.eq.1) go to 390 ifloc=locip6+(k-1)*nk1+l-1 go to 400 390 ifloc=locip6+nk1*np/2-(np-l+1)*(np-l)/2+k-l if(l.ge.k)ifloc=locip6+nk1*np/2-(np-k+1)*(np-k)/2+l-k cej 400 if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(ifloc+np)*a(ialp1+jg-1) & *a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(ifloc+np)*a(isig+jg-1) & *a(isig1+jh-1) endif c go to 510 c c ***integrated treatment for lb=0 thru lb=4. 410 continue nlt=lt nk=np-nlt nk1=nk-1 nlt1=nlt-1 k=0 420 k=k+1 k2=k*2 if (eg.lt.a(locip4+k2).or.eg.ge.a(locip6+k2)) & go to 430 if (lb.eq.2.or.lb.eq.3) go to 440 if (eh.ge.a(locip4+k2).and.eh.lt.a(locip6+k2)) & go to 490 go to 510 430 if (k.lt.nk1) go to 420 go to 510 440 if (lb.gt.2) go to 450 locl=loci lend=nk1 go to 460 450 locl=loci+nk*2 lend=nlt1 460 loclp4=locl+4 loclp6=locl+6 l=0 470 l=l+1 l2=l*2 if (eh.ge.a(loclp4+l2).and.eh.lt.a(loclp6+l2)) & go to 480 if (l.lt.lend) go to 470 go to 510 480 if (lb.ne.4) go to 486 m=0 482 m=m+1 m2=m*2 if (eg.ge.a(loclp4+m2).and.eh.lt.a(loclp6+m2)) & go to 484 if (m.lt.lend) go to 482 go to 510 cej 484 if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(locl+5+m2) & *a(locl+5+l2)*a(ialp1+jg-1)*a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(locl+5+m2) & *a(locl+5+l2)*a(isig+jg-1)*a(isig1+jh-1) endif c go to 510 cej 486 if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(locl+5+l2) & *a(ialp1+jg-1)*a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(locl+5+l2) & *a(isig+jg-1)*a(isig1+jh-1) endif c go to 510 490 if (lb.eq.4) go to 450 if (lb.eq.0) go to 500 cej if (mfcov.eq.34) then a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)* & a(ialp1+jg-1)*a(ialp2+jh-1) else a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2)*a(isig+jg-1) & *a(isig1+jh-1) endif c go to 510 500 a(icov+jh-1)=a(icov+jh-1)+a(loci+5+k2) 510 continue 520 continue c c ***write one row of the covariance matrix on scratch tape. jgend=0 do ih=1,nunion if (a(icov+ih-1).ne.zero) jgend=ih enddo if (jgend.gt.0) go to 540 if (jg.lt.nunion) go to 570 jgend=1 540 mf=mfcov mat=matd mt=mts(nmts) cej if (mfcov.eq.34) then a(jc)=ld a(jc+1)=ld1 else a(jc)=0 a(jc+1)=0 endif c a(jc+2)=mat1 a(jc+3)=mt1 a(jc+4)=jgend a(jc+5)=jg ibase=6 ic=ibase do ij=1,jgend ic=ic+1 cej if (mfcov.eq.34) then a(jc+ic-1)=a(icov+ij-1)*(a(isig+jg-1)*a(iflx+jg-1)) & *(a(isig1+ij-1)*a(iflx+ij-1)) else a(jc+ic-1)=a(icov+ij-1)*a(iflx+jg-1)*a(iflx+ij-1) endif c if ((ic-ibase).ge.npage.or.ij.eq.jgend) then if (ibase.ne.0) then call listio(0,0,nscr,a(jc),nb,ic) ibase=0 ic=0 else call moreio(0,0,nscr,a(jc),nb,ic) ic=0 endif endif enddo 570 continue go to 650 c c ***write a null covariance matrix on scratch tape. 600 mt=mts(nmts) mat=matd mf=mfcov a(jc)=0 a(jc+1)=0 a(jc+2)=mat1 a(jc+3)=mt1 a(jc+4)=1 a(jc+5)=nunion a(jc+6)=0 nw=7 call listio(0,0,nscr,a(jc),nb,nw) c c ***close loop over subsections of mfcov 650 continue cej 660 continue call asend(0,nscr) c c ***close loop over sections of mfcov go to 140 700 continue c ***if necessary, redefine one mats(i)-mts(i) pair if (kmtb.gt.0) then mats(kmtb)=matc(1) mts(kmtb)=mtc(1) endif c c ***covcal is finished call afend(0,nscr) call amend(0,nscr) call atend(0,nscr) call timer(time) write(nsyso,'(/, & '' covariances calculated for '',i2,'' reactions and '', & i3,'' groups'',14x,f8.1,''s'')') nmts,nunion,time write(nsyse,'(/, & '' covariances calculated for '',i2,'' reactions and '', & i3,'' groups'',14x,f8.1,''s'')') nmts,nunion,time call releas('sig1',-1,a) return end c subroutine covout(a) c ****************************************************************** c compute output covariances for all requested reactions (whether c evaluated or derived) in the user-specified group structure. c output covariances are listed and/or written to a gendf tape. c c input union-group absolute covariances are read from unit nscr c (see subroutine covcal). any non-zero input covariances for c derived cross sections are ignored. coefficients relating c derived and evaluated data reside in core at location a(ikxy). c fine-group energy bounds (iun), fluxes (iflx), and cross sections c (isig) also reside in core. except for the trivial derivation case c where both reactions ix and ixp are evaluated (isd=1), the entire c nscr tape is read and a contribution to the output covariance is c computed for each input reaction-pair. c c ix,ixp = reaction indices (see array mts) of output reaction- c pair (max. values = nmt,nmts) c ig,igp = group indices of output reaction-pair (max. value = c ngn) c iy,iyp = reaction indices of current input reaction-pair (max. c values = nmt,nmts) c jg,jgp = group indices of current input reaction-pair (max. c value = nunion) c c ***************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/mode/imode common/mainio/nsysi,nsyso,nsyse,ntty common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/grpn/ign,ngn,egn(901),iprint common/ewght/iwt cej common/err3/ifresr,ifunrs common/err4/legord,irespr,ifissp c dimension a(*) character strng*60 data eps/1.d-20/ data zero/0.d0/ c c ***allocate storage. nmts=nmt1 nmt2=nmts*nmts c ***foru-233 endf-7 nwds=8000000 nngn=ngn*(ngn+1)/2 ngn2=ngn*ngn c call reserv('scr',nwds,iscr,a) call reserv('cff',nngn,icff,a) call reserv('cfg',ngn2,icfg,a) call reserv('cgg',nngn,icgg,a) cej call reserv('cee',nngn,icee,a) call reserv('cef',ngn2,icef,a) call reserv('ceg',ngn2,iceg,a) call reserv('ctt',nngn,ictt,a) call reserv('ufg',ngn2,iufg,a) call reserv('uef',ngn2,iufg,a) call reserv('ueg',ngn2,iufg,a) call reserv('uff',nngn,iuff,a) call reserv('ugg',nngn,iugg,a) call reserv('uee',nngn,iuee,a) call reserv('utt',nngn,iutt,a) c call reserv('cflx',ngn*2,icflx,a) call reserv('sg',nunion,isg,a) cej if (mfcov.eq.34) then call reserv('xmu',ngn,ixmu,a) endif if (nlump.gt.0) then call reserv('lmt1',nmtmax,ilmt1,a) call reserv('lmt2',nmtmax,ilmt2,a) endif call reserv('alp',nunion,ialp,a) c nsumx=-1 call reserv('sum',nsumx,isum,a) cej if (nsumx.lt.max(ngn*nmt1,ngn*2)) & call error('covout','storage exceeded in sum.',' ') call findex('un',iun,a) call findex('flx',iflx,a) call findex('scr',iscr,a) call findex('sum',isum,a) call findex('cflx',icflx,a) call findex('sig',isig,a) do i=1,nsumx a(i-1+isum)=0 enddo cej if (nlump.gt.0) then call findex('lump',ilump,a) call findex('lmt',ilmt,a) call findex('lmt1',ilmt1,a) call findex('lmt2',ilmt2,a) do i=1,nmtmax a(ilmt1+i-1)=0 a(ilmt2+i-1)=0 enddo k=0 do i=1,nlump mtl=nint(a(ilump+2*(i-1))) n=nint(a(ilump+2*(i-1)+1)) loc=ilmt+nlmt*(i-1)-1 do j=1,n k=k+1 mtd=nint(a(loc+j)) a(ilmt1+k-1)=mtd a(ilmt2+k-1)=mtl enddo enddo lmtold=nint(a(ilmt1)) nmtold=0 a(ilmt1+k)=1000. else lmtold=1000 endif c c c ***position new gout tape (if any) for output. call repoz(nscr) if (nout.eq.0) go to 120 call repoz(nout) call repoz(ngout) nsh=0 call repoz(nin) ntape=nin if (nin.eq.0) ntape=ngout c ***write a tape id on nout call tpidio(ntape,0,0,a(iscr),nb,nw) mat=1 mf=0 mt=0 call tpidio(0,nout,0,a(iscr),nb,nw) if (nin.eq.0) go to 120 c ***copy input covariance tape to nout call contio(nin,nout,0,a(iscr),nb,nw) 110 call tomend(nin,nout,0,a(iscr)) call contio(nin,0,0,a(iscr),nb,nw) if (mat.eq.-1) go to 120 call contio(0,nout,0,a(iscr),nb,nw) go to 110 c c ***compute coarse-group cross sections. cej 120 ngnp1=ngn+1 if (mfcov.eq.31.or.mfcov.eq.33) then call sigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx),a(isig)) if (irespr.eq.0) then call resprp(nwds,a) elseif (irespr.eq.1) then call resprx(nwds,a) endif elseif (mfcov.eq.34) then call musigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx), & a(isig),a(ialp)) call findex('xmu',ixmu,a) do ijk = 1 , ngn a(ixmu+ijk-1) = a(isum+ijk-1) enddo elseif (mfcov.eq.35) then call fssigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx), & a(isig)) endif if (iwt.eq.1.or.iwt.eq.4.or.iwt.eq.5.or.iwt.ge.7) & call releas('wght',0,a) c nwds=2*npage+50 if (nwds.lt.ngn+6) nwds=ngn+6 call releas('scr',nwds,a) c ***pack storage npack=-1 call reserv('pack',npack,ipack,a) call releas('pack',0,a) nsumx=nsumx+npack call findex('sum',isum,a) call findex('cflx',icflx,a) call findex('scr',iscr,a) call findex('un',iun,a) call findex('flx',iflx,a) call findex('sig',isig,a) call findex('kxy',ikxy,a) call findex('cov',icov,a) cej if (nlump.gt.0) then call findex('lmt1',ilmt1,a) call findex('lmt2',ilmt2,a) endif if (mf32.ne.0.and.mfcov.eq.33) then call findex('cff',icff,a) call findex('cfg',icfg,a) call findex('cgg',icgg,a) call findex('cee',icee,a) call findex('cef',icef,a) call findex('ceg',iceg,a) call findex('ctt',ictt,a) call findex('uff',iuff,a) call findex('ufg',iufg,a) call findex('ugg',iugg,a) call findex('uee',iuee,a) call findex('uef',iuef,a) call findex('ueg',iueg,a) call findex('utt',iutt,a) endif call findex('alp',ialp,a) c isuma=isum cej if (irelco.eq.1) then if (mfcov.eq.34) then isuma=isum+ngn*2 nsumx=nsumx-ngn*2 else isuma=isum+ngn*nmts nsumx=nsumx-ngn*nmts endif endif c c ***determine whether all coarse groups will fit in core irange=ngn if ((ngn*ngn).gt.nsumx) irange=nsumx/ngn c c ***make a second copy of the fine-group covariance scratch tape nscr2=12*imode call openz(nscr2,1) call repoz(nscr) call repoz(nscr2) nsc=0 call totend(nscr,0,nscr2,a(iscr)) call repoz(nscr) call repoz(nscr2) c c ***loop over all reactions c ***if full matrix will not fit in core, c ***process by ranges of first group index. do 170 ix=1,nmt iabort=0 cej mtd=mts(ix) c c ***write the head record for this section on nout mat=matd mf=mfcov if (mf.eq.31) mf=33 cej if (nlump.gt.0.and.lmtold.lt.mts(ix)) then 175 mt=lmtold a(iscr)=za a(iscr+1)=awr a(iscr+2)=0. a(iscr+3)=a(ilmt2+nmtold) a(iscr+4)=0. a(iscr+5)=0. call contio(0,nout,0,a(iscr),nb,nw) call asend(nout,0) nmtold=nmtold+1 lmtold=nint(a(ilmt1+nmtold)) if (lmtold.lt.mts(ix)) go to 175 endif c mt=mts(ix) a(iscr)=za a(iscr+1)=awr a(iscr+2)=0 a(iscr+3)=0 a(iscr+4)=0 a(iscr+5)=nmts-ix+1 cej if (mfcov.eq.34) then mt=251 a(iscr+3)=irelco a(iscr+4)=legord a(iscr+5)=legord endif c call contio(0,nout,0,a(iscr),nb,nw) do 180 ixp=ix,nmts izero=0 igmin=1 igmax=irange c c ***check for the trivial derivation case where both ix and ixp c ***are directly evaluated. if it is, set isd=1. isd=0 if (iabort.eq.1) go to 185 if (irange.ne.ngn) go to 185 do 182 k=1,nek if (a(ikxy+(k-1)*nmt2+nmts*(ix-1)+ix-1).eq.0.) & go to 185 if (a(ikxy+(k-1)*nmt2+nmts*(ixp-1)+ixp-1).eq.0.) & go to 185 182 continue isd=1 185 continue nscr=(11+isd)*imode if (isd.ne.1) call repoz(nscr) do i=1,nsumx a(i-1+isuma)=0 enddo c c ***accumulate contributions to this matrix c ***and this range of coarse groups c ***from all matrices and fine groups on tape. 200 continue if (isd.eq.1) then if (ix.ne.ixp) go to 210 endif call contio(nscr,0,0,a(iscr),nb,nw) if (mf.eq.0) go to 390 if (mt.eq.0) go to 200 cej if (mfcov.eq.34) then nlg1=l1h nlg2=l2h nmt1h=n1h else nmt1h=l2h endif c if (isd.ne.1) go to 205 cej nmt1d=nmt1h nmd=0 if (mt.eq.mts(ix)) go to 205 c ***skip empty covariance matrices for the derived mts call tosend(nscr,0,0,a(iscr)) go to 200 205 continue mt1lst=1000 mt1old=mt1lst nm=0 cej if (mfcov.eq.34) then ldlst=-1 ldold=-1 endif c 210 continue if (isd.eq.1) then if (nmd.ge.nmt1d) go to 390 endif 220 call listio(nscr,0,0,a(iscr),nb,nwds) cej if (mfcov.eq.35) then if (ifissp-1.ne.nm) then jg=n2h go to 380 endif endif c mat1=l1h mt1=l2h mta=mt1+1000*mat1 cej if (mfcov.eq.34) then if (mt.eq.0) go to 180 ld=nint(c1h) ld1=nint(c2h) ld0=ld*100+ld1 if (ld0.ne.ldlst) k=1 if (isd.ne.1) go to 225 if (ld0.ne.ldlst) nmd=nmd+1 if (mt1.eq.mts(ixp).and.mat1.eq.mats(ixp)) go to 225 write(strng,'(''ld='',i3,'' ld1='',i3,'' mt1='',i3)') & ld,ld1,mt1 call error('covout','illegal condition for sad.',strng) endif c if (mta.ne.mt1lst) k=1 if (isd.ne.1) go to 225 if (mta.ne.mt1lst) nmd=nmd+1 if (mt1.eq.mts(ixp).and.mat1.eq.mats(ixp)) go to 225 c ***skip empty covariance matrices for the derived and c ***non-requested mt1-s if (nmd.lt.nmt1d) go to 220 c c ***desired mt1 missing. write empty matrix and abort c ***speed-up logic for this mt. iabort=1 go to 390 225 continue cej if (mfcov.eq.34) then if (ld0.ne.ldlst) nm=nm+1 ldlst=ld0 elseif (mfcov.ne.35) then if (mta.ne.mt1lst) nm=nm+1 endif c mt1lst=mta nw=n1h jg=n2h if (nw.eq.1.and.a(iscr+6).eq.0.) go to 380 c ***index first coarse group egtjg=a(iun+jg-1) do 230 i=1,ngn ig=i if (egtjg.ge.egn(i).and.egtjg.lt.egn(i+1)) go to 240 230 continue c ***read in rest of data for this group 240 ibase=6 ia=0 do i=1,nw ia=ia+1 a(icov+i-1)=a(iscr+ibase+ia-1) if (nb.gt.0.and.ibase+ia.ge.nwds) then call moreio(nscr,0,0,a(iscr),nb,nwds) ibase=0 ia=0 endif enddo if (egtjg.ge.egn(ngn+1)) go to 380 c ***index reactions if (mfcov.eq.34) then if (ld0.eq.ldold) go to 280 else if (mta.eq.mt1old) go to 280 endif iy=0 do i=1,nmt if (mt.eq.mts(i)) iy=i enddo iyp=0 do i=1,nmts if (mt1.eq.mts(i).and.mat1.eq.mats(i)) iyp=i enddo if (iy.eq.0.or.iyp.eq.0) & call error('covout', & 'unable to find iy or iyp from mts array.',' ') mt1old=mta cej if (mfcov.eq.34) ldold=ld0 c ***index derived energy range for jg 280 if (egtjg.ge.ek(k).and.egtjg.lt.ek(k+1)) go to 300 if (k.eq.nek) go to 380 k=k+1 go to 280 300 igp=1 kp=1 do 310 jgp=1,nw if (a(icov+jgp-1).eq.0.) go to 310 egtjgp=a(iun+jgp-1) c ***index derived energy range for jgp 320 if (egtjgp.ge.ek(kp).and.egtjgp.lt.ek(kp+1)) go to 330 if (kp.eq.nek) go to 310 kp=kp+1 go to 320 c ***index second coarse group 330 if (egtjgp.ge.egn(igp).and.egtjgp.lt.egn(igp+1)) & go to 350 if (igp.eq.ngn) go to 310 igp=igp+1 go to 330 c ***add this contribution 350 if (iyp.ne.iy) go to 360 if (ig.lt.igmin.or.ig.gt.igmax) go to 310 ipos=ngn*(ig-igmin)+igp a(isuma+ipos-1)=a(isuma+ipos-1)+ & a(ikxy+nmt2*(k-1)+nmts*(ix-1)+iy-1)* & a(ikxy+nmt2*(kp-1)+nmts*(ixp-1)+iyp-1)* & a(icov+jgp-1) if (a(isuma+ipos-1).ne.0.) izero=1 go to 310 360 if (ig.lt.igmin.or.ig.gt.igmax) go to 370 ipos=ngn*(ig-igmin)+igp a(isuma+ipos-1)=a(isuma+ipos-1)+ & a(ikxy+nmt2*(k-1)+nmts*(ix-1)+iy-1)* & a(ikxy+nmt2*(kp-1)+nmts*(ixp-1)+iyp-1)* & a(icov+jgp-1) if (a(isuma+ipos-1).ne.0.) izero=1 370 if (igp.lt.igmin.or.igp.gt.igmax) go to 310 ipos=ngn*(igp-igmin)+ig a(isuma+ipos-1)=a(isuma+ipos-1)+ & a(ikxy+nmt2*(k-1)+nmts*(ix-1)+iyp-1)* & a(ikxy+nmt2*(kp-1)+nmts*(ixp-1)+iy-1)* & a(icov+jgp-1) if (a(isuma+ipos-1).ne.0.) izero=1 310 continue c ***close loops over groups and covariance matrices. 380 if (jg.lt.nunion) go to 220 cej if (mfcov.eq.35) then nm=nm+1 if (nm.eq.ifissp) go to 390 go to 383 endif c if (isd.ne.1) go to 385 if (izero.eq.0) go to 390 if (ix.ne.iy.or.ixp.ne.iyp) call error('covout', & 'unexpectedly, ix ne iy or ixp ne iyp.',' ') c ***in the trivial derivation case, terminate loops over mt and mt1 cej 383 if (nmt1h.gt.1.and.nm.lt.nmt1h) go to 220 go to 390 385 continue cej if (mfcov.eq.34) call error('covout','please check isd=1', & ' ') if (nm.lt.nmt1h) go to 220 go to 200 390 continue cej if (mfcov.eq.34.or.mfcov.eq.35) go to 395 c c ***add contribution from resonance-parameter uncertainty call rescon(ix,ixp,igmin,igmax,isuma,izero,a) cej 395 continue c c ***write out covariance matrix elements for this c ***range of coarse groups. mat=matd mf=mfcov if (mf.eq.31) mf=33 mt=mts(ix) if (igmin.gt.1) go to 420 a(iscr)=0 a(iscr+1)=0 c a(iscr+2)=mats(ixp) if (mats(ixp).eq.0) then a(iscr+2)=mat else a(iscr+2)=mats(ixp) endif a(iscr+3)=mts(ixp) a(iscr+4)=0 a(iscr+5)=ngn cej if (mfcov.eq.34) then mt=251 a(iscr+2)=mt a(iscr+3)=ld a(iscr+4)=ld1 endif c nwds=6 call contio(0,nout,0,a(iscr),nb,nwds) call timer(time) if (mats(ixp).eq.0) then c if(irelco.eq.0)write(nsyso,40) mt,mats(ixp),mts(ixp),time c if(irelco.eq.1)write(nsyso,45) mt,mats(ixp),mts(ixp),time if(irelco.eq.0)write(nsyso,40) mt,mat,mts(ixp),time if(irelco.eq.1)write(nsyso,45) mt,mat,mts(ixp),time else if (mfcov.eq.31.or.mfcov.eq.33.or.mfcov.eq.35) then if (irelco.eq.0) write(nsyso,30) mt,mts(ixp),time if (irelco.eq.1) write(nsyso,35) mt,mts(ixp),time elseif (mfcov.eq.34) then if (irelco.eq.0) write(nsyso,31) mts(ix),mts(ixp),time & ,251,25 if (irelco.eq.1) write(nsyso,36) mts(ix),mts(ixp),time & ,251,25 endif endif if (mfcov.eq.34) write(nsyso,50) ld,ld1 if (igmax.lt.ngn) izero=1 if (iprint.ne.0) then if (izero.eq.1) write(nsyso,20) if (izero.eq.0) write(nsyso,25) endif 420 if (mfcov.eq.34) then call alsigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx), & a(isig),a(ialp),ld,ld1,mtd,mt1) mt=251 endif c do 430 ig=igmin,igmax ig2lo=0 ng2=0 ip=0 ibase=6 do 440 igp=1,ngn ip=ip+1 ipos=ngn*(ig-igmin)+igp c ***calculate absolute covariances if (mfcov.eq.34) then a(iscr+ibase+ip-1)=a(isuma+ipos-1)/(a(icflx+ig-1)* & a(icflx+ngn+igp-1)) else a(iscr+ibase+ip-1)=a(isuma+ipos-1)/(a(icflx+ig-1)* & a(icflx+igp-1)) endif if (a(iscr+ibase+ip-1).eq.0) go to 425 if (irelco.eq.0) go to 425 c ***calculate relative covariances if (mfcov.eq.34) then call findex('xmu',ixmu,a) denom=a(ixmu+igp-1)*a(ixmu+ig-1) else denom=a(isum+ngn*(ix-1)+ig-1)* & a(isum+ngn*(ixp-1)+igp-1) endif if (denom.eq.zero) denom=eps if (mfcov.eq.35) then a(iscr+ibase+ip-1)=a(iscr+ibase+ip-1)/denom* & (egn(ig+1)-egn(ig))*(egn(igp+1)-egn(igp)) else a(iscr+ibase+ip-1)=a(iscr+ibase+ip-1)/denom endif 425 if (abs(a(iscr+ibase+ip-1)).le.eps) then if (ig2lo.eq.0) ip=ip-1 else if (ig2lo.eq.0) ig2lo=igp ng2=igp endif 440 continue if (ng2.eq.0.and.ig.lt.ngn) go to 430 if (ng2.eq.0) ig2lo=ig if (ng2.eq.0) ng2=ig a(iscr)=0 a(iscr+1)=0 a(iscr+2)=ng2-ig2lo+1 a(iscr+3)=ig2lo a(iscr+4)=ng2-ig2lo+1 a(iscr+5)=ig ip=ng2-ig2lo+1 istart=iscr if (mfcov.eq.34) mf=mfcov call listio(0,nout,0,a(istart),nb,nw) do while (nb.ne.0) istart=istart+nw call moreio(0,nout,0,a(istart),nb,nw) enddo if (izero.eq.0) go to 430 if (iprint.eq.0) go to 430 ibase=6 nw=ip 460 nc=nw if (nc.gt.6) nc=6 write(nsyso,'(i4,i6,1p,6e11.3)') & ig,ig2lo,(a(iscr+ibase+i-1),i=1,nc) ibase=ibase+nc ig2lo=ig2lo+nc nw=nw-nc if (nw.gt.0) go to 460 430 continue c cej c ***write out diagonal covariance matrix elements of resonance c ***parameters. if (mfcov.eq.33.and.mf32.ne.0) then itp=0 irpc=0 iupc=0 if (mt.eq.18) then if(mts(ixp).eq.18) then itp=1 irpc=icff iupc=iuff else if(mts(ixp).eq.102) then itp=1 irpc=icfg iupc=iufg endif else if (mt.eq.102.and.mts(ixp).eq.102) then itp=1 irpc=icgg iupc=iugg else if (mt.eq.2) then if (mts(ixp).eq.2) then itp=1 irpc=icee iupc=iuee else if (mts(ixp).eq.18) then itp=1 irpc=icef else if (mts(ixp).eq.102) then itp=1 irpc=iceg endif else if(mt.eq.1.and.mts(ixp).eq.1) then itp=1 irpc=ictt iupc=iutt endif if (itp.eq.0) go to 590 do ig1=igmin,igmax ig2=igmax*(ig1-1)-(ig1-1)*(ig1-2)/2+1 if (a(irpc+ig2-1).gt.0) go to 510 if (ifunrs.gt.0.and.iupc.gt.0) then if ((iupc+ig2-1).gt.0) then if (a(iupc+ig2-1).gt.0.) go to 510 endif endif enddo go to 590 510 continue if (ifresr.gt.0.and.(ifunrs.gt.0.and.iupc.gt.0)) then write(nsyso,62) elseif (ifresr.gt.0) then write(nsyso,60) elseif (ifunrs.gt.0.and.iupc.gt.0) then write(nsyso,63) endif jscr=iscr+ngn do i=1,ngn a(iscr+i-1)=0 a(jscr+i-1)=0 enddo do ig=ig1,igmax ig2=igmax*(ig-1)-(ig-1)*(ig-2)/2+1 a(iscr+ig-1)=a(irpc+ig2-1)/a(icflx+ig-1)**2 enddo if (ifunrs.gt.0.and.iupc.gt.0) then do ig=ig1,igmax ig2=igmax*(ig-1)-(ig-1)*(ig-2)/2+1 a(jscr+ig-1)=a(iupc+ig2-1)/a(icflx+ig-1)**2 enddo endif if (irelco.eq.1) then do ig=ig1,igmax a(iscr+ig-1)=a(iscr+ig-1)/(a(isum+ngn*(ix-1)+ig-1)* & a(isum+ngn*(ixp-1)+ig-1)) enddo if (ifunrs.gt.0.and.iupc.gt.0) then do ig=ig1,igmax a(jscr+ig-1)=a(jscr+ig-1)/ & (a(isum+ngn*(ix-1)+ig-1)* & a(isum+ngn*(ixp-1)+ig-1)) enddo endif endif if (ifresr.gt.0.and.(ifunrs.gt.0.and.iupc.gt.0)) then do ig=ig1,igmax if (a(iscr+ig-1).gt.0.or.a(jscr+ig-1).gt.0) then write(nsyso,61) ig,ig,a(iscr+ig-1),a(jscr+ig-1) endif enddo elseif (ifresr.gt.0) then do ig=ig1,igmax if (a(iscr+ig-1).gt.0) then write(nsyso,61) ig,ig,a(iscr+ig-1) endif enddo elseif (ifunrs.gt.0.and.iupc.gt.0) then do ig=ig1,igmax if (a(jscr+ig-1).gt.0.) then write(nsyso,61) ig,ig,a(jscr+ig-1) endif enddo endif 590 continue endif c c ***close loop over ranges of source groups (if any). if (igmax.eq.ngn) go to 470 igmin=igmax+1 igmax=igmin+irange-1 if (igmax.gt.ngn) igmax=ngn go to 185 470 continue cej if (mfcov.eq.34) then if (nm.lt.nmt1h) then do i=1,nsumx a(isuma+i-1)=0 enddo go to 220 endif endif c c ***close loops over reaction types. nscr=11*imode mt1lst=1000 180 continue call asend (nout,0) 170 continue cej if (nlump.gt.0) then call releas('lmt1',0,a) call releas('lmt2',0,a) endif c c ***covout is finished. if (nout.eq.0) return call afend(nout,0) call amend(nout,0) call closz(nscr) call closz(nscr2) call closz(nscrg) return c 15 format(i4,i6,1p,6e11.3) 20 format(' ig igp +0 +1 +2',/, & ' --- --- ---- ---- ----') 25 format(' zero') 30 format(/,' absolute covariance ( mt',i3,' , ig , mt',i3, & ' , igp )',19x,f9.1,'s',/) 31 format(/,' absolute covariance ( mt',i3,' , ig , mt',i3, & ' , igp )',19x,f9.1,'s', & /,' same as ( mt',i3,' , ig , mt',i3, & ' , igp )') 35 format(/,' relative covariance ( mt',i3,' , ig , mt',i3, & ' , igp )',19x,f9.1,'s',/) 36 format(/,' relative covariance ( mt',i3,' , ig , mt',i3, & ' , igp )',19x,f9.1,'s', & /,' same as ( mt',i3,' , ig , mt',i3, & ' , igp )') 40 format(/,' absolute covariance ( mt',i3,' , ig , mat',i5, & ' /mt',i3,' , igp )',9x,f9.1,'s',/) 45 format(/,' relative covariance ( mt',i3,' , ig , mat',i5, & ' /mt',i3,' , igp )',9x,f9.1,'s',/) 50 format(' for legendre component: ',i2,' and ',i2) 60 format(/,5x,'...contribution from resonance parameters (mf=32)...' & ,/,5x,' ig igp resolved' & ,/,5x,' --- --- --------') 61 format(5x,i4,i6,1p,6e11.3) 62 format(/,5x,'...contribution from resonance parameters (mf=32)...' & ,/,5x,' ig igp resolved unresolve' & ,/,5x,' --- --- -------- ---------') 63 format(/,5x,'...contribution from resonance parameters (mf=32)...' & ,/,5x,' ig igp unresolve' & ,/,5x,' --- --- ---------') end c subroutine egngpn(a) c ****************************************************************** c generate requested neutron group structure or read in from c the system input file in the form of an endf/b list record c c ign meaning c --- --------------------------------------- c 1 arbitrary structure (read in) c 2 csewg 239 group structure c 3 lanl 30 group structure c 4 anl 27 group structure c 5 rrd 50 group structure c 6 gam-i 68 group structure c 7 gam-ii 100 group structure c 8 laser-thermos 35 group c 9 epri-cpm 69 group structure c 10 lanl 187-group structure c 11 lanl 70-group structure c 12 sand-ii 620-group structure c 13 lanl 80-group structure c 14 eurlib 100-group structure c 15 sand-iia 640-group structure c 16 vitamin-e 174-group structure c 17 vitamin-j 175-group structure c 18 xmas 172-group structure cej c 19 read in, supplemented with endf covariance grid c c ****************************************************************** implicit real*8 (a-h,o-z) common/mainio/nsysi,nsyso,nsyse,ntty common/grpn/ign,ng,eg(901),iprint cej common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr(3) dimension a(*) c dimension gl2(241),eg3(31),gl4(28),gl5(51),eg6(36),eg9(70) dimension eg10a(48),eg10b(13) dimension gl2a(111),gl2b(104),gl2c(26) dimension eg11(71),u80(80) dimension deltl(8),ndelta(9) dimension ig14(19),gl14(19) dimension eg15a(84), eg15b(91) dimension eg18(173) dimension eg20n(20) equivalence(gl2a(1),gl2(1)),(gl2b(1),gl2(112)),(gl2c(1),gl2(216)) external error,uniong,findex,sigfig data gl2a/ & 27.631d0,17.0d0,16.75d0,16.588d0,16.5d0,16.3d0,16.25d0,16.0d0, & 15.75d0,15.5d0,15.25d0,15.d0,14.75d0,14.5d0,14.25d0,14.d0, & 13.75d0,13.5d0,13.25d0,13.d0,12.75d0,12.5d0,12.25d0,12.d0, & 11.75d0,11.5d0,11.25d0,11.d0,10.75d0,10.5d0,10.25d0,10.d0, & 9.75d0,9.5d0,9.25d0,9.d0,8.9d0,8.8d0,8.75d0,8.7d0,8.6d0,8.5d0, & 8.4d0,8.3d0,8.25d0,8.2d0,8.1583d0,8.1d0,8.d0,7.9d0,7.8d0, & 7.75d0,7.7d0,7.6d0,7.5d0,7.375d0,7.25d0,7.125d0,7.d0,6.875d0, & 6.75d0,6.625d0,6.5d0,6.375d0,6.25d0,6.15d0,6.125d0,6.05d0, & 6.025d0,6.d0,5.95d0,5.875d0,5.75d0,5.675d0,5.65d0,5.625d0, & 5.5d0,5.375d0,5.25d0,5.175d0,5.125d0,5.075d0,5.d0,4.875d0, & 4.75d0,4.625d0,4.5d0,4.45d0,4.4d0,4.35d0,4.3d0,4.25d0,4.2d0, & 4.15d0,4.125d0,4.1d0,4.075d0,4.05d0,4.d0,3.95d0,3.9d0,3.85d0, & 3.8d0,3.75d0,3.7d0,3.65d0,3.6d0,3.575d0,3.55d0,3.525d0,3.5d0/ data gl2b/ & 3.475d0,3.45d0,3.4d0,3.35d0,3.3d0,3.25d0,3.2d0,3.15d0,3.1d0, & 3.05d0,3.d0,2.975d0,2.95d0,2.925d0,2.9d0,2.85d0,2.8d0,2.75d0, & 2.7d0,2.65d0,2.6d0,2.55d0,2.5d0,2.45d0,2.4d0,2.35d0,2.3417d0, & 2.325d0,2.3d0,2.25d0,2.2d0,2.15d0,2.125d0,2.1d0,2.05d0,2.d0, & 1.95d0,1.9d0,1.875d0,1.85d0,1.825d0,1.8d0,1.75d0,1.7d0, & 1.675d0,1.65d0,1.625d0,1.6d0,1.55d0,1.5d0,1.4833d0,1.4667d0, & 1.45d0,1.4417d0,1.4333d0,1.4167d0,1.4d0,1.35d0,1.3d0,1.25d0, & 1.2d0,1.175d0,1.15d0,1.125d0,1.1d0,1.05d0,1.d0,.95d0,.9d0, & .85d0,.8d0,.775d0,.75d0,.725d0,.7d0,.65d0,.6d0,.55d0,.525d0, & .5d0,.475d0,.45d0,.425d0,.41667d0,.40833d0,.4d0,.375d0, & .35d0,.325d0,.3d0,.275d0,.25d0,.225d0,.2d0,.175d0,.15d0, & .125d0,.1d0,.075d0,.05d0,.025d0,0.d0,-.025d0,-.05d0/ data gl2c/ & -.075d0,-.1d0,-.125d0,-.15d0,-.175d0,-.2d0,-.225d0,-.25d0, & -.275d0,-.3d0,-.325d0,-.35d0,-.375d0,-.4d0,-.425d0,-.45d0, & -.475d0,-.5d0,-.525d0,-.55d0,-.575d0,-.6d0,-.625d0,-.65d0, & -.675d0,-.69167d0/ data eg3/1.39d-4,1.52d-1,4.14d-1,1.13d0,3.06d0,8.32d0,2.26d1, & 6.14d1,1.67d2,4.54d2,1.235d3,3.35d3,9.12d3,2.48d4,6.76d4, & 1.84d5,3.03d5,5.00d5,8.23d5,1.353d6,1.738d6,2.232d6,2.865d6, & 3.68d6,6.07d6,7.79d6,1.00d7,1.20d7,1.35d7,1.50d7,1.70d7/ data gl4/14.5d0,13.0d0,12.5d0,12.0d0,11.5d0,11.0d0,10.5d0, & 10.0d0,9.5d0,9.0d0,8.5d0,8.0d0,7.5d0,7.0d0,6.5d0,6.0d0, & 5.5d0,5.0d0,4.5d0,4.0d0,3.5d0,3.0d0,2.5d0,2.0d0,1.5d0,1.0d0, & 0.5d0,0.0d0/ data gl5/27.631d0,16.5d0,16.d0,15.5d0,15.d0,14.5d0,14.d0, & 13.5d0,13.d0,12.5d0,12.d0,11.5d0,11.d0,10.5d0,10.25d0,10.d0, & 9.75d0,9.5d0,9.25d0,9.d0,8.75d0,8.5d0,8.25d0,8.d0,7.75d0, & 7.5d0,7.25d0,7.d0,6.75d0,6.5d0,6.25d0,6.d0,5.75d0,5.5d0, & 5.25d0,5.d0,4.75d0,4.5d0,4.25d0,4.d0,3.75d0,3.5d0,3.25d0, & 3.d0,2.5d0,2.d0,1.5d0,1.d0,.5d0,0.d0,-.6917d0/ data eg6/.253d-3,.2277d-2,.6325d-2,.12397d-1,.20493d-1,.30613d-1, & .42757d-1,.56925d-1,.81972d-1,.11159d0,.14573d0,.18444d0, & .2277d0,.25104d0,.27053d0,.29075d0,.30113d0,.32064d0,.35768d0, & .41704d0,.50326d0,.62493d0,.78211d0,.95070d0,.10137d+1, & .10428d+1,.10525d+1,.10624d+1,.10722d+1,.10987d+1,.11664d+1, & .13079d+1,.14575d+1,.1595d+1,.17262d+1,.1855d+1/ data eg9/1.d-5,.005d0,.01d0,.015d0,.02d0,.025d0,.03d0,.035d0, & .042d0,.05d0,.058d0,.067d0,.08d0,.1d0,.14d0,.18d0,.22d0,.25d0, & .28d0,.3d0,.32d0,.35d0,.4d0,.5d0,.625d0,.78d0,.85d0,.91d0,.95d0, & .972d0,.996d0,1.02d0,1.045d0,1.071d0,1.097d0,1.123d0,1.15d0, & 1.3d0,1.5d0,2.1d0,2.6d0,3.3d0,4.d0,9.877d0,15.968d0,27.7d0, & 48.052d0,75.501d0,148.728d0,367.262d0,906.898d0,1425.1d0, & 2239.45d0,3519.1d0,5530.d0,9118.d0,1.503d4,2.478d4,4.085d4, & 6.734d4,1.11d5,1.83d5,3.025d5,5.d5,8.21d5,1.353d6,2.231d6, & 3.679d6,6.0655d6,1.d7/ data eg10a/1.d-5,2.5399d-4,7.6022d-4,2.2769d-3,6.3247d-3, & .012396d0,.020492d0,.0255d0,.030612d0,.0355d0,.042755d0,.05d0, & .056922d0,.067d0,.081968d0,.11157d0,.14572d0,.1523d0,.18443d0, & .22769d0,.25103d0,.27052d0,.29074d0,.30112d0,.32063d0,.35767d0, & .41499d0,.50323d0,.62506d0,.78208d0,.83368d0,.87642d0,.91d0, & .95065d0,.971d0,.992d0,1.0137d0,1.0427d0,1.0525d0,1.0623d0, & 1.0722d0,1.0987d0,1.1254d0,1.1664d0,1.3079d0,1.4574d0,1.5949d0, & 1.7261d0/ data eg10b/1.1d7,1.2d7,1.3d7,1.35d7,1.375d7,1.394d7,1.42d7, & 1.442d7,1.464d7,1.5d7,1.6d7,1.7d7,2.d7/ data eg11/10.677d0,61.4421d0,101.301d0,130.073d0,167.017d0, & 214.454d0,275.365d0,353.575d0,453.999d0,582.947d0,748.518d0, & 961.117d0,1089.09d0,1234.1d0,1398.42d0,1584.61d0,1795.6d0, & 2034.68d0,2305.6d0,2612.59d0,2960.45d0,3354.63d0,3801.29d0, & 4307.43d0,4880.95d0,5530.84d0,6267.27d0,7101.74d0,8047.33d0, & 9118.82d0,10333.3d0,11708.8d0,13267.8d0,15034.4d0,17036.2d0, & 19304.5d0,21874.9d0,24787.5d0,28087.9d0,31827.8d0,40867.7d0, & 52475.2d0,67379.5d0,86517.d0,111090.d0,142642.d0,183156.d0, & 235178.d0,301974.d0,387742.d0,439369.d0,497871.d0,564161.d0, & 639279.d0,724398.d0,820850.d0,930145.d0,1053990.d0, & 1194330.d0,1353350.d0,1737740.d0,2231300.d0,2865050.d0, & 3678790.d0,4723670.d0,6065310.d0,7788010.d0,1.d7,1.28403d7, & 1.64872d7,2.d7/ data deltl/5.d0,7.5d0,10.d0,15.d0,20.d0,25.d0,30.d0,40.d0/ data ndelta/2,6,10,19,23,28,36,40,46/ data u80/.1681472d0,.125d0,.1d0,.125d0,.175,8*.25d0,10*.125d0, & 10*.25d0,.125d0,.075d0,.05d0,26*.125d0,5*.25d0,9*.5d0,3*1.,7.d0/ data ig14/2,9,13,15,17,23,25,55,60,61,63,64,65,93,94,95,99,100, & 101/ data gl14/.1d0,.05d0,.1d0,.05d0,.1d0,.05d0,.1d0,.25d0,.2d0,.05d0, & .075d0,.125d0,.25d0,.5d0,.25d0,.5d0,.588d0,.412d0,10.631d0/ data eg15a/ & 1.0d-5,1.0d-1,4.1399d-1,5.3158d-1,6.8256d-1,8.7642d-1,1.1254d0, & 1.4450d0,1.8554d0,2.3824d0,3.0590d0,3.9279d0,5.0435d0,6.4760d0, & 8.3153d0,1.0677d1,1.3710d1,1.7603d1,2.2603d1,2.9023d1,3.7267d1, & 4.7851d1,6.1442d1,7.8893d1,1.0130d2,1.3007d2,1.6702d2,2.1445d2, & 2.7536d2,3.5358d2,4.5400d2,5.8295d2,7.4852d2,9.6112d2,1.2341d3, & 1.5846d3,2.0347d3,2.2487d3,2.4852d3,2.6126d3,2.7465d3,3.0354d3, & 3.3546d3,3.7074d3,4.3074d3,5.5308d3,7.1017d3,9.1188d3,1.0595d4, & 1.1709d4,1.5034d4,1.9305d4,2.1875d4,2.3579d4,2.4176d4,2.4788d4, & 2.6058d4,2.7000d4,2.8500d4,3.1828d4,3.4307d4,4.0868d4,4.6309d4, & 5.2475d4,5.6562d4,6.7379d4,7.2000d4,7.9500d4,8.2500d4,8.6517d4, & 9.8037d4,1.1109d5,1.1679d5,1.2277d5,1.2907d5,1.3569d5,1.4264d5, & 1.4996d5,1.5764d5,1.6573d5,1.7422d5,1.8316d5,1.9255d5,2.0242d5/ data eg15b/ & 2.1280d5,2.2371d5,2.3518d5,2.4724d5,2.7324d5,2.8725d5,2.9452d5, & 2.9720d5,2.9850d5,3.0197d5,3.3373d5,3.6883d5,3.8774d5,4.0762d5, & 4.5049d5,4.9787d5,5.2340d5,5.5023d5,5.7844d5,6.0810d5,6.3928d5, & 6.7206d5,7.0651d5,7.4274d5,7.8082d5,8.2085d5,8.6294d5,9.0718d5, & 9.6164d5,1.0026d6,1.1080d6,1.1648d6,1.2246d6,1.2873d6,1.3534d6, & 1.4227d6,1.4957d6,1.5724d6,1.6530d6,1.7377d6,1.8268d6,1.9205d6, & 2.0190d6,2.1225d6,2.2313d6,2.3069d6,2.3457d6,2.3653d6,2.3852d6, & 2.4660d6,2.5924d6,2.7253d6,2.8650d6,3.0119d6,3.1664d6,3.3287d6, & 3.6788d6,4.0657d6,4.4933d6,4.7237d6,4.9659d6,5.2205d6,5.4881d6, & 5.7695d6,6.0653d6,6.3763d6,6.5924d6,6.7032d6,7.0469d6,7.4082d6, & 7.7880d6,8.1873d6,8.6071d6,9.0484d6,9.5123d6,1.0000d7,1.0513d7, & 1.1052d7,1.1618d7,1.2214d7,1.2523d7,1.3499d7,1.3840d7,1.4191d7, & 1.4550d7,1.4918d7,1.5683d7,1.6487d7,1.6905d7,1.7333d7,1.9640d7/ data eg18/ & 1.96403d+7,1.73325d+7,1.49182d+7,1.38403d+7,1.16183d+7, & 1.00000d+7,8.18731d+6,6.70320d+6,6.06531d+6,5.48812d+6, & 4.49329d+6,3.67879d+6,3.01194d+6,2.46597d+6,2.23130d+6, & 2.01897d+6,1.65299d+6,1.35335d+6,1.22456d+6,1.10803d+6, & 1.00259d+6,9.07180d+5,8.20850d+5,6.08101d+5,5.50232d+5, & 4.97871d+5,4.50492d+5,4.07622d+5,3.01974d+5,2.73237d+5, & 2.47235d+5,1.83156d+5,1.22773d+5,1.11090d+5,8.22975d+4, & 6.73795d+4,5.51656d+4,4.08677d+4,3.69786d+4,2.92830d+4, & 2.73944d+4,2.47875d+4,1.66156d+4,1.50344d+4,1.11378d+4, & 9.11882d+3,7.46586d+3,5.53084d+3,5.00451d+3,3.52662d+3, & 3.35463d+3,2.24867d+3,2.03468d+3,1.50733d+3,1.43382d+3, & 1.23410d+3,1.01039d+3,9.14242d+2,7.48518d+2,6.77287d+2, & 4.53999d+2,3.71703d+2,3.04325d+2,2.03995d+2,1.48625d+2, & 1.36742d+2,9.16609d+1,7.56736d+1,6.79041d+1,5.55951d+1, & 5.15780d+1,4.82516d+1,4.55174d+1,4.01690d+1,3.72665d+1, & 3.37201d+1,3.05113d+1,2.76077d+1,2.49805d+1,2.26033d+1, & 1.94548d+1,1.59283d+1,1.37096d+1,1.12245d+1,9.90555d+0, & 9.18981d+0,8.31529d+0,7.52398d+0,6.16012d+0,5.34643d+0, & 5.04348d+0,4.12925d+0,4.00000d+0,3.38075d+0,3.30000d+0, & 2.76792d+0,2.72000d+0,2.60000d+0,2.55000d+0,2.36000d+0, & 2.13000d+0,2.10000d+0,2.02000d+0,1.93000d+0,1.84000d+0, & 1.75500d+0,1.67000d+0,1.59000d+0,1.50000d+0,1.47500d+0, & 1.44498d+0,1.37000d+0,1.33750d+0,1.30000d+0,1.23500d+0, & 1.17000d+0,1.15000d+0,1.12535d+0,1.11000d+0,1.09700d+0, & 1.07100d+0,1.04500d+0,1.03500d+0,1.02000d+0,9.96000d-1, & 9.86000d-1,9.72000d-1,9.50000d-1,9.30000d-1,9.10000d-1, & 8.60000d-1,8.50000d-1,7.90000d-1,7.80000d-1,7.05000d-1, & 6.25000d-1,5.40000d-1,5.00000d-1,4.85000d-1,4.33000d-1, & 4.00000d-1,3.91000d-1,3.50000d-1,3.20000d-1,3.14500d-1, & 3.00000d-1,2.80000d-1,2.48000d-1,2.20000d-1,1.89000d-1, & 1.80000d-1,1.60000d-1,1.40000d-1,1.34000d-1,1.15000d-1, & 1.00001d-1,9.50000d-2,8.00000d-2,7.70000d-2,6.70000d-2, & 5.80000d-2,5.00000d-2,4.20000d-2,3.50000d-2,3.00000d-2, & 2.50000d-2,2.00000d-2,1.50000d-2,1.00000d-2,6.90000d-3, & 5.00000d-3,3.00000d-3,1.00001d-5/ data ezero/1.d7/ data tenth,eighth,quart/0.10d0,0.125d0,0.25d0/ data bgam2,tgam2/27.631021d0,-0.53062825d0/ data u187a,u187b,u187c,e187d,e187e/-15.5d0,-14.125d0,-5.875d0, & 2.6058d4,6.868d0/ data sanda,sandb,sandc,sandd,sande/1.d-4,1.d-6,2.8d-4,1.d6,1.d5/ data uu80/.6931472d0/ data e175/1.284d7/ cej data (eg20n(i),i=1,20) & / 1.0000d-5, 1.0130d+2, 2.1445d+2, 4.5400d+2, 9.6112d+2, & 2.0347d+3, 4.3074d+3, 9.1188d+3, 1.9305d+4, 4.0868d+4, & 8.6517d+4, 1.8316d+5, 3.8774d+5, 8.2085d+5, 1.3534d+6, & 2.2313d+6, 3.6788d+6, 6.0653d+6, 1.0000d+7, 2.0000d+7 / c data ngmax/901/ c c ***choose option according to ign lflag=0 c c ***group structure is read in (free format) cej if (ign.eq.1.or.ign.eq.19) then read(nsysi,*) ng ngp=ng+1 cej if (ngp.gt.ngmax) call error('egngpn','too many groups.',' ') read(nsysi,*) (eg(i),i=1,ngp) cej do i=1,ngp eg(i)=sigfig(eg(i),5,0) enddo c do i=1,ng if (eg(i).gt.eg(i+1)) cej & call error('egngpn', & 'read-in group structure is out of order.',' ') enddo c c ***csewg 239 group structure else if (ign.eq.2) then ng=240 do ig=1,241 eg(ig)=gl2(ig) enddo lflag=1 c c ***lanl 30 group structure else if (ign.eq.3) then ng=30 do ig=1,31 eg(ig)=eg3(ig) enddo c c ***anl 27 group structure else if (ign.eq.4) then ng=27 do ig=1,28 eg(ig)=gl4(ig) enddo lflag=1 c c ***rrd 50 group structure else if (ign.eq.5) then ng=50 do ig=1,51 eg(ig)=gl5(ig) enddo lflag=1 c c ***gam-i 68 group structure else if (ign.eq.6) then ng=68 u=-quart du=quart do ig=1,69 u=u+du eg(70-ig)=u enddo lflag=1 c c ***gam-ii 100 group structure else if (ign.eq.7) then ng=100 u=-4*tenth du=tenth do ig=1,99 u=u+du eg(101-ig)=u if (ig.eq.49) du=quart enddo eg(1)=bgam2 c ***upper limit changed to 17 mev. eg(101)=tgam2 lflag=1 c c ***laser-thermos 35 group structure else if (ign.eq.8) then ng=35 do ig=1,36 eg(ig)=eg6(ig) enddo c c ***epri-cpm 69 group structure else if (ign.eq.9) then ng=69 do ig=1,70 eg(ig)=eg9(ig) enddo c c ***lanl 187-group structure else if (ign.eq.10) then ng=187 do ig=1,48 eg(ig)=eg10a(ig) enddo u=u187a do ig=49,59 eg(ig)=ezero*exp(u) u=u+eighth enddo eg(60)=e187e u=u187b do ig=61,126 eg(ig)=ezero*exp(u) u=u+eighth enddo eg(127)=e187d u=u187c do ig=128,175 eg(ig)=ezero*exp(u) u=u+eighth enddo do ig=176,188 eg(ig)=eg10b(ig-175) enddo c c ***lanl 70 group structure else if (ign.eq.11) then ng=70 do ig=1,71 eg(ig)=eg11(ig) enddo c c ***sand-ii 620- and 640-group structures else if (ign.eq.12.or.ign.eq.15) then ng=620 if (ign.eq.15) ng=640 ngp=ng+1 eg(1)=sanda c ***generate the first 45 boundaries do i=1,8 delta=deltl(i)*sandb n1=ndelta(i) n2=ndelta(i+1)-1 do n=n1,n2 eg(n)=eg(n-1)+delta enddo enddo c ***correct group 21 eg(21)=sandc c ***groups 46 to 450 are multiples of previous groups do i=46,450 eg(i)=eg(i-45)*10 enddo c ***groups 451 through 620 have constant spacing of 1.e5 eg(451)=sandd do i=452,ngp eg(i)=eg(i-1)+sande enddo c c ***lanl 80-group structure else if (ign.eq.13) then ng=80 u=uu80 do ig=1,81 eg(82-ig)=ezero*exp(u) u=u-u80(ig) enddo eg(81)=2*ezero c c ***eurlib 100-group structure else if (ign.eq.14) then ng=100 eg(101)=-4 eg(101)=eg(101)/10 ic=0 do ig=2,101 if (ig.eq.ig14(ic+1)) ic=ic+1 eg(102-ig)=eg(103-ig)+gl14(ic) enddo lflag=1 c c ***vitamin-e 174- and vitamin-j 175-group structures (ornl-5510) else if (ign.eq.16.or.ign.eq.17) then ng=174 do ig=1,84 eg(ig)=eg15a(ig) enddo do ig=85,175 eg(ig)=eg15b(ig-84) enddo if (ign.ne.16) then ng=175 eg(166)=e175 do ig=167,176 eg(ig)=eg15b(ig-85) enddo endif c c ***xmas 172-group structure else if (ign.eq.18) then ng=172 do ig=1,173 eg(ig)=eg18(174-ig) enddo c c ***illegal ign cej else if (ign.eq.20) then ng=18 do ig=1,ng+1 eg(ig)=eg20n(ig) enddo else if (ign.eq.21) then ng=19 do ig=1,ng+1 eg(ig)=eg20n(ig) enddo else call error('egngpn','illegal group structure requested.',' ') endif c c ***convert lethargy grid to energies if (lflag.eq.1) then lim=ng+1 do ig=1,lim eg(ig)=sigfig(ezero*exp(-eg(ig)),7,0) enddo endif c c ***display group structure cej if (ign.ne.19) then if (ign.eq.1) write(nsyso,'(/, & '' neutron group structure......read in'')') if (ign.eq.2) write(nsyso,'(/, & '' neutron group structure......csewg 240 group'')') if (ign.eq.3) write(nsyso,'(/, & '' neutron group structure......lanl 30 group'')') if (ign.eq.4) write(nsyso,'(/, & '' neutron group structure......anl 27 group'')') if (ign.eq.5) write(nsyso,'(/, & '' neutron group structure......rrd 50 group'')') if (ign.eq.6) write(nsyso,'(/, & '' neutron group structure......gam-i 68 group'')') if (ign.eq.7) write(nsyso,'(/, & '' neutron group structure......gam-ii 100 group'')') if (ign.eq.8) write(nsyso,'(/, & '' neutron group structure......laser-thermos 35 group'')') if (ign.eq.9) write(nsyso,'(/, & '' neutron group structure......epri-cpm 69 group'')') if (ign.eq.10) write(nsyso,'(/, & '' neutron group structure......lanl 187-group'')') if (ign.eq.11) write(nsyso,'(/, & '' neutron group structure......lanl 70-group'')') if (ign.eq.12) write(nsyso,'(/, & '' neutron group structure......sand-ii 620 group'')') if (ign.eq.13) write(nsyso,'(/, & '' neutron group structure......lanl 80-group'')') if (ign.eq.14) write(nsyso,'(/, & '' neutron group structure......eurlib 100-group'')') if (ign.eq.15) write(nsyso,'(/, & '' neutron group structure......sand-iia 640-group'')') if (ign.eq.16) write(nsyso,'(/, & '' neutron group structure......vitamin-e 174-group'')') if (ign.eq.17) write(nsyso,'(/, & '' neutron group structure......vitamin-j 175-group'')') if (ign.eq.18) write(nsyso,'(/, & '' neutron group structure......xmas 172-group'')') do ig=1,ng write(nsyso,'(1x,i5,2x,1p,e12.5,'' - '',e12.5)') & ig,eg(ig),eg(ig+1) enddo endif c cej c ***prepare union of users grid with endf covariance grid. ngp=ng+1 do i=1,ngp eg(i)=sigfig(eg(i),ndig,0) enddo call uniong(nendf,a) call findex('un',iun,a) if (ign.eq.19) then write(nsyso,'(/, & '' union structure (= user structure) has'',i4, & '' groups'',/)') nunion do ig=1,nunion eg(ig)=a(ig-1+iun) enddo eg(nunion+1)=a(iun+nunion) ng=nunion else write(nsyso,'(/,'' union structure has'',i4,'' groups'',/)') & nunion endif do ig=1,nunion write(nsyso,'(1x,i5,6x,1p,e11.5,'' - '',e11.5)') & ig,a(iun+ig-1),a(iun+ig) enddo c return end cej subroutine epanel(elo,ehi,ans,nl,nz,iglo,mfcov,a) c ****************************************************************** c perform generalized group constant integrals for one panel. c the upper boundary of the panel is chosen to be the smallest c of ehi, the next cross section point, and the next flux point. c ****************************************************************** implicit real*8 (a-h,o-z) dimension sig(65),slst(65),flux(10,10),flst(10,10) dimension a(*),ans(nl,nz,*) data idisc,elast/0,0.d0/ cej data delta/0.999999999995d0/ save enext,flst,slst c c ***retrieve factors in integrands at lower boundary. il=1 iz=1 iglo=1 if (idisc.ne.0.or.elo.ne.elast) then elast=elo cej if (mfcov.eq.34) then call egtlgc(elo,enext,idisc,slst,a) else call egtsig(elo,enext,idisc,slst,a) endif c call egtflx(elo,en,idiscf,flst,nl,nz,a) if (en.eq.enext.and.idiscf.gt.idisc) idisc=idiscf if (en.lt.enext) idisc=idiscf if (en.lt.enext) enext=en endif c c ***retrieve cross section and flux at upper boundary. if (enext.lt.ehi) ehi=enext ehigh=ehi if (idisc.gt.0) ehigh=ehi*delta cej if (mfcov.eq.34) then call egtlgc(ehigh,enext,idisc,sig,a) else call egtsig(ehigh,enext,idisc,sig,a) endif c call egtflx(ehigh,en,idiscf,flux,nl,nz,a) if (en.eq.enext.and.idiscf.gt.idisc) idisc=idiscf if (en.lt.enext) idisc=idiscf if (en.lt.enext) enext=en c c ***compute group cross sections and fluxes. bq=(ehigh-elo)/2 ans(il,iz,1)=ans(il,iz,1)+(flux(iz,il)+flst(iz,il))*bq c cej do n=1,nl rr=(sig(n)*flux(iz,il)+slst(n)*flst(iz,il))*bq ans(n,iz,2)=ans(n,iz,2)+rr enddo c c ***save last values. elast=ehi cej do n=1,nl slst(n)=sig(n) enddo c flst(1,1)=flux(1,1) if (en.eq.enext.and.idiscf.gt.idisc) idisc=idiscf if (en.lt.enext) idisc=idiscf if (en.lt.enext) enext=en return end c subroutine grpav(mprint,tempin,a) c ****************************************************************** c compute multigroup cross sections for reactions needed in the c calculation of the covariance matrices. calculation uses the c union of the user specified group structure and the energy c grid found in mfcov. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/sigzer/sigz(10),nsigz common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,ntot,nunit(1) common/mainio/nsysi,nsyso,nsyse,ntty common/util/npage,iverf common/argcom/matl,mfd,mtd common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) character*60 strng character*66 text dimension mtname(17),b(8),z(20),ans(2) dimension a(*) data nt/1/, nz/1/, ngg/0/ data eps/1.d-9/ data big/1.d10/ data elow/1.d-5/ zero=0 c c ***initialize if (iread.eq.2) call error('grpav', & 'not coded for multimaterial group averaging.',' ') call timer(sec) write(nsyso,'(/,'' computing multigroup cross sections'', & 33x,f8.1,''s'')') sec call egnwtf(a) nwds=npage+50 call reserv('scr',nwds,iscr,a) iscr1=iscr-1 nsigz=1 sigz(1)=big ntot=11 ngout=-10 call repoz(ngout) math=1 mfh=0 mth=0 text=' ' nw=17 read(text,'(16a4,a2)') (z(i),i=1,nw) call tpidio(0,ngout,0,z,nb,nw) call findex('un',iun,a) iun1=iun-1 if (abs(egn(1)-elow).le.eps) egn(1)=elow etop=a(iun+nunion) c c ***search for desired mat and temperatures on pendf tape call repoz(npend) call findf(matd,1,0,npend) call contio(npend,0,0,a(iscr),nb,nw) 121 za=c1h awr=c2h if (iverf.ge.5) call contio(npend,0,0,a(iscr),nb,nw) if (iverf.ge.6) call contio(npend,0,0,a(iscr),nb,nw) call hdatio(npend,0,0,a(iscr),nb,nw) if (abs(c1h-tempin).le.tempin/10000) go to 130 if (c1h.gt.tempin) go to 125 call tomend(npend,0,0,a(iscr)) call contio(npend,0,0,a(iscr),nb,nw) if (math.ne.matd) go to 125 go to 121 125 write(strng,'(''unable to find temp='',1p,e11.3)') tempin call error('grpav',strng,' ') c c ***write head record for this material on gout tape. 130 nsh=1 math=matd mfh=1 mth=451 a(iscr)=za a(iscr+1)=awr a(iscr+2)=0 a(iscr+3)=nz a(iscr+4)=-11 a(iscr+5)=nt call contio(0,ngout,0,a(iscr),nb,nw) a(iscr)=tempin a(iscr+1)=0 a(iscr+2)=nunion a(iscr+3)=ngg a(iscr+4)=0 a(iscr+5)=0 nw=7 a(iscr+nw-1)=0 nw=nw+1 a(iscr+nw-1)=sigz(1) np1=nunion+1 do i=1,np1 a(i+nw+iscr1)=a(i+iun1) enddo nw=nw+np1 nl=1 a(iscr+4)=nw indx=iscr call listio(0,ngout,0,a(iscr),nb,nwds) do while (nb.ne.0) indx=indx+nwds call moreio(0,ngout,0,a(indx),nb,nwds) enddo mfold=1 mtold=451 nshold=nsh call asend(ngout,0) c c ***store total cross section from pendf tape for later use c c ***if this is an infinite dilution calculation, c ***omit the reading and storing of mt=1 do 165 nsz=1,nsigz if (sigz(nsz).lt.1.e8) go to 170 165 continue ntot=0 go to 175 170 call findf(matd,3,1,npend) if (npend.lt.0) ntot=-ntot call repoz(ntot) nsh=1 math=1 call afend(ntot,0) call contio(npend,ntot,0,a(iscr),nb,nw) call tosend(npend,ntot,0,a(iscr)) call amend(ntot,0) call atend(ntot,0) call repoz(ntot) 175 nsh=nshold c c ***main loop over reactions call findex('ga',iga,a) matl=matd mfd=3 do 290 imt=1,nga mtd=nint(a(iga+imt-1)) if (mtd.eq.452.or.mtd.eq.455.or.mtd.eq.456) then write(strng,'(''cannot group average mt='',i3)') mtd call error('grpav',strng, & 'use groupr first, then error with ngout.ne.0') endif if (mtd.eq.3) call mess('grpav', & 'mt3 cross sections are constucted', & ' from total minus elastic') if (mtd.eq.3) go to 290 text=' ' read(text,'(15a4)') (mtname(i),i=1,15) call timer(time) c c ***initialize ng2=2 nl=1 e=0 call egtsig(e,thresh,idis,sig,a) if (thresh.gt.etop) go to 270 call egtflx(e,enext,idis,flux,nl,nz,a) if (mprint.ne.0) then if (tempin.eq.zero) write(nsyso,'(/, & '' group constants at t=zero deg k'',37x,f8.1,''s'')')time if (tempin.ne.zero) write(nsyso,'(/, & '' group constants at t='',1p,e9.3,'' deg k'', & 32x,0p,f8.1,''s'')') tempin,time write(nsyso,'('' for mf'',i2,'' and mt'',i3,1x,15a4)') & mfd,mtd,(mtname(ii),ii=1,15) write(nsyso,'(15x,''group'',5x,''constant'')') endif call findex('un',iun,a) c c ***loop over initial energy groups do 210 ig=1,nunion elo=a(iun+ig-1) ehi=a(iun+ig) ig2lo=0 if (ehi.le.thresh) go to 210 enext=ehi ans(1)=0 ans(2)=0 cej 230 call epanel(elo,enext,ans,nl,nz,ig2lo,33,a) if (enext.eq.ehi) go to 240 elo=enext enext=ehi go to 230 240 continue c c ***write this group on gout tape. nw=nl*nz*ng2 ans(2)=ans(2)/ans(1) if (mprint.ne.0)write(nsyso,'(14x,i4,5x,1p,e11.4)')ig,ans(2) mfh=mfd mth=mtd if (mfh.ne.mfold) then call afend(ngout,0) mfh=mfd mth=mtd endif if (mth.ne.mtold) then b(1)=za b(2)=awr b(3)=nl b(4)=nz b(5)=0 b(6)=nunion nwds=6 call contio(0,ngout,0,b,nb,nwds) mfold=mfd mtold=mtd endif if (ans(2).ne.zero.or.ig.eq.nunion) then b(1)=tempin b(2)=0 b(3)=ng2 b(4)=ig2lo b(5)=nw b(6)=ig b(7)=ans(1) b(8)=ans(2) nwds=8 call listio(0,ngout,0,b,nb,nwds) endif 210 continue call asend(ngout,0) go to 280 c ***write message if mt has threshold gt highest union energy 270 write(strng,'(''mf '',i2,'' mt '',i3)') mfd,mtd call mess('grpav',strng, & 'has threshold gt highest union energy.') 280 call releas('sig',-1,a) 290 continue c c ***grpav is finished. 300 call afend(ngout,0) call amend(ngout,0) call atend(ngout,0) call releas('scr',-1,a) cej if (mfcov.ne.34) call releas('ga',0,a) call timer(sec) write(nsyso,'(/,'' group averaging completed'', & 43x,f8.1,''s'',/)') sec return end c subroutine rdgout(ngout,matd,mfd,mti,b,sig) c ****************************************************************** c find the desired information from a groupr-type output tape. c mti=-1 is used to retrieve flux from mt=1 records. c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nunit(7),nscrg,nscrt common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc character*60 strng dimension b(*),sig(*) cej dimension mtsig0(100) save mtlast,ngt,iz data mtsig0,mtsig / 100*0, 0 / c mtd=iabs(mti) if (mfd.gt.1) go to 200 c c ***copy rest of this mat to a scratch file. call repoz(nscrg) call repoz(ngout) call tpidio(ngout,0,0,b,nb,nwds) 100 call contio(ngout,0,0,b,nb,nwds) if (mat.eq.matd) go to 120 if (mat.lt.matd.and.mat.ne.-1) go to 110 write(strng,'(''mat'',i4,'' not found.'')') matd call error('rdgout',strng,' ') 110 call tomend(ngout,0,0,b) go to 100 120 if (mf.ne.mfd.or.mt.ne.mtd) then write(strng,'(''mf'',i2,'' mt'',i3,'' not found.'')') mfd,mtd call error('rdgout',strng,' ') endif nz=l2h ntw=n2h call listio(ngout,0,0,b,nb,nwds) ngt=l1h ngtp1=ngt+1 ibase=ntw+nz+6 isave=0 do i=1,ngtp1 isave=isave+1 sig(i)=b(ibase+isave) if (nb.gt.0 .and.ibase+isave.ge.nwds) then call moreio(ngout,0,0,b,nb,nwds) ibase=0 isave=0 endif enddo mti=ngt iz=1 nsc=0 call tofend(ngout,0,0,b) c ***copy rest of material to scratch tape call contio(ngout,0,nscrg,b,nb,nwds) call tomend(ngout,0,nscrg,b) call atend(0,nscrg) mtlast=1000 return c c ***retrieve desired cross section or flux. c ***construct mt=3 from total minus elastic 200 if (mtd.le.mtlast) call repoz(nscrg) if (mtd.eq.3) call repoz(nscrg) mtlast=mtd if (mtd.eq.3) mtd=1 do is=1,ngt sig(is)=0. enddo 210 call contio(nscrg,0,0,b,nb,nwds) if (mat.ge.1) go to 215 if (mti.ne.-2) then cej if (mtsig.gt.0) then do 211 i=1,mtsig if (mtd.eq.mtsig0(i)) go to 212 211 continue mtsig=mtsig+1 mtsig0(mtsig)=mtd else mtsig0(1)=mtd mtsig=1 endif write(strng,'(''mf'',i2,'' mt'',i3,'' not found.'')') mfd,mtd call mess('rdgout',strng, & 'calculation is continued by sigma=0.0.') 212 continue c endif call repoz(nscrg) return 215 continue if (mf.eq.0.or.mt.eq.0) go to 210 if (mf.eq.mfd.and.mt.eq.mtd) go to 230 if (mf.eq.mfd.and.mt.gt.mtd.and.mti.lt.0) go to 220 call tosend(nscrg,0,0,b) go to 210 c c ***if the total cross-section is absent, construct the c ***flux vector as the union of the fluxes c ***from all partials present 220 mti=-2 mtd=mt 230 nl=l1h nz=l2h 240 call listio(nscrg,0,0,b,nb,nwds) jg=n2h if=1+nl*(iz-1) is=nl*nz+1+nl*(iz-1) ib=is if (mti.lt.0) ib=if if ((ib+6).gt.nwds) go to 250 if (mtd.eq.1.or.mtlast.ne.3) sig(jg)=b(ib+6) if (mtd.eq.2.and.mtlast.eq.3) sig(jg)=sig(jg)-b(ib+6) go to 270 250 if (nb.eq.0) call error('rdgout', & 'bad index for b equivalent to sig(ig).', & ' ') call moreio(nscrg,0,0,b,nb,nwds2) ibn=ib+6-nwds if (ibn.le.nwds2) go to 260 nwds=nwds+nwds2 go to 250 260 if (mtd.eq.1.or.mtlast.ne.3) sig(jg)=b(ibn) if (mtd.eq.2.and.mtlast.eq.3) sig(jg)=sig(jg)-b(ibn) 270 do while (nb.ne.0) call moreio(nscrg,0,0,b,nb,nwds) enddo if (jg.lt.ngt) go to 240 if (mti.eq.-2) go to 210 if (mtlast.eq.3.and.mtd.eq.2) mtd=3 if (mtlast.ne.3.or.mtd.eq.3) return mtd=2 go to 210 end c subroutine sigc(ncg,csig,cflx,b,egt,flux,sig) c ****************************************************************** c calculate the coarse group cross sections. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/eunits/nendf,nin,nout,ninc,ngout,nstan,nunit(2),nscr common/mainio/nsysi,nsyso,nsyse,ntty common/estore/a(8500000) common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) character*60 strng character*2 hmt dimension csig(ncg,*),cflx(*),b(*),egt(*),flux(*),sig(*) dimension c(6),matp(60) data hmt/'mt'/ cej logical lmf8 data lmf8/.false./ c c ***put the coarse group structure on nout, ala groupr if (nlump.ne.0) then call findex('sg',isg,a) call findex('lump',ilump,a) call findex('lmt',ilmt,a) call repoz(nscr) call closz(nscr) endif if (nout.ne.0) then mat=matd mf=1 mt=451 b(1)=za b(2)=awr b(3)=0 b(4)=0 b(5)=-11 b(6)=0 call contio (0,nout,0,b,nb,nw) b(1)=0 b(2)=0 b(3)=ngn nw=6 ngnp1=ngn+1 do i=1,ngnp1 nw=nw+1 b(nw)=egn(i) enddo np=nw-6 b(5)=np loc=1 call listio (0,nout,0,b(loc),nb,nw) do while (nb.ne.0) loc=loc+nw call moreio(0,nout,0,b(loc),nb,nw) enddo call asend(nout,0) call afend(nout,0) endif c c ***initialize nun1=nunion+1 do i=1,nun1 egt(i)=sigfig(egt(i),ndig,0) enddo ngn1=ngn+1 do i=1,ngn1 egn(i)=sigfig(egn(i),ndig,0) enddo c ***calculate coarse group flux do ig=1,ngn cflx(ig)=0 do jg=1,nunion if (egt(jg).ge.egn(ig).and.egt(jg).lt.egn(ig+1)) then cflx(ig)=cflx(ig)+flux(jg) endif enddo enddo c c ***loop over all reaction types. c ***compute cross-group cross sections and write on output tape. do 210 ix=1,nmt1 if (mts(ix).lt.851) go to 250 do 220 il=1,nlump l=il mtl=nint(a(ilump+2*(l-1))) if (mtl.eq.mts(ix)) go to 230 220 continue write(strng,'(''covariance reaction'',i4)') mts(ix) call error('sigc',strng,'missing from lumping table.)') 230 nmtl=nint(a(ilump+2*(l-1)+1)) do jg=1,nunion sig(jg)=0 enddo do k=1,nmtl mtd=nint(a(ilmt-1+nlmt*(l-1)+k)) call rdsig(mats(ix),mtd,b,a(isg)) do jg=1,nunion sig(jg)=sig(jg)+a(jg-1+isg) enddo enddo go to 260 250 call rdsig(mats(ix),mts(ix),b,sig) 260 continue do ig=1,ngn csig(ig,ix)=0 do jg=1,nunion if (egt(jg).ge.egn(ig).and.egt(jg).lt.egn(ig+1)) then csig(ig,ix)=csig(ig,ix)+sig(jg)*flux(jg) endif enddo csig(ig,ix)=csig(ig,ix)/cflx(ig) enddo if (nout.eq.0) go to 320 cej if (mats(ix).ne.0) go to 330 mat=matd mf=3 mt=mts(ix) b(1)=0 b(2)=0 b(3)=0 b(4)=0 b(5)=ngn b(6)=0 ibase=6 ip=0 do ig=1,ngn ip=ip+1 b(ibase+ip)=csig(ig,ix) if (ip.ge.npage.or.ig.ge.ngn) then if (ibase.ne.0) then call listio(0,nout,0,b,nb,nwds) ibase=0 ip=0 else call moreio(0,nout,0,b,nb,ip) ip=0 endif endif enddo call asend(nout,0) 320 continue go to 210 cej 330 continue if (.not.lmf8) then call afend(nout,0) lmf8=.true. endif mat=matd mf=8 mt=5 b(1)=0.d0 b(2)=0.d0 b(3)=mats(ix) b(4)=mts(ix) b(5)=ngn b(6)=0 ibase=6 ip=0 do 350 ig=1,ngn ip=ip+1 b(ibase+ip)=csig(ig,ix) if (ip.lt.npage.and.ig.lt.ngn) go to 350 if (ibase.eq.0) go to 340 call listio(0,nout,0,b,nb,nwds) ibase=0 ip=0 go to 350 340 call moreio(0,nout,0,b,nb,ip) ip=0 350 continue 210 continue if (lmf8) call asend(nout,0) c mat=matd c c ***print cross sections in columns. nmtend=nmt1 if (nmtend.gt.4) nmtend=4 ic=0 do i=1,nmt1 matp(i)=matd if (mats(i).ne.0) then ic=ic+1 matp(i)=mats(i) endif enddo if (ic.eq.0) write(nsyso,'(/, & '' table of multigroup cross sections'',//, & '' group lower group cross section'',/, & '' no. energy flux '',4x,4(a2,i3,7x))') & (hmt,mts(i),i=1,nmtend) if (ic.gt.0) write(nsyso,'(/, & '' table of multigroup cross sections'',//, & '' group lower group cross section'',/, & '' no. energy flux '',4x,4(i4,''/'',i3,4x))') & (matp(i),mts(i),i=1,nmtend) nline=2*nmtend write(nsyso,'( & '' ----- ------ ----- '',4x,4(2a5,2x))') & ('-----',i=1,nline) do ig=1,ngn do ia=1,nmtend c(ia)=csig(ig,ia) enddo write(nsyso,'(i5,1p,6e12.4)') & ig,egn(ig),cflx(ig),(c(i),i=1,nmtend) enddo go to 510 460 if (ic.eq.0) write(nsyso,'(/, & '' group cross section'',/,'' no. '',6(a2,i3,7x))') & (hmt,mts(i),i=nmtst,nmtend) if (ic.gt.0) write(nsyso,'(/, & '' group cross section'',/, & '' no. '',6(i4,''/'',i3,4x))') & (matp(i),mts(i),i=nmtst,nmtend) nline=2*(nmtend-nmtst+1) write(nsyso,'('' ----- '',6(2a5,2x))') ('-----',i=1,nline) do ig=1,ngn izero=0 do ia=1,ndiff c(ia)=csig(ig,ia-1+nmtst) if (c(ia).ne.0.) izero=1 enddo if (izero.ne.0) then write(nsyso,'(i5,1p,6e12.4)') ig,(c(i),i=1,ndiff) endif enddo 510 if (nmt1.eq.nmtend) go to 550 nmtst=nmtend+1 ndiff=nmt1-nmtst+1 if (ndiff.gt.6) ndiff=6 nmtend=nmtst+ndiff-1 go to 460 550 if (nout.ne.0) call afend(nout,0) if (nlump.eq.0) go to 560 call releas('lump',0,a) call releas('lmt',0,a) call releas('sg',0,a) 560 return end c subroutine uniong(nendf,a) c ****************************************************************** c form union of user-s energy mesh with mfcov energy mesh. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/grpn/ign,ngn,egn(901),iprint common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) character*60 strng dimension a(*) external reserv,findex,findf,contio,listio,moreio,error,releas external sigfig c c ***initialize. nw=npage+50 call reserv('scr2',nw,iscr,a) nunmax=-1 call reserv('un',nunmax,iun,a) call findex('scr2',iscr,a) call findex('eni',ie,a) if (iverf.gt.4) go to 120 c c ***read energy mesh from mfcov. call findf(matd,mfcov,0,nendf) call contio(nendf,0,0,a(iscr),nb,nw) call contio(nendf,0,0,a(iscr),nb,nw) call listio(nendf,0,0,a(iscr),nb,nw) istart=iscr+6 neni=0 100 iend=iscr+nw-1 do i=istart,iend,2 neni=neni+1 if (neni.gt.nenimx) call error('uniong', & 'exceeded storage in mfcov energy grid.',' ') a(ie+neni-1)=a(i) enddo if (nb.eq.0) go to 110 call moreio(nendf,0,0,a(iscr),nb,nw) istart=iscr go to 100 110 do i=1,neni a(i-1+ie)=sigfig(a(i-1+ie),ndig,0) enddo c c ***unionize energy mesh. 120 j=1 ngnp1=ngn+1 k=0 do 130 i=1,ngnp1 140 if (a(ie+j-1).lt.egn(1)) go to 160 if (a(ie+j-1).le.egn(i)) go to 150 k=k+1 if (k.gt.nunmax) call error('uniong', & 'exceeded storage in union energy grid.',' ') a(iun+k-1)=egn(i) go to 130 150 k=k+1 if (k.gt.nunmax) call error('uniong', & 'exceeded storage in union energy grid.',' ') a(iun+k-1)=a(ie+j-1) j=j+1 if (j.le.neni.and.egn(i).ne.a(ie+j-2)) go to 140 if (j.le.neni.and.egn(i).eq.a(ie+j-2)) go to 130 c c ***finished with endf energies in=i go to 170 c c ***treat endf energies below first group boundary 160 if (j.eq.neni) go to 130 j=j+1 go to 140 130 continue c c ***finished if all ngn energies are used, as higher mfcov c ***energies are not of interest. go to 200 c c ***all mfcov energies used, some ngn energies left. 170 do i=in,ngnp1 if (egn(i).ne.a(iun+k-1)) then k=k+1 if (k.gt.nunmax) call error('uniong', & 'exceeded storage in union energy grid.',' ') a(iun+k-1)=egn(i) endif enddo 200 nunion=k-1 do i=2,k if (a(iun+i-1).le.a(iun+i-2)) then write(strng,'(1p,e12.4,'' le '',1p,e12.4)') & a(iun+i-1),a(iun+i-2) call error('uniong','union energies out of order',strng) endif enddo call releas('scr2',0,a) call releas('un',k,a) c ***release endf/b grid call releas('eni',0,a) return end c subroutine colaps(a) c ****************************************************************** c collapse (or expand) all mts on unit ngout to the union grid, c and write the new data onto a new gout tape (ngout=-10). c method assumes the cross section and the flux are constant c in energy within an input group. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/eunits/ntape(4),ngout,nstan,nscr(3) cej common/ewght/iwt character*60 strng common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension a(*) data nz/1/, nt/1/, nl/1/, ngg/0/ data big/1.d10/ zero=0 c cej if (iwt.ne.0) call egnwtf(a) ntp=-10 matn=0 nun1=nunion+1 call repoz(ngout) call repoz(ntp) nwscr=2*npage+50 call reserv('scr',nwscr,iscr,a) call findex('un',iun,a) nsh=0 call tpidio(ngout,ntp,0,a(iscr),nb,nw) c c ***loop over tape 110 call contio(ngout,0,0,a(iscr),nb,nw) if (math.eq.-1) go to 400 if (mfh.ne.1.or.mth.ne.451) & call error('colaps','did not find expected mf1, mt451.',' ') if (math.ne.matn) go to 120 c ***skip later temperatures for this material call tomend(ngout,0,0,a(iscr)) go to 110 120 ntw=n2h a(iscr+5)=1 call contio(0,ntp,0,a(iscr),nb,nw) if (matn.ne.0) call releas('ela',-1,a) matn=math nsigz=l2h call listio(ngout,0,0,a(iscr),nb,nw) is=iscr ng=l1h do while (nb.ne.0) is=is+nw if (is-iscr+1.gt.nwscr) & call error('colaps','storage exceeded.',' ') call moreio(ngout,0,0,a(is),nb,nw) enddo ng1=ng+1 call reserv('ela',ng1,iela,a) is=iscr+5+ntw+nsigz do i=1,ng1 a(i-1+iela)=sigfig(a(i+is),ndig,0) enddo if (iread.eq.1) go to 155 cej etop=sigfig(2.d7,ndig,0) c if (a(iela+ng).eq.etop) go to 155 a(iela+ng)=etop write(strng,'(''since iread='',i2)') iread call mess('colaps', & 'resetting top ngout group bound to 2.000e+07',strng) 155 continue cej if (a(iela).gt.a(iun).or.a(iela+ng).lt.a(iun+nunion)) & call error('colaps', & 'ngout group structure does not span union grid.',' ') a(iscr+2)=nunion a(iscr+3)=ngg a(iscr+4)=nt+nz+nun1+1 a(iscr+5)=0 a(iscr+6)=0 a(iscr+7)=big do i=1,nun1 a(i+7+iscr)=a(i-1+iun) enddo a(iscr+8+nun1)=0 nw=3+nun1 call listio(0,ntp,0,a(iscr),nb,nw) is=iscr do while (nb.ne.0) is=is+nw if (is-iscr+1.gt.nwscr) & call error('colaps','storage exceeded.',' ') call moreio(0,ntp,0,a(is),nb,nw) enddo call afend(ntp,0) call tofend(ngout,0,0,a(iscr)) c c ***loop over all sections of this mat 210 call contio(ngout,0,0,a(iscr),nb,nw) if (math.eq.0) go to 390 cej if (mfh.eq.5.and.mth.eq.18) go to 300 cej if (mfh.ge.4) go to 380 if (mfh.eq.0.or.mth.eq.0) go to 210 a(iscr+5)=nunion call contio(0,ntp,0,a(iscr),nb,nw) nl=nint(a(iscr+2)) nz=nint(a(iscr+3)) if (nl.ne.1.or.nz.ne.1) call error('colaps', & 'not coded for multiple sigma zeroes or legendre orders.',' ') ib=0 inuf=0 if (mth.eq.452.or.mth.eq.455.or.mth.eq.456) inuf=1 c c ***skip over low energy groups in input grid. ea3=0 220 call listio(ngout,0,0,a(iscr),nb,nw) jg=n2h flxa=a(iscr+6) xnua=a(iscr+7) siga=a(iscr+7+inuf) ea1=ea3 ea2=a(iela-1+jg) ea3=a(iela+jg) if (ea3.le.a(iun)) go to 220 c c ***loop over output groups 230 ib=ib+1 xnub=0 sigb=0 flxb=0 el=a(iun-1+ib) 250 if (ea2.gt.a(iun+ib)) go to 280 if (ea2.gt.el) el=ea2 er=a(iun+ib) if (ea3.lt.er) er=ea3 flux=flxa*(er-el)/(ea3-ea2) xnub=xnub+siga*xnua*flux sigb=sigb+siga*flux flxb=flxb+flux if (ea3.gt.a(iun+ib)) go to 280 if (ea3.eq.a(iun+ib).and.ib.ge.nunion) go to 280 call listio(ngout,0,0,a(iscr),nb,nw) jg=n2h flxa=a(iscr+6) xnua=a(iscr+7) siga=a(iscr+7+inuf) ea1=ea3 ea2=a(iela-1+jg) ea3=a(iela+jg) el=ea1 if (ea1.eq.a(iun+ib)) go to 280 go to 250 c c ***write results for this group 280 if (sigb.eq.zero.and.ib.lt.nunion) go to 230 nw=2+inuf temp=0 a(iscr)=temp a(iscr+1)=0 a(iscr+2)=nw a(iscr+3)=1 a(iscr+4)=nw a(iscr+5)=ib a(iscr+6)=flxb a(iscr+7)=0 a(iscr+7+inuf)=0 if (sigb.ne.zero.and.flxb.ne.zero) then a(iscr+7)=xnub/sigb a(iscr+7+inuf)=sigb/flxb endif call listio(0,ntp,0,a(iscr),nb,nw) if (ib.lt.nunion) go to 230 call tosend(ngout,0,0,a(iscr)) call asend(ntp,0) cej go to 210 cej c ***fission spectrum (chi) 300 continue call repoz(ngout) call findf(matd,3,18,ngout) iscr18=iscr iscr=iscr+ng1 do i=iscr18,iscr18+ng1-1 a(i)=0.d0 enddo call contio(ngout,0,0,a(iscr),nb,nw) 310 call listio(ngout,0,0,a(iscr),nb,nw) jg=n2h a(iscr18+jg-1)=a(iscr+6) if (jg.lt.ng) go to 310 call findf(matd,5,18,ngout) call contio(ngout,0,0,a(iscr),nb,nw) a(iscr+5)=nunion call contio(0,ntp,0,a(iscr),nb,nw) ib=0 jg=0 ea3=0.d0 call listio(ngout,0,0,a(iscr),nb,nw) iscr0=iscr+nw 320 jg=jg+1 flxa=a(iscr18+jg-1) chia=a(iscr+5+jg) ea1=ea3 ea2=a(iela-1+jg) ea3=a(iela+jg) if (ib.eq.0) then if (ea3.le.a(iun)) go to 320 else el=ea1 if (ea1.eq.a(iun+ib)) go to 350 go to 340 endif 330 ib=ib+1 flxb=0.d0 chib=0.d0 el=a(iun-1+ib) 340 if (ea2.gt.a(iun+ib)) go to 350 if (ea2.gt.el) el=ea2 er=a(iun+ib) if (ea3.lt.er) er=ea3 flux=flxa*(er-el)/(ea3-ea2) chib=chib+chia*flux flxb=flxb+flux if (ea3.gt.a(iun+ib)) go to 350 if (ea3.eq.a(iun+ib).and.ib.ge.nunion) go to 350 go to 320 350 if (chib.eq.0.and.ib.lt.nunion) go to 330 nw=2 nwl=8 temp=0.d0 a(iscr0)=temp a(iscr0+1)=0.d0 a(iscr0+2)=nw a(iscr0+3)=1 a(iscr0+4)=nw a(iscr0+5)=ib a(iscr0+6)=flxb a(iscr0+7)=0.d0 if (chib.gt.0.and.flxb.gt.0) a(iscr0+7)=chib/flxb call listio(0,ntp,0,a(iscr0),nb,nw) if (ib.lt.nunion) go to 330 call tosend(ngout,0,0,a(iscr)) call asend(ntp,0) 380 call tomend(ngout,0,0,a(iscr)) call afend(ntp,0) 390 call amend(ntp,0) go to 110 c c ***finished 400 call atend(ntp,0) call repoz(ngout) call closz(ngout) c c ***now redefine ngout to be the colaps output tape ngout=ntp call repoz(ngout) call releas('scr',-1,a) return end c subroutine gridd(neki,a) c ****************************************************************** c read through mfcov in version 5 or 6 format and extract the union c energy grid for the derivation relations (nc-type sub-subsections c with lty=0), construct the matrix of derivation coefficients c and extract the union energy grid from ni-type sub-subsections c for fine-group covariance calculations. c ****************************************************************** implicit real*8 (a-h,o-z) common/mainio/nsysi,nsyso,nsyse,ntty common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr(3) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/util/npage,iverf common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) cej common/err4/legord,irespr,ifissp character*60 strng1,strng2 dimension a(*) dimension el(50),eh(50),nmtr(60),imtr(60),jak(60) data nxmax/250/, irmax/60/ c external merge data small/1.d-10/ data big/1.d10/ zero=0 c c ***allocate storage and initialize. if (iread.ne.1) then nwak=irmax*nmtmax*2 call reserv('ak',nwak,iak,a) endif nwscr=2*npage+50 call reserv('scr',nwscr,iscr,a) call reserv('x',nxmax,ix,a) call findex('eni',ieni,a) if (iread.eq.0) call findex('ak',iak,a) call findex('scr',iscr,a) call findex('x',ix,a) ix1=ix-1 neki=0 neni=0 ir=0 nmtt=nmt1 call repoz(nendf) call tpidio(nendf,0,0,a(iscr),nb,nw) call findf(matd,mfcov,0,nendf) c c ***loop over sections. 110 call contio(nendf,0,0,a(iscr),nb,nw) if (mf.eq.0.and.iread.eq.1) go to 610 if (mf.eq.0) go to 450 c ***ignore components of a lumped reaction cej if (mfcov.eq.35) then nsub=n1h else nsub=n2h endif c if (nsub.eq.0) go to 410 if (iread.ne.1) go to 130 do 120 i=1,nmt if (mt.eq.mts(i)) go to 160 120 continue go to 420 130 nmt=nmt+1 nmt1=nmt1+1 if (nmt1.gt.nmtmax) call error('gridd', & 'too many reaction types.',' ') if (iread.eq.2) then do i=1,nmtt mats(nmt+nmtt+1-i)=mats(nmt+nmtt-i) mts(nmt+nmtt+1-i)=mts(nmt+nmtt-i) enddo endif mats(nmt)=0 mts(nmt)=mt 160 continue cej if (mfcov.eq.34) then if (nsub.gt.1) call error('gridd', & 'not coded for nmt1>1 of mf=34',' ') ltt=l2h call contio(nendf,0,0,a(iscr),nb,nw) mat2=l1h mt2=l2h nl=n1h nl1=n2h nsub=nl*nl1 if (mt.eq.mt2) nsub=nl*(nl+1)/2 endif c c ***loop over subsections. do 300 isub=1,nsub cej if (mfcov.ne.35) call contio(nendf,0,0,a(iscr),nb,nw) if (mfcov.eq.34.and.mt.eq.0) go to 110 if (mfcov.eq.34) then mat1=mat2 mt1=mt2 ld=l1h ld1=l2h elseif (mfcov.eq.35) then mat1=0 mt1=mt else mat1=l1h mt1=l2h endif c if (mt1.eq.0) call error('grid','illegal mt1=0.',' ') iok=1 if (iread.gt.0) go to 161 if (mat1.gt.0) go to 175 go to 180 161 if (iread.gt.1) go to 165 if (mat1.gt.0) go to 175 do 162 i=1,nmt if (mt1.eq.mts(i)) go to 180 162 continue go to 175 165 if (mat1.eq.0) go to 180 nmtp=nmt+1 do 170 i=nmtp,nmt1 if (mat1.eq.mats(i).and.mt1.eq.mts(i)) go to 180 170 continue c ***covariance matrix for mat1-mt1 is present in mfcov , but is c ***not wanted by user. flag this case by setting iok=0, in order c ***to avoid adding unnecessary points to the union energy grid. 175 iok=0 180 continue cej if (mfcov.eq.35) then nc=0 ni=1 else nc=n1h ni=n2h endif c if (nc.eq.0) go to 290 c c ***loop over nc sub-subsections do 210 ic=1,nc call contio(nendf,0,0,a(iscr),nb,nw) lty=l2h if (lty.gt.3) go to 960 call listio(nendf,0,0,a(iscr),nb,nw) l=iscr 220 do while (nb.ne.0) l=l+nw call moreio(nendf,0,0,a(l),nb,nw) enddo continue if (iok.eq.0) go to 210 cej if (mfcov.eq.34) then if (ld.gt.legord.or.ld1.gt.legord) go to 210 endif nt=2 call merge(a(iscr),nt,nxmax,a(ieni),neni,nenimx,ndig,zero,zero) elh=sigfig(c1h,ndig,0) ehh=sigfig(c2h,ndig,0) if (lty.eq.0) go to 260 matstd=l1h mtstd=l2h if (nstan.eq.0) go to 950 if (lty.eq.1) call grist(matstd,mtstd,nxmax,elh,ehh,a) zero=0 if (lty.eq.2) call grist(matstd,mtstd,nxmax,zero,zero,a) go to 210 260 continue if (iread.eq.1) go to 210 ir=ir+1 if (ir.gt.irmax) call error('grid', & 'too many formulas in nc-type sub-subsections with lty=0.', & ' ') imtr(ir)=nmt el(ir)=elh eh(ir)=ehh nmtr(ir)=n2h if (n2h.gt.nmtmax) call error('grid', & 'too many mt-numbers in nc-type subsections with lty=0.', & ' ') c c ***save the derivation formula for later processing. jtop=n1h jmax=2*nmtmax jaki=iak+jmax*(ir-1)-1 do j=1,jtop a(j+jaki)=a(j+5+iscr) enddo nt=2 call merge(a(iscr),nt,nxmax,ek,neki,nkmax,ndig,zero,zero) 210 continue 290 if (ni.eq.0) go to 300 c c ***loop over ni sub-subsections do 350 ii=1,ni call listio(nendf,0,0,a(iscr),nb,nw) l=iscr do while (nb.ne.0) l=l+nw call moreio(nendf,0,0,a(l),nb,nw) enddo continue cej if (mfcov.eq.35.and.ifissp.eq.-1) then if (c1h.le.2.d+5.and.c2h.ge.2.d+5) ifissp=isub endif c if (iok.eq.0) go to 350 cej if (mfcov.eq.34) then if (ld.gt.legord.or.ld1.gt.legord) go to 350 endif nx=n2h lb=l2h if (lb.lt.5.or.lb.eq.8) go to 325 call merge(a(iscr+6),nx,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) if (lb.eq.5) go to 350 if (mfcov.eq.35.and.lb.eq.7) go to 350 nec=(n1h-1)/nx iloc=iscr+6+nx call merge(a(iloc),nec,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) go to 350 325 continue do i=1,nx a(i+ix1)=a(2*i+4+iscr) enddo nl=l1h nx=nx-nl 340 call merge(a(ix),nx,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) call merge(a(ix+nx),nl,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) 350 continue 300 continue 410 call contio(nendf,0,0,a(iscr),nb,nw) go to 110 420 call tosend(nendf,0,0,a(iscr)) go to 110 c c ***set up coefficients for derived cross sections. 450 continue call releas('eni',neni,a) call repoz(nendf) call tpidio (nendf,0,0,a(iscr),nb,nw) nek=neki-1 if (neki.eq.0) nek=1 nmt2=nmt1*nmt1 nw=nek*nmt2 call reserv('kxy',nw,ikxy,a) do ik=1,nek do i=1,nmt1 do j=1,nmt1 ja=ikxy+j-1+nmt1*(i-1)+nmt2*(ik-1) a(ja)=0 if (i.eq.j) a(ja)=1 enddo enddo enddo if (neki.gt.0) go to 500 ek(1)=small ek(2)=big go to 600 c c ***reconstruct full akxy table. 500 nr=ir do 590 ir=1,nr irs=ir ilo=0 510 ilo=ilo+1 if (el(ir).eq.ek(ilo)) go to 520 go to 510 520 ihi=ilo 530 ihi=ihi+1 if (eh(ir).eq.ek(ihi)) go to 540 go to 530 540 ihi=ihi-1 ntr=nmtr(ir) do 560 nim=1,ntr ixm=nint(a(iak+jmax*(ir-1)+2*nim-1)) do 550 i=1,nmt jak(nim)=i if (ixm.eq.mts(i)) go to 560 550 continue write(strng1, & '(''mt'',i4,'' referenced in derivation formula'')') ixm write(strng2, & '(''for range '',i2,'' does not appear in mfcov'')') irs call error('gridd',strng1,strng2) call findex('ak',iak,a) 560 continue ider=imtr(ir) nder=nmtr(ir) do i=ilo,ihi ja=ikxy+nmt2*(i-1)+nmt1*(ider-1)-1 ka=iak-2+jmax*(ir-1) do j=1,nder jakj=jak(j) a(jakj+ja)=a(2*j+ka) enddo a(ider+ja)=0 enddo 590 continue 600 call releas('ak',0,a) 610 call releas('scr',0,a) call releas('x',0,a) return c c ***error messages. 950 write(nsyso,50) mt,mt1,matstd,mtstd write(nsyse,50) mt,mt1,matstd,mtstd 50 format(/,' ***error in grid***cannot calculate covariances of ', & 'reaction mt=',i3,' with',/,4x,'mt1=',i3, & ' because nstan=0. to proceed, mount an endf tape ', & 'containing',/,4x,'the standard', & ' reaction (matstd=',i4,', mtstd=',i3,') on unit nstan.',/, & 4x,'if necessary matstd and mtstd can be redefined on input ', & 'card 11.') call error('gridd',' ',' ') 960 write(nsyso,60) mt,mat1,mt1,lty write(nsyse,60) mt,mat1,mt1,lty 60 format(/,' ***error in grid***covariances of reaction mt=',i3, & ' with (mat1=',i4,' mt1=',i3,')',/, & 4x,'cannot be calculated. not coded for lty=',i3) call error('gridd',' ',' ') return end c subroutine resprp(nwscr,a) c ****************************************************************** c prepare tables containing the resonance-parameter contributions c to coarse-group covariances. c ****************************************************************** c (ERRORJ) c Many parts are modefied. c ****************************************************************** implicit real*8 (a-h,o-z) cej parameter (nparmx=60,igumax=20) common/err0/nresg cej common/err3/ifresr,ifunrs common/eunits/nendf,nunit(8) common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/grpn/ign,ngn,egn(901),iprint common/ewght/iwt common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/util/npage,iverf common/pic/pi common/cwav/cwaven common/amnc/amassn character*60 strng1,strng2 dimension a(*) dimension s(3,5),cov(5,5),rcov(nparmx,nparmx),us(3,nparmx,igumax) equivalence (cov,rcov),(s,us) zero=0 c nresg=0 cej ifresr=0 ifunrs=0 if (mfcov.ne.33.and.mfcov.ne.34) return c if (mf32.eq.0) return call findex('cff',icff,a) call findex('cfg',icfg,a) call findex('cgg',icgg,a) call findex('cee',icee,a) call findex('cef',icef,a) call findex('ceg',iceg,a) call findex('ctt',ictt,a) call findex('uff',iuff,a) call findex('ufg',iufg,a) call findex('ugg',iugg,a) call findex('uee',iuee,a) call findex('scr',iscr,a) call findex('cflx',icflx,a) c c ***initialize call repoz(nendf) call tpidio(nendf,0,0,a(iscr),nb,nw) do 100 ig=1,ngn a(icff-1+ig)=0. a(icfg-1+ig)=0. a(icgg-1+ig)=0. a(icef-1+ig)=0. a(iceg-1+ig)=0. a(icee-1+ig)=0. a(ictt-1+ig)=0. a(iuff-1+ig)=0. a(iufg-1+ig)=0. a(iugg-1+ig)=0. a(iuee-1+ig)=0. 100 continue call findf(matd,32,151,nendf) call contio(nendf,0,0,a(iscr),nb,nw) nis=n1h c c ***loop over isotopes do 110 is=1,nis call contio(nendf,0,0,a(iscr),nb,nw) abn=c2h ner=n1h lfw=0 if (iverf.eq.6) lfw=n1h c c ***loop over energy ranges do 115 ie=1,ner call contio(nendf,0,0,a(iscr),nb,nw) el=c1h eh=c2h lru=l1h lrf=l2h if (lru.eq.1.and.lrf.ge.1.and.lrf.le.2) go to 116 if (lru.eq.2.and.lrf.ge.1.and.lrf.le.2) go to 116 write(strng2,'(''lrf='',i4,'' lru='',i4)') lrf,lru call error('resprp', & 'illegal or unrecognized data structure in mf32',strng2) 116 continue if (lru.eq.1.and.lrf.eq.1) call mess('resprp', & 'for resolved resonance of single level breit-wigner,', & 'contributions to total and elastic was not coded.') nro=n1h if (nro.ne.0) then write(strng2,'(''nro='',i4)') nro call error('resprp', & 'illegal or unrecognized data structure in mf32', & strng2) endif naps=n2h call contio(nendf,0,0,a(iscr),nb,nw) spi=c1h spifac=1/(2*spi+1) ap=c2h lcomp=l2h if (lcomp.ne.0) then write(strng2,'(''lcomp='',i4)') lcomp call error('resprp', & 'illegal or unrecognized data structure in mf32', & strng2) endif nls=n1h if (lru.eq.2) go to 400 c c ***resolved resonance parameters c c ***process all resonance parameters for this isotope do 120 nl=1,nls c ***read parameters for this l-value call listio(nendf,0,0,a(iscr),nb,nw) l=iscr 130 if (nb.eq.0) go to 140 l=l+nw call moreio(nendf,0,0,a(l),nb,nw) if ((l+nw-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') & l+nw+nb-iscr,nwscr call error('resprp','storage exceeded.',strng2) endif go to 130 140 awri=a(iscr) l=nint(a(iscr+2)) nrs=nint(a(iscr+5)) xk=cwaven*awri/(awri+1.d+0) x2=2.*(pi/xk)**2 aw=amassn*awri ra=0.123d+0*aw**(1./3.)+0.08d+0 if (naps.eq.1) ra=ap iloc=iscr+6 c c ***loop over resonances do 150 nr=1,nrs er=a(iloc) aj=a(iloc+1) gt=a(iloc+2) rgt=1/gt gn=a(iloc+3) gg=a(iloc+4) gf=a(iloc+5) c ***index energy group if (er.lt.egn(1)) go to 155 if (er.ge.egn(ngn+1)) go to 120 do 160 i=1,ngn ig=i if (er.lt.egn(i+1)) go to 170 160 continue c c ***calculate fission and capture covariances in group ig c ***due to this resonance 170 if (ig.gt.nresg) nresg=ig if (iwt.eq.0) go to 180 c ***retrieve user's weight function at er lord=0 call egtwtf(er,enext,idis,lord,wt,a) go to 190 c ***if weight function is unavailable, flat weight the resonance 180 wt=a(icflx-1+ig)/(egn(ig+1)-egn(ig)) 190 g=(aj+.5)*spifac c=abn*wt*x2*g/er c ***estimate fission and capture cross section contributions c ***from this resonance sf=c*gn*gf*rgt sg=c*gn*gg*rgt se=c*gn*gn*rgt c ***calculate sensitivity of sf, sg and se to resonance parameters s(1,1)=-sf/er s(2,1)=-sg/er s(3,1)=-se/er s(1,2)=sf*(1./gn-rgt) s(2,2)=sg*(1./gn-rgt) s(3,2)=se*(2./gn-rgt) s(1,3)=-sf*rgt s(2,3)=sg*(1./gg-rgt) s(3,3)=-se*rgt s(1,4)=0. if (gf.gt.0.) s(1,4)=sf*(1./gf-rgt) s(2,4)=-sg*rgt s(3,4)=-se*rgt s(1,5)=sf/(aj+.5) s(2,5)=sg/(aj+.5) s(3,5)=se/(aj+.5) c ***retrieve resonance parameter covariances from the list record do 200 i=1,5 do 200 j=1,5 200 cov(i,j)=0. iloc=iloc+6 cov(1,1)=a(iloc) do 210 i=2,5 do 210 j=2,i iloc=iloc+1 cov(i,j)=a(iloc) 210 cov(j,i)=a(iloc) c ***check covariance matrix for validity if (iverf.lt.6) go to 214 do 212 i=1,5 id=i jd=5 if (cov(i,5).ne.0.) go to 235 212 continue 214 continue do 220 i=1,5 id=i jd=i if (cov(i,i).lt.0.) go to 235 220 continue do 230 i=1,5 id=i do 230 j=1,5 jd=j if (cov(i,i).gt.0.and.cov(j,j).gt.0.) go to 240 if (cov(i,j).ne.0.) go to 235 go to 230 240 corr=cov(i,j)/sqrt(cov(i,i)*cov(j,j)) if (abs(corr).lt.1.0001) go to 230 if (abs(corr).gt.2.) go to 235 write(strng1,'(''correlation coeff='',f8.4)') & corr write(strng2, & '(''for res parameters '',i1,'' and '',i1, & ''at er='',1p,e12.4)')i,j,er call mess('resprp',strng1,strng2) 230 continue go to 236 235 write(strng2, & '(''res parameters '',i1,'' and '',i1, & '' at er='',1p,e12.4)')id,jd,er call error('resprp','bad covariance data for',strng2) c c ***calculate cross section covariances by propagation of errors 236 continue do 250 i=1,5 do 250 j=1,5 a(icff-1+ig)=a(icff-1+ig)+s(1,i)*s(1,j)*cov(i,j) a(icfg-1+ig)=a(icfg-1+ig)+s(1,i)*s(2,j)*cov(i,j) a(icgg-1+ig)=a(icgg-1+ig)+s(2,i)*s(2,j)*cov(i,j) a(icef-1+ig)=a(icef-1+ig)+s(1,i)*s(3,j)*cov(i,j) a(iceg-1+ig)=a(iceg-1+ig)+s(2,i)*s(3,j)*cov(i,j) a(icee-1+ig)=a(icee-1+ig)+s(3,i)*s(3,j)*cov(i,j) 250 continue a(ictt-1+ig)=a(icee-1+ig)+a(icff-1+ig)+a(icgg-1+ig) go to 150 155 iloc=iloc+16 150 iloc=iloc+2 120 continue ifresr=1 go to 115 c c ***unresolved average breit-wigner resonance parameter c c ***process averaged l- and j-states resonance parameters for this c ***isotope 400 continue emid=exp(log(el*eh)/2.d+0) do 410 i=1,ngn igmin=i 410 if (el.lt.egn(i+1)) go to 411 write(strng2,'(''el='',1pe12.5)') el call error('resprp','unresolved energy range was illegal.', & strng2) 411 do 412 i=igmin,ngn igmax=i 412 if (eh.lt.egn(i+1)) go to 413 write(strng2,'(''eh='',1pe12.5)') eh call error('resprp','unresolved energy range was illegal.', & strng2) 413 continue if (igmax.gt.nresg) nresg=igmax c ***read resonance parameters for each l-value iscr01=iscr do 420 nl=1,nls call listio(nendf,0,0,a(iscr01),nb,nw) 425 iscr01=iscr01+nw if (nb.eq.0) go to 420 call moreio(nendf,0,0,a(iscr01),nb,nw) if ((iscr01+nw-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') & iscr01+nw+nb-iscr,nwscr call error('resprp','storage exceeded (lru=2).', & strng2) endif go to 425 420 continue c ***read relative covariance from list record call listio(nendf,0,0,a(iscr01),nb,nw) l=iscr01 430 if (nb.eq.0) go to 435 l=l+nw call moreio(nendf,0,0,a(l),nb,nw) if ((l+nw-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') & l+nw+nb-iscr,nwscr call error('resprp','storage exceeded (lru=2).',strng2) endif go to 430 435 continue c ***retrieve relative covariance mpar=nint(a(iscr01+2)) nw=nint(a(iscr01+4)) npar=nint(a(iscr01+5)) jpar=npar/mpar if (mpar.lt.3.or.mpar.gt.5) then write(strng1,'(''mpar='',i2,'' was not coded.'')') mpar call error('resprp',strng1,' ') endif if (npar.gt.nparmx) then write(strng2,'(''npar='',i5,'' maximum='',i5)') & npar,nparmx call error('resprp', & 'storage exceeded for rel.covariance.', & strng2) endif iloc=iscr01+5 do i=1,npar do j=i,npar iloc=iloc+1 rcov(i,j)=a(iloc) rcov(j,i)=a(iloc) enddo enddo c ***check covariance matrix for validity do i=1,npar id=i jd=i if (rcov(i,i).lt.0.) go to 440 enddo go to 445 440 write(strng2,'(''res parameters '',i1,'' and '',i1)')id,jd call error('resprp','bad rel.covariance data for',strng2) 445 continue c c ***loop over l-state jscr=iscr nj0=0 do 450 nl=1,nls awri=a(jscr) l=nint(a(jscr+2)) njs6=nint(a(jscr+4)) njs=nint(a(jscr+5)) xk=cwaven*awri/(awri+1.d+0) x2=2.*(pi/xk)**2 aw=amassn*awri ra=0.123d+0*aw**(1./3.)+0.08d+0 if (naps.eq.1) ra=ap iloc=jscr+6 c c ***loop over j-states do 460 nj=1,njs d=a(iloc) aj=a(iloc+1) gnox=a(iloc+2) gg=a(iloc+3) gf=a(iloc+4) gx=a(iloc+5) iloc=iloc+6 nj0=nj0+1 nj1=mpar*(nj0-1) g=(aj+0.5d+0)*spifac cc=abn*g*x2/d c0=abn*x2 do 470 ig=igmin,igmax e1=egn(ig) e2=egn(ig+1) if (ig.eq.igmin.and.ig.eq.igmax) then f=(eh-el)/(egn(ig+1)-egn(ig)) e1=el e2=eh elseif (ig.eq.igmin) then f=(egn(ig+1)-el)/(egn(ig+1)-egn(ig)) e1=el elseif (ig.eq.igmax) then f=(eh-egn(ig))/(egn(ig+1)-egn(ig)) e2=eh else f=1.d+0 endif em=(e2+e1)*0.5d+0 if (iwt.eq.0) then wt=a(icflx-1+ig)/emid else lord=0 call egtwtf(em,enext,idis,lord,wt,a) endif wt=wt*f rhoc=xk*sqrt(e1)*ap call facphi(l,rhoc,phi1) rhoc=xk*sqrt(e2)*ap call facphi(l,rhoc,phi2) phi=(phi1+phi2)*0.5d+0 c ***correction of penetrability for reduced neutron width if (l.eq.0) then gno=gnox*sqrt(em) elseif (l.eq.1) then rho=xk*sqrt(em)*ra gno=gnox*rho**2/(1.d+0+rho**2)*sqrt(em) elseif (l.eq.2) then rho=xk*sqrt(em)*ra gno=gnox*rho**4/(9.d+0+3.d+0*rho**2+rho**4)* & sqrt(em) endif gt=gno+gg+gf+gx rgn=1.d+0/gno rgt=1.d+0/gt c=cc*gno/gt/emid c ***estimate cross section contributions sf=c*wt*gf sg=c*wt*gg se=c*wt*gno se1=c0*wt*2.d+0*gno*sin(phi)**2/emid c ***calculate sensitivity, s(i,j) c i=1/2/3=fission/capture/elastic c j=1/2/3/4/5=d/gn/gf/gg/gx igu=ig-igmin+1 if (igu.gt.igumax) then write(strng2,'(''igu='',i5,'' maximum='',i5)') & igu,igumax call error('resprp', & 'storage exceeded for sensitivities.' & ,strng2) endif us(1,nj1+1,igu)=-sf/d us(2,nj1+1,igu)=-sg/d us(3,nj1+1,igu)=-se/d if (mpar.eq.1) go to 470 us(1,nj1+2,igu)=sf*(rgn-rgt) us(2,nj1+2,igu)=sg*(rgn-rgt) us(3,nj1+2,igu)=se*(2.d+0*rgn-rgt) if (mpar.eq.2) go to 470 us(1,nj1+3,igu)=-sf*rgt us(2,nj1+3,igu)=sg*(1.d+0/gg-rgt) us(3,nj1+3,igu)=-se*rgt if (mpar.eq.3) go to 470 if (mpar.eq.4.and.lfw.eq.0) then us(1,nj1+4,igu)=-sf*rgt us(2,nj1+4,igu)=-sg*rgt us(3,nj1+4,igu)=-se*rgt go to 470 endif us(1,nj1+4,igu)=0.d+0 if (gf.gt.0.) us(1,nj1+4,igu)=sf*(1.d+0/gf-rgt) us(2,nj1+4,igu)=-sg*rgt us(3,nj1+4,igu)=-se*rgt if (mpar.eq.4) go to 470 us(1,nj1+5,igu)=-sf*rgt us(2,nj1+5,igu)=-sg*rgt us(3,nj1+5,igu)=-se*rgt 470 continue 460 continue jscr=jscr+njs6+6 450 continue c c ***calculate relative covariance cross sections do 480 ig=igmin,igmax igu=ig-igmin+1 do 490 i=1,npar do 490 j=1,npar a(iuff-1+ig)=a(iuff-1+ig) + & us(1,i,igu)*us(1,j,igu)*rcov(i,j) a(iufg-1+ig)=a(iufg-1+ig) + & us(1,i,igu)*us(2,j,igu)*rcov(i,j) a(iugg-1+ig)=a(iugg-1+ig) + & us(2,i,igu)*us(2,j,igu)*rcov(i,j) a(iuee-1+ig)=a(iuee-1+ig) + & us(3,i,igu)*us(3,j,igu)*rcov(i,j) 490 continue 480 continue ifunrs=1 c c ***finished with this material 115 continue 110 continue return end c subroutine rescon(ix,ixp,igmin,igmax,isuma,izero,a) c ****************************************************************** c add the contributions from file 32 (see subroutine resprp) c to the covariance previously calculated from file 33 c for this range of coarse groups. c increment diagonal term only (igp=ig). c ****************************************************************** c (ERRORJ) c Many parts were revised from original routine in ERRORR. c ****************************************************************** implicit real*8 (a-h,o-z) common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err0/nresg common/grpn/ign,ngn,egn(901),iprint cej common/err3/ifresr,ifunrs common/err4/legord,irespr,ifissp c dimension a(*) zero=0 c if (mats(ixp).ne.0) return if (igmin.gt.nresg) return call findex('cff',icff,a) call findex('cfg',icfg,a) call findex('cgg',icgg,a) cej call findex('cee',icee,a) call findex('cef',icef,a) call findex('ceg',iceg,a) call findex('ctt',ictt,a) call findex('uff',iuff,a) call findex('ufg',iufg,a) call findex('ugg',iugg,a) call findex('uee',iuee,a) call findex('uef',iuef,a) call findex('ueg',iueg,a) call findex('utt',iutt,a) call findex('sum',isum,a) c itp=0 if (mts(ix).eq.18 .and.mts(ixp).eq.18 ) itp=1 if (mts(ix).eq.18 .and.mts(ixp).eq.102) itp=2 if (mts(ix).eq.102.and.mts(ixp).eq.102) itp=3 cej if (mts(ix).eq.2 .and.mts(ixp).eq.2 ) itp=4 if (mts(ix).eq.2 .and.mts(ixp).eq.18 ) itp=5 if (mts(ix).eq.2 .and.mts(ixp).eq.102) itp=6 if (mts(ix).eq.1 .and.mts(ixp).eq.1 ) itp=7 c if (itp.eq.0) return iglast=igmax if (iglast.gt.nresg) iglast=nresg jpos=-ngn*igmin cej if (ifresr.eq.0) go to 1000 go to (100,200,300,400,500,600,700),itp c c ***fission/fission 100 igind=0 do 110 ig =1,iglast do 110 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto110 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(icff-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(icff-1+igind) endif 110 continue go to 1000 c c ***fission/capture 200 do 210 ig =1,ngn do 210 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 210 a(isuma+ipos)=a(isuma+ipos)+a(icfg+igd) go to 1000 c c ***capture/capture 300 igind=0 do 310 ig =1,iglast do 310 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto310 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(icgg-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(icgg-1+igind) endif 310 continue go to 1000 c c ***elastic/elastic 400 igind=0 do 410 ig =1,iglast do 410 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto410 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(icee-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(icee-1+igind) endif 410 continue go to 1000 c c ***elastic/fission 500 do 510 ig =1,ngn do 510 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 510 a(isuma+ipos)=a(isuma+ipos)+a(icef+igd) go to 1000 c c ***elastic/capture 600 do 610 ig =1,ngn do 610 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 610 a(isuma+ipos)=a(isuma+ipos)+a(iceg+igd) go to 1000 c c ***total/total 700 igind=0 do 710 ig =1,iglast do 710 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto710 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(ictt-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(ictt-1+igind) endif 710 continue go to 1000 c c ***unresolved resonance contribution 1000 continue if (ifunrs.eq.0) go to 2000 if (irespr.eq.1) go to 1090 c ***convert to absolute covariance from relative if (ifunrs.eq.1) then ifunrs=2 iif=0 iig=0 do i=1,nmt if (mts(i).eq.2) go to 1010 enddo go to 1020 1010 ii=isum+ngn*(i-1) igind=0 do ig=1,ngn do ig2=ig,ngn igind=igind+1 if (a(ii+ig-1).le.0.) then a(iuee-1+igind)=0.d+0 else a(iuee-1+igind)=a(iuee-1+igind) & *a(ii+ig-1)*a(ii+ig2-1) endif enddo enddo 1020 do i=1,nmt if (mts(i).eq.18) go to 1030 enddo go to 1040 1030 ii=isum+ngn*(i-1) iif=ii igind=0 do ig=1,ngn do ig2=ig,ngn igind=igind+1 if (a(ii+ig-1).le.0.) then a(iuff-1+igind)=0.d+0 else a(iuff-1+igind)=a(iuff-1+igind) & *a(ii+ig-1)*a(ii+ig2-1) endif enddo enddo 1040 do i=1,nmt if (mts(i).eq.102) go to 1050 enddo go to 1060 1050 ii=isum+ngn*(i-1) iig=ii igind=0 do ig=1,ngn do ig2=1,ngn if (a(ii+ig-1).le.0.) then a(iugg-1+igind)=0.d+0 else a(iugg-1+igind)=a(iugg-1+igind) & *a(ii+ig-1)*a(ii+ig2-1) endif enddo enddo 1060 if (iig.gt.0.and.iif.gt.0) then do ig=1,ngn if (a(iig+ig-1).le.0..or.a(iif+ig-1).le.0.) then a(iufg-1+ig)=0.d+0 else a(iufg-1+ig)=a(iufg-1+ig)*a(iig+ig-1)*a(iif+ig-1) endif enddo else do ig=1,ngn a(iufg-1+ig)=0.d+0 enddo endif endif 1090 continue go to (1100,1200,1300,1400,1500,1600,1700),itp c c ***fission/fission 1100 igind=0 do 1110 ig=1,iglast do 1110 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1110 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iuff-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iuff-1+igind) endif 1110 continue go to 2000 c c ***fission/capture 1200 do 1210 ig =1,ngn do 1210 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 1210 a(isuma+ipos)=a(isuma+ipos)+a(iufg+igd) go to 2000 c c ***capture/capture 1300 igind=0 do 1310 ig=1,iglast do 1310 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1310 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iugg-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iugg-1+igind) endif 1310 continue go to 2000 c c ***elastic/elastic 1400 igind=0 do 1410 ig=1,iglast do 1410 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1410 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iuee-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iuee-1+igind) endif 1410 continue go to 2000 c c ***elastic/fission 1500 do 1510 ig =1,ngn do 1510 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 1510 a(isuma+ipos)=a(isuma+ipos)+a(iuef+igd) go to 2000 c c ***elastic/capture 1600 do 1610 ig =1,ngn do 1610 ig2=1,ngn ipos=jpos+ig*ngn+ig2-1 igd=ig*ngn-ngn+ig2-1 1610 a(isuma+ipos)=a(isuma+ipos)+a(iueg+igd) go to 2000 c c ***total/total 1700 continue if (irespr.eq.0) then igind=0 do 1710 ig=1,iglast do 1710 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1710 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iuee-1+igind) & +a(iugg-1+igind) & +a(iuff-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iuee-1+igind) & +a(iugg-1+igind) & +a(iuff-1+igind) endif 1710 continue elseif (irespr.eq.1) then igind=0 do 1720 ig=1,iglast do 1720 ig2=ig,ngn igind=igind+1 if(ig.lt.igmin.or.ig2.gt.igmax)goto1720 ipos=jpos+ig*ngn+ig2-1 a(isuma+ipos)=a(isuma+ipos)+a(iutt-1+igind) if(ig.ne.ig2)then ipos=jpos+ig2*ngn+ig-1 a(isuma+ipos)=a(isuma+ipos)+a(iutt-1+igind) endif 1720 continue endif go to 2000 c c ***check for nonzero array 2000 do 2010 ig=igmin,igmax ipos=jpos+ig*(ngn+1) if (a(isuma-1+ipos).ne.0) izero=1 if (izero.eq.1) go to 2100 2010 continue c c ***finished 2100 continue return end subroutine egtflx(e,enext,idis,flux,nl,nz,a) c ****************************************************************** c retrieve or compute weighting fluxes c ****************************************************************** implicit real*8 (a-h,o-z) dimension flux(10,10) dimension tot(10) common/util/npage,iverf common/argcom/matd,mfd,mtd common/eunits/nunit(7),ntot,nscrt common/sigzer/sigz(10),nsigz dimension a(*) external egtwtf,findf,reserv,contio,gety2 data big/1.d10/ zero=0 c c ***initialize. c ***test for infinite dilution (i.e., ntot=0) if (e.gt.zero.and.ntot.eq.0) go to 120 if (e.gt.zero) go to 100 call egtwtf(e,en,idis,l,wtf,a) if (ntot.eq.0) return call findf(matd,3,1,ntot) nw=npage+50 call reserv('tot',nw,itot,a) call contio(ntot,0,0,a(itot),nb,nw) call gety2(e,enext,idis,t,ntot,a(itot)) return c c ***compute self-shielded point flux assuming flux c ***is proportional to the inverse total cross section. 100 call findex('tot',itot,a) call gety2(e,enext,idis,t,ntot,a(itot)) do iz=1,nz tot(iz)=t enddo go to 130 120 enext=big 130 do il=1,nl l=il-1 call egtwtf(e,en,idisc,l,wtf,a) if (en.lt.enext) idis=idisc if (en.lt.enext) enext=en do iz=1,nz flux(iz,il)=wtf if (ntot.ne.0) then tmin=1 tmin=tmin/1000 if (tot(iz).le.zero) tot(iz)=tmin if (il.eq.1) then flux(iz,1)=flux(iz,1)/(1+tot(iz)/sigz(iz)) else flux(iz,il)=flux(iz,il-1)/(1+tot(iz)/sigz(iz)) endif endif enddo enddo return end c subroutine egtsig(e,enext,idis,sig,a) c ****************************************************************** c retrieve the reaction cross-section defined by mfd and mtd. c remove discontinuities by moving second point up by eps. c initialize if e=0. c ****************************************************************** implicit real*8 (a-h,o-z) dimension sig(*) common/eunits/nendf,npend,nunit(7) common/argcom/matd,mfd,mtd common/sigzer/sigz(10),nsigz common/util/npage,iverf dimension a(*) external error,findf,reserv,contio,gety1,findex save nsig zero=0 c c ***initialize if (e.eq.zero) then nsig=npend mf=3 if (mfd.eq.13.or.mfd.eq.17) mf=13 mt=0 if (mtd.le.150) mt=mtd if (mtd.eq.207) mt=mtd if (mtd.ge.600.and.mtd.le.899) mt=mtd if (mtd.eq.251.or.mtd.eq.252.or.mtd.eq.253) mt=2 if (mt.eq.0) call error('egtsig','mt=0.',' ') call findf(matd,mf,mt,nsig) nw=npage+50 call reserv('sig',nw,isig,a) call contio(nsig,0,0,a(isig),nb,nw) call gety1(e,enext,idis,s,nsig,a(isig)) c c ***retrieve point cross sections. else call findex('sig',isig,a) call gety1(e,enext,idis,s,nsig,a(isig)) do iz=1,nsigz sig(iz)=s enddo endif return end c subroutine grist(matstd,mtstd,nxmax,el,eh,a) c ****************************************************************** c merge the energy grid from the standard tape nstan into the union c energy grid from nendf. c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr1,nscr2,nscr3 common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/redef/nas,matb(5),mtb(5),matc(5),mtc(5) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/ety/ety1,ety2 character*60 strng dimension a(*) external findex,repoz,tpidio,mess,findf,contio,error external listio,moreio,sigfig,merge data small/1.d-10/ c call findex('scr',iscr,a) call findex('eni',ieni,a) call findex('x',ix,a) call repoz(nstan) call tpidio(nstan,0,0,a(iscr),nb,nw) c c ***redefine standard if necessary if (nas.eq.0) go to 110 do 100 i=1,nas if (matstd.ne.matb(i).or.mtstd.ne.mtb(i)) go to 100 write(strng,'(''standards reaction (,'',i4,'','',i3, & '') replaced by ('',i4,'','',i3,'')'')') & matstd,mtstd,matc(i),mtc(i) call mess('grist',strng,' ') matstd=matc(i) mtstd=mtc(i) go to 110 100 continue 110 call findf(matstd,mfcov,mtstd,nstan) call contio(nstan,0,0,a(iscr),nb,nw) nsub=n2h if (nsub.le.0) call error('grist','standards tape bad.',' ') c c ***loop over subsections do 200 il=1,nsub call contio(nstan,0,0,a(iscr),nb,nw) mat1=l1h mt1=l2h nc=n1h ni=n2h if (nc.eq.0) go to 140 c c ***read and merge energies from the nc-type sub-subsections do ic=1,nc call contio(nstan,0,0,a(iscr),nb,nw) lty=l2h call listio(nstan,0,0,a(iscr),nb,nw) do while (nb.ne.0) call moreio(nstan,0,0,a(iscr+2),nb,nw) enddo if (il.ne.1) then if (mat1.eq.matc(1).and.mt1.eq.mtc(1).and.lty.eq.3) then ety1=sigfig(c1h,ndig,0) ety2=sigfig(c2h,ndig,0) nt=2 zero=0 call merge(a(iscr),nt,nxmax,a(ieni),neni,nenimx,ndig, & zero,zero) endif endif enddo c c ***read and merge the energies from the ni sub-subsections 140 if (ni.eq.0.and.il.eq.1) then write(strng,'(''matstd='',i4,'', mtstd='',i3)') matstd,mtstd call error('grist','illegal ni=0 in the standard',strng) endif if (ni.eq.0) go to 200 do 150 ii=1,ni call listio(nstan,0,0,a(iscr),nb,nw) l=iscr do while (nb.ne.0) l=l+nw call moreio(nstan,0,0,a(l),nb,nw) enddo continue if (il.gt.1) go to 150 lb=l2h nx=n2h if (lb.eq.0) call error('grist','illegal lb=0.',' ') if (lb.lt.5.or.lb.eq.8) go to 175 call merge(a(iscr+6),nx,nxmax,a(ieni),neni,nenimx,ndig, & el,eh) if (lb.eq.5) go to 150 nec=(n1h-1)/nx iloc=iscr+6+nx call merge(a(iloc),nec,nxmax,a(ieni),neni,nenimx,ndig,el,eh) go to 150 175 continue do i=1,nx a(i-1+ix)=a(2*i+4+iscr) enddo nl=l1h nx=nx-nl call merge(a(ix),nx,nxmax,a(ieni),neni,nenimx,ndig,el,eh) call merge(a(ix+nx),nl,nxmax,a(ieni),neni,nenimx,ndig,el,eh) 150 continue if (el.gt.small) go to 210 if (nas.eq.0) go to 210 if (matb(1).ge.0) go to 210 if (matstd.ne.-matb(1).or.mtstd.ne.-mtb(1)) go to 210 200 continue 210 return end c subroutine lumpmt(a) c ****************************************************************** c read through the file 33 mts and store the list of component mts c making up the lumped mts. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/eunits/nendf,nunit(7),nscr common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension a(*) character*4 bl external reserv,findex,findf,contio,error,tosend,releas external openz,repoz,tpidio,tofend,amend,atend data bl/' '/ c nwl=nlump*nlmt call reserv('lmt',nwl,ilmt,a) nw=2*npage+50 call reserv('scr',nw,iscr,a) call findex('lump',ilump,a) do i=1,nwl a(i-1+ilmt)=0 enddo call findf(matd,mfcov,0,nendf) max=0 c c ***loop over mts 110 call contio(nendf,0,0,a(iscr),nb,nw) if (mfh.eq.0) go to 200 mt1=l2h if (mt1.lt.851) go to 140 do 120 l=1,nlump mtl=nint(a(ilump+2*(l-1))) if (mt1.ne.mtl) go to 120 a(ilump+2*(l-1)+1)=a(ilump+2*(l-1)+1)+1 k=nint(a(ilump+2*(l-1)+1)) if (k.gt.nlmt) call error('lumpmt','storage exceeded.',' ') if (k.gt.max) max=k a(ilmt-1+nlmt*(l-1)+k)=mth c ***set this mth in mts negative do 130 j=1,nmt if (mts(j).ne.mth) go to 130 mts(j)=-mts(j) if (mats(j).eq.0) mats(j)=-1 if (mats(j).gt.0) mats(j)=-mats(j) go to 140 130 continue 120 continue 140 call tosend(nendf,0,0,a(iscr)) go to 110 c c ***determine the maximum no. of words needed 200 if (max.eq.nlmt) go to 230 c ***squeeze storage loc1=ilmt-1+max do l=2,nlump loc=ilmt+nlmt*(l-1)-1 do j=1,max a(j+loc1)=a(j+loc) enddo loc1=loc1+max enddo nwl=max*nlump call releas('lmt',nwl,a) nlmt=max c ***copy mfcov to nscr for use in lumpxs 230 nscr=15 if (nendf.lt.0) nscr=-nscr call openz(nscr,1) call repoz(nscr) do i=1,17 read(bl,'(a4)') a(i-1+iscr) enddo math=1 mfh=0 mth=0 nsc=0 call tpidio(0,0,nscr,a(iscr),nb,nw) call findf(matd,mfcov,0,nendf) call contio(nendf,0,nscr,a(iscr),nb,nw) call tofend(nendf,0,nscr,a(iscr)) call amend(0,nscr) call atend(0,nscr) call repoz(nscr) call releas('scr',0,a) return end c subroutine lumpxs(mti,mtk,a) c ****************************************************************** c read the cross sections of the component mts for a lumped c covariance mt. c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr1,nscr2,nscr common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) dimension a(*) external findex,findf,contio,rdsig c call findex('lump',ilump,a) call findex('lmt',ilmt,a) call findex('scr',iscr,a) call findex('scr2',iscr2,a) call findex('sig',isig,a) call findex('sig1',isig1,a) call findex('b',ib,a) do 130 i=1,nlump l=i mtl=nint(a(ilump+2*(l-1))) if (mtl.eq.mti) go to 140 130 continue 140 nmtl=nint(a(ilump+2*(l-1)+1)) is=isig if (mti.ne.mtk) is=isig1 do i=1,nunion a(is-1+i)=0 enddo c c ***loop over component mts loc=ilmt+nlmt*(l-1)-1 do i=1,nmtl mtd=nint(a(i+loc)) call findf(matd,mfcov,mtd,nscr) call contio(nscr,0,0,a(iscr2),nb,nw) za=c1h awr=c2h call rdsig(matd,mtd,a(ib),a(iscr2)) c ***add scr2 to a(is) do j=1,nunion a(is-1+j)=a(is-1+j)+a(iscr2-1+j) enddo enddo return end c subroutine merge(x,nx,nxmax,y,ny,nymax,ndig,e1,e2) c ****************************************************************** c merge an energy grid in x with a previously existing one in y. c both grids are assumed to be in increasing order. c ****************************************************************** implicit real*8 (a-h,o-z) character*60 strng dimension x(*),y(*) external error,sigfig data eps/1.d-5/ zero=0 c if (nx.eq.0) return j=0 do 100 i=1,nx x(i)=sigfig(x(i),ndig,0) if (e1.eq.zero.and.e2.eq.zero) go to 110 if (x(i).le.e1) go to 100 if (x(i).ge.e2) go to 120 110 j=j+1 x(j)=x(i) 100 continue 120 nx=j if (ny.gt.0) go to 140 if (nx.gt.nxmax) call error('merge','storage exceeded.',' ') do i=1,nx y(i)=x(i) enddo ny=nx go to 200 c 140 j=0 do 180 i=1,nx 150 j=j+1 if (j.gt.ny) go to 170 if (y(j).lt.x(i)) go to 150 if (y(j).eq.x(i)) go to 180 if (abs(y(j)-x(i)).le.eps*y(j)) go to 180 c ***insert x(i) in the y array. if (ny.eq.nymax) call error('merge','storage exceeded.',' ') do k=j,ny loc=ny+j-k y(loc+1)=y(loc) enddo 170 ny=ny+1 y(j)=x(i) 180 continue c c ***check grid for data inconsistencies 200 ny1=ny-1 do i=1,ny1 isave=i do j=i,ny jsave=j if (y(i).gt.y(j)) then write(strng, & '(''y('',i4,'')='',1p,e12.4,'' lt y('',i4,'')='', & 1p,e12.4)') jsave,y(jsave),isave,y(isave) call error('merge',strng,' ') endif enddo enddo return end c subroutine rdsig(mat,mt,b,sig) c ****************************************************************** c read cross sections from ngout tape using subroutine rdgout, c re-initializing that subroutine for each new value of mat. c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr(3) dimension b(*),sig(*) external rdgout save matd,mfrd,matlst c if (mt.eq.0) then matd=mat mfrd=3 matlst=10000 else matrd=mat if (mat.eq.0) matrd=matd mtrd=mt if (mat.ne.matlst) then mfri=1 mtri=451 call rdgout(ngout,matrd,mfri,mtri,b,sig) matlst=mat endif call rdgout(ngout,matrd,mfrd,mtrd,b,sig) endif return end c subroutine egnwtf(a) c ****************************************************************** c set up calculation of weight functions or read in arbitary c function in the form of an endf/b tab1 record or c read in parameters for an analytic weight function. c c iwt meaning c --- ------- c 1 read in c 2 constant c 3 1/e c 4 1/e + fission spectrum + thermal maxwellian c 5 epri-cell lwr c 6 (thermal) -- (1/e) -- (fission + fusion) c 7 same with t-dep thermal part c 8 thermal--1/e--fast reactor--fission + fusion c 9 claw weight function c 10 claw with t-dependent thermal part c 11 vitamin-e weight function (ornl-5505) c 12 vit-e with t-dep thermal part c c ****************************************************************** implicit real*8 (a-h,o-z) common/mainio/nsysi,nsyso,nsyse,ntty cej common/ewght/iwt common/iwt4/eb,tb,ab,ec,tc,ac dimension a(*) dimension w1(92),w2(92),w3(8) dimension w8(66) dimension w9(102) data w1/0.d0,0.d0,0.d0,0.d0,1.d0,92.d0,92.d0,5.d0, & 1.d-5,5.25d-4,.009d0,.355d0,.016d0,.552d0,.024d0,.712d0, & .029d0,.785d0,.033d0,.829d0,.043d0,.898d0,.05d0,.918d0,.054d0, & .921d0,.059d0,.918d0,.07d0,.892d0,.09d0,.799d0,.112d0,.686d0, & .14d0,.52d0,.17d0,.383d0,.21d0,.252d0,.3d0,.108d0,.4d0,.0687d0, & .49d0,.051d0,.57d0,.0437d0,.6d0,.0413d0,1.d0,.024914d0,1.01d3, & 3.7829d-5,2.d4,2.2257d-6,3.07d4,1.5571d-6,6.07d4,9.1595d-7, & 1.2d5,5.7934d-7,2.01d5,4.3645d-7,2.83d5,3.8309d-7,3.56d5, & 3.6926d-7,3.77d5,3.4027d-7,3.99d5,2.7387d-7,4.42d5,1.0075d-7, & 4.74d5,2.1754d-7,5.02d5,2.6333d-7,5.4d5,3.0501d-7,6.5d5, & 2.9493d-7,7.7d5,2.5005d-7,9.d5,2.1479d-7,9.41d5,1.7861d-7, & 1.d6,9.1595d-8,1.05d6,1.1518d-7/ data w2/ & 1.12d6,1.3648d-7,1.19d6,1.5479d-7,1.21d6,1.5022d-7,1.31d6, & 6.8696d-8,1.4d6,1.2182d-7,2.22d6,5.9033d-8,2.35d6,9.1595d-8, & 2.63d6,3.9981d-8,3.d6,3.1142d-8,4.d6,1.7073e-8,5.d6,9.0679d-9, & 6.d6,4.7153d-9,8.d6,1.2276d-9,1.d7,3.0953d-10,1.257d7,2.4619d-10, & 1.26d7,3.4731d-10,1.27d7,1.0357d-9,1.28d7,2.8436d-9,1.29d7, & 7.191d-9,1.3d7,1.6776d-8,1.31d7,3.6122d-8,1.32d7,7.1864d-8, & 1.33d7,1.3222d-7,1.34d7,2.2511d-7,1.35d7,3.5512d-7,1.36d7, & 5.1946d-7,1.37d7,7.0478d-7,1.38d7,8.8825d-7,1.39d7,1.0408d-6, & 1.407d7,1.154d-6,1.42d7,1.087d-6,1.43d7,9.5757d-7,1.44d7, & 7.7804d-7,1.45d7,6.0403d-7,1.46d7,4.3317d-7,1.47d7,2.9041d-7, & 1.48d7,1.8213d-7,1.49d7,1.0699d-7,1.5d7,5.8832d-8,1.51d7, & 3.0354d-8,1.52d7,1.4687d-8,1.53d7,6.6688d-9,1.54d7,2.845d-9, & 1.55d7,1.1406d-9,1.5676d7,1.978d-10,2.d7,1.5477d-10/ data w3/3.d7,1.0318d-10,5.d7,6.1908d-10,1.d8,3.0954d-11, & 1.5d8,2.0636d-11/ data w8/4*0.d0,1.d0,29.d0,29.d0,5.d0, & .139000d-03, .751516d-03, .100000d-01, .497360d-01, & .200000d-01, .754488d-01, .400000d-01, .107756d+00, & .600000d-01, .110520d+00, .800000d-01, .101542d+00, & .100000d+00, .884511d-01, .614000d+02, .144057d-03, & .788930d+02, .217504d-03, .312030d+03, .127278d-02, & .179560d+04, .236546d-02, .804730d+04, .114311d-02, & .463090d+05, .387734d-03, .161630d+06, .125319d-03, & .639280d+06, .207541d-04, .286500d+07, .216111d-05, & .472370d+07, .748998d-06, .100000d+08, .573163d-07, & .127900d+08, .940528d-08, .129000d+08, .973648d-08, & .135500d+08, .985038d-07, .137500d+08, .176388d-06, & .139500d+08, .239801d-06, .140700d+08, .251963d-06, & .141900d+08, .239298d-06, .143900d+08, .176226d-06, & .145900d+08, .992422d-07, .155500d+08, .150737d-08, & .200000d+08, .725000d-10/ data w9/4*0d0,1d0,47d0,47d0,5d0, & 1.39d-4, 3.019d6, 5.d-4, 1.07d7, 1.d-3, 2.098d7, & 5.d-3, 8.939d7, 1.d-2, 1.4638d8, 2.5d-2, 2.008d8, & 4.d-2, 1.7635d8, 5.d-2, 1.478d8, 1.d-1, 4.d7, & 1.4d-1, 1.13d7, 1.5d-1, 7.6d6, 4.14d-1, 2.79d6, & 1.13d0, 1.02d6, 3.06d0, 3.77d5, 8.32d0, 1.39d5, & 2.26d1, 5.11d4, 6.14d1, 1.88d4, 1.67d2, 6.91d3, & 4.54d2, 2.54d3, 1.235d3, 9.35d2, 3.35d3, 3.45d2, & 9.12d3, 1.266d2, 2.48d4, 4.65d1, 6.76d4, 1.71d1, & 1.84d5, 6.27d0, 3.03d5, 3.88d0, 5.d5, 3.6d0, & 8.23d5, 2.87d0, 1.353d6, 1.75d0, 1.738d6, 1.13d0, & 2.232d6, 0.73d0, 2.865d6, 0.4d0, 3.68d6, 2.05d-1, & 6.07d6, 3.9d-2, 7.79d6, 1.63d-2, 1.d7, 6.5d-3, & 1.2d7, 7.6d-3, 1.3d7, 1.23d-2, 1.35d7, 2.64d-2, & 1.4d7, 1.14d-1, 1.41d7, 1.14d-1, 1.42d7, 1.01d-1, & 1.43d7, 6.5d-2, 1.46d7, 1.49d-2, 1.5d7, 4.d-3, & 1.6d7, 1.54d-3, 1.7d7, 0.85d-3/ data small/1.d-10/ data zero/0.d0/ data onep5/1.5d0/ c c ***read flux calculator input, if any. iwtt=iabs(iwt) nflmax=0 cej if (iwt.le.0) then ninwt=0 jsigz=0 read(nsysi,*) ehi,sigpot,nflmax,ninwt,jsigz call openz(ninwt,0) write(nsyso,'(/, & '' compute flux...ehi, sigpot, nflmax ='',f9.1,f9.2,i8)') & ehi,sigpot,nflmax,ninwt,jsigz endif c c ***arbitary if (iwtt.eq.1) then write(nsyso,'(/,'' weight function......read in'')') iw=-1 call reserv('wght',iw,iwght,a) read(nsysi,*) (a(iwght+i-1),i=1,iw) nr=nint(a(iwght+4)) np=nint(a(iwght+5)) iw=6+2*nr+2*np call releas('wght',iw,a) c c ***constant else if (iwtt.eq.2) then write(nsyso,'(/,'' weight function......constant for all l'')') c c ***1/e else if (iwtt.eq.3) then write(nsyso,'(/,'' weight function......1/e for all l'')') c c ***1/e+fission+thermal else if (iwtt.eq.4) then read(nsysi,*) eb,tb,ec,tc if (eb.gt.50*tb) then ab=1 ac=0 else ab=1/(exp(-eb/tb)*eb**2) ac=1/(exp(-ec/tc)*ec**onep5) endif iw=6 call reserv('wght',iw,iwght,a) a(iwght)=eb a(iwght+1)=tb a(iwght+2)=ab a(iwght+3)=ec a(iwght+4)=tc a(iwght+5)=ac write(nsyso,'(/, & '' weight function......thermal + 1/e + fission'',/, & '' thermal breakpoint and temperature '',1p,2e12.4,/, & '' fission breakpoint and temperature '',2e12.4)') & eb,tb,ec,tc c c ***epri-cell light water reactor weight. else if (iwtt.eq.5) then write(nsyso,'(/,'' weight function......epri-cell lwr'')') iw=192 call reserv('wght',iw,iwght,a) do i=1,92 a(i-1+iwght)=w1(i) enddo do i=1,92 a(i+91+iwght)=w2(i) enddo do i=1,8 a(i+183+iwght)=w3(i) enddo c c ***(thermal) -- (1/e) -- (fission + fusion) else if (iwtt.eq.6.or.iwtt.eq.7) then write(nsyso,'(/, & '' weight function......(thermal) -- (1/e) -- '', & ''(fission + fusion)'')') if (iwtt.gt.6) write(nsyso,'(22x,''temperature dependent'')') c c ***thermal--1/e--fast reactor--fission + fusion else if (iwtt.eq.8) then write(nsyso,'(/, & '' weight function...thermal--1/e--fast reactor--'', & ''fission + fusion'')') iw=66 call reserv('wght',iw,iwght,a) do i=1,66 a(i-1+iwght)=w8(i) enddo c c ***claw weight function else if (iwtt.eq.9.or.iwtt.eq.10) then write(nsyso, & '(/,'' weight function......claw weight function'')') if (iwtt.gt.9) then write(nsyso,'(22x,''temperature dependent'')') endif iw=102 call reserv('wght',iw,iwght,a) do i=1,102 a(i-1+iwght)=w9(i) enddo c c ***vitamin-e weight function else if (iwtt.eq.11.or.iwtt.eq.12) then write(nsyso,'(/,'' weight function......vitamin-e'')') if (iwtt.gt.11) write(nsyso,'(22x,''temperature dependent'')') c c ***illegal iwt else call error('egnwtf','illegal weight function requested.',' ') endif return end c subroutine egtwtf(e,enext,idis,lord,wtf,a) c ****************************************************************** c retrieve or compute required legendre component of the c weight function constructed or read in by egnwtf. c ****************************************************************** implicit real*8 (a-h,o-z) common/bkc/bk common/ewght/iwt common/temper/temp(10),ntemp common/iwt4/eb,tb,ab,ec,tc,ac dimension a(*) external findex,terpa save ip,ir,ipl,step data con1,con2,con3/7.45824d+07,1.d0,1.44934d-09/ data con4,con5,con6/3.90797d-02,2.64052d-05,6.76517d-02/ data en1,en2,en3,en4,en5/.414d0,2.12d6,1.d7,1.252d7,1.568d7/ data therm,theta,fusion,ep/.0253d0,1.415d6,2.5d4,1.407d7/ data emax/1.d10/ data s110,s101,s1002,s1005,s10001/1.10d0,1.01d0,1.002d0, & 1.005d0,1.0001d0/ data tenth,half,two/0.1d0,0.5d0,2.d0/ data veb/5.d5/ data wt6a,wt6b,wt6c,wt6d,wt6e,wt6f,wt6g,wt6h,wt6i,wt6j/ & .054d0,1.578551d-3,2.1d6,2.32472d-12,1.4d6,2.5d4, & 1.407d7,2.51697d-11,1.6d6,3.3d5/ data wt10a,wt10b,wt10c/.15d0,300.d0,1.15d6/ data exmin/-89.d0/ data zero/0.d0/ c c ***initialize iwtt=iabs(iwt) if (iwtt.eq.1.or.iwtt.eq.4.or.iwtt.eq.5.or.iwtt.eq.8. & or.iwtt.eq.9.or.iwtt.eq.10) & call findex('wght',iwght,a) idis=0 if (e.eq.0) then ip=2 ir=1 ipl=0 enext=emax step=s110 return endif c c ***branch to desired method iwtt=iabs(iwt) c c ***tabulated if (iwtt.eq.1.or.iwtt.eq.5.or.iwtt.eq.8.or.iwtt.eq.9) then call terpa(wtf,e,enext,idis,a(iwght),ip,ir) if (wtf.ne.zero) then if (ip.ne.ipl) then step=s10001*(enext/e)**tenth ipl=ip endif enxt=step*e if (enxt.gt.s101*e) enxt=s101*e if (enext.gt.enxt) idis=0 if (enext.gt.enxt) enext=enxt endif c c ***constant for all orders else if (iwtt.eq.2) then wtf=1 enext=emax c c ***1/e for all orders else if (iwtt.eq.3) then wtf=1/e enext=s101*e c c ***thermal + 1/e + fission c ***wght(1) to wght(6) are eb, tb, ab, ec, tc, ac else if (iwtt.eq.4) then if (e.le.eb) then wtf=ab*e*exp(-e/tb) enext=s101*e if (e.lt.eb.and.enext.gt.eb) enext=eb else if (e.le.ec) then wtf=1/e enext=s101*e if (e.lt.eb.and.enext.gt.eb) & enext=eb else wtf=ac*sqrt(e)*exp(-e/tc) enext=s101*e endif c c ***(thermal) -- (1/e) -- (fission + fusion) c ***with optional t dependence else if (iwtt.eq.6.or.iwtt.eq.7) then tt=wt6a if (iwtt.gt.6) tt=temp(jtemp)*bk bb=2*tt cc=1 if (iwtt.gt.6) cc=wt6b*exp(two)/bb**2 if (e.le.bb) then wtf=cc*e*exp(-e/tt) enext=s101*e else if (e.le.wt6c) then wtf=wt6b/e enext=s101*e else wtf=wt6d*sqrt(e)*exp(-e/wt6e) pow=-(sqrt(e/wt6f)-sqrt(wt6g/wt6f))**2/2 if (pow.gt.exmin) wtf=wtf+wt6h*exp(pow) enext=s101*e test=wt6i if (abs(e-wt6g).le.test) enext=s1005*e test=wt6j if (abs(e-wt6g).le.test) enext=s1002*e endif c c ***temperature-dependent thermal part else if (iwtt.eq.10) then ea=bk*temp(jtemp) eb=wt10a*temp(jtemp)/wt10b if (e.lt.eb) then wtf=wt10c*(e/eb**2)*exp(-(e-eb)/ea) enext=s101*e if (enext.gt.eb) enext=eb else call terpa(wtf,e,enext,idis,a(iwght),ip,ir) if (wtf.eq.zero) then enext=emax else if (ip.ne.ipl) then step=s10001*(enext/e)**tenth ipl=ip endif enxt=step*e if (enxt.gt.s101*e) enxt=s101*e if (enext.gt.enxt) idis=0 if (enext.gt.enxt) enext=enxt endif endif c c ***vitamin-e weight function (ornl-5510) c ***with optional t dependence else if (iwtt.eq.11.or.iwtt.eq.12) then enext=s101*e if (e.lt.en1) then tt=therm if (iwtt.gt.11) tt=temp(jtemp)*bk cc=con1 if (iwtt.gt.11) cc=con2*exp(en1/tt)/en1**2 wtf=cc*e*exp(-e/tt) if (enext.gt.en1) enext=en1 else if (e.lt.en2) then wtf=con2/e if (enext.gt.en2) enext=en2 else if (e.lt.en3) then wtf=con3*e**half*exp(-e/theta) if (enext.gt.en3) enext=en3 else if (e.lt.en4) then wtf=con4/e if (enext.gt.en4) enext=en4 else if (e.lt.en5) then wtf=con5*exp(-5*(e**half-ep**half)**2/fusion) if (abs(e-ep).le.veb) enext=s1002*e if (enext.gt.en5) enext=en5 else wtf=con6/e endif endif c c ***return enext on an even grid enext=sigfig(enext,7,0) return end c subroutine stand(li,l,loc,lty,a) c ****************************************************************** c read and store the appropriate data from nstan. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr1,nscr2,nscr3 common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/redef/nas,matb(5),mtb(5),matc(5),mtc(5) dimension a(*) dimension loc(*) external findex,sigfig,findf,contio,listio,moreio c call findex('scr',iscr,a) el=sigfig(c1h,ndig,0) eh=sigfig(c2h,ndig,0) matstd=l1h mtstd=l2h c c ***redefine standard if necessary if (nas.le.0) go to 110 do 100 i=1,nas if (matstd.ne.matb(i).or.mtstd.ne.mtb(i)) go to 100 matstd=matc(i) mtstd=mtc(i) go to 110 100 continue 110 call findf(matstd,mfcov,mtstd,nstan) call contio(nstan,0,0,a(iscr+l-1),nb,nw) c c ***first subsection is the one we want call contio(nstan,0,0,a(iscr+l-1),nb,nw) nc=n1h ni=n2h c c ***skip over nc sub-subsections if (nc.ne.0) then do ic=1,nc call contio(nstan,0,0,a(iscr+l-1),nb,nw) call listio(nstan,0,0,a(iscr+l-1),nb,nw) do while (nb.ne.0) call moreio(nstan,0,0,a(iscr+l-1),nb,nw) enddo enddo endif c c ***loop over ni sub-subsections do ii=1,ni call listio(nstan,0,0,a(iscr+l-1),nb,nw) li=li+1 loc(li)=iscr+l-1 a(iscr+l-1)=el a(iscr+l)=eh if (l2h.eq.6) a(iscr+l+1)=int((n1h-1)/n2h) a(iscr+l+3)=lty np=n1h l=l+nw do while (nb.ne.0) call moreio(nstan,0,0,a(iscr+l-1),nb,nw) l=l+nw enddo locli=loc(li)+5 do i=1,np a(i+locli)=sigfig(a(i+locli),ndig,0) enddo enddo return end c subroutine resprx(nwscr,a) c ****************************************************************** c prepare tables containing the resonance-parameter contributions c to coarse-group covariances. c ****************************************************************** implicit real*8 (a-h,o-z) parameter (mxlru2=100) common/err0/nresg common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/err3/ifresr,ifunrs common/reson1/ap,arat,ra,spifac,ll common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/grpn/ign,ngn,egn(901),iprint common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 character*60 strng1,strng2 dimension a(*) dimension amu(3,mxlru2) c ***initialize nresg=0 ifresr=0 ifunrs=0 if (mfcov.eq.33.and.mf32.ne.0) then call findex('cff',icff,a) call findex('cfg',icfg,a) call findex('cgg',icgg,a) call findex('cee',icee,a) call findex('cef',icef,a) call findex('ceg',iceg,a) call findex('ctt',ictt,a) call findex('uff',iuff,a) call findex('ufg',iufg,a) call findex('ugg',iugg,a) call findex('uee',iuee,a) call findex('uef',iuef,a) call findex('ueg',iueg,a) call findex('utt',iutt,a) call findex('scr',iscr,a) call findex('cflx',icflx,a) c call repoz(nendf) call tpidio(nendf,0,0,a(iscr),nb,nw) do ig=1,ngn a(iufg-1+ig)=0.d0 enddo nngn=ngn*(ngn+1)/2 do ig=1,nngn a(icff-1+ig)=0.d0 a(icee-1+ig)=0.d0 a(icgg-1+ig)=0.d0 a(ictt-1+ig)=0.d0 a(iuff-1+ig)=0.d0 a(iugg-1+ig)=0.d0 a(iuee-1+ig)=0.d0 a(iutt-1+ig)=0.d0 enddo nngn=ngn*ngn do ig=1,nngn a(icfg-1+ig)=0.d0 a(icef-1+ig)=0.d0 a(iceg-1+ig)=0.d0 a(iufg-1+ig)=0.d0 a(iuef-1+ig)=0.d0 a(iueg-1+ig)=0.d0 enddo nscr6=16 if (nendf.lt.0) nscr6=-nscr6 call openz(nscr6,1) call repoz(nscr6) call Resprx_dumrd2(matd,nendf,nscr6,a(iscr),amu,mxlru2) call findf(matd,32,151,nendf) call contio(nendf,0,0,a(iscr),nb,nw) za=c1h awr=c2h nis=n1h endif c c ***loop over isotopes do 110 is=1,nis call contio(nendf,0,0,a(iscr),nb,nw) abn=c2h lfw=l2h ner=n1h c c ***loop over energy ranges do 120 ie=1,ner write (*,10000) ie, ner 10000 format ('Energy range : ',I5,'/',I5) call contio(nendf,0,0,a(iscr),nb,nw) el=c1h eh=c2h ehg=eh elg=el ip1=0 ip2=0 do i=2,ngn+1 ee=egn(i) if(ip1.eq.0.and.ee.gt.el)then ip1=1 elg=egn(i-1) iest=i-1 endif if(ip2.eq.0.and.ee.gt.eh)then ip2=1 ehg=egn(i) ieed=i endif enddo lru=l1h lrf=l2h nro=n1h naps=n2h if (lru.eq.1.and.lrf.ge.1.and.lrf.le.3) go to 130 if (lru.eq.2.and.lrf.ge.1.and.lrf.le.2) go to 130 write(strng2,'(''lrf='',i4,'' lru='',i4)') lrf,lru call error('resprx', & 'illegal or no coding data structure in mf32', & strng2) 130 if (nro.ne.0) then write(strng2,'(''nro='',i4)') nro call error('resprx', & 'illegal or unrecognized data structure in mf32', & strng2) endif c call contio(nendf,0,0,a(iscr),nb,nw) spi=c1h spifac=1/(2*spi+1) ap=c2h lcomp=l2h nls=n1h l=iscr+6 c if (lru.eq.2) then c ***Unresolved call Resprx_Unr(a,amu,mxlru2,iest,ieed) else c ***Resolved if (lcomp.eq.0) then call Resprx_RRR_Lcomp0(nwscr,a) elseif (lcomp.eq.1 .or. lcomp.eq.2) then call Resprx_RRR_Lcomp12(nwscr,a,iest,ieed) else endif endif c c ***finished of this material or a section 120 continue 110 continue call closz(nscr6) c return end c subroutine Resprx_RRR_Lcomp0(nwscr,a) c ****************************************************************** c lru = 1, lcomp = 0 c ****************************************************************** implicit real*8 (a-h,o-z) parameter (maxnls=10,maxe=400000) common/err0/nresg common/err3/ifresr,ifunrs common/reson1/ap,arat,ra,spifac,ll common/reson2/ajmin,gj(10),diff,nj common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/grpn/ign,ngn,egn(901),iprint common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/util/npage,iverf common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common/cwav/cwaven common/amnc/amassn character*60 strng1,strng2 dimension a(*) dimension istloc(maxnls) dimension sig(maxe,5), gsig(4,901,6), sig1(4) dimension sens(4,6,901) dimension cov(5,5) dimension ag(6), aa(3), aa2(3) logical lneger data rc1,rc2,third/0.123d0,0.08d0,0.333333333d0/ data Zero /0.0d0/, half/0.5d0/ c c ***resolved resonance parameters (lru=1) c ***compatible resolved resonance subsection format (lcomp=0) if (nls.gt.maxnls) then write(strng2,'(''nls='',i8,'' maxnls='',i8)') nls,maxnls call error('resprx','storage exceeded.',strng2) endif do nl=1,nls istloc(nl)=l call listio(nendf,0,0,a(l),nb,nw) 140 continue if (nb.ne.0) then l=l+nw call moreio(nendf,0,0,a(l),nb,nw) go to 140 else l=l+nw if ((l+nw-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') l+nw-iscr,nwscr call error('resprx','storage exceeded.',strng2) endif endif enddo c c ***loop over l states do 160 nl=1,nls iloc=istloc(nl) awri=a(iloc) ll=nint(a(iloc+2)) nrs=nint(a(iloc+5)) arat=awri/(awri+1) aw=amassn*awri ra=rc1*aw**third+rc2 ral=ra apl=ap if (naps.eq.1) then ral=apl ra=ap endif if (lrf.eq.2) then sum=0.d0 den=4*spi+2 fl=ll ajmin=abs(abs(spi-fl)-half) ajmax=spi+fl+half nj=ajmax-ajmin+1.001d0 aj=ajmin do i=1,min(10,nj) gj(i)=(2*aj+1)/den aj=aj+1 sum=sum+gj(i) enddo diff=2*fl+1-sum endif inow=iloc+6 c c ***loop over all resonances do 170 nr=1,nrs er=abs(a(inow)) rho=cwaven*arat*sqrt(er)*ral call facts(ll,rho,ser,per) aa(1)=ser aa(2)=per aa(3)=0.d0 rgt=1/a(inow+2) c do ig=1,ngn do j=1,6 do i=1,4 gsig(i,ig,j)=0.d0 sens(i,j,ig)=0.d0 enddo enddo enddo c do 180 loop=1,6 do j=1,6 ag(j)=a(inow+j-1) enddo do j=1,3 aa2(j)=aa(j) enddo if (loop.eq.2) then if (ag(1).lt.zero) then ag(1)=ag(1)*1.0001d0 lneger=.false. else do ig1=1,ngn if (ag(1).ge.egn(ig1).and. & ag(1).lt.egn(ig1+1)) go to 190 enddo 190 continue e1=ag(1)*1.0001d0 do ig2=ig1,ngn if (e1.ge.egn(ig2).and. & e1.lt.egn(ig2+1)) go to 200 enddo 200 continue if (ig1.eq.ig2) then ag(1)=e1 lneger=.false. else ag(1)=ag(1)*0.9999d0 lneger=.true. endif endif rho=cwaven*arat*sqrt(abs(ag(1)))*ral call facts(ll,rho,ser,per) aa2(1)=ser aa2(2)=per elseif (loop.eq.3) then go to 180 elseif (loop.ge.4.and.loop.le.6) then if (ag(loop).eq.0.) go to 180 ag(loop)=ag(loop)*1.01d0 ag(3)=ag(4)+ag(5)+ag(6) endif e1=elg ii=0 if (nr.eq.1) then er1=er/10.d0 er2=er*10.d0 elseif (er.le.1.d+2) then er1=er/4.d0 er2=er*4.d0 else er1=er/2.5d0 er2=er*2.5d0 endif if (loop.eq.2) then er3=abs(ag(1))*0.995d0 er4=abs(ag(1))*1.005d0 er5=abs(ag(1))*0.9992d0 er6=abs(ag(1))*1.0008d0 else er3=er*0.995d0 er4=er*1.005d0 er5=er*0.9992d0 er6=er*1.0008d0 endif go to 220 c 210 continue if (e1.ge.er5.and.e1.le.er6) then ekp=1.000001d0 elseif (e1.ge.er3.and.e1.le.er4) then ekp=1.00001d0 elseif (e1.ge.er1.and.e1.le.er2) then ekp=1.0018d0 else ekp=1.02d0 endif e1=e1*ekp ebc=e1/ekp if(ebc.lt.el.and.e1.gt.el)e1=el if(ebc.lt.eh.and.e1.gt.eh)e1=eh c 220 continue if (e1.gt.ehg) e1=ehg if (e1.ge.el.and.e1.le.eh)then if (lrf.eq.1) then call ssslbw(e1,sig1,ag,aa2) elseif (lrf.eq.2) then call ssmlbw(e1,sig1,ag,aa2) else write(strng2,'(''lrf='',i4, & '' for lcomp=0'')')lrf call error('resprx','not allowed lrf.',strng2) endif else do i=1,4 sig1(i)=0.0 enddo endif ii=ii+1 if (ii.gt.maxe) call error('resprx', & 'number of pointwise xsec of resonance exceeded.', & 'please increase the maxe parameter.') do i=1,4 sig(ii,i)=sig1(i) enddo sig(ii,5)=e1 if (e1.ge.ehg) go to 230 go to 210 c 230 continue call Resprx_grping(ngn,egn,sig,ii,gsig(1,1,loop),a) 180 continue c do ig=1,ngn if (gsig(1,ig,1).le.zero) go to 255 do j=1,4 do i=1,5 if (gsig(j,ig,i+1).le.zero) go to 250 S = Gsig(J,Ig,I+1) - Gsig(J,Ig,1) if (i.eq.1) then c ***Parameter is resonance energy IF (Lneger) S = - S S = 10000.0d0 * S / Er ij=1 elseif (i.eq.2) then c ***Parameter is total width (irrelevant) ij=5 else c ***Parameter is width if (a(inow+i).eq.zero) go to 250 S = 100.0D0 * S / A(Inow+I) ij=i-1 endif if (abs(s).ge.1.d-10) sens(j,ij,ig)= & s*a(icflx-1+ig)*abn 250 continue enddo enddo 255 continue enddo do J=1,5 do I=1,5 cov(i,j)=0.d0 enddo enddo c inow=inow+6 cov(1,1)=a(inow) do i=2,5 do j=2,i inow=inow+1 cov(i,j)=a(inow) cov(j,i)=a(inow) enddo enddo c inow=inow+2 if (iverf.eq.6) then c ***For ENDFB/6 only four parameters per resonance jd=5 do i=1,5 id=i if (cov(i,5).ne.zero) go to 260 enddo endif do i=1,5 id=i jd=i if (cov(i,i).lt.zero) go to 260 enddo do i=1,5 id=i do j=1,5 jd=j if (cov(i,i).gt.zero.and.cov(j,j).gt.zero) then corr=cov(i,j)/sqrt(cov(i,i)*cov(j,j)) if (abs(corr).ge.1.0001d0) then if (abs(corr).gt.2.) go to 260 write(strng1,'(''correlation coeff.='', & f8.4)') corr write(strng2, & '(''for resonance parameters '',i1, & '' and '',i1,'' at er='',1pe12.4)') & i,j,er call mess('resprx',strng1,strng2) endif else if (cov(i,j).ne.zero) go to 260 endif enddo enddo go to 270 c 260 continue write(strng2, & '('' resonance parameters '',i1,'' and '',i1, & '' at er='',1pe12.4)') id,jd,er call error('resprx','bad covariance data for',strng2) c 270 continue c igind=0 do ig=1,ngn if (gsig(1,ig,1).le.zero) then igind=igind+(ngn-ig+1) go to 285 endif do ig2=ig,ngn igind=igind+1 do i=1,5 if (sens(1,i,ig).eq.zero.and.sens(2,i,ig).eq.zero & .and.sens(3,i,ig).eq.zero.and.sens(4,i,ig).eq.zero) & go to 282 do j=1,5 if (abs(cov(i,j)).le.zero) go to 280 a(icff-1+igind)=a(icff-1+igind)+ & cov(i,j)*sens(3,i,ig)*sens(3,j,ig2) a(icgg-1+igind)=a(icgg-1+igind)+ & cov(i,j)*sens(4,i,ig)*sens(4,j,ig2) a(icee-1+igind)=a(icee-1+igind)+ & cov(i,j)*sens(2,i,ig)*sens(2,j,ig2) a(ictt-1+igind)=a(ictt-1+igind)+ & cov(i,j)*sens(1,i,ig)*sens(1,j,ig2) 280 continue enddo 282 continue enddo enddo if (ig.gt.nresg) nresg=ig 285 continue enddo c igind=0 do ig=1,ngn do ig2=1,ngn igind=igind+1 do i=1,5 if (sens(1,i,ig).eq.zero.and.sens(2,i,ig).eq.zero & .and.sens(3,i,ig).eq.zero.and.sens(4,i,ig).eq.zero) & go to 292 do j=1,5 if (abs(cov(i,j)).le.zero) go to 290 a(icef-1+igind)=a(icef-1+igind)+ & cov(i,j)*sens(2,i,ig)*sens(3,j,ig2) a(iceg-1+igind)=a(iceg-1+igind)+ & cov(i,j)*sens(2,i,ig)*sens(4,j,ig2) a(icfg-1+igind)=a(icfg-1+igind)+ & cov(i,j)*sens(3,i,ig)*sens(4,j,ig2) 290 continue enddo 292 continue enddo enddo enddo c 170 continue 160 continue c c ***End of Do-Loops ifresr=1 c return end c subroutine Resprx_RRR_Lcomp12(nwscr,a,iest,ieed) c ****************************************************************** c lru = 1, lcomp = 1 or 2 c ****************************************************************** implicit real*8 (a-h,o-z) parameter (maxe=400000,mxnpar=4000,maxb=20000) common/mainio/nsysi,nsyso,nsyse,ntty common/err0/nresg common/err3/ifresr,ifunrs common/reson1/ap,arat,ra,spifac,ll common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/grpn/ign,ngn,egn(901),iprint common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common/cwav/cwaven common/amnc/amassn character*60 strng1,strng2 dimension a(*) dimension b(maxb) dimension sigr(maxe,5),sigp(maxe,5), gsig(4,901) dimension sens(4,mxnpar,901) dimension cov(mxnpar,mxnpar) dimension llmat(5), innls(5) data Zero /0.0d0/ data rc1,rc2,third/0.123d0,0.08d0,0.333333333d0/ c c ***general resolved resonance subsection formats (lcomp=1) c ***compact resolved resonance subsection formats (lcomp=2) IF (lcomp.eq.1) then call contio(nendf,0,0,a(l),nb,nw) awri=c1h nsrs=n1h nlrs=n2h if (nsrs.gt.0) then arat=awri/(awri+1) aw=amassn*awri ra=rc1*aw**third+rc2 ral=ra apl=ap endif if (nsrs.le.0) go to 600 else call Resprx_RRR_Lcomp2(nwscr,cov,mxnpar,a) endif c c ***write MF=2 data on b array c call Resprx_skiprp(nscr6,b,is,ie) call contio(nscr6,0,0,b,nb,nw) lru1=l1h lrf1=l2h lb=7 call contio(nscr6,0,0,b(lb),nb,nw) nls1=n1h spi1=c1h if (lru.ne.lru1.or.lrf.ne.lrf1) then write(strng2,'(''lru/lrf(mf=32)='',i3,''/'',i3, & '' vs. lru/lrf(mf=2)='',i3,''/'',i3)')lru,lrf,lru1,lrf1 call error('resprx', & 'different type of resonance for lcomp=1',strng2) endif lb=lb+6 l2=lb c do il=1,nls1 itmp=l2 call listio(nscr6,0,0,b(l2),nb,nw) l2=l2+nw 430 continue if (nb.eq.0) go to 440 call moreio(nscr6,0,0,b(l2),nb,nw) l2=l2+nw if (l2.gt.maxb) then write(strng2,'(''l2='',i8,'' maxb='',i8)')l2,maxb call error('resprx','storage exceeded.',strng2) endif go to 430 440 continue c ind=itmp if (lrf1.eq.3) then apl=b(ind+1) if (apl.eq.0.) apl=ap endif if (naps.eq.1) then ral=apl ra=ap endif ll=nint(b(ind+2)) llmat(il)=ll nrs1=nint(b(ind+5)) do nr=1,nrs1 rho=cwaven*arat*sqrt(abs(b(ind+6*nr)))*ral call facts(ll,rho,ser,per) b(l2)=ser b(l2+1)=per b(l2+2)=0 l2=l2+3 enddo enddo c lb2=l2 l3=lb2 c c ***end of writing MF=2 data to b array c if (lcomp.eq.1) then L = L + 6 nsmax = nsrs else nsmax = 1 endif c c ***loop over the number of "sections" of covariance matrix c ***store that information in array "a" do ns=1,nsmax if (lcomp.eq.1) then l1=l call listio(nendf,0,0,a(l1),nb,nw) l1=l1+nw 410 continue if (nb.eq.0) go to 420 call moreio(nendf,0,0,a(l1),nb,nw) l1=l1+nw go to 410 420 continue if ((l1-iscr).gt.nwscr) then write(strng2,'(''require='',i8, & '' supply='',i8, & '' for nwds given in s.covout'')') & l1-iscr,nwscr call error('resprx', & 'storage exceeded in lcomp=1.',strng2) endif mpar=nint(a(l+2)) nrb=nint(a(l+5)) nvs1=6*nrb nvs2=nint(a(l+4))-nvs1 npar=mpar*nrb if (npar+1.gt.mxnpar) then write(strng2,'(''npar='',i8, '' +1 > mxnpar='',i8)') & npar,mxnpar call error('resprx','storage exceeded.', strng2) endif endif c if (mpar.gt.4 .and. lrf.le.2) then write(nsyso,*)'Not coded' stop endif if (lrf.le.0 .or. lrf.gt.3) then write(strng2,'(''lrf='',i3,'' is no coding.'')') lrf call error('resprx','lcomp=1 general form.',strng2) endif c ipos=0 loop=0 do loopm=1,nrb do loopn=1,mpar loop=loop+1 if (loopn.eq.1) then write (*,10200) loopm, nrb 10200 format & ('Resonance number',I5,'(/',I5,') Resonance energy') else write (*,10300) loopm, nrb, loopn-1 10300 format & ('Resonance number',I5,'(/',I5,') Width number', I2) endif c ***search aimed mf32 resonance in mf=2 if(loopn.eq.1)then eres =a(l+6*loopm) ajres=a(l+6*loopm+1) il2=lb do il=1,nls1 itmp=il2 ipara=b(il2+5) if(ipara.ne.0)then do ipp=1,ipara il2=il2+6 eres2 =b(il2) ajres2=b(il2+1) if(eres*eres2.gt.0)then rr=abs(eres/eres2-1.) rr2=abs(ajres-ajres2) if(rr.lt.1d-6.and.rr2.lt.1d-4)then ipos=itmp+6+ipara*6+(ipp-1)*3 goto 461 endif endif enddo il2=il2+6 il2=il2+ipara*3 endif enddo write(*,*)'error in resprx_Lcomp_12' write(*,*)'E:',eres write(*,*)'ajres',ajres stop 461 continue ilnum=il endif c ***perturbed(-) if(loopn.eq.1)then il3=il2 backdt=b(il2) b(il2)=backdt*0.9999 gwidth=backdt*0.0001 backdt2=b(ipos) backdt3=b(ipos+1) rho=cwaven*arat*sqrt(abs(b(il2)))*ral lldum=llmat(il) call facts(lldum,rho,ser,per) b(ipos)=ser b(ipos+1)=per else if (lrf.eq.1 .or. lrf.eq.2) then il3 = il2 + Loopn + 1 elseif (lrf.eq.3) then il3 = il2 + Loopn endif backdt=b(il3) gwidth=backdt*0.01d0 b(il3)=backdt*0.99d0 endif if(gwidth.ne.zero) & call resprx_cal_pendf(ii,ilnum,ajres,a,sigr,eres,b,maxb) c b(il3)=backdt if(loopn.eq.1)then b(ipos)=backdt2 b(ipos+1)=backdt3 endif c ***perturbed(+) if(loopn.eq.1)then il3=il2 b(il2)=backdt*1.0001 rho=cwaven*arat*sqrt(abs(b(il2)))*ral lldum=llmat(il) call facts(lldum,rho,ser,per) b(ipos)=ser b(ipos+1)=per else b(il3)=backdt*1.01d0 endif if(gwidth.ne.zero) & call resprx_cal_pendf(ii,ilnum,ajres,a,sigp,eres,b,maxb) c b(il3)=backdt if(loopn.eq.1)then b(ipos)=backdt2 b(ipos+1)=backdt3 endif if(gwidth.ne.zero)then c ***differencing do ii1=1,4 do ii2=1,ii tmp=(sigp(ii2,ii1)-sigr(ii2,ii1))/(gwidth*2) sigp(ii2,ii1)=tmp enddo enddo c ***integration call Resprx_grping(ngn,egn,sigp,ii,gsig(1,1),a) c ***sensitivity calculation do ig=iest,ieed tmp=a(icflx-1+ig)*abn do j=1,4 sens(j,Loop,ig)=gsig(j,ig)*tmp enddo enddo else do ig=iest,ieed do j=1,4 sens(j,Loop,ig)=0. enddo enddo endif c enddo c ***end of do-loop over number of parameters per resonance enddo c ***end of do-loop over number of resonances if(lcomp.eq.1)then l3=l+5+nvs1 do i=1,npar do j=i,npar l3=l3+1 tmp=a(l3) cov(i,j)=tmp cov(j,i)=tmp enddo enddo endif c igind=0 do ig=1,ieed do ig2=ig,ngn igind=igind+1 if(ig.ge.iest.and.ig.le.ieed.and. & ig2.ge.iest.and.ig2.le.ieed)then itmp1=icff+igind-1 itmp2=icgg+igind-1 itmp3=icee+igind-1 itmp4=ictt+igind-1 do i=1,npar do j=i,npar tmp=cov(i,j) if (tmp.ne.zero) then a(itmp1)=a(itmp1)+tmp*sens(3,i,ig)*sens(3,j,ig2) a(itmp2)=a(itmp2)+tmp*sens(4,i,ig)*sens(4,j,ig2) a(itmp3)=a(itmp3)+tmp*sens(2,i,ig)*sens(2,j,ig2) a(itmp4)=a(itmp4)+tmp*sens(1,i,ig)*sens(1,j,ig2) if(i.ne.j)then a(itmp1)=a(itmp1)+tmp*sens(3,j,ig)*sens(3,i,ig2) a(itmp2)=a(itmp2)+tmp*sens(4,j,ig)*sens(4,i,ig2) a(itmp3)=a(itmp3)+tmp*sens(2,j,ig)*sens(2,i,ig2) a(itmp4)=a(itmp4)+tmp*sens(1,j,ig)*sens(1,i,ig2) endif endif enddo enddo endif enddo if (ig.gt.nresg) nresg=ig enddo c igind=0 do ig=1,ieed do ig2=1,ngn igind=igind+1 if(ig.ge.iest.and.ig.le.ieed.and. & ig2.ge.iest.and.ig2.le.ieed)then itmp1=icef+igind-1 itmp2=iceg+igind-1 itmp3=icfg+igind-1 do i=1,npar do j=i,npar tmp=cov(i,j) if (tmp.ne.zero) then a(itmp1)=a(itmp1)+tmp*sens(2,i,ig)*sens(3,j,ig2) a(itmp2)=a(itmp2)+tmp*sens(2,i,ig)*sens(4,j,ig2) a(itmp3)=a(itmp3)+tmp*sens(3,i,ig)*sens(4,j,ig2) if(i.ne.j)then a(itmp1)=a(itmp1)+tmp*sens(2,j,ig)*sens(3,i,ig2) a(itmp2)=a(itmp2)+tmp*sens(2,j,ig)*sens(4,i,ig2) a(itmp3)=a(itmp3)+tmp*sens(3,j,ig)*sens(4,i,ig2) endif endif enddo enddo endif enddo enddo enddo c ***end of "sections of covariance matrix" from ENDF File32 c 600 continue if (nlrs.gt.0) then do ns=1,nlrs call listio(nendf,0,0,a(l),nb,nw) idp=nint(a(l+2)) lb=nint(a(l+3)) nt=nint(a(l+4)) np=nint(a(l+5)) l1=l+nw 610 continue if (nb.eq.0) go to 620 call moreio(nendf,0,0,a(l1),nb,nw) l1=l1+nw go to 610 620 continue stop 'no coding of nlrs>0' enddo endif ifresr=1 return end c subroutine Resprx_RRR_Lcomp2(nwscr,cov,mxnpar,a) c ****************************************************************** c lru = 1, lcomp = 2 Generate covariance matrix for point-wise xs c ****************************************************************** implicit real*8 (a-h,o-z) common/reson1/ap,arat,ra,spifac,ll common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common/amnc/amassn character*60 strng1,strng2 dimension a(*) dimension kk(18) dimension cov(mxnpar,mxnpar) data rc1,rc2,third/0.123d0,0.08d0,0.333333333d0/ c do i1=1,mxnpar do i2=1,mxnpar cov(i1,i2)=0 enddo enddo nrb=0 nind=1 lbg=l do nn=1,nls l1=l call listio(nendf,0,0,a(l1),nb,nw) l1=l1+nw 414 if (nb.eq.0) go to 415 call moreio(nendf,0,0,a(l1),nb,nw) l1=l1+nw go to 414 415 continue if ((l1-iscr).gt.nwscr) then write(strng2,'(''require='',i8,'' supply='',i8, & '' for nwds given in s.covout'')') l1-iscr,nwscr call error('resprx','storage exceeded in lcomp=1.', & strng2) endif if(nn.eq.1)then awri=a(l) arat=awri/(awri+1) aw=amassn*awri ra=rc1*aw**third+rc2 ral=ra apl=ap endif mpar=nint(a(l+2)) nrb=nrb+nint(a(l+5)) l3=l do n2=1,nint(a(l+5)) l3=l3+12 cov(nind,nind)=a(l3) cov(nind+1,nind+1)=a(l3+2) cov(nind+2,nind+2)=a(l3+3) nind=nind+3 enddo l3=lbg+(nrb-nint(a(l+5))+1)*6 l2=l+6 do n2=1,nint(a(l+5)) do n3=1,6 a(l3+n3-1)=a(l2+n3-1) enddo l3=l3+6 l2=l2+12 enddo l=l1 enddo c *** read correlation matrix read(nendf,411)nnn,nm,nx 411 format(33x,3i11) do n2=1,nm read(nendf,412)nn1,nn2,(kk(nn3),nn3=1,18) 412 format(i5,i5,1x,18i3) nn2p=nn2-1 do n3=1,18 nn2p=nn2p+1 if(nn2p.ge.nn1) goto 413 if(kk(n3).gt.0)then cov(nn2p,nn1)=((kk(n3)+0.5)/100.0)* & cov(nn2p,nn2p)*cov(nn1,nn1) cov(nn1,nn2p)=cov(nn2p,nn1) else IF (Kk(N3).LT.0) THEN cov(nn2p,nn1)=(-(-kk(n3)+0.5)/100.0)* & cov(nn2p,nn2p)*cov(nn1,nn1) cov(nn1,nn2p)=cov(nn2p,nn1) endif enddo 413 continue enddo c if(mpar.ne.3)then write(*,"('mpar=',i5)")mpar mpar=3 endif c npar=nrb*mpar if (npar+1.gt.mxnpar) then write(strng2,'(''npar='',i8, '' +1 > mxnpar='',i8)') & npar,mxnpar call error('resprx','storage exceeded.', strng2) endif do n1=1,npar cov(n1,n1)=cov(n1,n1)*cov(n1,n1) enddo l=lbg c return end c subroutine Resprx_Unr(a,amu,mxlru2,iest,ieed) c ****************************************************************** c Unresolved resonance region (lru=2) c ****************************************************************** implicit real*8 (a-h,o-z) parameter(maxb=4000,mxnpar=100,maxe=400000) common/mainio/nsysi,nsyso,nsyse,ntty common/err0/nresg common/err3/ifresr,ifunrs common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,nscrg,nscrt common/grpn/ign,ngn,egn(901),iprint common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral character*60 strng1,strng2 dimension a(*) dimension sig(maxe,5), sig1(4) dimension gsigr(4,901), gsigp(4,901) dimension sens(4,mxnpar,901) dimension cov(mxnpar,mxnpar) dimension amu(3,mxlru2) dimension b(maxb) data Zero /0.0d0/ c write(*,*)'Unresolved resonance energy range.' l=iscr l1=l+6 do nl=1,nls call listio(nendf,0,0,a(l1),nb,nw) l1=l1+nw 810 continue if (nb.eq.0) go to 820 call moreio(nendf,0,0,a(l1),nb,nw) l1=l1+nw go to 810 820 continue enddo call listio(nendf,0,0,a(l1),nb,nw) l2=l1+nw 830 continue if (nb.eq.0) go to 840 call moreio(nendf,0,0,a(l2),nb,nw) l2=l2+nw go to 830 840 continue c mpar=nint(a(l1+2)) npar=nint(a(l1+5)) if (npar+1.gt.mxnpar) then write(strng2,'(''npar='',i8,'' +1 > mxnpar='',i8)') & npar,mxnpar call error('resprx','storage exceeded (lru=2).',strng2) endif c do ig=1,ngn do i=1,npar do j=1,4 sens(j,i,ig)=0 enddo enddo enddo c njs=0 inow=6 l0=l1-l l2=l0+1 c do 850 loop=1,npar+1 do i=1,l0 b(i)=a(l+i-1) enddo if (loop.eq.1) go to 860 loopm=(loop-2)/mpar loopn=mod(loop-1,mpar) if (loopn.eq.1.or.mpar.eq.1) then if (njs.eq.0) then njs=nint(b(inow+6)) else njs=njs-1 endif inow=inow+6 l2=l2+1 b(l2)=b(inow+1) b(inow+1)=b(inow+1)*1.01d0 elseif (loopn.eq.2.or.(mpar.eq.2.and.loopn.eq.0)) then l2=l2+1 b(l2)=b(inow+3) b(inow+3)=b(inow+3)*1.01d0 elseif (loopn.eq.3.or.(mpar.eq.3.and.loopn.eq.0)) then l2=l2+1 b(l2)=b(inow+4) b(inow+4)=b(inow+4)*1.01d0 elseif (loopn.eq.4.or.(mpar.eq.4.and.loopn.eq.0)) then if (lfw.eq.1) then l2=l2+1 b(l2)=b(inow+5) b(inow+5)=b(inow+5)*1.01d0 elseif (lfw.eq.0) then l2=l2+1 b(l2)=b(inow+6) b(inow+6)=b(inow+6)*1.01d0 endif elseif (loopn.eq.5.or.(mpar.eq.5.and.loopn.eq.0)) then l2=l2+1 b(l2)=b(inow+6) b(inow+6)=b(inow+6)*1.01d0 endif if (loopn.eq.0.and.njs.eq.1) then inow=inow+6 njs=0 endif 860 continue e1=elg ii=0 go to 880 c 870 continue e1=e1*1.015d0 ebc=e1/1.015d0 if(ebc.lt.el.and.e1.gt.el)e1=el if(ebc.lt.eh.and.e1.gt.eh)e1=eh 880 continue if (e1.gt.ehg) e1=ehg if(e1.GE.el.and.e1.LE.eh)then call ggunr1(e1,sig1,b,amu,mxlru2) else do i=1,4 sig1(i)=0.0 enddo endif ii=ii+1 if (ii.gt.maxe) call error('resprx', & 'number of pointwise xsec of resonance exceeded.', & 'please increase the maxe parameter.') do i=1,4 sig(ii,i)=sig1(i) enddo sig(ii,5)=e1 if (e1.ge.ehg) go to 890 go to 870 890 continue if(loop.eq.1)then call Resprx_grping(ngn,egn,sig,ii,gsigr,a) else call Resprx_grping(ngn,egn,sig,ii,gsigp,a) c ***sensitivity calculation do ig=iest,ieed do j=1,4 sfac=gsigr(j,ig) i=loop-1 if (b(l0+1+i).ne.zero) then s=gsigp(j,ig)-sfac s=100*s/b(l0+1+i) if (abs(s).ge.1.d-10) then sens(j,i,ig)=s*a(icflx-1+ig)*abn endif endif enddo enddo c endif 850 continue c l2=l0+1 l3=l1+5 do i=1,npar do j=i,npar l3=l3+1 bb=b(l2+i)*b(l2+j) tmp=a(l3)*bb cov(i,j)=tmp cov(j,i)=tmp enddo enddo c igind=0 do ig=1,ngn do ig2=ig,ngn igind=igind+1 if(ig.ge.iest.and.ig.le.ieed.and. & ig2.ge.iest.and.ig2.le.ieed)then do i=1,npar do j=1,npar if (cov(i,j).eq.zero) go to 910 a(iuff-1+igind)=a(iuff-1+igind)+ & cov(i,j)*sens(3,i,ig)*sens(3,j,ig2) a(iugg-1+igind)=a(iugg-1+igind)+ & cov(i,j)*sens(4,i,ig)*sens(4,j,ig2) a(iuee-1+igind)=a(iuee-1+igind)+ & cov(i,j)*sens(2,i,ig)*sens(2,j,ig2) a(iutt-1+igind)=a(iutt-1+igind)+ & cov(i,j)*sens(1,i,ig)*sens(1,j,ig2) 910 continue enddo enddo endif if (ig.gt.nresg) nresg=ig enddo 915 continue enddo c igind=0 do ig =1,ngn do ig2=1,ngn igind=igind+1 do i=1,npar if(sens(1,i,ig).eq.zero. and. & sens(2,i,ig).eq.zero. and. & sens(3,i,ig).eq.zero. and. & sens(4,i,ig).eq.zero) go to 920 do j=1,npar if (cov(i,j).eq.zero) go to 925 a(iuef+igind-1)=a(iuef+igind-1)+ & cov(i,j)*sens(2,i,ig)*sens(3,j,ig2) a(iueg+igind-1)=a(iueg+igind-1)+ & cov(i,j)*sens(2,i,ig)*sens(4,j,ig2) a(iufg+igind-1)=a(iufg+igind-1)+ & cov(i,j)*sens(3,i,ig)*sens(4,j,ig2) 925 continue enddo 920 continue enddo enddo enddo c ifunrs=1 write(*,*)'... ended.' return end c subroutine Resprx_cal_pendf(ii,npnls,valspi,a,sig,eres,b,maxb) c ****************************************************************** c Calculation of point-wise cross section in Lcomp1 or 2 c ****************************************************************** implicit real*8 (a-h,o-z) parameter(maxe=400000) common/mainio/nsysi,nsyso,nsyse,ntty common /Resprxxx/ icff,icfg,icgg,icee,icef,iceg,ictt,iuff,iufg, & iugg,iuee,iuef,iueg,iutt,iscr,icflx,nis,lfw,nls,lrf,naps,nsrs, & nvs1,Mpar,Npar,il2,il3,nrb,lru,nlrs,lcomp,l,nls1,l3,lb, & nscr6,is,ie,l2 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral common/irspd/eskip1,eskip2,eskip3 dimension b(maxb) dimension sig(maxe,5), sig1(4) dimension a(*) c e1=elg ii=0 c elb1=0.9*eres elu1=1.1*eres elb2=0.8*eres elu2=1.2*eres elb3=0.7*eres elu3=1.3*eres c 520 continue if (e1.gt.ehg) e1=ehg if (e1.ge.el.and.e1.le.eh)then if (lrf.eq.3) then call ggrmat(e1,sig1,b(1),npnls,valspi) elseif (lrf.eq.2) then call ggmlbw(e1,sig1,b(1)) endif else do i=1,4 sig1(i)=0 enddo endif c ii=ii+1 if (ii.gt.maxe) call error('resprx', & 'number of pointwise xsec of resonance exceeded.', & 'please increase the maxe parameter.') c do i=1,4 sig(ii,i)=sig1(i) enddo sig(ii,5)=e1 c if (e1.lt.ehg) then if(e1.lt.0.1)then e2=1.05 else if(e1.gt.elb1.and.e1.lt.elu1)then e2=eskip1 else if(e1.gt.elb2.and.e1.lt.elu2)then e2=eskip2 else if(e1.gt.elb3.and.e1.lt.elu3)then e2=eskip3 else e2=1.02 endif ebc=e1 e1=e1*e2 if(ebc.lt.el.and.e1.gt.el)e1=el if(ebc.lt.eh.and.e1.gt.eh)e1=eh go to 520 endif c return end c subroutine Resprx_dumrd2(matd,nendf,nscr6,a,amu,mxlru2) c ****************************************************************** c dummy read the resonance parameters (mf=2). c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension a(*),amu(3,mxlru2) character strng*60 data nscr16/0/ c c ***read mf=2 (resonance parameters) call findf(matd,2,151,nendf) call contio(nendf,nscr6,0,a,nb,nw) nis=n1h nlru2=0 c c ***loop over all isotopes do ni=1,nis call contio(nendf,nscr6,0,a,nb,nw) lfw=l2h ner=n1h c c ***loop over all energy ranges do ne=1,ner call contio(nendf,nscr6,0,a,nb,nw) lru=l1h lrf=l2h nro=n1h if (nro.gt.0) call tab1io(nendf,nscr6,0,a,nb,nw) c c ***breit-wigner if (lru.eq.1.and.(lrf.eq.1.or.lrf.eq.2)) then call contio(nendf,nscr6,0,a,nb,nw) nls=n1h do nl=1,nls call listio(nendf,nscr6,0,a,nb,nw) 110 if (nb.eq.0) go to 120 call moreio(nendf,nscr6,0,a,nb,nw) go to 110 120 continue enddo c c ***reich-moore elseif (lru.eq.1.and.lrf.eq.3) then call contio(nendf,nscr6,0,a,nb,nw) nls=n1h do nl=1,nls call listio(nendf,nscr6,0,a,nb,nw) 130 if (nb.eq.0) go to 140 call moreio(nendf,nscr6,0,a,nb,nw) go to 130 140 continue enddo c c ***unresolved resonance (lrf=1,lfw=0) elseif (lru.eq.2.and.lrf.eq.1.and.lfw.eq.0) then call contio(nendf,nscr6,0,a,nb,nw) nls=n1h do nl=1,nls call listio(nendf,nscr6,0,a,nb,nw) 150 if (nb.eq.0) go to 160 call moreio(nendf,nscr6,0,a,nb,nw) go to 150 160 continue enddo call error('dumrd2','lru=2/lrf=1/lfw=0: amu? no coding', & ' ') c c ***unresolved resonance (lrf=1,lfw=1) elseif (lru.eq.2.and.lrf.eq.1.and.lfw.eq.1) then call listio(nendf,nscr6,0,a,nb,nw) nls=nint(a(6)) do nl=1,nls call contio(nendf,nscr6,0,a,nb,nw) njs=n1h do nj=1,njs call listio(nendf,nscr6,0,a,nb,nw) 170 if (nb.eq.0) go to 180 call moreio(nendf,nscr6,0,a,nb,nw) go to 170 180 continue enddo enddo call error('dumrd2','lru=2/lrf=1/lfw=1: amu? no coding', & ' ') c c ***unresolved resonance (lrf=2) elseif (lru.eq.2.and.lrf.eq.2) then call contio(nendf,nscr6,0,a,nb,nw) nls=n1h do nl=1,nls call contio(nendf,nscr6,0,a,nb,nw) njs=n1h do nj=1,njs call listio(nendf,nscr6,0,a,nb,nw) nlru2=nlru2+1 amu(1,nlru2)=a(10) amu(2,nlru2)=a(12) amu(3,nlru2)=a(9) 190 if (nb.eq.0) go to 200 call moreio(nendf,nscr6,0,a,nb,nw) go to 190 200 continue enddo enddo c else write(strng,'('' *** lru='',i3,'' lrf='',i3, & '' no coding.'')') lru,lrf call error('dumrd2',strng,' ') endif if (nlru2.gt.mxlru2) call error('dumrd2', & 'nlru2 was exceeded mxlru2',' ') enddo enddo c return end c subroutine Resprx_grping(igx,egn,sig,ipoint,gsig,a) c ****************************************************************** c convert pointwise cross sections to simplistic groupwise ones. c ****************************************************************** implicit real*8 (a-h,o-z) parameter(maxe=400000) common/ewght/iwt dimension a(*),egn(*),sig(maxe,5),gsig(4,901) data half,zero/0.5d0,0.d0/ data two, three, six /2.0d0, 3.0d0, 6.0d0 / c do k=1,igx do i=2,4 gsig(i,k)=0 enddo enddo c sumde=0 lord=0 i0=1 100 continue do ig=1,igx if (sig(i0,5).ge.egn(ig).and.sig(i0,5).lt.egn(ig+1)) go to 110 enddo if (i0.lt.ipoint) then i0=i0+1 go to 100 else stop 'grping: no coding for i0>ipoint' endif 110 continue c x1=sig(i0,5) call egtwtf(x1,enext,idis,lord,wt1,a) c ***loop over all pointwise cross sections in a range do i=i0+1,ipoint c wt2 = wt1 x2 = x1 x1 = sig(i,5) x12 = x1-x2 egnt = egn(ig) egnt1= egn(ig+1) call egtwtf(x1,enext,idis,lord,wt1,a) if (x1.ge.egnt.and.x1.le.egnt1) then de = half * (x1-x2) * (wt1+wt2) sumde=sumde+de z1 = (two*wt1+wt2)*x12/six z2 = (two*wt2+wt1)*x12/six do j=2,4 y1=sig(i,j) y2=sig(i-1,j) if (y1.ne.zero .or. y2.ne.zero) then xx = y1*z1 + y2*z2 gsig(j,ig)=gsig(j,ig)+xx endif enddo if (x1.eq.egnt1) then do j=2,4 gsig(j,ig)=gsig(j,ig)/sumde enddo ig=ig+1 sumde=0 endif else if (x1.gt.egnt1) then ebb=egnt1 Ebx = Ebb - X2 Wt12 = Wt1 - Wt2 De = Half*Wt12*Ebx/x12 + Wt2 De = Ebx * Wt2 sumde=sumde+de Ebx2 = Ebx**2 Z1 = (Ebx /x12) * Wt12/Three + wt2/Two Z1 = (Ebx2/x12) * Z1 Z2 =-(Ebx /x12) * Wt12/Three + (wt1/Two-wt2) Z2 = (Ebx /x12) * Z2 + wt2 Z2 = Ebx * Z2 do j=2,4 y1=sig(i,j) y2=sig(i-1,j) if (y1.ne.zero .or. y2.ne.zero) then Xx = Y1*Z1 + Y2*Z2 gsig(j,ig)=gsig(j,ig)+xx endif enddo do j=2,4 gsig(j,ig)=gsig(j,ig)/sumde enddo ig=ig+1 Ebx = X1 - Ebb De = - Half*Wt12*Ebx/x12 + Wt2 De = Ebx * Wt2 sumde=de Ebx2 = Ebx**2 Z1 = (Ebx /x12) * Wt12/Three + (wt2/Two-wt1) Z1 = (Ebx /x12) * Z1 + wt1 Z1 = Ebx * Z1 Z2 =-(Ebx /x12) * Wt12/Three + wt1/Two Z2 = (Ebx2/x12) * Z2 do j=2,4 y1=sig(i,j) y2=sig(i-1,j) if (y1.ne.zero .or. y2.ne.zero) then Xx = Y1*Z1 + Y2*Z2 gsig(j,ig)=gsig(j,ig)+xx endif enddo endif enddo c c ***calculate group total cross section do k=1,igx gsig(1,k)=gsig(2,k)+gsig(3,k)+gsig(4,k) enddo c return end c subroutine Resprx_skiprp(iu,adim,ni,ne) c ****************************************************************** c skip to the resonance parameter of subsection requested by ni & ne c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension adim(*) character strng*60 c call repoz(iu) call contio(iu,0,0,adim,nb,nw) nis1=n1h do ni1=1,nis1 call contio(iu,0,0,adim,nb,nw) ner1=n1h do ne1=1,ner1 if (ni1.eq.ni.and.ne1.eq.ne) go to 130 call contio(iu,0,0,adim,nb,nw) lrf1=l2h if (lrf1.ge.4) then write(strng,'(''lrf='',i3)') lrf1 call error('skiprp','no coding type',strng) endif call contio(iu,0,0,adim,nb,nw) nls1=n1h do nl1=1,nls1 call listio(iu,0,0,adim,nb,nw) 110 if (nb.eq.0) go to 120 call moreio(iu,0,0,adim,nb,nw) go to 110 120 continue enddo enddo enddo 130 continue c return end c subroutine grpav4(mprint,a) c ****************************************************************** c compute multigroup legendre coefficients for reaction needed in c the calculation of the covariance matrices. calculation uses the c union of the user specified group structure and the energy c grid found in mfcov. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr,ntot,nscr3 common/eunits34/nscr4 common/mainio/nsysi,nsyso,nsyse,ntty common/util/npage,iverf common/argcom/matl,mfd,mtd common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/err4/legord,irespr,ifissp common/tramat/u1lele(10),plele(901,10) character*60 strng character*66 text dimension a(*),ans(10,2),z(26) data eps/1.d-9/ data big/1.d10/ data elow/1.d-5/ zero=0 c c ***initialize if (iread.eq.2) call error('grpav4', & 'not coded for multimaterial group averaging.',' ') call timer(sec) write(nsyso,'(/,'' computing multigroup legendre coef.'', & 33x,f8.1,''s'')') sec call egnwtf(a) nwds=npage+50 call reserv('scr',nwds,iscr,a) nscr4=14 if (nendf.lt.0) nscr4=-nscr4 call openz(nscr4,1) call repoz(nscr4) math=1 mfh=0 mth=0 text=' ' nw=17 read(text,'(16a4,a2)') (z(i),i=1,nw) call tpidio(0,nscr4,0,z,nb,nw) call findex('un',iun,a) iun1=iun-1 if (abs(egn(1)-elow).le.eps) egn(1)=elow etop=a(iun+nunion) c c ***search for desired mat on nendf tape call repoz(nendf) call findf(matd,1,0,nendf) call contio(nendf,0,0,a(iscr),nb,nw) za=c1h awr=c2h c c ***main loop over reactions call findex('ga',iga,a) matl=matd mfd=4 math=matd mfh=4 mtold=0 il=10 iz=1 nw=legord*iz+1 do 300 imt=1,nga mtd=nint(a(iga+imt-1)) call timer(time) mth=mtd z(1)=za z(2)=awr z(3)=1 z(4)=legord z(5)=0 z(6)=nunion call contio(0,nscr4,0,z,nb,nwds) c c ***initialize ng2=2 e=0 call egtlgc(e,thresh,idis,al,a) if (thresh.gt.etop) go to 270 call egtflx(e,enext,idis,flux,nl,nz,a) if (mprint.ne.0) then write(nsyso,30) legord,time if (ntty.gt.0) write(ntty,31) legord,time write(nsyso,32) u1lele(2) write(nsyso,45) mfd,mtd,' (same as mf=3/mt=251)' if (ntty.gt.0) write(ntty,45) mfd,mtd, & ' (same as mf=3/mt=251)' write(nsyso,10) endif call findex('un',iun,a) c c ***loop over initial energy groups do 260 ig=1,nunion elo=a(iun+ig-1) ehi=a(iun+ig) ig2lo=0 enext=ehi do j=1,2 do i=1,il ans(i,j)=0 enddo enddo c 220 call epanel(elo,enext,ans,il,iz,ig2lo,34,a) if (abs(enext/ehi-1.).lt.eps) goto 230 elo=enext enext=ehi go to 220 230 continue c c ***write this group on nscr4 tape do i=1,9 ans(i,2)=ans(i,2)/ans(1,1) plele(ig,i)=ans(i,2) c ***legendre coefficient a_i in center mass system enddo ans(1,2)=ans(1,2)*u1lele(2) c if (mprint.ne.0) write(nsyso,70) ig,(ans(i,2),i=1,legord) if (ig.ne.nunion) then do 245 i=1,legord 245 if (ans(i,2).ne.0.) go to 250 go to 260 endif 250 mfh=mfd mth=mtd z(1)=0. z(2)=0. z(3)=ng2 z(4)=ig2lo z(5)=nw z(6)=ig z(7)=ans(1,1) do 255 i=1,legord 255 z(i+7)=ans(i,2) nwds=legord+7 call listio(0,nscr4,0,z,nb,nwds) 260 continue call asend(nscr4,0) go to 280 c ***write message if mt has threshold gt highest union energy 270 write(strng,'(''mf '',i2,'' mt '',i3)') mfd,mtd call mess('grpav4',strng, & 'has threshold gt highest union energy.') 280 call releas('alnr',-1,a) 300 continue c c ***grpav4 is finished. call afend(nscr4,0) call amend(nscr4,0) call atend(nscr4,0) call releas('scr',-1,a) call releas('ga',0,a) call timer(sec) write(nsyso,40) sec if (ntty.gt.0) write(ntty,41) sec return c 10 format(5x,'group',5x,'legendre constant') 30 format(/,' legendre group constants: pl-order 1 to ',i2,26x,f8.1, & 's') 31 format(1x,'pl=',i2,3x,f8.1,'s') 32 format(' u(1,1) element of transformation matrix (cm -> lab)=', & 1pe12.5) 40 format(/,' legendre group averaging completed',34x,f8.1,'s',/) 41 format(/,' legendre group averaging completed',/,1x,f8.1,'s') 45 format(' for mf',i2,' and mt',i3,a) 70 format(4x,i4,5x,1p,6e11.3:/(13x,6e11.3)) end c c subroutine alsigc(ncg,alsig,cflx,b,egt,flux,sig,alp,ld,ld1,mt1, & mt2) c ****************************************************************** c calculate the coarse group legendre*sigma. c ****************************************************************** implicit real*8 (a-h,o-z) common/grpn/ign,ngn,egn(901),iprint common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/eunits/nendf,npend,nout,nin,ngout,nstan,nunit(3) common/eunits34/nscr4 common/tramat/u1lele(10),plele(901,10) dimension alsig(ncg,*),cflx(ncg,*),b(*),egt(*),flux(*),sig(*), & alp(*) data mfinit/0/ c c ***initialize if (nlump.gt.0) call error('alsigc','no coded lump xsec.',' ') if (mfinit.ne.0) go to 200 mfinit=34 c ***call sigfig to cure the bit-dropping problem do 110 i=1,nunion+1 110 egt(i)=sigfig(egt(i),ndig,0) do 120 i=1,ngn+1 120 egn(i)=sigfig(egn(i),ndig,0) c c ***compute cross-group legendre*sigma*flux and sigma*flux 200 call rdsig(matd,mt1,b,sig) call rdlgnd(nscr4,matd,mt1,ld,b,alp) do 220 ig=1,ngn alsig(ig,1)=0. cflx(ig,1)=0. do 210 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 210 alsig(ig,1)=alsig(ig,1)+alp(jg)*sig(jg)*flux(jg) cflx(ig,1)=cflx(ig,1)+sig(jg)*flux(jg) 210 continue 220 alsig(ig,1)=alsig(ig,1)/cflx(ig,1) call rdsig(matd,mt2,b,sig) call rdlgnd(nscr4,matd,mt2,ld1,b,alp) do 240 ig=1,ngn alsig(ig,2)=0. cflx(ig,2)=0. do 230 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 230 alsig(ig,2)=alsig(ig,2)+alp(jg)*sig(jg)*flux(jg) cflx(ig,2)=cflx(ig,2)+sig(jg)*flux(jg) 230 continue 240 alsig(ig,2)=alsig(ig,2)/cflx(ig,2) return end c subroutine egtlgc(e,enext,idis,al,a) c ****************************************************************** c retrieve the legendre coefficient defined by mfd and mtd. c initialize if e=0. c ****************************************************************** implicit real*8 (a-h,o-z) parameter (maxleg=64) common/eunits/nendf,npend,nunit(7) common/argcom/matd,mfd,mtd common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc common/tabl/nr,nbt(20),jnt(20) common/util/npage,iverf common/tramat/u1lele(10),plele(901,10) dimension al(*),a(*),al1(maxleg),al2(maxleg) save nsig,int,nnr,ne,nne,nl1,nl2,e1,e2,al1,al2 c c ***initialize idis=0 if (e.gt.0.) go to 200 nsig=nendf mf=4 mt=mtd call findf(matd,mf,mt,nsig) nw=46 call reserv('alnr',nw,ialnr,a) nw=70 call reserv('alg',nw,ialg,a) call contio(nsig,0,0,a(ialnr),nb,nw) aww=c2h lvt=l1h ltt=l2h if (lvt.eq.1) then nw=(maxleg+1)**2+6 call reserv('alv',nw,ialv,a) call listio(nsig,0,0,a(ialv),nb,nw) ialv1=ialv 105 if (nb.eq.0) go to 106 ialv1=ialv1+nw call moreio(nsig,0,0,a(ialv1),nb,nw) go to 105 106 continue nm=nint(a(ialv+5)) do 107 ij = 1 , 10 u1lele(ij)=a(ialv+6+(nm+1)+ij-1) 107 continue call releas('alv',0,a) else call contio(nsig,0,0,a(ialnr),nb,nw) call matrixin(aww,u1lele) endif if (ltt.eq.2) call error('egtlgc','no coded for ltt=2.',' ') call tab2io(nsig,0,0,a(ialnr),nb,nw) nr=n1h ne=n2h if (nsig.lt.0) then do 110 i=1,nr nbt(i)=nint(a(ialnr+i*2+4)) 110 jnt(i)=nint(a(ialnr+i*2+5)) endif int=jnt(1) call listio(nsig,0,0,a(ialg),nb,nw) e1=c2h nl1=n1h do 120 i=1,nl1 120 al1(i)=a(ialg+5+i) if (nl1.lt.maxleg) then do 125 i=nl1+1,maxleg 125 al1(i)=0. endif call listio(nsig,0,0,a(ialg),nb,nw) e2=c2h nl2=n1h do 130 i=1,nl2 130 al2(i)=a(ialg+5+i) if (nl2.lt.maxleg) then do 135 i=nl2+1,maxleg 135 al2(i)=0. endif nnr=1 nne=2 enext=e2 return c c ***retrieve legendre coefficient 200 call findex('alg',ialg,a) do 205 i=1,maxleg 205 al(i)=0. if (e.ge.e2) then if (nne.eq.ne.and.e.le.e2*1.00001) go to 300 if (nne.ge.ne) go to 400 do 210 i=1,nl2 210 al1(i)=al2(i) if (nl2.lt.maxleg) then do 215 i=nl2+1,maxleg 215 al1(i)=0. endif nl1=nl2 e1=e2 call listio(nsig,0,0,a(ialg),nb,nw) e2=c2h nl2=n1h do 220 i=1,nl2 220 al2(i)=a(ialg+5+i) if (nl2.lt.maxleg) then do 225 i=nl2+1,maxleg 225 al2(i)=0. endif nne=nne+1 endif c 300 n=max(nl1,nl2) if (nne.gt.nbt(nnr)) then nnr=nnr+1 int=jnt(nnr) endif do 310 i=1,n 310 call terp1(e1,al1(i),e2,al2(i),e,al(i),int) c 400 continue enext=e2 return end c subroutine musigc(ncg,csig,cflx,b,egt,flux,sig,alp) c ****************************************************************** c calculate the coarse group mubar. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/eunits/nendf,nin,nout,ninc,ngout,nstan,nunit(2),nscr common/eunits34/nscr4 common/mainio/nsysi,nsyso,nsyse,ntty common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) common/tramat/u1lele(10),plele(901,10) dimension csig(ncg,*),cflx(*),b(*),egt(*),flux(*),sig(*),alp(*) dimension c(6) data hmt/2hmt/, uline/5h-----/ c c ***put the coarse group structure on nout, ala groupr if (nout.eq.0) go to 140 mat=matd mf=1 mt=451 b(1)=za b(2)=awr b(3)=0 b(4)=0 b(5)=-11 b(6)=0 call contio(0,nout,0,b,nb,nw) b(1)=0.d0 b(2)=0.d0 b(3)=ngn nw=6 ngnp1=ngn+1 do 110 i=1,ngnp1 nw=nw+1 110 b(nw)=egn(i) np=nw-6 b(5)=np loc=1 call listio(0,nout,0,b(loc),nb,nw) 120 if (nb.eq.0) go to 130 loc=loc+nw call moreio(0,nout,0,b(loc),nb,nw) go to 120 130 continue call asend(nout,0) call afend(nout,0) 140 continue c c ***initialize mfd=3 c ***call sigfig to cure the bit-dropping problem. nun1=nunion+1 do 150 i=1,nun1 150 egt(i)=sigfig(egt(i),ndig,0) ngn1=ngn+1 do 160 i=1,ngn1 160 egn(i)=sigfig(egn(i),ndig,0) c ***calculate coarse group flux do 180 ig=1,ngn cflx(ig)=0.d0 do 170 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 170 cflx(ig)=cflx(ig)+flux(jg) 170 continue 180 continue c c ***mt=251, mubar: average cosine of the scattering angle c ***(laboratory system) for elastic scattering. c ***compute cross-group cross sections and write on output tape. mat=matd mf=3 mt=2 call rdsig(mat,mt,b,sig) ld=1 call rdlgnd(nscr4,mat,mt,ld,b,alp) ix=1 do 280 ig=1,ngn csig(ig,ix)=0. abit=0. do 270 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 270 sss0=0.0 do 271 ij = 2 , 9 sss0=sss0+plele(jg,ij)*u1lele(ij+1) 271 continue csig(ig,ix)=csig(ig,ix)+sig(jg)*flux(jg)* & (alp(jg)+u1lele(1)+sss0) abit=abit+sig(jg)*flux(jg) 270 continue csig(ig,ix)= csig(ig,ix)/abit 280 continue mf=3 mt=251 if (nout.eq.0) go to 320 b(1)=0.d0 b(2)=0.d0 b(3)=0 b(4)=0 b(5)=ngn b(6)=0 ibase=6 ip=0 do 310 ig=1,ngn ip=ip+1 b(ibase+ip)=csig(ig,ix) if (ip.lt.npage.and.ig.lt.ngn) go to 310 if (ibase.eq.0) go to 300 call listio(0,nout,0,b,nb,nwds) ibase=0 ip=0 go to 310 300 call moreio(0,nout,0,b,nb,ip) ip=0 310 continue call asend(nout,0) 320 continue 210 continue c c ***print cross sections in columns. mt=251 write(nsyso,10) hmt,mt write(nsyso,15) (uline,i=1,2) do 450 ig=1,ngn c(1)=csig(ig,1) write(nsyso,20) ig,egn(ig),cflx(ig),c(1) 450 continue if (nout.ne.0) call afend(nout,0) return c 10 format(/,' table of multigroup data',//, & ' group lower group cosine',/, & ' no. energy flux ',4x,4(a2,i3,7x)) 15 format( ' ----- ------ ----- ',4x,4(2a5,2x)) 20 format(i5,1p,6e12.4) end c c ***Transformation Matrix c subroutine matrixin(awr,res) c c ***This routine was given by T.Nakagawa of JAEA. c implicit real*8 (a-h,o-z) dimension bc(800),res(10) c nlmax=20 c c ***the transformation matrix c call matrixej(awr,nlmax,bc,res) c return end c FUNCTION CLEB(I1,I2,I3) c*********************************************************************** c* CLEB = CLEBSCH-GORDAN COEFFICIENT * c* THIS FUNCTION WAS TAKEN FROM THE PROGRAM MATRIX. * c*********************************************************************** implicit real*8 (a-h,o-z) DIMENSION FAC(101),NFAC(101) DATA FAC /1.0d0,1.0d0,2.0d0,6.0d0,2.4d0,1.2d0, & 7.2d0,5.04d0,4.032d0,3.6288d0,3.6288d0,3.99168d0,4.790016d0, & 6.2270208d0,8.7178291d0,1.3076744d0,2.0922790d0,3.5568743d0, & 6.4023737d0,1.2164510d0,2.4329020d0,5.1090942d0,1.1240007d0, & 2.5852017d0,6.2044840d0,1.5511210d0,4.0329146d0,1.0888869d0, & 3.0488834d0,8.8417620d0,2.6525286d0,8.2228387d0,2.6313084d0, & 8.6833176d0,2.9523280d0,1.0333148d0,3.7199333d0,1.3763753d0, & 5.2302262d0,2.0397882d0,8.1591528d0,3.3452527d0,1.4050061d0, & 6.0415263d0,2.6582716d0,1.1962222d0,5.5026222d0,2.5862324d0, & 1.2413916d0,6.0828186d0,3.0414093d0,1.5511188d0,8.0658175d0, & 4.2748833d0,2.3084370d0,1.2696403d0,7.1099859d0,4.0526920d0, & 2.3505613d0,1.3868312d0,8.3209871d0,5.0758021d0,3.1469973d0, & 1.9826083d0,1.2688693d0,8.2476506d0,5.4434494d0,3.6471111d0, & 2.4800355d0,1.7112245d0,1.1978572d0,8.5047859d0,6.1234458d0, & 4.4701155d0,3.3078854d0,2.4809141d0,1.8854947d0,1.4518309d0, & 1.1324281d0,8.9461821d0,7.1569457d0,5.7971260d0,4.7536433d0, & 3.9455240d0,3.3142401d0,2.8171041d0,2.4227095d0,2.1077573d0, & 1.8548264d0,1.6507955d0,1.4857160d0,1.3520015d0,1.2438414d0, & 1.1567725d0,1.0873662d0,1.0329978d0,9.9167793d0,9.6192760d0, & 9.4268904d0,9.3326215d0,9.3326215d0/ DATA NFAC /4*0,1,2,2,3,4,5,6,7,8,9,10,12,13,14, &15,17,18,19,21,22,23,25,26,28,29,30,32,33,35,36,38,40,41,43,44,46, &47,49,51,52,54,56,57,59,61,62,64,66,67,69,71,73,74,76,78,80,81,83, &85,87,89,90,92,94,96,98,100,101,103,105,107,109,111,113,115,116, &118,120,122,124,126,128,130,132,134,136,138,140,142,144,146,148, &149,151,153,155,157/ c CLEB=0.0 N1=I1+I2-I3+1 IF(N1.LE.0) GO TO 99 N2=I1-I2+I3+1 IF(N2.LE.0) GO TO 99 N3=-I1+I2+I3+1 IF(N3.LE.0) GO TO 99 IT=I1+I2+I3 IF(MOD(IT,2).NE.0) GO TO 99 N4=IT+2 NEPT=NFAC(N1)+NFAC(N2)+NFAC(N3)-NFAC(N4) IF(NEPT.LT.33) GO TO 50 WRITE(6,1000) NEPT 1000 FORMAT(35H0NEPT IS GREATER THAN 32 AND EQUALS,I5) GO TO 99 50 ARG=FAC(N1)*FAC(N2)*FAC(N3)/FAC(N4) Z1=ARG*10.0**NEPT D123=SQRT(Z1) IS=IT/2 SIGNX=1 IF(MOD(IS+I3,2).EQ.1) SIGNX=-1 IA=IS+1 IB=IS-I1+1 IC=IS-I2+1 ID=IS-I3+1 NEPT=NFAC(IA)-NFAC(IB)-NFAC(IC)-NFAC(ID) ARG=FAC(IA)/(FAC(IB)*FAC(IC)*FAC(ID)) Z1=2*I3+1 CLEB=SIGNX*SQRT(Z1)*D123*ARG*10.0**NEPT 99 RETURN END c SUBROUTINE MATRIXEJ(AWR,NM,BC,res) c*********************************************************************** c* CALCULATES A TRANSFORMATION MATRIX. THIS SUBROUTINE WAS TAKEN * c* FROM THE PROGRAM MATRIX. * c*********************************************************************** implicit real*8 (a-h,o-z) DIMENSION BC(*) DIMENSION T(65,65),res(10) c M=NM+1 A=AWR G=1.0/A 16 MM=MIN0(2*M,30) DO 20 I=1,MM DO 20 L=1,M T(L,I)=0.0 20 CONTINUE T(1,1)=1.0 100 T(2,1)=2.0*G/3.0 T(2,2)=1.0-.6*G**2 MUP=0 DO 110 I=3,MM I1=I-1 Z1=I1 Z2=I1+2 Z3=2*I1-1 Z4=2*I1+3 I2=I1-1 X1=(Z1/Z3-Z2*G**2/Z4)*(-G)**I2 T(2,I)=X1 IF(MUP.NE.0) GO TO 105 IF(ABS(X1).GE.1.0E-16) GO TO 110 MUP=I1 105 IF(ABS(X1).LT.1.0E-32) GO TO 120 110 CONTINUE IF(MUP.EQ.0) MUP=M 120 ILO=1 DO 160 L=3,M L1=L-2 Z1=2*L1+1 Z2=L1+1 Z3=L1 ILOW=ILO DO 150 I=ILOW,MM I1=I-1 SUM=-Z3*T(L1,I)/Z2 DO 140 N1=1,MUP X2=T(2,N1) IF(ABS(X2).EQ.0.0) GO TO 140 N2=N1-1 MAX=N2+I1+1 IF(MAX.GT.MM) MAX=MM MIN=IABS(N2-I1)+1 SUM1=0.0 DO 130 M1=MIN,MAX,2 X1=T(L1+1,M1) IF(ABS(X1).LT.1.0E-16) GO TO 130 M2=M1-1 SUM1=SUM1+CLEB(N2,M2,I1)**2*X1 130 CONTINUE SUM=SUM+Z1*X2*SUM1/Z2 140 CONTINUE 145 IF(I.GE.L) GO TO 147 IF(ABS(SUM).GE.ABS(T(L-1,I))) GO TO 148 147 T(L,I)=SUM GO TO 150 148 ILO=I+1 150 CONTINUE 160 CONTINUE 200 CONTINUE DO 300 I=1,M DO 300 L=1,M II=I-1 LL=L+M*II BC(LL)=T(L,I) IF(ABS(BC(LL)).LT.1.0E-20) BC(LL)=0.0 300 CONTINUE cej do 310 i=1,10 res(i)=t(2,i) 310 continue c return end c subroutine rdlgnd(nscr4,matd,mtd,npl,b,alp) c ****************************************************************** c read legendre coefficients from nscr4 tape produced subroutine c grpav4. c ****************************************************************** implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension b(*),alp(*) c c ***set up header record call repoz(nscr4) call findf(matd,4,mtd,nscr4) call contio(nscr4,0,0,b,nb,nwds) nl=l2h ngt=n2h do 110 i=1,ngt 110 alp(i)=0. if (npl.gt.nl) go to 200 il=npl+7 c c ***retrieve desired legendre coefficient 120 call listio(nscr4,0,0,b,nb,nwds) nw=n1h jg=n2h alp(jg)=b(il) if (jg.lt.ngt) go to 120 200 continue return end c subroutine fssigc(ncg,csig,cflx,b,egt,flux,sig) c ****************************************************************** c calculate the coarse group fission spectrum chi. c ****************************************************************** implicit real*8 (a-h,o-z) common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/grpn/ign,ngn,egn(901),iprint common/eunits/nendf,nin,nout,ninc,ngout,nstan,nunit(2),nscr common/mainio/nsysi,nsyso,nsyse,ntty common/err1/nmtmax,nkmax,nenimx,ndig,neni,nunion,nga,matd,irelco, & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(60),mts(60) common/err2/za,awr,ek(50) dimension csig(ncg,*),cflx(*),b(*),egt(*),flux(*),sig(*) dimension c(6) data hmt/2hmt/, uline/5h-----/ c c ***put the coarse group structure on nout, ala groupr if (nout.eq.0) go to 140 mat=matd mf=1 mt=451 b(1)=za b(2)=awr b(3)=0 b(4)=0 b(5)=-12 b(6)=0 call contio(0,nout,0,b,nb,nw) b(1)=0.d0 b(2)=0.d0 b(3)=ngn nw=6 ngnp1=ngn+1 do 110 i=1,ngnp1 nw=nw+1 110 b(nw)=egn(i) np=nw-6 b(5)=np loc=1 call listio(0,nout,0,b(loc),nb,nw) 120 if (nb.eq.0) go to 130 loc=loc+nw call moreio(0,nout,0,b(loc),nb,nw) go to 120 130 continue call asend(nout,0) call afend(nout,0) 140 continue c c ***initialize c ***call sigfig to cure the bit-dropping problem. nun1=nunion+1 do 150 i=1,nun1 150 egt(i)=sigfig(egt(i),ndig,0) ngn1=ngn+1 do 160 i=1,ngn1 160 egn(i)=sigfig(egn(i),ndig,0) c ***calculate coarse group flux do 180 ig=1,ngn cflx(ig)=0.d0 do 170 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 170 cflx(ig)=cflx(ig)+flux(jg) 170 continue 180 continue c c ***mt=18, chi: fission spectrum (mf=5/mt=18) c ***compute cross-group cross sections and write on output tape. mat=matd mf=5 mt=18 call rdchi(mat,b,sig) ix=1 do 280 ig=1,ngn csig(ig,ix)=0.d0 do 270 jg=1,nunion if (egt(jg).lt.egn(ig).or.egt(jg).ge.egn(ig+1)) go to 270 csig(ig,ix)=csig(ig,ix)+sig(jg)*flux(jg) 270 continue 280 csig(ig,ix)=csig(ig,ix)/cflx(ig) if (nout.eq.0) go to 320 b(1)=0.d0 b(2)=0.d0 b(3)=0 b(4)=0 b(5)=ngn b(6)=0 ibase=6 ip=0 do 310 ig=1,ngn ip=ip+1 b(ibase+ip)=csig(ig,ix) if (ip.lt.npage.and.ig.lt.ngn) go to 310 if (ibase.eq.0) go to 300 call listio(0,nout,0,b,nb,nwds) ibase=0 ip=0 go to 310 300 call moreio(0,nout,0,b,nb,ip) ip=0 310 continue call asend(nout,0) 320 continue 210 continue c c ***print data in columns. mt=18 write(nsyso,10) hmt,mt write(nsyso,15) (uline,i=1,2) do 450 ig=1,ngn c(1)=csig(ig,1) write(nsyso,20) ig,egn(ig),cflx(ig),c(1) 450 continue if (nout.ne.0) call afend(nout,0) return c 10 format(/,' table of multigroup data',//, & ' group lower group chi ',/, & ' no. energy flux ',4x,4(a2,i3,7x)) 15 format( ' ----- ------ ----- ',4x,4(2a5,2x)) 20 format(i5,1p,6e12.4) end c subroutine rdchi(matd,b,chi) c ****************************************************************** c read the fission energy spectrum (chi). c ****************************************************************** implicit real*8 (a-h,o-z) common/eunits/nendf,npend,nout,nin,ngout,nstan,nscr(3) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension b(*),chi(*) c c ***set up header record call repoz(ngout) call findf(matd,5,18,ngout) call contio(ngout,0,0,b,nb,nwds) nl=l2h ngt=n2h do i=1,ngt chi(i)=0.d0 enddo c c ***retrieve desired chi 120 call listio(ngout,0,0,b,nb,nwds) nw=n1h jg=n2h chi(jg)=b(8) if (jg.lt.ngt) go to 120 c return end c subroutine ggrmat(e,sigp,a,npnls,valspi) c ****************************************************************** c calculates r-matrix(reich-moore) cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This subroutine is based on 'csrmat' routine in reconr. c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/pic/pi common/cwav/cwaven common/amnc/amassn dimension sigp(4),a(*) dimension r(3,3),s(3,3),ri(3,3),si(3,3) external error,facts,facphi,frobns data rc1,rc2,third/.123d0,.08d0,.333333333d0/ data quar,haf,uno,two,four/0.25d0,0.50d0,1.0d0,2.0d0,4.0d0/ c zero=0 c c ***compute cross sections at this energy do i=1,4 sigp(i)=0.d0 enddo c ***retrieve starting location for data in a cej inow=1 c ***retrieve nuclide information naps=nint(a(inow+5)) awri=a(inow+12) ap=a(inow+7) aw=amassn*awri ra=rc1*aw**third+rc2 if (naps.eq.1) ra=ap spi=a(inow+6) gjd=2*(2*spi+1) nls=nint(a(inow+10)) c ***calculate wave number(k),rho and rhocap at energy (e) arat=awri/(awri+1) k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap gfa=0 gfb=0 gf=0 inow=inow+12 c c ***loop over l states c ***with Go Chiba 10/3/2007 mods nlsmax=nls if (npnls.lt.nlsmax) nlsmax=npnls do l=1,nlsmax inowb=inow nrs=nint(a(inow+5)) ncyc=nint(a(inow+4))/nrs ll=nint(a(inow+2)) apl=a(inow+1) rhoc=k*ap rho=k*ra if (apl.ne.zero) rhoc=k*apl if (apl.ne.zero.and.naps.eq.1) rho=k*apl c ***calculate shift and penetration factors at cross section energy call facts(ll,rho,se,dum1) pe=dum1 call facphi(ll,rhoc,phi) c ***constants independent of res. energy phid=phi p1=cos(2*phid) p2=sin(2*phid) c ***loop over possible j values fl=ll ajmin=abs(abs(spi-fl)-haf) ajmax=spi+fl+haf numj=nint(ajmax-ajmin+1) ajc=ajmin-1 if (ll.ne.0.and.(fl.gt.spi-haf.and.fl.le.spi)) then jjl=0 else jjl=1 endif c do jj=1,numj inow=inowb ajc=ajc+1 cej, with 10/3/2007 mod if (abs(ajc-valspi).gt.0.01.or.l.ne.npnls) then in=(inow+6)+nrs*6+nrs*3 go to 180 endif gj=(2*ajc+1)/gjd c ***initialize matrix do j=1,3 do i=1,3 s(j,i)=0 r(j,i)=0 enddo enddo c c ***loop over resonances inow=inow+6 in=inow+nrs*6 do i=1,nrs aj=abs(a(inow+1)) c ***select only resonances with current j value if (abs(aj-ajc).le.quar) then c ***retrieve parameters er=a(inow) gn=a(inow+2) gg=a(inow+3) gfa=a(inow+4) gfb=a(inow+5) per=a(in+1) a1=sqrt(gn*pe/per) a2=0 if (gfa.ne.zero) a2=sqrt(abs(gfa)) if (gfa.lt.zero) a2=-a2 a3=0 if (gfb.ne.zero) a3=sqrt(abs(gfb)) if (gfb.lt.zero) a3=-a3 c ***compute energy factors diff=er-e den=diff*diff+quar*gg*gg de2=haf*diff/den gg4=quar*gg/den c ***calculate r-function, or c ***calculate upper triangular matrix terms r(1,1)=r(1,1)+gg4*a1*a1 s(1,1)=s(1,1)-de2*a1*a1 if (gfa.ne.zero.or.gfb.ne.zero) then r(1,2)=r(1,2)+gg4*a1*a2 s(1,2)=s(1,2)-de2*a1*a2 r(1,3)=r(1,3)+gg4*a1*a3 s(1,3)=s(1,3)-de2*a1*a3 r(2,2)=r(2,2)+gg4*a2*a2 s(2,2)=s(2,2)-de2*a2*a2 r(3,3)=r(3,3)+gg4*a3*a3 s(3,3)=s(3,3)-de2*a3*a3 r(2,3)=r(2,3)+gg4*a2*a3 s(2,3)=s(2,3)-de2*a2*a3 gf=1 endif endif inow=inow+ncyc in=in+3 enddo c ***r-matrix path -- make symmetric matrix if (gf.ne.zero) then r(1,1)=uno+r(1,1) r(2,2)=uno+r(2,2) r(3,3)=uno+r(3,3) r(2,1)=r(1,2) s(2,1)=s(1,2) r(3,1)=r(1,3) s(3,1)=s(1,3) r(3,2)=r(2,3) s(3,2)=s(2,3) c ***invert the complex matrix call frobns(r,s,ri,si) c ***fission term for r-matrix path t1=ri(1,2) t2=si(1,2) t3=ri(1,3) t4=si(1,3) termf=four*gj*(t1*t1+t2*t2+t3*t3+t4*t4) u11r=p1*(two*ri(1,1)-uno)+two*p2*si(1,1) u11i=p2*(uno-two*ri(1,1))+two*p1*si(1,1) termt=two*gj*(uno-u11r) termn=gj*((uno-u11r)**2+u11i**2) c c ***r-function path else dd=r(1,1) rr=uno+dd ss=s(1,1) amag=rr**2+ss**2 rri=rr/amag ssi=-ss/amag uur=p1*(two*rri-uno)+two*p2*ssi uui=p2*(uno-two*rri)+two*p1*ssi if (abs(dd).lt.small.and. & abs(phid).lt.small) then xx=2*dd xx=xx+2*(dd*dd+ss*ss+phid*phid+p2*ss) xx=xx-2*phid*phid*(dd*dd+ss*ss) xx=xx/amag termt=two*gj*xx termn=gj*(xx**2+uui**2) else termt=two*gj*(uno-uur) termn=gj*((uno-uur)**2+uui**2) endif termf=0 endif c ***cross sections contributions if (jj.gt.jjl.and.jj.lt.numj) then termn=termn+two*gj*(1-p1) termt=termt+two*gj*(1-p1) endif termg=termt-termf-termn sigp(2)=sigp(2)+termn sigp(4)=sigp(4)+termg sigp(3)=sigp(3)+termf sigp(1)=sigp(1)+termt c 180 continue enddo inow=in 200 continue c ***continue the loop over l values enddo c c ***calculate final cross sections and store for return sigp(1)=pifac*sigp(1) sigp(2)=pifac*sigp(2) sigp(3)=pifac*sigp(3) sigp(4)=pifac*sigp(4) return end c c subroutine ggrmatorg(e,sigp,a,npnls,valspi) c ****************************************************************** c calculates r-matrix(reich-moore) cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This subroutine is based on 'csrmat' routine in reconr. c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/pic/pi common/cwav/cwaven common/amnc/amassn dimension sigp(4),a(*) dimension r(3,3),s(3,3),ri(3,3),si(3,3) external error,facts,facphi,frobns data rc1,rc2,third/.123d0,.08d0,.333333333d0/ data quar,haf,uno,two,four/0.25d0,0.50d0,1.0d0,2.0d0,4.0d0/ c zero=0 c c ***compute cross sections at this energy do i=1,4 sigp(i)=0.d0 enddo c ***retrieve starting location for data in a cej inow=1 c ***retrieve nuclide information naps=nint(a(inow+5)) awri=a(inow+12) ap=a(inow+7) aw=amassn*awri ra=rc1*aw**third+rc2 if (naps.eq.1) ra=ap spi=a(inow+6) gjd=2*(2*spi+1) nls=nint(a(inow+10)) c ***calculate wave number(k),rho and rhocap at energy (e) arat=awri/(awri+1) k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap gfa=0 gfb=0 gf=0 inow=inow+12 c c ***loop over l states do l=1,nls if (l.ne.npnls) goto 200 inowb=inow nrs=nint(a(inow+5)) ncyc=nint(a(inow+4))/nrs ll=nint(a(inow+2)) apl=a(inow+1) rhoc=k*ap rho=k*ra if (apl.ne.zero) then rhoc=k*apl if (naps.eq.1) rho=k*apl endif c ***calculate shift and penetration factors at cross section energy call facts(ll,rho,se,dum1) pe=dum1 call facphi(ll,rhoc,phi) c ***constants independent of res. energy phid=phi p1=cos(2*phid) p2=sin(2*phid) c c ***loop over possible j values fl=ll ajmin=abs(abs(spi-fl)-haf) ajmax=spi+fl+haf numj=nint(ajmax-ajmin+1) ajc=ajmin-1 if (ll.ne.0.and.(fl.gt.spi-haf.and.fl.le.spi)) then jjl=0 else jjl=1 endif c do jj=1,numj inow=inowb ajc=ajc+1 cej if (abs(ajc-valspi).gt.0.01) go to 180 gj=(2*ajc+1)/gjd c ***initialize matrix do j=1,3 do i=1,3 s(j,i)=0. r(j,i)=0. enddo enddo c c ***loop over resonances inow=inow+6 in=inow+nrs*6 do i=1,nrs aj=abs(a(inow+1)) c ***select only resonances with current j value if (abs(aj-ajc).le.quar) then c ***retrieve parameters er=a(inow) gn=a(inow+2) gg=a(inow+3) gfa=a(inow+4) gfb=a(inow+5) per=a(in+1) a12=gn*pe/per a1=sqrt(a12) if (gfa.ne.zero) then a22=abs(gfa) a2=sqrt(a22) else a22=0 a2=0 endif if (gfa.lt.zero) a2=-a2 if (gfb.ne.zero) then a32=abs(gfb) a3=sqrt(a32) else a32=0 a3=0 endif if (gfb.lt.zero) a3=-a3 c ***compute energy factors diff=er-e den=diff*diff+quar*gg*gg de2=haf*diff/den gg4=quar*gg/den c ***calculate r-function, or c ***calculate upper triangular matrix terms r(1,1)=r(1,1)+gg4*a12 s(1,1)=s(1,1)-de2*a12 if (gfa.ne.zero.or.gfb.ne.zero) then a1a2=a1*a2 a1a3=a1*a3 a2a3=a2*a3 r(1,2)=r(1,2)+gg4*a1a2 s(1,2)=s(1,2)-de2*a1a2 r(1,3)=r(1,3)+gg4*a1a3 s(1,3)=s(1,3)-de2*a1a3 r(2,2)=r(2,2)+gg4*a22 s(2,2)=s(2,2)-de2*a22 r(3,3)=r(3,3)+gg4*a33 s(3,3)=s(3,3)-de2*a33 r(2,3)=r(2,3)+gg4*a2a3 s(2,3)=s(2,3)-de2*a2a3 gf=1 endif endif inow=inow+ncyc in=in+3 enddo c ***r-matrix path -- make symmetric matrix if (gf.ne.zero) then r(1,1)=uno+r(1,1) r(2,2)=uno+r(2,2) r(3,3)=uno+r(3,3) r(2,1)=r(1,2) s(2,1)=s(1,2) r(3,1)=r(1,3) s(3,1)=s(1,3) r(3,2)=r(2,3) s(3,2)=s(2,3) c ***invert the complex matrix call frobns(r,s,ri,si) c ***fission term for r-matrix path t1=ri(1,2) t2=si(1,2) t3=ri(1,3) t4=si(1,3) termf=four*gj*(t1*t1+t2*t2+t3*t3+t4*t4) u11r=p1*(two*ri(1,1)-uno)+two*p2*si(1,1) u11i=p2*(uno-two*ri(1,1))+two*p1*si(1,1) termt=two*gj*(uno-u11r) termn=gj*((uno-u11r)**2+u11i**2) c ***r-function path else dd=r(1,1) rr=uno+dd ss=s(1,1) amag=rr**2+ss**2 rri=rr/amag ssi=-ss/amag uur=p1*(two*rri-uno)+two*p2*ssi uui=p2*(uno-two*rri)+two*p1*ssi if (abs(dd).lt.small.and. & abs(phid).lt.small) then xx=2*dd dd2ss2=dd*dd+ss*ss phi2=phid*phid xx=xx+2*(dd2ss2+phi2+p2*ss) xx=xx-2*phi2*dd2ss2 xx=xx/amag termt=two*gj*xx termn=gj*(xx**2+uui**2) else termt=two*gj*(uno-uur) termn=gj*((uno-uur)**2+uui**2) endif termf=0 endif c ***cross sections contributions if (jj.gt.jjl.and.jj.lt.numj) then tmp=two*gj*(1-p1) termn=termn+tmp termt=termt+tmp endif sigp(2)=sigp(2)+termn sigp(4)=sigp(4)+termt-termf-termn sigp(3)=sigp(3)+termf sigp(1)=sigp(1)+termt c 180 continue enddo inow=in 200 continue c ***continue the loop over l values enddo c c ***calculate final cross sections and store for return sigp(1)=pifac*sigp(1) sigp(2)=pifac*sigp(2) sigp(3)=pifac*sigp(3) sigp(4)=pifac*sigp(4) return end c subroutine ggmlbw(e,sigp,a) c ****************************************************************** c calculates multilevel breit-wigner cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This routine is based on 'csmlbw' routine in reconr c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/pic/pi common/cwav/cwaven common/amnc/amassn dimension sigp(4),sigj(10,2),gj(10),a(*) external facts,facphi c data rc1,rc2,third/.123d0,.08d0,.333333333d0/ data half/.5d0/ zero=0 c c ***compute cross sections for this energy do i=1,4 sigp(i)=0.d0 enddo c ***retrieve starting location for data in a cej inow=1 c ***retrieve nuclide information naps=nint(a(inow+5)) awri=a(inow+12) ap=a(inow+7) aw=amassn*awri ra=rc1*aw**third+rc2 if (naps.eq.1) ra=ap spi=a(inow+6) den=4*spi+2 nls=nint(a(inow+10)) c ***calculate wave number(k),rho and rhocap at energy (e) arat=awri/(awri+1) k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap inow=inow+12 c c ***loop over l states do l=1,nls nrs=nint(a(inow+5)) ll=nint(a(inow+2)) qx=a(inow+1) lrx=nint(a(inow+3)) call facts(ll,rho,se,pe) pec=0 if (lrx.ne.0) then rhop=cwaven*arat*sqrt(abs(e+qx))*ra call facts(ll,rhop,sec,pec) endif call facphi(ll,rhoc,phi) cos2p=1-cos(2*phi) sin2p=sin(2*phi) sum=0 fl=ll ajmin=abs(abs(spi-fl)-half) ajmax=spi+fl+half nj=nint(ajmax-ajmin+1) aj=ajmin do i=1,nj gj(i)=(2*aj+1)/den aj=aj+1 sum=sum+gj(i) enddo diff=2*fl+1-sum do ii=1,2 do i=1,nj sigj(i,ii)=0 enddo enddo inow=inow+6 in=inow+nrs*6 c c ***loop over all resonances do i=1,nrs er=a(inow) j=a(inow+1)-ajmin+1.001 gn=a(inow+3) gg=a(inow+4) gf=a(inow+5) ser=a(in) per=a(in+1) rper=1/per gc=a(in+2) in=in+3 inow=inow+6 erp=er+gn*(ser-se)*rper/2 edelt=e-erp gne=gn*pe*rper gx=gg+gf gtt=gne+gx gtt=gtt+gc*pec x=2*edelt/gtt comfac=2*gne/gtt/(1+x*x) sigj(j,1)=sigj(j,1)+comfac sigj(j,2)=sigj(j,2)+comfac*x comfac=comfac*gj(j)/gtt sigp(3)=sigp(3)+comfac*gf sigp(4)=sigp(4)+comfac*gg enddo do j=1,nj add=gj(j)*((cos2p-sigj(j,1))**2+(sin2p+sigj(j,2))**2) sigp(2)=sigp(2)+add enddo sigp(2)=sigp(2)+2*diff*cos2p inow=in enddo c c ***construct the final cross sections sigp(2)=sigp(2)*pifac sigp(3)=sigp(3)*2*pifac sigp(4)=sigp(4)*2*pifac sigp(1)=sigp(2)+sigp(3)+sigp(4) c return end c subroutine ssmlbw(e,sigp,a,aa) c ****************************************************************** c calculates multilevel breit-wigner cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This routine is based on 'csmlbw' routine in reconr? c For one resonance? c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/reson1/ap,arat,ra,spifac,ll common/reson2/ajmin,gj(10),diff,nj common/pic/pi common/cwav/cwaven dimension sigp(4),sigj(10,2),a(6),aa(3) external facts,facphi c c ***initialize do 10 i=1,4 sigp(i)=0.d0 10 continue c c ***compute cross sections for this energy k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap c ***calculate shift and penetration factors at cross section energy call facts(ll,rho,se,pe) pec=0.d+0 call facphi(ll,rhoc,phi) cos2p=1-cos(2*phi) sin2p=sin(2*phi) do 21 ii=1,2 do 20 i=1,10 sigj(i,ii)=0.d0 20 continue 21 continue c er=a(1) j=a(2)-ajmin+1.001 gn=a(4) gg=a(5) gf=a(6) ser=aa(1) per=aa(2) rper=1/per gc=aa(3) erp=er+gn*(ser-se)*rper/2 edelt=e-erp c ***calculate the neutron width at e gne=gn*pe*rper gx=gg+gf gtt=gne+gx gtt=gtt+gc*pec x=2*edelt/gtt c ***cross section calculations= c ***common calculational factor comfac=2*gne/gtt/(1+x*x) c ***elastic components sigj(j,1)=sigj(j,1)+comfac sigj(j,2)=sigj(j,2)+comfac*x comfac=comfac*gj(j)/gtt c ***fission sigp(3)=sigp(3)+comfac*gf c ***capture sigp(4)=sigp(4)+comfac*gg c do 45 j=1,nj sigp(2)=sigp(2)+gj(j)* & ((cos2p-sigj(j,1))**2+(sin2p+sigj(j,2))**2) 45 continue sigp(2)=sigp(2)+2*diff*cos2p sigp(2)=sigp(2)*pifac sigp(3)=sigp(3)*2*pifac sigp(4)=sigp(4)*2*pifac c ***total sigp(1)=sigp(2)+sigp(3)+sigp(4) return end c subroutine ssslbw(e,sigp,a,aa) c ****************************************************************** c calculates single level breit-wigner cross sections at energy e c for one section (one isotope-one energy range) c ****************************************************************** c (ERRORJ) c This routine is based on 'csslbw' in reconr? c For one resonance? c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/reson1/ap,arat,ra,spifac,ll common/pic/pi common/cwav/cwaven dimension sigp(4),a(6),aa(3) external facphi,facts c c ***initialize do 10 i=1,4 sigp(i)=0.d0 10 continue c c ***compute cross sections for this energy k=cwaven*arat*sqrt(abs(e)) pifac=pi/(k*k) rho=k*ra rhoc=k*ap call facts(ll,rho,se,pe) pec=0.d+0 call facphi(ll,rhoc,phi) cos2p=cos(2*phi) sin2p=sin(2*phi) sinsq=(sin(phi))**2 spot=4*(2*ll+1)*pifac*sinsq c er=a(1) aj=a(2) gn=a(4) gg=a(5) gf=a(6) ser=aa(1) per=aa(2) rper=1/per gc=aa(3) gx=gg+gf c ***spin factor gj=(2*aj+1)*spifac/2 erp=er+gn*(ser-se)*rper/2 edelt=e-erp gne=gn*pe*rper gtt=gne+gx gtt=gtt+gc*pec c ***cross sections for temp=0. c ***elastic comfac=pifac*gj*gne/(edelt**2+gtt*gtt/4) sigp(2)=sigp(2)+ & comfac*(gne*cos2p-2*gx*sinsq+2*edelt*sin2p) c ***fission sigp(3)=sigp(3)+comfac*gf c ***capture sigp(4)=sigp(4)+comfac*gg c sigp(2)=sigp(2)+spot c ***total sigp(1)=sigp(2)+sigp(3)+sigp(4) c return end c subroutine ggunr1(e,sigp,a,amu,mxlru2) c ****************************************************************** c unresolved resonance region (format 1) c single level breit wigner formalism c energy independent parameters c parameter interpolation is always used. c ****************************************************************** c (ERRORJ) c This routine is for calculation of unresolved R.P. with MF=32 c ****************************************************************** implicit real*8 (a-h,o-z) real*8 k common/pic/pi common/cwav/cwaven common/amnc/amassn dimension a(*),sigp(4),amu(3,mxlru2) external unfac,gnrl data rc1,rc2,third/.123d0,.08d0,.333333333d0/ zero=0 c c ***compute unresolved cross sections do i=2,4 sigp(i)=0.d0 enddo spi=a(1) ap=a(2) nls=nint(a(5)) nlru2=0 inow=7 c c ***compute unresolved cross sections c ***do loop over all l states do 190 l=1,nls awri=a(inow) ll=nint(a(inow+2)) njs=nint(a(inow+5)) arat=awri/(awri+1) aw=awri*amassn ra=rc1*aw**third+rc2 const=(2*pi**2)/(cwaven*arat)**2 inow=inow+6 c c ***do loop over all j states do 180 j=1,njs dx=a(inow) aj=a(inow+1) gnox=a(inow+2) ggx=a(inow+3) gfx=a(inow+4) gxx=a(inow+5) nlru2=nlru2+1 amun=amu(1,nlru2) mu=nint(amu(1,nlru2)) nu=nint(amu(2,nlru2)) lamda=nint(amu(3,nlru2)) gj=(2*aj+1)/(4*spi+2) e2=sqrt(e) k=arat*e2*cwaven rho=k*ra rhoc=k*ap c ***calculate penetrability (vl) and phase shift(ps) call unfac(ll,rho,rhoc,amun,vl,ps) vl=vl*e2 c ***calculate potential scattering if (j.eq.1) spot=4*pi*(2*ll+1)*(sin(ps)/k)**2 c ***compute cross section contributions gnx=gnox*vl diff=gxx den=e*dx temp=const*gj*gnx/den terg=temp*ggx ters=temp*gnx terf=temp*gfx c ***calculate fluctuation integrals call gnrl(gnx,gfx,ggx,mu,nu,lamda,gs ,diff,1) call gnrl(gnx,gfx,ggx,mu,nu,lamda,gc ,diff,2) call gnrl(gnx,gfx,ggx,mu,nu,lamda,gff,diff,3) gc=gc*terg gff=gff*terf gs=gs*ters c ***add interference correction add=const*gj*2*gnx*sin(ps)**2 add=add/(e*dx) gs=gs-add c ***cross sections sigp(2)=sigp(2)+gs sigp(3)=sigp(3)+gff sigp(4)=sigp(4)+gc inow=inow+6 180 continue sigp(2)=sigp(2)+spot 190 continue sigp(1)=sigp(2)+sigp(3)+sigp(4) c return end c subroutine covadd(iadd,imt,imtmax,ntape,nout) dimension imt(imtmax) character*66 dat character*44 dat2 c call openz(ntape,0) call openz(nout,1) c do i=1,4 read(ntape,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii write(nout,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii enddo c read(ntape,'(a44,i11,i11,i4,i2,i3,i5)')dat2,i1,i2,mat,mf,mt,ii write(nout,'(a44,i11,i11,i4,i2,i3,i5)') & dat2,i1,i2+iadd,mat,mf,mt,ii c do i=1,i1+i2 read(ntape,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii write(nout,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii enddo c do i=1,iadd write(nout,'(22x,4i11,i4,i2,i3,i5)') & 33,imt(i),4,0,mat,mf,mt,ii+i enddo c 1000 continue read(ntape,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii write(nout,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii c if(mf.eq.32.and.mt.eq.0)then write(nout,'(66x,i4,i2,i3,i5)')mat,0,0,99999 do i=1,iadd write(nout,'(6i11,i4,i2,i3,i5)') & 0,0,0,0,0,1,mat,33,imt(i),1 write(nout,'(6i11,i4,i2,i3,i5)') & 0,0,0,imt(i),0,1,mat,33,imt(i),2 write(nout,'(6i11,i4,i2,i3,i5)') & 0,0,1,5,3,2,mat,33,imt(i),3 write(nout,'(a33,33x,i4,i2,i3,i5)') & ' 1.000000-5 2.000000+7 0.000000+0',mat,33,imt(i),4 write(nout,'(66x,i4,i2,i3,i5)')mat,33,0,99999 enddo endif c if(mat.eq.-1)return goto 1000 c end *ident up259 */ groupr -- 16Oct07 */ use prompt nu-bar for the neutron multiplicity when processing */ mf6 fission (Sinitsa). *i groupr.4616 if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then call getyld(e,en,idis,yld,matd,1,456,nend3,a) do ig=1,ng do il=1,nl ff(il,ig)=ff(il,ig)*yld enddo enddo if (en.lt.enext*(1-small)) then enext=en idisc=idis endif endif *ident up260 */ errorr (errorj) -- 29Oct07 */ include a missing dimension statement and modify a couple of */ arguments used in grpav4 when calling egtflx. This error was */ noticed long ago by Jean-Christophe Sublet. Its fixed here, */ better late than never. *d errorj.7433 dimension a(*),ans(10,2),z(26),flux(10,10) *d errorj.7498 call egtflx(e,enext,idis,flux,il,iz,a) */ most errorj routines are missing external statements. The Lahey */ compiler requires an external declaration to use njoy's error */ routine in place of the intrinsic fortran error subroutine. Also */ add an explicit character definition for hmt and uline; define */ "small" consistent with its definition in reconr; correct use of */ temperature (the variable temp(jtemp), used in four locations in */ egtwtf is a carryover from when this code was extracted from groupr; */ it needs to be replaced with "tempin" in this routine). The */ following closely follows "upfzk14.dat" from Cornelis Broeders. *i errorj.231 external error *i errorj.252 common/temper/tempin *i errorj.714 external error *i errorj.1346 external error *i errorj.2744 external error *i errorj.2990 external error *i errorj.3125 external error *i errorj.3478 external error *i errorj.3745 external error *i errorj.4080 external error *i errorj.4901 external error *i errorj.5372 external error *d errorj.5569 common/temper/tempin *d errorj.5653 if (iwtt.gt.6) tt=tempin*bk *d errorj.5676,5677 ea=bk*tempin eb=wt10a*tempin/wt10b *d errorj.5704 if (iwtt.gt.11) tt=tempin*bk *i errorj.5807 external error *i errorj.5966 external error *i errorj.6338 external error *i errorj.6722 external error *i errorj.6834 external error *i errorj.7066 external error *i errorj.7139 external error *i errorj.7376 external error *i errorj.7418 external error *i errorj.7595 external error *i errorj.7647 external error *i errorj.7769 external error character*2 hmt character*5 uline *i errorj.8108 character*2 hmt character*5 uline *i errorj.8275 small=3.d-4 */ Delete unused subroutine, ggrmatorg. Note, if this subroutine is */ restored in the future, references to "a32" should be changed to */ read "a33" (3 locations). Also the value for "small" should be */ set to 3.d-4 to be consistent with the corresponding defintion */ from the csrmat routine in reconr. *d errorj.8479,8713 *ident up261 */ groupr -- 30oct07 */ Replace the data statement for ebeg, introduced in ident up257 with */ an assignment statement to keep the Lahey compiler happy (Broeders). *d up257.10 *d up257.12 *b groupr.278 *if sw ebeg=1.d-5 *else ebeg=1.e-5 *endif *ident up262 */ reconr -- 19nov07 (revised 11Jan2008). */ insert mods to handle URR energy-dependent scattering radius data */ sets. This is the first of three updates; the other two, up263 and */ up264 define the necessary changes in unresr and purr. *d reconr.653 call rdf2u0(nin,a,jnow,jx,nro,ienode,ieunr) *d reconr.655 call rdf2u1(nin,a,jnow,jx,nro,ienode,ieunr) *d reconr.657 call rdf2u2(nin,a,jnow,jx,nro,ienode,ieunr) *d reconr.1031 subroutine rdf2u0(nin,a,jnow,jx,nro,ienode,ieunr) *i reconr.1068 if (nro.eq.1) then call tab1io(nin,0,0,a(jnow),nb,nw) a(jnow+1)=-float(nro) jj=jnow+nw do while (nb.ne.0) call moreio(nin,0,0,a(jj),nb,nw) jj=jj+nw if (jj.gt.jx) then call error('rdf2u0','storage in a exceeded',' ') endif enddo jnow=jj endif *d reconr.1114 subroutine rdf2u1(nin,a,jnow,jx,nro,ienode,ieunr) *i reconr.1153 if (nro.eq.1) then call tab1io(nin,0,0,a(jnow),nb,nw) a(jnow+1)=-float(nro) jj=jnow+nw do while (nb.ne.0) call moreio(nin,0,0,a(jj),nb,nw) jj=jj+nw if (jj.gt.jx) then call error('rdf2u1','storage in a exceeded',' ') endif enddo jnow=jj endif *d reconr.1226 subroutine rdf2u2(nin,a,jnow,jx,nro,ienode,ieunr) *i reconr.1265 if (nro.eq.1) then call tab1io(nin,0,0,a(jnow),nb,nw) a(jnow+1)=-float(nro) jj=jnow+nw do while (nb.ne.0) call moreio(nin,0,0,a(jj),nb,nw) jj=jj+nw if (jj.gt.jx) then call error('rdf2u2','storage in a exceeded',' ') endif enddo jnow=jj endif *i reconr.3372 c c *** check sign of a(inow+7). If < 0, it equals -nro and c a(inow+6) marks the beginning of an energy dependent tab1 c record for the scattering radius; if > 0 then a(inow+6) c is the cont record beginning with spin data. nro=0 if (a(inow+7).lt.0.) then nro=-nint(a(inow+7)) inow=inow+6+2*nint(a(inow+10))+2*nint(a(inow+11)) endif *d reconr.3408,3410 lfw=nint(a(inow+4)) naps=nint(a(inow+5)) if (a(inow+7).gt.0.) then ay=a(inow+7) else iro=inow+6 ip=2 ir=1 call terpa(ay,e,enx,idx,a(iro),ip,ir) inow=inow+6+2*nint(a(iro+4))+2*nint(a(iro+5)) endif spi=a(inow+6) aaa=a(inow+7) *d reconr.3598,3600 c c *** check sign of a(inow+7). If < 0, it equals -nro and c a(inow+6) marks the beginning of an energy dependent tab1 c record for the scattering radius; if > 0 then a(inow+6) c is the cont record beginning with spin data. nro=0 if (a(inow+7).lt.0.) then nro=-nint(a(inow+7)) inoww=inow+6+2*nint(a(inow+10))+2*nint(a(inow+11)) else inoww=inow endif int=nint(a(inoww+20)) ne=nint(a(inoww+23)) iloc=inoww+30 *d reconr.3634,3637 naps=nint(a(inow+5)) if (a(inow+7).gt.0.) then ay=a(inow+7) else iro=inow+6 ip=2 ir=1 call terpa(ay,e,enx,idx,a(iro),ip,ir) inow=inow+6+2*nint(a(iro+4))+2*nint(a(iro+5)) endif spi=a(inow+6) aaa=a(inow+7) nls=nint(a(inow+10)) awri=a(inow+12) */ also revise coding in csunr1 and csunr2 to check nro and naps for */ channel radius and scattering radius formula options. *d reconr.3346 external terp1,unfac,gnrl,error *d reconr.3427 if (naps.eq.0) then aa=rc1*aw**third+rc2 elseif (naps.eq.1) then aa=ay else if (naps.eq.2 .and. nro.eq.1) then aa=aaa else call error('csunr1','illegal naps',' ') endif *d reconr.3571 external terp1,unfac,gnrl,error *d reconr.3642 if (naps.eq.0) then aa=rc1*aw**third+rc2 else if (naps.eq.1) then aa=ay else if (naps.eq.2 .and. nro.eq.1) then aa=aaa else call error('csunr2','illegal naps',' ') endif *ident up263 */ unresr -- 19nov07 (revised 15Jan2008). */ insert mods to handle URR energy-dependent scattering radius data */ sets. This is the second of three updates; the other two, up262 and */ up264 define the necessary changes in reconr and purr. Also make */ sure that the channel and scattering radii are calculated per the */ evaluator naps,nro options. *i unresr.359 common/unen3/nro,naps *i unresr.432 nro=n1h naps=n2h *i unresr.484 c c *** if present, read and store the energy-dependent scattering c radius tab1 data. if (nro.eq.1) then call tab1io(nendf,0,0,a(inow),nb,nw) jj=inow+nw do while (nb.ne.0) call moreio(nendf,0,0,a(jj),nb,nw) jj=jj+nw if (jj.gt.jx) then call error('rdunf2','storage in a exceeded',' ') endif enddo inow=jj endif *i unresr.796 common/unen3/nro,naps *d unresr.890,891 if (nro.eq.1) then iro=inow ip=2 ir=1 call terpa(ay,e,enx,idx,a(iro),ip,ir) inow=inow+6+2*nint(a(iro+4))+2*nint(a(iro+5)) else ay=a(inow+1) endif awri=a(inow) aaa=0. if (naps.eq.2 .and. nro.eq.1) aaa=a(inow+1) *d unresr.911 if (naps.eq.0) then aa=rc1*aw**third+rc2 elseif (naps.eq.1) then aa=ay else if (naps.eq.2 .and. nro.eq.1) then aa=aaa else call error('unresl','illegal naps',' ') endif *ident up264 */ purr -- 19nov07 (revised 15Jan2008). */ insert mods to handle URR energy-dependent scattering radius data */ sets. This is the third of three updates; the other two, up262 and */ up263 define the necessary changes in reconr and unresr. Also make */ sure that the channel and scattering radii are calculated per the */ evaluator naps,nro options. *i purr.558 common/unres1/nro,naps *i purr.621 nro=n1h naps=n2h *i purr.673 c c *** if present, read and store the energy-dependent scattering c radius tab1 data. if (nro.eq.1) then call tab1io(nin,0,0,a(inow),nb,nw) jj=inow+nw do while (nb.ne.0) call moreio(nin,0,0,a(jj),nb,nw) jj=jj+nw if (jj.gt.jx) then call error('rdf2un','storage in a exceeded',' ') endif enddo inow=jj endif *i purr.1110 common/unres1/nro,naps *d purr.1151,1152 if (nro.eq.1) then iro=inow ip=2 ir=1 call terpa(ay,e,enx,idx,a(iro),ip,ir) inow=inow+6+2*nint(a(iro+4))+2*nint(a(iro+5)) else ay=a(inow+1) endif awri=a(inow) aaa=0. if (naps.eq.2 .and. nro.eq.1)aaa=a(inow+1) *d purr.1172 if (naps.eq.0) then aa=rc1*aw**third+rc2 elseif (naps.eq.1) then aa=ay else if (naps.eq.2 .and. nro.eq.1) then aa=aaa else call error('unresx','illegal naps',' ') endif *ident up265 */ groupr -- 28nov07 */ replace the abort condition introduced in ident up167 (negative */ URR cross sections from UNRESR) with a warning message and continue */ processing (NJOY User Group request). *d up167.20 external findex,terpu,terp1,mess *d up167.22,23 if (sl.lt.zero.or.sn.lt.zero) call mess('getunr', & ' Warning, negative URR cross sections found, check unresr', & ' ') *ident up266 */ thermr -- 3dec07 */ update comments and valid range test for mtref. Current limit is */ 221 to 250, and has been so for many years (Peters, UMC). *d thermr.73 c * mtref mt for inelastic reaction (221-250 only) * *d thermr.163 if (mtref.lt.221.or.mtref.gt.250) *ident up267 */ acer -- 10dec07 */ A write format for User material and temperature (iopt=1) was */ copied from a similar statement for thermal (iopt=2) data and */ contains extraneous text and format specifications. *d acer.308,312 & '' temperature .......................... '',1p,e10.3)') */ Make sure ymin.ne.ymax in standard acer log-log aplots (can happen */ for jendl-3.3 o16 "resonance absorption" plot, which then crashes in */ viewr). *i acer.22798 c ***make sure amin and amax differ. if (amin.eq.amax) then amin=0.1*amin amax=10.*amax endif *ident up268 */ moder -- 10dec07 */ change coding that defines it2 when processing mf7, mt4 so that it */ defaults to it2=0, or if processing a version 6 or later file is set */ to NS, the number of non-principal scattering atoms. Also revise */ coding to read up to NS sets of effective temperature data. *i moder.927 dimension ia1(3) *d moder.934,937 it2=0 ia1(1)=0 ia1(2)=0 ia1(3)=0 if (iverf.ge.6) then it2=n2h if (it2.gt.0.and.it2.le.3) then do i=1,it2 ii=6*i+7 ia1(i)=nint(a(ii)) enddo elseif (it2.gt.3) then call error('file7','NS>3',' ') endif endif *d moder.966,969 do i=1,it2 if (ia1(i).eq.0) then call tab1io(nin,nout,nscr,a,nb,nw) do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo endif enddo *ident up269 */ acer -- 10dec07 */ due to small variations in the normalization of the thermal */ scattering distribution, the last bin may have a slightly */ smaller width than expected. this can lead to an average */ energy that is smaller than expected and sometimes lead to a */ non-increasing energy at the end of the table, especially with */ a large number of energy bins. this patch will fix that. */ (mattes, ike) for endf/b-vii.0 aluminum at 20k. *i acer.13390 sum=sum+(yn+yl)*(xn-xl)/2 *d acer.13393 xbar=gral/sum */ fix indx calculation when printing more than 200 bragg edges */ (mattes). *i acer.13753 if (ifini.eq.0) indx=itce+1+200*ipg *ident up270 */ acer -- 8Jan2008 */ some photonuclear processing issues. */ make sure the reaction q value is defined when processing */ photonuclear mf6, law4 data. *i acer.15497 q=xss(lqr+ir-1) */ revise logic to define color code to avoid array bounds */ overflow. Current coding is ok for up to 16 curves but */ that's not enough for some photonuclear evaluations. *d acer.21995,21998 do while (icolor.ge.8) idash=idash+1 icolor=icolor-8 enddo */ make sure the "k" index variable is initialized. *i acer.22507 k=0 *ident up271 */ acer -- 19mar08 */ eliminate potential double counting of light particle production */ when redundant data can be inferred from mf3, mt102 through mt107 */ and also from light particle recoil in subsections of mf6. Only */ known issue so far is deuteron production from endfb7 photon */ capture on 1h (Little, LANL). *i acer.892 nprod3=nprod *i acer.988 lprod(j)=lprod(i) *i acer.994 c c ***If light recoil particle production (p,d,t,3He,a) was c found in file 6 it may be redundant with light particle c production that can be inferred from mf=3, mt=102 to c 107. Therefore, check for redundant mt values in c mprod(i) & mprod(i+1), redundant zap values in iprod(i) c & iprod(i+1), but different mf values in kprod(i) & c kprod(i+1). If found, delete the ith entry, move i+1 c and later entries down one array location and decrement c nprod. if (nprod.ne.nprod3 .and. nprod.gt.1) then nprodt=2 do while (nprodt.le.nprod) if (mprod(nprodt).eq.mprod(nprodt-1) .and. & iprod(nprodt).eq.iprod(nprodt-1) .and. & kprod(nprodt).ne.kprod(nprodt-1)) then nprod=nprod-1 if (nprodt.le.nprod) then nprodt=nprodt-1 do n=nprodt,nprod iprod(n)=iprod(n+1) mprod(n)=mprod(n+1) kprod(n)=kprod(n+1) lprod(n)=lprod(n+1) enddo endif endif nprodt=nprodt+1 enddo endif *ident up272 */ errorr (errorj) -- multiple changes, 21mar08 - 4dec08 */ implement a multitude of fixes that have accumulated in recent months: */ - allocate more space in the generic "a" array (Arcilla); */ - get maximum evaluation energy from file, or default to 20 MeV */ (but delete coding in colaps where the max few group energy */ was constrained to 20 MeV - just go with User input); */ - allocate more space for the union energy grid; */ - allocate more space for the user few group energy grid; */ - better memory management in covcal; */ - better memory management in gridd; */ - delete redundant sigfig call and add ngmax check in egngpn; */ - better scratch space management and output to gendf in grpav; */ - better scratch space management in colaps (a variation on */ changes proposed by Trkov in upnea023); */ - add moreio following listio when reading chi in colaps since */ number of multigroups can exceed npage; */ - make sure we check if moreio is needed after listio in covout; */ - expand number of mt's from 60 to 80 (was done for errorr in */ ident up158, but was missed during the errorj upgrade); */ - revision to subroutine resprx_grping to properly handle */ small energy groups (Chiba/Rochman). */ - minor bug fix in resprx_grping (call egtflx with x1=0.), per */ Go Chiba 7/23/2008 email. *d errorj.237 common/estore/a(20000000) *d errorj.239 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.241 common/grpn/ign,ngn,egn(2501),iprint *d errorj.269,270 nmtmax=80 nenimx=2500 *d errorj.272 namax=20000000 *d errorj.721 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.745,747 nwi=nunion+1 nw=nwi if ((npage+50).gt.nw) nw=npage+50 call reserv('b',nw,ib,a) *d errorj.753 if (mtd.gt.nwi) *d errorj.1312 & i4,'' groups'',13x,f8.1,''s'')') nmts,nunion,time *d errorj.1315 & i4,'' groups'',13x,f8.1,''s'')') nmts,nunion,time *d errorj.1353 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.1355 common/grpn/ign,ngn,egn(2501),iprint *d errorj.1702 if (nmd.lt.nmt1d) then do while (nb.ne.0) c ***ok to overwrite a(iscr), just reading rest of list call moreio(nscr,0,0,a(iscr),nb,nwds) enddo go to 220 endif *i errorj.1706 do while (nb.ne.0) c ***ok to overwrite a(iscr), just reading rest of list call moreio(nscr,0,0,a(iscr),nb,nwds) enddo *d errorj.2175 common/grpn/ign,ng,eg(2501),iprint *d errorj.2178 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.2363 data ngmax/2501/ *d errorj.2753 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.2377,2379 *d errorj.2644,2645 if ((nunion+1).gt.ngmax) & call error('egngpn', & 'union grid exceeds ngmax',' ') write(nsyso,'(/, & '' union structure (= user structure) has'',i5, *d errorj.2653 write(nsyso,'(/,'' union structure has'',i5,'' groups'',/)') *d errorj.2746 common/grpn/ign,ngn,egn(2501),iprint *d errorj.2772 c c *** maximum scratch space need is nunion+6+4 for gendf 1/451 nwds=nunion+10 *d errorj.2826 a(iscr+4)=nunion+4 *i errorj.2836,2838 c c *** add a zero for the ngg+1 entry, redefine nwds for listio a(np1+nw+iscr)=zero nwds=nunion+4 nl=1 *d errorj.3128 common/grpn/ign,ngn,egn(2501),iprint *d errorj.3131 common/estore/a(20000000) *d errorj.3133 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.3138 dimension c(6),matp(80) *d errorj.3374 common/grpn/ign,ngn,egn(2501),iprint *d errorj.3376 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.3481 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.3499 c c ***test that ngout is really a groupr output tape, then set c scratch space to larger of nunion or # of groupr few groups nwscr=17 call reserv('scr',nwscr,iscr,a) call tpidio(ngout,0,0,a(iscr),nb,nw) call contio(ngout,0,0,a(iscr),nb,nw) if (n1h.ne.-1) call error('colaps', & 'ngout is not a groupr output tape',' ') call contio(ngout,0,0,a(iscr),nb,nw) call repoz(ngout) call releas('scr',0,a) nwscr=max(17,n1h+6,nunion+10) *i errorj.3520 if (nw.gt.nwscr) call error('colaps','storage exceeded.',' ') *d errorj.3535,3545 *i errorj.3654 c c *** need additional scratch space for chi processing call reserv('sc18',ng1,iscr18,a) call reserv('scr0',8,iscr0,a) *d errorj.3657,3658 *d errorj.3675 iscrt=iscr do while (nb.ne.0) iscrt=iscrt+nw call moreio(ngout,0,0,a(iscrt),nb,nw) enddo *d errorj.3751 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.3757,3758 dimension el(50),eh(50),nmtr(80),imtr(80),jak(80) data nxmax/800/, irmax/80/ *i errorj.3761 data small5/1.d-5/ *d errorj.3771 *i errorj.3772 nall=-1 call reserv('scr',nall,iscr,a) *d errorj.3788 if (mf.eq.0.and.iread.eq.1) then call releas('scr',0,a) go to 610 endif *i errorj.3889 if ((l-iscr).gt.nall) call error('gridd', & 'nc subsection list too large',' ') *i errorj.3941 if ((l-iscr).gt.nall) call error('gridd', & 'ni subsection list too large',' ') *i errorj.3988 call releas('scr',0,a) if (neki.gt.0 .and. 1.001*small5.lt.ek(1)) then c c ***if necessary, increment neki so that a default coefficient c table is produced for the energy range 10**-5 eV to ek(1), c plus redefine the ek(neki) array to include this interval. neki=neki+1 do ijk=neki,2,-1 ek(ijk)=ek(ijk-1) enddo ek(1)=small5 endif *d errorj.4048 610 continue *d errorj.4088,4089 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) common/grpn/ign,ngn,egn(2501),iprint *d errorj.4573 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.4575 common/grpn/ign,ngn,egn(2501),iprint *d errorj.5010 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.5123 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.5214 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.5740 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.5811 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.5816 common/grpn/ign,ngn,egn(2501),iprint *d errorj.5973 common/grpn/ign,ngn,egn(2501),iprint *d errorj.5986,5987 dimension sig(maxe,5), gsig(4,2501,6), sig1(4) dimension sens(4,6,2501) *d errorj.6345 common/grpn/ign,ngn,egn(2501),iprint *d errorj.6357,6358 dimension sigr(maxe,5),sigp(maxe,5), gsig(4,2501) dimension sens(4,mxnpar,2501) *d errorj.6840 common/grpn/ign,ngn,egn(2501),iprint *d errorj.6849,6850 dimension gsigr(4,2501), gsigp(4,2501) dimension sens(4,mxnpar,2501) *d errorj.7261 dimension a(*),egn(*),sig(maxe,5),gsig(4,2501) *d errorj.7420 common/grpn/ign,ngn,egn(2501),iprint *d errorj.7427 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.7430 common/tramat/u1lele(10),plele(2501,10) *d errorj.7596 common/grpn/ign,ngn,egn(2501),iprint *d errorj.7598 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.7601 common/tramat/u1lele(10),plele(2501,10) *d errorj.7654 common/tramat/u1lele(10),plele(2501,10) *d errorj.7772 common/grpn/ign,ngn,egn(2501),iprint *d errorj.7777 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) *d errorj.7779 common/tramat/u1lele(10),plele(2501,10) *d errorj.8111 common/grpn/ign,ngn,egn(2501),iprint *d errorj.8115 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(80),mts(80) */ Go Chiba/D. Rochman resprx_grping fix: *d errorj.7319,7360 ebb=egnt1 ebx=ebb-x2 wt12=wt1-wt2 coef=ebx/x12 wt3=wt2+wt12*ebx/x12 de=ebx*(wt2+wt3)*0.5 sumde=sumde+de z2=(two*wt2+wt3)*ebx/six z3=(two*wt3+wt2)*ebx/six do j=2,4 y1=sig(i,j) y2=sig(i-1,j) y3=y2+(y1-y2)*coef if (y2.ne.zero .or. y3.ne.zero) then xx=y2*z2+y3*z3 gsig(j,ig)=gsig(j,ig)+xx endif enddo do j=2,4 gsig(j,ig)=gsig(j,ig)/sumde enddo 1000 continue ig=ig+1 if (x1.gt.egn(ig+1)) then xl=egn(ig) xr=egn(ig+1) ebx=xr-xl wtl=wt2+wt12*(xl-x2)/x12 wtr=wt2+wt12*(xr-x2)/x12 sumde=ebx*(wtl+wtr)*0.5 zl=(2.*wtl+wtr)*ebx/six zr=(2.*wtr+wtl)*ebx/six do j=2,4 yl=y2+(y1-y2)*(xl-x2)/(x1-x2) yr=y2+(y1-y2)*(xr-x2)/(x1-x2) if (yl.ne.zero .or. yr.ne.zero) then gsig(j,ig)=yl*zl+yr*zr/sumde endif enddo goto 1000 else ebx=x1-egn(ig) de=ebx*(wt3+wt1)*0.5 sumde=de z1=(two*wt3+wt1)*ebx/six z3=(two*wt1+wt3)*ebx/six do j=2,4 y1=sig(i,j) y2=sig(i-1,j) y3=y2+(y1-y2)*coef if (y3.ne.zero .or. y1.ne.zero) then xx=y1*z1+y3*z3 gsig(j,ig)=gsig(j,ig)+xx endif enddo endif */ per Go Chiba 7/23/2008 email: *i errorj.7285 x1=0. call egtwtf(x1,enext,idis,lord,wt1,a) *ident up273 */ cov -- multiple changes, 21mar08 - 8dec08 */ - increased array limits (again!) to allow processing of */ large multigroup matricies (upnea024, Trkov); */ - revise plotting logic for standard deviations to use a */ logarithmic scale if the non-zero min-to-max range is yrtest */ (currently set to 10x), or larger (Trkov request); */ - revise plotting logic when mt=mt1 to include the underlying */ few-group data rather than duplicating the uncertainty */ (Trkov request). */ - add alphanumeric label, (n,4n), for mt=37. */ - expand color shades from 5 to 6. Now have a shade for any */ abs(correlation matrix element)>tlev(1). */ - revise logic for determining xmin and ymin in plotit to assure */ xmin.ne.xmax or ymin.ne.ymax (shows up as an abort in the axis3 */ subroutine in viewr). */ - expand plotting to include MF34 (mt251) and MF35 files. */ (related mf35 change to get Einc in the plot title is not done */ yet - just use 0.0253 eV for now)! <-- but see ident up283 */ - expand character length for plot title from 60 to 80 */ (need changes in viewr, next ident, to maintain compatibility). */ - increase "max" to allow more plots when auto looping (mimics the */ intent recommended in upnea044). */ - revise text position describing axes and add a warning when */ uncertainty data were altered to fit within the fixed axis */ limits. */ - delete unused variables, fxmax and fymax. */ - correct long-standing typo in introductory covr comments. */ - force energy axes to be identical when mt=mt1 so resulting */ correlation matrix plot is square (McKnight request). */ - add warning label when non-zero uncertainty data are forced */ to fit within the plot abscissa limits. */ - eliminate a "zero" group when plotting threshold reactions so */ that true non-zero data fill more of the plot space. */ - eliminate restriction for imat(n)>300 to call expando. *d covr.31 c * ---cards 2, 2a, and 3a for nout.le.0 only (plot option) * *d up111.8 common/storec/a(2900000) *i covr.114 common/covmf/mf3,mf5,mf35 common/covf3/einc *d covr.118 dimension tlev(6) *d up111.64 data tlev/0.001d0,0.1d0,0.2d0,0.3d0,0.6d0,1.0d0/ *d covr.166 nlev=6 *d up111.10 data iamax/2900000/, niad/17/, ipr/1/, ntics3/600/ *d covr.139 *i covr.142 max=1+nfigmx*(nfigmx+1)/2 mf3=3 mf5=5 c *********dummy data, for now einc=0.0253 c ********* *d covr.256 c c ***read the first two records to verify this is a legal tape, c set the mf35 flag and determine the number of groups for c scratch storage. call reserv('scr',17,iscr,a) call tpidio(nin,0,0,a(iscr),nb,nw) call contio(nin,0,0,a(iscr),nb,nw) if (mfh.ne.1 .or. mth.ne.451) then call error('covr','illegal input tape',' ') else if (nint(a(iscr+4)).eq.-11) then mf35=mf3 elseif (nint(a(iscr+4)).eq.-12) then mf35=mf5 else call error('covr','illegal errorj output tape for covr',' ') endif endif call contio(nin,0,0,a(iscr),nb,nw) nwscr=nint(a(iscr+2))+6 if (nwscr.lt.17) nwscr=17 call releas('scr',0,a) call repoz(nin) c *d covr.289 if (imt(n).le.0) call expndo(nscr,a) *d covr.355 call plotit(a(ixn),a(iyn),a(ixig),a(iyig),ixpn,ixmax, *i covr.453 common/covmf/mf3,mf5,mf35 *d covr.472 call finds(mat,mf35,0,nin) *d covr.474 if (mfh.ne.mf35) go to 160 *i covr.667 common/covmf/mf3,mf5,mf35 *d covr.729 call finds(mat,mf35,mt,nin) *d covr.748 call finds(mat1,mf35,mt1,nin) *d covr.756 mf3x=33 if (mf35.eq.5) mf3x=35 if (mt.eq.251) mf3x=34 call finds(mat,mf3x,mt,nin) *i covr.769 if (mf3x.eq.34) mat1x=math *i covr.771 if (mf3x.eq.34) mtx=l1h */ don't divide by zero; can happen if there is only */ one few group contained within the plot limits. *d up111.30,up111.31 if (rlimx.ne.0 .and. rlimy.ne.0) then rlimx=xslim*rlimx/(a(iy+ixmax-1)-ethry) rlimy=xslim*rlimy/(a(ix+ixmax-1)-ethrx) endif *d covr.906,907 *d covr.911 subroutine plotit(x,y,xig,yig,ixn,ixmax,rsdx,rsdy, *i covr.922 common/covmf/mf3,mf5,mf35 *d covr.926,927 character*80 strng external findex,smilab,matshd *d covr.932,934 data dx3,dy3/-.75d0,1.9d0/ data dy4/.75d0/ data yyym/59.999d0/ data yrtest/10.d0/, ylogmn/0.1001d0/, ylogmx/99.9d0/ *d covr.939,941 data dx3,dy3/-.75e0,1.9e0/ data dy4/.75e0/ data yyym/59.999e0/ data yrtest/10.e0/, ylogmn/0.1001e0/, ylogmx/99.9e0/ *i covr.947 c c *** check if mat=mat1 and mt=mt1, if true mov nu-bar or c the few-group cross section into rsdx. mtflg=0 if (mat.eq.mat1 .and. mt.eq.mt1) then mtflg=1 call findex('xx',ixx,a) do i=1,ixn rsdx(i)=a(ixx+i-1+(ixmax-ixn)) enddo endif *d covr.958 112 continue *d covr.960 *i covr.962 c c - find the smallest non-zero and largest s.d. values and compute c the min-to-max range. c ymin=1.d20 ymax=-1.d20 *i covr.966 if (rsdx(i).gt.zero .and. rsdx(i).lt.ymin) ymin=rsdx(i) if (rsdx(i).gt.ymax) ymax=rsdx(i) *d covr.969 *i covr.970 if (ymin.ne.zero) then yrange=ymax/ymin else yrange=0.d0 endif ydec=log10(ymin) if (ydec.lt.zero)ydec=ydec-1 yymin=ten**int(ydec) *i covr.974 xmin1=xmin *d covr.976,977 if (t.lt.zero) then t1=t-0.99999 else t1=t+0.00001 endif i=int(t1) *d covr.993 call smilab(iza,mat,mt,mtflg,strng) *d covr.996 if (yrange.gt.yrtest) then write(nplot,'(''4/'')') else write(nplot,'(''3/'')') endif *i covr.1003 c c ***write (e,std.dev.), or if the mtflg is set write c (e,few group nu-bar) or (e,few group xsec) to plot c file. If plotting the relative standard deviation, c restrict the axis limits to 0.1% to 100% for log c scale or less than 60% for linear scale. If plotting c few-group data there is no axis limitation. Also set c a flag to warn the user when data are modified to fit c on the plot (but don't get confused by zero data). iwarn=0 *d covr.1005,1006 if (mtflg.eq.0) then yyy=100.*yig(i) if (yrange.gt.yrtest .and. yyy.lt.ylogmn) then if (yyy.ne.0)iwarn=1 yyy=ylogmn endif if (yrange.gt.yrtest .and. yyy.gt.ylogmx) then iwarn=1 yyy=ylogmx elseif (yrange.le.yrtest .and. yyy.gt.yyym) then iwarn=1 yyy=yyym endif else yyy=yig(i) if (yrange.gt.yrtest) then if (yyy.le.yymin) then if (yyy.ne.0)iwarn=1 yyy=1.0001*yymin endif endif endif *d covr.1016 122 continue *d covr.1020 ymin=1.d20 ymax=-1.d20 *i covr.1024 if (rsdy(i).gt.zero .and. rsdy(i).lt.ymin) ymin=rsdy(i) if (rsdy(i).gt.ymax) ymax=rsdy(i) *d covr.1027 *i covr.1028 if (ymin.ne.zero) then yrange=ymax/ymin else yrange=0. endif *i covr.1032 c c ***set uncertainty plot lower limit to match the cross c section plot so get a square correlation matrix. if (mtflg.eq.1) ymin=xmin1 *d covr.1034,1035 if (t.lt.zero) then t1=t-0.99999 else t1=t+0.00001 endif i=int(t1) *d covr.1051 call smilab(iza1,mat1,mt1,0,strng) *d covr.1054 if (yrange.gt.yrtest) then write(nplot,'(''4/'')') else write(nplot,'(''3/'')') endif *i covr.1061 c c ***write (e,std.dev.) to the plot file. Restrict the c axis limits to 0.1% to 100% for log scale or less c than 60% for linear scale. *d covr.1064 if (yrange.gt.yrtest .and. yyy.lt.ylogmn) then if (yyy.ne.0)iwarn=1 yyy=ylogmn endif if (yrange.gt.yrtest .and. yyy.gt.ylogmx) then iwarn=1 yyy=ylogmx elseif (yrange.le.yrtest .and. yyy.gt.yyym) then iwarn=1 yyy=yyym endif *d covr.1075,1083 if (mtflg.eq.0) then write(nplot,'(a,''#H.75rdinate scale is %'',a,''/'')')qu,qu write(nplot,'(a,''#H.75<>relative standard deviation.'',a, & ''/'')')qu,qu elseif (mt.eq.251) then write(nplot,'(a,''#H.75rdinate scales are % relative'',a, & ''/'')')qu,qu write(nplot,'(a,''#H.75<>standard deviation and mu-bar.'',a, & ''/'')')qu,qu elseif (mt.ge.452 .and. mt.le.456) then write(nplot,'(a,''#H.75rdinate scales are % relative'',a, & ''/'')')qu,qu write(nplot,'(a,''#H.75<>standard deviation and nu-bar.'',a, & ''/'')')qu,qu elseif (mf35.eq.5) then write(nplot,'(a,''#H.75rdinate scales are % standard'',a, & ''/'')')qu,qu write(nplot,'(a,''#H.75<>deviation and spectrum.'',a, & ''/'')')qu,qu else write(nplot,'(a,''#H.75rdinate scales are % relative'',a, & ''/'')')qu,qu write(nplot,'(a,''#H.75<>standard deviation and barns.'',a, & ''/'')')qu,qu endif write(nplot,'(''0/'')') xpos=xpos+dy4 write(nplot,'(''-1 0 1. 1.'',5f8.3,''/'')')xpos,ypos,ysize,1.,wa write(nplot,'(a,''#H.75bscissa scales are energy (e).'',a, & ''/'')') qu,qu write(nplot,'(''/'')') if (iwarn.ne.0) then xpos=xpos+0.45 write(nplot,'(''0/'')') write(nplot,'(''-1 0 1. 1.'',5f8.3,''/'')')xpos,ypos,ysize, & 1.,wa write(nplot,'(a,''#H.75arning: some uncertainty'',a, & ''/'')')qu,qu write(nplot,'(a,''#H.75<>data were suppressed.'',a,''/'')') & qu,qu endif *i covr.1087 c call releas('xx',0,a) call releas('xy',0,a) c *d up111.12 common/storec/a(2900000) *d covr.1413 subroutine smilab(iza,mat,mt,mtflg,strng) *i covr.1418 common/covmf/mf3,mf5,mf35 common/covf3/einc *d covr.1421 character str1*6,str2*60,str3*39 *d covr.1424,1429 l1=6 if (mt.ge.452 .and. mt.le.456 .and. mtflg.eq.0) then write(str1,'(''[d]n/n'')') elseif (mt.ge.452 .and. mt.le.456 .and. mtflg.ne.0) then write(str1,'('' ]n'')') elseif (mt.eq.251 .and. mtflg.ne.0) then write(str1,'('' ]m'')') elseif (mtflg.ne.0 .and. mf35.eq.5) then write(str1,'('']f'')') l1=2 elseif (mtflg.eq.0 .and. mf35.eq.5) then write(str1,'(''[d]f/f'')') elseif (mtflg.eq.0 .and. mt.eq.251) then write(str1,'(''[d]m/m'')') elseif (mtflg.ne.0) then write(str1,'('' ]s'')') else write(str1,'(''[d]s/s'')') endif c if (mtflg.ne.0 .and. mf35.eq.5 .and. einc.gt.9.999e4) then write(str2,'(''>(in='',f5.2, & '' e) vs. out for '')') & einc/1.e6 l2=37 elseif (mtflg.ne.0 .and. mf35.eq.5 .and. einc.le.9.999e4) then write(str2,'(''>(in = '',1pe8.2, & '' e) vs. out for '')') & einc l2=39 else write(str2,'(''> vs. for '')') l2=14 endif *d covr.1431 strng=str1(1:l1)//str2(1:l2)//str3 *d covr.1499 & 'd','b','y','o','r','m','b','u','f', *d covr.1521 parameter (iramx=33) character*8 lnamel(2),hira(iramx),blank,nmea1,nmeb1,lnamer, *d covr.1523 dimension ira1(iramx),ira2(iramx) *d covr.1525 & 1,2,3,4,16,17,18,22,28,37,51,91,102,103,104,105,106,107,111, *d covr.1528 & 5,4,7,6,3,3,2,5,3,3,1,6,4,2,2,2,6,4,3, & 5,5,5,5,5,5,6,6,3,3,4,5,3,3/ *d covr.1531 & 'n]a<)','np)','4n)',')','cont.)',']g<)','p)','d)','t)', *d up111.59 jloc=11 *d covr.1569 do 300 j=1,iramx *d covr.1577 jloc=11 *ident up274 */ viewr - 20aug08 */ change character length from 60 to 80 (required to support */ similar change in covr from the previous ident). *d viewr.86 c * 80 characters allowed. * *d viewr.91 c * 80 characters allowed. * *d viewr.136 c * 80 characters allowed. * *d viewr.149 c * 80 characters allowed. * *d viewr.162 c * 80 characters allowed. * *d viewr.239 c * 80 characters allowed. * *d viewr.300 character*80 t1,t2,xl,yl,rl *d viewr.306 character*80 aleg *d viewr.316 character*80 text *i viewr.320 mxc=80 *d viewr.430 do i=1,mxc *d viewr.438 do i=1,mxc *d viewr.482 do i=1,mxc *d viewr.506 do i=1,mxc *d viewr.532 do i=1,mxc *d viewr.579 do i=1,mxc *d viewr.857 character*80 t1,t2,xl,yl,rl *d viewr.1128 character*80 aleg *d viewr.1211 character*80 aleg *d viewr.1288 character*80 t1,t2,xl,yl,rl *ident up275 */ plotr -- 25sep08 */ - clean up some variable initialization and typos. */ - 3D plots of groupr emission spectra was never fully implemented. */ delete previous partial coding and complete this implemenation. *d plotr.606 mfd=0 *d up77.19 mfd2=0 *d plotr.1431 if (locn+3*ne2m.le.maxaa.and.i1+3.le.maxx3) then *d plotr.1465 if (locn+3*ne2m.gt.maxaa.or.i1+3.gt.maxx3) *d plotr.1481,1482 factx1=1 facty1=1 *i plotr.1550 jnoth=0 *d plotr.1664,1854 c c ***set pointer for either neutron or photon group structure if (mfd.ne.16) then ngm=ngn+1 indx=locngn indx2=indx+ngn else ngm=ngg+1 indx=locngg indx2=indx+ngg endif c c ***set secondary energy plot limits. default values are the c entire groupr range. when user specified, adjust (if c necessary) to lie on group boundaries. use islo and ishi c to define the group limits. xmin=xleft xmax=xright if (xmin.eq.zero) then xmin=a(indx) xmax=a(indx2) islo=1 ishi=ngm-1 xstp=(xmax-xmin)/5 else itst=0 islo=0 ishi=0 i2=0 do while (itst.eq.0 .and. i2.le.ngl) i2=i2+1 if (islo.eq.0 .and. a(indx+i2).gt.xmin) then xmin=a(indx+i2-1) islo=i2 endif if (ishi.eq.0 .and. a(indx+i2).ge.xmax) then xmax=a(indx+i2) ishi=i2 endif itst=islo*ishi enddo if (islo.eq.0) call error('plotr', & 'user xmin exceeds groupr range', & ' ') if (xleft.ne.zero .and. xleft.lt.xmin) call mess('plotr', & ' user xmin is below the groupr range', & 'reset xmin to minimum groupr energy') if (ishi.eq.0) then call mess('plotr', & ' user xmax exceeds groupr range', & 'reset to maximum groupr energy') xmax=a(indx+ngl) ishi=ngl endif xstp=xstep endif xleft=xmin xright=xmax xstep=xstp if (xmin.ge.xmax) call error('plotr', & 'secondary energy mismatch', & 'xmin.ge.xmax') c c ***set incident energy plot limits. default values are the c entire groupr range. when user specified, adjust (if c necessary) to lie on group boundaries. use inlo and inhi c to define the group limits. ymin=ybot ymax=ytop if (ymin.eq.zero) then ymin=a(indx) ymax=a(indx2) inlo=1 inhi=ngm-1 ystp=(ymax-ymin)/10 else itst=0 inlo=0 inhi=0 i2=0 do while (itst.eq.0 .and. i2.le.ngl) i2=i2+1 if (inlo.eq.0 .and. a(indx+i2).gt.ymin) then ymin=a(indx+i2-1) inlo=i2 endif if (inhi.eq.0 .and. a(indx+i2).ge.ymax) then ymax=a(indx+i2) inhi=i2 endif itst=inlo*inhi enddo if (inlo.eq.0) call error('plotr', & 'user ymin exceeds groupr range', & ' ') if (ybot.ne.zero .and. ybot.lt.ymin) call mess('plotr', & ' user ymin is below the groupr range', & 'reset ymin to minimum groupr energy') if (inhi.eq.0) then call mess('plotr', & ' user ymax exceeds groupr range', & 'reset to maximum groupr energy') ymax=a(indx2) inhi=ngm-1 endif ystp=ystep endif ybot=ymin ytop=ymax ystep=ystp if (ymin.ge.ymax) call error('plotr', & 'incident energy mismatch', & 'ymin.ge.ymax') c c ***check array space if ((inhi-inlo+2).gt.maxxy) & call error('plotr', & 'too many incident groups for 3D plotting', & ' ') if ((ishi-islo+2).gt.maxxy) & call error('plotr', & 'too many secondary groups for 3D plotting', & ' ') c c ***load energy structure into incident, ex3, and secondary, ey3, c arrays. j=0 do i=inlo,inhi+1 j=j+1 ey3(j)=a(indx+i-1) enddo j=0 do i=inlo,ishi+1 j=j+1 ex3(j)=a(indx+i-1) enddo emin=0 emax=etop c c ***loop over incident groups locn=1 zmin=1 zmax=0 ig=1 do while (ig.lt.ngl) call listio(nin,0,0,a(jbase),nb,nw) l=jbase l=l+nw do while (nb.ne.0) call moreio(nin,0,0,a(l),nb,nw) l=l+nw enddo ng2=nint(a(jbase+2)) ig2lo=nint(a(jbase+3)) ig=nint(a(jbase+5)) c c ***incident group plot limits are inlo to inhi. make sure c ig is within this range. if (ig.lt.inlo .or. ig.gt.inhi) goto 3420 c c ***secondary group plot limits are islo to ishi. make sure c some part of ig2lo to (ig2lo+(ng2-1)) falls within this c range. ig2hi=ig2lo+(ng2-1) if (ig2lo.gt.ishi .or. ig2hi.lt.islo) goto 3420 c c ***loop over secondary energies, converting groupr matrix c element values to a "per eV" basis; set any element whose c value is less than small/100 to this limit to permit log c scale plotting; keep track of minimum and maximum values c for possible axis definition. c c use the aa array as a temporary holder for plot data. c start with the number of data points to follow, then the c incident energy group number followed by pairs of data c that are the secondary energy group number and the c spectrum. write these data in "histogram" format (i.e., c for a given group number, repeat the spectrum value with c the next higher group number. include small but non-zero c values at the lowest and highest energy to complete the c histogram. c k2=1 do j=2,ng2 ig2=ig2lo+j-2 if (ig2.ge.islo .and. ig2.le.ishi) then eghi=ey3(ig2-islo+2) eglo=ey3(ig2-islo+1) f2=a(jbase+6+nl*nz*(j-1))/(eghi-eglo) if (f2.lt.small/100) f2=small/100 if (f2.lt.zmin) zmin=f2 if (f2.gt.zmax) zmax=f2 if (k2.eq.1) then aa(locn+k2)=ig k2=k2+1 aa(locn+k2)=ig2 k2=k2+1 aa(locn+k2)=small/100 k2=k2+1 endif aa(locn+k2)=ig2 k2=k2+1 aa(locn+k2)=f2 k2=k2+1 aa(locn+k2)=ig2+1 k2=k2+1 aa(locn+k2)=f2 k2=k2+1 endif enddo aa(locn+k2)=aa(locn+k2-2) k2=k2+1 aa(locn+k2)=small/100 k2=k2+1 aa(locn)=k2 locn=locn+k2 3420 continue enddo call tosend(nin,0,0,a) c c ***use zmin, zmax to define axis limits, if no user input if (rbot.eq.zero) then c c ***first reset zmin, zmax to exact decade values. alz=log10(zmin) ialz=int(alz) if (ialz.lt.0)ialz=ialz-1 zmin=10.**ialz alz=log10(zmax) ialz=int(alz) if (ialz.gt.0)ialz=ialz+1 zmax=10.**ialz c c ***define rbot, rtop and rstep. rbot=zmin rtop=zmax rstep=1 endif c c ***define default axis labels if no user input if (nx.eq.0) then xl=xlabld nx=14 endif if (ny.eq.0) then yl=sece ny=nsece endif if (nr.eq.0) then rl=probp nr=nprobp endif c c ***finally have everything in place to write the plot file. jtype=2 factx1=1 facty1=1 write(nplt,'(i4,i8,7f7.2,''/ 3d plot'')') iplot,iwcol, & factx1,facty1,xll,yll,ww,wh,wr write(nplt,'(1x,a,a,a,''/'')') qu,t1,qu if (iauto.gt.0) call rname(mtd,name) if (iauto.gt.0) write(t2,'(''mf='',i2,'' mt='',i3,2x,a)') & mfd,mtd,name write(nplt,'(1x,a,a,a,''/'')') qu,t2,qu write(nplt,'(3i6,''/'')') -itype,jtype,igrid if (xstep.eq.zero) then write(nplt,'(''/'')') else write(nplt,'(1p,3e13.4,''/'')') xleft,xright,xstep endif write(nplt,'(1x,a,a,a,''/'')') qu,xl,qu if (ystep.eq.zero) then write(nplt,'(''/'')') else write(nplt,'(1p,3e13.4,''/'')') ybot,ytop,ystep endif write(nplt,'(1x,a,a,a,''/'')') qu,yl,qu if (rstep.eq.zero) then write(nplt,'(''/'')') else write(nplt,'(1p,3e13.4,''/'')') rbot,rtop,rstep endif write(nplt,'(1x,a,a,a,''/'')') qu,rl,qu write(nplt,'(''/'')') write(nplt,'(6f9.3,''/'')') xv,yv,zv,x3,y3,z3 write(nplt,'('' 1/'')') c c ***recover data from the aa array for plotting. the secondary c emission spectrum is plotted at the lower group energy. if c the commented lines below are made active, a second copy of c this spectrum will be plotted at an energy just below the top c of the group. llocn=1 do while (llocn.lt.locn) einc=ey3(nint(aa(llocn+1))-inlo+1) write(nplt,'(1p,e13.4,''/'')')einc do i=llocn+2,llocn+nint(aa(llocn))-1,2 esec=ex3(nint(aa(i))-islo+1) spec=aa(i+1) write(nplt,'(1p,2e13.4,''/'')')esec,spec enddo write(nplt,'(''/'')') c einc=0.9999*ey3(nint(aa(llocn+1))-inlo+2) c write(nplt,'(1p,e13.4,''/'')')einc c do i=llocn+2,llocn+nint(aa(llocn))-1,2 c esec=ex3(nint(aa(i))-islo+1) c spec=aa(i+1) c write(nplt,'(1p,2e13.4,''/'')')esec,spec c enddo c write(nplt,'(''/'')') llocn=llocn+nint(aa(llocn)) enddo write(nplt,'(''/'')') if (iauto.gt.0) go to 321 go to 110 *ident up276 */ groupr -- 30sep08 */ - define enext in getwtf for iwt=2 as for all iwt values. */ - make sure ehigh is defined when group interval exceeds the */ maximum cross section energy range. *d groupr.2493 enext=s101*e *i groupr.3272 ehigh=emax *ident up277 */ moder -- 30sep08 */ upgrade moder to conform to the compact covariance format */ with a variable, 2 to 6, number of digits (Trkov/Hebert, */ previously implemented unofficially as idents upnea034 and */ upnea037). *i up117.16 ndigit=l1h if (ndigit.lt.2 .or. ndigit.gt.6) then if(ndigit.eq.0) then ndigit=2 call mess('file32','illegal value of ndigit', & 'set default ldigit=2') else call error('file32','illegal value of ndigit',' ') endif endif *i up117.17 nw=ndigit *ident up278 */ njoy -- 30sep08 */ upgrade intgio to conform to the compact covariance format */ with a variable, 2 to 6, number of digits (Trkov, previously */ implemented unofficially as ident upnea033). *d up118.11 c if any unit is zero, it is not used. Parameter nw determines c the number of entries read or written, as well as the format c for formatted files; nw is an input quantity. If 00, set c efmean=average for this interval; if ifissp=-1, c redefine ifissp to whatever interval includes efmean. call findf(matd,35,18,nendf) call contio(nendf,0,0,a(iscr),nb,nw) nfissp=n1h if (ifissp.gt.nfissp) then write(strng,'("User ifissp (",i2,") not found. Max on ", & "file is ",i2,".")')ifissp,nfissp call error('errorr',strng,' ') endif i=0 do while (i.lt.nfissp) i=i+1 call listio(nendf,0,0,a(iscr),nb,nw) eclo=c1h echi=c2h if (n1h.gt.ncovl) ncovl=n1h+6 is=iscr do while (nb.ne.0) is=is+nw if (is-iscr+1.gt.nwscr) & call error('errorj','storage exceeded.',' ') call moreio(nendf,0,0,a(is),nb,nw) enddo if (i.eq.ifissp) then efmean=0.5*(eclo+echi) i=nfissp elseif (ifissp.le.0) then if (eclo.le.efmean .and. echi.ge.efmean) then ifissp=i igflag=1 i=nfissp endif if (nfissp.eq.1) then if (efmean.lt.eclo .or. efmean.gt.echi) then efmean=0.5*(eclo+echi) ifissp=1 i=nfissp write(strng,'(" reset efmean to ",1pe11.4, & " eV.")')efmean call mess('errorr','only one subsection',strng) else ifissp=1 igflag=1 endif endif endif enddo if (ifissp.le.0) call error('errorj', & 'no covariance data found for user ifissp/efmean',' ') call releas('scr',0,a) call repoz(nendf) c ***copy matd from nendf to nendf2 nendf2=19 if (nendf.lt.0)nendf2=-nendf2 call openz(nendf2,0) call tpidio(nendf,0,0,b,nb,nw) mat=1 mf=0 mt=0 call tpidio(0,0,nendf2,b,nb,nw) mat=0 do while (mat.le.matd) call contio(nendf,0,0,b,nb,nw) if (mat.eq.matd) then call contio(0,0,nendf2,b,nb,nw) call tomend(nendf,0,nendf2,b) call atend(0,nendf2) mat=10000 else call tomend(nendf,0,0,b) endif enddo if (mat.ne.10000) call error('errorj', & 'nendf-to-nendf2 copy for matd failed', & ' ') call repoz(nendf) endif c *d errorj.421,423 if (mfcov.eq.32) write(nsyso,'(" irespr ",31("."),i11)')irespr if (mfcov.eq.34) write(nsyso,'(" legord ",31("."),i11)')legord if (mfcov.eq.35) then write(nsyso,'(" igflag ",31("."),i11)')igflag write(nsyso,'(" ifissp ",31("."),i11)')ifissp write(nsyso,'(" efmean ",31("."),1pe11.4)')efmean write(nsyso,'(" covariance matrix energy range ",7("."), & 1pe11.4," to",1pe11.4," eV.")')eclo,echi endif *i errorj.693 if (mfcov.eq.35) call closz(nendf2) *b errorj.3482 common/err5/eclo,echi,efmean common/err5a/mffis,igflag,ncove,ncovl *d up272.114 c scratch space based upon problem dependent variables *d up272.124 if (mffis.ne.6) then nwscr=max(17,n1h+6,nunion+10) else nwscr=max(17,3*n1h+13,nunion+10) endif *d errorj.3574,3578 if (mffis.gt.0 .and. mfh.gt.mffis) then go to 380 elseif (mfh.eq.mffis) then if (mth.eq.18) then go to 300 else call tosend(ngout,0,0,a(iscr)) go to 210 endif else if (mth.eq.0) go to 210 if (mfh.gt.3) then call tosend(ngout,0,0,a(iscr)) go to 210 endif endif c *d errorj.3667 call findf(matd,mffis,18,ngout) *i errorj.3669 c ***write an mf5 cont record to ntp regardless of mffis mfh=5 *d errorj.3671,3717 c ***read the spectrum. if mffis=5 it is a simple incident c neutron energy independent vector, otherwise it comes c from the mf6 matrix if(mffis.eq.5) then call listio(ngout,0,0,a(iscr),nb,nw) is=iscr do while (nb.ne.0) is=is+nw if (is-iscr+1.gt.nwscr) call error('colaps', & 'storage exceeded',' ') call moreio(ngout,0,0,a(is),nb,nw) enddo else c c ***this coding assumes a groupr mf6 file created from an c original endf mf5 input file. The form of a groupr mf6 c file created from an endf mf6 input file differs (and c will be addressed in a future update)! c c ***start by reading the "isotropic" spectrum, save at a(iscrx) iscrx=iscr+ng+6 call listio(ngout,0,0,a(iscr),nb,nw) if (n2h.ne.0) call error('colaps','not ready for file6',' ') ig2lo=l2h np=n1h is=iscr do while (nb.ne.0) is=is+nw if (is-iscr+1.gt.nwscr) call error('colaps', & 'storage exceeded',' ') call moreio(ngout,0,0,a(is),nb,nw) enddo do i=1,ng a(iscrx-1+i)=0 enddo do i=1,np a(iscrx+ig2lo-2+i)=a(iscr+5+i) enddo do i=1,ng a(iscr+5+i)=0 enddo c iscr2=iscrx+ng jg=0 eltst=eclo ehtst=echi c ***read the flux and either nu*sigf for groups in the c "isotropic" energy range or nu*sigf*chi for higher c energy groups and create a merged nu*sigf*chi vector c for all groups in the eclo-to-echi energy interval, c or for the group that encompasses efmean. do while(jg.lt.ng) call listio(ngout,0,0,a(iscr2),nb,nw) ig2lo=l2h np=n1h jg=n2h is=iscr2 do while (nb.ne.0) is=is+nw if (is-iscr+1.gt.nwscr) call error('colaps', & 'storage exceeded.', & ' ') call moreio(ngout,0,0,a(is),nb,nw) enddo flxa=a(iscr2+6) ea1=a(iela+jg-1) ea2=a(iela+jg) if (igflag.ne.0) then eltst=ea1 ehtst=ea2 endif c ***set flux weight only in the energy range if (efmean.ge.ehtst .or. efmean.le.eltst) then flxa=0 else ea12=ea2-ea1 if (ea1.lt.eltst) ea1=eltst if (ea2.gt.ehtst) ea2=ehtst flxa=flxa*(ea2-ea1)/ea12 endif if(ig2lo.eq.0) then c ***contribution comes from isotropic part of the spectrum sfnuf=a(iscr2+7) do i=1,ng a(iscr+5+i)=a(iscr+5+i)+a(iscrx-1+i)*flxa*sfnuf enddo else c ***contribution comes from a matrix vector do i=2,np a(iscr+ig2lo+3+i)=a(iscr+ig2lo+3+i)+a(iscr2+5+i)*flxa enddo endif c ***if ea1>efmean, done. Reset jg to force do while exit if (ea1.gt.efmean)jg=ng+1 enddo c ***normalize nu*sigf*chi sfnuf=0 do i=1,ng sfnuf=sfnuf+a(iscr+5+i) enddo do i=1,ng a(iscr+5+i)=a(iscr+5+i)/sfnuf enddo mfh=5 endif c c ***translate GROUPR's chi and flux to nunion's group structure ib=0 jg=0 egu=0 do 350 ib=1,nunion chiu=0 flxu=0 enl=a(iun+ib-1) enu=a(iun+ib) do while (egu.le.enl) jg=jg+1 egu=a(iela+jg) enddo egl=a(iela+jg-1) dea=egu-egl flxg=a(iscr18+jg-1) chig=a(iscr+jg+5) if (er.le.ea3) then c ***union group ib is within groupr group jg. flux=flxg*(enu-enl)/dea chiu=chig*flux flxu=flux else c ***union group ib spans multiple groupr groups, make c partial chiu, flxu calculation then start looping c over additional groupr groups. enuu=egu flux=flxg*(enuu-enl)/dea chiu=chig*flux flxu=flux do while (egu.le.enu) jg=jg+1 enl=enuu egl=egu egu=a(iela+jg) dea=egu-egl flxg=a(iscr18+jg-1) chig=a(iscr+jg+5) if (egu.le.enu) then enuu=egu else enuu=enu endif flux=flxg*(enuu-enl)/dea chiu=chiu+chig*flux flxu=flxu+flux enddo endif c c ***write the union group flux and chi (using the groupr c mf3 format even though it is mf5 data) to ntp. nw=2 nwl=8 temp=0 a(iscr0)=temp a(iscr0+1)=0 a(iscr0+2)=nw a(iscr0+3)=1 a(iscr0+4)=nw a(iscr0+5)=ib a(iscr0+6)=flxu if (flxu.ne.0) then a(iscr0+7)=chiu/flxu else a(iscr0+7)=0 endif call listio(0,ntp,0,a(iscr0),nb,nw) 350 continue *i errorj.3754 common/err5a/mffis,igflag,ncove,ncovl *i errorj.3938 if (mf.eq.35) then if (n2h.gt.ncove)ncove=n2h endif *d errorj.3944,3949 */ */ perform endf zero-sum check and renormalize the matrix elements */ if the test fails. also, errorj expects absolute covariances */ of the probability distribution function while the endf-6 format */ specifies covariances of the bin probabilities. Therefore must */ divide the covariance data read from the endf tape by the bin */ width before proceeding with the errorj analysis. *i errorj.727 common/err5a/mffis,igflag,ncove,ncovl *d errorj.766 c ***scratch storage is the remaining space unless mfcov=35, then c assign max(npage+6,ncovl). namx=-1 if (mfcov.eq.35) namx=max(npage+6,ncovl) *i errorj.973 if (mfcov.eq.35) then call sumchk(a(loc(li)),a) call covbin(a(loc(li))) endif *i errorj.1319 subroutine sumchk(covl,a) c ****************************************************************** c compute row (or column) sums for the input covariance matrix and c the multigroup spectrum integral using the covariance matrix c energy grid. Then perform the endf specified "zero-sum" rule c test. If necessary, correct the individual matrix elements per c the endf manual (section 35.3 in the april, 2001 edition). c covl(1:ncovl) = mf35 list record (header, matrix energy grid c and the triangular covariance matrix elements). c ****************************************************************** c implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/err5a/mffis,igflag,ncove,ncovl common/err6/nendf2 character*66 c dimension covl(*),a(*) dimension b(17) parameter (stst=1.d-5) parameter (sml=1.d-30) external error,mess c c ***check for required symmetry and lb=7 flags isym=nint(covl(3)) lb=nint(covl(4)) if (isym.ne.1) call error('sumchk','endf file error', & 'mf35 matrix must be symmetric') if (lb.ne.7) call error('sumchk','endf file error', & 'mf35 matrix lb flag must be 7') ibase=6 ne=nint(covl(ibase)) if (ne.gt.ncove) call error('sumchk','ne, ncove mismatch',' ') ne1=ne-1 c c ***reserve space for ne1 row (column) sums and ne1 spectrum c integrals. call reserv('rcs',ne1,ircs,a) call reserv('spc',ne1,ispc,a) c c ***set pointer to matrix elements (a triangular matrix given in c a vector array starting at cov(ibase+1). also initialize the c summation variables and then accumulate the sum over rows (or c columns) and a cummulative sum of all matrix elements. ibase=ibase+ne do i=1,ne1 a(ircs+i-1)=0 enddo sumt=0 do i=1,ne1 do j=i,ne1 ibase=ibase+1 a(ircs+i-1)=a(ircs+i-1)+covl(ibase) sumt=sumt+covl(ibase) if (j.gt.i) then a(ircs+j-1)=a(ircs+j-1)+covl(ibase) sumt=sumt+covl(ibase) endif enddo enddo c c ***get multigroup spectrum integrals on the covariance matrix c energy grid (needed for zero-sum rule test). call spcint(covl,a(ispc),a,ne1) c c ***perform zero-sum test on the covariance matrix and apply c correction if needed. is=0 i=1 do while (is.eq.0 .and. i.lt.ne1) if ((a(ircs+i-1)/a(ispc+i-1)).gt.stst) is=is+1 i=i+1 enddo if (is.eq.0) then call mess('sumchk','zero-sum test passed',' ') else call mess('sumchk','zero-sum test failed', & 'applying normalization correction') ibase=ne+6 do i=1,ne1 do j=i,ne1 ibase=ibase+1 covl(ibase)=covl(ibase)-a(ispc+i-1)*a(ircs+j-1) & -a(ispc+j-1)*a(ircs+i-1) & +a(ispc+i-1)*a(ispc+j-1)*sumt if (abs(covl(ibase)).lt.sml)covl(ibase)=0 enddo enddo endif c c ***release 'spc' and 'rcs' (they will be re-assigned, if c necessary, upon the next entry into sumchk). call releas('spc',0,a) call releas('rcs',0,a) c return end c subroutine spcint(covm,spc,a,ne1) c ****************************************************************** c routine to obtain the spectrum from the input tape (nendf2) and c compute multigroup integrals on the covariance matrix energy grid c covm(1:ncovl) = mf35 list record (header, matrix energy grid c and the triangular covariance matrix elements). c c the spectrum are read from either file5 or file6. if from file5 c can use intega directly since the data are in a tab1 record. if c from file6 must convert the list record into an equivalent tab1 c before using intega for the integration. c c in this initial version, only support file5, lf=1 and file6, c law=lang=1. c ****************************************************************** c implicit real*8 (a-h,o-z) common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/err5a/mffis,igflag,ncove,ncovl common/err6/nendf2 character*60 strng character*66 c dimension covm(*),spc(*),a(*) dimension b(17) external error,mess,intega,terpa c c ***allocate scratch storage and initialize the spectrum c integral array nnw=10000 call reserv('scr3',nnw,isc3,a) do i=1,ne1 spc(i)=0 enddo mtt=mt c c ***read the endf2 input tape until reach the required mf/mtt call repoz(nendf2) call tpidio(nendf2,0,0,b,nb,nw) call contio(nendf2,0,0,b,nb,nw) mf56=0 do while (mf56.eq.0) read(nendf2,'(a66,i4,i2,i3)')c,mat,mf,mt if ((mf.eq.5 .or. mf.eq.6) .and. mt.eq.mtt) mf56=mf if (mf.gt.6) mf56=999 enddo if (mf56.eq.999) then write(strng,'("no mf5 or mf6, mt=",i3," spectrum on nendf2")') & mtt call error('spcint',strng,' ') endif read(c,'(2e11.0,4i11)')c1,c2,l1h,l2h,n1h,n2h nk=n1h if (mf56.eq.5) then c c ***loop over the nk subsections. First subsection is always a c tab1 regardless of subsequent lf flag. do k=1,nk call tab1io(nendf2,0,0,a(isc3),nb,nw) lf=nint(a(isc3+3)) if (lf.ne.1) then write(strng,'("not ready for lf = ",i2)')lf call error('spcint',strng,' ') endif nr1=nint(a(isc3+4)) np1=nint(a(isc3+5)) ib=isc3+5+2*(nr1+np1) if (lf.eq.1) then call tab2io(nendf2,0,0,a(ib),nb,nw) nr2=nint(a(ib+4)) np2=nint(a(ib+5)) ib2=ib+6+2*nr2 iloop=0 c c ***loop over tab1 spectrum data. Use the first c spectrum whose incident energy equals or exceeds c the covariance matrix lower energy bound. do while (iloop.le.np2) iloop=iloop+1 call tab1io(nendf2,0,0,a(ib2),nb,nw) if (nb.ne.0) ibx=ib2+nw do while (nb.ne.0) call moreio(nendf2,0,0,a(ibx),nb,nw) ibx=ibx+nw if (ibx.ge.isc3+nnw) call error('spcint', & 'array overflow',' ') enddo esp=a(ib2+1) nr12=nint(a(ib2+4)) np12=nint(a(ib2+5)) if (esp.ge.covm(1)) then ir=1 ip=2 call terpa(pe,esp,enext,idis,a(isc3),ip,ir) ir=1 ip=2 do i=1,ne1 elow=covm(i+6) ehigh=covm(i+7) call intega(aaa,elow,ehigh,a(ib2),ip,ir) spc(i)=spc(i)+pe*aaa enddo iloop=np2+1 endif enddo endif enddo elseif (mf56.eq.6) then c c ***general format is a loop over nk, but the neutron (zap=1) c should be the first particle defined, therefore restrict c the do loop to a single iteration. nnk=1 do k=1,nnk call tab1io(nendf2,0,0,a(isc3),nb,nw) izap=nint(a(isc3)) if (izap.ne.1) then write(strng,'("looking for mf=6,mt=",i3,",izap=1 but ", & "found izap =",i5)')mtt,nint(a(isc3)) call error('spcint',strng,' ') endif law=nint(a(isc3+3)) if (law.ne.1) then write(strng,'("not ready for mf=6, mt=",i3,", law = ", & i2)')mtt,law call error('spcint',strng,' ') endif nr1=nint(a(isc3+4)) np1=nint(a(isc3+5)) ib=isc3+5+2*(nr1+np1) if (law.eq.1) then call tab2io(nendf2,0,0,a(ib),nb,nw) lang=nint(a(ib+2)) lep=nint(a(ib+3)) nr2=nint(a(ib+4)) np2=nint(a(ib+5)) ib2=ib+6+2*nr2 iloop=0 c c ***loop over list spectrum data. Use the first c spectrum whose incident energy equals or exceeds c the covariance matrix lower energy bound. When c found, convert into an equivalent tab1 record c (overwrite the tab2 record starting at a(ib) since c we don't need these data any longer) and use c intega to get the spectrum integral. do while (iloop.le.np2) iloop=iloop+1 call listio(nendf2,0,0,a(ib2),nb,nw) ib2x=ib2+nw do while (nb.ne.0) call moreio(nendf2,0,0,a(ib2x),nb,nw) ib2x=ib2x+nw enddo esp=a(ib2+1) nd=nint(a(ib2+2)) na=nint(a(ib2+3)) nw=nint(a(ib2+4)) nep=nint(a(ib2+5)) if (esp.ge.covm(1)) then ir=1 ip=2 call terpa(pe,esp,enext,idis,a(isc3),ip,ir) indx1=ib+6 a(ib)=0 a(ib+1)=0 a(ib+2)=0 a(ib+3)=0 a(ib+4)=1 a(ib+5)=nep a(ib+6)=nep a(ib+7)=lep do i=1,nep,nw/nep indx1=indx1+2 a(indx1)=a(ib2+i+6) a(indx1+1)=a(ib2+i+7) enddo ir=1 ip=2 do i=1,ne1 elow=covm(i+6) ehigh=covm(i+7) call intega(aaa,elow,ehigh,a(ib),ip,ir) spc(i)=spc(i)+pe*aaa enddo endif iloop=np2+1 enddo endif enddo endif c c ***release scratch storage call releas('scr3',0,a) c return end c subroutine covbin(covl) c *********************************************************** c errorj works with absolute covariances of the probability c distribution function while the endf-6 format specifies c covariances of the bin probabilities. Divide covariances c by the bin width. c - this routine modeled after covbin in chmf35 by A.Trkov. c *********************************************************** c implicit real*8 (a-h,o-z) external error, mess character*60 strng dimension covl(*) c write(strng, & '("converting mf35 convariance data to errorj format")') call mess('covbin',strng,' ') ibase=6 ng=nint(covl(6))-1 midx=ibase+ng+1 do i=1,ng dei=covl(ibase+i+1)-covl(ibase+i) do j=i,ng dej=covl(ibase+j+1)-covl(ibase+j) midx=midx+1 covl(midx)=covl(midx)/(dei*dej) enddo enddo c return end c */ fix covadd to include za and awr on nout *i errorj.9089 character*22 czaawr *d errorj.9095,9096 if (i.ne.2) then read(ntape,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii write(nout,'(a66,i4,i2,i3,i5)') dat,mat,mf,mt,ii else read(ntape,'(a22,a44,i4,i2,i3,i5)')czaawr,dat2,mat,mf,mt,ii write(nout,'(a22,a44,i4,i2,i3,i5)')czaawr,dat2,mat,mf,mt,ii endif *d errorj.9120,9125 write(nout,'(a22,4i11,i4,i2,i3,i5)')czaawr,0,0,0,1, & mat,33,imt(i),1 write(nout,'(2f11.1,4i11,i4,i2,i3,i5)')0.,0.,0,imt(i),0,1, & mat,33,imt(i),2 write(nout,'(2f11.1,4i11,i4,i2,i3,i5)')0.,0.,1,5,3,2, & mat,33,imt(i),3 */ include efmean on the output tape *i errorj.8116 common/err5/eclo,echi,efmean *d errorj.8187 b(2)=efmean *ident up283 */ covr - 5mar2009,20apr2009 */ - up273 was the initial attempt to include mf35 plotting, but we */ didn't have the incident neutron energy (efmean) until up282. */ Pass this value into the plot title (plots producted by 99.273 */ until now always said Ein=0.0253eV. */ - previous plots used black curves which can be hidden by the plot */ frame. Change color to blue and make it thicker. * - up273 plots the normalized spectrum, change it so that group */ average spectrum data are plotted to eliminate discontinuities */ produced by varying group delta-E. */ - revise logic for determining plot limits to reduce white space *d up273.56,58 *i up273.95 common/covf3/einc *i covr.730 if (mf35.eq.5) einc=a(iscr+1) *d up273.327 character str1*14,str2*35,str3*31 *d up273.337,338 write(str1,'(''Grp-average ]f'')') l1=14 *d up273.350,353 write(str2,'(''>(#LH>in#HXLX>='',f5.2, & '' e), '')')einc/1.e6 l2=34 *d up273.355,358 write(str2,'(''>(#LH>in#HXLX>='',1pe9.2, & '' e), '')')einc l2=35 */ when writing what is "card 9" to the output file processed by */ viewr, specify a blue, double thick curve. *d covr.1002 write(nplot,'(''0 0 0 3 2 /'')') *d covr.1060 write(nplot,'(''0 0 0 3 2 /'')') */ change from spectrum to spectrum/eV plot *d up273.136,137 c ***check if mat=mat1 and mt=mt1. If so don't create redundant c uncertainty plots, rather plot nu-bar, few-group cross section c or spectrum/eV. *d up273.142,144 if (mf35.ne.5) then do i=1,ixn rsdx(i)=a(ixx+i-1+(ixmax-ixn)) enddo else call findex('y',iy,a) do i=1,ixn de=a(iy+i+(ixmax-ixn))-a(iy+i-1+(ixmax-ixn)) rsdx(i)=a(ixx+i-1+(ixmax-ixn))/de enddo endif *d up273.188,189 c ***write (e,stdev), or if the mtflg is set write (e,few-group c nu-bar, few-group sigma or few-group spectrum/eV) to the plot *d up273.290 write(nplot,'(a,''#H.75<>deviation and spectrum/eV.'',a, */ revise logic for determining plot limits to reduce correlation */ matrix white space *d covr.953 c ***determine first group with non-zero data for this plot *i up273.147 c c ***determine first group with non-zero data for this plot. do 121 i=1,ixn jj=i if (rsdy(i).gt.zero) go to 122 121 continue 122 continue c c ***only plot from higher energy group so correlation matrix c appears square. if (jj.gt.ii) ii=jj *d covr.1011,up273.221 *ident up284 */ thermr - 26mar2009 */ - provide more user input info in the introductory comments. *i thermr.65 c * 1 compute using ENDF6 input tape data * c * --------or for pre-ENDF6 input set icoh = * *ident up285 */ acer - 26mar2009 */ - update thermal data comment (from up113); */ - correct an array index error (from up87); */ - correct a typo in the mtname reaction list; */ - revise tplots to properly plot coherent or incoherent elastic */ mubar (is already done properly in njoy2009). *d up113.13 c * (pdf/cdf) (requires MCNP5.1.50 or later) and provides * *d up87.80 isort1=100000*mprod(i)+10*iprod(i)+lprod(i) *d acer.11411 & '(n,2n)a ', '(n,3n)a ', '(n,2n)iso ', '(n,abs) ', *d acer.14048,14074 if (idpnc.eq.4) then write(nout,'(a,''coherent elastic'',a,''/'')') qu,qu write(nout,'(''0/'')') e=xss(itce+1) ell=xss(itce+nee) do while (e.le.ell) idone=0 i=0 ubar=0 sum=0 bl=0 do while (idone.eq.0.and.i.lt.nee) i=i+1 ei=xss(itce+i) if (ei.gt.e) then idone=1 else ui=1-2*ei/e bi=(xss(itce+nee+i)-bl) ubar=ubar+bi*ui/e sum=sum+bi/e endif bl=xss(itce+nee+i) enddo ubar=ubar/sum write(nout,'(1p,2e14.6,''/'')') e,ubar e=e+e/50 enddo else write(nout,'(a,''incoherent elastic'',a,''/'')') qu,qu write(nout,'(''0/'')') loc=itca-1 do i=1,nee e=xss(itce+i) ubar=0 do j=1,ncl+1 ubar=ubar+xss(loc+j)/(ncl+1) enddo write(nout,'(1p,2e14.6,''/'')') e,ubar loc=loc+ncl+1 enddo endif *ident up286 */ viewr - 21apr2009 */ - make sure x2 is defined prior to initial usage (us a value that */ forces at least one pass through the subsequent do while loop). *i viewr.3181 x2=wu2+w-1 *ident up287 */ errorj - 21apr2009 */ - relax mpar=3 coding restriction when lcomp=2; */ - make sure apl is passed among all necessary routines; */ - revise standalone error message to use njoy's error routine */ These revisions incorporate the changes proposed in upnea048. *d up279.57,58 *d up279.68 nind=nind+mpar *d errorj.6810,6815 *d errorj.5818 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl *d errorj.5980 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl *d errorj.6351 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl *d errorj.6728 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl *d errorj.6845 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl *d errorj.7073 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl *d errorj.6485,6486 write(strng2,'(''mpar='',i4, '' lrf='',i4)') mpar,lrf call error('resprx','Not coded for mpar>4 lrf<3.', strng2) *ident up288 */ groupr - 22apr2009 */ - add the user title (card 3) to the output tape id record (Muir); */ - minor fix, save nqp, to stay in synch with njoy2009. *d groupr.323 if (ngout1.eq.0) then call tpidio(0,ngout2,0,title,nb,nwds) ntw=1 title(1)=0 endif *d groupr.824,827 *d up131.8 save nq,nqp,ig1,ng1 *ident up289 */ matxsr - 27apr2009 */ - there is never enough space in one routine or another, increase */ vector's "b" array (Aldama/Trkov). Was unofficially implemented */ for njoy99.259 in upnea031. *d up171.37 dimension b(30000) *d up171.39 maxb=30000 *ident up290 */ errorj - 27apr2009 */ - additional covariance related patches, unofficially implemented */ in upnea039 (but not those related to the 901 maximum group number */ since we've already increased this limit to 2501 in ident272), or */ from upnea049 (Trkov). */ - make sure iwt>0, and delete superfluous coding for iwt<0 that */ was carried over from groupr. *i errorj.344 if (iwt.le.0) then call mess ('errorj','input weighting function not supported', & 'switching to default, iwt=6') iwt=6 endif */ - make sure idiscf is initialized (should always be so, but some */ compilers don't always seem to know this). *d errorj.2673 data idisc,idiscf,elast/0,0,0.d0/ */ - dummy dimension declarations, similar to those for grpav4 in */ ident up260. These are somewhat superfluous since errorj */ restrictions on nz and nl mean we only really need one word */ (at this time) and lack of these dimension declarations has */ not caused a processing error. The values used here should */ keep all compilers happy and are consistent with the */ declarations used in other routines. *i errorj.2757 dimension sig(1),flux(10,10) *d errorj.5446,5458 iwtt=iabs(iwt) */ - define enext for iwt=2 as for other iwt values (same as we */ did for groupr in ident276. *d errorj.5625 enext=s101*e */ - keep the first column blank for printer control. *d errorj.5895 10000 format (' Energy range : ',I5,'/',I5) */ - make sure we've got the correct upper group identified. *d errorj.5910,5915 if(ip2.eq.0.and.ee.ge.eh)then ip2=1 ehg=egn(i) ieed=i-1 endif enddo if (elg.ge.eh) ieed=0 */ - define an alternate eskip size for negative energy resonances *d errorj.7114,7124 if (eres.lt.0.) then e2=1.0001 else if (e1.lt.0.1) then e2=1.05 elseif (e1.gt.elb1.and.e1.lt.elu1) then e2=eskip1 elseif (e1.gt.elb2.and.e1.lt.elu2) then e2=eskip2 elseif (e1.gt.elb3.and.e1.lt.elu3) then e2=eskip3 else e2=1.02 endif endif *ident up291 */ reconr -- 22jan09 - 29apr2009 (rem) */ the interpolation rule for the unresolved range is always being */ set to 2 (lin-lin), even if the evaluation says 5 (log-log). */ the interpolation rule for the energy-independent formats is set */ to 5 (log-log). this violates what endf-102 says, but it gives */ more reasonable shapes. *d reconr.242 call rdfil2(nrtot,a,jx,intunr) *d reconr.249 if (lrp.eq.3) call genunr(nin,a,intunr) *d reconr.481 subroutine rdfil2(nrtot,a,na,intunr) *i reconr.645 intunr=5 *d up262.11 call rdf2u2(nin,a,jnow,jx,nro,ienode,ieunr,intunr) *d up262.45 subroutine rdf2u2(nin,a,jnow,jx,nro,ienode,ieunr,intunr) *i reconr.1282 intunr=l1h *d reconr.1415 subroutine genunr(nin,a,intunr) *d reconr.1447 */ the coding that watches for steps that are too big shouldn't */ be applied in the unresolved range. it leads to the insertion */ of some unnecessary energy grid points. *d reconr.2182 if (in.gt.3.and.dx.gt.est.and.xm.lt.eresr) go to 175 */ the wide=3 parameters was intended to find old carry over */ evaluations that were prepared for parameter interpolation */ in the ur rather than the currently specified cross-section */ interpolation. it also finds some current evaluations with */ unreasonably large energy steps for cross-section interpolaton. */ there is an error in its implementation for lru=2,lrf=2 that */ omits doing the check on the first energy interval in the ur. *d reconr.1295,1297 ener=a(nloc+(ien-1)*jen) if (ener.ge.el.and.ener.lt.eh) then enex=a(nloc+(ien-1)*jen+jen) */ the wide=3 parameter is too large to reasonable subdivide */ the over wide intervals in a number of endf/b-vii evaluations. */ this change will tend to force energy grids down to a */ minimum of 10 points/decade. this should provide a lin-lin */ fit to a pure 1/v cross section within better than 1 percent. */ also, the 2.5 points were missing for higher decades. *d reconr.1045 dimension egridu(78) *d reconr.1047 data ngridu/78/ *d reconr.1049,1056 data egridu/1.0d1,1.25d1,1.5d1,1.7d1,2.0d1,2.5d1,3.0d1,3.5d1, & 4.0d1,5.0d1,6.0d1,7.2d1,8.5d1,1.0d2,1.25d2,1.5d2,1.7d2, & 2.0d2,2.5d2,3.0d2,3.5d2,4.0d2,5.0d2,6.0d2,7.2d2,8.5d2, & 1.0d3,1.25d3,1.5d3,1.7d3,2.0d3,2.5d3,3.0d3,3.5d3,4.0d3, & 5.0d3,6.0d3,7.2d3,8.5d3,1.0d4,1.25d4,1.5d4,1.7d4,2.0d4, & 2.5d4,3.0d4,3.5d4,4.0d4,5.0d4,6.0d4,7.2d4,8.5d4,1.0d5, & 1.25d5,1.5d5,1.7d5,2.0d5,2.5d5,3.0d5,3.5d5,4.0d5,5.0d5, & 6.0d5,7.2d5,8.5d5,1.0d6,1.25d6,1.5d6,1.7d6,2.0d6,2.5d6, & 3.0d6,3.5d6,4.0d6,5.0d6,6.0d6,7.2d6,8.5d6/ *d reconr.1058,1065 data egridu/1.0e1,1.25e1,1.5e1,1.7e1,2.0e1,2.5e1,3.0e1,3.5e1, & 4.0e1,5.0e1,6.0e1,7.2e1,8.5e1,1.0e2,1.25e2,1.5e2,1.7e2, & 2.0e2,2.5e2,3.0e2,3.5e2,4.0e2,5.0e2,6.0e2,7.2e2,8.5e2, & 1.0e3,1.25e3,1.5e3,1.7e3,2.0e3,2.5e3,3.0e3,3.5e3,4.0e3, & 5.0e3,6.0e3,7.2e3,8.5e3,1.0e4,1.25e4,1.5e4,1.7e4,2.0e4, & 2.5e4,3.0e4,3.5e4,4.0e4,5.0e4,6.0e4,7.2e4,8.5e4,1.0e5, & 1.25e5,1.5e5,1.7e5,2.0e5,2.5e5,3.0e5,3.5e5,4.0e5,5.0e5, & 6.0e5,7.2e5,8.5e5,1.0e6,1.25e6,1.5e6,1.7e6,2.0e6,2.5e6, & 3.0e6,3.5e6,4.0e6,5.0e6,6.0e6,7.2e6,8.5d6/ *d reconr.1128 dimension egridu(78) *d reconr.1130 data ngridu/78/ *d reconr.1132,1140 data egridu/1.0d1,1.25d1,1.5d1,1.7d1,2.0d1,2.5d1,3.0d1,3.5d1, & 4.0d1,5.0d1,6.0d1,7.2d1,8.5d1,1.0d2,1.25d2,1.5d2,1.7d2, & 2.0d2,2.5d2,3.0d2,3.5d2,4.0d2,5.0d2,6.0d2,7.2d2,8.5d2, & 1.0d3,1.25d3,1.5d3,1.7d3,2.0d3,2.5d3,3.0d3,3.5d3,4.0d3, & 5.0d3,6.0d3,7.2d3,8.5d3,1.0d4,1.25d4,1.5d4,1.7d4,2.0d4, & 2.5d4,3.0d4,3.5d4,4.0d4,5.0d4,6.0d4,7.2d4,8.5d4,1.0d5, & 1.25d5,1.5d5,1.7d5,2.0d5,2.5d5,3.0d5,3.5d5,4.0d5,5.0d5, & 6.0d5,7.2d5,8.5d5,1.0d6,1.25d6,1.5d6,1.7d6,2.0d6,2.5d6, & 3.0d6,3.5d6,4.0d6,5.0d6,6.0d6,7.2d6,8.5d6/ data wide/1.26d0/ *d reconr.1142,1150 data egridu/1.0e1,1.25e1,1.5e1,1.7e1,2.0e1,2.5e1,3.0e1,3.5e1, & 4.0e1,5.0e1,6.0e1,7.2e1,8.5e1,1.0e2,1.25e2,1.5e2,1.7e2, & 2.0e2,2.5e2,3.0e2,3.5e2,4.0e2,5.0e2,6.0e2,7.2e2,8.5e2, & 1.0e3,1.25e3,1.5e3,1.7e3,2.0e3,2.5e3,3.0e3,3.5e3,4.0e3, & 5.0e3,6.0e3,7.2e3,8.5e3,1.0e4,1.25e4,1.5e4,1.7e4,2.0e4, & 2.5e4,3.0e4,3.5e4,4.0e4,5.0e4,6.0e4,7.2e4,8.5e4,1.0e5, & 1.25e5,1.5e5,1.7e5,2.0e5,2.5e5,3.0e5,3.5e5,4.0e5,5.0e5, & 6.0e5,7.2e5,8.5e5,1.0e6,1.25e6,1.5e6,1.7e6,2.0e6,2.5e6, & 3.0e6,3.5e6,4.0e6,5.0e6,6.0e6,7.2e6,8.5d6/ data wide/1.26e0/ *d reconr.1240 dimension egridu(78) *d reconr.1242 data ngridu/78/ *d reconr.1244,1252 data egridu/1.0d1,1.25d1,1.5d1,1.7d1,2.0d1,2.5d1,3.0d1,3.5d1, & 4.0d1,5.0d1,6.0d1,7.2d1,8.5d1,1.0d2,1.25d2,1.5d2,1.7d2, & 2.0d2,2.5d2,3.0d2,3.5d2,4.0d2,5.0d2,6.0d2,7.2d2,8.5d2, & 1.0d3,1.25d3,1.5d3,1.7d3,2.0d3,2.5d3,3.0d3,3.5d3,4.0d3, & 5.0d3,6.0d3,7.2d3,8.5d3,1.0d4,1.25d4,1.5d4,1.7d4,2.0d4, & 2.5d4,3.0d4,3.5d4,4.0d4,5.0d4,6.0d4,7.2d4,8.5d4,1.0d5, & 1.25d5,1.5d5,1.7d5,2.0d5,2.5d5,3.0d5,3.5d5,4.0d5,5.0d5, & 6.0d5,7.2d5,8.5d5,1.0d6,1.25d6,1.5d6,1.7d6,2.0d6,2.5d6, & 3.0d6,3.5d6,4.0d6,5.0d6,6.0d6,7.2d6,8.5d6/ data wide/1.26d0/ *d reconr.1254,1262 data egridu/1.0e1,1.25e1,1.5e1,1.7e1,2.0e1,2.5e1,3.0e1,3.5e1, & 4.0e1,5.0e1,6.0e1,7.2e1,8.5e1,1.0e2,1.25e2,1.5e2,1.7e2, & 2.0e2,2.5e2,3.0e2,3.5e2,4.0e2,5.0e2,6.0e2,7.2e2,8.5e2, & 1.0e3,1.25e3,1.5e3,1.7e3,2.0e3,2.5e3,3.0e3,3.5e3,4.0e3, & 5.0e3,6.0e3,7.2e3,8.5e3,1.0e4,1.25e4,1.5e4,1.7e4,2.0e4, & 2.5e4,3.0e4,3.5e4,4.0e4,5.0e4,6.0e4,7.2e4,8.5e4,1.0e5, & 1.25e5,1.5e5,1.7e5,2.0e5,2.5e5,3.0e5,3.5e5,4.0e5,5.0e5, & 6.0e5,7.2e5,8.5e5,1.0e6,1.25e6,1.5e6,1.7e6,2.0e6,2.5e6, & 3.0e6,3.5e6,4.0e6,5.0e6,6.0e6,7.2e6,8.5d6/ data wide/1.26e0/ *d reconr.3349 data wide/1.26d0/ *d reconr.3352 data wide/1.26e0/ *d reconr.3574 data wide/1.26d0/ *d reconr.3578 data wide/1.26e0/ */ there is logic in reconr that adds points to the initial */ list of nodes to make sure that the reconr grid will be */ fine enough so that constant cross sections broaden to 1/v. */ this is really only needed for some special cases, like he-3, */ with small capture components. it is not necessary to do this */ in the unresolved resonance range. *i reconr.1595 if (eresr.lt.elim) elim=eresr *ident up292 */ unresr -- 22jan09 - 29apr2009 (rem) */ same change to wide as in reconr above. *d unresr.363 dimension egridu(78) *d unresr.367 data ngridu/78/ *d unresr.369,377 data egridu/1.0d1,1.25d1,1.5d1,1.7d1,2.0d1,2.5d1,3.0d1,3.5d1, & 4.0d1,5.0d1,6.0d1,7.2d1,8.5d1,1.0d2,1.25d2,1.5d2,1.7d2, & 2.0d2,2.5d2,3.0d2,3.5d2,4.0d2,5.0d2,6.0d2,7.2d2,8.5d2, & 1.0d3,1.25d3,1.5d3,1.7d3,2.0d3,2.5d3,3.0d3,3.5d3,4.0d3, & 5.0d3,6.0d3,7.2d3,8.5d3,1.0d4,1.25d4,1.5d4,1.7d4,2.0d4, & 2.5d4,3.0d4,3.5d4,4.0d4,5.0d4,6.0d4,7.2d4,8.5d4,1.0d5, & 1.25d5,1.5d5,1.7d5,2.0d5,2.5d5,3.0d5,3.5d5,4.0d5,5.0d5, & 6.0d5,7.2d5,8.5d5,1.0d6,1.25d6,1.5d6,1.7d6,2.0d6,2.5d6, & 3.0d6,3.5d6,4.0d6,5.0d6,6.0d6,7.2d6,8.5d6/ data wide/1.26d0/ *d unresr.379,387 data egridu/1.0e1,1.25e1,1.5e1,1.7e1,2.0e1,2.5e1,3.0e1,3.5e1, & 4.0e1,5.0e1,6.0e1,7.2e1,8.5e1,1.0e2,1.25e2,1.5e2,1.7e2, & 2.0e2,2.5e2,3.0e2,3.5e2,4.0e2,5.0e2,6.0e2,7.2e2,8.5e2, & 1.0e3,1.25e3,1.5e3,1.7e3,2.0e3,2.5e3,3.0e3,3.5e3,4.0e3, & 5.0e3,6.0e3,7.2e3,8.5e3,1.0e4,1.25e4,1.5e4,1.7e4,2.0e4, & 2.5e4,3.0e4,3.5e4,4.0e4,5.0e4,6.0e4,7.2e4,8.5e4,1.0e5, & 1.25e5,1.5e5,1.7e5,2.0e5,2.5e5,3.0e5,3.5e5,4.0e5,5.0e5, & 6.0e5,7.2e5,8.5e5,1.0e6,1.25e6,1.5e6,1.7e6,2.0e6,2.5e6, & 3.0e6,3.5e6,4.0e6,5.0e6,6.0e6,7.2e6,8.5d6/ data wide/1.26e0/ *ident up293 */ purr -- 22jan09 - 29apr2009 (rem) */ same change to wide as in reconr above. *d purr.559 dimension egridu(78) *d purr.562 data ngridu/78/ *d purr.564,571 data egridu/1.0d1,1.25d1,1.5d1,1.7d1,2.0d1,2.5d1,3.0d1,3.5d1, & 4.0d1,5.0d1,6.0d1,7.2d1,8.5d1,1.0d2,1.25d2,1.5d2,1.7d2, & 2.0d2,2.5d2,3.0d2,3.5d2,4.0d2,5.0d2,6.0d2,7.2d2,8.5d2, & 1.0d3,1.25d3,1.5d3,1.7d3,2.0d3,2.5d3,3.0d3,3.5d3,4.0d3, & 5.0d3,6.0d3,7.2d3,8.5d3,1.0d4,1.25d4,1.5d4,1.7d4,2.0d4, & 2.5d4,3.0d4,3.5d4,4.0d4,5.0d4,6.0d4,7.2d4,8.5d4,1.0d5, & 1.25d5,1.5d5,1.7d5,2.0d5,2.5d5,3.0d5,3.5d5,4.0d5,5.0d5, & 6.0d5,7.2d5,8.5d5,1.0d6,1.25d6,1.5d6,1.7d6,2.0d6,2.5d6, & 3.0d6,3.5d6,4.0d6,5.0d6,6.0d6,7.2d6,8.5d6/ *d purr.574 data wide/1.26d0/ *d purr.576,583 data egridu/1.0e1,1.25e1,1.5e1,1.7e1,2.0e1,2.5e1,3.0e1,3.5e1, & 4.0e1,5.0e1,6.0e1,7.2e1,8.5e1,1.0e2,1.25e2,1.5e2,1.7e2, & 2.0e2,2.5e2,3.0e2,3.5e2,4.0e2,5.0e2,6.0e2,7.2e2,8.5e2, & 1.0e3,1.25e3,1.5e3,1.7e3,2.0e3,2.5e3,3.0e3,3.5e3,4.0e3, & 5.0e3,6.0e3,7.2e3,8.5e3,1.0e4,1.25e4,1.5e4,1.7e4,2.0e4, & 2.5e4,3.0e4,3.5e4,4.0e4,5.0e4,6.0e4,7.2e4,8.5e4,1.0e5, & 1.25e5,1.5e5,1.7e5,2.0e5,2.5e5,3.0e5,3.5e5,4.0e5,5.0e5, & 6.0e5,7.2e5,8.5e5,1.0e6,1.25e6,1.5e6,1.7e6,2.0e6,2.5e6, & 3.0e6,3.5e6,4.0e6,5.0e6,6.0e6,7.2e6,8.5d6/ *d purr.586 data wide/1.26e0/ */ fix the interpolation flag in mt152 and mt153 *d purr.54 common/unenp/nunr,lssf,iinel,iabso,intunr *d up90.14 a(l+5)=intunr *d purr.394 a(n+4)=intunr *d purr.555 common/unenp/nunr,lssf,iinel,iabso,intunr *i purr.713 intunr=5 *i purr.768 intunr=5 *i purr.797 intunr=l1h *d purr.937 common/unenp/nunr,lssf,iinel,iabso,intunr *ident up294 */ acer -- 22jan09 - 29apr2009 (rem) */ read the interpolation flag from mt153 */ it is currently always set to 2 *i acer.4920 intunr=n1h *d acer.5487 xss(next+2)=intunr *ident up295 */ acer -- 01feb90 - 30apr2009 (rem) */ add pages for the ur cross sections to the acer plots. */ show infinitely dilute, 100-barn, and 1-barn self-shielded */ cross sections computed from the probability tables. *i acer.18535 dimension ee(250),s0(250),s1(250),s2(250) *d acer.18577 abso=xss(esz+2*nes-1+i) *d acer.18583,18584 if (abso.lt.ymin) ymin=abso if (abso.gt.ymax) ymax=abso *d up213.13 abso=xss(esz+2*nes-1+i) *d up213.19,20 if (abso.lt.ymin) ymin=abso if (abso.gt.ymax) ymax=abso *i acer.18899 c c ***plot ur cross sections if (iurpt.ne.0) then nure=nint(xss(iurpt)) intunr=nint(xss(iurpt+2)) nurb=nint(xss(iurpt+1)) lssf=nint(xss(iurpt+5)) c ***total if (lssf.eq.0) then xmin=1e10 xmax=0 ymin=1e10 ymax=0 do ie=1,nure ee(ie)=abs(xss(iurpt+5+ie)) if (ee(ie).gt.xmax) xmax=ee(ie) if (ee(ie).lt.xmin) xmin=ee(ie) s0(ie)=0 s1(ie)=0 s2(ie)=0 f0=0 f1=0 f2=0 cl=0 ll=iurpt+5+nure+(ie-1)*6*nurb do ib=1,nurb dp=xss(ll+ib)-cl s0(ie)=s0(ie)+dp*xss(ll+nurb+ib) s1(ie)=s1(ie)+dp*xss(ll+nurb+ib)/(100+xss(ll+nurb+ib)) s2(ie)=s2(ie)+dp*xss(ll+nurb+ib)/(1+xss(ll+nurb+ib)) f0=f0+dp f1=f1+dp/(100+xss(ll+nurb+ib)) f2=f2+dp/(1+xss(ll+nurb+ib)) cl=xss(ll+ib) enddo s1(ie)=s1(ie)/f1 s2(ie)=s2(ie)/f2 if (s0(ie).gt.ymax) ymax=s0(ie) if (s1(ie).gt.ymax) ymax=s1(ie) if (s2(ie).gt.ymax) ymax=s1(ie) if (s0(ie).lt.ymin) ymin=s0(ie) if (s1(ie).lt.ymin) ymin=s1(ie) if (s2(ie).lt.ymin) ymin=s2(ie) enddo nunu=nure else xmin=abs(xss(iurpt+5+1)) xmax=abs(xss(iurpt+5+nure)) ymin=1e10 ymax=0 ie=0 do i=1,nes e=xss(esz-1+i) if (e.lt.xmin.or.e.ge.xmax) cycle ie=ie+1 ee(ie)=e tot=xss(esz+nes-1+i) s0(ie)=tot do ii=1,nure-1 e1=abs(xss(iurpt+5+ii)) e2=abs(xss(iurpt+5+ii+1)) if (e.lt.e1.or.e.ge.e2) cycle kk=iurpt+5+nure+(ii-1)*6*nurb ll=iurpt+5+nure+(ii+1-1)*6*nurb s1(ie)=0 s2(ie)=0 f1=0 f2=0 c1=0 c2=0 do j=1,nurb call terp1(e1,xss(kk+j)-c1,e2,xss(ll+j)-c2, & e,dp,intunr) call terp1(e1,xss(kk+nurb+j),e2,xss(ll+nurb+j), & e,pp,intunr) s1(ie)=s1(ie)+dp*pp*tot/(100+pp*tot) s2(ie)=s2(ie)+dp*pp*tot/(1+pp*tot) f1=f1+dp/(100+pp*tot) f2=f2+dp/(1+pp*tot) c1=xss(kk+j) c2=xss(ll+j) enddo s1(ie)=s1(ie)/f1 s2(ie)=s2(ie)/f2 if (s0(ie).gt.ymax) ymax=s0(ie) if (s0(ie).lt.ymin) ymin=s0(ie) if (s1(ie).gt.ymax) ymax=s1(ie) if (s1(ie).lt.ymin) ymin=s1(ie) if (s2(ie).gt.ymax) ymax=s2(ie) if (s2(ie).lt.ymin) ymin=s2(ie) enddo enddo nunu=ie endif ymax=ymax+ymax/10 if (ymin.lt.ymax/1000)ymin=ymax/1000 call ascll(xmin,xmax) 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,''UR total cross section'',a,''/'')') & qu,qu write(nout,'(''4 0 2 1/'')') 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,''ross section (barns)'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''/'')') write(nout,'(a,''Inf. Dil.'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s0(ie) enddo write(nout,'(''/'')') write(nout,'(''2/'')') write(nout,'(''/'')') write(nout,'(''0 0 0 1/'')') write(nout,'(a,''100 b'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s1(ie) enddo write(nout,'(''/'')') write(nout,'(''3/'')') write(nout,'(''/'')') write(nout,'(''0 0 0 2/'')') write(nout,'(a,''1 b'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s2(ie) enddo write(nout,'(''/'')') c c ***elastic if (lssf.eq.0) then xmin=1e10 xmax=0 ymin=1e10 ymax=0 do ie=1,nure ee(ie)=abs(xss(iurpt+5+ie)) if (ee(ie).gt.xmax) xmax=ee(ie) if (ee(ie).lt.xmin) xmin=ee(ie) s0(ie)=0 s1(ie)=0 s2(ie)=0 f0=0 f1=0 f2=0 cl=0 do ib=1,nurb ll=iurpt+5+nure+(ie-1)*6*nurb dp=xss(ll+ib)-cl s0(ie)=s0(ie)+dp*xss(ll+2*nurb+ib) s1(ie)=s1(ie) & +dp*xss(ll+2*nurb+ib)/(100+xss(ll+nurb+ib)) s2(ie)=s2(ie) & +dp*xss(ll+2*nurb+ib)/(1+xss(ll+nurb+ib)) f0=f0+dp f1=f1+dp/(100+xss(ll+nurb+ib)) f2=f2+dp/(1+xss(ll+nurb+ib)) cl=xss(ll+ib) enddo s1(ie)=s1(ie)/f1 s2(ie)=s2(ie)/f2 if (s0(ie).gt.ymax) ymax=s0(ie) if (s1(ie).gt.ymax) ymax=s1(ie) if (s2(ie).gt.ymax) ymax=s2(ie) if (s0(ie).lt.ymin) ymin=s0(ie) if (s1(ie).lt.ymin) ymin=s1(ie) if (s2(ie).lt.ymin) ymin=s2(ie) enddo nunu=nure else xmin=abs(xss(iurpt+5+1)) xmax=abs(xss(iurpt+5+nure)) ymin=1e10 ymax=0 ie=0 do i=1,nes e=xss(esz-1+i) if (e.lt.xmin.or.e.ge.xmax) cycle ie=ie+1 ee(ie)=e tot=xss(esz+nes-1+i) elas=xss(esz+3*nes-1+i) s0(ie)=elas do ii=1,nure-1 e1=abs(xss(iurpt+5+ii)) e2=abs(xss(iurpt+5+ii+1)) if (e.lt.e1.or.e.ge.e2) cycle kk=iurpt+5+nure+(ii-1)*6*nurb ll=iurpt+5+nure+(ii+1-1)*6*nurb s1(ie)=0 s2(ie)=0 f1=0 f2=0 c1=0 c2=0 do j=1,nurb call terp1(e1,xss(kk+j)-c1,e2,xss(ll+j)-c2, & e,dp,intunr) call terp1(e1,xss(kk+nurb+j),e2,xss(ll+nurb+j), & e,pp,intunr) call terp1(e1,xss(kk+2*nurb+j),e2,xss(ll+2*nurb+j), & e,pe,intunr) s1(ie)=s1(ie)+dp*pe*elas/(100+pp*tot) s2(ie)=s2(ie)+dp*pe*elas/(1+pp*tot) f1=f1+dp/(100+pp*tot) f2=f2+dp/(1+pp*tot) c1=xss(kk+j) c2=xss(ll+j) enddo s1(ie)=s1(ie)/f1 s2(ie)=s2(ie)/f2 if (s0(ie).gt.ymax) ymax=s0(ie) if (s0(ie).lt.ymin) ymin=s0(ie) if (s1(ie).gt.ymax) ymax=s1(ie) if (s1(ie).lt.ymin) ymin=s1(ie) if (s2(ie).gt.ymax) ymax=s2(ie) if (s2(ie).lt.ymin) ymin=s2(ie) enddo enddo nunu=ie endif ymax=ymax+ymax/10 if (ymin.lt.ymax/1000)ymin=ymax/1000 call ascll(xmin,xmax) 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,''UR elastic cross section'',a,''/'')') & qu,qu write(nout,'(''4 0 2 1/'')') 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,''ross section (barns)'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''/'')') write(nout,'(a,''Inf. Dil.'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s0(ie) enddo write(nout,'(''/'')') write(nout,'(''2/'')') write(nout,'(''/'')') write(nout,'(''0 0 0 1/'')') write(nout,'(a,''100 b'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s1(ie) enddo write(nout,'(''/'')') write(nout,'(''3/'')') write(nout,'(''/'')') write(nout,'(''0 0 0 2/'')') write(nout,'(a,''1 b'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s2(ie) enddo write(nout,'(''/'')') c c ***fission if (lssf.eq.0) then xmin=1e10 xmax=0 ymin=1e10 ymax=0 do ie=1,nure ee(ie)=abs(xss(iurpt+5+ie)) if (ee(ie).gt.xmax) xmax=ee(ie) if (ee(ie).lt.xmin) xmin=ee(ie) s0(ie)=0 s1(ie)=0 s2(ie)=0 f0=0 f1=0 f2=0 cl=0 do ib=1,nurb ll=iurpt+5+nure+(ie-1)*6*nurb dp=xss(ll+ib)-cl s0(ie)=s0(ie)+dp*xss(ll+3*nurb+ib) s1(ie)=s1(ie) & +dp*xss(ll+3*nurb+ib)/(100+xss(ll+nurb+ib)) s2(ie)=s2(ie) & +dp*xss(ll+3*nurb+ib)/(1+xss(ll+nurb+ib)) f0=f0+dp f1=f1+dp/(100+xss(ll+nurb+ib)) f2=f2+dp/(1+xss(ll+nurb+ib)) cl=xss(ll+ib) enddo s1(ie)=s1(ie)/f1 s2(ie)=s2(ie)/f2 if (s0(ie).gt.ymax) ymax=s0(ie) if (s1(ie).gt.ymax) ymax=s1(ie) if (s2(ie).gt.ymax) ymax=s2(ie) if (s0(ie).lt.ymin) ymin=s0(ie) if (s1(ie).lt.ymin) ymin=s1(ie) if (s2(ie).lt.ymin) ymin=s2(ie) enddo nunu=nure else xmin=abs(xss(iurpt+5+1)) xmax=abs(xss(iurpt+5+nure)) ymin=1e10 ymax=0 nnf=0 do i=1,ntr mt=nint(xss(mtr-1+i)) if (mt.eq.18.or.mt.eq.19) then kf=nint(xss(lsig-1+i)+sig-1) nnf=nint(xss(kf+1)) iif=nint(xss(kf)) endif enddo ie=0 do i=1,nes e=xss(esz-1+i) if (e.lt.xmin.or.e.ge.xmax) cycle ie=ie+1 ee(ie)=e tot=xss(esz+nes-1+i) fiss=0 if (nnf.gt.0) then if (i.ge.iif) fiss=xss(kf+2+i-iif) endif s0(ie)=fiss do ii=1,nure-1 e1=abs(xss(iurpt+5+ii)) e2=abs(xss(iurpt+5+ii+1)) if (e.lt.e1.or.e.ge.e2) cycle kk=iurpt+5+nure+(ii-1)*6*nurb ll=iurpt+5+nure+(ii+1-1)*6*nurb s1(ie)=0 s2(ie)=0 f1=0 f2=0 c1=0 c2=0 do j=1,nurb call terp1(e1,xss(kk+j)-c1,e2,xss(ll+j)-c2, & e,dp,intunr) call terp1(e1,xss(kk+nurb+j),e2,xss(ll+nurb+j), & e,pp,intunr) call terp1(e1,xss(kk+3*nurb+j),e2,xss(ll+3*nurb+j), & e,pe,intunr) s1(ie)=s1(ie)+dp*pe*fiss/(100+pp*tot) s2(ie)=s2(ie)+dp*pe*fiss/(1+pp*tot) f1=f1+dp/(100+pp*tot) f2=f2+dp/(1+pp*tot) c1=xss(kk+j) c2=xss(ll+j) enddo s1(ie)=s1(ie)/f1 s2(ie)=s2(ie)/f2 if (s0(ie).gt.ymax) ymax=s0(ie) if (s0(ie).lt.ymin) ymin=s0(ie) if (s1(ie).gt.ymax) ymax=s1(ie) if (s1(ie).lt.ymin) ymin=s1(ie) if (s2(ie).gt.ymax) ymax=s2(ie) if (s2(ie).lt.ymin) ymin=s2(ie) enddo enddo nunu=ie endif if (ymax.gt.zero) then ymax=ymax+ymax/10 if (ymin.lt.ymax/1000)ymin=ymax/1000 call ascll(xmin,xmax) 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,''UR fission cross section'',a,''/'')') & qu,qu write(nout,'(''4 0 2 1/'')') 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,''ross section (barns)'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''/'')') write(nout,'(a,''Inf. Dil.'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s0(ie) enddo write(nout,'(''/'')') write(nout,'(''2/'')') write(nout,'(''/'')') write(nout,'(''0 0 0 1/'')') write(nout,'(a,''100 b'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s1(ie) enddo write(nout,'(''/'')') write(nout,'(''3/'')') write(nout,'(''/'')') write(nout,'(''0 0 0 2/'')') write(nout,'(a,''1 b'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s2(ie) enddo write(nout,'(''/'')') endif c c ***capture if (lssf.eq.0) then xmin=1e10 xmax=0 ymin=1e10 ymax=0 do ie=1,nure ee(ie)=abs(xss(iurpt+5+ie)) if (ee(ie).gt.xmax) xmax=ee(ie) if (ee(ie).lt.xmin) xmin=ee(ie) s0(ie)=0 s1(ie)=0 s2(ie)=0 f0=0 f1=0 f2=0 cl=0 do ib=1,nurb ll=iurpt+5+nure+(ie-1)*6*nurb dp=xss(ll+ib)-cl s0(ie)=s0(ie)+dp*xss(ll+4*nurb+ib) s1(ie)=s1(ie) & +dp*xss(ll+4*nurb+ib)/(100+xss(ll+nurb+ib)) s2(ie)=s2(ie) & +dp*xss(ll+4*nurb+ib)/(1+xss(ll+nurb+ib)) f0=f0+dp f1=f1+dp/(100+xss(ll+nurb+ib)) f2=f2+dp/(1+xss(ll+nurb+ib)) cl=xss(ll+ib) enddo s1(ie)=s1(ie)/f1 s2(ie)=s2(ie)/f2 if (s0(ie).gt.ymax) ymax=s0(ie) if (s1(ie).gt.ymax) ymax=s1(ie) if (s2(ie).gt.ymax) ymax=s2(ie) if (s0(ie).lt.ymin) ymin=s0(ie) if (s1(ie).lt.ymin) ymin=s1(ie) if (s2(ie).lt.ymin) ymin=s2(ie) enddo else xmin=abs(xss(iurpt+5+1)) xmax=abs(xss(iurpt+5+nure)) ymin=1e10 ymax=0 nnf=0 do i=1,ntr mt=nint(xss(mtr-1+i)) if (mt.eq.102) then kc=nint(xss(lsig-1+i)+sig-1) iic=nint(xss(kc)) endif enddo ie=0 do i=1,nes e=xss(esz-1+i) if (e.lt.xmin.or.e.ge.xmax) cycle ie=ie+1 ee(ie)=e tot=xss(esz+nes-1+i) capt=xss(kc+2+i-iic) s0(ie)=capt do ii=1,nure-1 e1=abs(xss(iurpt+5+ii)) e2=abs(xss(iurpt+5+ii+1)) if (e.lt.e1.or.e.ge.e2) cycle kk=iurpt+5+nure+(ii-1)*6*nurb ll=iurpt+5+nure+(ii+1-1)*6*nurb s1(ie)=0 s2(ie)=0 f1=0 f2=0 c1=0 c2=0 do j=1,nurb call terp1(e1,xss(kk+j)-c1,e2,xss(ll+j)-c2, & e,dp,intunr) call terp1(e1,xss(kk+nurb+j),e2,xss(ll+nurb+j), & e,pp,intunr) call terp1(e1,xss(kk+4*nurb+j),e2,xss(ll+4*nurb+j), & e,pe,intunr) s1(ie)=s1(ie)+dp*pe*capt/(100+pp*tot) s2(ie)=s2(ie)+dp*pe*capt/(1+pp*tot) f1=f1+dp/(100+pp*tot) f2=f2+dp/(1+pp*tot) c1=xss(kk+j) c2=xss(ll+j) enddo s1(ie)=s1(ie)/f1 s2(ie)=s2(ie)/f2 if (s0(ie).gt.ymax) ymax=s0(ie) if (s0(ie).lt.ymin) ymin=s0(ie) if (s1(ie).gt.ymax) ymax=s1(ie) if (s1(ie).lt.ymin) ymin=s1(ie) if (s2(ie).gt.ymax) ymax=s2(ie) if (s2(ie).lt.ymin) ymin=s2(ie) enddo enddo nunu=ie endif ymax=ymax+ymax/10 if (ymin.lt.ymax/1000)ymin=ymax/1000 call ascll(xmin,xmax) 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,''UR capture cross section'',a,''/'')') & qu,qu write(nout,'(''4 0 2 1/'')') 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,''ross section (barns)'',a,''/'')') qu,qu write(nout,'(''/'')') write(nout,'(''/'')') write(nout,'(a,''Inf. Dil.'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s0(ie) enddo write(nout,'(''/'')') write(nout,'(''2/'')') write(nout,'(''/'')') write(nout,'(''0 0 0 1/'')') write(nout,'(a,''100 b'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s1(ie) enddo write(nout,'(''/'')') write(nout,'(''3/'')') write(nout,'(''/'')') write(nout,'(''0 0 0 2/'')') write(nout,'(a,''1 b'',a,''/'')') qu,qu write(nout,'(''0/'')') do ie=1,nunu write(nout,'(1p,2e14.6,''/'')') ee(ie),s2(ie) enddo write(nout,'(''/'')') endif *ident up296 */ purr -- 24mar09 - 29apr2009 (rem) */ change the binning logic for the total cross sections to provide */ more low probability intervals in the low and high wings. the */ center of the distribution will use nbin-10 roughly equal */ probability bins, and the two wings will have 5 bins each using */ declining probilities going down or up in cross section. the */ value of nsamp is increased to help stabilize the bins. */ also add a printout for the minimum total cross section seen */ (ie, the real lower limit of the first bin). change the output */ for mt152 to be the renormalized direct calculation of the */ bondarenko cross sections instead of the renormalized values */ computed from the probability table. this makes the results */ independent of the binning used. the value of nbin should */ be 15 or more. *d up84.8 common/pustore/a(350000) *d up84.10 data namax/350000/, nidmax/24/, ipr/1/ *d up84.12 nsamp=10000 *d up84.53,54 nebin=nsamp/(nbin-10+1.76) ibin=nebin/200 *d up84.57,60 if (i.eq.1) ibin=ibin+nebin/40 if (i.eq.2) ibin=ibin+nebin/10 if (i.eq.3) ibin=ibin+nebin/4 if (i.eq.4) ibin=ibin+nebin/2 if (i.gt.4.and.i.lt.nbin-5) ibin=ibin+nebin if (i.eq.nbin-5) ibin=ibin+nebin/2 if (i.eq.nbin-4) ibin=ibin+nebin/4 if (i.eq.nbin-3) ibin=ibin+nebin/10 if (i.eq.nbin-2) ibin=ibin+nebin/40 if (i.eq.nbin-1) ibin=ibin+nebin/200 *i up84.119 write(nsyso, & '('' tmin'',1p,e11.3,1p,10e11.3)') & temp(itemp),tmin(itemp) *d up84.31 dimension sigf(5,10,10),sigb(5,10,10),tabl(nbin,5,ntemp) *d purr.2362,2366 sigb(1,i,itemp)=bval(1,i,itemp)/bval(6,i,itemp) sigb(2,i,itemp)=bval(2,i,itemp)/bval(6,i,itemp) sigb(3,i,itemp)=bval(3,i,itemp)/bval(6,i,itemp) sigb(4,i,itemp)=bval(4,i,itemp)/bval(6,i,itemp) sigb(5,i,itemp)=bval(5,i,itemp)/bval(7,i,itemp) *d purr.2373 & temp(itemp),sig0(i),(sigb(j,i,itemp),j=1,5) *d purr.38 c * nbin no. of probability bins (15 or more) *i purr.133 if (nbin.lt.15) & call error('purr','nbin should be 15 or more',' ') */ optional printout for plotting bondarenko cross sections */ normally commented out *i purr.59 common/pplot/epl(200),sigpl(200,5,10),back(200,5),ipl *i purr.74 ipl=0 *i purr.183 back(i,1)=a(loc) back(i,2)=a(loc+nunr) back(i,3)=a(loc+2*nunr) back(i,4)=a(loc+3*nunr) back(i,5)=back(i,1) *i purr.539 c print bondarenko cross sections for plotting c uncomment the following lines to activate c do k=1,5 c do j=1,nsigz c if (k.eq.1) write(nsyso, c & '(/'' p0 total, sigz='',1p,e10.2)') sigz(j) c if (k.eq.2) write(nsyso, c & '(/'' elastic, sigz='',1p,e10.2)') sigz(j) c if (k.eq.3) write(nsyso, c & '(/'' fission, sigz='',1p,e10.2)') sigz(j) c if (k.eq.4) write(nsyso, c & '(/'' capture, sigz='',1p,e10.2)') sigz(j) c if (k.eq.5) write(nsyso, c & '(/'' p1 total, sigz='',1p,e10.2)') sigz(j) c do i=1,ipl c tsig=sigpl(i,k,1) c if (lssf.eq.1) tsig=back(i,k) c if (sigpl(i,k,1).ne.zero) c & tsig=tsig*sigpl(i,k,j)/sigpl(i,k,1) c write(nsyso,'(1p,2e11.4)') epl(i),tsig c enddo c enddo c enddo *i purr.1742 common/pplot/epl(200),sigpl(200,5,10),back(200,5),ipl *i purr.1773 if (ipl.lt.200) ipl=ipl+1 epl(ipl)=e *i purr.2395 sigpl(ipl,j,i)=sigf(j,i,1) *i purr.2398 */ optional printout for plotting probability per barn with viewr */ uncomment the following lines to activate c write(nsyso,'(/'' probability per barn versus total'')') c write(nsyso,'('' e='',1p,e12.4)') e c tnorm=0 c do i=1,nbin c denom=tval(i,1)-tnorm c denom=tabl(i,1,1)/denom c write(nsyso,'(1p,2e11.4,''/'')') tabl(i,2,1),denom c tnorm=tval(i,1) c enddo *ident up297 */ heatr -- 22may2009 & 30sept2009 */ upgrade hout to insert/replace/append newly calculated mt data. */ this corrects a long-standing error in that the original */ dictionary record for the first mf/mt following the inserted */ heating mt records was omitted. *d heatr.5180,5216 inpk=2 mtn=mtp(inpk) j=0 ib1=ib-1 iowr=0 c c ***loop over existing dictionary records do i=1,nx ia=6*(i-1) mfi=nint(a(idict1+ia+3)) mti=nint(a(idict1+ia+4)) c c ***insert heating mt dictionary data (or overwrite c original dictionary data with revised data). do while ((mfi.eq.3 .and. mtn.le.mti) .or. & (mfi.gt.3 .and. inpk.le.npk)) if (mfi.eq.3 .and. mtn.eq.mti) iowr=1 a(ib1+j+1)=0 a(ib1+j+2)=0 a(ib1+j+3)=3 a(ib1+j+4)=mtp(inpk) a(ib1+j+5)=ncds(inpk) a(ib1+j+6)=0 j=j+6 inpk=inpk+1 if (inpk.le.npk) then mtn=mtp(inpk) else mtn=10000 endif enddo c c ***insert original dictionary data (unless the heating c mt entry above was an overwrite of existing data). if (mfi.ne.3 .or. (mfi.eq.3 .and. iowr.eq.0)) then a(ib1+j+1)=0 a(ib1+j+2)=0 a(ib1+j+3)=mfi a(ib1+j+4)=mti a(ib1+j+5)=a(idict1+ia+5) a(ib1+j+6)=a(idict1+ia+6) j=j+6 endif enddo c c ***insert rest of heating mt dictionary data, if any. do i=inpk,npk a(ib1+j+1)=0 a(ib1+j+2)=0 a(ib1+j+3)=3 a(ib1+j+4)=mtp(i) a(ib1+j+5)=ncds(i) a(ib1+j+6)=0 j=j+6 enddo */ now revise mf=3. replace redundant mt data with these new data */ and insert new mf=3 mt data in ascending mt order. *i heatr.5000 character*60 strng *d heatr.5243,5286 call contio(nin,0,0,a(iscr),nb,nw) if (mf.ne.3 .or. mt.eq.0) then write(strng,'("nin out of order. read mf,mt = ",2i5)')mf,mt call error('hout',strng,' ') endif mfnin=mf mtnin=mt inow=iscr+6 call contio(nscr,0,0,a(inow),nb,nw) if (mf.ne.3 .or. mt.eq.0) then write(strng,'("nscr out of order. read mf,mt = ",2i5)')mf,mt call error('hout',strng,' ') endif mfnscr=mf mtnscr=mt inow6=inow+6 do while (mfnin.eq.3 .and. mfnscr.eq.3) if (mtnin.lt.mtnscr) then mf=mfnin mt=mtnin call contio(0,nout,0,a(iscr),nb,nw) call tosend(nin,nout,0,a(inow6)) call contio(nin,0,0,a(iscr),nb,nw) mfnin=mf mtnin=mt elseif (mtnin.eq.mtnscr) then mf=mfnscr mt=mtnscr call contio(0,nout,0,a(inow),nb,nw) call tosend(nscr,nout,0,a(inow6)) call tosend(nin,0,0,a(inow6)) call contio(nin,0,0,a(iscr),nb,nw) mfnin=mf mtnin=mt call contio(nscr,0,0,a(inow),nb,nw) mfnscr=mf mtnscr=mt else do while (mtnin.ge.mtnscr .and. mfnscr.eq.3) mf=mfnscr mt=mtnscr call contio(0,nout,0,a(inow),nb,nw) call tosend(nscr,nout,0,a(inow6)) call contio(nscr,0,0,a(inow),nb,nw) mfnscr=mf mtnscr=mt enddo endif enddo if (mfnin.eq.3 .and. mfnscr.eq.0) then mf=mfnin mt=mtnin call contio(0,nout,0,a(iscr),nb,nw) elseif (mfnin.eq.0 .and. mfnscr.eq.3) then mf=mfnscr mt=mtnscr call contio(0,nout,0,a(inow),nb,nw) call tofend(nscr,nout,0,a(inow6)) elseif (mfnin.eq.0 .and. mfnscr.eq.0) then mf=mfnin mt=mtnin call contio(0,nout,0,a(iscr),nb,nw) endif call tomend(nin,nout,0,a(inow6)) *ident up298 */ groupr -- 01july2009 */ revise if test to allow processing of activation file data */ where zap=0, as occurs for fission data (Holloway, LANL). *d groupr.4299 if (mfd.ge.10000000) go to 100 *ident up299 */ thermr -- 20august2009 */ fix typo in moreio argument list (reported by Chikara Konno, JAEA). *d up97.26 call moreio(nendf,0,0,a(ll),nb,nw) *ident up300 */ errorr -- 20august2009 & 29september2009 */ original coding in the spcint routine (introduced in up282) only */ works for ascii input tapes, change the coding to work with either */ ascii or binary. *i up282.556 call findf(mat,3,0,nendf2) *d up282.559 call contio(nendf2,0,0,b,nb,nw) *d up282.568 *ident up301 */ groupr -- 31august2009 */ up288 is ok when ngout1=0 but writes extra, unneeded data to */ ngout2 when ngout1.ne.0. Subsequent jobs that read ngout2 */ properly skip over this gibberish, but the gendf output tape */ looks strange when viewed in a text editor. Patch up288 to do */ it right. When ngout1.ne.0 we simply copy the ngout1 tape id */ record to ngout2. *d up288.6,up288.10 if (ngout1.eq.0) call tpidio(0,ngout2,0,title,nb,nwds) ntw=1 title(1)=0 *ident up302 */ errorj -- 02september2009 */ need to allocate one more word for selected arrays. we really */ only need nunion words but they are passed through subroutines */ rdsig and rdgout in such a way that up to nunion+1 words can be */ required. This defect uncovered during njoy2009 testing. *d errorj.757,765 call reserv('flx',nunion,iflx,a) call reserv('sig',nunion+1,isig,a) call reserv('cov',nunion,icov,a) call reserv('sig1',nunion+1,isig1,a) call reserv('alp1',nunion,ialp1,a) call reserv('alp2',nunion,ialp2,a) call reserv('scr2',nunion+1,iscr2,a) *ident up303 */ purr -- 10september2009 */ make sure that energies outside the ur range (el-eh) are not */ added to the list of energy nodes (issue noted by Andre Trkov). *d purr.736 if (enow.ge.el.and.enow.le.eh) then call ilist2(enow,a(ieunr),nunr) endif *d purr.819 if (enow.ge.el.and.enow.le.eh) then call ilist2(enow,a(ieunr),nunr) endif *ident up304 */ leapr -- 22september2009 */ - need more space for sb in sbfill (increase ndmax and */ include an array bounds overflow test); */ - replace hardwired '2000' (old ndmax value) with ndmax; */ - revise an if test that doesn't need iprt in skold. *d leapr.316 ndmax=max(nbeta,25000) *d leapr.997 if (j.ge.ndmax) idone=1 *d leapr.1023 if (j.ge.ndmax) idone=1 *b leapr.1108 character*60 strng external error *i leapr.1117 if ((1+int((bmax-bmin)/delta)).gt.ndmax) then write(strng,'(''ndmax needs to be at least '',i6)') & 1+int((bmax-bmin)/delta) call error('sbfill',strng,' ') endif *d up114.116 if (iprint.eq.2) write(nsyso, *ident up305 */ errorj -- 20october2009 */ - use absolute value for AJ in Resprx_RRR_Lcom12 (Trkov); */ - insert the equivalent of ident up22 into ggrmat so that */ this subroutine continues to mimic reconr's csrmat. *i errorj.6537 ajres=abs(ajres) *d errorj.8350,8463 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 matricies do j=1,3 do i=1,3 s(j,i)=0 r(j,i)=0 enddo enddo c ***loop over resonances inow=inow+6 in=inow+nrs*6 do i=1,nrs aj=abs(a(inow+1)) c ***only select 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) 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 c ***take care of channel spin per the sign of aj: c kkkkkk = 0 => do not add anything in here; c kkkkkk = 1 => add resonance contribution but not c extra hard-sphere; c kkkkkk = 2 => add resonance plus hard-sphere phase c 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 c ***r-matrix path -- make symmetric matrix if (gf.ne.zero) then r(1,1)=uno+r(1,1) r(2,2)=uno+r(2,2) r(3,3)=uno+r(3,3) r(2,1)=r(1,2) s(2,1)=s(1,2) r(3,1)=r(1,3) s(3,1)=s(1,3) r(3,2)=r(2,3) s(3,2)=s(2,3) c ***invert the complex matrix call frobns(r,s,ri,si) c ***fission term for r-matrix path t1=ri(1,2) t2=si(1,2) t3=ri(1,3) t4=si(1,3) termf=four*gj*(t1*t1+t2*t2+t3*t3+t4*t4) u11r=p1*(two*ri(1,1)-uno)+two*p2*si(1,1) u11i=p2*(uno-two*ri(1,1))+two*p1*si(1,1) termt=two*gj*(uno-u11r) termn=gj*((uno-u11r)**2+u11i**2) c c ***r-function path else dd=r(1,1) rr=uno+dd ss=s(1,1) amag=rr**2+ss**2 rri=rr/amag ssi=-ss/amag uur=p1*(two*rri-uno)+two*p2*ssi uui=p2*(uno-two*rri)+two*p1*ssi if (abs(dd).lt.small.and.abs(phid).lt.small) then xx=2*dd xx=xx+2*(dd*dd+ss*ss+phid*phid+p2*ss) xx=xx-2*phid*phid*(dd*dd+ss*ss) xx=xx/amag termt=two*gj*xx termn=gj*(xx**2+uui**2) else termt=two*gj*(uno-uur) termn=gj*((uno-uur)**2+uui**2) endif termf=0 endif c 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 up306 */ thermr -- 18october2009 */ - several revisions to keep thermr99 in synch with thermr2009. */ - these changes reduce test01 differences that have been */ observed with different compiler optimization levels (rem). */ provide more starting beta points for free atom scattering. *d thermr.1684 nbeta=9 *d thermr.1691 a(ibeta+2)=2 a(ibeta+3)=4 a(ibeta+4)=6 a(ibeta+5)=8 a(ibeta+6)=10 a(ibeta+7)=15 a(ibeta+8)=25 */ use lat option on secondary energies *d thermr.1755 if (lat.eq.1) then ep=enow-a(ibeta-jbeta-1)*tevz else ep=enow-a(ibeta-jbeta-1)*tev endif *d up93.58,59 if (ep.eq.enow) then ep=sigfig(enow,6,-1) else ep=sigfig(ep,6,0) endif *d thermr.1758 if (lat.eq.1) then ep=enow+a(ibeta+jbeta-1)*tevz else ep=enow+a(ibeta+jbeta-1)*tev endif *d up93.61 *d thermr.1759 *d up93.63 *d thermr.1761,1762 if (ep.eq.enow) then ep=sigfig(enow,6,+1) iskip=1 else ep=sigfig(ep,6,0) endif */ use sigfig on cosines in sigl *i up93.73 x(2)=sigfig(x(2),6,0) *i thermr.2164 xm=sigfig(xm,6,0) *i up93.75 x(2)=sigfig(x(2),6,0) *i thermr.2220 xm=sigfig(xm,6,0) *ident up307 */ errorr -- 25october2009 */ - fix labels on sections to give mats correctly (rem) *d errorj.1847,1852 a(iscr+2)=mats(ixp) *d errorj.1867,1871 if (mats(ixp).ne.0) then if(irelco.eq.0)write(nsyso,40) mt,mats(ixp),mts(ixp), & time if(irelco.eq.1)write(nsyso,45) mt,mats(ixp),mts(ixp), & time *ident up308 */ reconr -- 25october2009 */ - correct abundance on default 2/151 *d reconr.4525 a(iscr+1)=1 *ident up309 */ acer -- 30october2009 */ - fix some print formats for consistency with njoy2009. *d acer.10070,10071 write(nsyso,'(12x,''lnu = '',i2,14x, & ''polynomial nu, nu = sum(c,i)*(e**(i-1))'')') j *d acer.10081 write(nsyso,'(12x,''lnu = '',i2,24x,''tabular nu'')') j *d up63.286 write(nsyso,'(12x,''lnu = '',i2,24x,''tabular nu'')') j *i up63.316 write(nsyso,'(/6x,''delayed fraction'')') *d up63.319 *d up63.401 & '' intt ='',i2,'' np = '',i4// *d acer.10396 & '' intt ='',i2,'' nd = '',i4,'' np = '',i4// *d acer.10526 & '' intt ='',i2,'' nd = '',i4,'' np = '',i4// *d acer.10560,10561 & '' intt ='',i2,'' nd = '',i4,'' np = '',i4)' & ) e2,intt,nd,nn *d acer.11030 & '' intt ='',i2,'' nd = '',i4,'' np = '',i4// *d acer.11192 & 1p,e14.6,'' int ='',i2,'' np ='',i4)') *d acer.11265,11266 & '' incident energy = '',1p,e14.6,'' intt ='', & i2,'' np = '',i4// *d acer.11298,11299 & '' incident energy = '',1p,e14.6,'' intt ='', & i2,'' nd = '',i4,'' np = '',i4// *d up9.179,180 & 1p,e14.6,'' intt ='',i2,'' nd = '',i4, & '' np = '',i4)') e2,intt,nd,nn *d acer.16876 & 1p,e14.6,'' int ='',i2,'' np ='',i4)') *d acer.16946 & '' intt ='',i2,'' nd = '',i4, & '' np = '',i4// *d acer.16949 & 1x,6(2x,''------------''))') e2,intt,nd,nn *d acer.16980,16981 & '' intt ='',i2,'' nd = '',i4, & '' np = '',i4// *ident up310 */ purr -- 02december2009 */ - make sure that the elastic scattering xs is not negative. If so, set */ to one microbarn so that all elastic scattering probability bins are */ non-zero (Trkov). *d purr.2108 if (els(itemp,ie).lt.-bkg(2)) els(itemp,ie)=-bkg(2)+(1/big) *ident up311 */ acer -- 11december2009 */ - ptleg2 has always calculated one too many Legendre functions. */ This is ok until nord=64 when an undetected array overflow occurs. *d acer.6988 call legndr(x(2),p,nord) *d acer.6994 call legndr(x(1),p,nord) *d acer.7008 call legndr(xm,p,nord) *ident up312 */ heatr -- 16december2009 */ - revise energy test in nheat so optimized and unoptimized code */ yield the same printed energy grid. *d heatr.1103 test=sigfig(test,9,1) *d heatr.1107 test=sigfig(test,9,1) *d heatr.1110 test=sigfig(test,9,1) */ - correct a typo in getsix's legendre polynomial expansion. *d heatr.2958 f=f+(2*il+1)*c(6+il)*p(il+1)/2 */ - h6cm mods to mimic f6cm coding; yields better agreement for */ optimized versus unoptimized code. *d up188.9 save eps,xc,ndnow,npnow,ncnow,elmax,e,epmax,na *i heatr.3063 data small/1.d-10/ *i heatr.3074 data small/1.e-10/ *d heatr.3097,3098 if (epn.lt.epnn*(1-small)) epnn=epn if (epm.gt.epmax*(1+small)) epmax=epm *d heatr.3104 eps=tiny/elmax *d heatr.3112,3117 if (epn.lt.epnn*(1-small)) epnn=epn if (epn.gt.epmax*(1+small)) epmax=epn epx=dn*e*(sqrt(epn/e)-sqrt(xc))**2 if (epx.lt.epnext*(1-small)) epnext=epx epx=up*e*(sqrt(epn/e)+sqrt(xc))**2 if (epx.gt.elmax*(1+small)) elmax=epx *d heatr.3183 if (da.lt.eps) go to 290 *d heatr.3196 if (abs(yt(l)-ym).gt.l*tol*abs(ym)+eps) go to 260 *d heatr.3222,3224 if (epnxt.le.ep*(1+small)) epnxt=e*(sqrt(epnn/e)+sqrt(xc))**2 if (epnxt.le.ep*(1+small)) epnxt=onep5*ep if (epnxt.gt.elmax*(1+small).and.elmax.gt.ep*(1+small)) & epnxt=elmax */ - h6ddx mods to mimic f6ddx coding; yields better agreement for */ optimized versus unoptimized code. *i heatr.3285 common/projh/awrp,izap *i heatr.3292 data small/1.d-10/ *i heatr.3297 data small/1.e-10/ *d heatr.3323 if (ep.lt.efirst*(1-small)) go to 200 *d heatr.3349,3350 if (l.le.ncnow-1 + .and.ep.ge.cnow(inow)*(1-small) + .and.ep.le.cnow(mnow)*(1+small)) then *d heatr.3363 if (ep.ge.cnow(inow)*(1-small).and. & ep.le.cnow(mnow)*(1+small)) then *d heatr.3370 aa=bacha(izap,iza2,izat,enow,ep) */ - h6psp mods to mimic f6psp coding; yields better agreement for */ optimized versus unoptimized code. *i heatr.3636 data small/1.d-10/ *i heatr.3642 data small/1.e-10/ *d heatr.3651,3652 *d heatr.3677 if (ep.lt.eimax*(1-small)) s=cn*sqrt(ep)*(eimax-ep)**ex *d heatr.3680,3681 if (epnext.gt.eimax*(1+small)) epnext=rndup*eimax if (ep.ge.eimax*(1-small)) epnext=emax */ - include missing external error declaration */ (per upnea056, Trkov). *d heatr.5005 external tofend,tosend,tomend,closz,error *ident up313 */ groupr -- 04january2010 */ - prevent harmless array overflow in lanl 80-group coding(Yazid) */ - technically insignificant changes to selected groupr routines to */ be consistent with corresponding coding in heatr. */ - make un definition consistent with heatr. *d groupr.1798 if (ig.le.ng) u=u-u80(ig) *i groupr.5448 if (un.gt.u-tiny) un=u-tiny */ - clean up the harmless (so far) use of an uninitialized variable. *d groupr.5843 aa=bach(izap,iza2,izat,enow,epnext) */ - make eimax definition consistent with heatr. *d groupr.9374 if (eimax.le.zero) eimax=1 *ident up314 */ purr -- 08january2010 */ - increase maxscr and move test for maxscr space so it occurs */ earlier in purr execution (Roubtsov, AECL). *d up104.5 maxscr=20000 *i purr.177 maxtst=max(12+nsigz+nunr*(1+5*nsigz),12+(1+6*nbin)*nunr) if (maxtst.gt.maxscr) then write(strng1,'(''maxscr is too small, increase to at least '', & i7,'' words'')')maxtst call error('purr',strng1,' ') endif *d purr.333,334 *d purr.388,389 */ - technically insignificant code shift(neaup055, Trkov). *i purr.767 intunr=5 *d up293.44 *ident up315 */ reconr -- 13january2010 */ - allow processing of mt261 (IRDF related, per upnea025). *d reconr.1689 if ((mth.ge.251.and.mth.le.300).and.mth.ne.261) go to 150 */ - allow proper processing of IRDF files that only contain mf10 (by */ creating a dummy mf3, mt1 section to satisfy later modules). */ - this coding performs the same function as upnea063. *i reconr.385 common/projr/zain,awin *i reconr.427 if (iverf.lt.6) then zain=0 awin=0 endif *i reconr.4406 c ***set flag for presence of file 3 with incident neutrons. if c none found increment nxc since we'll insert a dummy mf3, mt1 c section into the output tape later. no3=0 if (nint(zain).eq.1) then do i=1,nxc if (nint(a(imfs+i-1)).eq.3)no3=1 enddo if (no3.eq.0) nxc=nxc+1 endif *d reconr.4473 nxcc=nxc if (nint(zain).eq.1.and.no3.eq.0) nxcc=nxcc-1 do i=1,nxcc *i reconr.4488 if (no3.eq.0.and.nint(zain).eq.1.and.nint(a(imfs+i-1)).gt.3) & then no3=-1 a(j+1)=0 a(j+2)=0 a(j+3)=3 a(j+4)=1 a(j+5)=4 a(j+6)=0 j=j+6 endif *d reconr.4557,4561 c c ***save current header variables. if this is not a file 3 c section, insert a dummy mf3, mt1 section. za=c1h awr=c2h lis=l1h lfs=l2h n1l=n1h n2l=n2h mfl=mfh mtl=mth if (nint(zain).eq.1.and.mfl.gt.3) then a(iscr+2)=0 a(iscr+3)=99 a(iscr+4)=0 a(iscr+5)=0 mfh=3 mth=1 call contio(0,nout,0,a(iscr),nb,nw) a(iscr)=tempr a(iscr+1)=0 a(iscr+2)=0 a(iscr+3)=0 a(iscr+4)=1 a(iscr+5)=2 a(iscr+6)=2 a(iscr+7)=2 a(iscr+8)=emin a(iscr+9)=0 a(iscr+10)=eresh a(iscr+11)=0 nw=12 call tab1io(0,nout,0,a(iscr),nb,nw) call asend(nout,0) call afend(nout,0) goto 270 endif *d reconr.4655,4656 a(iscr+4)=n1l a(iscr+5)=n2l mfh=mfl *ident up316 */ groupr -- 13january2010 */ - allow processing of mt261 (IRDF related, per upnea026). *i groupr.3967 if (mtd.eq.261) mt=261 */ - reset minimum to smin for consistency with other coding */ (per upnea029). *i groupr.4286 data smin/1.d-9/ *i groupr.4289 data smin/1.e-9/ *d groupr.4432 if (a(ised-1+ik+nk*(ig-1)).gt.smin) go to 280 *ident up317 */ acer -- 13january2010 */ - more IRDF related coding, per upnea027 (Trkov). */ - Implement enhancements that allow processing of dosimetry data */ including metastable nuclide excitation functions in MF10. */ Internally the ace MT numbers were extended according to the */ following convention: */ MT* = MT + 1000*(10+LFS) */ where LFS is the final state of the nuclide. *i acer.11525 c strip the leading digits from MT in dosimetry reactions if (i.gt.999) i=i-1000*(i/1000) *d acer.14319 c reserve all available space for scratch nwscr=-1 *d acer.14356,14357 c ***locate first reaction in file 3 or file 10 do while (mfh.ne.3 .and. mfh.ne.10) call tofend(nin,0,0,a(iscr)) call contio(nin,0,0,a(iscr),nb,nw) if (mfh.gt.10 .or. math.le.0) & call error('acedos','no xs data for desired mat.',' ') end do *d acer.14367 if(mfh.gt.3) go to 110 *d acer.14371 */ guard against array overflow *i acer.14380 if (jscr.gt.nwscr) & call error('acedos','array storage exceeded',' ') *i acer.14383 if (jscr.gt.nwscr) & call error('acedos','array storage exceeded',' ') *i acer.14409 call contio(nin,0,0,a(iscr),nb,nw) *i acer.14411 c ***locate first reaction in file 10 call contio(nin,0,0,a(iscr),nb,nw) if (mfh.gt.10 .or. math.le.0) goto 120 do while (mfh.ne.10) call tofend(nin,0,0,a(iscr)) call contio(nin,0,0,a(iscr),nb,nw) if (mfh.gt.10 .or. math.le.0) goto 120 end do 110 continue c ***loop over reactions on nin do while (mfh.ne.0) ns=max(1,n1h) xss(lsig-1+j)=l if (mfh.ne.0) then if (mth.ne.1) then do is=1,ns jscr=iscr call tab1io(nin,0,0,a(jscr),nb,nw) lfs=l2h xss(mtr-1+j)=mth+1000*(10+lfs) nr=nint(a(iscr+4)) ne=nint(a(iscr+5)) intr=nint(a(iscr+7)) jscr=jscr+nw if (jscr.gt.nwscr) & call error('acedos','array storage exceeded',' ') do while (nb.ne.0) call moreio(nin,0,0,a(jscr),nb,nw) jscr=jscr+nw if (jscr.gt.nwscr) & call error('acedos','array storage exceeded', & ' ') enddo if (nr.ne.1.or.intr.ne.2) then xss(l)=nr l=l+1 do i=1,nr xss(l+2*i-2)=a(iscr+4+2*i) xss(l+2*i-1)=a(iscr+5+2*i) enddo l=l+2*nr else xss(l)=0 l=l+1 endif xss(l)=ne k=iscr+6+2*nr l=l+1 do i=1,ne xss(l)=a(k)/emev xss(l+ne)=a(k+1) l=l+1 k=k+2 enddo l=l+ne j=j+1 enddo endif call tosend(nin,0,0,a(iscr)) call contio(nin,0,0,a(iscr),nb,nw) endif enddo 120 continue */ allow more digits for dosimetry mt's *d acer.14496 & '' reaction mt = '',i6,3x,a10/'' interpolation: '',12i6)') *d acer.14501 & '' reaction mt = '',i6,3x,a10/'' linear interpolation'')') *i acer.17540 else if (hz(10:10).eq.'y') then izai=1 awi=awit(1) *i acer.17619 else if (hz(10:10).eq.'y') then izai=1 awi=awit(1) *d acer.17692 else if (ht.eq.'d'.or.ht.eq.'y'.or. & (mcnpx.gt.0.and.ht(2:2).eq.'y')) then */ - add temperature to the ace file (previously always wrote 0). *i acer.14309 common/bkc/bk *d acer.14438 tz=temp*bk/emev *ident up318 */ acer -- 13january2010 */ - initialize selected arrays so data from the previous material */ doesn't corrupt output for the current material when acer is */ executed multiple times in the same job (upnea058, Trkov). *i acer.227 common/xsst/xss(5000000),n3 common/jxst/jxs(32) *i acer.260 n3=0 do i=1,max3 xss(i)=0 enddo do i=1,32 jxs(i)=0 enddo */ - never seem to have enough space (more requested by Trkov, */ upnea028, for IRDF processing and by Roubtsov for detailed */ zero degree files). *d up123.5 common/astore/a(750000) *d up123.7 data namax/750000/, nidmax/27/ *d up123.9 common/astore/a(750000) *d up123.11 common/astore/a(750000) *d up123.13 common/astore/a(750000) *d up123.15 common/astore/a(750000) *d up123.17 common/astore/a(750000) *d up123.19 common/astore/a(750000) *d up123.21 common/astore/a(750000) *d up123.23 common/astore/a(750000) *d up123.25 data namax/750000/ *d up123.27 common/astore/a(750000) *d up123.29 common/astore/a(750000) *d up123.31 common/astore/a(750000) *d up123.33 common/astore/a(750000) *d up123.35 common/astore/a(750000) *d up123.37 common/astore/a(750000) *d up123.39 common/astore/a(750000) *d up123.41 common/astore/a(750000) *d up108.51 max3=5000000 *d up108.53 common/xsst/xss(5000000),n3 *d up108.55 common/xsst/xss(5000000),n3 *d up108.57 common/xsst/xss(5000000),n3 *d up108.59 common/xsst/xss(5000000),n3 *d up108.61 common/xsst/xss(5000000),n3 *d up108.63 common/xsst/xss(5000000),n3 *d up108.65 common/xsst/xss(5000000),n3 *d up108.67 common/xsst/xss(5000000),n3 *d up108.69 common/xsst/xss(5000000),n3 *d up108.71 common/xsst/xss(5000000),n3 *d up108.73 common/xsst/xss(5000000),n3 *d up108.75 common/xsst/xss(5000000),n3 *d up108.77 common/xsst/xss(5000000),n3 *d up108.79 common/xsst/xss(5000000),n3 *d up108.81 common/xsst/xss(5000000),n3 *d up108.83 common/xsst/xss(5000000),n3 *d up108.85 common/xsst/xss(5000000),n3 *d up108.87 common/xsst/xss(5000000),n3 *d up108.89 common/xsst/xss(5000000),n3 *d up108.91 common/xsst/xss(5000000),n3 *d up108.93 common/xsst/xss(5000000),n3 *d up108.95 common/xsst/xss(5000000),n3 *d up108.97 common/xsst/xss(5000000),n3 *d up108.99 common/xsst/xss(5000000),n3 *d up108.101 common/xsst/xss(5000000),n3 *d up108.103 common/xsst/xss(5000000),n3 *d up108.105 common/xsst/xss(5000000),n3 *d up108.107 common/xsst/xss(5000000),n3 *d up108.109 common/xsst/xss(5000000),n3 *d up108.111 common/xsst/xss(5000000),n3 *d up108.113 common/xsst/xss(5000000),n3 *d up108.115 common/xsst/xss(5000000),n3 *d up108.117 common/xsst/xss(5000000),n3 *d up108.119 common/xsst/xss(5000000),n3 *d up108.121 common/xsst/xss(5000000),n3 *d up108.123 common/xsst/xss(5000000),n3 *d up108.125 common/xsst/xss(5000000),n3 *d up108.127 common/xsst/xss(5000000),n3 *d up108.129 common/xsst/xss(5000000),n3 *ident up319 */ acer - 11january2010 */ - acer's iopp=0 coding is incomplete. fix it here (buchan) *d acer.666 if (mfd.eq.12.and.iopp.ne.0) mf1x(1)=mf1x(1)+1 *d acer.673,674 if (mfd.eq.13.and.iopp.ne.0) mf1x(2)=mf1x(2)+1 if (mfd.eq.15.and.iopp.ne.0) mf1x(3)=mf1x(3)+1 *d up153.8 if (iopp.ne.0.and. & ((mfd.eq.12.and.mtd.ne.460).or.(mfd.eq.13))) then *d acer.776 *d acer.3505 if (mf1x(1).eq.0.and.iopp.ne.0) write(nsyso, *ident up320 */ matxsr - 27january2010 */ - revise an if test to eliminate possible attempt to use an */ undefined variable (kornreich, lanl). *d matxsr.2222 if ((nl+1).gt.lord1) lord1=nl+1 *ident up321 */ errorj - 03february2010 */ - patch group structure array index error (same as done for */ groupr in up313. *d errorj.2526 if (ig.le.ng) u=u-u80(ig) *ident up322 */ acer - 03february2010 */ - various patches for photonuclear processing, to stay in */ synch with 2009 coding following test jobs with TENDL-2009 */ incident photon files. *d acer.15255 nwscr=50000 *i acer.16339 if (jscr.gt.nwscr) call error('acephn', & 'a array overflow in file 6 tab1',' ') *i acer.16342 if (jscr.gt.nwscr) call error('acephn', & 'a array overflow in file 6 tab1',' ') *i acer.16362 lang=nint(a(ll+2)) *i acer.16387 if (ll.gt.nwscr) call error('acephn', & 'a array overflow in file 6 list',' ') *i acer.16390 if (ll.gt.nwscr) call error('acephn', & 'a array overflow in file 6 list',' ') *d acer.16404 if (lang.eq.1) then *d acer.16410,16414 xss(nex)=lep+10*nd *d acer.16424,16434 if (ig.le.nd) then xss(nex+1+ig+ng)= & sigfig(a(lld+7+ncyc*(ig-1)),7,0) else xss(nex+1+ig+ng)= & sigfig(a(lld+7+ncyc*(ig-1))*emev, & 7,0) endif if (xss(nex+1+ig+ng).gt.zero.and. & xss(nex+1+ig+ng).lt.small) & xss(nex+1+ig+ng)=small if (ig.eq.1)then if (nd.eq.0) then xss(nex+1+ig+2*ng)=0 else xss(nex+1+ig+2*ng)= & a(lld+7+ncyc*(ig-1)) endif elseif (ig.le.nd) then xss(nex+1+ig+2*ng)= & xss(nex+ig+2*ng)+ & a(lld+7+ncyc*(ig-1)) elseif (ig.eq.nd+1) then xss(nex+1+ig+2*ng)=xss(nex+ig+2*ng) endif *d acer.16446 if (lang.eq.2) then *d acer.16456 if (lang.ne.2.or.na.eq.0) then *d acer.16941 intt=mod(nint(xss(loci)),10) nd=nint(xss(loci)/10) *i acer.22440 if (zmax.eq.0) go to 100 *i acer.22537 100 continue *ident up323 */ acer - 11february2010 */ - add moreio following tab1io in acensd to make sure we read */ all of these data; */ - fix index typo when plotting emission spectra with multiple */ interpolation ranges (Trkov). *i acer.5624 ll=iscr+nw do while (nb.ne.0) call moreio(nin,0,0,a(ll),nb,nw) ll=ll+nw enddo *d acer.20362 if (j.ne.0) l=l+2*j *ident up324 */ errorr - 17february2010; adapted from upnea062 by Andre Trkov. */ - Add MF40 processing capability */ NOTE: When running with mfcov=40 the User must input a groupr */ generated gendf file created with mfd=10. This coding */ has been tested for a single LFS state in MF10 and a */ single covariance set for that state in MF40. */ NOTE: The Fall, 2009 CSEWG meeting accepted a format change */ to include IZAP in the L1 location of the CONT record */ initiating an MF40 subsection. This coding assumes that */ endf formatted input files have been corrected, and will */ warn the user when reading an izap value of zero. Files */ with izap=0 and non-zero LFS values will likely not be */ processed. */ - Write -14 in the errorj output tape header record as a flag */ for subsequent modules that this tape contains mf40 data; */ - Change of convention in GENDF files generated by ERRORR; */ originally the C1 and C2 records were zero but for consistency */ with GENDF files produced by groupr, C1 is now set to ZA and */ C2 is either set to zero or when processing MF40 is set to */ 10*ZA+LFS. We also include temperature in the C1 location of */ the second mf1, mt451 record as done by GROUPR. */ - Make sure matrix elements are zero in groups where the cross */ section is zero. */ *d errorj.81,84 c * (if iread eq 2 or if mfcov eq 31, 35 or 40 (see * c * card 7), then ngout cannot be zero) * *d errorj.122 c * mfcov endf covariance file (31, 33, 34, 35 or 40) to be * *d errorj.393,400 if (ngout.eq.0.and. & (mfcov.eq.31.or.mfcov.eq.35.or.mfcov.eq.40)) then write(strng,'('' ngout must be nonzero when mfcov = '',i2)') & mfcov call error('errorr',strng,' ') endif *i up272.28 & ,mzap(80),lfs *i up272.37 & ,mzap(80),lfs *i up272.50 & ,mzap(80),lfs *i up272.69 & ,mzap(80),lfs *i up272.73 & ,mzap(80),lfs *i up272.102 & ,mzap(80),lfs *i up272.108 & ,mzap(80),lfs *i up272.110 & ,mzap(80),lfs common/temper/tempin *i up272.141 & ,mzap(80),lfs *i up272.178 & ,mzap(80),lfs *i up272.181 & ,mzap(80),lfs *i up272.185 & ,mzap(80),lfs *i up272.187 & ,mzap(80),lfs *i up272.189 & ,mzap(80),lfs *i up272.191 & ,mzap(80),lfs *i up272.193 & ,mzap(80),lfs *i up272.216 & ,mzap(80),lfs *i up272.222 & ,mzap(80),lfs *i up272.230 & ,mzap(80),lfs *i up272.236 & ,mzap(80),lfs *d errorj.424,425 if (mfcov.ne.31.and.mfcov.ne.33.and. & mfcov.ne.34.and.mfcov.ne.35.and. & mfcov.ne.40) then *i errorj.620 c c ***check dictionary for required files icov=0 do i=1,nx mfi=nint(a(idict+2+(i-1)*6)) if (mfcov.eq.30.and.(mfi.ge.30 .and. mfi.le.33)) icov=icov+1 if (mfcov.eq.31.and.mfi.eq.31) icov=icov+1 if (mfcov.eq.32.and.mfi.eq.32) icov=icov+1 if (mfcov.eq.33.and.(mfi.eq.32.or.mfi.eq.33)) icov=icov+1 if (mfcov.eq.34.and.mfi.eq.34) icov=icov+1 if (mfcov.eq.35.and.mfi.eq.35) icov=icov+1 if (mfcov.eq.40.and.mfi.eq.40) icov=icov+1 enddo if (icov.eq.0) then write(strng,'(''no data on file for mfcov='',i3)') mfcov call mess('errorr',strng,'processing terminated') c ***skip remaining errorr input (if any) if (ign.eq.1.or.ign.eq.19) then read(nsysi,*) ng ngp=ng+1 read(nsysi,*) (dmy,i=1,ngp) endif go to 330 endif *i errorj.685 330 continue *d up260.25 external error,mess *d errorj.729 character*70 strng,strng2 *i errorj.816 if (iverf.eq.4) then nl=l2h elseif (iverf.gt.4) then nl=n2h endif izap=0 *d errorj.821,824 elseif (mfcov.eq.40) then za=c1h awr=c2h nl=n1h call contio(nendf,0,0,a(iscr),nb,nw) if (l1h.eq.0) then write(strng,'(''WARNING! izap=0 for mf40, mt'',i3, & '' is nonstandard'')')mt if (l2h.eq.0) then write(strng2,'(''if produced, covr plot title will '', & ''be ambiguous'')') call mess('covcal',strng,strng2) else write(strng2,'(''covcal may skip this mt, or covr '', & ''plot title will be ambiguous'')') call mess('covcal',strng,strng2) endif endif izap=10*l1h+l2h *i errorj.1490 elseif (mfcov.eq.40) then call sigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx),a(isig)) *i errorj.1566 izap=mzap(ix) *d errorj.1576 if (mfcov.ne.40) then a(iscr+1)=0 else a(iscr+1)=izap endif *d errorj.1590 if (mfcov.ne.40) then a(iscr+1)=0. else a(iscr+1)=izap endif *d errorj.1873 if (mfcov.eq.31.or.mfcov.eq.33.or.mfcov.eq.35.or. & mfcov.eq.40) then *i errorj.1875 if (mfcov.eq.40) write(nsyso,38)lfs c... if (mfcov.eq.40) write(nsyso,38)lfs/10,lfs-10*(lfs/10) *i errorj.2126 38 format(' final metastable state lfs',i3/) c..38 format(' final metastable state zap,lfs',i6,i3/) *i errorj.3160 if (mfcov.eq.40) b(5)=-14 *d errorj.3791 izap=0 *i errorj.3793 nfs=1 *i errorj.3795 nfs=1 if (mfcov.eq.40) then za=c1h nfs=n1h nsub=1 call contio(nendf,0,0,a(iscr),nb,nw) lfs=l2h izap=10*l1h+l2h endif *i errorj.3815 mzap(nmt)=izap *i errorj.3831 do 310 ilfs=1,nfs *i errorj.3978 310 continue */ */ search gout tape by product identifier *i errorj.734 izero=0 *d errorj.752 call rdgout(ngout,matd,mfd,mtd,izero,a(ib),a(iegt)) *d errorj.784 call rdgout(ngout,matd,mfd,mtd,izero,a(ib),a(iflx)) *d errorj.786 call rdsig(matd,izero,izero,a(ib),a(iscr)) *d errorj.874 call rdsig(mat,mt,izap,a(ib),a(isig)) *d errorj.986 if (mt1.lt.851) call rdsig(mat1,mt1,izero,a(ib),a(isig1)) *d errorj.2985 subroutine rdgout(ngout,matd,mfd,mti,izap,b,sig) *i errorj.3076 jzap=0 if (izap.ne.0) jzap=nint(c2h) *d errorj.3078 if (mf.eq.mfd.and.mt.eq.mtd.and.jzap.eq.izap) go to 230 *i errorj.3142 izero=0 *d errorj.3220 call rdsig(mats(ix),mtd,izero,b,a(isg)) *d errorj.3226 250 call rdsig(mats(ix),mts(ix),mzap(ix),b,sig) *d errorj.3243,3244 b(1)=za b(2)=mzap(ix) *i errorj.5217 izero=0 *d errorj.5246 call rdsig(matd,mtd,izero,a(ib),a(iscr2)) *d errorj.5320 subroutine rdsig(mat,mt,izap,b,sig) *i errorj.5329 izero=0 *d errorj.5342 call rdgout(ngout,matrd,mfri,mtri,izero,b,sig) *d errorj.5345 call rdgout(ngout,matrd,mfrd,mtrd,izap,b,sig) *i errorj.7604 izero=0 *d errorj.7617 200 call rdsig(matd,mt1,izero,b,sig) *d errorj.7628 call rdsig(matd,mt2,izero,b,sig) *i errorj.7782 izero=0 *d errorj.7841 call rdsig(mat,mt,izero,b,sig) */ */ add temperature to the output tape (also za to mt251) *i errorj.3134 common/temper/tempin *d errorj.3163 b(1)=tempin *i errorj.3520 tempin=c1h *i errorj.7775 common/temper/tempin *d errorj.7796 b(1)=tempin *d errorj.7863 b(1)=za *i errorj.8113 common/temper/tempin *d errorj.8133 b(1)=tempin */ */ prevent printing "undefined" cross sections and covariances *d errorj.1921 */ *i errorj.1922,1924 *d errorj.1923,1924 if (denom.gt.zero) then denom=max(denom,eps) a(iscr+ibase+ip-1)=a(iscr+ibase+ip-1)/denom* & (egn(ig+1)-egn(ig))*(egn(igp+1)-egn(igp)) else a(iscr+ibase+ip-1)=0 endif *d errorj.1926 if (denom.gt.zero) then denom=max(denom,eps) a(iscr+ibase+ip-1)=a(iscr+ibase+ip-1)/denom else a(iscr+ibase+ip-1)=0 endif *d errorj.3235 ff=cflx(ig) if (ff.gt.0) then csig(ig,ix)=csig(ig,ix)/ff else csig(ig,ix)=0 endif *ident up325 */ acer - 18february2010 */ - make sure mtcomp is initialized when processing charged */ particle files; */ - correct selected if tests to properly distinguish between */ incident neutron and incident charged particle files. also */ correct some mt lists within these tests (Sauvan, Spain). *i acer.1348 mtcomp=0 *d acer.1351 *d acer.1904 if (mt.eq.3.or.(mt.eq.4.and.izai.eq.1)) then *d up87.10,acer.4786 if (mt.eq.5.or.mt.eq.11.or.mt.eq.32.or.mt.eq.35.or. & mt.eq.104.or.mt.eq.114.or.mt.eq.115.or.mt.eq.117.or. *d acer.4827,4828 & mt.eq.112.or.mt.eq.113.or.mt.eq.114.or.mt.eq.117.or. *d acer.5018 if (mth.eq.4.and.izai.eq.1) keep4=1 *d acer.5025 *d acer.5032 & mt.eq.104.or.mt.eq.114.or.mt.eq.115.or.mt.eq.117.or. *d acer.5049,5050 & mt.eq.112.or.mt.eq.113.or.mt.eq.114.or.mt.eq.117.or. *d acer.5131 *d up87.36 if (mt.eq.2.or.mt.eq.5.or.mt.eq.11.or. & mt.eq.32.or.mt.eq.35.or. *d acer.5138 & mt.eq.104.or.mt.eq.114.or.mt.eq.115.or.mt.eq.117.or. *d acer.5155,5156 & mt.eq.112.or.mt.eq.113.or.mt.eq.114.or.mt.eq.117.or. *i acer.11387 common/ace7/awi,izai,mcnpx,newfor *i acer.11568 c c ***alternate name when processing incident charged particle files if (izai.gt.1) then if (mt.eq.4) then name='(z,n) ' elseif ((izai.eq.1001.and.mt.eq.103).or. + (izai.eq.1002.and.mt.eq.104).or. + (izai.eq.1003.and.mt.eq.105).or. + (izai.eq.2003.and.mt.eq.106).or. + (izai.eq.2004.and.mt.eq.107)) then name=hndf(4) endif endif c *ident up326 */ broadr -- 18february2010 */ minor change in broadn to avoid attempts to broaden a zero */ cross section (not relevant with incident neutron files but */ can be an issue with incident charged particle files). *i broadr.1153 if (stot.lt.errmin)go to 145 *ident up327 */ acer -- 18february2010 */ - pass both endf and pendf tape identifiers to unionx and change */ file 6 related processing to search through the endf tape when */ processing incident charged particle files. */ - insert new mess in acelcp for file 6 law=0 data. *d acer.500 call unionx(nendf,npend,mscr,matd,nedis,nethr,a) *d acer.1264 subroutine unionx(nendf,nin,nout,matd,nedis,nethr,a) *i acer.1815 nins=nin nin=nendf *i acer.1893 nin=nins *i acer.8046 character*60 strng *i acer.9717 else if (law.eq.0) then write(strng,'(''no heating info for recoil '', & ''particle '',i5)')izap call mess('acelcp',strng,' ') *ident up328 */ covr -- 23february2010 */ - update to recognize and plot errorj output tapes containing */ mf40 data (initial mf40 processing by errorj was introduced */ in up324). */ WARNING: It is possible for ERRORJ to process MF40 data */ with IZAP undefined. In such instances plot files */ produced by COVR will include the text string ", MF40" */ so they may be distinguished from plot files produced */ from processing MF33 data. If IZAP .ne. 0 then its */ value will appear in the plot title. The presence */ this numeric label indicates these are MF40 data. *d up273.41 common/covmf/mfflg,mf3,mf5,mf35 *d up273.89 common/covmf/mfflg,mf3,mf5,mf35 *d up273.95 common/covmf/mfflg,mf3,mf5,mf35 *d up273.120 common/covmf/mfflg,mf3,mf5,mf35 *d up273.324 common/covmf/mfflg,mf3,mf5,mf35 *d covr.311 call corr(nscr,mat,mt,mat1,mt1,izap,a) *d covr.356 & a(irxn),a(iryn),a(ixlev),noleg,ne,izap,a) *d covr.515 subroutine corr(nin,mat,mt,mat1,mt1,izap,a) *d covr.549 call covard(nin,mat,mt,mat1,mt1,izap,icall,a) *d covr.552 110 call covard(nin,mat1,mt1,mat1,mt1,izap,icall,a) *d covr.594 call covard(nin,mat,mt,mat,mt,izap,icall,a) *d covr.607 call covard(nin,mat,mt,mat1,mt1,izap,icall,a) *d covr.653 subroutine covard(nin,mat,mt,mat1,mt1,izap,icall,a) *d up273.70 mfflg=nint(a(iscr+4)) if (mfflg.eq.-11.or.mfflg.eq.-14) then *d covr.668 character*60 strng,strng2 *i up273.101 if (mfflg.eq.-14) mf3x=40 *d covr.765,767 write(strng,'(''did not find file '',i2,'' subsection'')')mf3x write(strng2,'(''for mt='',i3,'' mat='',i4)') mt1,mat1 call error('covard',strng,strng2) endif izap=0 if (mfflg.eq.-14) then if (mat.eq.mat1.and.mt.eq.mt1) then izap=nint(c2h) endif endif *d covr.912 & xlev,noleg,ne,izap,a) *d up273.179 call smilab(iza,mat,mt,izap,mtflg,strng) *d up273.248 call smilab(iza1,mat1,mt1,izap,0,strng) *d up273.322 subroutine smilab(iza,mat,mt,izap,mtflg,strng) *d up283.19 character str1*14,str2*35,str3*40,str4*16 *d covr.1422 external matmes,mess *d covr.1430 call matmes(iza,mat,mt,str3,lstr3) *d up273.364 if (mfflg.ne.-14) then strng=str1(1:l1)//str2(1:l2)//str3(1:lstr3) elseif (mfflg.eq.-14.and.izap.eq.0) then strng=str1(1:l1)//str2(1:l2)//str3(1:lstr3)//', MF40' else write(str4,'('', izap = '',i7)')izap strng=str1(1:l1)//str2(1:l2)//str3(1:lstr3)//str4 endif *d covr.1435 subroutine matmes(iza,mat,mt,strng,lstrng) *i covr.1478 lstrng=nmat+inamel+nnam *ident up329 */ errorj -- 24february2010 */ - implement scattering radius uncertainty (a modification of */ upnea048 which was based upon coding developed by G.Chiba and */ adapted by D.Rochman and A.Hogenbirk). */ - includes coding to read scattering radius uncertainty data */ from the endf-formatted input file for the isr=1 format */ revision accepted at the Fall 2009 CSEWG meeting. The */ default condition is for no user input of this quantity. */ - expand user input to allow a single value for the scattering */ radius uncertainty to be specified. If done it will override */ the data (if any) that would have come from the endf tape. *i up282.44 c * dap user specified scattering radius uncertainty, given * c * as a fraction (i.e., dap=0.1 means 10% uncertainty * c * in the scattering radius). The default value is * c * zero. This variable is only defined for mfcov=33 * c * and if non-zero will be used in lieu of any data * c * that might have been read from the nendf tape. * *i errorj.248 common/reson3/dap,dap3(5),isr,isru *d up282.59 isru=0 dap=0 read(nsysi,*)iread,mfcov,irespr,legord,ifissp,efmean,dap *i errorj.391 if (mfcov.eq.33.and.dap.ne.0) isru=1 *d up282.174 if (mfcov.eq.33) write(nsyso,'(" irespr ",31("."),i11)')irespr if (isru.ne.0) write(nsyso,'( " user dap ",29("."),f11.3)')dap *i errorj.5814 common/reson3/dap,dap3(5),isr,isru *d up287.12 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl,nlspei(20) *i errorj.5829 indx=0 *i errorj.5893 indx=indx+1 *d errorj.5938 nls=nlspei(indx) isr=n2h if (isr.eq.1) then jscr=iscr+6 if (lrf.eq.1.or.lrf.eq.2) then call contio(nendf,0,0,a(jscr),nb,nw) if (isru.eq.0) then dap=a(jscr+1) else dap=ap*dap endif do i=1,nls dap3(i)=dap enddo elseif (lrf.eq.3) then call listio(nendf,0,0,a(jscr),nb,nw) if (isru.eq.0) then mls=nint(a(jscr+4)) dap=a(jscr+6) else mls=1 dap=ap*dap endif if (mls.eq.1) then do i=1,nls dap3(i)=dap enddo elseif (mls.gt.1.and.mls.eq.nls+1) then do i=1,nls dap3(i)=a(jscr+6+i) enddo elseif (mls.gt.1.and.mls.lt.nls+1) then do i=1,mls-1 dap3(i)=a(jscr+6+i) enddo do i=mls,nls dap3(i)=dap enddo else write(strng1,'(''mls='',i1,'', nls='',i1, & ''are inconsistent'')')mls,nls write(strng2,'(''will ignore scattering '', & ''radius uncertainty'')') call mess('resprx',strng1,strng2) isr=0 dap=0 endif else write(strng1,'(''not ready for isr=1, lrf='',i1)')lrf call error('resprx',strng1,' ') endif elseif (isr.eq.0.and.isru.ne.0) then isr=1 dap=ap*dap if (nls.gt.0) then do i=1,nls dap3(i)=dap enddo endif elseif (isr.ne.0) then call error('resprx','illegal isr',' ') endif if (isr.ne.0.and.isru.ne.0) then write(strng1,'(''user override for scattering radius '', & ''uncertainty'')') write(strng2,'(''use DAP ='',f6.3,''*AP for all L'')') & dap/ap call mess('resprx',strng1,strng2) endif *d up260.56 external error,mess *i errorj.5971 common/reson3/dap,dap3(5),isr,isru *d up287.14 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl,nlspei(20) *i errorj.5993 if (isr.ne.0) then write(strng1,'(''lcomp=0, scattering radius uncertainty is '', & ''not included'')') call mess('resprx_rrr_lcomp0',strng1,' ') endif c *d up260.58 external error,mess *i errorj.6343 common/reson3/dap,dap3(5),isr,isru *d up287.16 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl,nlspei(20) *i errorj.6360 dimension pneorg(10000) *i errorj.6365 imess=0 *i errorj.6491 c c ***Check for scattering radius uncertainty. c If so, perform unperturbed and radius perturbed calcs c and develop sensitivity coefficients. if (isr.eq.0.and.imess.eq.0) then imess=1 write(strng1,'(''no scattering radius uncertainty'')') call mess('resprx_rrr_lcomp12',strng1,' ') elseif (isr.eq.1.and.imess.eq.0) then imess=1 write(strng1,'(''include scattering radius uncertainty'')') call mess('resprx_rrr_lcomp12',strng1,' ') endif if (isr.eq.1) then c c ***reference (no perturbation) call resprx_cal_pendf(ii,99,0.d0,a,sigr,-1.d0,b,maxb) c ***perturbated system c - perturbation of scattering radius from mf=2 c - perturbation of penetration factor inow=1 ap=b(inow+7) ap=ap+dap b(inow+7)=ap nls=nint(b(inow+10)) inow=inow+12 itmp=1 do lll=1,nls apl=b(inow+1) if (apl.eq.0) then apl=ap else apl=apl+dap3(lll) endif b(inow+1)=apl ll=nint(b(inow+2)) nrs=nint(b(inow+5)) inow=inow+6 do jj=1,nrs rho=cwaven*arat*sqrt(abs(b(inow+6*(jj-1))))*apl call facts(ll,rho,ser,per) pneorg(itmp)=b(inow+6*nrs+3*(jj-1)) pneorg(itmp+1)=b(inow+6*nrs+3*(jj-1)+1) itmp=itmp+2 b(inow+6*nrs+3*(jj-1))=ser b(inow+6*nrs+3*(jj-1)+1)=per enddo inow=inow+6*nrs+3*nrs enddo call resprx_cal_pendf(ii,99,0.d0,a,sigp,-1.d0,b,maxb) c c ***sensitivity calculation do ii1=1,4 do ii2=1,ii tmp=((sigp(ii2,ii1)-sigr(ii2,ii1)))/dap sigp(ii2,ii1)=tmp enddo enddo call Resprx_grping(ngn,egn,sigp,ii,gsig(1,1),a) do ii1=1,ngn tmp=a(icflx-1+ii1)*abn do j=1,4 gsig(j,ii1)=gsig(j,ii1)*tmp enddo enddo c c ***to get absolute standard deviation for scattering radius dap2=dap*dap c c ***error propagation igind=0 do ig=1,ngn do ig2=ig,ngn igind=igind+1 itmp1=icff+igind-1 itmp2=icgg+igind-1 itmp3=icee+igind-1 itmp4=ictt+igind-1 a(itmp1)=a(itmp1)+dap2*gsig(3,ig)*gsig(3,ig2) a(itmp2)=a(itmp2)+dap2*gsig(4,ig)*gsig(4,ig2) a(itmp3)=a(itmp3)+dap2*gsig(2,ig)*gsig(2,ig2) a(itmp4)=a(itmp4)+dap2*gsig(1,ig)*gsig(1,ig2) enddo enddo c igind=0 do ig=1,ngn do ig2=1,ngn igind=igind+1 itmp1=icef+igind-1 itmp2=iceg+igind-1 itmp3=icfg+igind-1 a(itmp1)=a(itmp1)+dap2*gsig(2,ig)*gsig(3,ig2) a(itmp2)=a(itmp2)+dap2*gsig(2,ig)*gsig(4,ig2) a(itmp3)=a(itmp3)+dap2*gsig(3,ig)*gsig(4,ig2) enddo enddo c c ***restore reference data inow=1 ap=b(inow+7) ap=ap-dap b(inow+7)=ap nls=nint(b(inow+10)) itmp=1 inow=inow+12 do lll=1,nls apl=b(inow+1) apl=apl/(1+dap3(lll)) b(inow+1)=apl nrs=nint(b(inow+5)) inow=inow+6 do jj=1,nrs b(inow+6*nrs+3*(jj-1))=pneorg(itmp) b(inow+6*nrs+3*(jj-1)+1)=pneorg(itmp+1) itmp=itmp+2 enddo inow=inow+6*nrs+3*nrs enddo c ***end of scattering radius uncertainty treatment endif *d up287.18 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl,nlspei(20) *d up287.20 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl,nlspei(20) *d up287.22 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl,nlspei(20) *i errorj.7140 common /Resprxxz/ abn,eh,el,ehg,elg,spi,ral,apl,nlspei(20) *i errorj.7149 indx=0 *i errorj.7158 indx=indx+1 *i errorj.7168 nlspei(indx)=nls *i errorj.7180 nlspei(indx)=nls *i errorj.7192 nlspei(indx)=nls *i errorj.7206 nlspei(indx)=nls *i errorj.7224 nlspei(indx)=nls */ *d errorj.8345 if((abs(ajc-valspi).gt.0.01.or.l.ne.npnls).and. & npnls.ne.99) then *ident up330 */ gaspr -- 08march2010 */ - an eternal request; need more space! (Haicheng Wu, CNDC) *d up101.6 dimension egas(100000),sgas(5,100000) *d up101.8 maxg=100000 *ident up331 */ unresr -- 08march2010 */ - an eternal request; need more space! (Haicheng Wu, CNDC) */ we do it with a parameter statement to make it easier to */ increase in the future. *i unresr.798 parameter (mxks=100) *d unresr.803,804 dimension abns(mxks),tj(mxks,10,3),tk(mxks,10,3), & tl(3*mxks+1,10,3),del(3),sigm(10),t(4,10,3),yy(3),gg(5),temp(3) *d unresr.933 if (ks.gt.mxks) call error('unresl', & 'storage exceeded, increase mxks',' ') *ident up332 */ purr -- 08march2010 */ - an eternal request; need more space! (Haicheng Wu, CNDC) */ we do it with a parameter statement to make it easier to */ increase in the future. *i purr.1097 parameter (mxns0=100) *d up5.11,up5.13 common/sigcon/e,t,cth(mxns0),csz(mxns0),cc2p(mxns0),cs2p(mxns0), & cgn(mxns0),cgg(mxns0),cgf(mxns0),cgx(mxns0),cgt(mxns0), & dbar(mxns0),spot,dbarin,sigi(4),ndfn(mxns0),ndff(mxns0), & ndfx(mxns0),nseq0 *d up5.17,purr.1248 if (nseq0.gt.mxns0) call error('unresx', & 'too many sequences, increase mxns0',' ') *i purr.1496 parameter (mxns0=100) *d up5.19,up5.21 common/sigcon/e,t,cth(mxns0),csz(mxns0),cc2p(mxns0),cs2p(mxns0), & cgn(mxns0),cgg(mxns0),cgf(mxns0),cgx(mxns0),cgt(mxns0), & dbar(mxns0),spot,dbarin,sigi(4),ndfn(mxns0),ndff(mxns0), & ndfx(mxns0),nseqz *i purr.1617 parameter (mxns0=100) *d up5.23,up5.25 common/sigcon/e,t,cth(mxns0),csz(mxns0),cc2p(mxns0),cs2p(mxns0), & cgn(mxns0),cgg(mxns0),cgf(mxns0),cgx(mxns0),cgt(mxns0), & dbar(mxns0),spot,dbarin,sigi(4),ndfn(mxns0),ndff(mxns0), & ndfx(mxns0),nseqz *i purr.1728 parameter (mxns0=100) *d up5.27,up5.29 common/sigcon/e,t,cth(mxns0),csz(mxns0),cc2p(mxns0),cs2p(mxns0), & cgn(mxns0),cgg(mxns0),cgf(mxns0),cgx(mxns0),cgt(mxns0), & dbar(mxns0),spot,dbarin,sigi(4),ndfn(mxns0),ndff(mxns0), & ndfx(mxns0),nseq0 *ident up333 */ groupr -- 08march2010 */ - fix a long-standing typo in the 36/38-group gamma structure */ (identified by Haicheng Wu, CNDC); */ - restrict ismooth usage as done in njoy2009 (rem). *d groupr.1951 & .20d0,.30d0,.40d0,.45d0,.51d0,.512d0,.60d0,.70d0,.80d0,1.0d0, *d groupr.1989 & .20e0,.30e0,.40e0,.45e0,.51e0,.512e0,.60e0,.70e0,.80e0,1.0e0, *d up257.132 if (ismooth.gt.0.and.lep.eq.1.and.jzap.eq.1) then *ident up334 */ matxsr -- 11march2010 */ - revise logic to force 255Fm (z=100) into a z=99 category (rem). */ - update thermal names to endf/b-vii conventions (note that */ names will be slightly wrong if running with earlier endf/b */ versions, but users can correct them by hand in the text */ matxs file, rem). *d matxsr.1003 if (htype(i).eq.hgsct) then imat=matgg(im) if (hmatn(im)(1:2).eq.'fm') imat=9920 endif *d matxsr.1292 character*6 h4(26) *d matxsr.1312,1315 data num4/246/ data h4/'free','hh2o','poly','poly$','hzrh','hzrh$', & 'benz','dd2o','graph','graph$','be','be$','bebeo','bebeo$', & 'zrzrh','zrzrh$','obeo','obeo$','ouo2','ouo2$', & 'uuo2','uuo2$','al','al$','fe','fe$'/ *ident up335 */ dtfr -- 30march2010 */ - long ago (up24) we increased the group limit to 400 but groupr */ allows many more. Increase some dtfr limits (Parsons, LANL) to */ handle these larger group structures. *d up24.5 common/dgrpn/egn(2501),ngn *d up24.7 common/dstore/a(40000),sig(500000) *d up24.9,up24.10 dimension spect(2501) dimension fcap(2501),ffis(2501) *d up24.12 data nwamax/40000/, nwsmax/500000/ *d up24.14 common/dgrpn/egn(2501),ngn *d up24.16 common/dstore/x(7000),y(7000),z(2000),a(524000) *d dtfr.950 ndim=7000 *d up24.18 common/dgrpn/egn(2501),ngn *d up24.20 common/dgrpn/egn(2501),ngn *ident up336 */ errorj -- 31march2010 */ - per Go Chiba, make the point xs calculation in resprx_cal_pendf */ more sensitive to the underlying multigroup structure. *d errorj.251 common/irspd/eskip1,eskip2,eskip3,eskip4 *i errorj.403 eskip4=1.05 *i errorj.2179 common/irspd/eskip1,eskip2,eskip3,eskip4 *i errorj.2633 c ewmin=1.05 do ig=1,ng if (eg(ig+1).lt.0.1) then ew=eg(ig+1)/eg(ig) if (ew.lt.ewmin) ewmin=ew endif enddo eskip4=ewmin*0.99 *d errorj.7074 common/irspd/eskip1,eskip2,eskip3,eskip4 *d up290.52 e2=eskip4 *ident up337 */ acer -- 8june2010 */ - always seem to need more space somewhere for something, this */ for jendl/actinoid2008 235U (and others), when plotting */ urr results. *d up295.7 dimension ee(1000),s0(1000),s1(1000),s2(1000) *ident up338 */ reconr -- 7july2010 */ - jendl-4.0 contains evaluations that do not have RR data, do */ have URR data and have LSSF=1. We've not encountered this */ combination before and the emerge routine aborts trying to */ find non-existent RR data. This patch sets nrtot=0 in resxs */ under these conditions and emerge then runs correctly. *i reconr.2009 common/recon2/lfw,mata,itype,lrp,lfi,lssf *i reconr.2028 c c ***if urr region only and lssf=1, set nrtot=0 & return if (lssf.eq.1.and.eresl.eq.eresu) then nrtot=0 return endif *ident up339 */ groupr --12july2010 */ - LFS values from file 8 have always been less than 10, and so */ are saved by conver as the units digit in a packed integer. */ This doesn't work for some recent TENDL files with LFS values */ of 10 or more. We'll simply define a separate array for these */ data and avoid future packing problems. *d groupr.245 & mf4r(6,50),mf6p(6,50),mf10f(200),mf10s(200),mf10i(200), & lfs8(200) *d groupr.867 & mf4r(6,50),mf6p(6,50),mf10f(200),mf10s(200),mf10i(200), & lfs8(200) *d groupr.1206 & mf4r(6,50),mf6p(6,50),mf10f(200),mf10s(200),mf10i(200), & lfs8(200) *d groupr.1256 & mf4r(6,50),mf6p(6,50),mf10f(200),mf10s(200),mf10i(200), & lfs8(200) *d groupr.7934 & mf4r(6,50),mf6p(6,50),mf10f(200),mf10s(200),mf10i(200), & lfs8(200) *i groupr.238 common/argcom1/lfs *i groupr.485 lfs=0 *d groupr.488 call nextr(iauto,matd,mfd,mtdp,lfs,a(iscr)) *d groupr.490 if (mfd.gt.10000000) then if (lfs.lt.10) then izam=mod(mfd,10000000)+lfs else izam=10*mod(mfd,10000000)+lfs endif endif *d groupr.514 call nextr(iauto,matd,mfd,mtdp,lfs,a(iscr)) *d up65.8 if (mfd.gt.10000000) then if (lfs.lt.10) then izam=mod(mfd,10000000)+lfs else izam=10*mod(mfd,10000000)+lfs endif endif *d groupr.527 if (lfs.lt.10) then izam=mod(mfd,10000000)+lfs else izam=10*mod(mfd,10000000)+lfs endif *d up65.17 if (lfs.lt.10) then jzam=mod(mfd,10000000)+lfs else jzam=10*mod(mfd,10000000)+lfs endif *d groupr.856 subroutine nextr(iauto,matd,mfd,mtd,lfs,a) *i up65.41 lfs=lfs8(ir) *i groupr.995 lfs=lfs8(ir) *i groupr.1024 common/argcom1/lfs *d groupr.1032 character*8 azam *d groupr.1165,1172 imm=lfs if (imm.eq.0) then write(azam,'(i5)') izaa dummy='('//proj//','//reac//')-'//azam(1:5)//'-production.' elseif (imm.lt.10) then write(azam,'(i5,''m'',i1)') izaa,imm dummy='('//proj//','//reac//')-'//azam//'-production.' else izaa=izaa/10 write(azam,'(i5,''m'',i2)') izaa,imm dummy='('//proj//','//reac//')-'//azam//'-production.' endif *d groupr.3793 subroutine getyld(e,enext,idis,yld,mat,mf,mt,lfs,itape,a) *d groupr.3828,3829 *i groupr.3913 common/argcom1/lfs *d groupr.3922 save mt,nsig *d groupr.3949 *i groupr.4272 common/argcom1/lfs *d groupr.4346 & call getyld(e,en,idis,yld,matd,mfd,mtd,lfs,nend3,a) *d groupr.4348 & call getyld(e,en,idis,yld,matd,1,mtd,0,nend3,a) *d groupr.4374 & call getyld(e,en,idis,yld,matd,1,456,0,nend3,a) *d up259.7 call getyld(e,en,idis,yld,matd,1,456,0,nend3,a) *d groupr.8574 mf10i(imf10)=10*izan lfs8(imf10)=iis *i groupr.8611 lfs8(imf10)=0 *ident up340 */ reconr --15july2010 */ - pendf output omits many basic endf variables that appear in */ mf1, mt451. They are easy to include and we do so now (per */ J-C Sublet request). *i reconr.92 common/recon5/elis,sta,emax common/recon6/lis,lis0,nfor,lrel,nver *d reconr.202 if (iverf.ge.5) then call contio(nin,0,0,a(iscr),nb,nw) elis=c1h sta=c2h lis=l1h lis0=l2h nfor=n2h endif *i reconr.210 emax=c2h lrel=l1h nver=n2h *i reconr.4378 common/recon5/elis,sta,emax common/recon6/lis,lis0,nfor,lrel,nver *d reconr.4423,4429 a(iscr)=elis a(iscr+1)=sta a(iscr+2)=lis a(iscr+3)=lis0 a(iscr+4)=0 a(iscr+5)=nfor *d reconr.4434,4435 a(iscr+1)=emax a(iscr+2)=lrel *d reconr.4438 a(iscr+5)=nver *ident up341 */ mixr -- 22sept2010 */ - discovered during a recent training class that mixr in njoy99 */ has never worked. Add a missing index needed to exit the */ do while loop. */ - also increase working array size, and add test for array bound */ overflow, per upnea65. *d mixr.54 dimension a(300000) *i mixr.74 mxlna=300000 *i mixr.314 je=je+1 *i mixr.318 if (inow.gt.mxlna) then call error('mixr','mxlna array limit exceeded',' ') endif *ident up342 */ errorr -- 22sept2010 */ - processing of new JENDL-4 evaluations has uncovered the need for */ changes in selected errorr routines (rem & ack). */ - when mfcov=35: */ - revise gendf ascii read to handle ascii or binary input tape; */ - revise nendf-to-nendf2 copy to handle binary tapes; */ - loop over all mt subsections to get largest possible ncovl; */ - restore awr to output tape (inadvertantly deleted in up324). */ - restructure mfcov=31 or 33 if test since the paths followed are */ not identical for evaluations with mf32 data. */ - need more memory in resprx_rrr_lcomp12 routine for b(maxb). */ - delete a couple of obsolete error/stop messages. */ - force E(res) uncertainty into mpid(1) even when not present */ (Rochman). */ - need more space for large input energy grid (endf/a 16o, for */ example). *d up282.75 if (ngout.gt.0) then read(ngout,'(66x,i4,i2,i3)') mat,mf,mt else read(-ngout)mat,mf,mt endif *d up282.120 *d up282.125 *d up282.131 *d up282.144 *d up282.160 call tomend(nendf,0,nendf2,a(iscr)) *i up282.169 call releas('scr',0,a) *d errorj.1474,1475 if (mfcov.eq.31) then call sigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx),a(isig)) elseif (mfcov.eq.33) then call sigc(ngn,a(isum),a(icflx),a(iscr),a(iun),a(iflx),a(isig)) *d up324.148 a(iscr+1)=awr *d up324.154 a(iscr+1)=awr *d errorj.6339 parameter (maxe=400000,mxnpar=4000,maxb=30000) *d errorj.7200,7201 *d errorj.7218,7219 *d up279.41,up279.43 c all other resonances), but force E(res) uncertainty into the c first position. mpar=1 mpid(1)=1 do i=2,6 *d up279.49,up279.50 if (mpar.eq.1.and.abs(a(lbg+12)).eq.zero) call error('RRR_Lcomp2', & 'no RR uncertainties in mf32',' ') *d up272.144 data nxmax/5000/, irmax/80/ *ident up343 */ moder -- 30sept2010 */ - we've never updated moder for the new scattering radius */ format that was approved at the Fall 2009 CSEWG meeting; */ - also we've never updated moder to handle mf=34,35 or 40 when */ converting errorr tapes between binary and ascii format. *i up81.9 lrf=l2h *i up81.22 isr=n2h if (isr.ne.0) then if (isr.eq.1 .and. lrf.le.2) then call contio(nin,nout,nscr,a,nb,nw) elseif (isr.eq.1 .and. lrf.eq.3) then call listio(nin,nout,nscr,a,nb,nw) elseif (isr.eq.1 .and. lrf.eq.7) then call error('file32','not ready for isr=1, lrf=7',' ') else call error('file32','unknown isr',' ') endif endif *i moder.203 if (mt.eq.451.and.n1h.eq.-12) go to 800 if (mt.eq.451.and.n1h.eq.-14) go to 800 *d moder.309,310 if (mf.eq.3.or.mf.eq.5) then c files 3 & 5 have no head cards, backspace and read list record *d moder.320 else if (mf.eq.33.or.mf.eq.40) then *d moder.335,336 c c ***covariance tape mf34 or mf35 else if (mf.eq.34.or.mf.eq.35) then call contio(nin,nout,nscr,a,nb,nw) ng=n2h ig=0 c loop over groups do while (ig.lt.ng) call listio(nin,nout,nscr,a,nb,nw) ig=n2h do while (nb.ne.0) call moreio(nin,nout,nscr,a,nb,nw) enddo enddo c c ***only allow mf1, mf3 and mf33, 34, 35 & 40 on covariance tapes *ident up344 */ errorr -- 7oct2010 */ - need more array space when processing large multigroup data sets */ (here and in covr, next ident). *d up272.26 common/estore/a(50000000) *d up272.35 namax=50000000 *d up272.100 common/estore/a(50000000) *ident up345 */ covr -- 7oct2010 */ - need more array space when processing large multigroup data sets */ (here and in errorr, previous ident). *d up273.39 common/storec/a(9900000) *d up273.50 data iamax/9900000/, niad/17/, ipr/0/, ntics3/600/ *d up273.320 common/storec/a(9900000) *d up111.16 if (ipat.gt.99999) call error('matshd','ipat gt 99999.',' ') *ident up346 */ viewr -- 14oct2010 */ - need more space for detailed correlation matrix plots (ack). *d viewr.310,315 dimension z(15),aa(200000) dimension x(10000),y(10000),b(10000) dimension dxm(10000),dxp(10000),dym(10000),dyp(10000) equivalence (x(1),aa(1)),(y(1),aa(10001)),(b(1),aa(20001)) equivalence (dxm(1),aa(20001)),(dxp(1),aa(30001)), & (dym(1),aa(40001)),(dyp(1),aa(50001)) *d viewr.319 data maxaa/200000/ *ident up347 */ groupr -- 14oct2010 */ - miscellaneous changes proposed by K.Kosako (Shimizu Corp) */ for JENDL-4 processing. */ - allow for larger group structures on listing; */ - consistent use of "zero" in an if statement; */ - recognize the possibility of more than one subsection */ when processing file15; */ - make if test logic for matn=Xzzzaaam (for X=1,2,3, or 4) */ first introduced in up65 consistent throughout all routines. *d groupr.3516 write(nsyso,'(1x,i5,2x,i5,1x,1p,10a11)') *d groupr.3554 write(nsyso,'(1x,i5,2x,i5,1x,1p,10a11)') *d groupr.3596 write(nsyso,'(1x,i5,2x,i5,6x,i1,2x,1p,10a11)') *d groupr.3602 write(nsyso,'(1x,i5,6x,i1,2x,1p,10a11)') *d groupr.3615 write(nsyso,'(1x,i5,2x,1p,10a11)') *d groupr.3647 write(nsyso,'(1x,i5,2x,1p,10a11)') *d groupr.3665 write(nsyso,'(1x,i5,2x,1p,10a11)') *d groupr.3683 write(nsyso,'('' spec'',3x,i5,2x,1p,6a11)') *d groupr.3701 write(nsyso,'(1x,i5,'' prod'',2x,1p,6a11)') *d groupr.4205 if (a(loc).lt.zero.and.a(loc1).lt.zero) iovl=1 */ *d groupr.4282 */ save ifirst,nyl,nfl,igmin,nksed */ *i groupr.4467 */ nksed=nk */ *d groupr.4505 */ nk=nksed */ !!!check this since it doesn't revert to current code when nk=1!!! */ *d groupr.4528 */ if (a(ieyl+ik-1).eq.zero) tempo=tempo*a(ised+ik-1+nk*(ig-1)) *d up339.30 if (mfd.ge.10000000) then *d up339.40 if (mfd.ge.10000000) then *d up65.10 if (mfd.lt.10000000) go to 405 *d up65.37 if (mfd.ge.10000000) mfh=3 *d up65.39 if (mfd.ge.10000000) mfh=3 *d groupr.993 430 if (mfd.lt.10000000) go to 280 *d up65.43 else if (mfd.ge.10000000) then *d groupr.3819,3821 if (mft.ge.40000000) mft=10 if (mft.ge.30000000) mft=9 if (mft.ge.20000000) mft=6 *d groupr.3831 if (mf.ge.10000000) iza=mod(mf/10,1000000) *d groupr.3945,3948 if (mfd.ge.10000000) mf=3 if (mfd.ge.20000000) mf=3 if (mfd.ge.30000000) mf=3 if (mfd.ge.40000000) mf=10 *d up65.79 if (mfd.eq.12.or.(mfd.ge.20000000.and.mfd.lt.40000000)) *ident up348 */ reconr -- 29nov2010 */ - update reconr (and groupr in up349) to recognize the many new mt */ values approved during the Fall 2010 CSEWG meeting. Some of these */ changes were developed by Shannon Holloway (LANL) while interacting */ interacting with the EAF community. *d reconr.1688 if (mth.eq.151) go to 150 *d up242.53 if (mth.gt.200.and.mth.lt.mpmin) go to 440 *ident up349 */ groupr -- 29nov2010 */ - update groupr (and reconr in up348) to recognize the many new mt */ values approved during the Fall 2010 CSEWG meeting. Some of these */ changes were developed by Shannon Holloway (LANL) while interacting */ interacting with the EAF community, plus already need more space */ in selected arrays recently defined in up339. *b groupr.226 parameter (maxr1=500, maxr2=500) *d groupr.244,up339.10 common/rlist/mf4(maxr1),mf6(maxr1), & mf12(maxr1),mf13(maxr1),mf18(maxr1), & mf4r(6,maxr1),mf6p(6,maxr1), & mf10f(maxr2),mf10s(maxr2),mf10i(maxr2),lfs8(maxr2) *b groupr.864 parameter (maxr1=500, maxr2=500) *d groupr.866,up339.13 common/rlist/mf4(maxr1),mf6(maxr1), & mf12(maxr1),mf13(maxr1),mf18(maxr1), & mf4r(6,maxr1),mf6p(6,maxr1), & mf10f(maxr2),mf10s(maxr2),mf10i(maxr2),lfs8(maxr2) *i groupr.882 if (mtd.ge.152.and.mtd.le.200) go to 110 *d groupr.1033,1034 dimension ir(113),ip(7),i2(17) character*7 nr(113) *i groupr.1045 & 152,153,154,155,156,157,158,159,160, & 161,162,163,164,165,166,167,168,169,170, & 171,172,173,174,175,176,177,178,179,180, & 181,182,183,184,185,186,187,188,189,190, & 191,192,193,194,195,196,197,198,199,200, *i groupr.1054 & '5n','6n','2nt','ta','4np','3nd','nda','2npa','7n', & '8n','5np','6np','7np','4na','5na','6na','7na','4nd','5nd', & '6nd','3nt','4nt','5nt','6nt','2nh','3nh','4nh','3n2p','3n2a', & '3npa','dt','npd','npt','ndt','nph','ndh','nth','nta','2n2p', & 'ph','dh','ha','4n2p','4n2a','4npa','3p','n3p','3n2pa','5n2p', *d groupr.1061 data nreac/113/,npart/17/,nproj/7/ *d groupr.1205,1208 parameter (maxr1=500, maxr2=500) common/rlist/mf4(maxr1),mf6(maxr1), & mf12(maxr1),mf13(maxr1),mf18(maxr1), & mf4r(6,maxr1),mf6p(6,maxr1), & mf10f(maxr2),mf10s(maxr2),mf10i(maxr2),lfs8(maxr2) c max=maxr1 *d groupr.1255,1258 parameter (maxr1=500, maxr2=500) common/rlist/mf4(maxr1),mf6(maxr1), & mf12(maxr1),mf13(maxr1),mf18(maxr1), & mf4r(6,maxr1),mf6p(6,maxr1), & mf10f(maxr2),mf10s(maxr2),mf10i(maxr2),lfs8(maxr2) c max=maxr1 *i groupr.3959 if (mtd.ge.152.and.mtd.le.200) mt=mtd *b groupr.7931 parameter (maxr1=500, maxr2=500) *d groupr.7933,up339.22 common/rlist/mf4(maxr1),mf6(maxr1), & mf12(maxr1),mf13(maxr1),mf18(maxr1), & mf4r(6,maxr1),mf6p(6,maxr1), & mf10f(maxr2),mf10s(maxr2),mf10i(maxr2),lfs8(maxr2) *d groupr.7945 *d groupr.8564 if (mth.eq.151) go to 830 if (mth.gt.200.and.mth.lt.600) go to 830 *ident up350 */ plotr -- 01dec2010 */ - provide option for plotting self shielding factors *i plotr.191 c * set ntp negative for self shieldin factor *d up77.16 if (iverf.gt.1.and.mfd.eq.3.and.ntp.gt.1) then *d plotr.1621 if (ntp.gt.0) then s=a(jbase+6+nth*nl*nz+(nkh-1)+nl*(ntp-1)) else s=0 if (a(jbase+6+nth*nl*nz+(nkh-1)).ne.zero) then s=a(jbase+6+nth*nl*nz+(nkh-1)+nl*(-ntp-1))/ & a(jbase+6+nth*nl*nz+(nkh-1)) endif endif *ident up351 */ heatr -- 02dec2010 */ - provide more digits for za */ - watch for negative coefficients with log interpolation */ (e.g., JENDL-4 H-2) */ - make sure that x is defined *d heatr.634 & '' does not give recoil za='',i6)') *d heatr.685 & '' does not give recoil za='',i6)') *d heatr.3892 innt=int if (innt.eq.4.or.innt.eq.5) then if (flo(i)*fhi(i).le.zero) innt=innt-2 endif call terp1(elo,flo(i),ehi,fhi(i),e,fle(i),innt) *i heatr.4560 x=0 *ident up352 */ errorr -- 02dec2010 */ - more storage space needed *d up272.28,up324.39 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.32,up272.33 nmtmax=100 nenimx=5000 *d up272.37,up324.41 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.50,up324.43 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.69,up324.45 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.73,up324.47 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.102,up324.49 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.108,up324.51 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.110,up324.53 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.141,up324.56 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.178,up324.58 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.181,up324.60 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.185,up324.62 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.187,up324.64 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.189,up324.66 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.191,up324.68 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.193,up324.70 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.216,up324.72 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.222,up324.74 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.230,up324.76 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d up272.236,up324.78 & nek,iread,nmt,nmt1,mfcov,mf32,nlump,nlmt,mats(100),mts(100) & ,mzap(100),lfs *d errorj.3770 nwscr=250000 *ident up353 */ gaspr -- 06dec2010 */ - update to recognize the many new mt's introduced at the Fall */ 2010 CSEWG meeting (reconr & groupr were previously updated */ in up348 & up349). *d up247.15 if (mth.gt.200.or.mth.eq.0) then *d up244.81 if (mth.gt.200.and.mth.lt.mpmin) go to 245 *d gaspr.235 if (mth.eq.11) izr=izr-1004 *d gaspr.257 if (mth.eq.37) izr=izr-4 *i gaspr.300 if (mth.ge.154.and.mth.le.159) izg=1 if (mth.ge.162.and.mth.le.200) izg=1 if (mth.eq.152) izr=irz-5 if (mth.eq.153) izr=izr-6 if (mth.eq.154) izr=izr-1005 if (mth.eq.155) izr=izr-3007 if (mth.eq.156) izr=izr-1005 if (mth.eq.157) izr=izr-1005 if (mth.eq.158) izr=izr-3007 if (mth.eq.159) izr=izr-3007 if (mth.eq.160) izr=izr-7 if (mth.eq.161) izr=izr-8 if (mth.eq.162) izr=irz-1006 if (mth.eq.163) izr=izr-1007 if (mth.eq.164) izr=izr-1008 if (mth.eq.165) izr=izr-2008 if (mth.eq.166) izr=izr-2009 if (mth.eq.167) izr=izr-2010 if (mth.eq.168) izr=izr-2011 if (mth.eq.169) izr=izr-1006 if (mth.eq.170) izr=izr-1007 if (mth.eq.171) izr=izr-1008 if (mth.eq.172) izr=irz-1006 if (mth.eq.173) izr=izr-1007 if (mth.eq.174) izr=izr-1008 if (mth.eq.175) izr=izr-1009 if (mth.eq.176) izr=izr-2005 if (mth.eq.177) izr=izr-2006 if (mth.eq.178) izr=izr-2007 if (mth.eq.179) izr=izr-2005 if (mth.eq.180) izr=izr-4011 if (mth.eq.181) izr=izr-3008 if (mth.eq.182) izr=irz-2005 if (mth.eq.183) izr=izr-2004 if (mth.eq.184) izr=izr-2005 if (mth.eq.185) izr=izr-2006 if (mth.eq.186) izr=izr-3005 if (mth.eq.187) izr=izr-3006 if (mth.eq.188) izr=izr-3007 if (mth.eq.189) izr=izr-3008 if (mth.eq.190) izr=izr-2004 if (mth.eq.191) izr=izr-3004 if (mth.eq.192) izr=irz-3005 if (mth.eq.193) izr=izr-4007 if (mth.eq.194) izr=izr-2006 if (mth.eq.195) izr=izr-4012 if (mth.eq.196) izr=izr-3009 if (mth.eq.197) izr=izr-3003 if (mth.eq.198) izr=izr-3004 if (mth.eq.199) izr=izr-4009 if (mth.eq.200) izr=izr-2007 *d up244.107 if (mth.gt.200.and.mth.lt.mpmin) go to 310 *i up244.114 if (mth.eq.152.or.mth.eq.153.or.mth.eq.160.or.mth.eq.161)go to 310 *i gaspr.524 else if (mth.eq. 152) then izr=izr-5 else if (mth.eq. 153) then izr=izr-6 else if (mth.eq. 154) then izr=izr-1005 y205=1 else if (mth.eq. 155) then izr=izr-3007 y205=1 y207=1 else if (mth.eq. 156) then izr=izr-1005 y203=1 else if (mth.eq. 157) then izr=izr-1005 y204=1 else if (mth.eq. 158) then izr=izr-3007 y204=1 y207=1 else if (mth.eq. 159) then izr=izr-3007 y203=1 y207=1 else if (mth.eq. 160) then izr=izr-7 else if (mth.eq. 161) then izr=izr-8 else if (mth.eq. 162) then izr=izr-1006 y203=1 else if (mth.eq. 163) then izr=izr-1007 y203=1 else if (mth.eq. 164) then izr=izr-1008 y203=1 else if (mth.eq. 165) then izr=izr-2008 y207=1 else if (mth.eq. 166) then izr=izr-2009 y207=1 else if (mth.eq. 167) then izr=izr-2010 y207=1 else if (mth.eq. 168) then izr=izr-2011 y207=1 else if (mth.eq. 169) then izr=izr-1006 y204=1 else if (mth.eq. 170) then izr=izr-1007 y204=1 else if (mth.eq. 171) then izr=izr-1008 y204=1 else if (mth.eq. 172) then izr=izr-1006 y205=1 else if (mth.eq. 173) then izr=izr-1007 y205=1 else if (mth.eq. 174) then izr=izr-1008 y205=1 else if (mth.eq. 175) then izr=izr-1009 y205=1 else if (mth.eq. 176) then izr=izr-2005 y206=1 else if (mth.eq. 177) then izr=izr-2006 y206=1 else if (mth.eq. 178) then izr=izr-2007 y206=1 else if (mth.eq. 179) then izr=izr-2005 y203=2 else if (mth.eq. 180) then izr=izr-4011 y207=2 else if (mth.eq. 181) then izr=izr-3008 y203=1 y207=1 else if (mth.eq. 182) then izr=izr-2005 y204=1 y205=1 else if (mth.eq. 183) then izr=izr-2004 y203=1 y204=1 else if (mth.eq. 184) then izr=izr-2005 y203=1 y205=1 else if (mth.eq. 185) then izr=izr-2006 y204=1 y205=1 else if (mth.eq. 186) then izr=izr-3005 y203=1 y206=1 else if (mth.eq. 187) then izr=izr-3006 y204=1 y206=1 else if (mth.eq. 188) then izr=izr-3007 y205=1 y206=1 else if (mth.eq. 189) then izr=izr-3008 y205=1 y207=1 else if (mth.eq. 190) then izr=izr-2004 y203=2 else if (mth.eq. 191) then izr=izr-3004 y203=1 y206=1 else if (mth.eq. 192) then izr=izr-3005 y204=1 y206=1 else if (mth.eq. 193) then izr=izr-4007 y206=1 y207=1 else if (mth.eq. 194) then izr=izr-2006 y203=2 else if (mth.eq. 195) then izr=izr-4012 y207=2 else if (mth.eq. 196) then izr=izr-3009 y203=1 y207=1 else if (mth.eq. 197) then izr=izr-3003 y203=3 else if (mth.eq. 198) then izr=izr-3004 y203=3 else if (mth.eq. 199) then izr=izr-4009 y203=2 y207=1 else if (mth.eq. 200) then izr=izr-2007 y203=2 *d gaspr.653 if (nint(a(j+3)).eq.3.and.nint(a(j+4)).gt.200) idone=1 *d gaspr.730 *d gaspr.741 if (mth.gt.200.or.mth.eq.0) then *ident up354 */ acer -- 07dec2010 */ - update to recognize the many new mt's introduced at the Fall */ 2010 CSEWG meeting (reconr, groupr & gaspr were previously */ updated in up348, up349 & up352). *d acer.1930 & (mt.eq.151).or. *i up57.22 & (mt.ge.152.and.mt.le.154).or. & (mt.ge.156.and.mt.le.181).or. & (mt.ge.183.and.mt.le.190).or. & (mt.ge.194.and.mt.le.196).or. & (mt.ge.198.and.mt.le.200).or. *i acer.4773 & mt.eq.156.or.mt.eq.159.or.mt.eq.162.or. & mt.eq.163.or.mt.eq.164.or.mt.eq.179.or. & mt.eq.181.or.mt.eq.183.or.mt.eq.184.or. & mt.eq.186.or.mt.eq.190.or.mt.eq.191.or. & mt.eq.194.or.mt.eq.196.or.mt.eq.197.or. & mt.eq.198.or.mt.eq.199.or.mt.eq.200.or. *i up325.15 & mt.eq.157.or.mt.eq.158.or.mt.eq.169.or. & mt.eq.170.or.mt.eq.171.or.mt.eq.182.or. & mt.eq.183.or.mt.eq.185.or.mt.eq.187.or. & mt.eq.192.or. *i acer.4799 & mt.eq.154.or.mt.eq.155.or.mt.eq.172.or. & mt.eq.173.or.mt.eq.174.or.mt.eq.175.or. & mt.eq.182.or.mt.eq.184.or.mt.eq.185.or. & mt.eq.188.or.mt.eq.189.or. *i up87.14 & mt.eq.176.or.mt.eq.177.or.mt.eq.178.or. & mt.eq.186.or.mt.eq.187.or.mt.eq.188.or. & mt.eq.191.or.mt.eq.192.or.mt.eq.193.or. *i up325.17 & mt.eq.155.or.mt.eq.158.or.mt.eq.159.or. & mt.eq.165.or.mt.eq.166.or.mt.eq.167.or. & mt.eq.168.or.mt.eq.180.or.mt.eq.181.or. & mt.eq.189.or.mt.eq.193.or.mt.eq.195.or. & mt.eq.196.or.mt.eq.199.or. *d up57.25 if (mt.gt.91.and.mt.le.151) iskip=1 if (mt.eq.155.or.mt.eq.182.or.mt.eq.191) iskip=1 if (mt.eq.192.or.mt.eq.193.or.mt.eq.197) iskip=1 if (mt.gt.200.and.mt.le.849) iskip=1 *i acer.5027 & mt.eq.156.or.mt.eq.159.or.mt.eq.162.or. & mt.eq.163.or.mt.eq.164.or.mt.eq.179.or. & mt.eq.181.or.mt.eq.183.or.mt.eq.184.or. & mt.eq.186.or.mt.eq.190.or.mt.eq.191.or. & mt.eq.194.or.mt.eq.196.or.mt.eq.197.or. & mt.eq.198.or.mt.eq.199.or.mt.eq.200.or. *i up325.22 & mt.eq.157.or.mt.eq.158.or.mt.eq.169.or. & mt.eq.170.or.mt.eq.171.or.mt.eq.182.or. & mt.eq.183.or.mt.eq.185.or.mt.eq.187.or. & mt.eq.192.or. *i acer.5037 & mt.eq.154.or.mt.eq.155.or.mt.eq.172.or. & mt.eq.173.or.mt.eq.174.or.mt.eq.175.or. & mt.eq.182.or.mt.eq.184.or.mt.eq.185.or. & mt.eq.188.or.mt.eq.189.or. *i up87.27 & mt.eq.176.or.mt.eq.177.or.mt.eq.178.or. & mt.eq.186.or.mt.eq.187.or.mt.eq.188.or. & mt.eq.191.or.mt.eq.192.or.mt.eq.193.or. *i up325.24 & mt.eq.155.or.mt.eq.158.or.mt.eq.159.or. & mt.eq.165.or.mt.eq.166.or.mt.eq.167.or. & mt.eq.168.or.mt.eq.180.or.mt.eq.181.or. & mt.eq.189.or.mt.eq.193.or.mt.eq.195.or. & mt.eq.196.or.mt.eq.199.or. *d up57.30 if (mt.gt.91.and.mt.lt.152) iskip=0 if (mt.eq.155.or.mt.eq.182.or.mt.eq.191) iskip=0 if (mt.eq.192.or.mt.eq.193.or.mt.eq.197) iskip=0 if (mt.gt.200.and.mt.le.849) iskip=0 *i acer.5133 & mt.eq.156.or.mt.eq.159.or.mt.eq.162.or. & mt.eq.163.or.mt.eq.164.or.mt.eq.179.or. & mt.eq.181.or.mt.eq.183.or.mt.eq.184.or. & mt.eq.186.or.mt.eq.190.or.mt.eq.191.or. & mt.eq.194.or.mt.eq.196.or.mt.eq.197.or. & mt.eq.198.or.mt.eq.199.or.mt.eq.200.or. *i up325.30 & mt.eq.157.or.mt.eq.158.or.mt.eq.169.or. & mt.eq.170.or.mt.eq.171.or.mt.eq.182.or. & mt.eq.183.or.mt.eq.185.or.mt.eq.187.or. & mt.eq.192.or. *i acer.5143 & mt.eq.154.or.mt.eq.155.or.mt.eq.172.or. & mt.eq.173.or.mt.eq.174.or.mt.eq.175.or. & mt.eq.182.or.mt.eq.184.or.mt.eq.185.or. & mt.eq.188.or.mt.eq.189.or. *i up87.40 & mt.eq.176.or.mt.eq.177.or.mt.eq.178.or. & mt.eq.186.or.mt.eq.187.or.mt.eq.188.or. & mt.eq.191.or.mt.eq.192.or.mt.eq.193.or. *i up325.32 & mt.eq.155.or.mt.eq.158.or.mt.eq.159.or. & mt.eq.165.or.mt.eq.166.or.mt.eq.167.or. & mt.eq.168.or.mt.eq.180.or.mt.eq.181.or. & mt.eq.189.or.mt.eq.193.or.mt.eq.195.or. & mt.eq.196.or.mt.eq.199.or. *i up243.56 & .or.mth.eq.155.or.mth.eq.182.or.mth.eq.191 & .or.mth.eq.192.or.mth.eq.193.or.mth.eq.197 *d acer.5216 if (mth.le.200.or.mth.ge.600) then *i up243.64 & .or.(mth.ge.152.and.mth.le.200) *d acer.5227 if (mth.le.200.or.mth.ge.600) then *d up57.38,acer.11390 character*10 hndf(508) character*10 hndf1(50),hndf2(48),hndf3(102) *d acer.11398,up57.46 equivalence (hndf4(1),hndf(201)) equivalence (hndf5(1),hndf(251)) equivalence (hndf6(1),hndf(301)) equivalence (hndf7(1),hndf(351)) equivalence (hndf8(1),hndf(401)) equivalence (hndf9(1),hndf(451)) equivalence (hndf10(1),hndf(501)) equivalence (hndf11(1),hndf(508)) *d acer.11444 & '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', & '(n,x) ', '(n,5n) ', '(n,6n) ', '(n,2nt) ', & '(n,ta) ', '(n,4np) ', '(n,3nd) ', '(n,nda) ', & '(n,2npa) ', '(n,7n) ', '(n,8n) ', '(n,5np) ', & '(n,6np) ', '(n,7np) ', '(n,4na) ', '(n,5na) ', & '(n,6na) ', '(n,7na) ', '(n,4nd) ', '(n,5nd) ', & '(n,6nd) ', '(n,3nt) ', '(n,4nt) ', '(n,5nt) ', & '(n,6nt) ', '(n,2nhe3) ', '(n,3nhe3) ', '(n,4nhe3) ', & '(n,3n2p) ', '(n,3n2a) ', '(n,3npa) ', '(n,dt) ', & '(n,npd) ', '(n,npt) ', '(n,ndt) ', '(n,nphe3) ', & '(n,ndhe3) ', '(n,nthe3) ', '(n,nta) ', '(n,2n2p) ', & '(n,phe3) ', '(n,dhe3) ', '(n,he3a) ', '(n,4n2p) ', & '(n,2n2a) ', '(n,4npa) ', '(n,3p) ', '(n,n3p) ', & '(n,3n2pa) ', '(n,5n2p) '/ *d up57.67,up57.69 if (i.ge.201.and.i.le.207) i=i+300 if (i.ge.600) i=i-399 if (mt.eq.444) i=508 *d acer.11531 if (mt.le.200) then *d up57.71 name=hndf(mt+301) *d up57.73 name=hndf(508) *d acer.11538 name=hndf(mt-499) *d acer.11540 name=hndf(250) *d acer.11544 name=hndf(mt-469) *d acer.11546 name=hndf(300) *d acer.11550 name=hndf(mt-439) *d acer.11552 name=hndf(350) *d acer.11556 name=hndf(mt-409) *d acer.11558 name=hndf(400) *d acer.11562 name=hndf(mt-379) *d acer.11564 name=hndf(450) *ident up355 */ errorr -- 07dec2010 */ - small tweak to recognize expanded range of mf3 mt values approved */ at the Fall 2010 CSEWG meeting. *d errorj.4980 if (mtd.le.200) mt=mtd *ident up356 */ broadr -- 07dec2010 */ - as with up348, up349, up354 & up355, need to revise coding to */ recognize the new mf3 mt values approved at the Fall 2010 CSEWG */ meeting. *d up176.10 if (mth.gt.200.and.mth.lt.600) go to 165 *d broadr.646 if (mfh.eq.2.and.mth.eq.152) go to 247 *d broadr.724 if (mth.ge.201) iflag=1 *ident up357 */ acer -- 09dec2010 */ - first of several updates for acer, recommended by JAEA */ colleagues for processing JENDL-4 evaluations. *i acer.7524 if (ie.ne.jfirst) ie=jfirst *d up72.11,up72.12 xxmin=a(iscr+6+nn*2) xxmax=a(iscr+4+nn*2+n*2) *d up72.19 if (100000000*abs(sumup-1).gt.1) then *d up72.23 & '' norm='',f11.8)') i,xss(lxx+ie-1),sumup *d up72.31 if (100000000*abs(sumup-1).gt.1) then *d up122.6,7 & '' precursor'',i2,'' norm='',f11.8)') i,sumup *i up72.42 if (xss(l+2*mm+j).ge.0.999999997d0.and. & xss(l+2*mm+j).le.1.000100000d0) then xss(l+2*mm+j)=1 xss(l+2*mm+j+2+3*mm)=1 endif *i up72.43 if (xss(l+3*mm).lt.1.0d0) then xss(l+3*mm)=1 xss(l+6*mm+2)=1 endif *ident up358 */ acer -- 09dec2010 */ - second of several updates for acer, recommended by JAEA */ colleagues for processing JENDL-4 evaluations. *d up318.59 max3=7000000 *d up318.7 common/xsst/xss(7000000),n3 *d up318.61 common/xsst/xss(7000000),n3 *d up318.63 common/xsst/xss(7000000),n3 *d up318.65 common/xsst/xss(7000000),n3 *d up318.67 common/xsst/xss(7000000),n3 *d up318.69 common/xsst/xss(7000000),n3 *d up318.71 common/xsst/xss(7000000),n3 *d up318.73 common/xsst/xss(7000000),n3 *d up318.75 common/xsst/xss(7000000),n3 *d up318.77 common/xsst/xss(7000000),n3 *d up318.79 common/xsst/xss(7000000),n3 *d up318.81 common/xsst/xss(7000000),n3 *d up318.83 common/xsst/xss(7000000),n3 *d up318.85 common/xsst/xss(7000000),n3 *d up318.87 common/xsst/xss(7000000),n3 *d up318.89 common/xsst/xss(7000000),n3 *d up318.91 common/xsst/xss(7000000),n3 *d up318.93 common/xsst/xss(7000000),n3 *d up318.95 common/xsst/xss(7000000),n3 *d up318.97 common/xsst/xss(7000000),n3 *d up318.99 common/xsst/xss(7000000),n3 *d up318.101 common/xsst/xss(7000000),n3 *d up318.103 common/xsst/xss(7000000),n3 *d up318.105 common/xsst/xss(7000000),n3 *d up318.107 common/xsst/xss(7000000),n3 *d up318.109 common/xsst/xss(7000000),n3 *d up318.111 common/xsst/xss(7000000),n3 *d up318.113 common/xsst/xss(7000000),n3 *d up318.115 common/xsst/xss(7000000),n3 *d up318.117 common/xsst/xss(7000000),n3 *d up318.119 common/xsst/xss(7000000),n3 *d up318.121 common/xsst/xss(7000000),n3 *d up318.123 common/xsst/xss(7000000),n3 *d up318.125 common/xsst/xss(7000000),n3 *d up318.127 common/xsst/xss(7000000),n3 *d up318.129 common/xsst/xss(7000000),n3 *d up318.131 common/xsst/xss(7000000),n3 *d up318.133 common/xsst/xss(7000000),n3 *d up318.135 common/xsst/xss(7000000),n3 *d up318.137 common/xsst/xss(7000000),n3 */ make sure the threshold isn't violated in the least significant digit *i acer.5466 if (xss(next+9).gt.xss(next+5)) then xss(next+9)=sigfig(xss(next+5)*0.999998d0,7,0) endif */ initialize lld *i acer.8436 lld=iscr *ident up359 */ acer -- 09dec2010 */ - third of several updates for acer, recommended by JAEA */ colleagues for processing JENDL-4 evaluations. */ - expand mf,mt array space */ - use awr consistently in all common blocks */ - more explicit test for lnu flag with mt452, mt455 & mt456 *d acer.213,214 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.253 nxcmax=500 *d acer.456,457 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.546,547 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.1017,1018 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.1278,1279 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.2120,2121 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.2520,2521 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.2872,2873 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.3450,3451 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.3735,3736 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.4285,4286 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.4666,4667 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.5772,5773 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.13073,13074 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.13454,13455 common/ace2/za,awr,elast,mt19,mf1x(3),nxc,nxcmax,mfs(500), & mts(500),ncs(500),ngmt,nned,iopp *d acer.4694 awz=awr *d acer.5341 awz=c2h *d acer.5464 x=(awz+1)/awz *d acer.5583 call acelcp(next,matd,nin,za,awz) *d acer.5750 subroutine acecpe(next,iscr,nin,awz,awp,spi,ne,lidp,ie,il,nes) *d acer.5786 amass=awz/awp *d acer.5810 call ptlegc(a(lld),awi,izai,awr,nint(za),spi) *d acer.5843 at=awr*amassn *d acer.13477 *d acer.4851 if (lnu.eq.1.and.(mta.eq.452.or.mta.eq.456)) then *i acer.4867 elseif (lnu.eq.1.and.mta.eq.455) then c polynomial expansion for spontaneous fission call listio(nin,0,0,a(iscr),nb,nw) nnf=n1h do i=1,nnf dntc(i)=a(iscr+5+i) enddo call listio(nin,0,0,a(iscr),nb,nw) n=n1h nw=3+2*(n+1) call reserv('nud',nw,inud,a) in=inud a(in)=2 j=in+1 a(j)=0 j=j+1 a(j)=n a(j+1)=1.0d-11 a(j+2)=a(iscr+6) a(j+3)=etop a(j+4)=a(iscr+6) nnud=nw *ident up360 */ acer -- 09dec2010 */ - fourth of several updates for acer, recommended by JAEA */ colleagues for processing JENDL-4 evaluations. */ - modifications to handle a variable number of discrete photons */ as a function of incident neutron energy (this is a legal endf */ format, but mcnp expects ND to be constant for all incident */ energies) */ - NOTE: original JAEA coding modified at LANL (1/21+/2011). *b acer.7386 character*66 strng *i acer.7390 data eps/1.d-6/ *i acer.7393 data eps/1.e-6/ *i acer.7405 nwordg=999 call reserv('dise',nwordg,idise,a) do i=1,nwordg a(idise+i-1)=zero enddo *i acer.7765 c ***create a union list of all discrete photons for this mtd call contio(nin,0,0,a(iscr),nb,nw) awr=c2h call tab1io(nin,0,0,a(iscr),nb,nw) law=nint(a(iscr+3)) egamma=zero if (law.eq.2) egamma=a(iscr+1) do while (nb.ne.0) call moreio(nin,0,0,a(iscr),nb,nw) enddo call tab2io(nin,0,0,a(iscr),nb,nw) ne=n2h nd0=0 c ***loop over incident energies do ie=1,ne call listio(nin,0,0,a(iscr),nb,nw) ei=a(iscr+1) nd=nint(a(iscr+2)) jscr=iscr do while (nb.ne.0) jscr=jscr+nw call moreio(nin,0,0,a(jscr),nb,nw) enddo if (nd.gt.0) then c ***create an initial list of discrete photons. c ***use nd0 as a list counter. if a discrete photon c ***energy is zero, reset it to a small non-zero c ***value (for now), but this should not happen c ***and indicates an error in the evaluated file. if (nd0.eq.0) then do ki=1,nd ep=a(iscr+4+2*ki) if (ep.eq.zero) then call mess('acelpp', & '1discrete photon energy must .ne. 0', & 'reset to 1.e-5 eV') ep=1.e-5 endif if (law.eq.2) ep=ep-awr*ei/(awr+1) a(idise+ki-1)=ep enddo nd0=nd else c ***compare discrete photon list at higher incident c ***neutron energies with a union list from lower c ***incident neutron energies. endf formats allow c ***these to differ but mcnp doesn't. let the c ***a(idise...) array accumulate a union list. do ki=1,nd ep=a(iscr+4+2*ki) if (ep.eq.zero) then call mess('acelpp', & '2discrete photon energy must .ne. 0', & 'reset to 1.e-5 eV') ep=1.e-5 endif if (law.eq.2) ep=ep-awr*ei/(awr+1) do m=1,nd0 r=abs(ep/a(idise+m-1)-1) if (r.le.eps) goto 111 enddo c ***found a new discrete energy. insert it into c ***the existing a(idise) array, making sure to c ***maintain a highest to lowest energy order. if (abs(ep).gt.abs(a(idise))) then do m=nd0,1,-1 a(idise+m)=a(idise+m-1) enddo a(idise)=ep nd0=nd0+1 elseif (abs(ep).lt.abs(a(idise+nd0-1))) then a(idise+nd0)=ep nd0=nd0+1 else do m=1,nd0-1 if (abs(ep).lt.abs(a(idise+m-1)).and. & abs(ep).gt.abs(a(idise+m))) then do j=nd0,m+1,-1 a(idise+j)=a(idise+j-1) enddo a(idise+m)=ep go to 110 endif enddo write(strng,'(''mtd='',i3,'' mt='',i6, & '' ie='',i4,i5,'' nd='',3i4,'' ed='', & 1p,e12.5)') & mtd,int(xss(mtrp-1+i)),ie,ne,nd,nd0,ki, & a(iscr+4+2*ki) call error('acelpp', & 'cannot place discrete photon in a(idise', & strng) 110 continue nd0=nd0+1 endif 111 continue enddo endif if (nd0.gt.nwordg) then write(strng,'(''nwordg is'',i6,'' but need '',i6)') & nwords,nd0 call error('acelpp', & 'too many discrete photons found',strng) endif endif enddo call repoz(nin) call findf(matd,16,mtd,nin) *i acer.7800 c ***loop over incident energies if (nd0.gt.0) call reserv('ind0',2*nd0,ind0,a) *i acer.7802 ei=a(iscr+1) *i acer.7813 c c ***if discrete photons are present make sure all energies c ***are non-zero, then save a copy of these data. if (nd.ne.0) then do nn=1,nd if (a(iscr+4+2*nn).eq.zero) a(iscr+4+2*nn)=1.e-5 a(ind0+2*(nn-1))=a(iscr+4+2*nn) a(ind0+2*(nn-1)+1)=a(iscr+5+2*nn) enddo endif c c ***make sure all (nd0) discrete photons are included c ***for all incident energies. nd is the number of c ***discrete photons for the current incident energy. c ***when nd=nd0, only need to check law and whether this c ***is a primary photon. if (nd0.ne.0.and.nd.eq.nd0) then do nn=1,nd if(law.eq.1.and.a(iscr+4+2*nn).lt.zero) & a(iscr+4+2*nn)=-a(iscr+4+2*nn)+ei*awr/(awr+1) enddo elseif (nd0.ne.0.and.nd.ne.nd0) then c c ***if nd=0 then must insert all discrete photons, c ***with zero probability if (nd.eq.0) then c ***move continuous data, then insert discrete data. do ki=n*2,1,-1 a(iscr+5+2*nd0+ki)=a(iscr+5+ki) enddo do ki=1,nd0 epu=a(idise+ki-1) if (law.eq.1.and.epu.lt.zero) & epu=-epu+awr*ei/(awr+1) if (law.eq.2) epu=epu+awr*ei/(awr+1) a(iscr+4+2*ki)=epu a(iscr+5+2*ki)=0 enddo c ***update length of list record n=n+nd0 c c ***already have some, but not all discrete photons c ***tabulated. compare current list versus union c ***list and insert missing data. else c ***move continuous data, then insert discrete data. do ki=n*2,nd*2+1,-1 a(iscr+5+2*nd0+ki-2*nd)=a(iscr+5+ki) enddo c ***loop over union list of photons, inserting c ***missing energies with zero probability. also c ***check law and/or sign of photon energy to know c ***if this is a primary or secondary photon. if c ***a primary photon, its energy must be increased c ***to account for the incident neutron energy. do m=nd0,1,-1 ep=a(idise+m-1) if (law.eq.1.and.ep.lt.0) & ep=-ep+ei*awr/(awr+1) if (law.eq.2)ep=ep+ei*awr/(awr+1) a(iscr+4+2*m)=ep a(iscr+5+2*m)=zero nn=nd+1 do while (nn.gt.1) nn=nn-1 r=abs(a(ind0+2*(nn-1)))/abs(a(idise+m-1))-1 if (abs(r).lt.eps) then a(iscr+5+2*m)=a(ind0+2*(nn-1)+1) nn=-1 elseif (r.gt.zero) then nn=-1 endif enddo enddo c ***update length of list record n=n-nd+nd0 endif c ***update number of discrete photons nd=nd0 endif c ***done with discrete photon corrections c *i acer.7843 if (nd0.gt.0) call releas('ind0',0,a) *i acer.7849 call releas('dise',0,a) *i acer.7658 mtdnc=int(xss(i-1+mtrp))-mtd*1000 *i acer.7664 if (mtdnc.gt.nc) mtdnc=1 *i acer.7665 if (ic.ne.mtdnc) then c dummy read the unmatched probability record 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 call tab2io(nin,0,0,a(iscr),nb,nw) ne=n2h do ie=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 enddo else *i acer.7752 endif *d acer.10727 & '(4x,i6,2x,i6,2x,i6,1x,i7,2x,i6,10x,1p,3e14.6,16x,i3)') *d acer.10734 & '(4x,i6,2x,i6,2x,i6,1x,i7,2x,i6,10x,1p,2e14.6,30x,i3)') *d acer.10753 write(nsyso,'(4x,i6,2x,i6,2x,i6,1x,i7,2x,i6, *d acer.10760 write(nsyso,'(4x,i6,2x,i6,2x,i6,1x,i7,2x,i6, *d acer.10768 & '(4x,i6,2x,i6,2x,i6,1x,i7,2x,i6,2x,i6,2x, *ident up361 */ covr -- 12jan2011 */ - implement upnea052 that corrects how portions of up273 and up283 */ are implemented. Some of that coding was erroneously placed */ within a "*if sw" statement, or changes were only made within */ a "*if sw" block. These corrections bring bring sw-mode and */ not sw-mode code into agreement. */ - also implement upnea072 which provides additional information */ to an existing information message. *i covr.947 *else xsize=5.00e0 ysize=3.38e0 *endif *d covr.948,951 *i covr.1418 *endif *d covr.1419 *d up192.7 data tlev/0.001e0,0.1e0,0.2e0,0.3e0,0.6e0,1.0e0/ */ *i covr.1102 common/cov3/wcap,nexp,mat,mt,mat1,mt1 *d up160.13 character*60 strng,strn1 *i up160.38 write(strn1,'(''processing of mat/mt'',i5,''/'',i3, & '' vs. mat1/mt1'',i5,''/'',i3)') mat,mt,mat1,mt1 *d up160.41 call mess('matshd',strn1,strng) *ident up362 */ groupr -- 12jan2011 */ - implement upnea069 that allows smaller non-zero values in */ spectrum calculations (and accept all non-zero values when */ mt=18) so that subsequent spectrum covariance processing is */ handled more accurately. *d up316.13 if (a(ised-1+ik+nk*(ig-1)).gt.smin/1000.or.mtd.eq.18) go to 280 *ident up363 */ errorr -- xxjan2011 */ - implement all or part of several upnea updates. */ - upnea051. More robust determination of what resonance parameter */ uncertainties are present. */ - upnea067. Move existing code that checks for presence of MF=3x; */ also correct a couple of existing error stop tests. */ - upnea070. Accept all non-zero "denom" values when calculating */ MF35 related matrix elements. */ - upnea071. ident up324 attempted to skip over erroneous user */ input and continue, but was incomplete. Also */ provide additional information when user "isr" */ input is bad. */ - also as covariance data sets increase in size we continue to */ need larger arrays to work with these data (NRG/Petten request */ to handle TENDL-2010 files). */ ****************************************************************** */ * - NOTE: Petten request was for mxnpar=10000, but on a WinXP * */ * 32bit PC with 4GB physical memory the Intel v11.1 * */ * compiler/linker says the resulting executable is too * */ * large. Using mxnpar=7000 produces an executable that * */ * runs the standard test problem suite ok, but we may * */ * have to be reduce this parameter in the future to * */ * allow other arrays to increase. * */ ****************************************************************** */ upnea051: *i errorj.6734 data mpid /1,3,4,5,6,0/ *d up279.38,48 *d up342.52,53 *i up279.56 mm=0 *d up279.61,67 *d up287.9 do m=1,5 mm=mm+1 ii=l3+mpid(m)-1 cov(mm,mm)=a(ii) enddo *d up279.74,76 l3=lbg+6 l2=lbg+6 do n2=1,nrb *i up279.100 c mpar=nnn/nrb if(mpar.ne.5)then mm=0 do nr=1,nrb mbase=5*(nr-1) do m=1,mpar mm=mm+1 mmm=mbase+m cov(mm,mm)=cov(mmm,mmm) enddo enddo endif c if(nm.ne.0)then nw=ndigit *i up279.122 endif *d up290.49 e2=1.0+(eskip1-1.0)*5. */ upnea067: *i errorj.467 icov=0 *i errorj.472 c c ***check dictionary for required files if (mfcov.eq.30.and.(mf.ge.30 .and. mf.le.33)) icov=icov+1 if (mfcov.eq.31.and.mf.eq.31) icov=icov+1 if (mfcov.eq.33.and.(mf.eq.32.or.mf.eq.33)) icov=icov+1 if (mfcov.eq.34.and.mf.eq.34) icov=icov+1 if (mfcov.eq.35.and.mf.eq.35) icov=icov+1 if (mfcov.eq.40.and.mf.eq.40) icov=icov+1 *d errorj.479,480 if (nga.gt.nwi) & call error('errorr','too many reaction types for mf34.',' ') *i errorj.484 if (nlump.gt.nlmt) & call error('errorr','too many lumped reaction types',' ') *d up324.84,96 c *** check if there are data on file to process */ part of upnea070: *d up324.265 */ upnea071: *i up324.105 iwtt=iabs(iwt) if (iwtt.eq.1) then iw=-1 call reserv('wght',iw,iwght,a) read(nsysi,*) (a(iwght+i-1),i=1,iw) nr=nint(a(iwght+4)) np=nint(a(iwght+5)) iw=6+2*nr+2*np call releas('wght',iw,a) else if(iwtt.eq.4) then read(nsysi,*) eb,tb,ec,tc endif *d up329.100 write(strng1,*) 'illegal isr',isr call error('resprx',strng1,' ') */ make selected arrays larger: *d errorj.1369,1370 nwds=10000000 *d errorj.5967 parameter (maxnls=10,maxe=600000) *d up342.42 parameter (maxe=600000,mxnpar=7000,maxb=30000) *d errorj.6835 parameter(maxb=4000,mxnpar=100,maxe=600000) *d errorj.7067 parameter(maxe=600000) *d errorj.7259 parameter(maxe=600000) *ident up364 */ broadr -- 10+feb2011 */ - more space to support ever larger delta-T doppler broadening */ in one step. */ - make sure all thermal related variables are initialized. *d up176.18 dimension a(15000000) *d up176.20 namax=15000000 *i broadr.480 sc=0 sf=0 *d broadr.575,576 if ((sf+sc).ne.zero.and.(slf+slc).ne.zero) & etint=etint+(fnow*fnu*sf/(sf+sc) & +flast*fnul*slf/(slf+slc))*(enow-elast)/2 *ident up365 */ gaspr -- 30mar2011 */ - fixup several typos in gaspr when the many new mt values */ were inserted last Fall. *d up353.17 if (mth.eq.152)izr=izr-5 *d up353.27 if (mth.eq.162)izr=izr-1006 *d up353.37 if (mth.eq.172)izr=izr-1006 *d up353.47 if (mth.eq.182)izr=izr-2005 *d up353.57 if (mth.eq.192)izr=izr-3005 *ident up366 */ covr -- 30mar2011 */ - current coding for the correlation matrix uses a 6-element */ data statement to define the color-coded intervals. With */ this update we revise covr input to allow the user to define */ a new set of boundaries, with up to nine intervals for the */ color coding. Furthermore, previous color code changes */ (updates up111, 192 and 273) were not uniformly applied to */ both single and double precision versons of njoy99. We correct */ that omission here. *d up273.37 c * ---cards 2, 2', 2a, and 3a for nout.le.0 only (plot option) * *i covr.36 c * 2=color background and contours, plus * c * card 2' follows. * *i covr.37 c * * c * card 2' (only when icolor=2) * c * nlev,(tlev(i),i=1,nlev) * c * defines the number of correlation matrix * c * intervals and their boundaries. Zero is * c * assumed as the lower limit of the first * c * boundary, but the user must specify unity * c * as the upper limit of the last boundary. * c * nlev is a positive integer .le. 9. * c * default values (used when icolor=1) are: * c * 6,0.001,0.1,0.2,0.3,0.6,1.0 * *i covr.96 parameter(nlevmx=9) *d up273.44 dimension tlev(nlevmx) *d up273.46 data tlev/0.001d0,0.1d0,0.2d0,0.3d0,0.6d0,1.0d0,3*0.0d0/ *d up192.6 data tlev/0.001e0,0.1e0,0.2e0,0.3e0,0.6e0,1.0e0,3*0.0/ *i covr.162 nlev=6 if (icolor.eq.2) then read(nsysi,*)nlev,(tlev(i),i=1,nlev) if (nlev.gt.nlevmx) then write(strng,'('' nlev>'',i2,'' not allowed'')')nlevmx call error('covr',strng,' ') endif do i=2,nlev if (tlev(i).le.tlev(i-1)) then call error('covr', & 'tlev array must sequentially increase', & ' ') endif enddo if (tlev(nlev).ne.1) then write(strng,'(''reset tlev('',i2,'') from '',1pe11.4, & '' to 1.0'')')nlev,tlev(nlev) call mess('covr',strng,' ') tlev(nlev)=1 endif endif *d up273.48 *d covr.1407,1408 scale=10./(nlev-1) if (ilevel.gt.1) then t=float(nlev-ilevel) jpat=50-nint(scale*t) endif if (ilevel.lt.-1) then t=float(nlev+ilevel) jpat=60-nint(scale*t) endif *ident up367 */ acer -- 07apr2011 */ - coding in aplodd and aploxp for 3D distribution plots can get */ confused by near threshold delta function distributions and */ subsequent VIEWR execution to create plots can possibly abort, */ or even fill the user's scratch disk due to bad 3D axis limits. */ Revised coding skips past the near threshold delta function and */ sets axis limits that are more realistic. */ *d acer.20248 zmax1=0 zmax2=0 *d acer.20270 if (p.gt.zmax2.and.p.lt.zmax1)zmax2=p if (p.gt.zmax1) then zmax2=zmax1 zmax1=p endif *d acer.20275 if (zmax1.gt.zero) then if (zmax2/zmax1.lt.1.e-4) then zmax=zmax2 else zmax=zmax1 endif *d acer.20370 zmax1=0 zmax2=0 *d acer.20386 if (p.gt.zmax2.and.p.lt.zmax1)zmax2=p if (p.gt.zmax1) then zmax2=zmax1 zmax1=p endif *d acer.20391 if (zmax1.gt.zero) then if (zmax2/zmax1.lt.1.e-4) then zmax=zmax2 else zmax=zmax1 endif *d acer.20407 ppl=xss(1+nn+loci) *d acer.20505 zmax1=0 zmax2=0 *d acer.20523 if (f0.gt.zmax2.and.f0.lt.zmax1)zmax2=f0 if (f0.gt.zmax1) then zmax2=zmax1 zmax1=f0 endif *d acer.20526 if (zmax1.gt.zero) then if (zmax2/zmax1.lt.1.e-4) then zmax=zmax2 else zmax=zmax1 endif *d acer.20540 if (ppl.ge.zmin.and.ep.gt.xmax) xmax=ep *d acer.21524 zmax1=0 zmax2=0 *d acer.21541 if (pd.gt.zmax2.and.pd.lt.zmax1)zmax2=pd if (pd.gt.zmax1) then zmax2=zmax1 zmax1=pd endif *i acer.21545 if (zmax2/zmax1.lt.1.e-4) then zmax=zmax2 else zmax=zmax1 endif *ident up368 */ gaspr -- 15apr2011 */ - more space, more space ... my kingdom for more space (per */ J-C Sublet for processing large TENDL files). */ - found a long-standing error related to defining the lowest */ particle production threshold energy, plus a typo in one */ case for izr. *i gaspr.25 parameter (maxg=700000) *d up330.5 dimension egas(maxg),sgas(5,maxg) *d up330.7 *d gaspr.270,283 if (lr.eq.22) izr=izr-2004 if (lr.eq.23) izr=izr-6012 if (lr.eq.24) izr=izr-2005 if (lr.eq.25) izr=izr-2006 if (lr.ge.28.and.lr.le.30) izg=1 if (lr.eq.28) izr=izr-1001 if (lr.eq.29) izr=izr-4008 if (lr.eq.30) izr=izr-4009 if (lr.ge.32.and.lr.le.36) izg=1 if (lr.eq.32) izr=izr-1002 if (lr.eq.33) izr=izr-1003 if (lr.eq.34) izr=izr-2003 if (lr.eq.35) izr=izr-5010 if (lr.eq.36) izr=izr-5011 *ident up369 */ acer -- 13jun2011 */ - the current test for energy dependent yields in acelf6 can fail */ to be true if non-zero yield values in the endf formatted file */ are too small, causing "yield" to be set to zero which later */ causes a divide by zero error. we change the if test to be */ more sensitive. *d acer.6404 if (a(ii)-a(ii-2).ne.zero) ivar=1 *ident up370 */ purr -- 08sep2011 */ - correct several instances where update coding was inadvertantly */ placed within the "set sw" block. Reported by Petten (Hogenbirk). *d up332.7 *b purr.1101 parameter (mxns0=100) *d up332.17 *b purr.1498 parameter (mxns0=100) *d up332.24 *b purr.1619 parameter (mxns0=100) *d up332.31 *b up84.30 parameter (mxns0=100) *ident up371 */ leapr -- 08sep2011 */ - correct instance where update coding was inadvertantly placed */ within the "set sw" block. Reported by Petten (Hogenbirk). *d up304.14,up304.15 *i leapr.1106 character*60 strng external error *ident up372 */ groupr -- 08sep2011 */ - correct instances where update coding was inadvertantly placed */ within the "set sw" block. Reported by Petten (Hogenbirk). *d up339.66 *b groupr.1026 common/argcom1/lfs *d up257.88 *b groupr.8641 common/mainio/nsysi,nsyso,nsyse,ntty *ident up373 */ acer -- 08sep2011 */ - correct instance where update coding was inadvertantly placed */ within the "set sw" block. Also fix a variable name typo in */ a WRITE statement. Reported by Petten (Hogenbirk). */ - increase discrete photon array space (Petten, Hogenbirk). */ - expand coding logic associated with up367 for more robeust */ z-axis limit determination. (ack). *d up327.17 *b acer.8048 character*60 strng *b acer.7377 parameter (nwordg=10000) *d up360.17 *d up360.123 & nwordg,nd0 *d acer.20265 if (nn.ge.2) then *i acer.20271 else p=xss(loci+2) zmin=p zmax1=p zmax2=zmax1 *d up367.21 if (zmax2/zmax1.lt.1.e-4.and.zmax2.ne.0) then *d acer.20379,20380 loci=loci+1 if (nn.ge.2) then *i acer.20387 else p=xss(loci+2) zmin=p zmax1=p zmax2=zmax1 *d up367.37 if (zmax2/zmax1.lt.1.e-4.and.zmax2.ne.0) then *ident up374 */ heatr -- 07aug2012 */ - include recent nea mods, */ - nea76, K.Vignitchouk; average energy for lf=12 (it's in the endf */ manual but had never been put in the code). */ - nea79, D.L.Aldama (IAEA); include moreio for sections with more */ than npage words. */ - nea94, O.Cabellos; more space (an eternal request!). Also */ make elst coding in nheat, gheat and hout more precise */ to eliminate duplicate print to standard output (ack). */ Standard output for test problems 8 and 13 are changed, */ but the pendf tapes are unaffected. */ Caution: the change to rup at up193.6 may not work */ on 32-bit machines and single precision ... */ but we don't recommend anyone run this way. */ nea76: *i heatr.2169 c c ***law 12--energy dependent fission neutron spectrum (madland-nix) else if (lf.eq.12) then s=((a(lnext)+a(lnext+1))/2)+(4*theta/3) */ nea79: *i heatr.3832 if (nb.ne.0) then l=iraw do while (nb.ne.0) l=l+nwc call moreio(nin,0,0,c(l),nb,nwc) enddo endif *i heatr.3837 if (nb.ne.0) then l=iraw do while (nb.ne.0) l=l+nwc call moreio(nin,0,0,c(l),nb,nwc) enddo endif *i heatr.3877 if (nb.ne.0) then l=iraw do while (nb.ne.0) l=l+nwc call moreio(nin,0,0,c(l),nb,nwc) enddo endif */ nea94 & ack: *d heatr.94 dimension a(150000) *d heatr.110 namax=150000 *d heatr.114 ilmax=200 *d heatr.91 common/heat2/qa(3),tempr,efirst,elast,za,awr,elist(200) *d heatr.410 common/heat2/qa(3),tempr,efirst,elast,za,awr,elist(200) *d heatr.781 common/heat2/qa(3),tempr,efirst,elast,za,awr,elist(200) *d heatr.4405 common/heat2/qa(3),tempr,efirst,elast,za,awr,elist(200) *d heatr.4997 common/heat2/qa(3),tempr,efirst,elast,za,awr,elist(200) *d up43.12 data rup/1.000000001d0/ *d up193.6 data rup/1.000000001e0/ *d heatr.1083 e=sigfig(e,9,0) *d heatr.1113 elst=elst-elst/10000000 *d heatr.4558 e=sigfig(c(1),9,0) *d heatr.4716 e=sigfig(c(1),9,0) *i heatr.5081 e=sigfig(e,9,0) *d heatr.5112 if (e.ge.elist(ilist)) ilist=ilist+1 *ident up375 */ acer -- 09aug12 */ - up360 coding to handle a variable number of discrete photons */ may think primary photons are different when they aren't. */ make the comparison test a little less sensitive. We see */ this in endf/b-vii.1 hydrogen ... when running with binary */ files we're ok, when running with ascii files we are not! */ (Conlin, LANL). *d up360.11 data eps/1.e-5/ *d up360.13 data eps/1.d-5/ *ident up376 */ gaspr -- 09aug2012 */ - more space, more space ... my kingdom for more space (per */ J.Conlin when processing endf/b-vii.1 185Re). */ - correct a long-standing typo (nea096, Cabellos) *d up368.9 parameter (maxg=1000000) *d gaspr.522 izr=izr-3006 *ident up377 */ heatr -- 17aug2012 */ - add coding to handle polynomial coefficients for fission */ heating. the endf format was changed a couple of years */ ago and now its being used in endf/b-vii.1. */ - 12/11/2012: revise this update to use the mf1/mt451 */ nmod and lrel variables to restrict the */ quadratic term MeV to eV correction to */ endf/b-vii.1 files. *d heatr.411 *d up55.7 common/heat3/qdel,c458(72),cpoly(0:3) common/heat4/mt103,mt104,mt105,mt106,mt107,mt16,mt458,nply *i heatr.446 do i=1,72 c458(i)=0 enddo do i=0,3 cpoly(i)=0 enddo *i heatr.426 data rmevev/1.d-6/ *i heatr.430 data rmevev/1.e-6/ *d up225.9 if (iverf.eq.6) then if (c2h.gt.etop) etop=c2h lrel=l1h nmod=n2h endif *d heatr.584,591 nply=nint(a(iscr+3)) c save polynomial coefficients ... c0 & c1 terms are ok, c but in endf/b-vii.1 the c2 terms are mistakenly given c as if the energy will be given in MeV and therefore c need correction. do i=1,18 c458(i)=a(iscr+5+i) enddo if (nply.ge.1) then do i=19,36 c458(i)=a(iscr+5+i) enddo if (nply.gt.1) then do n=2,nply if (nmod.ne.7.or.lrel.ne.1) then efix=1 else efix=rmevev**(n-1) endif do i=1,18 c458(18*n+i)=a(iscr+5+18*n+i)*efix enddo enddo endif endif write(nsyso,'(/, & '' q correction for delayed fission energy''/)') qdel=c458(5)+c458(9)+c458(11) if (nply.eq.0) then qdel=c458(9)+c458(11) write(nsyso,'( & '' delayed gammas: '',1pe13.6/ & '' delayed betas: '',e13.6/ & '' total correction: '',e13.6)') & c458(9),c458(11),qdel else if (nply.eq.1) then if (c458(27).ne.0) then write(nsyso,'('' delayed gammas: '',1pe13.6, & '' + ('',e13.6,'')*E'')')c458(9),c458(27) else write(nsyso,'('' delayed gammas: '',1pe13.6)') & c458(9) endif if (c458(29).ne.0) then write(nsyso,'('' delayed betas: '',1pe13.6, & '' + ('',e13.6,'')*E'')')c458(11),c458(29) else write(nsyso,'('' delayed betas: '',1pe13.6)') & c458(11) if (c458(27).eq.0) then write(nsyso,'('' total correction: '',1pe13.6)') & c458(9)+c458(11) endif endif else if (nply.eq.2) then if (c458(27).ne.0.and.c458(45).ne.0) then write(nsyso,'('' delayed gammas: '',1pe13.6, & '' + ('',e13.6,'')*E + ('',e13.6,'')*E**2'')') & c458(9),c458(27),c458(45) else if (c458(27).ne.0.and.c458(45).eq.0) then write(nsyso,'('' delayed gammas: '',1pe13.6, & '' + ('',e13.6,'')*E'')')c458(9),c458(27) else if (c458(27).eq.0.and.c458(45).ne.0) then write(nsyso,'('' delayed gammas: '',1pe13.6, & '' + ('',e13.6,'')*E**2'')')c458(9),c458(45) else write(nsyso,'('' delayed gammas: '',1pe13.6)') & c458(9) endif if (c458(29).ne.0.and.c458(47).ne.0) then write(nsyso,'('' delayed betas: '',1pe13.6, & '' + ('',e13.6,'')*E + ('',e13.6,'')*E**2'')') & c458(11),c458(29),c458(47) else if (c458(29).ne.0.and.c458(47).eq.0) then write(nsyso,'('' delayed betas: '',1pe13.6, & '' + ('',e13.6,'')*E'')')c458(11),c458(29) else if (c458(29).eq.0.and.c458(47).ne.0) then write(nsyso,'('' delayed betas: '',1pe13.6, & '' + ('',e13.6,'')*E**2'')')c458(11),c458(47) else write(nsyso,'('' delayed betas: '',1pe13.6)') & c458(11) if (c458(27).eq.0.and.c458(45).eq.0) then write(nsyso,'('' total correction: '',1pe13.6)') & c458(9)+c458(11) endif endif else if (nply.eq.3) then write(nsyso,'('' uses a 3rd degree polynomial.'')') else call error('hinit','need more space for c458 and cpoly', & '') endif if (nply.ne.0) then do i=0,nply cpoly(i)=c458(1+i*18)+c458(3+i*18)+c458(7+i*18) enddo endif *d heatr.782 *d up55.13 common/heat3/qdel,c458(72),cpoly(0:3) common/heat4/mt103,mt104,mt105,mt106,mt107,mt16,mt458,nply *i up137.8 data qsmall/1.d-6/ *i heatr.816 data qsmall/1.e-6/ *i heatr.918 if (nply.ne.0) then qchk=abs(c458(15)-q)/q if (qchk.gt.qsmall) then q=c458(15) qendf=q call mess('nheat', & 'use mt458 ER for initial fission q',' ') endif endif *d heatr.921 & '(''changed q from '',1p,e14.6,'' to '',1p,e14.6)') *i heatr.1009 if (icon.lt.0) go to 179 *d heatr.1134,up115.32 c correct fission q for current incident energy c - use mt458 prompt nu energy rather than ebar*yld if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then if (nply.eq.0) then q0=q00-(yld-yld0)*fq1+fq2*e else q0=cpoly(0) pnue=c458(3) do i=1,nply q0=q0+cpoly(i)*e**i pnue=pnue+c458(3+i*18)*e**i enddo endif endif if (icon.ge.0) then ebal6=0 dame=dame*y if ((mtd.lt.18.or.mtd.gt.21).and.mtd.ne.38) then h=(e+q0-ebar*yld)*y else if (nply.eq.0) then h=(e+q0-ebar*yld)*y else h=(q0-pnue)*y endif endif else if ((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38) then if (nply.eq.0) then h=(e+q0-ebar*yld)*y else h=(q0-pnue)*y endif else h=ebar*yld*y endif *i heatr.1162 if (((mtd.ge.18.and.mtd.le.21).or.mtd.eq.38).and.nply.ne.0) & ebar=pnue/yld *i heatr.1766 common/heat4/mt103,mt104,mt105,mt106,mt107,mt16,mt458,nply *i heatr.1799 if (nply.gt.0) mt1=456 *i heatr.1801 c ... but when nply.ne.0, use prompt neutron data only *i up115.39 common/heat4/mt103,mt104,mt105,mt106,mt107,mt16,mt458,nply *d heatr.2573 290 if (mth.ne.102.or.(zap.eq.0.and.irec.eq.0)) then *i up115.44 if (nply.gt.0) mt1=456 *i up115.46 c ... but when nply.ne.0, use prompt neutron data only *d heatr.2639 if (mth.ne.102.or.(zap.eq.0.and.irec.eq.0)) then *ident up378 */ acer -- 27aug2012 */ - existing acelpp coding that stores law=4 pdf and cdf values uses */ sigfig to different precision ... not a good idea. we'll change */ the pdf sigfig to be as precise as the existing cdf. */ - cdf's usually start at 0.0, except when we have discrete data */ and there we want the initial cdf point to equal the first pdf. *d acer.7747 xss(k+n+nexd)=sigfig(xss(k+n+nexd)*renorm,9,0) *d acer.7839 xss(ki+n+nexd)=sigfig(xss(ki+n+nexd)*renorm,9,0) *d acer.7824,7825 if (nd.gt.0.and.ki.eq.1) then xss(ki+2*n+nexd)=xss(ki+n+nexd) elseif (ki.le.nd) then xss(ki+2*n+nexd)= & xss(ki+2*n-1+nexd)+a(iscr+7+ncyc*(ki-1)) endif *ident up379 */ groupr -- 28aug2012 */ - incorporate several changes proposed by Serco to AWE ... these */ are already in NJOY2012 and so this makes the codes consistent. */ - upwe1: make shade closer to unity so can account for the full */ downscatter range for hydrogen; */ - upwe9: fix indexing error; */ - upwe11: delete rerfc, replace with SLATEC erfc (as was done in */ broadr many, many years ago!); */ - upwd8: more space; */ - upwd10: force unit base interpolation for mf5 tabulated */ distributions */upwe1: *d groupr.6455 data shade/0.99999995d0/ *d groupr.6485 data shade/0.99999995e0/ */upwe9: *d groupr.5100,5101 if (ed.ge.c(jlo+1)*(1-small).and.ed.le.c(jhi+1)*(1+small)) then elo=c(jlo+1) ehi=c(jhi+1) go to 300 endif */upwe11: *d groupr.8982 external terpa,error,intega,hnab,erfc *d groupr.9003,9004 *d groupr.9063 bot=rp4*(1-expa*erfc(rc))-rc*exp(r4) *d groupr.9071 top=rl*exp(r3)-rh*exp(r4)-rp4*(expb*erfc(rh)-expc*erfc(rl)) *i groupr.9212 external erfc *d groupr.9233,9234 *d groupr.9239 fa(1)=1-expa*erfc(aa) *d groupr.9241 fb(1)=1-expb*erfc(bb) */upwd8: *d up107.688 dimension a(7000000) *d up107.690 iamax=7000000 */upwd10: *i groupr.8750 if (int.eq.2) int=22 *i groupr.8791 if (int.eq.2) int=22 *i groupr.8797 if (int.eq.2) int=22 *i groupr.8884 if (int.eq.2) int=22 *i groupr.8895 if (int.eq.2) int=22 *ident up380 */ heatr -- 11sept2012 */ - update 297 doesn't include all mt's in the dictionary when */ multiple heatr jobs are run. move the "overwrite" flag so it */ gets reset properly and allows the complete dictionary to be */ written. Note ... this was a dictionary mt omission only ... */ the mt sections have always been written to the output tape. *d up297.12 *i up297.15 iowr=0 *ident up381 */ reconr -- 12sept2012 */ - subroutine csunr2 can get lost when the number of energies */ per (l,j) state varies (reported by Koning for various tendl- */ 2012 files). *d reconr.3671 if ((i1+6).lt.jnow) then do while (a(i1+6).lt.e) i1=i1+6 enddo endif *ident up382 */ acer -- 12sept2012 */ - coding to allow users to redefine the zaid fails when the */ original suffix .ge. 0.5 (reported by Arcilla (BNL) and */ Trkov (ijs)). Unofficially fixed in upnea074. *d acer.17652 iza=int(zaid+0.001) *ident up383 */ purr -- 13sept2012 */ - purr can take a long time to execute. write a status message */ to the terminal periodically so the user knows we're still */ running. */ - 12/13/2012 - revised text *i purr.224 c c ***purr can run for a long time ... keep the user informed call timer(time) write(nsyse,'(2x,i5,'' of '',i5, & '' loops done for all temps & sig0s.'',19x,f8.1,''s'')') & ie,nunr,time *ident up384 */ acer -- 14sept2012 */ - declare a previously uninitialized variable used in charged */ particle processing. *i acer.7217 dco=0 *ident up385 */ errorr -- 20oct2012 */ - upgrade mf34 processing to ... */ - gracefully skip over any section where mt.ne.2; */ - check mf4 ltt, lct and mf34 lct flags ... */ - errorj coding assumes ltt=2 and */ - assumes mf4 lct=2 (cm data) plus mf34 lct=0 or 2 */ - if not true than grpav4 can't calculate the necessary */ data ... an upgrade to njoy2012 is required! *i errorj.7482 if (mtd.ne.2) then write(strng,'("skipping over mf=3, mt=",i3)')mtd call mess('grpav4',strng,'') goto 300 endif */ *i errorj.232 common/ang1/lct4,lct34,ltt4,ltt34 common/ang2/eltt4,emaxx *i errorj.263 logical*1 need1,need2 *i errorj.330 emaxx=2.e7 *i errorj.332 emaxx=1.5e7 *i errorj.336 call contio(nendf,0,0,b,nb,nw) if (c2h.gt.0) emaxx=c2h *i errorj.652 c c ***if an mfcov=34 job, check various mf4 and mf34 flags to see c whether grpav4 can calculate the required data. if (mfcov.eq.34) then need2=.false. !Assumed default, grpav4 is ok to use if (ltt4.eq.0.or.ltt4.eq.2) need2=.true. !cannot use grpav4 if (ltt4.eq.3.and. & (eltt4+elo).lt.egn(ngn+1)) need2=.true. !cannot use grpav4 if (need2 .and. .not.need1) & call error('errorr','upgrade to njoy2012 is required', & 'then include groupr with mf3,mt251') endif *i errorj.3747 common/ang1/lct4,lct34,ltt4,ltt34 common/ang2/eltt4,emaxx *i errorj.3783 c if (mfcov.eq.34) then c ***get ltt, lct and (maybe) transition energy, eltt4, between c Legendre and probability distribution representations. call findf(matd,4,2,nendf) call contio(nendf,0,0,a(iscr),nb,nw) ltt4=l2h call contio(nendf,0,0,a(iscr),nb,nw) lct4=l2h eltt4=emaxx if (ltt4.eq.3) then call tab2io(nendf,0,0,a(iscr),nb,nw) ii=n2h do i=1,ii call listio(nendf,0,0,a(iscr),nb,nw) enddo eltt4=c2h endif endif *ident up386 */ acer -- 15nov2012 */ - up375 used the wrong line number when attempting to redefine */ eps ... undo that mistake here. *d up375.10 character*66 strng *d up360.15 data eps/1.e-5/ *ident up387 */ purr -- 19nov2012 */ - the calculation of ctx in subroutine unrest includes a temperature */ ratio, tref/temp(_). we really should be taking the square root */ of this ratio, per the definition of cth in unresx. this impacts */ all probability tables that have not been calculated at 300K. */ (ornl, wiarda). *d purr.1822 ctx=cth(k)*sqrt(tref/temp(itemp)) *ident up388 */ acer -- 20nov2012 */ - an endf evaluation with missing mt sections among mf12 through */ mf15 can get stuck in an infinite loop. add a test to avoid */ this. *i acer.7555 mtdold=-1 *i acer.7560 if (mtd.ne.mtdold) then mtdold=mtd else call error('acelpp','mf14/mt infinite loop', & 'probable endf error') endif *ident up389 */ heatr -- 04-11dec2012 */ - upgrade nheat to process the new mt's (152 to 200) approved by */ csewg in 2010 ... mostly implemented in previous idents but we */ continue to find additional mods are necessary. */ - upgrade testing for expected mf12 mt sections in hconvr. omitted */ sections such as found in jendl-3.3 93nb or 207pb, for example, */ only show up later with cryptic error messages that are hard to */ understand. a companion update for acer's convr follows in */ ident up390. *d heatr.871 if (mt.gt.120.and.mt.lt.152) go to 110 if (mt.gt.200.and.mt.lt.600) go to 110 *i heatr.4105 parameter (nqmx=450) *i heatr.4107 dimension mtq(nqmx) dimension eeq(nqmx) *i heatr.4117 mt0=0 mt0old=0 *d heatr.4119 imax=50 *i heatr.4127 c c ***check for consistancy between mf3 mt's and, if present, mf12 c mt's. if any discrete inelastic levels are defined, we c expect to a sequential list of mt values from 51 to a maximum c of 90. Furthermore, for version 6 formatted endf files there c may be sequential mt values from 600 to a maximum of 648, 650 c to a maximum of 698, 700 to a maximum of 748, 750 to a maximum c of 798 and 800 to a maximum of 848 and 876 to 891 for outgoing c protons, deuterons, tritons, 3He, alpha particles and the c (n,2n) reaction, respectively. The allowed mt interval for c version 5 formatted files differs, and is accounted for in c the coding that follows. The absence of an expected mf3 mt c section is flagged as an error condition; the absence of an c expected mf12 mt section is noted in a message since, while c unusual, may be normal. do i=1,nqmx mtq(i)=0 eeq(i)=0 enddo mtnow=0 mtmiss=0 i10=0 nmf3=0 nmf12=0 10 continue call contio(nin,0,0,a(iscr),nb,nw) if (i10.eq.0) then i10=1 maths=math endif if (math.eq.0) go to 20 if (mfh.lt.3 .or. (mfh.gt.3.and.mfh.lt.12)) then call tofend(nin,0,0,a(iscr)) go to 10 endif if (mfh.gt.12) go to 20 if (mfh.eq.3) then if (mth.eq.51.or. & (iverf.ge.6.and.(mth.eq.601.or.mth.eq.651.or.mth.eq.701.or. & mth.eq.751.or.mth.eq.801.or.mth.eq.776)).or. & (iverf.le.5.and.(mth.eq.701.or.mth.eq.721.or.mth.eq.741.or. & mth.eq.761.or.mth.eq.781))) then mtnow=mth elseif ((mth.gt.51.and.mth.lt.91).or. & (iverf.ge.6.and.mth.gt.601.and.mth.lt.648).or. & (iverf.ge.6.and.mth.gt.651.and.mth.lt.698).or. & (iverf.ge.6.and.mth.gt.701.and.mth.lt.748).or. & (iverf.ge.6.and.mth.gt.751.and.mth.lt.798).or. & (iverf.ge.6.and.mth.gt.801.and.mth.lt.848).or. & (iverf.ge.6.and.mth.gt.876.and.mth.lt.890).or. & (iverf.le.5.and.mth.gt.701.and.mth.lt.718).or. & (iverf.le.5.and.mth.gt.721.and.mth.lt.738).or. & (iverf.le.5.and.mth.gt.741.and.mth.lt.758).or. & (iverf.le.5.and.mth.gt.761.and.mth.lt.778).or. & (iverf.le.5.and.mth.gt.781.and.mth.lt.798)) then if (mtnow+1.ne.mth) then mtmess=1 write(strng,'(''mf3, mt'',i2,'' is missing'')')mth-1 call mess('hconvr',strng,'') endif mtnow=mth endif call contio(nin,0,0,a(iscr),nb,nw) nmf3=nmf3+1 mtq(nmf3)=mth eeq(nmf3)=a(iscr+1) call tosend(nin,0,0,a(iscr)) go to 10 elseif (mfh.eq.12) then if (mth.eq.51.or. & (iverf.ge.6.and.(mth.eq.601.or.mth.eq.651.or.mth.eq.701.or. & mth.eq.751.or.mth.eq.801.or.mth.eq.776)).or. & (iverf.le.5.and.(mth.eq.701.or.mth.eq.721.or.mth.eq.741.or. & mth.eq.761.or.mth.eq.781))) then mtnow=mth elseif ((mth.gt.51.and.mth.lt.91).or. & (iverf.ge.6.and.mth.gt.601.and.mth.lt.648).or. & (iverf.ge.6.and.mth.gt.651.and.mth.lt.698).or. & (iverf.ge.6.and.mth.gt.701.and.mth.lt.748).or. & (iverf.ge.6.and.mth.gt.751.and.mth.lt.798).or. & (iverf.ge.6.and.mth.gt.801.and.mth.lt.848).or. & (iverf.ge.6.and.mth.gt.876.and.mth.lt.890).or. & (iverf.le.5.and.mth.gt.701.and.mth.lt.718).or. & (iverf.le.5.and.mth.gt.721.and.mth.lt.738).or. & (iverf.le.5.and.mth.gt.741.and.mth.lt.758).or. & (iverf.le.5.and.mth.gt.761.and.mth.lt.778).or. & (iverf.le.5.and.mth.gt.781.and.mth.lt.798)) then if (mtnow+1.ne.mth) then write(strng,'(''mf12, mt'',i2,'' may be missing'')')mth-1 call mess('hconvr',strng, & 'discrete photon data may be incomplete') endif mtnow=mth endif nmf12=nmf12+1 call tosend(nin,0,0,a(iscr)) go to 10 endif if (mtmess.ne.0) then call error('hconvr', & 'missing mf3 mt''s, probable endf error','') endif c c ***mt checks are done, rewind the endf tape and position c at the first record for this material 20 continue call repoz(nin) call findf(maths,1,451,nin) *d heatr.4182,4187 c c ***set base value for mt0 if (mth.ge.51.and.mth.le.91.and.mt0.ne.49) mt0=49 if (iverf.ge.6) then if (mth.ge.601.and.mth.le.649.and.mt0.ne.599) mt0=599 if (mth.ge.651.and.mth.le.699.and.mt0.ne.649) mt0=649 if (mth.ge.701.and.mth.le.749.and.mt0.ne.699) mt0=699 if (mth.ge.751.and.mth.le.799.and.mt0.ne.749) mt0=749 if (mth.ge.801.and.mth.le.849.and.mt0.ne.799) mt0=799 if (mth.ge.876.and.mth.le.891.and.mt0.ne.874) mt0=874 elseif (iverf.le.5) then if (mth.ge.701.and.mth.le.719.and.mt0.ne.699) mt0=699 if (mth.ge.721.and.mth.le.739.and.mt0.ne.719) mt0=719 if (mth.ge.741.and.mth.le.759.and.mt0.ne.739) mt0=739 if (mth.ge.761.and.mth.le.779.and.mt0.ne.759) mt0=759 if (mth.ge.781.and.mth.le.799.and.mt0.ne.779) mt0=779 endif c c ***load the a(ie+_) array with mf3 -q. Will overwrite with mf12 c mt data when possible (which should be always but if there is c a missing mf12 mt, we're covered). if (mt0.ne.mt0old) then do i=1,imax a(ie+i-1)=0 enddo mt0old=mt0 m1=mt0+2 if (mt0.eq.49) then m2=91 elseif (iverf.ge.6.and.mt0.ne.874) then m2=m1+48 elseif (iverf.ge.6.and.mt0.eq.874) then m2=m1+15 elseif (iverf.le.5) then m2=m1+17 endif nn=1 mttst=-1 do while (mttst.lt.m2.and.nn.le.nmf3) mttst=mtq(nn) if (mttst.ge.m1.and.mttst.le.m2) a(ie+mttst-mt0-1)=-eeq(nn) nn=nn+1 enddo endif *d heatr.4197 itst=0 if (ei.eq.zero.and.a(ie+k-1).eq.zero) then itst=1 elseif (ei.ne.zero) then if (abs(ei-a(ie+k-1))/ei.le.0.0001) itst=1 endif if (itst.ne.0) go to 225 *ident up390 */ acer -- 04-11dec2012 */ - upgrade testing for expected mf12 mt sections in convr. omitted */ sections such as found in jendl-3.3 93nb or 207pb, for example, */ only show up later with cryptic error messages that are hard to */ understand. a companion update for groupr's conver follows in */ ident up391. *i acer.3738 parameter (nqmx=450) *d up186.12,13 dimension eeth(nqmx) dimension mtth(nqmx) *d acer.3759 mt0=0 mt0old=0 imax=50 *d acer.3968,3973 c c ***make sure mt0 is correct for this range of mt's. if (mth.ge.51.and.mth.le.90.and.mt0.ne.49) mt0=49 if (iverf.ge.6) then if (mth.ge.601.and.mth.le.649.and.mt0.ne.599) mt0=599 if (mth.ge.651.and.mth.le.699.and.mt0.ne.649) mt0=649 if (mth.ge.701.and.mth.le.749.and.mt0.ne.699) mt0=699 if (mth.ge.751.and.mth.le.799.and.mt0.ne.749) mt0=749 if (mth.ge.801.and.mth.le.849.and.mt0.ne.799) mt0=799 if (mth.ge.876.and.mth.le.891.and.mt0.ne.874) mt0=874 elseif (iverf.le.5) then if (mth.ge.701.and.mth.le.719.and.mt0.ne.699) mt0=699 if (mth.ge.721.and.mth.le.739.and.mt0.ne.719) mt0=719 if (mth.ge.741.and.mth.le.759.and.mt0.ne.739) mt0=739 if (mth.ge.761.and.mth.le.779.and.mt0.ne.759) mt0=759 if (mth.ge.781.and.mth.le.799.and.mt0.ne.779) mt0=779 endif c c ***load the a(ie... array with mf3 -q. Will overwrite with mf12 c mt data when possible (which should be always but if there is c a missing mf12 mt, we're covered). if (mt0.ne.mt0old) then do i=1,imax a(ie+i-1)=0 enddo mt0old=mt0 m1=mt0+2 if (mt0.eq.49) then m2=91 elseif (iverf.ge.6.and.mt0.ne.874) then m2=m1+48 elseif (iverf.ge.6.and.mt0.eq.874) then m2=m1+15 elseif (iverf.le.5) then m2=m1+17 endif nn=1 mttst=-1 do while (mttst.lt.m2.and.nn.le.nnth) mttst=mtth(nn) if (mttst.ge.m1.and.mttst.le.m2) & a(ie+mttst-mt0-1)=eeth(nn)*awr/(awr+1) nn=nn+1 enddo endif *d acer.3986 if (ei.eq.zero.and.a(ie+k-1).eq.zero) idone=1 if (ei.ne.zero.and.abs(ei-a(ie+k-1))/ei.lt.0.0001) idone=1 *ident up391 */ groupr -- 04-11dec2012 */ - upgrade testing for expected mf12 mt sections in convr. omitted */ sections such as found in jendl-3.3 93nb or 207pb, for example, */ only show up later with cryptic error messages that are hard to */ understand. similar updates for heatr/hconr and acer/conver were */ made in up389 and up390, respectively. *d up257.18 parameter (mxnnth=350) *d groupr.7956 imax=50 *i groupr.7983 mt0old=0 *d groupr.8187,8192 c c ***make sure mt0 is correct for this range of mt's. if (mth.ge.51.and.mth.le.90.and.mt0.ne.49) mt0=49 if (iverf.ge.6) then if (mth.ge.601.and.mth.le.649.and.mt0.ne.599) mt0=599 if (mth.ge.651.and.mth.le.699.and.mt0.ne.649) mt0=649 if (mth.ge.701.and.mth.le.749.and.mt0.ne.699) mt0=699 if (mth.ge.751.and.mth.le.799.and.mt0.ne.749) mt0=749 if (mth.ge.801.and.mth.le.849.and.mt0.ne.799) mt0=799 if (mth.ge.876.and.mth.le.891.and.mt0.ne.874) mt0=874 elseif (iverf.le.5) then if (mth.ge.701.and.mth.le.719.and.mt0.ne.699) mt0=699 if (mth.ge.721.and.mth.le.739.and.mt0.ne.719) mt0=719 if (mth.ge.741.and.mth.le.759.and.mt0.ne.739) mt0=739 if (mth.ge.761.and.mth.le.779.and.mt0.ne.759) mt0=759 if (mth.ge.781.and.mth.le.799.and.mt0.ne.779) mt0=779 endif c c ***load the a(ie... array with mf3 -q. Will overwrite with mf12 c mt data when possible (which should be always but if there is c a missing mf12 mt, we're covered). if (mt0.ne.mt0old) then do i=1,imax a(ie+i-1)=0 enddo mt0old=mt0 m1=mt0+2 if (mt0.eq.49) then m2=91 elseif (iverf.ge.6.and.mt0.ne.874) then m2=m1+48 elseif (iverf.ge.6.and.mt0.eq.874) then m2=m1+15 elseif (iverf.le.5) then m2=m1+17 endif nn=1 mttst=-1 do while (mttst.lt.m2.and.nn.le.nnth) mttst=mtth(nn) if (mttst.ge.m1.and.mttst.le.m2) & a(ie+mttst-mt0-1)=eeth(nn)*awr/(awr+1) nn=nn+1 enddo endif *d groupr.8205 if (ei.eq.zero.and.a(ie+k-1).eq.zero) idone=1 if (ei.ne.zero.and.abs(ei-a(ie+k-1))/ei.lt.0.0001) idone=1 *ident up392 */ heatr -- 05dec2012 */ - detect cases where the capture recoil is given without an */ associated spectrum. use the photon recoil method to */ generate a capture recoil spectrum. without this fix, */ cases from TENDL2012 give zero for capture damage (this */ issue reported by J.C.Sublet). *i heatr.622 lf=l1h *i heatr.649 if (mt.eq.102.and.zap.gt.0.and.lf.eq.0) then write(strng,'(''mf6, mt'',i3, & '' has recoil with no spectrum'')') mt call mess('hinit',strng, & 'photon momentum recoil used.') mt6no(ii6)=nk endif *ident up393 */ acer -- 13dec2012 */ - we relaxed the value of eps in up375, but a side effect is that */ similar energy discrete photons might not be treated as being */ different (2.112380e6 versus 2.112370e6 in e71 50V mt16, for */ example). Make this check more sensitive. *d up360.82 if (r.le.0.001*eps) goto 111 *d up360.203 if (abs(r).lt.0.001*eps) then *ident up394 */ - groupr -- 10may2013 */ - coding in njoy99.379 to replace use of an expansion for the */ complementary error function with the more accurate SLATEC */ "erfc" routine was implemented incorrectly. */ - we fix that here, plus delete some no longer needed code. */ - thanks to NRG/Petten (Hogenbirk) and LLNL (Mattoon) for */ uncovering this error. */ - a similar fix appears in njoy2012.2. *d groupr.8986,8987 *d groupr.8995,8996 *d groupr.9062,up379.30 bot=rp4*(1-erfc(rc))-rc*exp(r4) *d groupr.9069,up379.32 top=rl*exp(r3)-rh*exp(r4)-rp4*(erfc(rh)-erfc(rl)) *d groupr.9217,9218 *d groupr.9226,9227 *d up379.37,groupr.9242 fa(1)=1-erfc(abs(aa)) if (aa.lt.zero) fa(1)=-fa(1) fb(1)=1-erfc(abs(bb)) if (bb.lt.zero) fb(1)=-fb(1) *ident up395 */ - acer -- 23july2013 */ - need more space for irdff processing, but the required change */ in acedos is in a common block so the same change occurs in */ multiple locations. *d up318.21 common/astore/a(2000000) *d up318.23 data namax/2000000/, nidmax/27/ *d up318.25 common/astore/a(2000000) *d up318.27 common/astore/a(2000000) *d up318.29 common/astore/a(2000000) *d up318.31 common/astore/a(2000000) *d up318.33 common/astore/a(2000000) *d up318.35 common/astore/a(2000000) *d up318.37 common/astore/a(2000000) *d up318.39 common/astore/a(2000000) *d up318.41 data namax/2000000/ *d up318.43 common/astore/a(2000000) *d up318.45 common/astore/a(2000000) *d up318.47 common/astore/a(2000000) *d up318.49 common/astore/a(2000000) *d up318.51 common/astore/a(2000000) *d up318.53 common/astore/a(2000000) *d up318.55 common/astore/a(2000000) *d up318.57 common/astore/a(2000000) *ident up396 */ - groupr -- 12august2013 */ - revisions to the flux calculator to keep njoy99 and njoy2012 */ consistent ... */ - up105.86 partially corrected a coding logic error in the */ flux calculator; we complete that correction here. *d groupr.3030 200 continue if (abs(e-el).lt.el*small.and.en.lt.0) then w=wl xc=xl enext=en go to 250 endif if (abs(e-en).lt.en*small) go to 240 *d groupr.3031 if (e.gt.el*(1-small).and.e.lt.en*(1+small)) go to 230 *i groupr.3034 el=en wl=wn xl=xn *d groupr.3038.3040 *ident vers */ update the version name and date */ to reflect the date of the latest modifications *d njoy.8,9 c * version 99.396 * c * 8 august 2013 * *d njoy.307 data vers/'99.396 '/