*cpl module *lst module *ident up1 */ heatr -- 8feb95 -- fix error in heating that occurs when iprint=0 *i heatr.816 if (icon.lt.0) go to 179 *d heatr.818 *i heatr.838 if (iprint.ne.1) go to 182 *ident up2 */ njoy -- 30may95 -- fix problem in messages *d njoy.384 l=len(mess) j=0 do 110 i=1,l *d njoy.385 *i njoy.386 j=i *d njoy.389,390 120 if (k.eq.0) j=0 lenr=j */ njoy -- 30may95 -- fix typo in definition *d njoy.3021 real xx,gammln *ident up3 */ heatr -- 30may95 -- define yields for more MT numbers *i heatr.1409 if (mtd.eq.11.or.mtd.eq.41) yld=2. *i heatr.1410 if (mtd.eq.38.or.mtd.eq.42) yld=3. if (mtd.eq.37) yld=4. *ident up4 */ groupr -- 30may95 -- define yields for more MT numbers *i groupr.3458 if (mth.eq.11.or.mth.eq.41) yld=2. *i groupr.3459 if (mth.eq.42) yld=3. */ groupr -- 30may95 -- define some new reaction names *d groupr.952,953 dimension ir(64),ip(7),i2(11) character*7 nr(64) *d groupr.961,963 data ir/11,16,17,22,23,24,25,28,29, 1 30,32,33,34,35,36,37,41,42,44,45, 2 108,109,111,112,113,114,115,116,117, *d groupr.970,972 data nr/'2nd','2n','3n','na','n3a','2na','3na','np','n2a', 1 '2n2a','nd','nt','nh','nd2a','nt2a','4n','2np','3np', 2 'n2p','npa','2a','3a','2p','pa','t2a','d2a','pd','pt','da', *d groupr.979 data nreac/64/,npart/11/,nproj/7/ *ident up5 */ acer -- 30may95 -- define multiplicities for more MT numbers *i acer.4856 if (mth.eq.11.or.mth.eq.41) n=2 *i acer.4857 if (mth.eq.42) n=3 */ acer -- 30may95 -- add some new reaction names *d acer.7149 2 '(n,1/2*3) ', '(n,1/2*4) ', '(n,x) ', '(n,2nd) ', *d acer.7157,7158 a '(n,x) ', '(n,2np) ', '(n,3np) ', '(n,n2p) ', b '(n,npa) ', '(n,x) ', '(n,2/2*1) ', '(n,2/2*2) ', *d acer.7178 5 '(n,pd) ', '(n,pt) ', '(n,da) ', '(n,x) ', */ acer -- 30may95 -- include mt91 in reference frame check *d acer.10016 if (((ic.ge.16.and.ic.lt.50).or.ic.eq.91).and.id.lt.0) then */ acer -- 31may95 -- fix mispositioned statement *d acer.11580 eth=2.53e-8 *ident up6 */ thermr -- 14jun95 -- fix ordering of declarations *d thermr.1160 *i thermr.1161 data ngrid/59/ *ident up7 */ errorr -- 14jun95 -- fix incorrect calls *d errorr.760 call error('gridd',' ',' ') *d errorr.763 call error('gridd',' ',' ') *d errorr.1881 call tosend(nscr,0,0,a(iscr)) *d errorr.2911 call tofend(ngout,0,0,a(iscr)) *ident up8 */ acer -- 22jun95 -- fix problem with zaid *i acer.1036 za=nint(za) *ident up9 */ acer -- 01jul95 -- fix error introduced in 91.104 that causes the */ elastic ang. dist. to be omitted for h-1. *d acer.4810 *d acer.4905 call skiprz(nin,-1) */ acer -- 01jul95 -- fix problem with shifting of points for */ mf6 generalized yield. *d acer.5336 if (k.eq.0.and.xn.lt.xnext) xnext=xn *d acer.5342,5343 *d acer.5355,5356 *i acer.5421 lgyl=igyl+2 if (j.eq.1) call terp1(xss(lgyl),xss(lgyl+ngyl), 1 xss(lgyl+1),xss(lgyl+1+ngyl),eyl*1.e-6,gyl,2) lgyl=igyl+1+ngyl if (j.eq.ngyl) call terp1(xss(lgyl-1),xss(lgyl-1+ngyl), 1 xss(lgyl),xss(lgyl+ngyl),eyl*1.e-6,gyl,2) */ acer -- 01jul95 -- still trying to get the changes made for */ mf6,law7 in 91.104 and 91.117 right! *d acer.5288,5289 1516 call tab1io(nin,0,0,a(jscr),nb,nw) nmu=l2h */ acer -- 01jul95 -- use more cosines for converting mf6 to */ law7 angle-energy format. *d acer.3395,3398 *d acer.3404 ncos=17 *d acer.3406 110 amu(i)=-1.+(i-1)*2./(ncos-1) */ acer -- 14jul95 -- provide for container storage *d acer.203 max3=800000 *d acer.4548 common /xsst/ n3,xss(800000) *d acer.6241 common /xsst/ n3,xss(800000) *d acer.7321 common /xsst/ n3,xss(800000) *d acer.7524 common /xsst/ n3,xss(800000) *d acer.8224 common /xsst/ n3,xss(800000) *d acer.8642 common /xsst/ n3,xss(800000) *d acer.8767 common /xsst/ n3,xss(800000) *d acer.8934 common /xsst/ n3,xss(800000) *d acer.9037 common /xsst/ n3,xss(800000) *d acer.9154 common /xsst/ n3,xss(800000) *d acer.9233 common /xsst/ n3,xss(800000) *d acer.9326 common /xsst/ n3,xss(800000) *d acer.9579 common /xsst/ n3,xss(800000) *d acer.9675 common /xsst/ n3,xss(800000) *d acer.9750 common /xsst/ n3,xss(800000) *d acer.9950 common /xsst/ n3,xss(800000) *d acer.10236 common /xsst/ n3,xss(800000) *ident up10 */ njoy -- 20jul95 -- use coarser tolerances for functions *d njoy.2881 parameter (maxit=100,eps=1.e-14,fpmin=1.e-30,euler=.5772156649) *d njoy.2965 parameter (itmax=100,eps=1.e-14) *d njoy.2992 parameter (itmax=100,eps=1.e-14,fpmin=1.e-30) *ident up11 */ groupr -- 11sep95 -- allow auto to find gas production reactions *d groupr.819 c ***exclude thermal reactions *d groupr.828 if (mtd.lt.150) go to 110 if (mtd.ge.203.and.mtd.le.207) go to 110 if (mtd.gt.300) go to 110 */ groupr -- 11sep95 -- process radioactivity cross sections. */ reactions on gendf are labeled with 10*iza+iso. */ 10/ automatically selects reactions given in mf8 */ using the mfd 90 and 100 series. *i groupr.205 c * 10/ do all radioactive isotope productions * *i groupr.232 common/rlist/mf4(20),mf6(20),mf12(20),mf13(20),mf18(20), 1 mf4r(6,20),mf6p(6,20),mf10f(20),mf10s(20),mf10i(20) *i groupr.429 izam=0 if (mfd.gt.90) izam=nint(a(iscr)) *d groupr.439 if (mfd.gt.6.and.mfd.lt.8) go to 381 if (mfd.gt.8.and.mfd.lt.10) go to 381 if (mfd.gt.10.and.mfd.lt.16) go to 381 *i groupr.457 izam=0 if (mfd.gt.90) izam=nint(a(iscr)) *d groupr.459 write(strng,'(''auto finds no reactions for mf='',i3)') mfd *d groupr.466 if (mfd.le.90) go to 405 if (izam.gt.0) go to 405 c find iza for radionuclide production mfn=mfd/10 mfi=mfd-10*mfn ir=1 402 if (mf10f(ir).eq.0) go to 404 if (mf10f(ir).eq.mfn.and.mf10s(ir).eq.mtd) go to 403 ir=ir+1 go to 402 403 if (mf10i(ir+mfi-1).eq.0) go to 404 izam=mf10i(ir+mfi-1) go to 405 404 call error('groupr','cannot find desired radionuclide', 1 'production information') 405 if (auto.eq.1) call namer(izap,izam,mfd,mtd,mtname) *d groupr.560 a(iscr+1)=izam *d groupr.687 40 format(7h for mf,i3,7h and mt,i3,1x,15a4) *d groupr.814 1 mf4r(6,20),mf6p(6,20),mf10f(20),mf10s(20),mf10i(20) *d groupr.846 220 if (mfd.ne.8) go to 225 *i groupr.849 c radioactive nuclide production (first time) 225 if (mfd.ne.10) go to 230 ir=1 if (mf10f(ir).eq.0) go to 280 mfd=10*mf10f(ir)+1 mtd=mf10s(ir) a(1)=mf10i(ir) go to 290 *d groupr.921 420 if (mfd.ne.36) go to 430 *i groupr.924 c radionuclide production (after first 10/ entry) 430 if (mfd.lt.91) go to 280 if (mfd.gt.90.and.mf.le.100) mmf=9 if (mfd.gt.100) mmf=10 mmi=mfd-10*mmf ir=1 is=0 432 if (mf10f(ir).eq.mmf.and.mf10s(ir).eq.mtd) is=is+1 if (is.eq.mmi) go to 433 ir=ir+1 go to 432 433 if (mf10f(ir+1).eq.0) go to 280 if (mf10f(ir+1).ne.mf10f(ir)) is=0 if (mf10s(ir+1).ne.mf10s(ir)) is=0 mfd=10*mf10f(ir+1)+is+1 mtd=mf10s(ir+1) a(1)=mf10i(ir+1) go to 290 *d groupr.941 subroutine namer(izad,izam,mfd,mtd,mtname) *i groupr.951 character*7 azam *i groupr.1077 if (mfd.gt.90) go to 160 *i groupr.1086 go to 170 160 izaa=izam/10 imm=izam-10*izaa if (imm.eq.0) then write(azam,'(i5)') izaa dummy='('//proj//','//reac//')-'//azam(1:5)//'-production.' else write(azam,'(i5,''m'',i1)') izaa,imm dummy='('//proj//','//reac//')-'//azam//'-production.' endif *d groupr.1110 1 mf4r(6,20),mf6p(6,20),mf10f(20),mf10s(20),mf10i(20) *d groupr.1140 1 mf4r(6,20),mf6p(6,20),mf10f(20),mf10s(20),mf10i(20) *d groupr.6321 1 mf4r(6,20),mf6p(6,20),mf10f(20),mf10s(20),mf10i(20) *i groupr.6341 imf10=1 *i groupr.6459 if (mfh.eq.8) go to 820 *i groupr.6908 c c ***examine contents of file 8 820 iza=nint(c1h) nk=n1h ik=0 825 ik=ik+1 call listio(nin,0,0,a(iscr),nb,nw) izan=nint(c1h) imf=l1h iis=l2h mf10f(imf10)=imf mf10s(imf10)=mth mf10i(imf10)=10*izan+iis imf10=imf10+1 if (ik.lt.nk) go to 825 go to 790 *i groupr.6918 mf10f(imf10)=0 mf10s(imf10)=0 mf10i(imf10)=0 *ident up12 */ matxsr -- 11 sep 95 -- radioactive isotope production. */ 10*iza+iso for the product is available. */ naming scheme for production reactions (6 char): */ cxxxxx for capture reactions (selfshielded), */ rxxxxx for other reactions, where */ xxxxx is a 5 character string iza+100*iso. *d matxsr.1139,1141 if (htyp.eq.hnthr.and.mf.ge.90) go to 420 if (mfv.eq.3.and.mf.gt.90) go to 365 if (mf.ne.mfv.and.mf.ne.(mfv+2).and. 1 mf.ne.mfm.and.mf.ne.(mfm+1)) go to 420 365 do 410 mz=1,nsigz *i matxsr.1142 if (mf.gt.90) go to 380 *d matxsr.1152 375 if (mf.gt.90) go to 380 if (mf.ne.2.or.mfm.lt.21) go to 380 *d matxsr.1308 subroutine hname(hreact,hp,mt,lr,izam) *d matxsr.1362 c ***determine name from mt number or radionuclide if (izam.gt.0) go to 340 *i matxsr.1476 go to 350 c c ***radionuclide production 340 ii=izam/10 mm=izam-10*ii jj=ii+100*mm if (mt.eq.102.and.jj.ge.10000) write(strng,'(''c'',i5)') jj if (mt.eq.102.and.jj.lt.10000) write(strng,'(''c0'',i4)') jj if (mt.ne.102.and.jj.ge.10000) write(strng,'(''r'',i5)') jj if (mt.ne.102.and.jj.lt.10000) write(strng,'(''r0'',i4)') jj *i matxsr.1540 izam=0 if (mf.gt.90) izam=nint(c2h) *d matxsr.1550 if (mf.ne.mfd.and.mf.le.90) go to 145 *d matxsr.1577 call hname(hvps(n1i),hp,mt,n1h,izam) *d matxsr.1894 call hname(hmtx(i),hp,mt,lr,0) *ident up13 */ acer -- 2 oct 94 -- turn on gas-production reactions *d acer.1920,1923 if (mt.gt.150.and.mt.lt.201) go to 260 if (mt.gt.207.and.mt.lt.221) go to 260 if (mt.ge.221.and.mt.le.260 1 .and.mt.ne.mti.and.mt.ne.mte) go to 260 if (mt.gt.250.and.mt.le.300) go to 260 *d acer.4595 if (mt.gt.150.and.mt.lt.201) go to 105 if (mt.gt.207) go to 105 *d acer.4717 if (mth.gt.150.and.mth.lt.201) go to 250 if (mth.gt.207.and.mth.ne.301) go to 250 *d acer.4762,4763 if (mth.ge.201.and.mth.le.207) go to 241 if (if12s.ne.0.or.if16s.ne.0) go to 241 xss(it+j)=xss(it+j)+s 241 n=n+1 *d acer.7146 equivalence (hndf9(1),hndf(401)) *d acer.7267 if (i.ge.201.and.i.le.207) i=i+200 *ident up14 */ njoy -- 28nov95 -- add gas production module *i njoy.77 c * gaspr...add gas production (mt203-207) to pendf * c * * *i njoy.269 c ***gaspr c ***add gas production (mt203-207) to pendf else if (module.eq.'gaspr') then call gaspr c *i njoy.3078 c subroutine gaspr c ****************************************************************** c * * c * add gas production reactions (mt203-207) to the pendf tape. * c * any old gas sections on the input pendf tape are deleted. * c * the directory is updated to show the new reactions. * c * this module can be run anywhere in the pendf preparation * c * sequence as long as it is somewhere after broadr. * c * * c *---input specifications (free format)---------------------------* c * * c * card 1 * c * nendf unit for endf/b tape * c * nin unit for input pendf tape * c * nout unit for output pendf tape * c * * c ****************************************************************** common/mainio/nsysi,nsyso,nsyse,ntty common/util/npage,iverf common/cont/c1h,c2h,l1h,l2h,n1h,n2h,math,mfh,mth,nsh,nsp,nsc dimension z(3) dimension a(10000) dimension b(6) dimension egas(20000),sgas(5,20000) dimension six(5000) maxg=20000 nscr1=10 c set iprint nonzero for gas production printout on listing iprint=0 c c ***read user input call timer(time) write(nsyso,10) time if (ntty.gt.0) write(ntty,10) time if (ntty.gt.0) write(ntty,'(/'' enter nendf, npend, noutp.'')') nz=3 call infree(nsysi,z,nz,4) nendf=nint(z(1)) npend=nint(z(2)) noutp=nint(z(3)) if (npend.lt.0) nscr1=-nscr1 if (npend*noutp.lt.0) call error('gaspr', 1 'npend and noutp must both be binary', 2 'or both be coded') write(nsyso,'(/'' units:'',3i6)') nendf,npend,noutp call openz(nendf,0) call openz(npend,0) call openz(noutp,1) call openz(nscr1,1) c c ***check endf tape for mf6,mt5 call repoz(nendf) call tpidio(nendf,0,0,a(1),nb,nw) call contio(nendf,0,0,a(1),nb,nw) za=c1h awr=c2h if (iverf.eq.4) nx=n2h if (iverf.ge.5) call contio(nendf,0,0,a(1),nb,nw) nsub=10 zain=1. awin=1. if (iverf.lt.6) go to 105 call contio(nendf,0,0,a(1),nb,nw) nsub=n1h zain=nsub/10 awin=c1h 105 call hdatio(nendf,0,0,a(1),nb,nw) matd=math 110 if (nb.eq.0) go to 120 call moreio(nendf,0,0,a(1),nb,nw) go to 110 120 if (iverf.ne.4) nx=n2h nw=nx call dictio(nendf,0,0,a(1),nb,nw) mf6mt5=0 do 130 i=1,nw,6 mfi=nint(a(1+i+1)) mti=nint(a(1+i+2)) if (mfi.gt.6) go to 140 if (mfi.eq.6.and.mti.eq.5) mf6mt5=1 130 continue 140 call repoz(nendf) if (mf6mt5.eq.0) go to 220 write(nsyso,'(/'' mf6,mt5 found'')') mfd=6 mtd=5 call findf(matd,mfd,mtd,nendf) call contio(nendf,0,0,a(1),nb,nw) nk=n1h lsix=1 l203=0 l204=0 l205=0 l206=0 l207=0 do 210 ik=1,nk call tab1io(nendf,0,0,a(1),nb,nw) izap=nint(c1h) law=l2h ll=1+nw 150 if (nb.eq.0) go to 152 call moreio(nendf,0,0,a(ll),nb,nw) ll=ll+nw go to 150 152 if (izap.eq.1001) then l203=lsix do 155 i=1,nw 155 six(lsix+i-1)=a(i) lsix=lsix+nw else if (izap.eq.1002) then l204=lsix do 157 i=1,nw 157 six(lsix+i-1)=a(i) lsix=lsix+nw else if (izap.eq.1003) then l205=lsix do 160 i=1,nw 160 six(lsix+i-1)=a(i) lsix=lsix+nw else if (izap.eq.2003) then l206=lsix do 162 i=1,nw 162 six(lsix+i-1)=a(i) lsix=lsix+nw else if (izap.eq.2004) then l207=lsix do 165 i=1,nw 165 six(lsix+i-1)=a(i) lsix=lsix+nw endif if (law.eq.0.or.law.eq.3.or.law.eq.4) go to 210 if (law.eq.6) go to 170 if (law.eq.1.or.law.eq.2.or.law.eq.5) go to 175 if (law.eq.7) go to 190 call error('file6','illegal endf6 law.',' ') 170 call contio(nendf,0,0,a,nb,nw) go to 210 175 call tab2io(nendf,0,0,a,nb,nw) ne=n2h do 185 ie=1,ne call listio(nendf,0,0,a,nb,nw) 180 if (nb.eq.0) go to 185 call moreio(nendf,0,0,a,nb,nw) go to 180 185 continue go to 210 190 call tab2io(nendf,0,0,a,nb,nw) ne=n2h do 205 ie=1,ne call tab2io(nendf,0,0,a,nb,nw) nmu=n2h do 200 imu=1,nmu call tab1io(nendf,0,0,a,nb,nw) 195 if (nb.eq.0) go to 200 call moreio(nendf,0,0,a,nb,nw) go to 195 200 continue 205 continue 210 continue c c ***loop over all temperatures on the pendf tape 220 call repoz(npend) call repoz(noutp) call tpidio(npend,noutp,0,a(1),nb,nw) itemp=0 225 itemp=itemp+1 call contio(npend,0,0,b(1),nb,nw) if (mfh.eq.0) go to 550 c c ***copy data up to the point where gas production will go call repoz(nscr1) call contio(0,nscr1,0,b(1),nb,nw) call tofend(npend,nscr1,0,a(1),nb,nw) call tofend(npend,nscr1,0,a(1),nb,nw) 230 call contio(npend,0,0,b(1),nb,nw) mfb=mfh mth=mth if (mth.gt.150.or.mth.eq.0) go to 235 call contio(0,nscr1,0,b(1),nb,nw) call tosend(npend,nscr1,0,a(1),nb,nw) go to 230 235 call contio(0,nscr1,0,b(1),nb,nw) c c ***check the reactions in file 3 for gas threshold call repoz(nscr1) call tofend(nscr1,0,0,a(1)) call tofend(nscr1,0,0,a(1)) thrg=1.e10 240 call contio(nscr1,0,0,a(1),nb,nw) if (mth.gt.117.or.mth.eq.0) go to 250 izg=0 izr=nint(za+zain) call gety1(0.,enext,idis,y,nscr1,a(1)) lr=l2h if (mth.ge.1.and.mth.le.4) go to 245 if (mth.eq.5.and.mf6mt5.eq.1) izg=1 if (mth.ge.6.and.mth.le.15) go to 245 if (mth.eq.16) izr=izr-2 if (mth.eq.17) izr=izr-3 if (mth.ge.18.and.mth.le.21) go to 245 if (mth.ge.22.and.mth.le.37) izg=1 if (mth.ge.38.and.mth.le.40) go to 245 if (mth.ge.41.and.mth.le.42) izg=1 if (mth.eq.43) go to 245 if (mth.ge.44.and.mth.le.45) izg=1 if (mth.ge.46.and.mth.le.50) go to 245 if (mth.ge.51.and.mth.le.91) then if (lr.ge.22.and.lr.le.25) izg=1 if (lr.ge.28.and.lr.le.30) izg=1 if (lr.ge.32.and.lr.le.36) izg=1 endif if (mth.ge.92.and.mth.le.101) go to 245 if (mth.ge.103.and.mth.le.116) izg=1 if (mth.ge.118) go to 245 if (izg.eq.0.and.izr.gt.2004) go to 245 if (enext.lt.thrg) thrg=enext 245 call tosend(nscr1,0,0,a(1)) go to 240 250 continue if (itemp.eq.1) 1 write(nsyso,'(/'' the gas production threshold is'', 2 1pe12.4,'' ev'')') thrg c c ***read through the scratch tape c ***collecting gas production in the process c ***use the energy grid of mt1 starting at thrg call repoz(nscr1) call tofend(nscr1,0,0,a(1)) call tofend(nscr1,0,0,a(1)) call contio(nscr1,0,0,a(1),nb,nw) call gety1(0.,enext,idis,y,nscr1,a(1)) enext=thrg i=0 260 i=i+1 if (i.gt.maxg) call error('gaspr', 1 'too many gas production energy points',' ') en=enext call gety1(en,enext,idis,y,nscr1,a(1)) egas(i)=en if (enext.lt.1.e10) go to 260 ngas=i if (itemp.eq.1) write(nsyso,'(/'' found'',i6,'' points'')') ngas call tosend(nscr1,0,0,a(1)) if (itemp.eq.1) write(nsyso, 1 '(/'' pendf mt mt203 mt204 mt205 mt206 mt207''/ 2 '' ________ _____ _____ _____ _____ _____'')') do 265 i=1,ngas do 265 j=1,5 sgas(j,i)=0. 265 continue c c ***loop over other reactions and c ***sum up gas production values 270 call contio(nscr1,0,0,a(1),nb,nw) if (mth.gt.117.or.mth.eq.0) go to 330 if (mth.le.4) go to 310 if (mth.ge.6.and.mth.le.15) go to 310 if (mth.ge.18.and.mth.le.21) go to 310 if (mth.ge.38.and.mth.le.40) go to 310 if (mth.ge.42.and.mth.le.50) go to 310 if (mth.ge.92.and.mth.le.101) go to 310 if (mth.ge.117) go to 310 call gety1(0.,enext,idis,y,nscr1,a(1)) lr=l2h izr=nint(za+zain) y203=0. y204=0. y205=0. y206=0. y207=0. if (mth.eq.5.and.mf6mt5.eq.1) then if (l203.gt.0) y203=111. if (l204.gt.0) y204=111. if (l205.gt.0) y205=111. if (l206.gt.0) y206=111. if (l207.gt.0) y207=111. else if (mth.eq.16) then izr=izr-2 else if (mth.eq.17) then izr=izr-3 else if (mth.eq.22) then izr=izr-2005 y207=1. else if (mth.eq.23) then izr=izr-6013 y207=3. else if (mth.eq.24) then izr=izr-2006 y207=1. else if (mth.eq.25) then izr=izr-2007 y207=1. else if (mth.eq.28) then izr=izr-1002 y203=1. else if (mth.eq.29) then izr=izr-4009 y207=2. else if (mth.eq.30) then izr=izr-4010 y207=2. else if (mth.eq.32) then izr=izr-1003 y204=1. else if (mth.eq.33) then izr=izr-1004 y205=1. else if (mth.eq.34) then izr=izr-2004 y206=1. else if (mth.eq.35) then izr=izr-5010 y204=1. y207=2. else if (mth.eq.36) then izr=izr-5011 y205=1. y207=2. else if (mth.eq.37) then izr=izr-4 else if (mth.eq.41) then izr=izr-1003 y203=1. else if (mth.eq.42) then izr=izr-1004 y203=1. else if (mth.eq.44) then izr=izr-2003 y203=2. else if (mth.eq.45) then izr=izr-3006 y203=1. y207=1. else if (mth.ge.51.and.mth.le.91) then izr=izr-1 if (lr.eq.22) then izr=izr-2004 y207=1. else if (lr.eq.23) then izr=izr-6012 y207=3. else if (lr.eq.24) then izr=izr-2005 y207=1. else if (lr.eq.25) then izr=izr-2006 y207=1. else if (lr.eq.28) then izr=izr-1001 y203=1. else if (lr.eq.29) then izr=izr-4008 y207=2. else if (lr.eq.30) then izr=izr-4009 y207=2. else if (lr.eq.32) then izr=izr-1002 y204=1. else if (lr.eq.33) then izr=izr-1003 y205=1. else if (lr.eq.34) then izr=izr-2003 y206=1. else if (lr.eq.35) then izr=izr-5010 y204=1. y207=2. else if (lr.eq.36) then izr=izr-5011 y205=1. y207=2. else if (lr.eq.39) then izr=izr else if (lr.eq.40) then izr=izr endif else if (mth.eq.103) then izr=izr-1001 y203=1. else if (mth.eq.104) then izr=izr-1002 y204=1. else if (mth.eq.105) then izr=izr-1003 y205=1. else if (mth.eq.106) then izr=izr-2003 y206=1. else if (mth.eq.107) then izr=izr-2004 y207=1. else if (mth.eq.108) then izr=izr-4008 y207=2. else if (mth.eq.109) then izr=izr-6012 y207=3. else if (mth.eq.111) then izr=izr-2002 y203=2. else if (mth.eq.112) then izr=izr-3005 y203=1. y207=1. else if (mth.eq.113) then izr=izr-5011 y205=1. y207=2. else if (mth.eq.114) then izr=izr-5010 y204=1. y207=2. else if (mth.eq.115) then izr=izr-2003 y203=1. y204=1. else if (mth.eq.116) then izr=izr-2004 y203=1. y205=1. endif if (izr.eq.1001) y203=y203+1. if (izr.eq.1002) y204=y204+1. if (izr.eq.1003) y205=y205+1. if (izr.eq.2003) y206=y206+1. if (izr.eq.2004) y207=y207+1. if (y203.eq.0..and.y204.eq.0..and.y205.eq.0. 1 .and.y206.eq.0..and.y207.eq.0.) go to 310 enext=thrg if (itemp.eq.1) 1 write(nsyso,'(i8,5(4x,f3.1))') mth,y203,y204,y205,y206,y207 i=0 280 i=i+1 en=egas(i) call gety1(en,enext,idis,y,nscr1,a(1)) ip=2 ir=1 if (y203.gt.100.) then call terpa(yyy,egas(i),xnext,idis,six(l203),ip,ir) sgas(1,i)=sgas(1,i)+yyy*y else sgas(1,i)=sgas(1,i)+y203*y endif if (y204.gt.100.) then call terpa(yyy,egas(i),xnext,idis,six(l204),ip,ir) sgas(2,i)=sgas(2,i)+yyy*y else sgas(2,i)=sgas(2,i)+y204*y endif if (y205.gt.100.) then call terpa(yyy,egas(i),xnext,idis,six(l205),ip,ir) sgas(3,i)=sgas(3,i)+yyy*y else sgas(3,i)=sgas(3,i)+y205*y endif if (y206.gt.100.) then call terpa(yyy,egas(i),xnext,idis,six(l206),ip,ir) sgas(4,i)=sgas(4,i)+yyy*y else sgas(4,i)=sgas(4,i)+y206*y endif if (y207.gt.100.) then call terpa(yyy,egas(i),xnext,idis,six(l207),ip,ir) sgas(5,i)=sgas(5,i)+yyy*y else sgas(5,i)=sgas(5,i)+y207*y endif if (i.lt.ngas) go to 280 310 call tosend(nscr1,0,0,a(1),nb,nw) go to 270 330 if (itemp.eq.1) 1 write(nsyso,'(/'' *** means that the yield is '', 2 ''energy dependent'')') c c ***print out the gas-production results if (iprint.eq.0) go to 355 if (itemp.gt.1) go to 355 write(nsyso,'(/'' gas production versus energy'')') do 350 i=1,ngas write(nsyso,'(1p6e12.4)') egas(i),sgas(1,i),sgas(2,i),sgas(3,i), 1 sgas(4,i),sgas(5,i) 350 continue 355 continue c c ***update the directory in file 1 call repoz(nscr1) nsec=0 n203=0 n204=0 n205=0 n206=0 n207=0 do 370 jg=1,5 do 360 i=1,ngas ii=i if (sgas(jg,i).ne.0) go to 365 360 continue go to 370 365 ii=ii-1 nsec=nsec+1 if (jg.eq.1) n203=ngas-ii+1 if (jg.eq.2) n204=ngas-ii+1 if (jg.eq.3) n205=ngas-ii+1 if (jg.eq.4) n206=ngas-ii+1 if (jg.eq.5) n207=ngas-ii+1 370 continue call contio(nscr1,0,0,a(1),nb,nw) if (iverf.eq.4) nx=n2h if (iverf.eq.4) a(6)=n2h+nsec call contio(0,noutp,0,a(1),nb,nw) if (iverf.ge.5) call contio(nscr1,noutp,0,a(1),nb,nw) if (iverf.lt.6) go to 375 call contio(nscr1,noutp,0,a(1),nb,nw) 375 call hdatio(nscr1,0,0,a(1),nb,nw) if (iverf.ne.4) nx=n2h if (iverf.ne.4) a(6)=n2h+nsec call hdatio(0,noutp,0,a(1),nb,nw) 380 if (nb.eq.0) go to 385 call moreio(nscr1,noutp,0,a(1),nb,nw) go to 380 385 nw=nx call dictio(nscr1,0,0,a(1),nb,nw) nold=0 do 387 i=1,nx j=6*(i-1) mfi=nint(a(j+3)) mti=nint(a(j+4)) if (mfi.eq.3.and.mti.ge.203.and.mti.le.207) nold=nold+1 387 continue if (nold.gt.0) 1 write(nsyso,'(/'' gas data on input pendf tape deleted'')') do 390 i=1,nx j=6*(i-1) if (nint(a(j+3)).gt.3) go to 395 if (nint(a(j+3)).eq.3.and.nint(a(j+4)).gt.117) go to 395 390 continue j=6*nx go to 401 395 ni=6*(nsec-nold) do 400 i=1,ni a(6*nx+ni+1-i)=a(6*nx+1-i) 400 continue 401 if (n203.eq.0) go to 402 a(j+1)=0. a(j+2)=0. a(j+3)=3. a(j+4)=203. a(j+5)=(n203+2)/3 a(j+6)=1 j=j+6 402 if (n204.eq.0) go to 403 a(j+1)=0. a(j+2)=0. a(j+3)=3. a(j+4)=204. a(j+5)=(n204+2)/3 a(j+6)=1 j=j+6 403 if (n205.eq.0) go to 404 a(j+1)=0. a(j+2)=0. a(j+3)=3. a(j+4)=205. a(j+5)=(n205+2)/3 a(j+6)=1 j=j+6 404 if (n206.eq.0) go to 405 a(j+1)=0. a(j+2)=0. a(j+3)=3. a(j+4)=206. a(j+5)=(n206+2)/3 a(j+6)=1 j=j+6 405 if (n207.eq.0) go to 410 a(j+1)=0. a(j+2)=0. a(j+3)=3. a(j+4)=207. a(j+5)=(n207+2)/3 a(j+6)=1 j=j+6 410 nw=nx+nsec-nold call dictio(0,noutp,0,a(1),nb,nw) call tofend(nscr1,noutp,0,a(1)) call tofend(nscr1,noutp,0,a(1)) c c ***copy file 3 down to the gas production area 420 call contio(nscr1,0,0,b(1),nb,nw) mfb=mfh mtb=mth if (mth.gt.117.or.mth.eq.0) go to 430 call contio(0,noutp,0,b(1),nb,nw) call tosend(nscr1,noutp,0,a(1),nb,nw) go to 420 c c ***write the gas production sections in file 3 430 do 500 jg=1,5 do 440 i=1,ngas ii=i if (sgas(jg,i).ne.0) go to 450 440 continue go to 500 450 i=ii-1 if (i.eq.0) i=1 if (jg.eq.1) mth=203 if (jg.eq.2) mth=204 if (jg.eq.3) mth=205 if (jg.eq.4) mth=206 if (jg.eq.5) mth=207 math=matd mfh=3 a(1)=za a(2)=awr a(3)=0. a(4)=0. a(5)=0. a(6)=0. nw=6 call contio(0,noutp,0,a(1),nb,nw) np=ngas-i+1 a(1)=0. a(2)=0. a(3)=0. a(4)=0. a(5)=1 a(6)=np a(7)=np a(8)=2 k=8 istart=i 455 iend=ngas if ((iend-istart).ge.npage/2) iend=istart+npage/2-1 j=k-1 ib=istart-1 460 j=j+2 ib=ib+1 a(j)=egas(ib) a(j+1)=sgas(jg,ib) if (ib.lt.iend) go to 460 nw=j+1 if (k.eq.0) go to 470 k=0 call tab1io(0,noutp,0,a(1),nb,nw) if (nb.eq.0) go to 480 istart=iend+1 go to 455 470 call moreio(0,noutp,0,a(1),nb,nw) if (nb.eq.0) go to 480 istart=iend+1 go to 455 480 call asend(noutp,0) 500 continue c c ***copy rest of this temperature to output file c ***delete any gas sections on the input pend file mfh=mfb mth=mtb nw=6 520 if (mfh.eq.0) go to 530 if (mth.ge.203.and.mth.le.207) go to 525 call contio(0,noutp,0,b(1),nb,nw) call tosend(npend,noutp,0,a(1),nb,nw) call contio(npend,0,0,b(1),nb,nw) go to 520 525 call tosend(npend,0,0,a(1),nb,nw) call contio(npend,0,0,b(1),nb,nw) go to 520 530 call contio(0,noutp,0,b(1),nb,nw) call tomend(npend,noutp,0,a(1),nb,nw) go to 225 550 call contio(0,noutp,0,b(1),nb,nw) c c ***finished write(nsyso,'(/'' found'',i2,'' temperatures'')') itemp-1 call timer(time) write(nsyso,20) time if (ntty.gt.0) write(ntty,30) time c 10 format(/' gaspr...', 1 'add gas production cross sections', 2 27x,f8.1,1hs) 20 format(69x,f8.1,1hs/1x,7(10h**********),7h*******) 30 format(/1x,10h**********,f8.1,1hs,11h **********) return end *ident up15 */ njoy -- 8jan96 -- fix gami function. */ this problem only affects materials that use */ the madland-nix fission law in mf5, such as */ am241 from endf/b-vi.3. *d njoy.2946,2947 call gser(gamser,a,x,gln) gammp=gamser *d njoy.2950,2951 call gcf(gammcf,a,x,gln) gammp=1.-gammcf *i njoy.2952 gami=exp(gln)*gammp *d njoy.2956 subroutine gser(gamser,a,x,gln) *d njoy.2983 subroutine gcf(gammcf,a,x,gln) *d njoy.3028 ser=1.000000000190015d0 *d njoy.3035 ser=1.000000000190015 *ident up16 */ groupr -- 8jan96 -- allow for more mf12 gammas. */ the previous limit of 100 discrete gammas */ is ok for endf/b-vi, but it causes trouble */ for a local evaluation with especially */ detailed mt102 gammas. *d groupr.6191 dimension loca(300) *d groupr.6193 data nylmax/300/ *ident up17 */ broadr -- 8jan96 -- fix problem with mt4. */ this problem occurs when there is resolved */ unresolved overlap in an elemental evaluation */ (e.g., endf/b-vi wnat), and it shows up as */ bogus numbers in MT4 for the overlap range. *d broadr.394 if (mth.eq.4.and.mt4br.eq.1) go to 275 *ident up18 */ dtfr -- 9jan96 -- make sure that chi is written out. */ the problem occurs for materials with energy */ independent fission matrices and no delayed */ fission (e.g., pa233 and np239 in endf/b-vi). *d dtfr.395 cnorm=cnorm+cnm*spect(k) ids(ked)=ked 395 continue *ident up19 */ acer -- 9jan96 -- add damage to the ace file. */ this just requires looking for mt444, */ providing a name string for damage, */ and updating the plotting routine. *d up13.11 if (mt.gt.207.and.mt.ne.444) go to 105 *d up13.14 if (mth.gt.207.and. 1 mth.ne.301.and.mth.ne.444) go to 250 *d acer.4760 if (mth.eq.444) s=1.e-6*s *i up13.16 if (mth.eq.444) go to 241 *d acer.7133 character*10 hndf(408) *i acer.7137 character*10 hndf10(1) *i up13.21 equivalence (hndf10(1),hndf(408)) *i acer.7268 if (mt.eq.444) i=408 *i acer.7274 else if (mt.eq.444) then name=hndf(408) *d acer.10285 write(nout,'(''*

rincipal cross sections*/'')') *d acer.10376 if (ymax.eq.ymin) go to 229 *i acer.10409 c c ***plot log-log damage 229 xmin=1.e10 xmax=0. ymin=1.e10 ymax=-1.e10 n=0 do 231 i=1,ntr mt=nint(xss(mtr+i-1)) if (mt.ne.444) go to 231 k=nint(xss(lsig+i-1)+sig-1) n=nint(xss(k+1)) iaa=nint(xss(k)) 231 continue if (n.eq.0) go to 235 do 232 i=1,n e=xss(iaa+i-1) dam=xss(k+2+i-1) if (dam.lt.1.e-10) dam=1.e-10 if (e.lt.xmin) xmin=e if (e.gt.xmax) xmax=e if (dam.lt.ymin) ymin=dam if (dam.gt.ymax) ymax=dam 232 continue if (ymax.eq.ymin) go to 235 call ascll(xmin,xmax) if (ymin.lt.ymax/1.e6) ymin=ymax/1.e8 call ascll(ymin,ymax) write(nout,'(''1/'')') it=1 do 233 i=1,70 if (hk(i:i).ne.' ') it=i 233 continue write(nout,'(''*<'',a,''>*/'')') hk(1:it) write(nout,'(''*amage*/'')') write(nout,'(''4 0 2 1/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,1. write(nout,'(''*nergy (e)*/'')') write(nout,'(1p,3e12.3,''/'')') ymin,ymax,1. write(nout,'(''*amage (e-barns)*/'')') write(nout,'(''/'')') write(nout,'(''*damage*/'')') write(nout,'(''0/'')') thin=10**(log10(xmax/xmin)/2500) xlast=1.e-12 j=0 do 234 i=1,n e=xss(iaa+i-1) if (nes.gt.2500.and.e.lt.thin*xlast) go to 234 if (j.ge.2500) go to 234 dam=xss(k+2+i-1) if (dam.lt.ymin) go to 234 if (dam.lt.0.) dam=1.e-10 j=j+1 write(nout,'(1p,2e14.6,''/'')') e,dam xlast=e 234 continue write(nout,'(''/'')') *i acer.10418 if (mt.gt.207) go to 250 *i acer.10453 if (mt.gt.207) go to 265 *d acer.10516 write(nout,'(''*

rincipal cross sections*/'')') *d acer.10608 if (ymin.eq.0..and.ymax.eq.0.) go to 429 *i acer.10642 c c ***plot lin-lin damage 429 xmin=1.e10 xmax=0. ymin=1.e10 ymax=-1.e10 n=0 do 431 i=1,ntr mt=nint(xss(mtr+i-1)) if (mt.ne.444) go to 431 k=nint(xss(lsig+i-1)+sig-1) n=nint(xss(k+1)) iaa=nint(xss(k)) 431 continue if (n.eq.0) go to 435 do 432 i=1,n e=xss(iaa+i-1) if (e.lt..20) go to 432 dam=xss(k+2+i-1) if (dam.lt.0.) dam=1.e-10 if (e.lt.xmin) xmin=e if (e.gt.xmax) xmax=e if (dam.lt.ymin) ymin=dam if (dam.gt.ymax.and.e.gt.1.) ymax=dam 432 continue if (ymin.eq.0..and.ymax.eq.0.) go to 435 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/'')') it=1 do 433 i=1,70 if (hk(i:i).ne.' ') it=i 433 continue write(nout,'(''*<'',a,''>*/'')') hk(1:it) write(nout,'(''*amage*/'')') write(nout,'(''1 0 2 1/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,xstep write(nout,'(''*nergy (e)*/'')') write(nout,'(1p,3e12.3,''/'')') ymin,ymax,ystep write(nout,'(''*amage (e-barns)*/'')') write(nout,'(''/'')') write(nout,'(''*damage*/'')') write(nout,'(''0/'')') thin=(xmax-xmin)/2500 xlast=1.e-12 j=0 do 434 i=1,n e=xss(iaa+i-1) if (e.lt..20) go to 434 if (nes.gt.2500.and.e.lt.xlast+thin.and.i.ne.nes) go to 434 if (j.ge.2500) go to 434 dam=xss(k+2+i-1) if (dam.lt.0.) dam=1.e-10 j=j+1 write(nout,'(1p,2e14.6,''/'')') e,dam xlast=e 434 continue write(nout,'(''/'')') *i acer.10651 if (mt.gt.207) go to 439 *i acer.10689 if (mt.gt.207) go to 445 */ acer -- 9jan96 -- add expanded plots of resonance data *i acer.10360 c c ***plot expanded resonance data for total if (nes.lt.1500) go to 183 ii1=200 e1=xss(esz-1+ii1) j1=alog10(e1) if (j1.lt.0) j1=j1-1 e1=10.**j1 169 if (e1.lt.1.e-6) e1=1.e-6 e2=100.*e1 if (e2.gt.10.) e2=10. ii1=0 ii2=0 do 171 i=1,nes if (ii1.eq.0.and.xss(esz-1+i).gt.e1) ii1=i if (ii2.eq.0.and.xss(esz-1+i).gt.e2) ii2=i 171 continue ii2=ii2-1 nn=ii2-ii1+1 xmin=1.e10 xmax=1.e-10 ymin=1.e10 ymax=1.e-10 do 172 i=ii1,ii2 e=xss(esz-1+i) tot=xss(esz+nes-1+i) if (e.lt.xmin) xmin=e if (e.gt.xmax) xmax=e if (tot.gt.0..and.tot.lt.ymin) ymin=tot if (tot.gt.0..and.tot.gt.ymax) ymax=tot 172 continue call ascll(xmin,xmax) if (ymin.lt.ymax/1.e6) ymin=ymax/1.e6 call ascll(ymin,ymax) write(nout,'(''1/'')') it=1 do 173 i=1,70 if (hk(i:i).ne.' ') it=i 173 continue write(nout,'(''*<'',a,''>*/'')') hk(1:it) write(nout,'(''*resonance total cross section*/'')') write(nout,'(''4 0 2 1/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,1. write(nout,'(''*nergy (e)*/'')') write(nout,'(1p,3e12.3,''/'')') ymin,ymax,1. write(nout,'(''*ross section (barns)*/'')') write(nout,'(''/'')') write(nout,'(''*total*/'')') write(nout,'(''0/'')') thin=10**(log10(xmax/xmin)/2500) xlast=1.e-12 j=0 do 174 i=ii1,ii2 e=xss(esz-1+i) if (nn.gt.2500.and.e.lt.thin*xlast) go to 174 if (j.ge.2500) go to 174 tot=xss(esz+nes-1+i) if (tot.lt.ymin) go to 174 j=j+1 write(nout,'(1p,2e14.6,''/'')') e,tot xlast=e 174 continue write(nout,'(''/'')') if (ii2.lt.nes-200.and.e2.lt.10.) then e1=e2 go to 169 endif c c ***plot expanded resonance data for fission and capture ii1=200 e1=xss(esz-1+ii1) j1=alog10(e1) if (j1.lt.0) j1=j1-1 e1=10.**j1 168 if (e1.lt.1.e-6) e1=1.e-6 e2=100.*e1 if (e2.gt.10.) e2=10. ii1=0 ii2=0 do 175 i=1,nes if (ii1.eq.0.and.xss(esz-1+i).gt.e1) ii1=i if (ii2.eq.0.and.xss(esz-1+i).gt.e2) ii2=i 175 continue ii2=ii2-1 nn=ii2-ii1+1 nnf=0 do 176 i=1,ntr mt=nint(xss(mtr+i-1)) if (mt.eq.18) then kf=nint(xss(lsig+i-1)+sig-1) nnf=nint(xss(kf+1)) iif=nint(xss(kf)) else if (mt.eq.102) then kc=nint(xss(lsig+i-1)+sig-1) nnc=nint(xss(kc+1)) iic=nint(xss(kc)) endif 176 continue xmin=1.e10 xmax=1.e-10 ymin=1.e10 ymax=1.e-10 nofiss=1 do 177 i=ii1,ii2 e=xss(esz-1+i) fiss=0. if (nnf.gt.0.and.i.ge.iif) fiss=xss(kf+2+i-iif) if (fiss.gt.0.) nofiss=0 cap=xss(kc+2+i-iic) if (e.lt.xmin) xmin=e if (e.gt.xmax) xmax=e if (fiss.gt.0..and.fiss.lt.ymin) ymin=fiss if (fiss.gt.0..and.fiss.gt.ymax) ymax=fiss if (cap.gt.0..and.cap.lt.ymin) ymin=cap if (cap.gt.0..and.cap.gt.ymax) ymax=cap 177 continue call ascll(xmin,xmax) if (ymin.lt.ymax/1.e6) ymin=ymax/1.e6 call ascll(ymin,ymax) write(nout,'(''1/'')') it=1 do 178 i=1,70 if (hk(i:i).ne.' ') it=i 178 continue write(nout,'(''*<'',a,''>*/'')') hk(1:it) write(nout,'(''*resonance absorption cross sections*/'')') write(nout,'(''4 0 2 1/'')') write(nout,'(1p,3e12.3,''/'')') xmin,xmax,1. write(nout,'(''*nergy (e)*/'')') write(nout,'(1p,3e12.3,''/'')') ymin,ymax,1. write(nout,'(''*ross section (barns)*/'')') write(nout,'(''/'')') write(nout,'(''*capture*/'')') write(nout,'(''0/'')') thin=10**(log10(xmax/xmin)/2500) xlast=1.e-12 j=0 do 179 i=ii1,ii2 e=xss(esz-1+i) if (nn.gt.2500.and.e.lt.thin*xlast) go to 179 if (j.ge.2500) go to 179 cap=xss(kc+2+i-iic) if (cap.lt.ymin) go to 179 j=j+1 write(nout,'(1p,2e14.6,''/'')') e,cap xlast=e 179 continue write(nout,'(''/'')') if (nofiss.eq.1) go to 182 write(nout,'(''2/'')') write(nout,'(''0 0 1/'')') write(nout,'(''*fission*/'')') write(nout,'(''0/'')') xlast=1.e-12 j=0 do 181 i=ii1,ii2 e=xss(esz-1+i) if (nn.gt.2500.and.e.lt.thin*xlast) go to 181 if (j.ge.2500) go to 181 if (i.lt.iif) go to 181 fiss=xss(kf+2+i-iif) if (fiss.lt.ymin) go to 181 j=j+1 write(nout,'(1p,2e14.6,''/'')') e,fiss xlast=e 181 continue write(nout,'(''/'')') 182 if (ii2.lt.nes-200.and.e2.lt.10.) then e1=e2 go to 168 endif 183 continue */ acer -- 9jan96 -- combine continuum, disappearance and gas */ production plots. change the vertical scale */ for lin-lin plots. *i acer.10410 c *make pages showing the nonthreshold reactions 235 mtlast=0 c *d acer.10412 236 xmin=1000 *i acer.10417 if (nlev.eq.5) go to 250 *i acer.10418 if (mt.le.mtlast) go to 250 *i acer.10452 if (nlev.eq.5) go to 265 *i acer.10453 if (mt.le.mtlast) go to 265 *i acer.10457 mtl=mt *i acer.10480 mtlast=mtl c c ***continue the loop over nonthreshold reactions go to 236 *d acer.10496 if (tot.gt.ymax.and.e.gt.1.) ymax=tot *d acer.10498 if (abs.gt.ymax.and.e.gt.1.) ymax=abs *d acer.10500 if (elas.gt.ymax.and.e.gt.1.) ymax=elas *d acer.10504 if (gprod.gt.ymax.and.e.gt.1.) ymax=gprod *d acer.10606 if (heat.gt.ymax.and.e.gt.1.) ymax=heat *i acer.10643 c ***make pages showing the nonthreshold reactions 435 mtlast=0 c *d acer.10645 436 xmin=1000 *i acer.10650 if (nlev.eq.5) go to 439 *i acer.10651 if (mt.le.mtlast) go to 439 *d acer.10665 if (y.gt.ymax.and.x.gt.1.) ymax=y *i acer.10688 if (nlev.eq.5) go to 445 *i acer.10689 if (mt.le.mtlast) go to 445 *i acer.10693 mtl=mt *i acer.10714 mtlast=mtl c c ***continue the loop over nonthreshold reactions go to 436 *d acer.10743 if (y.gt.ymax.and.x.gt.1.) ymax=y *d acer.10801 c ***make the pages showing the threshold reactions *d acer.10818 if (mt.gt.207) go to 550 *d acer.10820 *i acer.10823 if (xss(iaa).lt.1.e-6) go to 550 nlev=nlev+1 *d acer.10847 write(nout,'(''*hreshold reactions*/'')') *d acer.10861 if (mt.gt.207) go to 565 *d acer.10863,10864 *i acer.10867 if (xss(iaa).lt.1.e-6) go to 565 mtl=mt nlev=nlev+1 *d acer.10892 c ***continue the loop over the threshold reactions *d acer.10971,11060 585 continue */ acer -- 9jan96 -- fix control over translation to lf=7 format. */ this error causes problems for be-9. *d acer.2154 if (lf.eq.1.and.lct.eq.1) new6=1 *ident up20 */ viewr -- 11jan96 -- fix incorrect offsets for landscape mode. */ the effect is that characters don't line up */ with line elements correctly. *d viewr.3653,3655 u1=72*x+36+18 rr=72*(x+r)+36+18-u1 v1=72*y+36+18 *d viewr.3688,3689 u=72*x+36+18 v=72*y+36+18 */ viewr -- 11jan96 -- fix subscript problem. */ the level of the text doesn't recover */ properly after a subscript. *d viewr.2692 *d viewr.2709 *d viewr.2718 *i viewr.2719 delta=celev *d viewr.2866 *d viewr.2883 *d viewr.2892 *i viewr.2893 delta=celev */ viewr -- 11jan96 -- change the default size for subscripts */ and superscripts to make them more readable. *d viewr.2722 temp='.7' *d viewr.2896 temp='.7' */ viewr -- 11jan96 -- don't put log labels too close. */ this logic will space close labels like */ every other power of ten, every third */ power, etc., depending on sizes. *i viewr.2092 if (abs(xx*xy+yx*yy+zx*zy-1.).lt..1) then room=1.2*hn else room=1.2*www endif iskip=room*abs(cycles) iskip=1+iskip *i viewr.2166 iii=i-origen if (mod(iii,iskip).ne.0) go to 155 */ viewr -- 11jan96 -- fix errors in linear scales. */ the old way sometimes produced labels like */ 0, 1, 1, 2, 2, 3x10-3. *d viewr.1925,1927 nscale=0 ifracs=0 if (abs(astp).lt..099.or.abs(astp).gt..901) then *i viewr.1932 if (abs(amax/scale).lt..99) then nscale=nscale-3 scale=scale/1000. endif iv=nint(astp/scale) vv=astp/scale if (abs(vv-iv).gt..01) ifracs=1 *d viewr.1942,1943 vv=v/scale if (ifracs.eq.1) then write(num,'(f4.1)') vv *d viewr.1994 */ viewr -- 11jan96 -- fix the background grids for 3d plots. */ the problem shows up for the grid in the */ xz plane at the far end of the y axis. *i viewr.1307 if (x3.gt.0.) then call axis3(zmin,zmax,zop,' ',0,0,0,z3, 1 x3,y3,0.,0.,0.,1.,0.,-1.,0.,1,0) else call axis3(zmin,zmax,zop,' ',0,0,0,z3, 1 0.,y3,0.,0.,0.,1.,0.,-1.,0.,1,0) endif *i viewr.1309 call axis3(xmin,xmax,xop,' ',0,0,0,x3, 1 0.,y3,z3,1.,0.,0.,0.,1.,0.,1,0) *ident up21 */ groupr -- 25jan96 -- fix errors introduced in up4. */ note that mth was used instead of mtd. */ these lines of up4 also appear in 91.128. */ reported independently by de leege (delft) */ and konno (jaeri). *d up4.4 if (mtd.eq.11.or.mtd.eq.41) yld=2. *d up4.6 if (mtd.eq.42) yld=3. *ident up22 */ acer -- 25jan96 -- fix bad reaction name string. this was */ reported by brian palmer (bwfc). this line */ appears in up25 of njoy91. *d acer.7242 h '(n,he3*c) '/ */ acer -- 25jan96 -- make sure resonance plot range doesn't go to zero *i up19.176 if (e2.le.1.001*e1) go to 183 *ident up23 */ heatr -- 25jan96 -- fix typo in heatr. this problem was introduced */ in 91.103, and it was noticed by konno (jaeri). *d heatr.2339 if (i.eq.nd+1) go to 430 *ident up24 */ heatr -- 31jan96 -- modify tabsq6 to allow for discrete photons. *i heatr.3019 nd=nint(a(3)) na=nint(a(4)) *i heatr.3022 if (nd.eq.0) go to 110 c c ***accumulate contributions from discrete levels do 100 i=1,nd x=a(ibase+ncyc*(i-1)+1) y=a(ibase+ncyc*(i-1)+2) xr=x*x*rein g=g+xr*y h=h+df(xr,z,awr+1.,z,awr)*y s=s+y 100 continue if (np.eq.nd) go to 130 c c ***accumulate contributions from continuum 110 nc=np-nd ibase=ibase+ncyc*nd *d heatr.3025,3027 do 125 i=2,nc *d heatr.3032 if (xl.eq.xh) go to 125 *d heatr.3042,3043 125 continue c c ***finished 130 g=g/s *ident up25 */ broadr -- 10feb96 -- fix erfc in funky. the previous */ formula didn't have a good enough */ fractional accuracy far out on the wings. */ this probem caused errors of up to */ 0.3 percent in some broadened 1/v xsecs. *d broadr.1214,1215 data a0,a1,a2,a3,a4,a5,a6,a7,a8,a9/ 1 -1.26551223d0,1.00002368d0,.37409196d0, 2 .09678418d0,-.18628806d0,.27886807d0,-1.13520398d0, 3 1.48851587d0,-.82215223d0,.17087277d0/ *d broadr.1218,1219 data a0,a1,a2,a3,a4,a5,a6,a7,a8,a9/ 1 -1.26551223,1.00002368,.37409196, 2 .09678418,-.18628806,.27886807,-1.13520398, 3 1.48851587,-.82215223,.17087277/ *d broadr.1229,1230 c this version of erfc from numerical recipes in fortran c is good to a fractional accuracy of 1.e-7 for a.le.4. c for even better results, use your system's erfc(a). t=1./(1.+0.5*abs(a)) erfcc=t*exp(-a*a+a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*(a6 1 +t*(a7+t*(a8+t*a9))))))))) if (a.lt.0.) erfcc=2.-erfcc f(1)=0.5*erfcc *ident up26 */ njoy -- 23feb96 -- fix bad argument lists for tosend, */ tofend, and tomend in the new gaspr */ module. noticed by broeders (kfk) */ when compiling with linux. *d up14.186,187 call tofend(npend,nscr1,0,a(1)) call tofend(npend,nscr1,0,a(1)) *d up14.193 call tosend(npend,nscr1,0,a(1)) *d up14.484 310 call tosend(nscr1,0,0,a(1)) *d up14.609 call tosend(nscr1,noutp,0,a(1)) *d up14.678 call tosend(npend,noutp,0,a(1)) *d up14.681 525 call tosend(npend,0,0,a(1)) *d up14.685 call tomend(npend,noutp,0,a(1)) *ident up27 */ groupr -- 21mar96 -- fix typo in radioactivity work */ (from piet de leege, delft) *d up11.69 if (mfd.gt.90.and.mfd.le.100) mmf=9 *ident up28 */ viewr -- 21mar96 -- must use two single quotes for portability */ (from nordborg, nea data bank) *d viewr.1998 write(num,'(''*10#EH.8<'',i2,''#HXEX<'')') nscale *d viewr.2001 write(num,'(''*10#EH.8<'',i1,''#HXEX<'')') nscale *d viewr.2052 write(num,'(''10#EH.8<'',i2,''#HXEX<'')') imin *d viewr.2055 write(num,'(''10#EH.8<'',i3,''#HXEX<'')') imin *d viewr.2058 write(num,'(''10#EH.8<'',i1,''#HXEX<'')') imin *d viewr.2081 write(num,'(''10#EH.8<'',i2,''#HXEX<'')') imax *d viewr.2084 write(num,'(''10#EH.8<'',i3,''#HXEX<'')') imax *d viewr.2087 write(num,'(''10#EH.8<'',i1,''#HXEX<'')') imax *d viewr.2168 write(num,'(''10#EH.8<'',i2,''#HXEX<'')') i *d viewr.2171 write(num,'(''10#EH.8<'',i3,''#HXEX<'')') i *d viewr.2174 write(num,'(''10#EH.8<'',i1,''#HXEX<'')') i *ident up29 */ heatr -- 22mar96 -- make sure that subdivision interval does not */ decrease to zero on short-word machines */ (noticed by trkov, enea bologna) *d heatr.2247 *d heatr.2250 *i heatr.2253 if (xm.eq.x(i-1).or.xm.eq.x(i)) go to 190 */ heatr -- 22mar96 -- make h6cm more consistent with f6cm in groupr */ to help prevent infinite loops on short-word machines */ and to avoid undefined values of yt */ (suggested by trkov, enea bologna) *i heatr.2459 *if sw real*8 xx,xc,cc,c *endif *d heatr.2543 if (un.lt.umin+1.e-5) un=umin *i heatr.2557 do 245 l=1,nl 245 yt(l)=p(l)*s/sqrt(yy) *d heatr.2560 *ident up30 */ groupr -- 22mar96 -- make sure that subdivision interval does not */ decrease to zero on short-word machines */ (noticed by trkov, enea bologna) *d groupr.4282 *d groupr.4285 *i groupr.4288 if (xm.eq.x(i-1).or.xm.eq.x(i)) go to 190 *ident up31 */ covr -- 22mar96 -- fix some format statements to remove compilation warnings */ (provided by trkov, enea bologna) *d covr.940 write(nplot,'(''*'',a,''*/'')') strng *d covr.952 write(nplot,'(1p,2e13.4,''/'')') xig(i),yyy *d covr.943 write(nplot,'(1p,2e12.4,''/'')') xmin,xmax *d covr.995 write(nplot,'(''*'',a,''*/'')') strng *d covr.998 write(nplot,'(1p,2e12.4,''/'')') ymin,ymax *d covr.1007 write(nplot,'(1p,2e13.4,''/'')') xig(i),yyy *ident up32 */ leapr -- 22mar96 -- fix a format statement to remove compilation warning */ (provided by trkov, enea bologna) *d leapr.1343 1 '(/4x,'' beta'',7x,''s(alpha,beta)'',7x,''ss(alpha,beta)'', *ident up33 */ reconr -- 22mar96 -- fix pseudo threshold processing. */ the original logic for removing small cross sections */ to obtain a pseudo threshold didn't allow for cases */ where the interpolation law changes before the */ pseudo threshold or where there are too many energy */ points below the new threshold. these cases */ occured for JEF-2.2. */ (patch developed by trkov, enea bologna) *i reconr.1244 jr=1 kr=0 ibase=iscr+5+2*nint(a(iscr+4)) *d reconr.1246 if (kr+ir.gt.nbta) jr=jr+1 *d reconr.1249,1250 *i reconr.1257 if ((ibase+2*ir).lt.nw.or.nb.eq.0) go to 207 call moreio(nin,nout,0,a(ibase+1),nb,nw) kr=kr+ir ir=0 nw=ibase+nw 207 continue *d reconr.1296 if (kr+ir.le.nbta) go to 235 *ident up34 */ njoy -- 22mar96 -- for gaspr, fix the preparation of the new */ directory for cases where old gas production */ mt-s were removed. *i up14.522 k=1+nw *d up14.524,529 if (iverf.lt.5) go to 373 call contio(nscr1,0,0,a(k),nb,nw) k=k+nw 373 if (iverf.lt.6) go to 375 call contio(nscr1,0,0,a(k),nb,nw) k=k+nw 375 call hdatio(nscr1,0,0,a(k),nb,nw) k=k+nw *d up14.531,532 *d up14.534 call moreio(nscr1,0,0,a(k),nb,nw) k=k+nw *d up14.537 call dictio(nscr1,0,0,a(k),nb,nw) *d up14.540 j=k-1+6*(i-1) *d up14.548 j=k-1+6*(i-1) *d up14.552 j=k-1+6*nx *d up14.556 a(6*nx+ni+k-i)=a(6*nx+k-i) *d up14.598,599 410 nw=6 k=1 if (iverf.eq.4) a(6)=nx+nsec-nold call contio(0,noutp,0,a(k),nb,nw) k=k+nw if (iverf.lt.5) go to 411 call contio(0,noutp,0,a(k),nb,nw) k=k+nw 411 if (iverf.lt.6) go to 412 call contio(0,noutp,0,a(k),nb,nw) k=k+nw 412 if (iverf.ne.4) a(k+5)=nx+nsec-nold call hdatio(0,noutp,0,a(k),nb,nw) k=k+nw if (nb.eq.0) go to 414 413 call moreio(0,noutp,0,a(k),nb,nw) k=k+nw if (nb.ne.0) go to 413 414 nw=nx+nsec-nold call dictio(0,noutp,0,a(k),nb,nw) *ident up35 */ heatr -- 22mar96 -- fix q value of charged-particle levels in mf6 *d heatr.811,812 q0=t *ident up36 */ thermr -- 29mar96 -- fix interpolation special cases and warn user */ when too far outside of temperature range. */ this logic allows extrapolation up to 10 pc */ above and below the given range or value. *i thermr.962 nr=nint(a(ifl+4)) np=nint(a(ifl+5)) if (np.gt.1) go to 145 tt1=a(ifl+6+2*nr) if (abs(temp-tt1).gt.0.1*temp) call error('iel', 1 'bad temperature for debye-waller factor',' ') dwa=a(ifl+7+2*nr) go to 150 145 tt1=a(ifl+6+2*nr) ttn=a(ifl+4+2*nr+2*np) if (temp.lt.0.9*tt1.or.temp.gt.1.1*ttn) call error('iel', 1 'bad temperature for debye-waller factor',' ') if (tt1.gt.temp) a(ifl+4+2*nr)=temp if (ttn.lt.temp) a(ifl+4+2*nr+2*np)=temp *d thermr.966 *i thermr.1329 tt1=a(iscr+6+2*nr) if (abs(tempt-tt1).gt.0.1*tempt) call error('calcem', 1 'bad temperature for teff',' ') *d thermr.1336 *d thermr.1338 if (tempt.lt.0.9*tt1.or.tempt.gt.1.1*ttn) call error('calcem', 1 'bad temperature for teff',' ') if (tt1.gt.tempt) a(iscr+4+2*nr)=tempt if (ttn.lt.tempt) a(iscr+4+2*nr+2*np)=tempt *i thermr.1344 tt1=a(iscr+6+2*nr) if (abs(tempt-tt1).gt.0.1*tempt) call error('calcem', 1 'bad temperature for teff2',' ') *d thermr.1351 *d thermr.1353 if (tempt.lt.0.9*tt1.or.tempt.gt.1.1*ttn) call error('calcem', 1 'bad temperature for teff2',' ') if (tt1.gt.tempt) a(iscr+4+2*nr)=tempt if (ttn.lt.tempt) a(iscr+4+2*nr+2*np)=tempt *ident up37 */ acer -- 29mar96 -- fix numerical problems in finding equal prob */ bin values for tabulated ang distribs that */ are very close to isotropic. this arises now */ because more bins are being used for the */ conversion of lab MF6 to LAW7 (see up9). */ The error showed up as a floating point */ fault for ENDF/B-VI lead isotopes on Crays. *d acer.3143,3144 if (abs(slpe).lt.1.e-4) tbmu(l)=-(area-dprob-p(k)*amu(j))/p(k) if (abs(slpe).lt.1.e-4) go to 280 *d acer.3150 270 d=sqrt(w) *d acer.3161 c more than 1.0e-05, print non fatal diagnostic. *d acer.3165 if (abs(avar).gt.1.e-5) write(nsyso,6) avar,mat,mf,mt *d acer.3252 c more than 1.0e-05, print non fatal diagnostic. *d acer.3256 if (abs(avar).gt.1.e-5) write(nsyso,6) avar,mat,mf,mt *d acer.3324,3325 6 format(/52h message from pttab--integrated area of distribution/ 1 20x,10his off by ,1p,e12.5/ */ acer -- 31mar96 -- fix problem with plotting ENDF/B-VI mo-nat. */ the evaluation has silly numbers in the nth */ location of a histogram. don't use them to */ calculate zmin and zmax. see mf15/mt102. *i acer.11493 if (intt.eq.1.and.j.eq.n) go to 920 */ acer -- 31mar96 -- repair and extend the consistency checks */ for energy distributions as suggested by */ frankle, lanl. *i acer.10125 loci=loci+1 clast=0. *d acer.10129 if (c.lt.0..or.c.gt.1.000001) then *i acer.10133 if (c.lt.clast) then write(nsyso,'('' decreasing cumm. prob for '',a, 1 '' at '',1p,2e12.4)') name,e,ep nerr=nerr+1 endif clast=c *i acer.10147 clast=0. *d acer.10152 if (c.lt.0..or.c.gt.1.000001) then *i acer.10156 if (c.lt.clast) then write(nsyso,'('' decreasing cumm. prob for '',a, 1 '' at '',1p,2e12.4)') name,e,ep nerr=nerr+1 endif clast=c *i acer.10198 clast=0. *d acer.10203 if (c.lt.0..or.c.gt.1.000001) then *i acer.10207 if (c.lt.clast) then write(nsyso,'('' decreasing cumm. prob for '',a, 1 '' at '',1p,2e12.4)') name,e,ep nerr=nerr+1 endif clast=c *ident up38 */ njoy -- 17apr96 -- fix gety1 and gety2 to treat the last point */ as a discontinuity. this only affects cases */ where the cross sections runs out before the */ group structure (some cp cases). *i njoy.2393 if ((ln+3).gt.nwtot.and.nb.eq.0) idis=1 *i njoy.2405 if (x.gt.a(ln+1)) y1=0. *i njoy.2474 if ((ln+3).gt.nwtot.and.nb.eq.0) idis=1 *i njoy.2486 if (x.gt.a(ln+1)) y2=0. *ident up39 */ groupr -- 17apr96 -- provide fixes for the case where the */ incident energy range ends before the */ group structure ends. this is common */ in lanl charged-particle files. *i groupr.2601 if (enext.gt..99e10) go to 115 *d groupr.2622 if (enext.gt..99e10) go to 114 *d groupr.2629,2630 114 if (sig(1,1).ne.0.) go to 125 115 do 116 iz=1,nz *d groupr.3924 c(l+3)=law *ident up40 */ reconr -- 16jul96 -- arrange to have all the subsections */ of mf10 merged onto the union grid. *i reconr.1172 nss=1 if (mfh.eq.10) nss=n1h iss=nss *d reconr.1178 if (mfl.eq.3.or.mfl.eq.10.or.mfl.eq.13.or.mfl.eq.23) 1 call afend(nout,0) *d reconr.1213 181 call tab1io(nin,0,0,a(iscr),nb,nw) *i reconr.1425 iss=iss-1 if (iss.gt.0) go to 181 *i reconr.3450 nss=1 if (mfh.eq.10) nss=n1h if (nss.gt.1) call debug(1) iss=nss *d reconr.3558 if (iss.eq.nss) nxc=nxc+1 *d reconr.3561 if (iss.eq.nss) a(incs+nxc-1)=1 a(incs+nxc-1)=a(incs+nxc-1)+2+(n2h+2)/3 *d reconr.3589 480 iss=iss-1 if (iss.gt.0) go to 220 call tosend(nin,0,0,a(iscr)) *i reconr.3607 subroutine debug(i) return end *ident up41 */ dtfr -- 20jul96 -- add self-shielding for nu*sigf and the capture */ and fission parts of the gamma prod matrix. *i dtfr.106 dimension fcap(241),ffis(241) *i dtfr.278 if (mt.eq.102.or.mt.eq.18) go to 220 *i dtfr.292 go to 240 c save capture and fission self-shielding factors 220 jg=ng-ig+1 loca=lz+il+nl*nz if (mt.eq.18) ffis(jg)=1. if (mt.eq.18.and.a(loca).ne.0.) 1 ffis(jg)=a(loca+nl*(jz-1))/a(loca) if (mt.eq.102) fcap(jg)=1. if (mt.eq.102.and.a(loca).ne.0.) 1 fcap(jg)=a(loca+nl*(jz-1))/a(loca) if (ned.gt.0) go to 240 go to 260 *d dtfr.366 sss=a(loca) if (mt.eq.18.or.mt.eq.19) sss=sss*ffis(jg) sig(locs)=sig(locs)+sss *d dtfr.371,372 sig(locs)=sig(locs)+a(locf)*sss cnorm=cnorm+a(locf)*sss *d dtfr.389,390 sss=a(loca) if (mt.eq.18.or.mt.eq.19) sss=sss*ffis(jg) sig(locs)=sig(locs)+sss cnm=cnm+sss*a(locf) *d dtfr.403 sig(locs)=sig(locs)+a(loca+1)*a(loca+2)*ffis(jg) *d dtfr.405 dnorm=dnorm+a(loca+1)*a(loca+2)*ffis(jg) *i dtfr.427 ff=1. if (mt.eq.102) ff=fcap(jg) if (mt.eq.18) ff=ffis(jg) *d dtfr.437 sig(locs)=sig(locs)+a(loca)*ff *d dtfr.451 sig(locs)=sig(locs)+a(loca)*ff*spect(k) *ident up42 */ gaspr -- 23jul96 -- include some rare reactions (rel. 3 al-27) */ and fix a few other problems. *d up14.210 if (mth.ge.6.and.mth.le.10) go to 245 if (mth.eq.11) izg=1 if (mth.eq.11) izr=izr-3007 if (mth.ge.12.and.mth.le.15) go to 245 *d up14.214 if (mth.ge.22.and.mth.le.25) izg=1 if (mth.eq.22) izr=izr-2005 if (mth.eq.23) izr=izr-6013 if (mth.eq.24) izr=izr-2006 if (mth.eq.25) izr=izr-2007 if (mth.ge.26.and.mth.le.27) go to 245 if (mth.ge.28.and.mth.le.32) izg=1 if (mth.eq.28) izr=izr-1002 if (mth.eq.29) izr=izr-4009 if (mth.eq.30) izr=izr-4010 if (mth.eq.31) go to 245 if (mth.ge.32.and.mth.le.36) izg=1 if (mth.eq.32) izr=izr-1003 if (mth.eq.33) izr=izr-1004 if (mth.eq.34) izr=izr-2004 if (mth.eq.35) izr=izr-5011 if (mth.eq.36) izr=izr-5012 if (mth.eq.37) izr=izr-3 *i up14.216 if (mth.eq.41) izr=izr-1003 if (mth.eq.42) izr=izr-1004 *i up14.218 if (mth.eq.44) izr=izr-2003 if (mth.eq.45) izr=izr-3006 *i up14.220 izr=izr-1 *i up14.221 if (mth.eq.22) izr=izr-2004 if (mth.eq.23) izr=izr-6012 if (mth.eq.24) izr=izr-2005 if (mth.eq.25) izr=izr-2006 *i up14.222 if (mth.eq.28) izr=izr-1001 if (mth.eq.29) izr=izr-2008 if (mth.eq.30) izr=izr-4009 *i up14.223 if (mth.eq.32) izr=izr-1002 if (mth.eq.33) izr=izr-1003 if (mth.eq.34) izr=izr-2003 if (mth.eq.35) izr=izr-5010 if (mth.eq.36) izr=izr-5011 *d up14.226 if (mth.ge.103.and.mth.le.117) izg=1 if (mth.eq.103) izr=izr-1001 if (mth.eq.104) izr=izr-1002 if (mth.eq.105) izr=izr-1003 if (mth.eq.106) izr=izr-2003 if (mth.eq.107) izr=izr-2004 if (mth.eq.108) izr=izr-4008 if (mth.eq.109) izr=izr-6012 if (mth.eq.111) izr=izr-2002 if (mth.eq.112) izr=izr-3005 if (mth.eq.113) izr=izr-5011 if (mth.eq.114) izr=izr-5010 if (mth.eq.115) izr=izr-2003 if (mth.eq.116) izr=izr-2004 if (mth.eq.117) izr=izr-3006 *d up14.228 if (izg.eq.0.and. 1 (izr.gt.2004.or.izr.le.0)) go to 245 *d up14.270 if (mth.ge.6.and.mth.le.10) go to 310 if (mth.ge.12.and.mth.le.15) go to 310 *d up14.273 if (mth.eq.43) go to 310 if (mth.ge.46.and.mth.le.50) go to 310 *d up14.275 if (mth.ge.118) go to 310 *i up14.289 else if (mth.eq.11) then izr=izr-1004 y204=1. *d up14.325 izr=izr-5011 *d up14.329 izr=izr-5012 *i up14.435 else if (mth.eq.117) then izr=izr-3007 y204=1. y207=1. *ident up43 */ groupr -- 23jul96 -- add more space for auto reaction lists *d up11.16,17 common/rlist/mf4(50),mf6(50),mf12(50),mf13(50),mf18(50), 1 mf4r(6,50),mf6p(6,50),mf10f(50),mf10s(50),mf10i(50) *d groupr.813 common/rlist/mf4(50),mf6(50),mf12(50),mf13(50),mf18(50), *d up11.52 1 mf4r(6,50),mf6p(6,50),mf10f(50),mf10s(50),mf10i(50) *d groupr.1109 common/rlist/mf4(50),mf6(50),mf12(50),mf13(50),mf18(50), *d up11.103 1 mf4r(6,50),mf6p(6,50),mf10f(50),mf10s(50),mf10i(50) *d groupr.1139 common/rlist/mf4(50),mf6(50),mf12(50),mf13(50),mf18(50), *d up11.105 1 mf4r(6,50),mf6p(6,50),mf10f(50),mf10s(50),mf10i(50) *d groupr.6320 common/rlist/mf4(50),mf6(50),mf12(50),mf13(50),mf18(50), *d up11.107 1 mf4r(6,50),mf6p(6,50),mf10f(50),mf10s(50),mf10i(50) *ident up44 */ reconr -- 11sep96 -- fix trkov patch in up33 *i up33.13 nbta=1 *ident up45 */ acer -- 11sep96 -- fix to prevent overflows and underflows when */ calculating equiprobable bins for int=4. */ contributed by harm wienke, iaea. *d acer.3230,3231 nj=j if (abs(b).lt.1.e-4) then area=area+p(nj)*(amu(nj)-amu(k)) else area=area+(p(nj)/b)*(1.0-exp(b*(amu(k)-amu(nj)))) endif *d acer.3248,3249 if (abs(b).lt.1.e-4) then tbmu(l)=amu(j)-(area-dprob)/p(nj) avar=p(nj)*(amu(j)-tbmu(l)) else tbmu(l)=amu(j)+log(1.0-(b/p(nj))*exp(b*(amu(nj)-amu(j)))* 1 (area-dprob))/b avar=(p(nj)/b)* 1 (exp(b*(amu(j)-amu(nj)))-exp(b*(tbmu(l)-amu(nj)))) endif *d acer.3269 p(k)=p(nj)*exp(b*(tbmu(l)-amu(nj))) *d acer.3272 p(k)=p(nj)*exp(b*(tbmu(l)-amu(nj))) */ acer - 11sep96 -- allow the backward angle limit for the */ equiprobable bins to be greater than -1.0 *i acer.3014 c c set area of back angles to be omitted from distribution aback=1.e-4 *i acer.3084 if (l.eq.1.and.area.lt.aback) tbmu(1)=amu(k) *i acer.3124 if (l.eq.1.and.area.lt.aback) tbmu(1)=amu(k) *d acer.3233 410 if (l.eq.1.and.area.lt.aback) tbmu(1)=amu(k) k=k+1 */ acer -- 11sep96 -- improve the error messages in pttab *d acer.3190 if (tbmu(npt).ne.1..and.mf.eq.4) write(nsyso,7) e,mt *d acer.3110 if (abs(avar).gt.1.e-5) write(nsyso,6) avar,e,mat,mf,mt *d up37.17 if (abs(avar).gt.1.e-5) write(nsyso,6) avar,e,mat,mf,mt *d up37.21 if (abs(avar).gt.1.e-5) write(nsyso,6) avar,e,mat,mf,mt *d up37.23,24 6 format(/25h ---message from pttab---, 1 31hintegrated area of distribution/ 2 20x,10his off by ,1p,e12.5,6h at e=,e12.4/ *d acer.3327 7 format(/52h ---message from pttab---last value of mu ne 1 at e=, 1 1p,e12.4,8h for mt=,i3) *ident up46 */ heatr -- 21sep96 -- fix lang and kinematics for tabulated law2 in mf6 *i heatr.2361 lang=nint(c(3)) *i heatr.2381 if (irec.gt.0) u=-u *d heatr.2387 465 e2=afact*e*(1.+2.*beta*u+beta*beta) *i heatr.2394 if (irec.gt.0) then beta=arec*beta afact=afact/arec endif *i heatr.2396 if (irec.gt.0) l=6+2*nmu-2*imu+1 *i heatr.2397 if (irec.gt.0) u=-u *d heatr.2399 e2=afact*e*(1.+2.*beta*u+beta*beta) */ heatr -- 21sep96 -- prevent infinite loop on mu for sw machines *i heatr.2542 if (un.gt.u-.0001) un=u-.0001 */ heatr -- 21sep96 -- don't do balance corrections if mt=5. */ there is no q0 to check against! *d heatr.903 if (last6.eq.1.and.mt.ne.5.and.mt.ne.102) 1 ebal6=(e+q0)*y-c(npkk) */ heatr -- 21sep96 -- don't print small balance errors *d heatr.921 199 if (abs(ebal6).lt.100.*y) go to 201 */ heatr -- 21sep96 -- add new option for the reference system lct. */ if lct=3, the light particles (n thru alpha) */ are in the cm system, but the heavy particles */ (recoil nuclei) are in the lab. this option */ only affects law=1. it is used for high-energy */ evaluations, such as those from los alamos. *i heatr.2225 if (law.eq.1.and.lct.eq.3.and.zap.gt.2004) go to 400 *d heatr.3206 if (lcd.eq.1.and.lct.ne.1) go to 300 if (lcd.eq.2.and.lct.lt.2) go to 300 *d heatr.3246 if (lcd.eq.1.and.lct.ge.2) xn=(1.+awr*x)/sqrt(1.+awr*awr+2*awer*x) */ heatr -- 11sep96 -- increase quadrature order to handle 200 mev *d heatr.1245 dimension a(1),fl(65),p(65),qp(64),qw(64) *d heatr.1248,1256 data nq/64/ data qp/ x -9.99305042E-01,-9.96340117E-01,-9.91013371E-01,-9.83336254E-01, x -9.73326828E-01,-9.61008800E-01,-9.46411375E-01,-9.29569172E-01, x -9.10522137E-01,-8.89315446E-01,-8.65999398E-01,-8.40629296E-01, x -8.13265315E-01,-7.83972359E-01,-7.52819907E-01,-7.19881850E-01, x -6.85236313E-01,-6.48965471E-01,-6.11155355E-01,-5.71895646E-01, x -5.31279464E-01,-4.89403146E-01,-4.46366017E-01,-4.02270158E-01, x -3.57220158E-01,-3.11322872E-01,-2.64687162E-01,-2.17423644E-01, x -1.69644420E-01,-1.21462819E-01,-7.29931218E-02,-2.43502927E-02, x 2.43502927E-02, 7.29931218E-02, 1.21462819E-01, 1.69644420E-01, x 2.17423644E-01, 2.64687162E-01, 3.11322872E-01, 3.57220158E-01, x 4.02270158E-01, 4.46366017E-01, 4.89403146E-01, 5.31279464E-01, x 5.71895646E-01, 6.11155355E-01, 6.48965471E-01, 6.85236313E-01, x 7.19881850E-01, 7.52819907E-01, 7.83972359E-01, 8.13265315E-01, x 8.40629296E-01, 8.65999398E-01, 8.89315446E-01, 9.10522137E-01, x 9.29569172E-01, 9.46411375E-01, 9.61008800E-01, 9.73326828E-01, x 9.83336254E-01, 9.91013371E-01, 9.96340117E-01, 9.99305042E-01/ data qw/ x 1.78328072E-03, 4.14703326E-03, 6.50445797E-03, 8.84675983E-03, x 1.11681395E-02, 1.34630479E-02, 1.57260305E-02, 1.79517158E-02, x 2.01348232E-02, 2.22701738E-02, 2.43527026E-02, 2.63774697E-02, x 2.83396726E-02, 3.02346571E-02, 3.20579284E-02, 3.38051618E-02, x 3.54722133E-02, 3.70551285E-02, 3.85501532E-02, 3.99537411E-02, x 4.12625632E-02, 4.24735151E-02, 4.35837245E-02, 4.45905582E-02, x 4.54916279E-02, 4.62847966E-02, 4.69681828E-02, 4.75401657E-02, x 4.79993886E-02, 4.83447622E-02, 4.85754674E-02, 4.86909570E-02, x 4.86909570E-02, 4.85754674E-02, 4.83447622E-02, 4.79993886E-02, x 4.75401657E-02, 4.69681828E-02, 4.62847966E-02, 4.54916279E-02, x 4.45905582E-02, 4.35837245E-02, 4.24735151E-02, 4.12625632E-02, x 3.99537411E-02, 3.85501532E-02, 3.70551285E-02, 3.54722133E-02, x 3.38051618E-02, 3.20579284E-02, 3.02346571E-02, 2.83396726E-02, x 2.63774697E-02, 2.43527026E-02, 2.22701738E-02, 2.01348232E-02, x 1.79517158E-02, 1.57260305E-02, 1.34630479E-02, 1.11681395E-02, x 8.84675983E-03, 6.50445797E-03, 4.14703326E-03, 1.78328072E-03/ *d heatr.1268 nld=60 *d heatr.1322 nld=60 *d heatr.2204,2213 dimension p(65),qp(64),qw(64) data nq/64/ data qp/ x -9.99305042E-01,-9.96340117E-01,-9.91013371E-01,-9.83336254E-01, x -9.73326828E-01,-9.61008800E-01,-9.46411375E-01,-9.29569172E-01, x -9.10522137E-01,-8.89315446E-01,-8.65999398E-01,-8.40629296E-01, x -8.13265315E-01,-7.83972359E-01,-7.52819907E-01,-7.19881850E-01, x -6.85236313E-01,-6.48965471E-01,-6.11155355E-01,-5.71895646E-01, x -5.31279464E-01,-4.89403146E-01,-4.46366017E-01,-4.02270158E-01, x -3.57220158E-01,-3.11322872E-01,-2.64687162E-01,-2.17423644E-01, x -1.69644420E-01,-1.21462819E-01,-7.29931218E-02,-2.43502927E-02, x 2.43502927E-02, 7.29931218E-02, 1.21462819E-01, 1.69644420E-01, x 2.17423644E-01, 2.64687162E-01, 3.11322872E-01, 3.57220158E-01, x 4.02270158E-01, 4.46366017E-01, 4.89403146E-01, 5.31279464E-01, x 5.71895646E-01, 6.11155355E-01, 6.48965471E-01, 6.85236313E-01, x 7.19881850E-01, 7.52819907E-01, 7.83972359E-01, 8.13265315E-01, x 8.40629296E-01, 8.65999398E-01, 8.89315446E-01, 9.10522137E-01, x 9.29569172E-01, 9.46411375E-01, 9.61008800E-01, 9.73326828E-01, x 9.83336254E-01, 9.91013371E-01, 9.96340117E-01, 9.99305042E-01/ data qw/ x 1.78328072E-03, 4.14703326E-03, 6.50445797E-03, 8.84675983E-03, x 1.11681395E-02, 1.34630479E-02, 1.57260305E-02, 1.79517158E-02, x 2.01348232E-02, 2.22701738E-02, 2.43527026E-02, 2.63774697E-02, x 2.83396726E-02, 3.02346571E-02, 3.20579284E-02, 3.38051618E-02, x 3.54722133E-02, 3.70551285E-02, 3.85501532E-02, 3.99537411E-02, x 4.12625632E-02, 4.24735151E-02, 4.35837245E-02, 4.45905582E-02, x 4.54916279E-02, 4.62847966E-02, 4.69681828E-02, 4.75401657E-02, x 4.79993886E-02, 4.83447622E-02, 4.85754674E-02, 4.86909570E-02, x 4.86909570E-02, 4.85754674E-02, 4.83447622E-02, 4.79993886E-02, x 4.75401657E-02, 4.69681828E-02, 4.62847966E-02, 4.54916279E-02, x 4.45905582E-02, 4.35837245E-02, 4.24735151E-02, 4.12625632E-02, x 3.99537411E-02, 3.85501532E-02, 3.70551285E-02, 3.54722133E-02, x 3.38051618E-02, 3.20579284E-02, 3.02346571E-02, 2.83396726E-02, x 2.63774697E-02, 2.43527026E-02, 2.22701738E-02, 2.01348232E-02, x 1.79517158E-02, 1.57260305E-02, 1.34630479E-02, 1.11681395E-02, x 8.84675983E-03, 6.50445797E-03, 4.14703326E-03, 1.78328072E-03/ *d heatr.3055 dimension flo(65),fhi(65) *d heatr.3179 c direct gaussian quadrature of order 64. significance of the *d heatr.3189,3197 dimension qp(64),qw(64),p(65) data qp/ x -9.99305042E-01,-9.96340117E-01,-9.91013371E-01,-9.83336254E-01, x -9.73326828E-01,-9.61008800E-01,-9.46411375E-01,-9.29569172E-01, x -9.10522137E-01,-8.89315446E-01,-8.65999398E-01,-8.40629296E-01, x -8.13265315E-01,-7.83972359E-01,-7.52819907E-01,-7.19881850E-01, x -6.85236313E-01,-6.48965471E-01,-6.11155355E-01,-5.71895646E-01, x -5.31279464E-01,-4.89403146E-01,-4.46366017E-01,-4.02270158E-01, x -3.57220158E-01,-3.11322872E-01,-2.64687162E-01,-2.17423644E-01, x -1.69644420E-01,-1.21462819E-01,-7.29931218E-02,-2.43502927E-02, x 2.43502927E-02, 7.29931218E-02, 1.21462819E-01, 1.69644420E-01, x 2.17423644E-01, 2.64687162E-01, 3.11322872E-01, 3.57220158E-01, x 4.02270158E-01, 4.46366017E-01, 4.89403146E-01, 5.31279464E-01, x 5.71895646E-01, 6.11155355E-01, 6.48965471E-01, 6.85236313E-01, x 7.19881850E-01, 7.52819907E-01, 7.83972359E-01, 8.13265315E-01, x 8.40629296E-01, 8.65999398E-01, 8.89315446E-01, 9.10522137E-01, x 9.29569172E-01, 9.46411375E-01, 9.61008800E-01, 9.73326828E-01, x 9.83336254E-01, 9.91013371E-01, 9.96340117E-01, 9.99305042E-01/ data qw/ x 1.78328072E-03, 4.14703326E-03, 6.50445797E-03, 8.84675983E-03, x 1.11681395E-02, 1.34630479E-02, 1.57260305E-02, 1.79517158E-02, x 2.01348232E-02, 2.22701738E-02, 2.43527026E-02, 2.63774697E-02, x 2.83396726E-02, 3.02346571E-02, 3.20579284E-02, 3.38051618E-02, x 3.54722133E-02, 3.70551285E-02, 3.85501532E-02, 3.99537411E-02, x 4.12625632E-02, 4.24735151E-02, 4.35837245E-02, 4.45905582E-02, x 4.54916279E-02, 4.62847966E-02, 4.69681828E-02, 4.75401657E-02, x 4.79993886E-02, 4.83447622E-02, 4.85754674E-02, 4.86909570E-02, x 4.86909570E-02, 4.85754674E-02, 4.83447622E-02, 4.79993886E-02, x 4.75401657E-02, 4.69681828E-02, 4.62847966E-02, 4.54916279E-02, x 4.45905582E-02, 4.35837245E-02, 4.24735151E-02, 4.12625632E-02, x 3.99537411E-02, 3.85501532E-02, 3.70551285E-02, 3.54722133E-02, x 3.38051618E-02, 3.20579284E-02, 3.02346571E-02, 2.83396726E-02, x 2.63774697E-02, 2.43527026E-02, 2.22701738E-02, 2.01348232E-02, x 1.79517158E-02, 1.57260305E-02, 1.34630479E-02, 1.11681395E-02, x 8.84675983E-03, 6.50445797E-03, 4.14703326E-03, 1.78328072E-03/ *d heatr.3199 data nqp/64/,nlmax/65/ *d heatr.3204 1 call error('hgetco','limited to 64 legendre coefficients.',' ') *ident up47 */ acer -- 23sep96 -- allow for tabulated distributions in mf6, law2. */ also allow for legendre orders to 64. *d acer.2086 common/topf/mcoars,npt *d acer.2103 call ptinit(a) *i acer.2216 c c ***work on mf4 *i acer.2229 c c ***work on mf5 or mf6 *d acer.2382 c ***just copy the others. *i acer.2389 do 1180 ie=1,ne *d acer.2390 if (ltt.eq.3) go to 1182 *d acer.2392,2395 if (ltt.eq.2) go to 1182 call listio(nscr,0,0,a(iscr),nb,nw) now=iscr+nw 1167 if (nb.eq.0) go to 1168 call moreio(nscr,0,0,a(now),nb,nw) now=now+nw go to 1167 1168 continue now=now-1 lang=nint(a(iscr+2)) if (mf.eq.6.and.lang.gt.0) go to 1163 call ptleg(nscr,nout,a) go to 1180 1163 do 1164 i=iscr,now 1164 a(now+2-i+iscr)=a(now-i+iscr) 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),nscr,nout) go to 1180 182 if (mf.eq.5) call tab1io(nscr,0,0,a(iscr),nb,nw) if (mf.eq.6) call listio(nscr,0,0,a(iscr),nb,nw) now=iscr+nw 1171 if (nb.eq.0) go to 1172 call moreio(nscr,0,0,a(now),nb,nw) now=now+nw go to 1171 1172 call cptab(nscr,nout,a(iscr)) go to 1180 1182 call tab1io(nscr,0,0,a(iscr),nb,nw) now=iscr+nw 1174 if (nb.eq.0) go to 1175 call moreio(nscr,0,0,a(now),nb,nw) now=now+nw go to 1174 1175 call pttab(ltt,a(iscr),nscr,nout) 1180 continue call contio(nscr,0,0,a(iscr),nb,nw) if (mt.ne.0) call error('topfil', 1 'expected a send card',' ') *d acer.2463 *i acer.2464 dimension pl(65) *d acer.2488 sum=0.5 u=1.-2.*(n-1)*ancos1 call legndr(u,pl,nl+1) *d acer.2490 110 sum=sum+a(k+lp5)*0.5*(2*k+1)*pl(k+1) *d acer.2492 *d acer.2494 120 sumi=0.5 *d acer.2501 sumi=sumi+co*0.5*(2*k+1)*pl(k+1) *d acer.2543 1 format(/39h ---message from test4---neg. prob. of ,1p,e11.4, *d acer.2602,2619 subroutine ptinit(a) c ****************************************************************** c initialize the calculation of equal probability bins c from legendre coefficients. see ptleg. c ****************************************************************** dimension a(1) data ni/64/ *d acer.2622 nwords=ni*(1+ni/2) *d acer.2624,2625 *d acer.2627,2645 *d acer.2675 nwords=ni+1 *d acer.2689 nwords=ni *d acer.2696,2699 end c subroutine ptleg(nin,nout,a) c ****************************************************************** c this subroutine translates endf/b legendre ang dist data into c tabulated form with equal probability mu intervals. c borrowed from etopl. c ****************************************************************** common/mainio/nsysi,nsyso,nsyse,ntty common/ace2/za,awr,mt19,mf1x(3),nxc,nxcmax,mfs(300),mts(300), 1 ncs(300),elast,ngmt,nned,iopp common/cont/c1h,c2h,l1h,l2h,n1h,n2h,mat,mf,mt,nsh,nsp,nsc common/topf/mcoars,npt common/util/npage,iverf dimension a(1) data ni/64/ c *d acer.2715,2718 c c ***work with list record read in topfil *d acer.2800 c described above. if it differs from 1.0 by more than 1.0e-5 *d acer.2803 if (abs(1.-sum).gt.1.e-5) write(nsyso,3) avar,mat,mf,mt,e *d acer.2879,2886 *d acer.2889 1 format(50h ---message from ptleg---negative area between mu=, *d acer.2892,2894 3 format(53h ---message from ptleg---integrated area of legendre , 1 4hdist,/,20x,28h using 1000 subintervals is ,1p,e12.5/ 2 21x,4hmat=,i4,4h mf=,i2,4h mt=,i3,3h e=,e12.6) *d acer.2903 common/topf/mcoars,npt *d acer.2910,2928 c ***work with tab1 or list record read in topfil if (mf.eq.6) then nr=1 int=2 nw=6+nint(a(5)) else nr=nint(a(5)) np=nint(a(6)) int=nint(a(8)) nw=6+2*nr+2*np endif now=nw+1 *d acer.2992,2993 *d acer.2996,2998 *d acer.3008 common/topf/mcoars,npt *d acer.3016,3019 c ***work on tab1 record read (or constructed) by topfil *d acer.3306,3307 *d acer.3310,3314 *d acer.3321 4 format(/50h ---message from pttab---neg arg in sqrt for int=2/ *d acer.3373 10 format(/50h ---message from summer---for distribution as per , *d acer.3377,3379 20 format(/52h ---message from summer---for distr with equal prob , 1 6hbins, ,/,6x,5harea=,1p,e12.5,6h mat=,i4,5h mf=,i2,5h mt=, 2 i3,4h e=,e12.5) */ acer -- 23sep96 -- cope with the new lct=3 *d acer.4861 if (lct.ge.2) n=-n *i acer.5241 if (lct.gt.2) lct=2 *ident up48 */ acer -- 25sep96 -- allow for anisotropic gammas (endf c and o) *d acer.4260,4264 c write files 14 and 15. if multigroup photon data are available, c create an isotropic mf14/mt1. read in the multigroup energy c distributions, convert them into equally probable photons, and c write them out as mf15/mt1 using a specially defined law lf3. c convert the normal endf photon angular distributions from mf14 c into eqaul-probability bins in a new version of mf14. copy c the normal endf mf15 and the specially converted mf16 photons. *i acer.4286 call ptinit(a) *d acer.4293 c ***write the isotropic mf14/mt1 for the multigroup photons *d acer.4310 c c ***convert the endf mf14 distributions to equal-prob bins *d acer.4312,4313 1100 call contio(nf12c,nout,0,a(iscr),nb,nw) if (mf.eq.0) go to 1300 li=nint(a(iscr+2)) if (li.eq.0) go to 1200 c c ***this entire reaction is isotropic call tosend(nf12c,nout,0,a(iscr)) go to 1100 c c ***this reaction contains anisotropic photons 1200 ltt=nint(a(iscr+3)) nk=nint(a(iscr+4)) ni=nint(a(iscr+5)) do 1290 ik=1,nk if (ik.gt.ni) go to 1210 c c ***this subsection is isotropic call contio(nf12c,nout,0,a(iscr),nb,nw) go to 1290 c c ***this subsection is anisotropic. convert it. 1210 call tab2io(nf12c,nout,0,a(iscr),nb,nw) ne=nint(a(iscr+5)) do 1280 ie=1,ne if (ltt.eq.2) go to 1250 call listio(nf12c,0,0,a(iscr),nb,nw) call ptleg(nf12c,nout,a) go to 1280 1250 call tab1io(nf12c,0,0,a(iscr),nb,nw) now=1+nw 1260 if (nb.eq.0) go to 1270 call moreio(nf12c,0,0,a(now),nb,nw) now=now+nw 1270 call pttab(ltt,a(iscr),nf12c,nout) 1280 continue c c ***continue the loops over subsections and reactions 1290 continue call contio(nf12c,nout,0,a(iscr),nb,nw) if (mt.ne.0) call error('gamout', 1 'expected send card while reading mf14',' ') go to 1100 1300 continue c c ***check for multigroup mf15 data *d acer.4316,4317 *d acer.4519 c c ***copy the endf mf15 data *d acer.4524 c c ***copy the mf16 data derived from the endf mf6, if any *i acer.4528 c c ***the gamma angle and energy distributions are ready *d acer.5874 c ***store the photon angular distributions *d acer.5876,5877 *i acer.5879 i=0 730 i=i+1 if (i.gt.ntrp) go to 1780 lff=mod(nint(xss(i-1+mtrp)),10) if (lff.gt.1) go to 730 igg=mod(nint(xss(i-1+mtrp)),1000)/10 mtd=nint(xss(i-1+mtrp)/10000) iimt=i call findf(matd,14,mtd,nin) call contio(nin,0,0,a(iscr),nb,nw) li=l1h nk=n1h if (li.eq.0) go to 1735 c all gammas isotropic for this reaction do 1734 ik=1,nk xss(i+landp-1)=0 i=i+1 1734 continue i=i-1 go to 730 c some of the gammas are anisotropic 1735 ltt=l2h ni=n2h ik=0 if (ni.eq.0) go to 1750 do 1740 ii=1,ni ik=ik+1 i=i+1 call contio(nin,0,0,a(iscr),nb,nw) eg=c1h es=c2h do 1737 j=1,ntrp if (abs(eg-a(iphot+5*(j-1))).gt.1e-4*eg) go to 1737 xss(j+landp-1)=0 1737 continue 1740 continue 1750 ik=ik+1 i=i+1 call tab2io(nin,0,0,a(iscr),nb,nw) eg=c1h es=c2h ne=n2h do 1752 j=1,ntrp if (abs(eg-a(iphot+5*(j-1))).gt.1e-5*eg) go to 1752 xss(j+landp-1)=nex-andp+1 1752 continue xss(nex)=ne do 1760 ie=1,ne call tab1io(nin,0,0,a(iscr),nb,nw) xss(nex+ie)=c2h*1.e-6 lc=nex+2*ne+33*(ie-1) xss(nex+ne+ie)=lc-landp+1 do 1755 imu=1,33 xss(lc+imu)=a(iscr+6+2*imu) 1755 continue 1760 continue nex=nex+1+35*ne if (ik.lt.nk) go to 1750 go to 730 1780 continue *i acer.6913 do 1495 i=1,ntrp if (nint(xss(i+landp-1)).ne.0) go to 1505 1495 continue *i acer.6914 go to 1590 1505 do 1580 i=1,ntrp ngg=nint(xss(i-1+mtrp)) na=nint(xss(i+landp-1)) if (na.gt.0) go to 1515 go to 1580 1515 na=na+andp-1 ne=nint(xss(na)) list=(ne+7)/8 nb=na+ne nbin1=nbina+1 do 1620 l=1,list iaa=(l-1)*8+1 ib=min0(ne,iaa+7) ic=ib-iaa+1 j=1 do 1595 m=iaa,ib k=nint(xss(m+nb)) if (k.gt.0) k=k+landp loc(j)=k 1595 j=j+1 if (iprint.eq.0) go to 1500 write (nsyso,1635) ngg write (nsyso,640) (ek,blank,ii=1,ic) write (nsyso,645) (xss(ii+na),ii=iaa,ib) write (nsyso,650) 1500 continue nkk=ic do 1615 j=1,nbin1 do 1610 m=1,ic if (loc(m).eq.0) go to 1605 ii=loc(m)+j-1 write (kk(m),605) xss(ii) go to 1610 1605 write (kk(m),600) 1610 continue write (nsyso,660) j,(kk(ii),ii=1,nkk) 1615 continue 1620 continue 1580 continue 1590 continue *i acer.7045 1635 format(1h1///22x,32hangular distributions for photon,i10//) *ident up49 */ acer -- 30sep96 -- check for e' greater than e in energy */ distributions. patch and/or warn. *d acer.5027 395 e=c2h xss(next+j)=e*1.e-6 *i acer.5036 ep=a(iscr+6+2*ki) if (ep.gt.e.and.q.lt.0.) then write(nsyso,'('' ---warning from acelod ---'', 1 6x,''mf5 ep.gt.e with negative q''/ 2 6x,''mt='',i2,'' e='',1p,e12.4,'' ep='',e12.4/ 3 6x,''patching...'')') mt,e*1.e-6,ep*1.e-6 ep=e-(n-ki)*1.e3 a(iscr+6+2*ki)=ep endif *i acer.5495 ep=a(iscr+6+ncyc*(ki-1)) if (ep.gt.ee.and.mth.ne.5.and.q.lt.0.) then write(nsyso,'('' ---warning from acelod ---'', 1 6x,''mf6 ep.gt.e with negative q''/ 2 6x,''mt='',i2,'' e='',1p,e12.4,'' ep='',e12.4/ 3 6x,''patching...'')') mt,e*1.e-6,ep*1.e-6 ep=e-(n-ki)*1.e3 a(iscr+6+ncyc*(ki-1))=ep else if (ep.gt.ee.and.mth.eq.5) then write(nsyso,'('' ---warning from acelod ---'', 1 6x,''mf6/mt5 ep.gt.e''/ 2 6x,''mt='',i2,'' e='',1p,e12.4,'' ep='',e12.4/ 3 6x,''leaving it as is...'')') mt,e*1.e-6,ep*1.e-6 endif */ acer -- 30sep96 -- consistency check for e' greater than e. */ in file 5, provide warning messsage for neg. q. */ positive q reactions should be ok. */ in file 6 with mt.ne.5, do the same. */ in file 6 with mt.eq.5, there is no q to check. */ assume that ep.gt.e is an error for a.lt.180. */ for high a, could be real positive q channel, */ or fission could be mixed in. *i acer.10072 q=xss(lqr+i-1) *i acer.10128 if (ep.gt.e.and.q.lt.0.) then write(nsyso,'('' ep.gt.e with q.lt.0 for '',a, 1 '' at '',1p,2e12.4)') name,e,ep nerr=nerr+1 endif *i acer.10151 if (ep.gt.e) then if (mt.ne.5.and.q.lt.0) then write(nsyso,'('' ep.gt.e with q.lt.0 for '',a, 1 '' at '',1p,2e12.4)') name,e,ep nerr=nerr+1 else if (mt.eq.5.and.aw0.lt.180.) then write(nsyso,'('' ep.gt.e with q.lt.0 for '',a, 1 '' at '',1p,2e12.4)') name,e,ep write(nsyso, 1 '('' awr.lt.180---this is probably an error.'')') nerr=nerr+1 else if (mt.eq.5.and.aw0.ge.180.) then write(nsyso,'('' ep.gt.e with q.lt.0 for '',a, 1 '' at '',1p,2e12.4)') name,e,ep write(nsyso, 1 '('' awr.ge.180---there could be a legitimate ,''/ 2 '' positive-q channel or admixed fission.'')') nerr=nerr+1 endif endif */ acer -- 30sep96 -- work on obsolete 30x20 photon array *d acer.5736,5740 c omit obsolete 30x20 photon spectrum 625 continue *i acer.6759 if (mtrp.le.gpd+nes) go to 405 *d acer.7442 n=nxs(1)-jxs(13)+1 *i acer.7992 if (mtrp.le.gpd+nes) go to 445 *d acer.9865 l=jxs(13) *ident up50 */ njoy --31sep96 -- undo the changes up up38. evaluators will have */ to make sure that reactions that end early take */ themselves to zero at the upper energy limit. *d up38.7 *d up38.9 *d up38.11 *d up38.13 *ident up51 */ matxsr -- 29nov96 -- add up separate contributions to production */ reactions used for radioactive nuclides. *i matxsr.1695 c c ***add up separate contributions to production reactions 410 do 430 i=1,n1d n1i=n1d-i+1 do 420 j=1,n1i-1 n1j=j if (hvps(n1j).eq.hvps(n1i)) go to 440 420 continue 430 continue go to 480 440 do 450 k=1,ning lout=ivdat+n1j*ning-k lin=ivdat+n1i*ning-k a(lout)=a(lout)+a(lin) 450 continue if (n1i.eq.n1d) go to 470 nmove=(n1d-n1i)*ning do 460 k=1,nmove lout=ivdat+(n1i-1)*ning+k-1 lin=ivdat+n1i*ning+k-1 a(lout)=a(lin) 460 continue nmove=n1d-n1i do 465 k=1,nmove hvps(n1i+k-1)=hvps(n1i+k) 465 continue 470 n1d=n1d-1 go to 410 480 continue */ matxsr -- 9dec96 -- fix common name loc to avoid conflict */ with reserved word (neadb) *d matxsr.940 common/locd/nritev,nriteM *d matxsr.1715 common/locd/nritev,nriteM *d matxsr.1829 common/locd/nritev,nriteM *ident up52 */ acer -- 3dec96 -- fix problem with finding bins for tabulated */ distributions. if the area of the last cosine */ range or two is very small, the binning can */ stop before the cosine list is finished, */ thus leaving a bad value for the top of the */ last bin. couldn't resist some cleaning up. *d acer.3062 if (int.eq.2) go to 180 *d acer.3065 if (int.eq.4) go to 250 *d acer.3067,3183 c int=1 -- histogram interpolation l=2 j=2 k=1 area1=0. aneed=dprob tbmu(1)=amu(1) 140 area=p(k)*(amu(j)-amu(k)) if (area.gt.aneed.and.l.lt.npt) go to 150 area1=area1+area aneed=aneed-area if (l.eq.2.and.area1.lt.aback) tbmu(1)=amu(j) if (j.ge.np) go to 170 k=k+1 j=j+1 go to 140 150 if (p(k).gt.0.) go to 160 p(k)=p(k-1)*1.e-3 160 tbmu(l)=(aneed/p(k))+amu(k) amu(k)=tbmu(l) area1=0. aneed=dprob l=l+1 go to 140 170 tbmu(l)=amu(np) area1=area1-dprob if (abs(area1).gt.1.e-5) write(nsyso,6) area1,e,mat,mf,mt go to 340 c int=2 -- linear-linear interpolation 180 l=2 j=2 k=1 area1=0. aneed=dprob tbmu(1)=amu(1) 190 area=0.5*(p(j)+p(k))*(amu(j)-amu(k)) if (area.gt.aneed.and.l.lt.npt) go to 200 area1=area1+area aneed=aneed-area if (l.eq.2.and.area1.lt.aback) tbmu(1)=amu(j) if (j.ge.np) go to 240 k=k+1 j=j+1 go to 190 200 slpe=(p(j)-p(k))/(amu(j)-amu(k)) if (abs(slpe).lt.1.e-4) go to 220 aa=0.5*slpe b=p(k)-slpe*amu(k) c=(0.5*slpe*amu(k)-p(k))*amu(k)-aneed w=b*b-4.*aa*c if (w.ge.0.) go to 210 write(nsyso,4) mat,mf,mt,e write(nsyso,5) p(j),p(k),amu(j),amu(k) 210 d=sqrt(w) x1=(-b+d)/(2.*aa) x2=(-b-d)/(2.*aa) if (amu(k).lt.x1.and.x1.le.amu(j)) tbmu(l)=x1 if (amu(k).lt.x2.and.x2.le.amu(j)) tbmu(l)=x2 go to 235 220 if (p(k).gt.0.) go to 230 p(k)=p(k-1)*1.e-3 230 tbmu(l)=aneed/p(k)+amu(k) 235 p(k)=p(k)+slpe*(tbmu(l)-amu(k)) amu(k)=tbmu(l) area1=0. aneed=dprob l=l+1 go to 190 240 tbmu(l)=amu(np) area1=area1-dprob if (abs(area1).gt.1.e-5) write(nsyso,6) area1,e,mat,mf,mt go to 340 c int=4 -- lin-log interpolation 250 l=2 j=2 k=1 area1=0. aneed=dprob tbmu(1)=amu(1) 260 b=log(p(j)/p(k))/(amu(j)-amu(k)) if (abs(b).lt.1.e-4) then area=p(k)*(amu(j)-amu(k)) else area=p(k)*(exp(b*(amu(j)-amu(k)))-1.)/b endif if (area.gt.aneed.and.l.lt.npt) go to 270 area1=area1+area aneed=aneed-area if (l.eq.2.and.area1.lt.aback) tbmu(1)=amu(j) if (j.ge.np) go to 280 k=k+1 j=j+1 go to 260 270 if (abs(b).lt.1.e-4) then tbmu(l)=aneed/p(k)+amu(k) else tbmu(l)=log(1.0+b*aneed/p(k))/b+amu(k) endif p(k)=p(k)*exp(b*(tbmu(l)-amu(k))) amu(k)=tbmu(l) area1=0. aneed=dprob l=l+1 go to 260 280 tbmu(l)=amu(np) area1=area1-dprob if (abs(area1).gt.1.e-5) write(nsyso,6) area1,e,mat,mf,mt *d acer.3221,3275 */ acer -- 3dec96 -- fix the recently added test for ep>e. the */ units ev and mev are being confused. *d up49.19 e=ee*1.e6 if (ep.gt.e.and.mth.ne.5.and.q.lt.0.) then *d up49.26 else if (ep.gt.e.and.mth.eq.5) then */ acer -- 3dec96 -- fix unset variable suff (panini, neadb) *i acer.9322 common/ace6/suff,nohk,nxtra */ acer -- 4dec96 -- close a unit so that it can be reused. *i acer.532 call closz(nscr2) */ acer -- 9dec96 -- turn off coding connected with ace type 3 *d acer.9803 *d acer.9848 *d acer.9851 *d acer.9858 *d acer.9861 *i acer.9882 *else call error('acefix', 1 'word-addressable random i/o required for type 3',' ') *endif */ acer -- 9dec96 -- remove an unused message *d acer.2934,2935 *ident up53 */ groupr -- 4dec96 -- make sure function returns its value for */ the initialization entry to keep the */ compilers happy. *i groupr.4560 f6ddx=0. */ groupr -- 9dec96 -- use generic max function (neadb) *d groupr.7621 if (m.lt.max(xn1,xn2)) go to 230 *ident up54 */ heatr -- 4dec96 -- the patch is up46 has the side effect of */ ruining the calculations for law3, i.e., */ isotropic discrete scattering. *d up46.4 lang=0 if (law.eq.2) lang=nint(c(3)) *d heatr.2362 nld=0 if (law.eq.2) nld=nint(c(6)) */ heatr -- 4dec96 -- remove unreferenced coding (protsik, ge) *d heatr.1592,1599 */ heatr -- 4dec96 -- delete references to two unused values. */ also, make sure that function values are */ returned by initialization entry. *d heatr.2119,2120 *i heatr.2664 h6ddx=0. *d heatr.2803 h6dis=0. */ heatr -- 4dec96 -- check on index range (carminati, cern) *i heatr.872 if (iimt.le.0) go to 195 */ heatr -- 9dec96 -- fix typo (panini, neadb) *d up46.43 xn=(1.+awr*x)/sqrt(1.+awr*awr+2.*awr*x) */ heatr -- 9dec96 -- increase storage container size for */ jef (carminati, cern) *d heatr.87 common/hstore/a(25000) *d heatr.91 namax=25000 */ heatr -- 9dec96 -- make comparison safer for risc machine */ (carminati, cern) *d heatr.586 test=enext*fact if (idnx.gt.0.and.test.gt.e) enext=test *ident up55 */ moder -- 4dec96 -- fix string length for error message. *d moder.43 character*105 strng *ident up56 */ thermr -- 4dec96 -- make sure function returns a value to */ keep the compilers happy. *i thermr.1701 sig=0. *ident up57 */ errorr -- 4dec96 -- the temperature is no longer available in file 3. */ the code must search in file 1. (carminati, cern) *d errorr.2630 120 call findf(matd,1,0,npend) *d errorr.2632 121 za=c1h *d errorr.2634 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) *d errorr.2640 go to 121 */ errorr -- 9dec96 -- fix out-of-bound error in mtname */ (panini, neadb) *d errorr.2594 dimension mtname(17),b(8),z(20),iz(20),ans(2) *ident up58 */ njoy -- 4dec96 -- provide more digits for storag messages *d njoy.2582 30 format(60x,'id ',a4,1x,i3,/,i6) *d njoy.2688 40 format(60x,'xx ',a4,5x,i6) *ident up59 */ leapr -- 9dec96 -- sw fixes from panini, neadb *d leapr.1967 t2=2.e-38 *i leapr.2258 *if sw smin=2.e-38 *else smin=1.e-99 *endif *d leapr.2639 if (ilog.eq.0.and.scr(8+2*j).lt.smin) scr(8+2*j)=0.0 *d leapr.2712 if (ilog.eq.0.and.scr(6+j).lt.smin) scr(6+j)=0.0 *ident up60 */ broadr -- 9dec96 -- use generic max function *d broadr.1337 if (m.lt.max(xn1,xn2)) go to 130 *ident up61 */ ccccr -- 9dec96 -- fix mistyped variable (neadb) *d ccccr.465 maxup=nint(z(2)) *ident up62 */ heatr -- 19dec96 -- fix error in correcting error. */ repairs bad results for tabulated ang. dist. */ this is a problem for the lanl high-energy */ evaluations, but most evaluations below 20 mev */ use polynomials and won't be affected. */ noticed by chadwick, lanl. *d up54.26 if (lcd.eq.1.and.lct.ge.2) 1 xn=(1.+awr*x)/sqrt(1.+awr*awr+2*awr*x) *ident up63 */ njoy -- 19dec96 -- fix error made in up58. this problem only */ messes up the storag messages. it doesn't affect */ answers. found by trkov (ijs slovenia). *d up58.4 30 format(60x,'id',a4,1x,i3,'/',i6) *ident up64 */ broadr -- 19dec96 -- a step value of 2.0 often matches the energy */ step in the evaluation. this can lead to */ problems with an if test where some machines */ can take one branch, and some the other. this */ can be prevented by using an unusual value */ for step. discovered by trkov on dec alpha. */ this is not a problem unless fairly coarse */ tolerances are used for reconstruction */ (for example, test problem 1). *d broadr.783 data nstack/12/, nmax/10/ data step/2.01/, rmax/3.0/, errmin/1.e-15/ *ident up65 */ acer -- 19dec96 -- fix a bad calling sequence. this normally */ causes no problem, but compilers notice. *d acer.718 call tosend(nine,noute,0,a(iscr)) *ident up66 */ powr -- 19dec96 -- fix a bad calling sequence. this normally */ causes no problem, but compilers notice. *d powr.220 100 call fast(iprint,igprnt) *ident up67 */ thermr -- 3mar97 -- fix problems with temperature interpolation */ when there is only one temperature by allowing */ a small band of temperatures to work. */ this patches errors made in up36. *d up36.19 if (tt1.gt.temp) a(ifl+6+2*nr)=temp *i thermr.1329 tempt=temp *d up36.30 if (tt1.gt.tempt) a(iscr+6+2*nr)=tempt *d up36.40 if (tt1.gt.tempt) a(iscr+6+2*nr)=tempt *ident up68 */ acer -- 25mar97 -- keep all the charged particle reactions */ in the ace file to use for particle production *d acer.1924 if (mt.gt.301.and.mt.lt.444) go to 260 if (iverf.lt.6) then if (mt.gt.444.and.mt.lt.700) go to 260 if (mt.gt.800) go to 260 else if (mt.gt.444.and.mt.lt.600) go to 260 if (mt.gt.850) go to 260 endif *i acer.4580 c ***keep all reactions that survived unionx c ***including mt=3,4 when needed for photon production *d acer.4594 *d up13.10 *d up19.7 if (mt.eq.1.or.mt.eq.2) go to 105 if (mt.eq.301) go to 105 *d acer.4597 if (mt.lt.5.or.mt.gt.91) go to 105 *d acer.4600 *i acer.4713 c ***keep all reactions that survived unionx c ***including mt=3,4 when needed for photon production *d up13.13 *d up19.9,10 *d up13.16 *d up19.14 *d up13.17 if (mth.lt.5) go to 241 if (mth.gt.150) go to 241 *d acer.4777,4788 c ***add mt=3 and/or 4 if needed for photon production 255 do 256 if12=1,nf12s mtd=mf12s(if12) if (mtd.eq.3.and.if12s.eq.0) then if12s=1 go to 257 else if (mtd.eq.4.and.if12s.eq.0) then if12s=2 go to 257 else if (mtd.eq.4.and.if12s.eq.1) then if12s=3 go to 257 endif 256 continue go to 260 257 call findf(matd,3,mtd,nin) call contio(nin,0,0,a(iscr),nb,nw) go to 205 260 continue */ acer -- 5mar97 -- fill in the name string for damage */ that was omitted in up19 *i acer.7263 data hndf10(1)/'damage '/ */ acer -- 25mar97 -- allow for isotropic photons at some energies *i up48.101 i=i-1 *i up48.124 lc=nex+2*ne *d up48.128 if (n2h.eq.2) go to 1756 *i up48.132 lc=lc+33 go to 1760 1756 xss(nex+ne+ie)=0 *d up48.134 nex=lc+1 */ acer -- 28mar97 -- watch out for a special case in the numerics */ for equally probable bins (aneed close to zero) *d up52.58 200 if (aneed.lt.1.e-4) go to 215 slpe=(p(j)-p(k))/(amu(j)-amu(k)) *i up52.72 215 tbmu(l)=amu(k)+aneed/p(k) go to 235 */ acer -- 28apr97 -- provide more storage for thermal file six *d acer.8350 ninmax=3000 *i acer.8480 if (loc.gt.ninmax) call error('acesix', 1 'exceeded storage for incoherent elastic',' ') *ident up69 */ reconr -- 4apr97 -- fix a special case for evaluations with upper */ energy greater than 20 mev. if eresh=20e6, */ the 20 mev point gets removed, which can */ spoil any discontinuity that might appear */ there when matching high-energy data to the */ older low-energy data. the result is a */ glitch in the total and the reactions with */ a starting singularity at 20 mev (eg, mt=5). */ the logic to remove eresh is really there for */ ordinary resonance ranges, and it is safe */ to leave it there at 20 mev. *i reconr.1442 if (eg.gt.19.e6) go to 415 *ident up70 */ groupr -- 1dec96 -- modify thermal interpolation */ to expose the interpolated points */ and to use unit base at low energies *i groupr.5563 dimension fl1(20),fl2(20),fi(20),fl(20) *i groupr.5686 do 320 il=1,nl fl(il)=0. 320 continue eg=0. eb=0.1*elo c write(6,'(''e='',1p,e12.4,'' ('',2e12.4,'')'')') e,elo,ehi *d groupr.5701,5762 if (egp1.lt.eb) then egp1=egp*eb/(e-elo+eb) egp2=egp*(ehi-elo+eb)/(e-elo+eb) endif c c ***get next point projected from low side 345 if (k1.gt.nlo) go to 360 ek1=a(l2+6+ncyc*(k1-1)) if (ek1.gt.1.00001*eg1) go to 355 k1=k1+1 go to 345 360 ek1=a(l3+6+ncyc*(nhi-1)) 355 ei1=ek1+e-elo if (ek1.lt.0.1*elo) ei1=ek1*(e-elo+eb)/eb c c ***get next point projected from high side 375 if (k2.gt.nhi) go to 450 ek2=a(l3+6+ncyc*(k2-1)) if (ek2.gt.1.00001*eg2) go to 385 k2=k2+1 go to 375 385 ei2=ek2-ehi+e if (ek2.lt.ehi-elo+eb) 1 ei2=ek2*(e-elo+eb)/(ehi-elo+eb) c c ***do integrals to next point ei=egp if (ei1.lt.ei) ei=ei1 if (ei2.lt.ei) ei=ei2 if (ei.eq.egp) then call aedi(egp1,fl1,nl,a(l2)) call aedi(egp2,fl2,nl,a(l3)) else if (ei.eq.ei1) then call aedi(ek1,fl1,nl,a(l2)) ee=ek1+ehi-elo if (ek1.lt.eb) ee=ek1*(ehi-elo+eb)/eb call aedi(ee,fl2,nl,a(l3)) eg1=ek1 eg2=ee else if (ei.eq.ei2) then ee=ek2-ehi+elo if (ee.lt.eb) ee=ek2*eb/(ehi-elo+eb) call aedi(ee,fl1,nl,a(l2)) call aedi(ek2,fl2,nl,a(l3)) eg2=ek2 eg1=ee endif f1=(ehi-e)/(ehi-elo) f2=(e-elo)/(ehi-elo) do 390 il=1,nl fi(il)=f1*fl1(il)+f2*fl2(il) 390 continue c write(6,'(1p,3e12.4)') ei,fi(1),fi(2) do 395 il=1,nl aed(il,i)=aed(il,i)+0.5*(fi(il)+fl(il))*(ei-eg) fl(il)=fi(il) 395 continue eg=ei if (ei.lt.egp) go to 345 *i groupr.5859 c subroutine aedi(ee,fl,nl,aa) c ****************************************************************** c interpolate for legendre components of thermal scattering at ee c ****************************************************************** dimension fl(nl),aa(*) dimension p(20) c ncyc=nint(aa(6)) nw=nint(aa(5)) np=nw/ncyc nu=ncyc-2 do 100 il=1,nl fl(il)=0. 100 continue do 110 i=1,np-1 ip=i if (ee.le.aa(7+ncyc*i)) go to 120 110 continue go to 170 120 f1=(aa(7+ncyc*ip)-ee)/(aa(7+ncyc*ip)-aa(7+ncyc*(ip-1))) f2=(ee-aa(7+ncyc*(ip-1)))/(aa(7+ncyc*ip)-aa(7+ncyc*(ip-1))) do 150 iu=1,nu u=aa(8+iu+ncyc*(ip-1)) call legndr(u,p,nl) do 130 il=1,nl fl(il)=fl(il)+f1*aa(8+ncyc*(ip-1))*p(il)/nu 130 continue u=aa(8+iu+ncyc*ip) call legndr(u,p,nl) do 140 il=1,nl fl(il)=fl(il)+f2*aa(8+ncyc*ip)*p(il)/nu 140 continue 150 continue 170 continue return end *ident up71 */ plotr -- 15oct96 -- provide automatic reaction loops *i plotr.153 c * mtd=0 means loop over all reactions in mfd * c * (usually one page per mt, but for mf=3, * c * resonance reactions may have several pages) * *i plotr.288 character*10 name *i plotr.537 iauto=0 if (mtd.eq.0) iauto=1 ipass=0 *i plotr.625 c c ***auto reaction loop goes through here. *d plotr.627 1600 call contio(nin,0,0,a,nb,nw) if (mfh.eq.0.and.iauto.eq.1) nplot=1 if (mfh.eq.0.and.iauto.eq.1) go to 110 mtd=mth if (iauto.gt.0.and.ipass.eq.0) eht=0. if (iauto.gt.0) then elt=0. xleft=0. xright=0. xstep=0. ybot=0. ytop=0. ystep=0. endif *d plotr.823 1409 nnn=0 if (mmf.eq.6) then *i plotr.831 nnn=nint(a(6)) *i plotr.834 jnoth=0 if (enext.lt.1.e3) jnoth=1 ipass=ipass+1 *i plotr.837 iii=0 ee1=0. ee2=0. *i plotr.838 iii=iii+1 *i plotr.846 if (jnoth.eq.1.and.nnn.gt.3000) then if (iii.eq.300) ee1=enow if (iii.eq.nnn-500) ee2=enow endif *i plotr.854 if (ee1.ne.0.) then jj=log10(ee1) ee1=10.**jj endif if (ee2.ne.0.) then jj=log10(ee2) ee2=10.**jj endif if (iauto.gt.0) then itype=1 if (jnoth.eq.1.and.ipass.gt.2) itype=4 if (ipass.gt.2.and.ee1.eq.0.) ipass=5 if (jnoth.eq.1.and.ee1.gt.0..and.ipass.eq.4) then elt=ee1 eht=ee1*100. if (eht.gt.ee2) eht=ee2 xleft=elt xright=eht xstep=1. if (eht.eq.ee2) ipass=5 endif if (jnoth.eq.1.and.ee1.gt.0..and.ipass.eq.5) then elt=ee1*100 eht=ee2 xleft=elt xright=eht xstep=1. endif endif *i plotr.927 call tosend(nin,0,0,a) c c ***for automatic linear plots of non-threshold reactions, c ***readjust the vertical scale to make high-energy data show up if (iauto.eq.0) go to 610 if (itype.gt.2) go to 610 if (x(1)/factx.gt.1.) go to 610 etmax=x(n-1) st1=0. st2=0. st3=0. st4=y(n-1) do 391 i=1,n if (x(i).gt..20*etmax.and.y(i).gt.st1) st1=y(i) if (x(i).gt..33*etmax.and.y(i).gt.st2) st2=y(i) if (x(i).gt..50*etmax.and.y(i).gt.st3) st3=y(i) 391 continue stmax=1.1*st1 if (stmax.gt.50.*st4) stmax=1.1*st2 if (stmax.lt.st3) stmax=st3 stmin=0. call ascale(4,stmin,stmax,major,minor) ststp=stmax/major ybot=0. ytop=stmax ystep=ststp *d plotr.970 2380 write(strng,'(''for mf6/mt'',i3)') mtd call mess('plotr','no distribution, no plot',strng) call tosend(nin,0,0,a) if (iauto.gt.0) go to 1600 *i plotr.1046 call tosend(nin,0,0,a) *i plotr.1101 if (lf.eq.1) go to 2520 call mess('plotr','can only plot mf5/lf1',' ') call tosend(nin,0,0,a) if (iauto.gt.0) go to 1600 go to 110 *i plotr.1168 call tosend(nin,0,0,a) *i plotr.1499 call tosend(nin,0,0,a) *i plotr.1058 if (iauto.gt.0) call rname(mtd,name) if (iauto.gt.0) write(t2,'(''mf='',i2,'' mt='',i3,2x,a)') 1 mfd,mtd,name *i plotr.1095 if (iauto.gt.0) go to 1600 *i plotr.1184 if (iauto.gt.0) call rname(mtd,name) if (iauto.gt.0) write(t2,'(''mf='',i2,'' mt='',i3,2x,a)') 1 mfd,mtd,name *i plotr.1233 if (iauto.gt.0) go to 1600 *i plotr.1510 if (iauto.gt.0) call rname(mtd,name) if (iauto.gt.0) write(t2,'(''mf='',i2,'' mt='',i3,2x,a)') 1 mfd,mtd,name *i plotr.1533 if (iauto.gt.0) go to 1600 *i plotr.1579 if (iauto.gt.0) call rname(mtd,name) if (iauto.gt.0) write(t2,'(''mf='',i2,'' mt='',i3,2x,a)') 1 mfd,mtd,name *i plotr.1614 if (jnoth.eq.0) ipass=0 if (jnoth.eq.1.and.ipass.eq.5) ipass=0 if (iauto.gt.0.and.ipass.gt.0) go to 320 if (iauto.gt.0) go to 1600 *i plotr.1969 c subroutine rname(mt,name) c ****************************************************************** c return the reaction name for an endf mt number c ****************************************************************** common/util/npage,iverf character*10 name character*10 hndf(424) character*10 hndf1(50),hndf2(48),hndf3(51) character*10 hndf4(50),hndf5(50),hndf6(50) character*10 hndf7(50),hndf8(50) character*10 hndf9(7) character*10 hndf10(16) character*10 h719,h739,h759,h779,h799 character*10 h301,h443,h444 character*10 h251,h252,h253 equivalence (hndf1(1),hndf(1)), (hndf2(1),hndf(51)), 1 (hndf3(1),hndf(99)) equivalence (hndf4(1),hndf(150)) equivalence (hndf5(1),hndf(200)) equivalence (hndf6(1),hndf(250)) equivalence (hndf7(1),hndf(300)) equivalence (hndf8(1),hndf(350)) equivalence (hndf9(1),hndf(401)) equivalence (hndf10(1),hndf(408)) data hndf1/ 'total ', 'elastic ', 'nonelastic', 1 'inelastic ', '(n,x) ', '(n,2n_1f) ', '(n,2n_2f) ', 2 '(n,2n_3f) ', '(n,2n_4f) ', '(n,x) ', '(n,2nd) ', 3 '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', 4 '(n,2n) ', '(n,3n) ', 'fission ', '(n,f) ', 5 '(n,n''f) ', '(n,2nf) ', '(n,n''a) ', '(n,n'')3a ', 6 '(n,2n)a ', '(n,3n)a ', '(m,2n)iso ', '(n,abs) ', 7 '(n,n''p) ', '(n,n''a) ', '(n,2n)2a ', '(n,x) ', 8 '(n,n''d) ', '(n,n''t) ', '(n,n''he3)', '(n,n'')d2a', 9 '(n,n'')t2a', '(n,4n) ', '(n,3nf) ', '(n,x) ', a '(n,x) ', '(n,2np) ', '(n,3np) ', '(n,n2p) ', b '(n,npa) ', '(n,x) ', '(n,2n_1s) ', '(n,2n_2s) ', c '(n,2n_3s) ', '(n,2n_4s) ', '(n,x) '/ data hndf2/ 1 '(n,n_1) ', '(n,n_2) ', '(n,n_3) ', '(n,n_4) ', 2 '(n,n_5) ', '(n,n_6) ', '(n,n_7) ', '(n,n_8) ', 3 '(n,n_9) ', '(n,n_10) ', '(n,n_11) ', '(n,n_12) ', 4 '(n,n_13) ', '(n,n_14) ', '(n,n_15) ', '(n,n_16) ', 5 '(n,n_17) ', '(n,n_18) ', '(n,n_19) ', '(n,n_20) ', 6 '(n,n_21) ', '(n,n_22) ', '(n,n_23) ', '(n,n_24) ', 7 '(n,n_25) ', '(n,n_26) ', '(n,n_27) ', '(n,n_28) ', 8 '(n,n_29) ', '(n,n_30) ', '(n,n_31) ', '(n,n_32) ', 9 '(n,n_33) ', '(n,n_34) ', '(n,n_35) ', '(n,n_36) ', a '(n,n_37) ', '(n,n_38) ', '(n,n_39) ', '(n,n_40) ', b '(n,n_c) ', '(n,x) ', '(n,x) ', '(n,x) ', c '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) '/ data hndf3/ 1 '(n,n'')g ', '(n,x) ', '(n,parab) ', '(n,g) ', 2 '(n,p) ', '(n,d) ', '(n,t) ', '(n,he3) ', 3 '(n,a) ', '(n,2a) ', '(n,3a) ', '(n,x) ', 4 '(n,2p) ', '(n,pa) ', '(n,t2a) ', '(n,d2a) ', 5 '(n,pd) ', '(n,pt) ', '(n,da) ', '(n,x) ', 6 '(n,x) ', '(n,dest) ', '(n,x) ', '(n,x) ', 7 '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', 8 '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', 9 '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', a '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', b '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', c '(n,x) ', '(n,x) ', '(n,x) ', '(n,x) ', d '(n,x) ', '(n,x) ', '(n,x) '/ data hndf4/'(n,p_0) ', 1 '(n,p_1) ', '(n,p_2) ', '(n,p_3) ', '(n,p_4) ', 2 '(n,p_5) ', '(n,p_6) ', '(n,p_7) ', '(n,p_8) ', 3 '(n,p_9) ', '(n,p_10) ', '(n,p_11) ', '(n,p_12) ', 4 '(n,p_13) ', '(n,p_14) ', '(n,p_15) ', '(n,p_16) ', 5 '(n,p_17) ', '(n,p_18) ', '(n,p_19) ', '(n,p_20) ', 6 '(n,p_21) ', '(n,p_22) ', '(n,p_23) ', '(n,p_24) ', 7 '(n,p_25) ', '(n,p_26) ', '(n,p_27) ', '(n,p_28) ', 8 '(n,p_29) ', '(n,p_30) ', '(n,p_31) ', '(n,p_32) ', 9 '(n,p_33) ', '(n,p_34) ', '(n,p_35) ', '(n,p_36) ', a '(n,p_37) ', '(n,p_38) ', '(n,p_39) ', '(n,p_40) ', b '(n,p_41) ', '(n,p_42) ', '(n,p_43) ', '(n,p_44) ', c '(n,p_45) ', '(n,p_46) ', '(n,p_47) ', '(n,p_48) ', d '(n,p_c) '/ data hndf5/'(n,d_0) ', 1 '(n,d_1) ', '(n,d_2) ', '(n,d_3) ', '(n,d_4) ', 2 '(n,d_5) ', '(n,d_6) ', '(n,d_7) ', '(n,d_8) ', 3 '(n,d_9) ', '(n,d_10) ', '(n,d_11) ', '(n,d_12) ', 4 '(n,d_13) ', '(n,d_14) ', '(n,d_15) ', '(n,d_16) ', 5 '(n,d_17) ', '(n,d_18) ', '(n,d_19) ', '(n,d_20) ', 6 '(n,d_21) ', '(n,d_22) ', '(n,d_23) ', '(n,d_24) ', 7 '(n,d_25) ', '(n,d_26) ', '(n,d_27) ', '(n,d_28) ', 8 '(n,d_29) ', '(n,d_30) ', '(n,d_31) ', '(n,d_32) ', 9 '(n,d_33) ', '(n,d_34) ', '(n,d_35) ', '(n,d_36) ', a '(n,d_37) ', '(n,d_38) ', '(n,d_39) ', '(n,d_40) ', b '(n,d_41) ', '(n,d_42) ', '(n,d_43) ', '(n,d_44) ', c '(n,d_45) ', '(n,d_46) ', '(n,d_47) ', '(n,d_48) ', d '(n,d_c) '/ data hndf6/'(n,t_0) ', 1 '(n,t_1) ', '(n,t_2) ', '(n,t_3) ', '(n,t_4) ', 2 '(n,t_5) ', '(n,t_6) ', '(n,t_7) ', '(n,t_8) ', 3 '(n,t_9) ', '(n,t_10) ', '(n,t_11) ', '(n,t_12) ', 4 '(n,t_13) ', '(n,t_14) ', '(n,t_15) ', '(n,t_16) ', 5 '(n,t_17) ', '(n,t_18) ', '(n,t_19) ', '(n,t_20) ', 6 '(n,t_21) ', '(n,t_22) ', '(n,t_23) ', '(n,t_24) ', 7 '(n,t_25) ', '(n,t_26) ', '(n,t_27) ', '(n,t_28) ', 8 '(n,t_29) ', '(n,t_30) ', '(n,t_31) ', '(n,t_32) ', 9 '(n,t_33) ', '(n,t_34) ', '(n,t_35) ', '(n,t_36) ', a '(n,t_37) ', '(n,t_38) ', '(n,t_39) ', '(n,t_40) ', b '(n,t_41) ', '(n,t_42) ', '(n,t_43) ', '(n,t_44) ', c '(n,t_45) ', '(n,t_46) ', '(n,t_47) ', '(n,t_48) ', t '(n,t_c) '/ data hndf7/'(n,he3_0) ', 1 '(n,he3_1) ', '(n,he3_2) ', '(n,he3_3) ', '(n,he3_4) ', 2 '(n,he3_5) ', '(n,he3_6) ', '(n,he3_7) ', '(n,he3_8) ', 3 '(n,he3_9) ', '(n,he3_10)', '(n,he3_11)', '(n,he3_12)', 4 '(n,he3_13)', '(n,he3_14)', '(n,he3_15)', '(n,he3_16)', 5 '(n,he3_17)', '(n,he3_18)', '(n,he3_19)', '(n,he3_20)', 6 '(n,he3_21)', '(n,he3_22)', '(n,he3_23)', '(n,he3_24)', 7 '(n,he3_25)', '(n,he3_26)', '(n,he3_27)', '(n,he3_28)', 8 '(n,he3_29)', '(n,he3_30)', '(n,he3_31)', '(n,he3_32)', 9 '(n,he3_33)', '(n,he3_34)', '(n,he3_35)', '(n,he3_36)', a '(n,he3_37)', '(n,he3_38)', '(n,he3_39)', '(n,he3_40)', b '(n,he3_41)', '(n,he3_42)', '(n,he3_43)', '(n,he3_44)', c '(n,he3_45)', '(n,he3_46)', '(n,he3_47)', '(n,he3_48)', h '(n,he3_c) '/ data hndf8/'(n,a_0) ', 1 '(n,a_1) ', '(n,a_2) ', '(n,a_3) ', '(n,a_4) ', 2 '(n,a_5) ', '(n,a_6) ', '(n,a_7) ', '(n,a_8) ', 3 '(n,a_9) ', '(n,a_10) ', '(n,a_11) ', '(n,a_12) ', 4 '(n,a_13) ', '(n,a_14) ', '(n,a_15) ', '(n,a_16) ', 5 '(n,a_17) ', '(n,a_18) ', '(n,a_19) ', '(n,a_20) ', 6 '(n,a_21) ', '(n,a_22) ', '(n,a_23) ', '(n,a_24) ', 7 '(n,a_25) ', '(n,a_26) ', '(n,a_27) ', '(n,a_28) ', 8 '(n,a_29) ', '(n,a_30) ', '(n,a_31) ', '(n,a_32) ', 9 '(n,a_33) ', '(n,a_34) ', '(n,a_35) ', '(n,a_36) ', a '(n,a_37) ', '(n,a_38) ', '(n,a_39) ', '(n,a_40) ', b '(n,a_41) ', '(n,a_42) ', '(n,a_43) ', '(n,a_44) ', c '(n,a_45) ', '(n,a_46) ', '(n,a_47) ', '(n,a_48) ', d '(n,a_c) '/ data hndf10/ 1 'free gas ', 'H(H2O) ', 'poly ', ' ', 2 'H(ZrH) inc', 'H(ZrH) coh', 'benzine ', 'D(D2O) ', 3 'graph inc ', 'graph coh ', 'Be inc ', 'Be coh ', 4 'BeO inc ', 'BeO coh ', 'Zr(ZrH)inc', 'Zr(ZrH)coh'/ data h719/'(n,p_c)x '/ data h739/'(n,d_c)x '/ data h759/'(n,t_c)x '/ data h779/'(n,he3_c)x'/ data h799/'(n,a_c)x '/ data hndf9/'(n,xn) ','(n,xg) ','(n,xp) ', 1 '(n,xd) ','(n,xt) ','(n,xhe3) ','(n,xa) '/ data h301/'heating '/ data h443/'kerma '/ data h444/'damage '/ data h251/'mubar '/ data h252/'xi '/ data h253/'gamma '/ c if (iverf.ge.6) then i=mt if (i.ge.201.and.i.le.207) i=i+200 if (i.ge.600) i=i-450 name=hndf(i) if (mt.ge.221.and.mt.le.236) name=hndf(408+mt-221) if (mt.eq.251) name=h251 if (mt.eq.252) name=h252 if (mt.eq.253) name=h253 if (mt.eq.301) name=h301 if (mt.eq.443) name=h443 if (mt.eq.444) name=h444 else if (mt.lt.150) then name=hndf(mt) else if (mt.ge.201.and.mt.le.207) then name=hndf(mt+200) else if (mt.ge.221.and.mt.le.236) then name=hndf(408+mt-221) else if (mt.ge.700.and.mt.lt.718) then name=hndf(mt-550) else if (mt.eq.718) then name=hndf(199) else if (mt.eq.719) then name=h719 else if (mt.ge.720.and.mt.lt.738) then name=hndf(mt-520) else if (mt.eq.738) then name=hndf(249) else if (mt.eq.739) then name=h739 else if (mt.ge.740.and.mt.lt.758) then name=hndf(mt-490) else if (mt.eq.758) then name=hndf(299) else if (mt.eq.759) then name=h759 else if (mt.ge.760.and.mt.lt.779) then name=hndf(mt-460) else if (mt.eq.778) then name=hndf(349) else if (mt.eq.779) then name=h779 else if (mt.ge.780.and.mt.lt.798) then name=hndf(mt-430) else if (mt.eq.798) then name=hndf(399) else if (mt.eq.799) then name=h799 else if (mt.eq.301) then name=h301 else if (mt.eq.443) then name=h444 else if (mt.eq.444) then name=h443 else if (mt.eq.251) then name=h251 else if (mt.eq.252) then name=h252 else if (mt.eq.253) then name=h253 else name='unknown ' endif endif return end */ plotr -- 15oct96 -- thin e grid for angular distributions. */ if the energy step is fairly large, don't thin. */ if the difference between this distribution and */ the last is large, don't thin. *d plotr.293 dimension ex3(200),ey3(200) *i plotr.309 data maxxy/200/ *i plotr.993 estep=0.2e6 varlim=0.08 nthind=0 *d plotr.1013 if (i.ge.maxxy) go to 2460 *i plotr.1045 c check for possible thinning if (i.eq.1) go to 2460 if (ie.eq.ne) go to 2460 if (ey3(i).gt.ey3(i-1)+estep) go to 2460 var=0. do 2461 imu=1,nmu var=var+(aa(locn-imu-nmum)-aa(locn-imu))**2 2461 continue if (var.gt.varlim) go to 2460 nthind=nthind+1 locn=locn-nmum i=i-1 nmax=nmax-1 *i plotr.1046 if (nthind.gt.0) then write(strng,'(''for mt='',i3)') mtd call mess('plotr','mf4 incident energy grid thinned',strng) endif *d plotr.1051 if (i.ge.maxxy) call mess('plotr', *d plotr.1138 if (i.ge.maxxy) go to 2545 */ plotr -- 15oct -- add color to the plots (see also up51). */ make input consistent with viewer. *d plotr.35 c * lori page orientation (def=1) * c * 0 portrait (7.5x10in) * c * 1 landscape (10x7.5in) * *i plotr.41 c * (default=0.30) * c * ipcol page color (def=white) * c * 0=white * c * 1=navajo white * c * 2=blanched almond * c * 3=antique white * c * 4=very pale yellow * c * 5=very pale rose * c * 6=very pale green * c * 7=very pale blue * *i plotr.53 c * iwcol window color (def=white) * c * color list same as for ipcol above * *d plotr.57 c * ww,wh,wr window width, height, and rotation angle * *d plotr.65 c * default=none * *d plotr.70 c * default=none * *d plotr.230,231 c * iccol curve color (def=black) * c * 0=black * c * 1=red * c * 2=green * c * 3=blue * c * 4=magenta * c * 5=cyan * c * 6=brown * c * 7=purple * c * ithick thickness of curve (def=1) * c * 0 = invisible (for shaded areas) * c * ishade shade pattern * c * 0 = none * c * 1 to 10 = 10% to 100% gray * c * 11 to 20 = 45 deg right hatching * c * 21 to 30 = 45 deg left hatching * c * 31 to 40 = 45 deg cross hatching * c * 41 to 50 = shades of green * c * 51 to 60 = shades of red * c * 61 to 70 = shades of brown * c * 71 to 80 = shades of blue * c * default=0 * *d plotr.264 c * terminate with empty card (/) * *i plotr.310 c default paper size is US letter size. c see similar statements in viewr. xpaper=8.5 ypaper=11.0 *d plotr.326,327 1 '('' enter lori[1], istyle[2], size[.30], '', 2 ''ipcol[white]'')') nz=4 *i plotr.330 z(4)=0 *d plotr.335,336 ipcol=nint(z(4)) write(nsyso,15) lori,istyle,size,ipcol write(nplt,'(2i2,f8.3,i8,'' /'')') lori, istyle,size,ipcol c default page size is paper size with 0.5in margins all around *d plotr.338,339 xpage=xpaper-1.0 ypage=ypaper-1.0 *d plotr.341,342 xpage=ypaper-1.0 ypage=xpaper-1.0 *d plotr.348,357 110 nz=9 z(1)=1 z(2)=0 z(3)=1. z(4)=1. z(5)=0. z(6)=0. z(7)=xpage z(8)=ypage z(9)=0. if (ntty.gt.0) write(ntty,'('' enter iplot[1], '', 1 ''iwcol[white], factx[1.], facty[1.], xll[0.], yll[0.], '', 2 ''ww[xpage], wh[ypage], wr[0.]'')') *d plotr.360,365 iwcol=nint(z(2)) factx=z(3) facty=z(4) xll=z(5) yll=z(6) ww=z(7) wh=z(8) wr=z(9) *d plotr.367 write(nsyso,20) iplot,iwcol,factx,facty,xll,yll,ww,wh,wr *d plotr.541 nz=6 *d plotr.545 z(4)=0 z(5)=1 z(6)=0 *d plotr.552,553 iccol=nint(z(4)) ithick=nint(z(5)) ishade=nint(z(6)) write(nsyso,45) icon,isym,idash,iccol,ithick,ishade *d plotr.1057 write(nplt,'(i4,i8,7f7.2,''/ 3d plot'')') iplot,iwcol, 1 factx,facty,xll,yll,ww,wh,wr *i plotr.1078 write(nplt,'(''/'')') *i plotr.1204 write(nplt,'(''/'')') *i plotr.1530 write(nplt,'(''/'')') *d plotr.1183 write(nplt,'(i4,i8,7f7.2,''/ 3d plot'')') iplot,iwcol, 1 factx,facty,xll,yll,ww,wh,wr *d plotr.1509 write(nplt,'(i4,i8,7f7.2,''/ 3d plot'')') iplot,iwcol, 1 factx,facty,xll,yll,ww,wh,wr *d plotr.1546 c ***loop thru input lines until an empty card is found *d plotr.1551 2 '' terminate list with empty card (/)'')') *i plotr.1553 z(1)=-99. z(2)=-99. *d plotr.1559 if (z(1).eq.-99..and.z(2).eq.-99.) go to 520 *d plotr.1575 610 write(nplt,'(i4,i8,7f7.2,''/ 2d plot'')') iplot,iwcol, 1 factx,facty,xll,yll,ww,wh,wr *d plotr.1602 611 write(nplt,'(''/'')') write(nplt,'(5i6,i8,''/'')') icon,isym,idash,iccol,ithick,ishade *d plotr.1633 3 40h size ................................. ,f10.3/ 4 40h ipcol ................................ ,i10) *i plotr.1635 2 40h iwcol ................................ ,i10/ *d plotr.1640,1641 5 40h ww ................................... ,f10.3/ 6 40h wh ................................... ,f10.3/ 7 40h wr ................................... ,f10.3) *d plotr.1673 3 40h iccol ................................ ,i10/ 4 40h ithick ............................... ,i10/ 5 40h ishade ............................... ,i10) *ident up72 */ viewr -- 15oct96 -- add color for plots. */ make input consistent with plotr. *d viewr.44,45 c * 0 portrait (7.5x10in) * c * 1 landscape (10x7.5in) * *i viewr.52 c * ipcol page color (def=white) * c * 0=white * c * 1=navajo white * c * 2=blanched almond * c * 3=antique white * c * 4=very pale yellow * c * 5=very pale rose * c * 6=very pale green * c * 7=very pale blue * *i viewr.64 c * iwcol window color (def=white) * c * color list same as for ipcol above * *d viewr.154 c * card 8 -- dummy input card for consistency with plotr * c * it always should be 0/ * c * * c * -----cards 9 and 10 for 2d plots only----- * *d viewr.156 c * card 9 * *i viewr.198 c * iccol curve color (def=black) * c * 0=black * c * 1=red * c * 2=green * c * 3=blue * c * 4=magenta * c * 5=cyan * c * 6=brown * c * 7=purple *i viewr.207 c * 41 to 50 = shades of green * c * 51 to 60 = shades of red * c * 61 to 70 = shades of brown * c * 71 to 80 = shades of blue * *d viewr.210 c * card 10 ---ileg.ne.0 only--- * *d viewr.215 c * card 10a ---ileg.eq.2 only--- * *d viewr.221 c * -----card 11 for 3d plots only----- * *d viewr.223 c * card 11 * *d viewr.232 c * card 12 * *d viewr.239 c * card 13 ---nform = 0 only--- 2-d data * *d viewr.252 c * card 14 ---nform = 1 only--- 3-d data * *d viewr.257 c * card14a ---nform = 1 only--- * *d viewr.268,269 common/setup1/lori,xpage,ypage,istyle,size,ipcol,wline common/setup2/iwcol,xll,yll,ww,wh,wa,xg,yg *d viewr.275 common/setup5/icon,isym,idash,ithick,ishade,iccol *i viewr.294 c default paper size is US letter size. c see similar statements in plotr. xpaper=8.5 ypaper=11.0 *d viewr.312 nz=4 *i viewr.315 z(4)=0 *i viewr.319 ipcol=nint(z(4)) *i viewr.319 c default page size is paper size with 0.5in margin all around *d viewr.321,322 xpage=ypaper-1.0 ypage=xpaper-1.0 *d viewr.324,325 xpage=xpaper-1.0 ypage=ypaper-1.0 *d viewr.328 write(nsyso,15) lori,xpage,ypage,istyle,size,ipcol *d viewr.336,344 110 nz=9 z(1)=1 z(2)=0 z(3)=1. z(4)=1. z(5)=0. z(6)=0. z(7)=xpage z(8)=ypage z(9)=0. *d viewr.347,353 iwcol=nint(z(2)) factx=z(3) facty=z(4) xll=z(5) yll=z(6) ww=z(7) wh=z(8) wa=z(9) *d viewr.355 write(nsyso,20) iplot,iwcol,factx,facty,xll,yll,ww,wh,wa *i viewr.453 c c ***read dummy card for consistency with plotr input 250 nz=1 call infree(nsysi,z,nz,ncw) *d viewr.456,457 if (i3d.eq.1) go to 280 nz=6 *d viewr.461,462 z(4)=0 z(5)=1 z(6)=0 *d viewr.467,469 iccol=nint(z(4)) ithick=nint(z(5)) ishade=nint(z(6)) write(nsyso,45) icon,isym,idash,iccol,ithick,ishade *d viewr.625 4 40h size ................................. ,f10.3/ 5 40h ipcol ................................ ,i10) *i viewr.627 2 40h iwcol ................................ ,i10/ *i viewr.656 2 40h iccol ................................ ,i10/ *i viewr.697 c ipcol page color *i viewr.699 c iwcol window color *i viewr.766 c iccol curve color *d viewr.777,778 common/setup1/lori,xpage,ypage,istyle,size,ipcol,wline common/setup2/iwcol,xll,yll,ww,wh,wr,xg,yg *d viewr.784 common/setup5/icon,isym,idash,ithick,ishade,iccol *d viewr.796 call initp(lori,xpage,ypage,istyle,hlab,wline,0,ipcol) *d viewr.804 call init2(xpos,ypos,xg,yg,jtype,iwcol) *d viewr.910 300 call frame2(xg,yg,grace,iccol) *d viewr.938 common/setup1/lori,xpage,ypage,istyle,size,ipcol,wline *d viewr.987,988 common/setup1/lori,xpage,ypage,istyle,size,ipcol,wline common/setup5/icon,isym,idash,ithick,ishade,iccol *d viewr.1056 common/setup1/lori,xpage,ypage,istyle,size,ipcol,wline *d viewr.1119,1120 common/setup1/lori,xpage,ypage,istyle,size,ipcol,wline common/setup2/iwcol,xll,yll,ww,wh,wr,xg,yg *d viewr.1139 if (iplot.eq.1) 1 call initp(lori,xpage,ypage,istyle,hlab,wline,0,ipcol) *d viewr.1143 call init3(x3,y3,z3,xv,yv,zv,iwcol) *i viewr.1318 call grid3(1,-1,1) *d viewr.1518 subroutine initp(iori,xpage,ypage,istyle,htt,wtt,ibord,ipcol) *d viewr.1522 c font height, normal line weight, and page background color. *i viewr.1530 common/plot11/ifg,ibg dimension x(5),y(5) *i viewr.1535 ibg=1+ipcol ifg=1 *d viewr.1550,1555 n=5 x(1)=0. y(1)=0. x(2)=xpage y(2)=0. x(3)=xpage y(3)=ypage x(4)=0. y(4)=ypage x(5)=x(1) y(5)=y(1) w=.005 call poly2(x,y,n,w,1.) *i viewr.1568 common/plot11/ifg,ibg ifg=1 *d viewr.1643 subroutine init2(uo,vo,xg,yg,iright,iwcol) *i viewr.1650 c iwcol is the background color of the inside of the graph frame. *i viewr.1655 common/plot11/ifg,ibg dimension x(5),y(5) *i viewr.1684 c c ***color in the background inside the graph frame. ibg=1+iwcol ifg=1 call transw(uo,vo,ull,vll) call transw(uo+xg,vo+yg,uur,vur) n=5 x(1)=ull y(1)=vll x(2)=uur y(2)=vll x(3)=uur y(3)=vur x(4)=ull y(4)=vur x(5)=x(1) y(5)=y(1) w=.005 call poly2(x,y,n,w,1.) *d viewr.1688 subroutine frame2(xg,yg,grace,iccol) *i viewr.1690 c and set foreground color for this curve *i viewr.1691 common/plot11/ifg,ibg ifg=1+iccol *d viewr.1709 subroutine init3(bx,by,bz,vx,vy,vz,iwcol) *i viewr.1716 common/plot11/ifg,ibg c c ***set color of 3d slices to the window color ibg=1+iwcol ifg=1 *d viewr.1746,1747 if (bx.gt.0.) call trans3(0.,-5.*ht,0.,u,v) if (bx.lt.0.) call trans3(bx,-5.*ht,0.,u,v) *d viewr.1752,1753 if (bx.gt.0.) call trans3(0.,by,bz+ht,u,v) if (bx.lt.0.) call trans3(bx,by,bz+ht,u,v) *d viewr.1764,1765 if (bx.gt.0.) call trans3(bx+3.*ht,by+2.*ht,0.,u,v) if (bx.lt.0.) call trans3(3.*ht,by+2.*ht,0.,u,v) *d viewr.2380 120 if (ny.le.0) go to 140 *i viewr.2390 else *d viewr.2429 140 if (nz.le.0) go to 160 *i viewr.2439 else *i viewr.2485 common/plot11/ifg,ibg *d viewr.2518 if (ishade.gt.0.and.ishade.le.10) then ifg=ishade call fillh(0.) ifg=0 else if (ishade.gt.40) then ifg=ishade call fillh(0.) ifg=0 endif *i viewr.3102 write(nps,'(''%%EOF'')') *i viewr.3156 common/plot11/ifg,ibg common/plot12/ibrgb(3,8),ifrgb(3,8),isrgb(3,40) *i viewr.3166 r=ifrgb(1,ifg)/256. g=ifrgb(2,ifg)/256. b=ifrgb(3,ifg)/256. write(nps,'(3f6.3,'' setrgbcolor'')') r,g,b *d viewr.3231 subroutine fillh(color) *d viewr.3233 c fill current path with background (1.) or foreground (0.) color. c this may be a discrete color, or one of a progression of c grays or shading colors used to show values. *d viewr.3236 common/plot11/ifg,ibg common/plot12/ibrgb(3,8),ifrgb(3,8),isrgb(3,40) if (color.gt..99) then r=ibrgb(1,ibg)/256. g=ibrgb(2,ibg)/256. b=ibrgb(3,ibg)/256. else if (color.lt..01.and.ifg.le.10) then r=0.1*(10-ifg) g=0.1*(10-ifg) b=0.1*(10-ifg) else if (color.lt..01.and.ifg.le.40) then r=ifrgb(1,ifg)/256. g=ifrgb(2,ifg)/256. b=ifrgb(3,ifg)/256. else if (color.lt..01.and.ifg.gt.40) then r=isrgb(1,ifg-40)/256. g=isrgb(2,ifg-40)/256. b=isrgb(3,ifg-40)/256. endif write(nps,'(''gsave'',3f6.3,'' setrgbcolor fill grestore'')') 1 r,g,b */ viewr -- 15oct96 -- adjust the zero position on the paper. *i viewr.3072 c set up for US letter size paper (xpaper=8.5in, ypaper=11.0in). c see separate setting for xpaper and ypaper at the start of viewr. c there are also default settings for the page size in plotr. *i viewr.3074 common/plot13/xpaper,ypaper common/plot14/ushift,vshift,uwidth xpaper=8.5 ypaper=11.0 *d viewr.3080,3081 i1=0.5*(xpaper-xpage)*72 i2=0.5*(ypaper-ypage)*72 i3=i1+xpage*72 i4=i2+ypage*72 ushift=i1 vshift=i2 uwidth=xpage*72 *d viewr.3083,3084 i1=0.5*(ypaper-xpage)*72 i2=0.5*(xpaper-ypage)*72 i3=i1+ypage*72 i4=i2+xpage*72 ushift=i2 vshift=i1 uwidth=ypage*72 *d viewr.3086,3089 *i viewr.3155 common/plot14/ushift,vshift,uwidth *d viewr.3158,3161 u1=uwidth-72*y+ushift v1=72*x+vshift *i viewr.3182 common/plot14/ushift,vshift,uwidth *d viewr.3163,3164 u1=72*x+ushift v1=72*y+vshift *d viewr.3215,3218 u=uwidth-72*y+ushift v=72*x+vshift *d viewr.3220,3221 u=72*x+ushift v=72*y+vshift *i viewr.3643 common/plot14/ushift,vshift,uwidth *d viewr.3647,3651 u1=uwidth-72*y+ushift v1=72*x+vshift rr=72*r *d up20.6,8 u1=72*x+ushift rr=72*r v1=72*y+vshift *i viewr.3672 common/plot14/ushift,vshift,uwidth *d viewr.3679,3682 u=uwidth-72*y+ushift v=72*x+vshift *d up20.10,11 u=72*x+ushift v=72*y+vshift *i viewr.3732 c loads color tables into common. there are separate rgb c tables for background and foreground colors. *i viewr.3738 common/plot12/ibrgb(3,8),ifrgb(3,8),isrgb(3,40) dimension ibrns(30),ireds(30),igrns(30),iblus(30) equivalence (isrgb(1,1),igrns(1)) equivalence (isrgb(1,11),ireds(1)) equivalence (isrgb(1,21),ibrns(1)) equivalence (isrgb(1,31),iblus(1)) *i viewr.3795 c c color tables c light colors for backgrounds data ibrgb/ 255,255,255, ! white 1 255,222,173, ! navajo white 2 255,235,205, ! blanched almond 3 250,235,215, ! antique white 4 255,255,198, ! very pale yellow 5 255,197,220, ! very pale rose 6 205,250,205, ! very pale green 7 172,233,250/ ! very pale blue c dark colors for foregrounds (curves) data ifrgb/ 0, 0, 0, ! black 1 225, 0, 0, ! red 2 0,200, 0, ! green 3 0, 0,225, ! blue 4 225, 0,225, ! magenta 5 0,225,225, ! cyan 6 170,102, 35, ! brown 7 160, 32,240/ ! purple c progressive shades of brown data ibrns/ 255,218,177, 1 243,195,142, 2 237,179,108, 3 225,159, 75, 4 215,140, 76, 5 200,131, 62, 6 175,117, 52, 7 160, 90, 33, 8 140, 72, 29, 9 121, 62, 25/ c progressive shades of green data igrns/ 205,255,205, 1 175,235,175, 2 135,225,135, 3 110,210,110, 4 90,180, 90, 5 80,160, 80, 6 70,140, 70, 7 64,125, 64, 8 55,107, 55, 9 45, 90, 45/ c progressive shades of blue data iblus/ 192,237,253, 1 135,164,229, 2 120,120,220, 3 100,100,210, 4 70, 70,200, 5 40, 40,195, 6 21, 21,182, 7 20, 20,170, 8 16, 16,140, 9 0, 0,125/ c progressive shades of red data ireds/ 255,206,206, 1 235,195,195, 2 230,118,118, 3 215, 90, 90, 4 206, 60, 60, 5 200, 40, 30, 6 188, 39, 20, 7 175, 32, 32, 8 160, 0, 0, 9 135, 0, 0/ */ viewr -- 19dec96 -- fix bad parameter list *d viewr.2307 subroutine grid2(nx,ny) *ident up73 */ dtfr -- 15oct96 -- adapt to the new viewr format *d dtfr.933 write(nplot,'('' 1 0 1. 1.'',5f6.2,''/'')') *d dtfr.936 write(nplot,'('' -1 0 1. 1.'',5f6.2,''/'')') *d dtfr.956 write(nplot,'(''/'')') write(nplot,'('' 0 0 0 0 1/'')') *d dtfr.1008 write(nplot,'(''/'')') write(nplot,'(i5,i3,i3,'' 0 1/'')') lin,nsym,ndash *d dtfr.1254 write(nplot,'('' 1 0 1. 1.'',5f6.2,''/ 3d data'')') *d dtfr.1257 write(nplot,'('' -1 0 1. 1.'',5f6.2,''/ 3d data'')') *i dtfr.1269 write(nplot,'(''/'')') *d dtfr.1341 write(nplot,'('' 1 0 1. 1.'',5f6.2,''/ 3d data'')') *d dtfr.1344 write(nplot,'('' -1 0 1. 1.'',5f6.2,''/ 3d data'')') *i dtfr.1385 write(nplot,'(''/'')') *ident up74 */ covr -- 15oct96 -- adjust to use new viewr format *d covr.31 c * ---cards 2, 2a, and 3a for nout.ne.0 only (plot option) * *i covr.32 c * card 2 * c * icolor select color or monochrome style * c * 0=monochrome (uses cross hatching) * c * 1=color background and contours * c * (default=0) * *i covr.92 common/cov0/icolor *i covr.145 if (ntty.gt.0) write(ntty,24) nz=1 z(1)=0 call infree(nsysi,z,nz,4) icolor=nint(z(1)) *d covr.217 1 write(nsyso,50) nin,nout,nplot,icolor,irelco,ncase,noleg, *d covr.249 write(nplot,'(''1 2 .22'',i3,''/'')') icolor *i covr.433 24 format(/16h enter icolor.) *i covr.443 2 40h icolor ............................... ,i10/ *i covr.885 common/cov0/icolor *d covr.937 write(nplot,'(''1 0 1. 1.'',5f8.3,''/'')') *i covr.946 write(nplot,'(''/'')') *d covr.992 write(nplot,'(''-1 0 1. 1.'',5f8.3,''/'')') *d covr.1002 write(nplot,'(''/'')') write(nplot,'(''0 0 0 0 1/'')') *d covr.1015 write(nplot,'(''-1 0 1. 1.'',5f8.3,''/'')') *d covr.1021 write(nplot,'(''-1 0 1. 1.'',5f8.3,''/'')') *i covr.1036 common/cov0/icolor *d covr.1178 write(nplot,'(''-1 0 1. 1.'',5f8.3,''/'')') *i covr.1189 write(nplot,'(''/'')') *d covr.1191,1192 if (icolor.eq.0) then if (ilevel.gt.1) jpat=15+ilevel if (ilevel.lt.-1) jpat=34-ilevel else if (ilevel.gt.1) jpat=40+2*ilevel if (ilevel.lt.-1) jpat=50-2*ilevel endif *d covr.1193 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *d covr.1205 write(nplot,'(''-1 0 1. 1.'',5f8.3,''/'')') *d covr.1212 write(nplot,'(''-1 0 1. 1.'',5f8.3,''/'')') *i covr.1220 write(nplot,'(''/'')') *d covr.1222 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *i covr.1230 write(nplot,'(''/'')') *d covr.1231 if (icolor.eq.0) jpat=27 if (icolor.ne.0) jpat=40 jpat=jpat+1 if (icolor.ne.0) jpat=jpat+1 *d covr.1232 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *i covr.1240 write(nplot,'(''/'')') *d covr.1241 jpat=jpat+1 if (icolor.ne.0) jpat=jpat+1 *d covr.1242 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *i covr.1250 write(nplot,'(''/'')') *d covr.1251 jpat=jpat+1 if (icolor.ne.0) jpat=jpat+1 *d covr.1252 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *i covr.1260 write(nplot,'(''/'')') *d covr.1261 jpat=jpat+1 if (icolor.ne.0) jpat=jpat+1 *d covr.1262 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *d covr.1271 write(nplot,'(''-1 0 1. 1.'',5f8.3,''/'')') *i covr.1279 write(nplot,'(''/'')') *d covr.1281 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *i covr.1289 write(nplot,'(''/'')') *d covr.1290 if (icolor.eq.0) jpat=36 if (icolor.ne.0) jpat=50 jpat=jpat+1 if (icolor.ne.0) jpat=jpat+1 *d covr.1291 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *i covr.1299 write(nplot,'(''/'')') *d covr.1300 jpat=jpat+1 if (icolor.ne.0) jpat=jpat+1 *d covr.1301 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *i covr.1309 write(nplot,'(''/'')') *d covr.1310 jpat=jpat+1 if (icolor.ne.0) jpat=jpat+1 *d covr.1311 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat *i covr.1319 write(nplot,'(''/'')') *d covr.1320 jpat=jpat+1 if (icolor.ne.0) jpat=jpat+1 *d covr.1321 write(nplot,'(''0 0 0 0 0'',i3,''/'')') jpat */ covr -- 15oct96 -- reposition elements on the page *d covr.898,899 xsize=5.00 ysize=3.38 *d covr.934,935 xpos=ysize-.75 ypos=xsize-1.00 *d covr.989,990 xpos=ysize+.50 ypos=-.25 *d covr.1012,1013 xpos=2.00 ypos=xsize-.75 *d covr.1173,1174 xsize=5.00 ysize=3.38 *d covr.1175,1176 xpos=ysize-.75 ypos=-.25 *d covr.1202,1203 400 xpos=ysize-.75+xsize+.60 ypos=.75 *d covr.1211 ypos=.625 */ covr -- 15oct96 -- remove unused variables *d covr.893 *d covr.1459 1 nmed1,nmee1,nmef1,nmeg1,nmeh1 *ident up75 */ acer -- 15oct96 -- adapt acer to new viewr features *i acer.10247 c c ***default colors are black and white ipcol=0 iwcol=0 iccol=0 *d acer.10251 write(nout,'(''1 2 .30'',i3,''/'')') ipcol *d acer.10279 write(nout,'(''1'',i3,''/'')') iwcol *i acer.10290 write(nout,'(''/'')') *i acer.10308 write(nout,'(''/'')') *i acer.10325 write(nout,'(''/'')') *i acer.10343 write(nout,'(''/'')') *d up19.198 write(nout,'(''1'',i3,''/'')') iwcol *i up19.210 write(nout,'(''/'')') *d up19.283 write(nout,'(''1'',i3,''/'')') iwcol *i up19.295 write(nout,'(''/'')') *i up19.314 write(nout,'(''/'')') *d acer.10380 write(nout,'(''1'',i3,''/'')') iwcol *i acer.10391 write(nout,'(''/'')') *d up19.59 write(nout,'(''1'',i3,''/'')') iwcol *i up19.71 write(nout,'(''/'')') *d acer.10439 write(nout,'(''1'',i3,''/'')') iwcol *i acer.10450 write(nout,'(''/'')') *i acer.10459 if (nlev.gt.1) write(nout,'(''/'')') *d acer.10510 write(nout,'(''1'',i3,''/'')') iwcol *i acer.10521 write(nout,'(''/'')') *i acer.10539 write(nout,'(''/'')') *i acer.10556 write(nout,'(''/'')') *i acer.10574 write(nout,'(''/'')') *d acer.10613 write(nout,'(''1'',i3,''/'')') iwcol *i acer.10624 write(nout,'(''/'')') *d up19.128 write(nout,'(''1'',i3,''/'')') iwcol *i up19.140 write(nout,'(''/'')') *d acer.10675 write(nout,'(''1'',i3,''/'')') iwcol *i acer.10686 write(nout,'(''/'')') *i acer.10695 if (nlev.gt.1) write(nout,'(''/'')') *d acer.10752 write(nout,'(''1'',i3,''/'')') iwcol *i acer.10763 write(nout,'(''/'')') *i acer.10774 if (nlev.gt.1) write(nout,'(''/'')') *d acer.10841 write(nout,'(''1'',i3,''/'')') iwcol *i acer.10852 write(nout,'(''/'')') *i acer.10868 if (nlev.gt.1) write(nout,'(''/'')') *d acer.10927 write(nout,'(''1'',i3,''/'')') iwcol *i acer.10938 write(nout,'(''/'')') *i acer.10949 if (nlev.gt.1) write(nout,'(''/'')') *d acer.11102 write(nout,'(''1'',i3,''/'')') iwcol *i acer.11109 write(nout,'(''/'')') *i acer.11111 if (j.gt.1) write(nout,'(''/'')') *d acer.11226 write(nout,'(''1'',i3,''/'')') iwcol *i acer.11235 write(nout,'(''/'')') *d acer.11320 write(nout,'(''1'',i3,''/'')') iwcol *i acer.11329 write(nout,'(''/'')') *d acer.11418 write(nout,'(''1'',i3,''/'')') iwcol *i acer.11427 write(nout,'(''/'')') *d acer.11526 write(nout,'(''1'',i3,''/'')') iwcol *i acer.11535 write(nout,'(''/'')') *d acer.11715 write(nout,'(''1'',i3,''/'')') iwcol *i acer.11722 write(nout,'(''/'')') *d acer.11862 write(nout,'(''1'',i3,''/'')') iwcol *i acer.11869 write(nout,'(''/'')') *ident up76 */ heatr -- 15oct96 -- adapt for new viewr input specs. *d heatr.4298 write(nplot,'(''*Energy-Balance Check*/'')') *i heatr.4304 write(nplot,'(''/'')') *i heatr.4308 write(nplot,'(''/'')') *i heatr.4312 write(nplot,'(''/'')') *d heatr.4358 write(nplot,'(''*Energy-Balance Check*/'')') *i heatr.4364 write(nplot,'(''/'')') *i heatr.4368 write(nplot,'(''/'')') *i heatr.4372 write(nplot,'(''/'')') *d heatr.4422 write(nplot,'(''*Energy-Balance Check*/'')') *i heatr.4428 write(nplot,'(''/'')') *i heatr.4432 write(nplot,'(''/'')') *i heatr.4436 write(nplot,'(''/'')') *d heatr.4485 write(nplot,'(''*Energy-Balance Check*/'')') *i heatr.4491 write(nplot,'(''/'')') *i heatr.4495 write(nplot,'(''/'')') *i heatr.4499 write(nplot,'(''/'')') *ident up77 */ njoy -- 10jul97 -- fix the format fixed in up63 again! *d up63.6 30 format(60x,'id ',a4,1x,i3,'/',i6) *ident up78 */ broadr -- 10jul97 -- fix the calculation of "term" in hnab, */ which was numerically ill-posed, and */ could cause overflows on short-exponent */ machines (trkov, ijs slovenia) *d broadr.1301 fact=h *d broadr.1303 fact=fact*h/m *d broadr.1329 190 term=fact*xk*qmn *ident up79 */ groupr -- 10jul97 -- fix the calculation of "term" in hnab, */ which was numerically ill-posed, and */ could cause overflows on short-exponent */ machines (trkov, ijs slovenia) *d groupr.7585 fact=h *d groupr.7587 fact=fact*h/m *d groupr.7613 290 term=fact*xk*qmn *ident up80 */ matxsr -- 10jul97 -- remove the capital "m" that eroneously */ appeared during up51 (trkov) *d up51.37 common/locd/nritev,nritem *d up51.39 common/locd/nritev,nritem *d up51.41 common/locd/nritev,nritem *ident up81 */ gaminr -- 10jul97 -- make variable "rndoff" correct for */ short-word machines. this caused an */ infinite loop for test problem 3 on */ an hp machine (trkov) *d gaminr.1007 *if sw data rndoff/1.000001/ *else data rndoff/1.0000001/ *endif *ident up82 */ wimsr -- 10jul97 -- extensive improvements to the wimsr module */ based on the work of a.trkov, inst.j.stefan, */ ljubljana, slovenia, in connection with an */ international effort on wims and wims data. */ */ These three update were provided by Trkov, and his comments */ are included. We have not tested them, but there has been */ quite a bit of testing, and there is some international */ agreement on the code and format extensions. REM */ */ Corrections to wimsr module of njoy94.0 as in upijs5 for njoy91.91 */ Revised: Dec-96 */ - change to lowercase for convenience */ - call to "free" replaced by "infree" */ - add common "wim5" to the main module (ref.Leszczynski) */ - correct format to print current spectrum (ref.Leszczynski) */ WARNING: The updates were developed in several stages, addressing */ one thing at a time, so there exist several "layers" of */ updates. There are cases where the "*b" Update command */ is used to avoid refering to the active lines from a */ previous layer of updates. This would cause problems if */ the ident name would be changed. There is a bug in the */ "upd1.3" emulator in routine "before" where the test on */ "nact" refers to the old limit of 1000, even though the */ array sizes are correctly dimensioned to 5000. If the */ updates below are added after "up50" for NJOY94, say, */ the update will not be completed successfully. */ (NOTE: the upd.f in this package has */ been properly updated. REM ) */ */ fix printout format errors in wimsr (a.trkov,94/4) *i wimsr.129 3 '' print option ......................... '',i10/ *d wimsr.202 5 '' pot. scatt. cross section ............ '',0p,f10.2/ */ group index undefined in rsiout *i wimsr.673 call findex('egb',iegb,a) */ */ preserve awr definition and convert to atomic weight where necessary *d wimsr.303 awr=c2h *d wimsr.1788 awt=awr*1.0086652 write(nout,40) ident,awt,iznum,ifis,ntemp,nrestb,isof */ */ check for the presence of mf3, mt252 and print a warning *d wimsr.319 c check for presence of mf3, mt252, mf3, mt18 and mf6, mt18. *i wimsr.323 i252=0 *i wimsr.329 if (mfh.eq.3.and.mth.eq.252) i252=1 *i wimsr.353 if (i252.ne.1) then write(strng,'(''mat '',i4,'' has no mf3, mt252 '')') mat call mess('wminit',strng 1 ,'isotropic c.m.scattering will be assumed') endif */ */ initialize aver.log.decrement per collision assuming isotropic scatt. *i wimsr.852 c preset aver.log.decrement per collision assuming isotropic scatt. alf=(awr-1.)/(awr+1.) alf=alf*alf xxi=1.+ alog(alf)*alf/(1.-alf) *i wimsr.854 a(i-1+ixi)=xxi */ */ allow sigp to be the energy-dependent self shielded scatt. x-sect. *i wimsr.814 call reserv('spot',ngnd,ispot,a) *i wimsr.854 a(i-1+ispot)=sigp *i wimsr.1262 call findex('spot',ispot,a) *i wimsr.1193 c replace constant potential with scattering cross section if (sigp.eq.0.) a(ispot+i-1)=a(iscat+i-1) *d wimsr.1279 if (iverw.eq.5) write(nscr2) (a(ispot+i-1),i=ngr0,ngr1), *d wimsr.1284 if (iverw.eq.4) write(nscr2) (a(ispot+i-1),i=ngr0,ngr1), *d wimsr.1292 write(nsyso,30) (a(ispot+i-1),i=ngr0,ngr1) */ */ let entering a large ref.sig0 (>=1.e10barns) always imply inf.dilution *d wimsr.849 if (sgref.lt.dilinf) isg=1 */ */ if a reference sig0 value (<1.e10 barns) is entered which is not on */ the input sig0 list, print a message. all group constants will be */ entered corresponding to the first sig0 on the list (usually at */ inf.dilution). this differs from the option when ref. sig0=1.e10 barns */ where the group constants involving the scattering cross section are */ entered corresponding to the last sig0 on the list (i.e. fully shielded). *d wimsr.889,891 if (abs(sgref-a(l+5+ntw+i)).gt.sgref*.01) go to 147 iz=i go to 148 147 continue write(strng, 1 '(''ref. sig0'',1p,e10.3,'' not on the list'')') sgref call mess('xsecs ',strng,'first entry used as default') iz=1 sgref=a(l+5+ntw+iz) */ */ if all cross sections are self shielded, pick the corresponding */ self shielded capture and fission cross sections *i wimsr.944 if (isg.gt.0 .and. nz.ge.iz) loca=l+lz+nl*(iz-1+nz) *b wimsr.955 if (isg.gt.0 .and. nz.ge.iz) loca=l+lz+nl*(iz-1+nz) */ */ upgrade the input instructions corresponding to the above extensions *i wimsr.46 c * (.ge. 1.e10 to select all cross sect. at inf.dil.* c * but fully shielded elastic x-sect, * c * .lt. 1.e10 to select all x-sect at inf.dil. * c * =sig0 from the list on groupr input to * c * select all x-sect. at that sig0) * *i wimsr.48 c * (if zero, replace by the elastic cross section) * */ */ allow the current spectrum for the transport correction in the */ fast and resonance groups to be read from input *i wimsr.63 c * jp1 transport correction neutron current spectrum flag * c * 0=use p1-flux for transport correction (default) * c * >0=read in jp1 values of the neutron current * c spectrum from input * *i wimsr.77 c * card 8 (only when jp1>0) c * p1flx current spectrum (jp1 entries read, the rest are * c * set with the default p1-flux calculated by njoy). * *d wimsr.180 nz=12 *i wimsr.184 z(12)=0 *i wimsr.196 jp1=nint(z(12)) *d wimsr.208 b '' fission product indicator ............ '',i10/ c '' current spectrum indicator ........... '',i10)') *d wimsr.210 d ip1opt,inorf,isof,ifprod,jp1 *i wimsr.246 c c ***input current spectrum call reserv('p1flx',ngnd,ip1flx,a) do 192 j=1,ngnd 192 a(ip1flx+j-1)=0 if (jp1.lt.1) go to 196 if (ntty.gt.0) write(ntty,'(/'' enter '',i2, 1 '' current spectrum values)'')') jp1 jscr=iscr nz=jp1 call infree(nsysi,a(jscr),nz,4) do 194 j=1,nz 194 a(ip1flx+j-1)=a(jscr+j-1) 196 continue */ */ define p1-flux for transport correction if necessary *i wimsr.835 call findex('p1flx',ip1flx,a) *i wimsr.843 p1nrm=1. *d wimsr.960 c ***p1-flux for transport correction (if not read in from input) c normalize the input current to the first common njoy p1-flux *d wimsr.961 220 loc=ip1flx+jg-1 loca=l+lz+nl*(nz-1) if (isg.gt.0 .and. nz.ge.iz) loca=l+lz+nl*(iz-1) if ( nl.gt.1) loca=loca+1 if (a(loc).eq.0) then a(loc)=a(loca) p1nrm =1. else if(p1nrm.eq.1.) p1nrm=a(loca)/a(loc) a(loc)=a(loc)*p1nrm endif */ */ replace explicitly dimensioned csigp1 by a reserved work space at icsp1 *d wimsr.805 *i wimsr.834 call reserv('csp1',ngnd,icsp1,a) *d wimsr.854 a(i-1+icsp1)=0. *d wimsr.1049 c accumulate a(icsp1), the sum of the p1 components of scattering *d wimsr.1051 *d wimsr.1053 a(icsp1-1+jg)=a(icsp1-1+jg)+a(loca+1) *d wimsr.1107 c accumulate a(icsp1), the sum of the p1 components of scattering */ correct the transport correction expression for fast & resonance groups *d wimsr.1109,1110 if (jg2.lt.nth) a(icsp1-1+jg2)= 1 a(icsp1-1+jg2)+a(loca+1)*a(ip1flx+jg-1)/a(ip1flx+jg2-1) *d wimsr.1111 */ correct scattering matrix together with transport cross section *d wimsr.1044 if (jg2-jg.lt.-1 .and. a(loca).lt.0.) go to 290 *d wimsr.1057 *d wimsr.1058,1059 *d wimsr.1060 *d wimsr.1061,1062 *d wimsr.1112 *d wimsr.1113,1114 *i wimsr.1188 if (ip1opt.gt.0) 1 a(locxs+(i-1)*(1+ngnd))=a(locxs+(i-1)*(1+ngnd))-a(icsp1-1+i) */ accumulate the scattering cross section (rather than elastic */ only) from the self-shielded scattering matrices. reconstruct */ transport from scattering, absorption and p1-correction. *i wimsr.863 a(i-1+iscat)=0. *d wimsr.976,981 240 continue *d wimsr.1046 loc=iscat+jg-1 *d wimsr.1101 loc=iscat+jg-1 *d wimsr.1189 440 a(i-1+locxtr)=a(i-1+iscat)+a(i-1+locab0)-a(icsp1-1+i) */ */ for some combinations of data, neutron fission yield was incorrect. */ define: jfisd for delayed nu-bar (mt455), */ jfist for total nu-bar (mt452), */ jfiss =1 when using total nu-bar, */ jfiss =2 when reconstructing from fission matrix. */ reconstruction from fission matrix is used preferentially, provided */ the delayed nu-bar data are present. a message is printed if nu-bar */ reconstruction remains incomplete. */ */ accumulate nu-bar from fission matrix into locnus, otherwise store it */ at inu. this avoids problem when multiple temparatures are requested. *b wimsr.852 jfisd=0 jfist=0 *d wimsr.991 245 continue *d wimsr.993 if (jfiss.eq.0) jfiss=1 *d wimsr.996 jfist=1 loc=inu+jg-1 *d wimsr.1014 jfisd=1 locn=locnus+jg-1 *d wimsr.1125 jfiss=2 *d wimsr.1127 locn=locnus+jg-1 *d wimsr.1160 if (jfiss.lt.2) go to 380 if (jfisd.lt.1 .and. jfist.gt.0) go to 380 *d wimsr.1163 if (a(locsfi+i-1).ne.0.) a(inu+i-1)=a(locnus+i-1)/a(locsfi+i-1) *i wimsr.1164 if (jfisd.eq.1) go to 380 write(strng,'(''nu-bar calculated from fission matrix'')') call mess('xsecs',strng,'only prompt contribution available') */ */ save fission cross section at inf.dil. which is needed when calculating */ nu-bar from fission matrix *i wimsr.822 call reserv('sfi',ngnd,locsfi,a) *d wimsr.953 216 loc=locsfi+jg-1 *i wimsr.954 a(loc)=a(loc)+a(loca) loc=locsf0+jg-1 */ */ fix nf (jfis) parameter and printout logic for resonance integrals *d wimsr.1196,1197 jfis=0 if (ires.gt.0) jfis=1 if (jfis.ge.1 .and. jfiss.gt.0) jfis=3 if (jfis.gt.1 .and. inorf.gt.0) jfis=2 if (jfis.eq.0 .and. jfiss.gt.0) jfis=4 *d wimsr.1198 *d wimsr.1199,1200 *d wimsr.1201 *d wimsr.1844 if (ifis.ne.3) go to 179 */ */ preset to zero only those cross sections which are accumulated from */ partial contributions to avoid overwriting temperature-independent */ constants *d wimsr.856,857 *d wimsr.859,863 *d wimsr.865 *d wimsr.869,871 *d wimsr.1180 410 a(i-1+locab0)=a(i-1+locsf0)+a(i-1+iabs1)+a(i-1+iabs2)-a(i-1+in2n) *d wimsr.945 a(loc)=a(loca) */ */ reverse the sequence of calls to resint and xsecs *d wimsr.250,252 *i wimsr.256 c ***process effective resonance integrals. call resint(a) c */ */ save the non-resonant contribution to absorption *b wimsr.815 call reserv('abs2',ngnd,iabs2,a) *d wimsr.829 */ */ use nu-bar, sig.pot. and non-resonant contribution to absorption in resint *d wimsr.407 *i wimsr.413 call findex('nu',locnu,a) call findex('spot',ispot,a) call findex('abs2',iabs2,a) */ */ use sig.potential stored at ispot in xsecs to define resonance integrals *i wimsr.668 call findex('spot',ispot,a) *d wimsr.625 siglam=a(ispot+nfg+jg-1)*a(iglam+jg-1) *d wimsr.680 siglam=a(ispot+nfg+jg-1)*a(iglam+jg-1) *d wimsr.1232 c release work array space but save nu, spot and abs2 610 call releas('l1',-1,a) */ */ use nu-bar stored at locnu in xsecs to define the neutron fiss.yield */ *d wimsr.433,434 *d wimsr.451,452 *d wimsr.468 *d wimsr.472 *d wimsr.475,476 *d wimsr.486 *d wimsr.492 *d wimsr.495 *d wimsr.542,564 *d wimsr.580 locn=locnu+nfg+jg-1 *d wimsr.585 *d wimsr.587 *d wimsr.588 *d wimsr.589 *d wimsr.590 */ */ preset the absorption with the non-resonant part from xsecs *d wimsr.426 *d wimsr.427 *d wimsr.428 do 114 jg=1,nrg abs2=a(iabs2+nfg+jg-1) do 114 is=1,nwflxr i=(jg-1)*nwflxr+is a(i-1+locabs)=abs2 */ */ allow different number of temperatures for the resonance and the */ thermal energy groups (redefine ires to imply the number of */ temperatures in the resonance groups when ires>0) *i wimsr.42 c * in the thermal energy range *d wimsr.47 c * ires resonance absorber indicator * c * 0=no resonance tables * c * >0=ires temperatures processed * *d wimsr.198 1 '' no. temperatures (thermal)............ '',i10/ *d wimsr.201 4 '' resonance absorber (0=no, >0=no.temp.) '',i10/ *i wimsr.365 if (ires.gt.0 .and. ntemp.lt.ires) ires=jtemp *i wimsr.370 if(ires.gt.ntemp) nwflx=ires*nsigz*nrg *d wimsr.400 ntsr=ires*nsigz*nrg *d wimsr.404 nwflxr=ires*nsigz *d wimsr.408,409 call reserv('abs',ires,iabs,a) nwelas=ires*nsigz*nrg *d wimsr.411 *d wimsr.412 nwfa=ires*nsigz *d wimsr.501 175 iadd=nsigz+nsigz*(jtemp-1+ires*(jg-1)) *d wimsr.511 loc=iflux+nsigz+nsigz*(jtemp-1+ires*(jg-1)) *d wimsr.525 215 iadd=nsigz+nsigz*(jtemp-1+ires*(jg-1)) *d wimsr.536 221 iadd=nsigz+nsigz*(jtemp-1+ires*(jg-1)) *d wimsr.572 320 if (jtemp.ge.ires) go to 400 *d wimsr.582,583 do 410 jtem=1,ires iterm=jz-1+nsigz*ires*(jg-1)-nsigz *d wimsr.595 do 430 it=1,ires *d wimsr.602,603 do 440 it=1,ires index=iflux+jz-1+nsigz*(it-1+ires*(jg-1)) *d wimsr.605 indexl=iflux+jz-1+nsigz*(it-2+ires*(jg-1)) *d wimsr.611,612 if (ires.eq.1) go to 455 do 445 it=1,ires *d wimsr.615 loc=locabs+nsigz*(it-2+ires*(jg-1)) *d wimsr.626,627 do 465 it=1,ires loca=locabs+nsigz*(it-1+ires*(jg-1)) *d wimsr.633 if (ix.eq.2) loc=locnus+nsigz*(it-1+ires*(jg-1)) *d wimsr.676 ntnp=ires*nsigz *d wimsr.678 write(nscr) xid,ires,nsigz *d wimsr.681 loc=locabs+ires*nsigz*(jg-1) *d wimsr.682 write(nscr) (tempr(j),j=1,ires), *d wimsr.684 2 ((a(loc-1+nsigz*(jtemp-1)+j),j=1,nsigz),jtemp=1,ires) *d wimsr.686 loc=locnus+ires*nsigz*(jg-1) *d wimsr.687 write(nscr) (tempr(j),j=1,ires), *d wimsr.689 2 ((a(loc-1+nsigz*(jtemp-1)+j),j=1,nsigz),jtemp=1,ires) *d wimsr.691 loc=ielas+ires*nsigz*(jg-1) *d wimsr.692 write(nscr) (tempr(j),j=1,ires), *d wimsr.694 2 ((a(loc-1+nsigz*(jtemp-1)+j),j=1,nsigz),jtemp=1,ires) *d wimsr.701 write(nsyso,50) (tempr(i),i=1,ires) *d wimsr.707 do 120 it=1,ires *d wimsr.708 locf=iflux-1+nsigz*(it-1+ires*(ig-1)) *d wimsr.733 do 160 it=1,ires *d wimsr.734 loca=loc-1+nsigz*(it-1+ires*(ig-1)) *d wimsr.755 do 180 it=1,ires *d wimsr.756 loca=ielas-1+nsigz*(it-1+ires*(ig-1)) *d wimsr.1835 read(nscr1) xid,jres,jsigz *d wimsr.1839 write(nout,50) rid,jres,jsigz *d wimsr.1841 nw=jres+jsigz+ntnp *d wimsr.1847 write(nout,50) rid,jres,jsigz *d wimsr.1855,1856 write(nout,50) rid,jres,jsigz nw=jres+jsigz+ntnp */ */ extension of the burnup flag - suppress printout if iburn<0 *i wimsr.37 c * -1=suppress printout of burnup data * *d wimsr.216 if (iburn.le.0) go to 166 *i wimsr.1780 if (iburn.lt.0) go to 120 *b wimsr.1786 120 continue */ */ a double entry for the material identifier is misleading and */ potentially dangerous. integer nfid is derived from rdfid. *d wimsr.35,36 c * nfid not used * c * rdfid identification of material for the wims library * *i wimsr.169 nfid =rdfid+0.01 */ */ correct for consistency to pick thermal p1 matrix data in group 28 *d wimsr.1587 180 if (ig.gt.nth1.and.ig.le.nth) nth1=ig *d wimsr.1608 if (mth.eq.2.and.ig.le.nth) go to 140 */ */ enter reference sigma-zero index isg into the common wim1 and pick */ the p1 scattering matrices at appropriate sigma-zero where applicable. */ convention: isg=zero when sgref is at infinite dilution, */ =index of the reference sigma=zero otherwise. *d wimsr.84 common/wim1/ngnd,nfg,nrg,igref,iprint,isg, *d wimsr.282 common/wim1/ngnd,nfg,nrg,igref,iprint,isg, *d wimsr.387 common/wim1/ngnd,nfg,nrg,igref,iprint,isg, *d wimsr.655 common/wim1/ngnd,nfg,nrg,igref,iprint,isg, *d wimsr.798 common/wim1/ngnd,nfg,nrg,igref,iprint,isg, *d wimsr.1249 common/wim1/ngnd,nfg,nrg,igref,iprint,isg, *d wimsr.1474 common/wim1/ngnd,nfg,nrg,igref,iprint,isg, *d wimsr.1688 common/wim1/ngnd,nfg,nrg,igref,iprint,isg, *d wimsr.1745 common/wim1/ngnd,nfg,nrg,igref,iprint,isg, *i wimsr.892 if(isg.gt.0) isg=iz *d wimsr.1570,1571 jz=nz if(isg.gt.0 .and. isg.lt.nz) jz=isg loca=l+lz+(il-1)+nl*nz*(i-1)+(jz-1)*nl *d wimsr.1616,1617 jz=nz if(isg.gt.0 .and. isg.lt.nz) jz=isg loca=l+lz+(il-1)+nl*nz*(i-1)+(jz-1)*nl */ */ fix index when writing the p1 scattering matrix to the scratch tape *d wimsr.1877 read(nscr4) (a(iscr+nump1+j-1),j=1,nb) */ */ suppress upscattering from thermal into resonance groups *i wimsr.1191 c suppress upscattering from thermal into resonance groups nthr=nfg+nrg+1 do 430 jg=nthr,ngnd jg2=nint(a(l1+jg-1)) 422 if(jg2.ge.nthr) go to 430 loc1=locxs+jg-1+ngnd*(jg2-1) loc2=locxs+jg-1+ngnd*(nthr-1) a(loc2)=a(loc2)+a(loc1) a(loc1)=0. jg2=jg2+1 a(l1+jg-1)=jg2 go to 422 430 continue *d wimsr.1662 c suppress upscattering from thermal into resonance groups 280 nthr=nfg+nrg+1 do 290 jg=nthr,ngnd jg2=nint(a(l1+jg-1)) 282 if(jg2.ge.nthr) go to 290 loc1=iloc+jg-1+ngnd*(jg2-1) loc2=iloc+jg-1+ngnd*(nthr-1) a(loc2)=a(loc2)+a(loc1) a(loc1)=0. jg2=jg2+1 a(l1+jg-1)=jg2 go to 282 290 continue c print to output and to scratch tape call p1sout(a,jtemp) */ */ correct the error in assembling the fission spectrum *d wimsr.1140 locc=locchi+ngnd-k */ */ delete redundant statements, calls to reserv and findex etc. *d wimsr.835 *d wimsr.825 *d wimsr.827 */ */ allow for a larger number of groups in the future *d wimsr.1237 40 format(/' fission spectrum (groups 1 -',i3,')',/ */ */ correct for consistency with new reaction type assignment *d wimsr.1085 if (mth.ge.221.and.mth.le.250) go to 365 *d wimsr.1565 if (mth.ge.221.and.mth.le.250) go to 155 */ */ remove iu from common wim4 (equivalent to isof), add wim5 *d wimsr.88 common/wim4/isof,nfiss,ifiss common/wim5/ifprod *d wimsr.284 common/wim4/isof,nfiss,ifiss *d wimsr.801 common/wim4/isof,nfiss,ifiss *d wimsr.1748 common/wim4/isof,nfiss,ifiss */ */ reserve space for the spectrum unconditionally *d wimsr.294,295 *d wimsr.304 *d wimsr.305,308 call reserv('uff',ngnd,iuff,a) do 111 i=1,ngnd a(i-1+iuff)=0. 111 continue *d wimsr.838,839 call findex('uff',iuff,a) *d wimsr.1236 *d wimsr.1229 600 if (isof.eq.0.or.iprint.eq.0) go to 610 *d wimsr.1862 190 if (isof.eq.0) go to 195 */ */ flags for fission spetrum processing */ define: jfspt for the total spectrum (mf5 mt452), */ jfspd for the delayed spectrum (mf5 mt455 */ jfspp for the prompt contribution (mf6 mt18 or 19 and 20) *b wimsr.852 jfspd=0 jfspt=0 jfspp=0 *i wimsr.858 a(i-1+locchi)=0. */ */ if fiss.spectrum present, accumulate directly in the output field *i wimsr.1000 jfspt=1 *d wimsr.1004 loc=iuff+jg2-1 *d wimsr.1007 */ */ flag processing of delayed spectrum *d wimsr.1019 255 jfspd=1 do 265 i=2,ng2 *d wimsr.1024 */ */ flag processing of prompt spectrum from fission matrix *b wimsr.1126 jfspp=1 *d wimsr.1135 *d wimsr.1142 */ */ depending on the available data, assemble the fission spectrum *d wimsr.1212,1220 c check for fission spectrum consistency if (jfspt.ne.0) go to 500 if (jfspd.eq.1 .and. jfspp.eq.1) go to 490 write(strng,'(''spectrum calculated from fission matrix'')') call mess('xsecs ',strng,'only prompt contribution available') 490 do 495 i=1,ngnd a(iuff-1+i)=a(locchi-1+i) 495 continue c normalize the fission spectrum 500 cnorm=0. do 510 i=1,ngr1 loc=iuff+i-1 if(a(loc).le.0) go to 510 cnorm=cnorm+a(loc) nfiss=i 510 continue if(cnorm.le.0) go to 520 cnorm=1./cnorm do 515 i=1,nfiss loc=iuff+i-1 a(loc)=a(loc)*cnorm 515 continue *d wimsr.1230 write(nsyso,40) nfiss *d wimsr.1231 write(nsyso,50) (a(iuff-1+i),i=1,nfiss) *d wimsr.1864 write(nout,20) (a(iuff+j-1),j=1,nfiss) */ */ use variable sgref instead of defining equivalent sgrf *d wimsr.89 common/wim6/mat,iznum,awr,sgref,sigp,mti,mtc,ip1opt,inorf,ires *d wimsr.211 *d wimsr.285 common/wim6/mat,iznum,awr,sgref,sigp,mti,mtc,ip1opt,inorf,ires *d wimsr.389 common/wim6/mat,iznum,awr,sgref,sigp,mti,mtc,ip1opt,inorf,ires *d wimsr.657 common/wim6/mat,iznum,awr,sgref,sigp,mti,mtc,ip1opt,inorf,ires *d wimsr.802 common/wim6/mat,iznum,awr,sgref,sigp,mti,mtc,ip1opt,inorf,ires *d wimsr.842 *d wimsr.1251 common/wim6/mat,iznum,awr,sgref,sigp,mti,mtc,ip1opt,inorf,ires *d wimsr.1477 common/wim6/mat,iznum,awr,sgref,sigp,mti,mtc,ip1opt,inorf,ires *d wimsr.1750 common/wim6/mat,iznum,awr,sgref,sigp,mti,mtc,ip1opt,inorf,ires */ */ print the neutron current weighting spectrum *i wimsr.1271 call findex('p1flx',ip1flx,a) *i wimsr.1290 p1nrm=1. if(igref.le.nnt) p1nrm=1./a(ip1flx-1+igref) write(nsyso,60) nnt write(nsyso,30) (p1nrm*a(ip1flx-1+i),i=1,nnt) *i wimsr.1432 60 format(/' neutron current spectrum (groups 1-',i3,')'/ 1 40h ---------------------------------------) */ *ident up83 */ wimsr -- 10jul97 -- continuation of trkov's wimsr changes */ */ Corrections and changes to module wimsr of njoy 94.25 */ made in ENEA-Bologna-Italy (January-March 1996) */ Gian Carlo Panini - Manuela Frisoni - Francisco Leszczynski(*) */ (*) IAEA fellow (c6/arg/95015p (arg/0/008))-permanent adress: */ Centro Atomico Bariloche-8400 S.C.de Bariloche-Argentina */ Revised : September 1996 */ Reviewed: Dec-96 (A.Trkov) */ Some of the original updates were removed or slightly */ modified after a discussion with Dr. Leszczynski */ */ 31mar96 -- more space for more than 69 groups */ (originally proposed size 250000, reduced to 100000, A.Trkov) *d wimsr.82 common/wstore/a(100000) *d wimsr.98,wimsr.99 nwscr=30000 namax=400000 */ */ 16set96 -- correct format for jp1 input add *d wimsr.178,179 1 '(/'' enter ntemp, nsigz, sgref, ires, sigp, mti,mtc,'', 2 '' ip1opt[1], norf[0], isof[0], ifprod[0],jp1[0].'')') */ */ 31mar96 -- format i3 for more than 69 groups *d wimsr.777 1 43hflux per unit lethargy normalized at group ,i3/ */ */ 31mar96 -- format i3 for more than 69 groups */ (format for current spectrum printout corrected in upijs5) *d wimsr.1424 10 format(/' sigma potential (groups ',i3,'-',i3,')'/ *d wimsr.1427 1i3,'-',i3,')'/ *d wimsr.1431 1'(groups ',i3,'-',i3,')'/ *d wimsr.1433 61 format(/' absorption (groups 1-',i3,')'/ *d wimsr.1435 62 format(/' fission (groups 1-',i3,')'/ *d wimsr.1437 63 format(/' nu*fission (groups 1-',i3,')'/ *d wimsr.1439 64 format(/' transport corrected total (groups 1-',i3,')'/ *d wimsr.1442 1 ' (groups ',i3,'-',i3,')'/ *d wimsr.1444 66 format(/' n,2n (groups 1-',i3,')'/ */ */ 31mar96 -- more space for than 69 more groups library *d wimsr.1741 common/wstore/a(100000) */ *ident up84 */ wimsr -- 10jul97 -- continuation of trkov's changes to wimsr */ */ A.Trkov, F.Leszczynski, 26-may-97 */ Incorrect data were written to the wimsr output file when the */ module was called several times in sequence (noticed by Leszczynski) */ Close output data and scratch files to avoid problems. *i wimsr.265 call closz(nout) call closz(nscr0) call closz(nscr1) call closz(nscr2) call closz(nscr3) call closz(nscr4) *d wimsr.392,393 *ident up85 */ broadr -- 10jul97 -- change broadr to use the slatec erfc *i broadr.1211 external erfc *d up25.8,11 *d up25.13,16 *d up25.18,25 f(1)=0.5*erfc(a) *ident up86 */ njoy -- 11jul97 -- provide more accurate math functions */ from the publicly available slatec library *d njoy.2858,3048 c c ---------------------------------------------------------------------- c some mathematical routines taken from the slatec library. the c purpose of this section is to compute the following: c c e1(x) the first-order exponential integral c gami(a,x) the incomplete gamma function c erfc(x) the complementary error function c c njoy runs in single precision on 64-bit machines like the cray. c it can use the same coding on 32-bit machines that can use something c like a "-r8" option to automatically double everything. on systems c running with 32-bits, njoy uses its "set sw" option to promote c selected variables to double precision. therefore, we here provide c some "wrapper" routines to interface from the generic calls to the c corresponding slatec routines. some minor renaming of the slatec c routines was necessary to make this possible. the slatec routines c were modified to have the look and feel of njoy, and to use the c njoy error and message routines. c *if sw double precision function e1(x) double precision x,de1 e1=de1(x) return end double precision function gami(a,x) double precision a,x,dgami gami=dgami(a,x) return end double precision function erfc(x) double precision x,derfc erfc=derfc(x) return end *else function e1(x) e1=se1(x) return end function gami(a,x) gami=sgami(a,x) return end function erfc(x) erfc=serfc(x) return end *endif c c the machine-dependent parameters for the slatec routines are set by c s1mach or d1mach. for njoy, we leave all the lines in these routines c commented out, and we use machine-dependent update idents to set the c one we need for each supported system. c ---------------------------------------------------------------------- *if sw c double precision function de1 (x) c ****************************************************************** c compute the exponential integral e1(x). c taken from the slatec library fnlib de1. c ****************************************************************** double precision x, ae10cs(50), ae11cs(60), ae12cs(41), e11cs(29), 1 e12cs(25), ae13cs(50), ae14cs(64), xmax, xmaxt, d1mach, dcsevl logical first save ae10cs, ae11cs, ae12cs, e11cs, e12cs, ae13cs, ae14cs, 1 ntae10, ntae11, ntae12, nte11, nte12, ntae13, ntae14, xmax, 2 first data ae10cs( 1) / +.3284394579 6166990878 7384420188 1 d-1 / data ae10cs( 2) / -.1669920452 0313628514 7618434338 7 d-1 / data ae10cs( 3) / +.2845284724 3613468074 2489985325 2 d-3 / data ae10cs( 4) / -.7563944358 5162064894 8786693853 3 d-5 / data ae10cs( 5) / +.2798971289 4508591575 0484318087 9 d-6 / data ae10cs( 6) / -.1357901828 5345310695 2556392625 5 d-7 / data ae10cs( 7) / +.8343596202 0404692558 5610290490 6 d-9 / data ae10cs( 8) / -.6370971727 6402484382 7524298853 2 d-10 / data ae10cs( 9) / +.6007247608 8118612357 6083156158 4 d-11 / data ae10cs( 10) / -.7022876174 6797735907 5062615008 8 d-12 / data ae10cs( 11) / +.1018302673 7036876930 9665234688 3 d-12 / data ae10cs( 12) / -.1761812903 4308800404 0630996642 2 d-13 / data ae10cs( 13) / +.3250828614 2353606942 4403035387 7 d-14 / data ae10cs( 14) / -.5071770025 5058186788 2487225904 4 d-15 / data ae10cs( 15) / +.1665177387 0432942981 7248608415 6 d-16 / data ae10cs( 16) / +.3166753890 7975144006 7700353655 5 d-16 / data ae10cs( 17) / -.1588403763 6641415151 3311834353 8 d-16 / data ae10cs( 18) / +.4175513256 1380188330 0303461848 4 d-17 / data ae10cs( 19) / -.2892347749 7071419067 1071447885 2 d-18 / data ae10cs( 20) / -.2800625903 3966081035 0634058966 9 d-18 / data ae10cs( 21) / +.1322938639 5392709037 0758002378 1 d-18 / data ae10cs( 22) / -.1804447444 1773016272 8388783355 7 d-19 / data ae10cs( 23) / -.7905384086 5226160762 9164481760 4 d-20 / data ae10cs( 24) / +.4435711366 3695701039 4623583802 7 d-20 / data ae10cs( 25) / -.4264103994 9781208688 6530920655 5 d-21 / data ae10cs( 26) / -.3920101766 9371175415 5371316204 8 d-21 / data ae10cs( 27) / +.1527378051 3439942663 4375232697 1 d-21 / data ae10cs( 28) / +.1024849527 0493723393 1030878311 7 d-22 / data ae10cs( 29) / -.2134907874 7714335762 6271140588 2 d-22 / data ae10cs( 30) / +.3239139475 1600282670 6169470036 6 d-23 / data ae10cs( 31) / +.2142183762 2998899547 6264316829 6 d-23 / data ae10cs( 32) / -.8234609419 6010184147 0034808231 2 d-24 / data ae10cs( 33) / -.1524652829 6458094796 1369440114 0 d-24 / data ae10cs( 34) / +.1378208282 4606391346 6848036432 5 d-24 / data ae10cs( 35) / +.2131311202 8339478795 2322499925 3 d-26 / data ae10cs( 36) / -.2012649651 5264841218 1746676312 7 d-25 / data ae10cs( 37) / +.1995535662 2633580161 0631178267 3 d-26 / data ae10cs( 38) / +.2798995808 9840034649 4868652031 9 d-26 / data ae10cs( 39) / -.5534511845 3896266376 4081927782 3 d-27 / data ae10cs( 40) / -.3884995396 1599688616 8254402614 6 d-27 / data ae10cs( 41) / +.1121304434 5073593828 5068035467 9 d-27 / data ae10cs( 42) / +.5566568152 4237409482 5656383351 4 d-28 / data ae10cs( 43) / -.2045482929 8104997004 4853393817 6 d-28 / data ae10cs( 44) / -.8453813992 7123362334 1145749367 4 d-29 / data ae10cs( 45) / +.3565758433 4312915628 1611111628 7 d-29 / data ae10cs( 46) / +.1383653872 1256347055 3994909887 1 d-29 / data ae10cs( 47) / -.6062167864 4513724365 8453376477 8 d-30 / data ae10cs( 48) / -.2447198043 9893132674 3765511918 9 d-30 / data ae10cs( 49) / +.1006850640 9339983480 1154818048 0 d-30 / data ae10cs( 50) / +.4623685555 0148690156 6434146167 4 d-31 / data ae11cs( 1) / +.2026315064 7078889499 4012365173 81 d+0 / data ae11cs( 2) / -.7365514099 1203130439 5368987280 34 d-1 / data ae11cs( 3) / +.6390934911 8361915862 7532838400 20 d-2 / data ae11cs( 4) / -.6079725270 5247911780 6531533639 99 d-3 / data ae11cs( 5) / -.7370649862 0176629330 6814114934 84 d-4 / data ae11cs( 6) / +.4873285744 9450183453 4649924880 76 d-4 / data ae11cs( 7) / -.2383706484 0448290766 5884894602 35 d-5 / data ae11cs( 8) / -.3051861262 8561521027 0273322461 21 d-5 / data ae11cs( 9) / +.1705033157 2564559009 6880329929 07 d-6 / data ae11cs( 10) / +.2383420452 7487747258 6015981364 03 d-6 / data ae11cs( 11) / +.1078177255 6163166562 5968723640 20 d-7 / data ae11cs( 12) / -.1795569284 7399102653 6426914465 99 d-7 / data ae11cs( 13) / -.4128407234 1950457727 9123946404 36 d-8 / data ae11cs( 14) / +.6862214858 8631968618 3468445266 64 d-9 / data ae11cs( 15) / +.5313018312 0506356147 6020096759 61 d-9 / data ae11cs( 16) / +.7879688026 1490694831 3050228935 15 d-10 / data ae11cs( 17) / -.2626176232 9356522290 3416752712 32 d-10 / data ae11cs( 18) / -.1548368763 6308261963 1257562941 00 d-10 / data ae11cs( 19) / -.2581896237 7261390492 8024051225 91 d-11 / data ae11cs( 20) / +.5954287919 1591072658 9035299593 52 d-12 / data ae11cs( 21) / +.4645140038 7681525833 7849193214 05 d-12 / data ae11cs( 22) / +.1155785502 3255861496 2880062037 31 d-12 / data ae11cs( 23) / -.1047523687 0835799012 3175471896 70 d-14 / data ae11cs( 24) / -.1189665350 2709004368 1044892609 29 d-13 / data ae11cs( 25) / -.4774907749 0261778752 6430193499 50 d-14 / data ae11cs( 26) / -.8107764961 5772777976 2497347541 35 d-15 / data ae11cs( 27) / +.1343556925 0031554199 3769879981 78 d-15 / data ae11cs( 28) / +.1413453002 2913106260 2488738812 87 d-15 / data ae11cs( 29) / +.4945159257 3953173115 5206632328 83 d-16 / data ae11cs( 30) / +.7988404848 0080665648 8585873993 67 d-17 / data ae11cs( 31) / -.1400863218 8089809829 2487119353 93 d-17 / data ae11cs( 32) / -.1481424695 8417372107 7228040016 80 d-17 / data ae11cs( 33) / -.5582617364 6025601904 0106939371 13 d-18 / data ae11cs( 34) / -.1144207454 2191647264 7830725445 98 d-18 / data ae11cs( 35) / +.2537182387 9566853500 5240184799 23 d-20 / data ae11cs( 36) / +.1320532815 4805359813 2788633890 97 d-19 / data ae11cs( 37) / +.6293026108 1586809166 2874267894 85 d-20 / data ae11cs( 38) / +.1768827042 4882713734 9992613325 48 d-20 / data ae11cs( 39) / +.2326618798 5146045209 6742968874 32 d-21 / data ae11cs( 40) / -.6780306081 1125233043 7738318441 13 d-22 / data ae11cs( 41) / -.5944087695 9676373802 8741505318 91 d-22 / data ae11cs( 42) / -.2361821453 1184415968 5325925034 66 d-22 / data ae11cs( 43) / -.6021449972 4601478214 1684787445 76 d-23 / data ae11cs( 44) / -.6551790647 4348299071 3704441446 39 d-24 / data ae11cs( 45) / +.2938875529 7497724587 0420386993 49 d-24 / data ae11cs( 46) / +.2260160620 0642115173 2157287585 10 d-24 / data ae11cs( 47) / +.8953436924 5958628745 0912068730 87 d-25 / data ae11cs( 48) / +.2401592347 1098457555 7720674577 06 d-25 / data ae11cs( 49) / +.3411837688 8907172955 6664230434 13 d-26 / data ae11cs( 50) / -.7161707169 4630342052 3550133452 79 d-27 / data ae11cs( 51) / -.7562039065 9281725157 9286519807 99 d-27 / data ae11cs( 52) / -.3377461215 7467324637 9529207808 00 d-27 / data ae11cs( 53) / -.1047932570 3300941711 5264303322 45 d-27 / data ae11cs( 54) / -.2165455025 2170342240 8548802013 86 d-28 / data ae11cs( 55) / -.7529712574 5288269994 6892984320 00 d-30 / data ae11cs( 56) / +.1910317939 2798935768 6380840004 26 d-29 / data ae11cs( 57) / +.1149210496 6530338547 7907288337 06 d-29 / data ae11cs( 58) / +.4389697058 2661751514 4103591936 00 d-30 / data ae11cs( 59) / +.1232088323 9205686471 6471577258 66 d-30 / data ae11cs( 60) / +.2222017445 7553175317 5385811626 66 d-31 / data ae12cs( 1) / +.6362958979 6747038767 1298878068 03 d+0 / data ae12cs( 2) / -.1308116867 5067634385 8126711211 35 d+0 / data ae12cs( 3) / -.8436741021 3053930014 4876621297 52 d-2 / data ae12cs( 4) / +.2656849153 1006685413 0294280689 06 d-2 / data ae12cs( 5) / +.3282272178 1658133778 7921701425 17 d-3 / data ae12cs( 6) / -.2378344777 1430248269 5798078510 50 d-4 / data ae12cs( 7) / -.1143980430 8100055514 4470767970 47 d-4 / data ae12cs( 8) / -.1440594343 3238338455 2397176993 23 d-5 / data ae12cs( 9) / +.5241595665 1148829963 7728180616 64 d-8 / data ae12cs( 10) / +.3840730640 7844323480 9792030597 16 d-7 / data ae12cs( 11) / +.8588024486 0267195879 6605157593 44 d-8 / data ae12cs( 12) / +.1021922662 5855003286 3399695539 11 d-8 / data ae12cs( 13) / +.2174913232 3289724542 8213398059 92 d-10 / data ae12cs( 14) / -.2209023814 2623144809 5235038117 41 d-10 / data ae12cs( 15) / -.6345753354 4928753294 3836222088 01 d-11 / data ae12cs( 16) / -.1083774656 6857661115 3405397329 19 d-11 / data ae12cs( 17) / -.1190982287 2222586730 2622004402 77 d-12 / data ae12cs( 18) / -.2843868238 9265590299 5087660086 61 d-14 / data ae12cs( 19) / +.2508032702 6686769668 5871954875 46 d-14 / data ae12cs( 20) / +.7872964152 8559842431 5977264212 65 d-15 / data ae12cs( 21) / +.1547506634 7785217148 4843346373 29 d-15 / data ae12cs( 22) / +.2257532283 1665075055 2726081972 90 d-16 / data ae12cs( 23) / +.2223335286 7266608760 2813808366 93 d-17 / data ae12cs( 24) / +.1696781956 3544153513 4641946623 99 d-19 / data ae12cs( 25) / -.5760831625 5947682105 3100873045 33 d-19 / data ae12cs( 26) / -.1759123577 4646878055 6253694088 53 d-19 / data ae12cs( 27) / -.3628605637 5103174394 7553286826 66 d-20 / data ae12cs( 28) / -.5923556979 7328991652 5581434880 00 d-21 / data ae12cs( 29) / -.7603038092 6310191114 4291368959 99 d-22 / data ae12cs( 30) / -.6254784352 1711763842 6414284799 99 d-23 / data ae12cs( 31) / +.2548336075 9307648606 0376064000 00 d-24 / data ae12cs( 32) / +.2559861573 1739857020 1688746666 66 d-24 / data ae12cs( 33) / +.7137623935 7899318800 2070528000 00 d-25 / data ae12cs( 34) / +.1470375993 9567568181 5789568000 00 d-25 / data ae12cs( 35) / +.2510552476 5386733555 1986346666 66 d-26 / data ae12cs( 36) / +.3588666638 7790890886 5836373333 33 d-27 / data ae12cs( 37) / +.3988603515 6771301763 3177599999 99 d-28 / data ae12cs( 38) / +.2176367694 7356220478 8053333333 33 d-29 / data ae12cs( 39) / -.4614699848 7618942367 6074666666 66 d-30 / data ae12cs( 40) / -.2071351787 7481987707 1530666666 66 d-30 / data ae12cs( 41) / -.5189037856 3534371596 9706666666 66 d-31 / data e11cs( 1) / -.1611346165 5571494025 7206639275 66180 d+2 / data e11cs( 2) / +.7794072778 7426802769 2722458917 41497 d+1 / data e11cs( 3) / -.1955405818 8631419507 1272838128 14491 d+1 / data e11cs( 4) / +.3733729386 6277945611 5171908656 90209 d+0 / data e11cs( 5) / -.5692503191 0929019385 2638922200 51166 d-1 / data e11cs( 6) / +.7211077769 6600918537 8477248126 35813 d-2 / data e11cs( 7) / -.7810490144 9841593997 7151840890 64148 d-3 / data e11cs( 8) / +.7388093356 2621681878 9748813661 77858 d-4 / data e11cs( 9) / -.6202861875 8082045134 3581336079 09712 d-5 / data e11cs( 10) / +.4681600230 3176735524 4058238683 62657 d-6 / data e11cs( 11) / -.3209288853 3298649524 0725530272 28719 d-7 / data e11cs( 12) / +.2015199748 7404533394 8262622130 19548 d-8 / data e11cs( 13) / -.1167368681 6697793105 3562716950 15419 d-9 / data e11cs( 14) / +.6276270667 2039943397 7887483796 15573 d-11 / data e11cs( 15) / -.3148154167 2275441045 2467818023 93600 d-12 / data e11cs( 16) / +.1479904174 4493474210 8944722517 33333 d-13 / data e11cs( 17) / -.6545709158 3979673774 2634015880 53333 d-15 / data e11cs( 18) / +.2733687222 3137291142 5080127487 99999 d-16 / data e11cs( 19) / -.1081352434 9754406876 7217276245 33333 d-17 / data e11cs( 20) / +.4062832804 0434303295 3003485866 66666 d-19 / data e11cs( 21) / -.1453553935 8960455858 9143722666 66666 d-20 / data e11cs( 22) / +.4963274618 1648636830 1984426666 66666 d-22 / data e11cs( 23) / -.1620861269 6636044604 8665600000 00000 d-23 / data e11cs( 24) / +.5072144803 8607422226 4319999999 99999 d-25 / data e11cs( 25) / -.1523581113 3372207813 9733333333 33333 d-26 / data e11cs( 26) / +.4400151125 6103618696 5333333333 33333 d-28 / data e11cs( 27) / -.1223614194 5416231594 6666666666 66666 d-29 / data e11cs( 28) / +.3280921666 1066001066 6666666666 66666 d-31 / data e11cs( 29) / -.8493345226 8306432000 0000000000 00000 d-33 / data e12cs( 1) / -.3739021479 22027951166 869820482 7 d-1 / data e12cs( 2) / +.4272398606 2209577260 4917917652 8 d-1 / data e12cs( 3) / -.1303182079 8497005441 5392055219 726 d+0 / data e12cs( 4) / +.1441912402 4698890734 1095893982 137 d-1 / data e12cs( 5) / -.1346170780 5106802211 6121527983 553 d-2 / data e12cs( 6) / +.1073102925 3063779997 6115850970 073 d-3 / data e12cs( 7) / -.7429999516 1194364961 0283062223 163 d-5 / data e12cs( 8) / +.4537732569 0753713938 6383211511 827 d-6 / data e12cs( 9) / -.2476417211 3906013184 6547423802 912 d-7 / data e12cs( 10) / +.1220765813 7459095370 0228167846 102 d-8 / data e12cs( 11) / -.5485141480 6409239382 1357398028 261 d-10 / data e12cs( 12) / +.2263621421 3007879929 3688162377 002 d-11 / data e12cs( 13) / -.8635897271 6980097940 4172916282 240 d-13 / data e12cs( 14) / +.3062915536 6933299758 1032894881 279 d-14 / data e12cs( 15) / -.1014857188 5594414755 7128906734 933 d-15 / data e12cs( 16) / +.3154821740 3406987754 6855328426 666 d-17 / data e12cs( 17) / -.9236042407 6924095448 4015923200 000 d-19 / data e12cs( 18) / +.2555042679 7081400244 0435029333 333 d-20 / data e12cs( 19) / -.6699128056 8456684721 7882453333 333 d-22 / data e12cs( 20) / +.1669254054 3538731943 1987199999 999 d-23 / data e12cs( 21) / -.3962549251 8437964185 6000000000 000 d-25 / data e12cs( 22) / +.8981358965 9851133201 0666666666 666 d-27 / data e12cs( 23) / -.1947633669 9301643332 2666666666 666 d-28 / data e12cs( 24) / +.4048360190 2463003306 6666666666 666 d-30 / data e12cs( 25) / -.8079815676 9984512000 0000000000 000 d-32 / data ae13cs( 1) / -.6057732466 4060345999 3193827377 47 d+0 / data ae13cs( 2) / -.1125352434 8366090030 6497688527 18 d+0 / data ae13cs( 3) / +.1343226624 7902779492 4878593294 14 d-1 / data ae13cs( 4) / -.1926845187 3811457249 2468389913 03 d-2 / data ae13cs( 5) / +.3091183377 2060318335 5867374753 68 d-3 / data ae13cs( 6) / -.5356413212 9618418776 3935597951 47 d-4 / data ae13cs( 7) / +.9827812880 2474923952 4918827172 37 d-5 / data ae13cs( 8) / -.1885368984 9165182826 9028919389 10 d-5 / data ae13cs( 9) / +.3749431935 6894735406 9640421905 31 d-6 / data ae13cs( 10) / -.7682345587 0552639273 7334656805 56 d-7 / data ae13cs( 11) / +.1614327056 7198777552 9563000608 68 d-7 / data ae13cs( 12) / -.3466802211 4907354566 3090602260 27 d-8 / data ae13cs( 13) / +.7587542091 9036277572 8897470541 14 d-9 / data ae13cs( 14) / -.1688643332 9881412573 5145266367 03 d-9 / data ae13cs( 15) / +.3814570674 9552265682 8042509272 72 d-10 / data ae13cs( 16) / -.8733026632 4446292706 8517182723 34 d-11 / data ae13cs( 17) / +.2023672864 5867960961 7943110643 30 d-11 / data ae13cs( 18) / -.4741328303 9555834655 2103408201 60 d-12 / data ae13cs( 19) / +.1122117204 8389864324 7317999289 20 d-12 / data ae13cs( 20) / -.2680422543 4840309912 8268090933 95 d-13 / data ae13cs( 21) / +.6457851441 7716530343 5803690672 12 d-14 / data ae13cs( 22) / -.1568276050 1666478830 3057028491 94 d-14 / data ae13cs( 23) / +.3836786539 9315404861 8215164414 08 d-15 / data ae13cs( 24) / -.9451717302 7579130478 8710489325 56 d-16 / data ae13cs( 25) / +.2343481228 8949573293 8966664391 33 d-16 / data ae13cs( 26) / -.5845866158 0214714576 1231944198 82 d-17 / data ae13cs( 27) / +.1466622986 7947778605 8736174191 95 d-17 / data ae13cs( 28) / -.3699392347 6444472706 5925382744 74 d-18 / data ae13cs( 29) / +.9379015993 6721242136 0142918178 13 d-19 / data ae13cs( 30) / -.2389367322 1937873136 3082240873 81 d-19 / data ae13cs( 31) / +.6115062462 9497608051 9342238378 66 d-20 / data ae13cs( 32) / -.1571858532 7554025507 7198532881 06 d-20 / data ae13cs( 33) / +.4057238728 5585397769 5192944913 06 d-21 / data ae13cs( 34) / -.1051402655 4738034990 5663671227 73 d-21 / data ae13cs( 35) / +.2734966493 0638667785 8060031317 33 d-22 / data ae13cs( 36) / -.7140160408 0205796099 3555742719 99 d-23 / data ae13cs( 37) / +.1870555243 2235079986 7569242111 99 d-23 / data ae13cs( 38) / -.4916746816 6870480520 4780209493 33 d-24 / data ae13cs( 39) / +.1296498811 9684031730 9160871253 33 d-24 / data ae13cs( 40) / -.3429251568 8362864461 6239404373 33 d-25 / data ae13cs( 41) / +.9097224164 3887034329 1048209066 66 d-26 / data ae13cs( 42) / -.2420211231 4316856489 9348479999 99 d-26 / data ae13cs( 43) / +.6456361293 4639510757 6704750933 33 d-27 / data ae13cs( 44) / -.1726913273 5340541122 3159876266 66 d-27 / data ae13cs( 45) / +.4630861165 9151500715 1942314666 66 d-28 / data ae13cs( 46) / -.1244870363 7214131241 7551701333 33 d-28 / data ae13cs( 47) / +.3354457409 0520678532 9070079999 99 d-29 / data ae13cs( 48) / -.9059886852 1070774437 5439359999 99 d-30 / data ae13cs( 49) / +.2452414705 1474238587 2732160000 00 d-30 / data ae13cs( 50) / -.6652817873 3552062817 1079679999 99 d-31 / data ae14cs( 1) / -.1892918000 7530168254 9567994282 0 d+0 / data ae14cs( 2) / -.8648117855 2598714899 6881705682 4 d-1 / data ae14cs( 3) / +.7224101543 7465947470 2151483918 4 d-2 / data ae14cs( 4) / -.8097559457 5573861971 5965561018 1 d-3 / data ae14cs( 5) / +.1099913443 2661388671 7925115700 2 d-3 / data ae14cs( 6) / -.1717332998 9377673714 9535881448 7 d-4 / data ae14cs( 7) / +.2985627514 4792833228 2534249500 3 d-5 / data ae14cs( 8) / -.5659649145 7719300565 6016726715 5 d-6 / data ae14cs( 9) / +.1152680839 7141400192 2658350166 3 d-6 / data ae14cs( 10) / -.2495030440 2693382288 4212876506 5 d-7 / data ae14cs( 11) / +.5692324201 8337543670 3937036814 0 d-8 / data ae14cs( 12) / -.1359957664 8056003384 9003093917 6 d-8 / data ae14cs( 13) / +.3384662888 7608845901 8451292585 9 d-9 / data ae14cs( 14) / -.8737853904 4746819523 5084931658 0 d-10 / data ae14cs( 15) / +.2331588663 2226597186 1261340047 0 d-10 / data ae14cs( 16) / -.6411481049 2137859697 5316519632 6 d-11 / data ae14cs( 17) / +.1812246980 2048164333 8435948468 2 d-11 / data ae14cs( 18) / -.5253831761 5584606888 1940384046 6 d-12 / data ae14cs( 19) / +.1559218272 5919256988 5502860982 5 d-12 / data ae14cs( 20) / -.4729168297 0803987184 7642936946 6 d-13 / data ae14cs( 21) / +.1463761864 3932435020 7619949380 8 d-13 / data ae14cs( 22) / -.4617388988 7129241022 3217362360 4 d-14 / data ae14cs( 23) / +.1482710348 2893693237 8923966037 1 d-14 / data ae14cs( 24) / -.4841672496 2392291469 7316573441 7 d-15 / data ae14cs( 25) / +.1606215575 7002904081 1657196618 8 d-15 / data ae14cs( 26) / -.5408917538 9571709478 9502378425 2 d-16 / data ae14cs( 27) / +.1847470159 3468978813 7023140231 0 d-16 / data ae14cs( 28) / -.6395830792 7590944705 0061042505 0 d-17 / data ae14cs( 29) / +.2242780721 6997594572 5023327617 0 d-17 / data ae14cs( 30) / -.7961369173 9839475527 4455530864 6 d-18 / data ae14cs( 31) / +.2859308111 5401974598 0861992927 2 d-18 / data ae14cs( 32) / -.1038450244 7011371459 0069713744 6 d-18 / data ae14cs( 33) / +.3812040607 0979757808 6684100831 9 d-19 / data ae14cs( 34) / -.1413795417 7172007687 1756272369 6 d-19 / data ae14cs( 35) / +.5295367865 1827409583 0544259481 5 d-20 / data ae14cs( 36) / -.2002264245 0268259021 3721113143 9 d-20 / data ae14cs( 37) / +.7640262751 2751960147 3684861091 8 d-21 / data ae14cs( 38) / -.2941119006 8687878833 1126352336 2 d-21 / data ae14cs( 39) / +.1141823539 0789271930 3769148358 6 d-21 / data ae14cs( 40) / -.4469308475 9552984252 4702071848 9 d-22 / data ae14cs( 41) / +.1763262410 5717507706 3049140852 0 d-22 / data ae14cs( 42) / -.7009968187 9259023563 5151826234 0 d-23 / data ae14cs( 43) / +.2807573556 5583789222 8775750751 5 d-23 / data ae14cs( 44) / -.1132560944 9810864321 4188889156 2 d-23 / data ae14cs( 45) / +.4600574684 3750179461 5676423372 7 d-24 / data ae14cs( 46) / -.1881448598 9761334598 6460914810 8 d-24 / data ae14cs( 47) / +.7744916111 5077308454 4432847803 7 d-25 / data ae14cs( 48) / -.3208512760 5853689267 0270382626 1 d-25 / data ae14cs( 49) / +.1337445542 9108397606 1993042138 4 d-25 / data ae14cs( 50) / -.5608671881 8022170488 9477173521 0 d-26 / data ae14cs( 51) / +.2365839716 5285374837 1006947327 9 d-26 / data ae14cs( 52) / -.1003656195 0253053340 6583452685 6 d-26 / data ae14cs( 53) / +.4281490878 0941611312 8664255692 7 d-27 / data ae14cs( 54) / -.1836345261 8153181996 9132695825 0 d-27 / data ae14cs( 55) / +.7917798231 3495400000 9746867814 4 d-28 / data ae14cs( 56) / -.3431542358 7422203610 2501577523 1 d-28 / data ae14cs( 57) / +.1494705493 8971032374 7506600891 7 d-28 / data ae14cs( 58) / -.6542620279 8657054397 3904242005 3 d-29 / data ae14cs( 59) / +.2877581395 1991711143 4048735368 5 d-29 / data ae14cs( 60) / -.1271557211 7960247110 2798120004 2 d-29 / data ae14cs( 61) / +.5644615555 6487225223 8804462250 6 d-30 / data ae14cs( 62) / -.2516994994 2840951060 8061683029 3 d-30 / data ae14cs( 63) / +.1127259818 9275102063 7036880418 1 d-30 / data ae14cs( 64) / -.5069814875 8004608555 6258471936 0 d-31 / data first /.true./ c if (first) then eta = 0.1*real(d1mach(3)) ntae10 = initds (ae10cs, 50, eta) ntae11 = initds (ae11cs, 60, eta) ntae12 = initds (ae12cs, 41, eta) nte11 = initds (e11cs, 29, eta) nte12 = initds (e12cs, 25, eta) ntae13 = initds (ae13cs, 50, eta) ntae14 = initds (ae14cs, 64, eta) c xmaxt = -log(d1mach(1)) xmax = xmaxt - log(xmaxt) endif first = .false. c if (x.gt.(-1.d0)) go to 50 if (x.gt.(-32.d0)) go to 20 de1 = exp(-x)/x * (1.d0 + dcsevl (64.d0/x+1.d0, ae10cs, ntae10)) return c 20 if (x.gt.(-8.d0)) go to 30 de1 = exp(-x)/x * (1.d0 + dcsevl ((64.d0/x+5.d0)/3.d0, ae11cs, 1 ntae11)) return c 30 if (x.gt.(-4.d0)) go to 40 de1 = exp(-x)/x * (1.d0 + dcsevl (16.d0/x+3.d0, ae12cs, ntae12)) return c 40 de1 = -log(-x) + dcsevl ((2.d0*x+5.d0)/3.d0, e11cs, nte11) return c 50 if (x.gt.1.0d0) go to 60 if (x .eq. 0.d0) call error('de1','x is 0',' ') de1 = (-log(abs(x)) - 0.6875d0 + x) + dcsevl (x, e12cs, nte12) return c 60 if (x.gt.4.0d0) go to 70 de1 = exp(-x)/x * (1.d0 + dcsevl ((8.d0/x-5.d0)/3.d0, ae13cs, 1 ntae13)) return c 70 if (x.gt.xmax) go to 80 de1 = exp(-x)/x * (1.d0 + dcsevl (8.d0/x-1.d0, ae14cs, ntae14)) return c 80 continue c call mess('de1','x so big e1 underflows',' ') de1 = 0.d0 return c end *else c function se1 (x) c ****************************************************************** c compute the exponential integral e1(x). c taken from the slatec library fnlib e1. c ****************************************************************** dimension ae11cs(39), ae12cs(25), e11cs(19), e12cs(16), 1 ae13cs(25), ae14cs(26) logical first save ae11cs, ae12cs, e11cs, e12cs, ae13cs, ae14cs, 1 ntae11, ntae12, nte11, nte12, ntae13, ntae14, xmax, first data ae11cs( 1) / .1215032397 1606579e0 / data ae11cs( 2) / -.0650887785 13550150e0 / data ae11cs( 3) / .0048976513 57459670e0 / data ae11cs( 4) / -.0006492378 43027216e0 / data ae11cs( 5) / .0000938404 34587471e0 / data ae11cs( 6) / .0000004202 36380882e0 / data ae11cs( 7) / -.0000081133 74735904e0 / data ae11cs( 8) / .0000028042 47688663e0 / data ae11cs( 9) / .0000000564 87164441e0 / data ae11cs(10) / -.0000003448 09174450e0 / data ae11cs(11) / .0000000582 09273578e0 / data ae11cs(12) / .0000000387 11426349e0 / data ae11cs(13) / -.0000000124 53235014e0 / data ae11cs(14) / -.0000000051 18504888e0 / data ae11cs(15) / .0000000021 48771527e0 / data ae11cs(16) / .0000000008 68459898e0 / data ae11cs(17) / -.0000000003 43650105e0 / data ae11cs(18) / -.0000000001 79796603e0 / data ae11cs(19) / .0000000000 47442060e0 / data ae11cs(20) / .0000000000 40423282e0 / data ae11cs(21) / -.0000000000 03543928e0 / data ae11cs(22) / -.0000000000 08853444e0 / data ae11cs(23) / -.0000000000 00960151e0 / data ae11cs(24) / .0000000000 01692921e0 / data ae11cs(25) / .0000000000 00607990e0 / data ae11cs(26) / -.0000000000 00224338e0 / data ae11cs(27) / -.0000000000 00200327e0 / data ae11cs(28) / -.0000000000 00006246e0 / data ae11cs(29) / .0000000000 00045571e0 / data ae11cs(30) / .0000000000 00016383e0 / data ae11cs(31) / -.0000000000 00005561e0 / data ae11cs(32) / -.0000000000 00006074e0 / data ae11cs(33) / -.0000000000 00000862e0 / data ae11cs(34) / .0000000000 00001223e0 / data ae11cs(35) / .0000000000 00000716e0 / data ae11cs(36) / -.0000000000 00000024e0 / data ae11cs(37) / -.0000000000 00000201e0 / data ae11cs(38) / -.0000000000 00000082e0 / data ae11cs(39) / .0000000000 00000017e0 / data ae12cs( 1) / .5824174951 3472674e0 / data ae12cs( 2) / -.1583488509 0578275e0 / data ae12cs( 3) / -.0067642755 90323141e0 / data ae12cs( 4) / .0051258439 50185725e0 / data ae12cs( 5) / .0004352324 92169391e0 / data ae12cs( 6) / -.0001436133 66305483e0 / data ae12cs( 7) / -.0000418013 20556301e0 / data ae12cs( 8) / -.0000027133 95758640e0 / data ae12cs( 9) / .0000011513 81913647e0 / data ae12cs(10) / .0000004206 50022012e0 / data ae12cs(11) / .0000000665 81901391e0 / data ae12cs(12) / .0000000006 62143777e0 / data ae12cs(13) / -.0000000028 44104870e0 / data ae12cs(14) / -.0000000009 40724197e0 / data ae12cs(15) / -.0000000001 77476602e0 / data ae12cs(16) / -.0000000000 15830222e0 / data ae12cs(17) / .0000000000 02905732e0 / data ae12cs(18) / .0000000000 01769356e0 / data ae12cs(19) / .0000000000 00492735e0 / data ae12cs(20) / .0000000000 00093709e0 / data ae12cs(21) / .0000000000 00010707e0 / data ae12cs(22) / -.0000000000 00000537e0 / data ae12cs(23) / -.0000000000 00000716e0 / data ae12cs(24) / -.0000000000 00000244e0 / data ae12cs(25) / -.0000000000 00000058e0 / data e11cs( 1) / -16.1134616555 71494026e0 / data e11cs( 2) / 7.7940727787 426802769e0 / data e11cs( 3) / -1.9554058188 631419507e0 / data e11cs( 4) / .3733729386 6277945612e0 / data e11cs( 5) / -.0569250319 1092901938e0 / data e11cs( 6) / .0072110777 6966009185e0 / data e11cs( 7) / -.0007810490 1449841593e0 / data e11cs( 8) / .0000738809 3356262168e0 / data e11cs( 9) / -.0000062028 6187580820e0 / data e11cs(10) / .0000004681 6002303176e0 / data e11cs(11) / -.0000000320 9288853329e0 / data e11cs(12) / .0000000020 1519974874e0 / data e11cs(13) / -.0000000001 1673686816e0 / data e11cs(14) / .0000000000 0627627066e0 / data e11cs(15) / -.0000000000 0031481541e0 / data e11cs(16) / .0000000000 0001479904e0 / data e11cs(17) / -.0000000000 0000065457e0 / data e11cs(18) / .0000000000 0000002733e0 / data e11cs(19) / -.0000000000 0000000108e0 / data e12cs( 1) / -0.0373902147 92202795e0 / data e12cs( 2) / 0.0427239860 62209577e0 / data e12cs( 3) / -.1303182079 849700544e0 / data e12cs( 4) / .0144191240 2469889073e0 / data e12cs( 5) / -.0013461707 8051068022e0 / data e12cs( 6) / .0001073102 9253063780e0 / data e12cs( 7) / -.0000074299 9951611943e0 / data e12cs( 8) / .0000004537 7325690753e0 / data e12cs( 9) / -.0000000247 6417211390e0 / data e12cs(10) / .0000000012 2076581374e0 / data e12cs(11) / -.0000000000 5485141480e0 / data e12cs(12) / .0000000000 0226362142e0 / data e12cs(13) / -.0000000000 0008635897e0 / data e12cs(14) / .0000000000 0000306291e0 / data e12cs(15) / -.0000000000 0000010148e0 / data e12cs(16) / .0000000000 0000000315e0 / data ae13cs( 1) / -.6057732466 4060346e0 / data ae13cs( 2) / -.1125352434 8366090e0 / data ae13cs( 3) / .0134322662 47902779e0 / data ae13cs( 4) / -.0019268451 87381145e0 / data ae13cs( 5) / .0003091183 37720603e0 / data ae13cs( 6) / -.0000535641 32129618e0 / data ae13cs( 7) / .0000098278 12880247e0 / data ae13cs( 8) / -.0000018853 68984916e0 / data ae13cs( 9) / .0000003749 43193568e0 / data ae13cs(10) / -.0000000768 23455870e0 / data ae13cs(11) / .0000000161 43270567e0 / data ae13cs(12) / -.0000000034 66802211e0 / data ae13cs(13) / .0000000007 58754209e0 / data ae13cs(14) / -.0000000001 68864333e0 / data ae13cs(15) / .0000000000 38145706e0 / data ae13cs(16) / -.0000000000 08733026e0 / data ae13cs(17) / .0000000000 02023672e0 / data ae13cs(18) / -.0000000000 00474132e0 / data ae13cs(19) / .0000000000 00112211e0 / data ae13cs(20) / -.0000000000 00026804e0 / data ae13cs(21) / .0000000000 00006457e0 / data ae13cs(22) / -.0000000000 00001568e0 / data ae13cs(23) / .0000000000 00000383e0 / data ae13cs(24) / -.0000000000 00000094e0 / data ae13cs(25) / .0000000000 00000023e0 / data ae14cs( 1) / -.1892918000 753017e0 / data ae14cs( 2) / -.0864811785 5259871e0 / data ae14cs( 3) / .0072241015 4374659e0 / data ae14cs( 4) / -.0008097559 4575573e0 / data ae14cs( 5) / .0001099913 4432661e0 / data ae14cs( 6) / -.0000171733 2998937e0 / data ae14cs( 7) / .0000029856 2751447e0 / data ae14cs( 8) / -.0000005659 6491457e0 / data ae14cs( 9) / .0000001152 6808397e0 / data ae14cs(10) / -.0000000249 5030440e0 / data ae14cs(11) / .0000000056 9232420e0 / data ae14cs(12) / -.0000000013 5995766e0 / data ae14cs(13) / .0000000003 3846628e0 / data ae14cs(14) / -.0000000000 8737853e0 / data ae14cs(15) / .0000000000 2331588e0 / data ae14cs(16) / -.0000000000 0641148e0 / data ae14cs(17) / .0000000000 0181224e0 / data ae14cs(18) / -.0000000000 0052538e0 / data ae14cs(19) / .0000000000 0015592e0 / data ae14cs(20) / -.0000000000 0004729e0 / data ae14cs(21) / .0000000000 0001463e0 / data ae14cs(22) / -.0000000000 0000461e0 / data ae14cs(23) / .0000000000 0000148e0 / data ae14cs(24) / -.0000000000 0000048e0 / data ae14cs(25) / .0000000000 0000016e0 / data ae14cs(26) / -.0000000000 0000005e0 / data first /.true./ c if (first) then eta = 0.1*s1mach(3) ntae11 = inits (ae11cs, 39, eta) ntae12 = inits (ae12cs, 25, eta) nte11 = inits (e11cs, 19, eta) nte12 = inits (e12cs, 16, eta) ntae13 = inits (ae13cs, 25, eta) ntae14 = inits (ae14cs, 26, eta) c xmaxt = -log (s1mach(1)) xmax = xmaxt - log(xmaxt) endif first = .false. c if (x.gt.(-10.)) go to 20 c c e1(x) = -ei(-x) for x .le. -10. c se1 = exp(-x)/x * (1.+csevl (20./x+1., ae11cs, ntae11)) return c 20 if (x.gt.(-4.0)) go to 30 se1 = exp(-x)/x * (1.+csevl ((40./x+7.)/3., ae12cs, ntae12)) return c 30 if (x.gt.(-1.0)) go to 40 se1 = -log(abs(x)) + csevl ((2.*x+5.)/3., e11cs, nte11) return c 40 if (x.gt.1.) go to 50 if (x .eq. 0.) call error('e1','x is 0',' ') se1 = (-log(abs(x)) - 0.6875 + x) + csevl (x, e12cs, nte12) return c 50 if (x.gt.4.) go to 60 se1 = exp(-x)/x * (1.+csevl ((8./x-5.)/3., ae13cs, ntae13)) return c 60 if (x.gt.xmax) go to 70 se1 = exp(-x)/x * (1. + csevl (8./x-1., ae14cs, ntae14)) return c 70 continue c call mess('se1','x so big e1 underflows',' ') se1 = 0. return c end *endif *if sw c double precision function dgami (a, x) c ****************************************************************** c evaluate the incomplete gamma function. c from the slatec library fnlib dgami. c ****************************************************************** double precision a, x, factor, dlngam, dgamit c if (a .le. 0.d0) call error('dgami','a must be gt zero',' ') if (x .lt. 0.d0) call error('dgami','x must be ge zero',' ') c dgami = 0.d0 if (x.eq.0.0d0) return c factor = exp (dlngam(a) + a*log(x)) dgami = factor * dgamit (a, x) c return end *else c function sgami (a, x) c ****************************************************************** c evaluate the incomplete gamma function. c from the slatec library fnlib gami. c ****************************************************************** c if (a .le. 0.0) call error('gami','a must be gt zero',' ') if (x .lt. 0.0) call error('gami','x must be ge zero',' ') c sgami = 0.0 if (x.eq.0.0) return c factor = exp (alngam(a) + a*log(x) ) sgami = factor * gamit(a, x) c return end *endif *if sw c double precision function derfc (x) c ****************************************************************** c compute the complementary error function. c from the slatec library fnlib derfc. c ****************************************************************** double precision x, erfcs(21), erfccs(59), erc2cs(49), sqeps, 1 sqrtpi, xmax, txmax, xsml, y, d1mach, dcsevl logical first save erfcs, erc2cs, erfccs, sqrtpi, nterf, 1 nterfc, nterc2, xsml, xmax, sqeps, first data erfcs( 1) / -.4904612123 4691808039 9845440333 76 d-1 / data erfcs( 2) / -.1422612051 0371364237 8247418996 31 d+0 / data erfcs( 3) / +.1003558218 7599795575 7546767129 33 d-1 / data erfcs( 4) / -.5768764699 7674847650 8270255091 67 d-3 / data erfcs( 5) / +.2741993125 2196061034 4221607914 71 d-4 / data erfcs( 6) / -.1104317550 7344507604 1353812959 05 d-5 / data erfcs( 7) / +.3848875542 0345036949 9613114981 74 d-7 / data erfcs( 8) / -.1180858253 3875466969 6317518015 81 d-8 / data erfcs( 9) / +.3233421582 6050909646 4029309533 54 d-10 / data erfcs( 10) / -.7991015947 0045487581 6073747085 95 d-12 / data erfcs( 11) / +.1799072511 3961455611 9672454866 34 d-13 / data erfcs( 12) / -.3718635487 8186926382 3168282094 93 d-15 / data erfcs( 13) / +.7103599003 7142529711 6899083946 66 d-17 / data erfcs( 14) / -.1261245511 9155225832 4954248533 33 d-18 / data erfcs( 15) / +.2091640694 1769294369 1705002666 66 d-20 / data erfcs( 16) / -.3253973102 9314072982 3641600000 00 d-22 / data erfcs( 17) / +.4766867209 7976748332 3733333333 33 d-24 / data erfcs( 18) / -.6598012078 2851343155 1999999999 99 d-26 / data erfcs( 19) / +.8655011469 9637626197 3333333333 33 d-28 / data erfcs( 20) / -.1078892517 7498064213 3333333333 33 d-29 / data erfcs( 21) / +.1281188399 3017002666 6666666666 66 d-31 / data erc2cs( 1) / -.6960134660 2309501127 3915082619 7 d-1 / data erc2cs( 2) / -.4110133936 2620893489 8221208466 6 d-1 / data erc2cs( 3) / +.3914495866 6896268815 6114370524 4 d-2 / data erc2cs( 4) / -.4906395650 5489791612 8093545077 4 d-3 / data erc2cs( 5) / +.7157479001 3770363807 6089414182 5 d-4 / data erc2cs( 6) / -.1153071634 1312328338 0823284791 2 d-4 / data erc2cs( 7) / +.1994670590 2019976350 5231486770 9 d-5 / data erc2cs( 8) / -.3642666471 5992228739 3611843071 1 d-6 / data erc2cs( 9) / +.6944372610 0050125899 3127721463 3 d-7 / data erc2cs( 10) / -.1371220902 1043660195 3460514121 0 d-7 / data erc2cs( 11) / +.2788389661 0071371319 6386034808 7 d-8 / data erc2cs( 12) / -.5814164724 3311615518 6479105031 6 d-9 / data erc2cs( 13) / +.1238920491 7527531811 8016881795 0 d-9 / data erc2cs( 14) / -.2690639145 3067434323 9042493788 9 d-10 / data erc2cs( 15) / +.5942614350 8479109824 4470968384 0 d-11 / data erc2cs( 16) / -.1332386735 7581195792 8775442057 0 d-11 / data erc2cs( 17) / +.3028046806 1771320171 7369724330 4 d-12 / data erc2cs( 18) / -.6966648814 9410325887 9586758895 4 d-13 / data erc2cs( 19) / +.1620854541 0539229698 1289322762 8 d-13 / data erc2cs( 20) / -.3809934465 2504919998 7691305772 9 d-14 / data erc2cs( 21) / +.9040487815 9788311493 6897101297 5 d-15 / data erc2cs( 22) / -.2164006195 0896073478 0981204700 3 d-15 / data erc2cs( 23) / +.5222102233 9958549846 0798024417 2 d-16 / data erc2cs( 24) / -.1269729602 3645553363 7241552778 0 d-16 / data erc2cs( 25) / +.3109145504 2761975838 3622741295 1 d-17 / data erc2cs( 26) / -.7663762920 3203855240 0956671481 1 d-18 / data erc2cs( 27) / +.1900819251 3627452025 3692973329 0 d-18 / data erc2cs( 28) / -.4742207279 0690395452 2565599996 5 d-19 / data erc2cs( 29) / +.1189649200 0765283828 8068307845 1 d-19 / data erc2cs( 30) / -.3000035590 3257802568 4527131306 6 d-20 / data erc2cs( 31) / +.7602993453 0432461730 1938527709 8 d-21 / data erc2cs( 32) / -.1935909447 6068728815 6981104913 0 d-21 / data erc2cs( 33) / +.4951399124 7733378810 0004238677 3 d-22 / data erc2cs( 34) / -.1271807481 3363718796 0862198988 8 d-22 / data erc2cs( 35) / +.3280049600 4695130433 1584165205 3 d-23 / data erc2cs( 36) / -.8492320176 8228965689 2479242239 9 d-24 / data erc2cs( 37) / +.2206917892 8075602235 1987998719 9 d-24 / data erc2cs( 38) / -.5755617245 6965284983 1281950719 9 d-25 / data erc2cs( 39) / +.1506191533 6392342503 5414405119 9 d-25 / data erc2cs( 40) / -.3954502959 0187969531 0428569599 9 d-26 / data erc2cs( 41) / +.1041529704 1515009799 8464505173 3 d-26 / data erc2cs( 42) / -.2751487795 2787650794 5017890133 3 d-27 / data erc2cs( 43) / +.7290058205 4975574089 9770368000 0 d-28 / data erc2cs( 44) / -.1936939645 9159478040 7750109866 6 d-28 / data erc2cs( 45) / +.5160357112 0514872983 7005482666 6 d-29 / data erc2cs( 46) / -.1378419322 1930940993 8964480000 0 d-29 / data erc2cs( 47) / +.3691326793 1070690422 5109333333 3 d-30 / data erc2cs( 48) / -.9909389590 6243654206 5322666666 6 d-31 / data erc2cs( 49) / +.2666491705 1953884133 2394666666 6 d-31 / data erfccs( 1) / +.7151793102 0292477450 3697709496 d-1 / data erfccs( 2) / -.2653243433 7606715755 8893386681 d-1 / data erfccs( 3) / +.1711153977 9208558833 2699194606 d-2 / data erfccs( 4) / -.1637516634 5851788416 3746404749 d-3 / data erfccs( 5) / +.1987129350 0552036499 5974806758 d-4 / data erfccs( 6) / -.2843712412 7665550875 0175183152 d-5 / data erfccs( 7) / +.4606161308 9631303696 9379968464 d-6 / data erfccs( 8) / -.8227753025 8792084205 7766536366 d-7 / data erfccs( 9) / +.1592141872 7709011298 9358340826 d-7 / data erfccs( 10) / -.3295071362 2528432148 6631665072 d-8 / data erfccs( 11) / +.7223439760 4005554658 1261153890 d-9 / data erfccs( 12) / -.1664855813 3987295934 4695966886 d-9 / data erfccs( 13) / +.4010392588 2376648207 7671768814 d-10 / data erfccs( 14) / -.1004816214 4257311327 2170176283 d-10 / data erfccs( 15) / +.2608275913 3003338085 9341009439 d-11 / data erfccs( 16) / -.6991110560 4040248655 7697812476 d-12 / data erfccs( 17) / +.1929492333 2617070862 4205749803 d-12 / data erfccs( 18) / -.5470131188 7543310649 0125085271 d-13 / data erfccs( 19) / +.1589663309 7626974483 9084032762 d-13 / data erfccs( 20) / -.4726893980 1975548392 0369584290 d-14 / data erfccs( 21) / +.1435873376 7849847867 2873997840 d-14 / data erfccs( 22) / -.4449510561 8173583941 7250062829 d-15 / data erfccs( 23) / +.1404810884 7682334373 7305537466 d-15 / data erfccs( 24) / -.4513818387 7642108962 5963281623 d-16 / data erfccs( 25) / +.1474521541 0451330778 7018713262 d-16 / data erfccs( 26) / -.4892621406 9457761543 6841552532 d-17 / data erfccs( 27) / +.1647612141 4106467389 5301522827 d-17 / data erfccs( 28) / -.5626817176 3294080929 9928521323 d-18 / data erfccs( 29) / +.1947443382 2320785142 9197867821 d-18 / data erfccs( 30) / -.6826305642 9484207295 6664144723 d-19 / data erfccs( 31) / +.2421988887 2986492401 8301125438 d-19 / data erfccs( 32) / -.8693414133 5030704256 3800861857 d-20 / data erfccs( 33) / +.3155180346 2280855712 2363401262 d-20 / data erfccs( 34) / -.1157372324 0496087426 1239486742 d-20 / data erfccs( 35) / +.4288947161 6056539462 3737097442 d-21 / data erfccs( 36) / -.1605030742 0576168500 5737770964 d-21 / data erfccs( 37) / +.6063298757 4538026449 5069923027 d-22 / data erfccs( 38) / -.2311404251 6979584909 8840801367 d-22 / data erfccs( 39) / +.8888778540 6618855255 4702955697 d-23 / data erfccs( 40) / -.3447260576 6513765223 0718495566 d-23 / data erfccs( 41) / +.1347865460 2069650682 7582774181 d-23 / data erfccs( 42) / -.5311794071 1250217364 5873201807 d-24 / data erfccs( 43) / +.2109341058 6197831682 8954734537 d-24 / data erfccs( 44) / -.8438365587 9237891159 8133256738 d-25 / data erfccs( 45) / +.3399982524 9452089062 7359576337 d-25 / data erfccs( 46) / -.1379452388 0732420900 2238377110 d-25 / data erfccs( 47) / +.5634490311 8332526151 3392634811 d-26 / data erfccs( 48) / -.2316490434 4770654482 3427752700 d-26 / data erfccs( 49) / +.9584462844 6018101526 3158381226 d-27 / data erfccs( 50) / -.3990722880 3301097262 4224850193 d-27 / data erfccs( 51) / +.1672129225 9444773601 7228709669 d-27 / data erfccs( 52) / -.7045991522 7660138563 8803782587 d-28 / data erfccs( 53) / +.2979768402 8642063541 2357989444 d-28 / data erfccs( 54) / -.1262522466 4606192972 2422632994 d-28 / data erfccs( 55) / +.5395438704 5424879398 5299653154 d-29 / data erfccs( 56) / -.2380992882 5314591867 5346190062 d-29 / data erfccs( 57) / +.1099052830 1027615735 9726683750 d-29 / data erfccs( 58) / -.4867713741 6449657273 2518677435 d-30 / data erfccs( 59) / +.1525877264 1103575676 3200828211 d-30 / data sqrtpi / 1.772453850 9055160272 9816748334 115d0 / data first /.true./ c if (first) then eta = 0.1*real(d1mach(3)) nterf = initds (erfcs, 21, eta) nterfc = initds (erfccs, 59, eta) nterc2 = initds (erc2cs, 49, eta) c xsml = -sqrt(-log(sqrtpi*d1mach(3))) txmax = sqrt(-log(sqrtpi*d1mach(1))) xmax = txmax - 0.5d0*log(txmax)/txmax - 0.01d0 sqeps = sqrt(2.0d0*d1mach(3)) endif first = .false. c if (x.gt.xsml) go to 20 derfc = 2.0d0 return c 20 if (x.gt.xmax) go to 40 y = abs(x) if (y.gt.1.0d0) go to 30 if (y.lt.sqeps) derfc = 1.0d0 - 2.0d0*x/sqrtpi if (y.ge.sqeps) derfc = 1.0d0 - x*(1.0d0 + dcsevl (2.d0*x*x-1.d0, 1 erfcs, nterf)) return c 30 y = y*y if (y.le.4.d0) derfc = exp(-y)/abs(x) * (0.5d0 + dcsevl ( 1 (8.d0/y-5.d0)/3.d0, erc2cs, nterc2) ) if (y.gt.4.d0) derfc = exp(-y)/abs(x) * (0.5d0 + dcsevl ( 1 8.d0/y-1.d0, erfccs, nterfc) ) if (x.lt.0.d0) derfc = 2.0d0 - derfc return c 40 continue c call mess('derfc','x so big erfc underflows',' ') derfc = 0.d0 return c end *else c function serfc (x) c ****************************************************************** c compute the complementary error function. c from the slatec library fnlib erfc. c ****************************************************************** dimension erfcs(13), erfccs(24), erc2cs(23) logical first save erfcs, erc2cs, erfccs, sqrtpi, nterf, nterfc, 1 nterc2, xsml, xmax, sqeps, first data erfcs( 1) / -.0490461212 34691808e0 / data erfcs( 2) / -.1422612051 0371364e0 / data erfcs( 3) / .0100355821 87599796e0 / data erfcs( 4) / -.0005768764 69976748e0 / data erfcs( 5) / .0000274199 31252196e0 / data erfcs( 6) / -.0000011043 17550734e0 / data erfcs( 7) / .0000000384 88755420e0 / data erfcs( 8) / -.0000000011 80858253e0 / data erfcs( 9) / .0000000000 32334215e0 / data erfcs(10) / -.0000000000 00799101e0 / data erfcs(11) / .0000000000 00017990e0 / data erfcs(12) / -.0000000000 00000371e0 / data erfcs(13) / .0000000000 00000007e0 / data erc2cs( 1) / -.0696013466 02309501e0 / data erc2cs( 2) / -.0411013393 62620893e0 / data erc2cs( 3) / .0039144958 66689626e0 / data erc2cs( 4) / -.0004906395 65054897e0 / data erc2cs( 5) / .0000715747 90013770e0 / data erc2cs( 6) / -.0000115307 16341312e0 / data erc2cs( 7) / .0000019946 70590201e0 / data erc2cs( 8) / -.0000003642 66647159e0 / data erc2cs( 9) / .0000000694 43726100e0 / data erc2cs(10) / -.0000000137 12209021e0 / data erc2cs(11) / .0000000027 88389661e0 / data erc2cs(12) / -.0000000005 81416472e0 / data erc2cs(13) / .0000000001 23892049e0 / data erc2cs(14) / -.0000000000 26906391e0 / data erc2cs(15) / .0000000000 05942614e0 / data erc2cs(16) / -.0000000000 01332386e0 / data erc2cs(17) / .0000000000 00302804e0 / data erc2cs(18) / -.0000000000 00069666e0 / data erc2cs(19) / .0000000000 00016208e0 / data erc2cs(20) / -.0000000000 00003809e0 / data erc2cs(21) / .0000000000 00000904e0 / data erc2cs(22) / -.0000000000 00000216e0 / data erc2cs(23) / .0000000000 00000052e0 / data erfccs( 1) / 0.0715179310 202925e0 / data erfccs( 2) / -.0265324343 37606719e0 / data erfccs( 3) / .0017111539 77920853e0 / data erfccs( 4) / -.0001637516 63458512e0 / data erfccs( 5) / .0000198712 93500549e0 / data erfccs( 6) / -.0000028437 12412769e0 / data erfccs( 7) / .0000004606 16130901e0 / data erfccs( 8) / -.0000000822 77530261e0 / data erfccs( 9) / .0000000159 21418724e0 / data erfccs(10) / -.0000000032 95071356e0 / data erfccs(11) / .0000000007 22343973e0 / data erfccs(12) / -.0000000001 66485584e0 / data erfccs(13) / .0000000000 40103931e0 / data erfccs(14) / -.0000000000 10048164e0 / data erfccs(15) / .0000000000 02608272e0 / data erfccs(16) / -.0000000000 00699105e0 / data erfccs(17) / .0000000000 00192946e0 / data erfccs(18) / -.0000000000 00054704e0 / data erfccs(19) / .0000000000 00015901e0 / data erfccs(20) / -.0000000000 00004729e0 / data erfccs(21) / .0000000000 00001432e0 / data erfccs(22) / -.0000000000 00000439e0 / data erfccs(23) / .0000000000 00000138e0 / data erfccs(24) / -.0000000000 00000048e0 / data sqrtpi /1.772453850 9055160e0/ data first /.true./ c if (first) then eta = 0.1*s1mach(3) nterf = inits (erfcs, 13, eta) nterfc = inits (erfccs, 24, eta) nterc2 = inits (erc2cs, 23, eta) xsml = -sqrt (-log(sqrtpi*s1mach(3))) txmax = sqrt (-log(sqrtpi*s1mach(1))) xmax = txmax - 0.5*log(txmax)/txmax - 0.01 sqeps = sqrt (2.0*s1mach(3)) endif first = .false. c if (x.gt.xsml) go to 20 serfc = 2. return c 20 if (x.gt.xmax) go to 40 y = abs(x) if (y.gt.1.0) go to 30 if (y.lt.sqeps) serfc = 1.0 - 2.0*x/sqrtpi if (y.ge.sqeps) serfc = 1.0 - 1 x*(1.0 + csevl (2.*x*x-1., erfcs, nterf) ) return c 30 y = y*y if (y.le.4.) serfc = exp(-y)/abs(x) * (0.5 + csevl ((8./y-5.)/3., 1 erc2cs, nterc2) ) if (y.gt.4.) serfc = exp(-y)/abs(x) * (0.5 + csevl (8./y-1., 1 erfccs, nterfc) ) if (x.lt.0.) serfc = 2.0 - serfc return c 40 continue c call mess('serfc','x so big erfc underflows',' ') serfc = 0. return c end *endif *if sw c subroutine dlgams (x, dlgam, sgngam) c ****************************************************************** c compute the logarithm of the absolute value of the gamma function. c from the slatec library fnlib dlgams. c ****************************************************************** double precision x, dlgam, sgngam, dlngam c dlgam = dlngam(x) sgngam = 1.0d0 if (x.gt.0.d0) return c int = mod (-aint(x), 2.0d0) + 0.1d0 if (int.eq.0) sgngam = -1.0d0 c return end *else c subroutine algams (x, algam, sgngam) c ****************************************************************** c compute the logarithm of the absolute value of the gamma function. c from the slatec library fnlib algams. c ****************************************************************** algam = alngam(x) sgngam = 1.0 if (x.gt.0.0) return c int = mod (-aint(x), 2.0) + 0.1 if (int.eq.0) sgngam = -1.0 c return end *endif *if sw c double precision function dlngam (x) c ****************************************************************** c compute the logarithm of the absolute value of the gamma function. c from the slatec library fnlib dlngam. c ****************************************************************** double precision x, dxrel, pi, sinpiy, sqpi2l, sq2pil, xmax, 1 y, dgamma, d9lgmc, d1mach, temp logical first external dgamma save sq2pil, sqpi2l, pi, xmax, dxrel, first data sq2pil / 0.9189385332 0467274178 0329736405 62 d0 / data sqpi2l / +.2257913526 4472743236 3097614947 441 d+0 / data pi / 3.1415926535 8979323846 2643383279 50 d0 / data first /.true./ c if (first) then temp = 1.d0/log(d1mach(2)) xmax = temp*d1mach(2) dxrel = sqrt(d1mach(4)) endif first = .false. c y = abs (x) if (y.gt.10.d0) go to 20 dlngam = log (abs (dgamma(x)) ) return c 20 if (y .gt. xmax) call error('dlngam', + 'abs(x) so big dlngam overflows',' ') c if (x.gt.0.d0) dlngam = sq2pil + (x-0.5d0)*log(x) - x + d9lgmc(y) if (x.gt.0.d0) return c sinpiy = abs (sin(pi*y)) if (sinpiy .eq. 0.d0) call error('dlngam', + 'x is a negative integer',' ') c if (abs((x-aint(x-0.5d0))/x) .lt. dxrel) call mess('dlngam', + 'answer lt half precision because x too near negative integer', + ' ') c dlngam = sqpi2l + (x-0.5d0)*log(y) - x - log(sinpiy) - d9lgmc(y) return c end *else c function alngam (x) c ****************************************************************** c compute the logarithm of the absolute value of the gamma function. c from the slatec library fnlib alngam. c ****************************************************************** logical first external gamma save sq2pil, sqpi2l, pi, xmax, dxrel, first data sq2pil / 0.9189385332 0467274e0/ data sqpi2l / 0.2257913526 4472743e0/ data pi / 3.1415926535 8979324e0/ data first /.true./ c if (first) then xmax = s1mach(2)/log(s1mach(2)) dxrel = sqrt (s1mach(4)) endif first = .false. c y = abs(x) if (y.gt.10.0) go to 20 c alngam = log (abs (gamma(x))) return c 20 if (y .gt. xmax) call error('alngam', + 'abs(x) so big alngam overflows',' ') c if (x.gt.0.) alngam = sq2pil + (x-0.5)*log(x) - x + r9lgmc(y) if (x.gt.0.) return c sinpiy = abs (sin(pi*y)) if (sinpiy .eq. 0.) call error('alngam', + 'x is a negative integer',' ') c if (abs((x-aint(x-0.5))/x) .lt. dxrel) call mess('alngam', + 'answer lt half precision because x too near ', + 'negative integer') c alngam = sqpi2l + (x-0.5)*log(y) - x - log(sinpiy) - r9lgmc(y) return c end *endif *if sw c double precision function dcsevl (x, cs, n) c ****************************************************************** c evaluate a chebyshev series. c from the slatec library fnlib dcsevl. c ****************************************************************** double precision b0, b1, b2, cs(*), onepl, twox, x, d1mach logical first save first, onepl data first /.true./ c if (first) onepl = 1.0d0 + d1mach(4) first = .false. if (n .lt. 1) call error('dcsevl','number of terms .le. 0',' ') if (n .gt. 1000) call error('dcsevl', + 'number of terms .gt. 1000',' ') if (abs(x) .gt. onepl) call error('dcsevl', + 'x outside the interval (-1,+1)',' ') c b1 = 0.0d0 b0 = 0.0d0 twox = 2.0d0*x do 10 i = 1,n b2 = b1 b1 = b0 ni = n + 1 - i b0 = twox*b1 - b2 + cs(ni) 10 continue c dcsevl = 0.5d0*(b0-b2) c return end *else c function csevl (x, cs, n) c ****************************************************************** c evaluate a chebyshev series. c from the slatec library fnlib csevl. c ****************************************************************** real b0, b1, b2, cs(*), onepl, twox, x logical first save first, onepl data first /.true./ c if (first) onepl = 1.0e0 + s1mach(4) first = .false. if (n .lt. 1) call error('csevl','number of terms .le. 0',' ') if (n .gt. 1000) call error ('csevl', + 'number of terms .gt. 1000',' ') if (abs(x) .gt. onepl) call error('csevl', + 'x outside the interval (-1,+1)',' ') c b1 = 0.0e0 b0 = 0.0e0 twox = 2.0*x do 10 i = 1,n b2 = b1 b1 = b0 ni = n + 1 - i b0 = twox*b1 - b2 + cs(ni) 10 continue c csevl = 0.5e0*(b0-b2) c return end *endif *if sw c double precision function d9lgit (a, x, algap1) c ****************************************************************** c subsidiary routine. c compute the logarithm of tricomi's incomplete gamma function with c perron's continued fraction for large x and a .ge. x. c from the slatec library fnlib d9lgit. c ****************************************************************** double precision a, x, algap1, ax, a1x, eps, fk, hstar, p, r, s, 1 sqeps, t, d1mach logical first save eps, sqeps, first data first /.true./ c if (first) then eps = 0.5d0*d1mach(3) sqeps = sqrt(d1mach(4)) endif first = .false. c if (x .le. 0.d0 .or. a .lt. x) call error('d9lgit', + 'x should be gt 0.0 and le a',' ') c ax = a + x a1x = ax + 1.0d0 r = 0.d0 p = 1.d0 s = p do 20 k=1,200 fk = k t = (a+fk)*x*(1.d0+r) r = t/((ax+fk)*(a1x+fk)-t) p = r*p s = s + p if (abs(p).lt.eps*s) go to 30 20 continue call error('d9lgit', + 'no convergence in 200 terms of continued fraction',' ') c 30 hstar = 1.0d0 - x*s/a1x if (hstar .lt. sqeps) call mess('d9lgit', + 'result less than half precision',' ') c d9lgit = -x - algap1 - log(hstar) return c end *else c function r9lgit (a, x, algap1) c ****************************************************************** c subsidiary routine c compute the logarithm of tricomi's incomplete gamma function with c perron's continued fraction for large x and a .ge. x. c ****************************************************************** save eps, sqeps data eps, sqeps / 2*0.0 / c if (eps.eq.0.0) eps = 0.5*s1mach(3) if (sqeps.eq.0.0) sqeps = sqrt(s1mach(4)) c if (x .le. 0.0 .or. a .lt. x) call error('r9lgit', + 'x should be gt 0.0 and le a',' ') c ax = a + x a1x = ax + 1.0 r = 0.0 p = 1.0 s = p do 20 k=1,200 fk = k t = (a+fk)*x*(1.0+r) r = t/((ax+fk)*(a1x+fk)-t) p = r*p s = s + p if (abs(p).lt.eps*s) go to 30 20 continue call error('r9lgit', + 'no convergence in 200 terms of continued fraction',' ') c 30 hstar = 1.0 - x*s/a1x if (hstar .lt. sqeps) call mess('r9lgit', + 'result less than half precision',' ') c r9lgit = -x - algap1 - log(hstar) c return end *endif *if sw c double precision function d9lgmc (x) c ****************************************************************** c subsidiary routine. c compute the log gamma correction factor so that c log(dgamma(x)) = log(sqrt(2*pi)) + (x-5.)*log(x) - x + d9lgmc(x). c from the slatec library fnlib d9lgmc. c ****************************************************************** double precision x, algmcs(15), xbig, xmax, dcsevl, d1mach logical first save algmcs, nalgm, xbig, xmax, first data algmcs( 1) / +.1666389480 4518632472 0572965082 2 d+0 / data algmcs( 2) / -.1384948176 0675638407 3298605913 5 d-4 / data algmcs( 3) / +.9810825646 9247294261 5717154748 7 d-8 / data algmcs( 4) / -.1809129475 5724941942 6330626671 9 d-10 / data algmcs( 5) / +.6221098041 8926052271 2601554341 6 d-13 / data algmcs( 6) / -.3399615005 4177219443 0333059966 6 d-15 / data algmcs( 7) / +.2683181998 4826987489 5753884666 6 d-17 / data algmcs( 8) / -.2868042435 3346432841 4462239999 9 d-19 / data algmcs( 9) / +.3962837061 0464348036 7930666666 6 d-21 / data algmcs( 10) / -.6831888753 9857668701 1199999999 9 d-23 / data algmcs( 11) / +.1429227355 9424981475 7333333333 3 d-24 / data algmcs( 12) / -.3547598158 1010705471 9999999999 9 d-26 / data algmcs( 13) / +.1025680058 0104709120 0000000000 0 d-27 / data algmcs( 14) / -.3401102254 3167487999 9999999999 9 d-29 / data algmcs( 15) / +.1276642195 6300629333 3333333333 3 d-30 / data first /.true./ c if (first) then nalgm = initds (algmcs, 15, real(d1mach(3)) ) xbig = 1.0d0/sqrt(d1mach(3)) xmax = exp (min(log(d1mach(2)/12.d0), -log(12.d0*d1mach(1)))) endif first = .false. c if (x .lt. 10.d0) call error('d9lgmc','x must be ge 10',' ') if (x.ge.xmax) go to 20 c d9lgmc = 1.d0/(12.d0*x) if (x.lt.xbig) d9lgmc = dcsevl (2.0d0*(10.d0/x)**2-1.d0, algmcs, 1 nalgm) / x return c 20 d9lgmc = 0.d0 c call error('d9lgmc','x so big d9lgmc underflows',' ') return c end *else c function r9lgmc (x) c ****************************************************************** c subsidiary routine. c compute the log gamma correction factor so that c log(gamma(x)) = log(sqrt(2*pi)) + (x-.5)*log(x) - x r9lgmc(x). c from the slatec library fnlib r9lgmc. c ****************************************************************** dimension algmcs(6) logical first save algmcs, nalgm, xbig, xmax, first data algmcs( 1) / .1666389480 45186e0 / data algmcs( 2) / -.0000138494 817606e0 / data algmcs( 3) / .0000000098 108256e0 / data algmcs( 4) / -.0000000000 180912e0 / data algmcs( 5) / .0000000000 000622e0 / data algmcs( 6) / -.0000000000 000003e0 / data first /.true./ c if (first) then nalgm = inits (algmcs, 6, s1mach(3)) xbig = 1.0/sqrt(s1mach(3)) xmax = exp (min(log(s1mach(2)/12.0), -log(12.0*s1mach(1))) ) endif first = .false. c if (x .lt. 10.0) call error('r9lgmc','x must be ge 10',' ') if (x.ge.xmax) go to 20 c r9lgmc = 1.0/(12.0*x) if (x.lt.xbig) r9lgmc = csevl (2.0*(10./x)**2-1., algmcs, nalgm)/x return c 20 r9lgmc = 0.0 c call mess('r9lgmc','x so big r9lgmc underflows',' ') return c end *endif *if sw c double precision function dgamit (a, x) c ****************************************************************** c calculate tricomi's form of the incomplete gamma function. c from the slatec library fnlib dgamit. c ****************************************************************** double precision a, x, aeps, ainta, algap1, alneps, alng, alx, 1 bot, h, sga, sgngam, sqeps, t, d1mach, dgamr, d9gmit, d9lgit, 2 dlngam, d9lgic logical first save alneps, sqeps, bot, first data first /.true./ c if (first) then alneps = -log (d1mach(3)) sqeps = sqrt(d1mach(4)) bot = log (d1mach(1)) endif first = .false. c if (x .lt. 0.d0) call error('dgamit','x is negative',' ') c if (x.ne.0.d0) alx = log (x) sga = 1.0d0 if (a.ne.0.d0) sga = sign (1.0d0, a) ainta = aint (a + 0.5d0*sga) aeps = a - ainta c if (x.gt.0.d0) go to 20 dgamit = 0.0d0 if (ainta.gt.0.d0 .or. aeps.ne.0.d0) dgamit = dgamr(a+1.0d0) return c 20 if (x.gt.1.d0) go to 30 if (a.ge.(-0.5d0) .or. aeps.ne.0.d0) call dlgams (a+1.0d0, algap1, 1 sgngam) dgamit = d9gmit (a, x, algap1, sgngam, alx) return c 30 if (a.lt.x) go to 40 t = d9lgit (a, x, dlngam(a+1.0d0)) dgamit = exp (t) return c 40 alng = d9lgic (a, x, alx) c c evaluate dgamit in terms of log (dgamic (a, x)) c h = 1.0d0 if (aeps.eq.0.d0 .and. ainta.le.0.d0) go to 50 c call dlgams (a+1.0d0, algap1, sgngam) t = log (abs(a)) + alng - algap1 if (t.gt.alneps) go to 60 c if (t.gt.(-alneps)) h = 1.0d0 - sga * sgngam * exp(t) if (abs(h).gt.sqeps) go to 50 c call mess('dgamit','result lt half precision',' ') c 50 t = -a*alx + log(abs(h)) dgamit = sign (exp(t), h) return c 60 t = t - a*alx dgamit = -sga * sgngam * exp(t) return c end *else c real function gamit (a, x) c ****************************************************************** c calculate tricomi's form of the incomplete gamma function. c from the slatec library fnlib gamit. c ****************************************************************** logical first save alneps, sqeps, bot, first data first /.true./ c if (first) then alneps = -log(s1mach(3)) sqeps = sqrt(s1mach(4)) bot = log(s1mach(1)) endif first = .false. c if (x .lt. 0.0) call error('gamit','x is negative',' ') c if (x.ne.0.0) alx = log(x) sga = 1.0 if (a.ne.0.0) sga = sign (1.0, a) ainta = aint (a+0.5*sga) aeps = a - ainta c if (x.gt.0.0) go to 20 gamit = 0.0 if (ainta.gt.0.0 .or. aeps.ne.0.0) gamit = gamr(a+1.0) return c 20 if (x.gt.1.0) go to 40 if (a.ge.(-0.5) .or. aeps.ne.0.0) call algams (a+1.0, algap1, 1 sgngam) gamit = r9gmit (a, x, algap1, sgngam, alx) return c 40 if (a.lt.x) go to 50 t = r9lgit (a, x, alngam(a+1.0)) gamit = exp(t) return c 50 alng = r9lgic (a, x, alx) c c evaluate gamit in terms of log(gamic(a,x)) c h = 1.0 if (aeps.eq.0.0 .and. ainta.le.0.0) go to 60 call algams (a+1.0, algap1, sgngam) t = log(abs(a)) + alng - algap1 if (t.gt.alneps) go to 70 if (t.gt.(-alneps)) h = 1.0 - sga*sgngam*exp(t) if (abs(h).gt.sqeps) go to 60 call mess('gamit','result lt half precision',' ') c 60 t = -a*alx + log(abs(h)) gamit = sign (exp(t), h) return c 70 t = t - a*alx gamit = -sga*sgngam*exp(t) return c end *endif *if sw c subroutine dgamlm (xmin, xmax) c ****************************************************************** c compute the minimum and maximum bounds for the argument in c the gamma function. c from the slatec library fnlib dgamlm. c ****************************************************************** double precision xmin, xmax, alnbig, alnsml, xln, xold, d1mach c alnsml = log(d1mach(1)) xmin = -alnsml do 10 i=1,10 xold = xmin xln = log(xmin) xmin = xmin - xmin*((xmin+0.5d0)*xln - xmin - 0.2258d0 + alnsml) 1 / (xmin*xln+0.5d0) if (abs(xmin-xold).lt.0.005d0) go to 20 10 continue call error('dgamlm','unable to find xmin',' ') c 20 xmin = -xmin + 0.01d0 c alnbig = log (d1mach(2)) xmax = alnbig do 30 i=1,10 xold = xmax xln = log(xmax) xmax = xmax - xmax*((xmax-0.5d0)*xln - xmax + 0.9189d0 - alnbig) 1 / (xmax*xln-0.5d0) if (abs(xmax-xold).lt.0.005d0) go to 40 30 continue call error('dgamlm','unable to find xmax',' ') c 40 xmax = xmax - 0.01d0 xmin = max (xmin, -xmax+1.d0) c return end *else c subroutine gamlim (xmin, xmax) c ****************************************************************** c compute the minimum and maximum bounds for the argument in c the gamma function. c from the slatec library fnlib gamlim. c ****************************************************************** alnsml = log(s1mach(1)) xmin = -alnsml do 10 i=1,10 xold = xmin xln = log(xmin) xmin = xmin - xmin*((xmin+0.5)*xln - xmin - 0.2258 + alnsml) 1 / (xmin*xln + 0.5) if (abs(xmin-xold).lt.0.005) go to 20 10 continue call error('gamlim','unable to find xmin',' ') c 20 xmin = -xmin + 0.01 c alnbig = log(s1mach(2)) xmax = alnbig do 30 i=1,10 xold = xmax xln = log(xmax) xmax = xmax - xmax*((xmax-0.5)*xln - xmax + 0.9189 - alnbig) 1 / (xmax*xln - 0.5) if (abs(xmax-xold).lt.0.005) go to 40 30 continue call error('gamlim','unable to find xmax',' ') c 40 xmax = xmax - 0.01 xmin = max (xmin, -xmax+1.) c return end *endif *if sw c double precision function dgamma (x) c ****************************************************************** c compute the complete gamma function. c from the slatec library fnlib dgamma. c ****************************************************************** double precision x, gamcs(42), dxrel, pi, sinpiy, sq2pil, xmax, 1 xmin, y, d9lgmc, dcsevl, d1mach logical first save gamcs, pi, sq2pil, ngam, xmin, xmax, dxrel, first data gamcs( 1) / +.8571195590 9893314219 2006239994 2 d-2 / data gamcs( 2) / +.4415381324 8410067571 9131577165 2 d-2 / data gamcs( 3) / +.5685043681 5993633786 3266458878 9 d-1 / data gamcs( 4) / -.4219835396 4185605010 1250018662 4 d-2 / data gamcs( 5) / +.1326808181 2124602205 8400679635 2 d-2 / data gamcs( 6) / -.1893024529 7988804325 2394702388 6 d-3 / data gamcs( 7) / +.3606925327 4412452565 7808221722 5 d-4 / data gamcs( 8) / -.6056761904 4608642184 8554829036 5 d-5 / data gamcs( 9) / +.1055829546 3022833447 3182350909 3 d-5 / data gamcs( 10) / -.1811967365 5423840482 9185589116 6 d-6 / data gamcs( 11) / +.3117724964 7153222777 9025459316 9 d-7 / data gamcs( 12) / -.5354219639 0196871408 7408102434 7 d-8 / data gamcs( 13) / +.9193275519 8595889468 8778682594 0 d-9 / data gamcs( 14) / -.1577941280 2883397617 6742327395 3 d-9 / data gamcs( 15) / +.2707980622 9349545432 6654043308 9 d-10 / data gamcs( 16) / -.4646818653 8257301440 8166105893 3 d-11 / data gamcs( 17) / +.7973350192 0074196564 6076717535 9 d-12 / data gamcs( 18) / -.1368078209 8309160257 9949917230 9 d-12 / data gamcs( 19) / +.2347319486 5638006572 3347177168 8 d-13 / data gamcs( 20) / -.4027432614 9490669327 6657053469 9 d-14 / data gamcs( 21) / +.6910051747 3721009121 3833697525 7 d-15 / data gamcs( 22) / -.1185584500 2219929070 5238712619 2 d-15 / data gamcs( 23) / +.2034148542 4963739552 0102605193 2 d-16 / data gamcs( 24) / -.3490054341 7174058492 7401294910 8 d-17 / data gamcs( 25) / +.5987993856 4853055671 3505106602 6 d-18 / data gamcs( 26) / -.1027378057 8722280744 9006977843 1 d-18 / data gamcs( 27) / +.1762702816 0605298249 4275966074 8 d-19 / data gamcs( 28) / -.3024320653 7353062609 5877211204 2 d-20 / data gamcs( 29) / +.5188914660 2183978397 1783355050 6 d-21 / data gamcs( 30) / -.8902770842 4565766924 4925160106 6 d-22 / data gamcs( 31) / +.1527474068 4933426022 7459689130 6 d-22 / data gamcs( 32) / -.2620731256 1873629002 5732833279 9 d-23 / data gamcs( 33) / +.4496464047 8305386703 3104657066 6 d-24 / data gamcs( 34) / -.7714712731 3368779117 0390152533 3 d-25 / data gamcs( 35) / +.1323635453 1260440364 8657271466 6 d-25 / data gamcs( 36) / -.2270999412 9429288167 0231381333 3 d-26 / data gamcs( 37) / +.3896418998 0039914493 2081663999 9 d-27 / data gamcs( 38) / -.6685198115 1259533277 9212799999 9 d-28 / data gamcs( 39) / +.1146998663 1400243843 4761386666 6 d-28 / data gamcs( 40) / -.1967938586 3451346772 9510399999 9 d-29 / data gamcs( 41) / +.3376448816 5853380903 3489066666 6 d-30 / data gamcs( 42) / -.5793070335 7821357846 2549333333 3 d-31 / data pi / 3.1415926535 8979323846 2643383279 50 d0 / data sq2pil / 0.9189385332 0467274178 0329736405 62 d0 / data first /.true./ c if (first) then ngam = initds (gamcs, 42, 0.1*real(d1mach(3)) ) c call dgamlm (xmin, xmax) dxrel = sqrt(d1mach(4)) endif first = .false. c y = abs(x) if (y.gt.10.d0) go to 50 c c compute gamma(x) for -xbnd .le. x .le. xbnd. reduce interval c and find gamma(1+y) for 0.0 .le. y .lt. 1.0 first of all. c n = x if (x.lt.0.d0) n = n - 1 y = x - n n = n - 1 dgamma = 0.9375d0 + dcsevl (2.d0*y-1.d0, gamcs, ngam) if (n.eq.0) return c if (n.gt.0) go to 30 c c compute gamma(x) for x .lt. 1.0 c n = -n if (x .eq. 0.d0) call error('dgamma','x is 0',' ') if (x .lt. 0.0 .and. x+n-2 .eq. 0.d0) call error('dgamma', + 'x is a negative integer',' ') if (x .lt. (-0.5d0) .and. abs((x-aint(x-0.5d0))/x) .lt. dxrel) + call mess('dgamma', + 'answer lt half precision because x too near negative integer', + ' ') c do 20 i=1,n dgamma = dgamma/(x+i-1 ) 20 continue return c c gamma(x) for x .ge. 2.0 and x .le. 10.0 c 30 do 40 i=1,n dgamma = (y+i) * dgamma 40 continue return c c gamma(x) for abs(x) .gt. 10.0. recall y = abs(x). c 50 if (x .gt. xmax) call error('dgamma', + 'x so big gamma overflows',' ') c dgamma = 0.d0 c if (x .lt. xmin) call mess('dgamma', c + 'x so small gamma underflows',' ') if (x.lt.xmin) return c dgamma = exp ((y-0.5d0)*log(y) - y + sq2pil + d9lgmc(y) ) if (x.gt.0.d0) return c if (abs((x-aint(x-0.5d0))/x) .lt. dxrel) call mess('dgamma', + 'answer lt half precision, x too near negative integer',' ') c sinpiy = sin (pi*y) if (sinpiy .eq. 0.d0) call error('dgamma', + 'x is a negative integer',' ') c dgamma = -pi/(y*sinpiy*dgamma) c return end *else c function gamma (x) c ****************************************************************** c compute the complete gamma function. c from the slatec library fnlib gamma. c ****************************************************************** dimension gcs(23) logical first save gcs, pi, sq2pil, ngcs, xmin, xmax, dxrel, first data gcs ( 1) / .0085711955 90989331e0/ data gcs ( 2) / .0044153813 24841007e0/ data gcs ( 3) / .0568504368 1599363e0/ data gcs ( 4) /-.0042198353 96418561e0/ data gcs ( 5) / .0013268081 81212460e0/ data gcs ( 6) /-.0001893024 529798880e0/ data gcs ( 7) / .0000360692 532744124e0/ data gcs ( 8) /-.0000060567 619044608e0/ data gcs ( 9) / .0000010558 295463022e0/ data gcs (10) /-.0000001811 967365542e0/ data gcs (11) / .0000000311 772496471e0/ data gcs (12) /-.0000000053 542196390e0/ data gcs (13) / .0000000009 193275519e0/ data gcs (14) /-.0000000001 577941280e0/ data gcs (15) / .0000000000 270798062e0/ data gcs (16) /-.0000000000 046468186e0/ data gcs (17) / .0000000000 007973350e0/ data gcs (18) /-.0000000000 001368078e0/ data gcs (19) / .0000000000 000234731e0/ data gcs (20) /-.0000000000 000040274e0/ data gcs (21) / .0000000000 000006910e0/ data gcs (22) /-.0000000000 000001185e0/ data gcs (23) / .0000000000 000000203e0/ data pi /3.14159 26535 89793 24e0/ c sq2pil is log (sqrt (2.*pi) ) data sq2pil /0.91893 85332 04672 74e0/ data first /.true./ c if (first) then ngcs = inits (gcs, 23, 0.1*s1mach(3)) call gamlim (xmin, xmax) dxrel = sqrt (s1mach(4)) endif first = .false. c y = abs(x) if (y.gt.10.0) go to 50 c c compute gamma(x) for abs(x) .le. 10.0. reduce interval and c find gamma(1+y) for 0. .le. y .lt. 1. first of all. c n = x if (x.lt.0.) n = n - 1 y = x - n n = n - 1 gamma = 0.9375 + csevl(2.*y-1., gcs, ngcs) if (n.eq.0) return c if (n.gt.0) go to 30 c c compute gamma(x) for x .lt. 1. c n = -n if (x .eq. 0.) call error('gamma','x is 0',' ') if (x .lt. 0. .and. x+n-2 .eq. 0.) call error('gamma' 1, 'x is a negative integer',' ') if (x .lt. (-0.5) .and. abs((x-aint(x-0.5))/x) .lt. dxrel) 1 call mess( 'slatec', 'gamma', 2'answer lt half precision because x too near negative integer' 3,' ') c do 20 i=1,n gamma = gamma / (x+i-1) 20 continue return c c gamma(x) for x .ge. 2. c 30 do 40 i=1,n gamma = (y+i)*gamma 40 continue return c c compute gamma(x) for abs(x) .gt. 10.0. recall y = abs(x). c 50 if (x .gt. xmax) call error('gamma', + 'x so big gamma overflows',' ') c gamma = 0. c if (x .lt. xmin) call mess('gamma', c + 'x so small gamma underflows',' ') if (x.lt.xmin) return c gamma = exp((y-0.5)*log(y) - y + sq2pil + r9lgmc(y) ) if (x.gt.0.) return c if (abs((x-aint(x-0.5))/x) .lt. dxrel) call mess('gamma', + 'answer lt half precision, x too near negative integer', + ' ') c sinpiy = sin (pi*y) if (sinpiy .eq. 0.) call error('gamma', + 'x is a negative integer',' ') c gamma = -pi / (y*sinpiy*gamma) c return end *endif *if sw c double precision function dgamr (x) c ****************************************************************** c compute the reciprocal of the gamma function. c from the slatec library fnlib dgamr. c ****************************************************************** double precision x,alngx,sgngx,dgamma dgamr = 0.0d0 if (x.le.0.0d0 .and. aint(x).eq.x) return c if (abs(x).gt.10.0d0) go to 10 dgamr = 1.0d0/dgamma(x) return c 10 call dlgams (x, alngx, sgngx) dgamr = sgngx * exp(-alngx) return c end *else c function gamr (x) c ****************************************************************** c compute the reciprocal of the gamma function. c from the slatec library fnlib gamr. c ****************************************************************** gamr = 0.0 if (x.le.0.0 .and. aint(x).eq.x) return c if (abs(x).gt.10.0) go to 10 gamr = 1.0/gamma(x) return c 10 call algams (x, alngx, sgngx) gamr = sgngx * exp(-alngx) return c end *endif *if sw c function initds (os, nos, eta) c ****************************************************************** c determine the number of terms needed in an orthogonal c polynomial series so that it meets a specified accuracy. c from the slatec library fnlib initds. c ****************************************************************** double precision os(*) c if (nos .lt. 1) call mess('initds', + 'number of coefficients is less than 1',' ') c err = 0. do 10 ii = 1,nos i = nos + 1 - ii err = err + abs(real(os(i))) if (err.gt.eta) go to 20 10 continue c 20 if (i .eq. nos) call mess('initds', + 'chebyshev series too short for specified accuracy',' ') initds = i c return end *else c function inits (os, nos, eta) c ****************************************************************** c determine the number of terms needed in an orthogonal c polynomial series so that it meets a specified accuracy. c from the slatec library fnlib inits. c ****************************************************************** real os(*) c if (nos .lt. 1) call mess('inits', + 'number of coefficients is less than 1',' ') c err = 0. do 10 ii = 1,nos i = nos + 1 - ii err = err + abs(os(i)) if (err.gt.eta) go to 20 10 continue c 20 if (i .eq. nos) call mess('inits', + 'chebyshev series too short for specified accuracy',' ') inits = i c return end *endif *if sw c double precision function d9gmit (a, x, algap1, sgngam, alx) c ****************************************************************** c subsidiary routine. c compute tricomi's incomplete gamma function for small arguments. c from the slatec library fnlib d9gmit. c ****************************************************************** double precision a, x, algap1, sgngam, alx, ae, aeps, algs, alg2, 1 bot, eps, fk, s, sgng2, t, te, d1mach, dlngam logical first save eps, bot, first data first /.true./ c if (first) then eps = 0.5d0*d1mach(3) bot = log (d1mach(1)) endif first = .false. c if (x .le. 0.d0) call error('d9gmit','x should be gt 0',' ') c ma = a + 0.5d0 if (a.lt.0.d0) ma = a - 0.5d0 aeps = a - ma c ae = a if (a.lt.(-0.5d0)) ae = aeps c t = 1.d0 te = ae s = t do 20 k=1,200 fk = k te = -x*te/fk t = te/(ae+fk) s = s + t if (abs(t).lt.eps*abs(s)) go to 30 20 continue call error('d9gmit', + 'no convergence in 200 terms of taylor-s series',' ') c 30 if (a.ge.(-0.5d0)) algs = -algap1 + log(s) if (a.ge.(-0.5d0)) go to 60 c algs = -dlngam(1.d0+aeps) + log(s) s = 1.0d0 m = -ma - 1 if (m.eq.0) go to 50 t = 1.0d0 do 40 k=1,m t = x*t/(aeps-(m+1-k)) s = s + t if (abs(t).lt.eps*abs(s)) go to 50 40 continue c 50 d9gmit = 0.0d0 algs = -ma*log(x) + algs if (s.eq.0.d0 .or. aeps.eq.0.d0) go to 60 c sgng2 = sgngam * sign (1.0d0, s) alg2 = -x - algap1 + log(abs(s)) c if (alg2.gt.bot) d9gmit = sgng2 * exp(alg2) if (algs.gt.bot) d9gmit = d9gmit + exp(algs) return c 60 d9gmit = exp (algs) return c end *else c function r9gmit (a, x, algap1, sgngam, alx) c ****************************************************************** c subsidiary routine. c compute tricomi's incomplete gamma function for small arguments. c from the slatec library fnlib r9gmit. c ****************************************************************** if (eps.eq.0.0) eps = 0.5*s1mach(3) if (bot.eq.0.0) bot = log(s1mach(1)) c if (x .le. 0.0) call error('r9gmit','x should be gt 0',' ') c ma = a + 0.5 if (a.lt.0.0) ma = a - 0.5 aeps = a - ma c ae = a if (a.lt.(-0.5)) ae = aeps c t = 1.0 te = ae s = t do 20 k=1,200 fk = k te = -x*te/fk t = te/(ae+fk) s = s + t if (abs(t).lt.eps*abs(s)) go to 30 20 continue call error('r9gmit', + 'no convergence in 200 terms of taylor-s series',' ') c 30 if (a.ge.(-0.5)) algs = -algap1 + log(s) if (a.ge.(-0.5)) go to 60 c algs = -alngam(1.0+aeps) + log(s) s = 1.0 m = -ma - 1 if (m.eq.0) go to 50 t = 1.0 do 40 k=1,m t = x*t/(aeps-m-1+k) s = s + t if (abs(t).lt.eps*abs(s)) go to 50 40 continue c 50 r9gmit = 0.0 algs = -ma*log(x) + algs if (s.eq.0.0 .or. aeps.eq.0.0) go to 60 c sgng2 = sgngam*sign(1.0,s) alg2 = -x - algap1 + log(abs(s)) c if (alg2.gt.bot) r9gmit = sgng2*exp(alg2) if (algs.gt.bot) r9gmit = r9gmit + exp(algs) return c 60 r9gmit = exp(algs) return c end *endif *if sw c double precision function d9lgic (a, x, alx) c ****************************************************************** c subsidiary routine. c compute the log complementary incomplete gamma function c for large x and for a .le. x. c from the slatec library fnlib d9lgic. c ****************************************************************** double precision a, x, alx, eps, fk, p, r, s, t, xma, xpa, d1mach save eps data eps / 0.d0 / c if (eps.eq.0.d0) eps = 0.5d0*d1mach(3) c xpa = x + 1.0d0 - a xma = x - 1.d0 - a c r = 0.d0 p = 1.d0 s = p do 10 k=1,300 fk = k t = fk*(a-fk)*(1.d0+r) r = -t/((xma+2.d0*fk)*(xpa+2.d0*fk)+t) p = r*p s = s + p if (abs(p).lt.eps*s) go to 20 10 continue call error('d9lgic', + 'no convergence in 300 terms of continued fraction',' ') c 20 d9lgic = a*alx - x + log(s/xpa) c return end *else c function r9lgic (a, x, alx) c ****************************************************************** c subsidiary routine. c compute the log complementary incomplete gamma function c for large x and for a .le. x. c from the slatec library fnlib r9lgic. c ****************************************************************** save eps data eps / 0.0 / c if (eps.eq.0.0) eps = 0.5*s1mach(3) c xpa = x + 1.0 - a xma = x - 1.0 - a c r = 0.0 p = 1.0 s = p do 10 k=1,200 fk = k t = fk*(a-fk)*(1.0+r) r = -t/((xma+2.0*fk)*(xpa+2.0*fk)+t) p = r*p s = s + p if (abs(p).lt.eps*s) go to 20 10 continue call error('r9lgic', + 'no convergence in 200 terms of continued fraction',' ') c 20 r9lgic = a*alx - x + log(s/xpa) c return end *endif *if sw c double precision function d1mach (i) c ****************************************************************** c return floating point machine dependent constants. c used by slatec library routines. c c d1mach( 1) = b**(emin-1), the smallest positive magnitude. c d1mach( 2) = b**emax*(1 - b**(-t)), the largest magnitude. c d1mach( 3) = b**(-t), the smallest relative spacing. c d1mach( 4) = b**(1-t), the largest relative spacing. c d1mach( 5) = log10(b) c c assume double precision numbers are represented in the t-digit, c base-b form c c sign (b**e)*( (x(1)/b) + ... + (x(t)/b**t) ) c c where 0 .le. x(i) .lt. b for i=1,...,t, 0 .lt. x(1), and c emin .le. e .le. emax. c c the values of b, t, emin and emax are provided in i1mach as c follows: c c i1mach(10) = b, the base. c i1mach(14) = t, the number of base-b digits. c i1mach(15) = emin, the smallest exponent e. c i1mach(16) = emax, the largest exponent e. c c to alter this function for a particular environment, the desired c set of data statements should be activated by removing the c from c column 1. also, the values of d1mach(1) - d1mach(4) should be c checked for consistency with the local operating system. c ****************************************************************** integer small(4) integer large(4) integer right(4) integer diver(4) integer log10(4) c double precision dmach(5) save dmach c equivalence (dmach(1),small(1)) equivalence (dmach(2),large(1)) equivalence (dmach(3),right(1)) equivalence (dmach(4),diver(1)) equivalence (dmach(5),log10(1)) c c machine constants for the amiga c absoft fortran compiler using the 68020/68881 compiler option c c data small(1), small(2) / z'00100000', z'00000000' / c data large(1), large(2) / z'7fefffff', z'ffffffff' / c data right(1), right(2) / z'3ca00000', z'00000000' / c data diver(1), diver(2) / z'3cb00000', z'00000000' / c data log10(1), log10(2) / z'3fd34413', z'509f79ff' / c c machine constants for the amiga c absoft fortran compiler using software floating point c c data small(1), small(2) / z'00100000', z'00000000' / c data large(1), large(2) / z'7fdfffff', z'ffffffff' / c data right(1), right(2) / z'3ca00000', z'00000000' / c data diver(1), diver(2) / z'3cb00000', z'00000000' / c data log10(1), log10(2) / z'3fd34413', z'509f79ff' / c c machine constants for the apollo c c data small(1), small(2) / 16#00100000, 16#00000000 / c data large(1), large(2) / 16#7fffffff, 16#ffffffff / c data right(1), right(2) / 16#3ca00000, 16#00000000 / c data diver(1), diver(2) / 16#3cb00000, 16#00000000 / c data log10(1), log10(2) / 16#3fd34413, 16#509f79ff / c c machine constants for the burroughs 1700 system c c data small(1) / zc00800000 / c data small(2) / z000000000 / c data large(1) / zdffffffff / c data large(2) / zfffffffff / c data right(1) / zcc5800000 / c data right(2) / z000000000 / c data diver(1) / zcc6800000 / c data diver(2) / z000000000 / c data log10(1) / zd00e730e7 / c data log10(2) / zc77800dc0 / c c machine constants for the burroughs 5700 system c c data small(1) / o1771000000000000 / c data small(2) / o0000000000000000 / c data large(1) / o0777777777777777 / c data large(2) / o0007777777777777 / c data right(1) / o1461000000000000 / c data right(2) / o0000000000000000 / c data diver(1) / o1451000000000000 / c data diver(2) / o0000000000000000 / c data log10(1) / o1157163034761674 / c data log10(2) / o0006677466732724 / c c machine constants for the burroughs 6700/7700 systems c c data small(1) / o1771000000000000 / c data small(2) / o7770000000000000 / c data large(1) / o0777777777777777 / c data large(2) / o7777777777777777 / c data right(1) / o1461000000000000 / c data right(2) / o0000000000000000 / c data diver(1) / o1451000000000000 / c data diver(2) / o0000000000000000 / c data log10(1) / o1157163034761674 / c data log10(2) / o0006677466732724 / c c machine constants for the cdc 170/180 series using nos/ve c c data small(1) / z"3001800000000000" / c data small(2) / z"3001000000000000" / c data large(1) / z"4ffefffffffffffe" / c data large(2) / z"4ffe000000000000" / c data right(1) / z"3fd2800000000000" / c data right(2) / z"3fd2000000000000" / c data diver(1) / z"3fd3800000000000" / c data diver(2) / z"3fd3000000000000" / c data log10(1) / z"3fff9a209a84fbcf" / c data log10(2) / z"3ffff7988f8959ac" / c c machine constants for the cdc 6000/7000 series c c data small(1) / 00564000000000000000b / c data small(2) / 00000000000000000000b / c data large(1) / 37757777777777777777b / c data large(2) / 37157777777777777777b / c data right(1) / 15624000000000000000b / c data right(2) / 00000000000000000000b / c data diver(1) / 15634000000000000000b / c data diver(2) / 00000000000000000000b / c data log10(1) / 17164642023241175717b / c data log10(2) / 16367571421742254654b / c c machine constants for the celerity c1260 c c data small(1), small(2) / z'00100000', z'00000000' / c data large(1), large(2) / z'7fefffff', z'ffffffff' / c data right(1), right(2) / z'3ca00000', z'00000000' / c data diver(1), diver(2) / z'3cb00000', z'00000000' / c data log10(1), log10(2) / z'3fd34413', z'509f79ff' / c c machine constants for the convex c using the -fn or -pd8 compiler option c c data dmach(1) / z'0010000000000000' / c data dmach(2) / z'7fffffffffffffff' / c data dmach(3) / z'3cc0000000000000' / c data dmach(4) / z'3cd0000000000000' / c data dmach(5) / z'3ff34413509f79ff' / c c machine constants for the convex c using the -fi compiler option c c data dmach(1) / z'0010000000000000' / c data dmach(2) / z'7fefffffffffffff' / c data dmach(3) / z'3ca0000000000000' / c data dmach(4) / z'3cb0000000000000' / c data dmach(5) / z'3fd34413509f79ff' / c c machine constants for the convex c using the -p8 compiler option c c data dmach(1) / z'00010000000000000000000000000000' / c data dmach(2) / z'7fffffffffffffffffffffffffffffff' / c data dmach(3) / z'3f900000000000000000000000000000' / c data dmach(4) / z'3f910000000000000000000000000000' / c data dmach(5) / z'3fff34413509f79fef311f12b35816f9' / c c machine constants for the cray c c data small(1) / 201354000000000000000b / c data small(2) / 000000000000000000000b / c data large(1) / 577767777777777777777b / c data large(2) / 000007777777777777774b / c data right(1) / 376434000000000000000b / c data right(2) / 000000000000000000000b / c data diver(1) / 376444000000000000000b / c data diver(2) / 000000000000000000000b / c data log10(1) / 377774642023241175717b / c data log10(2) / 000007571421742254654b / c c machine constants for the data general eclipse s/200 c note - it may be appropriate to include the following card - c static dmach(5) c c data small / 20k, 3*0 / c data large / 77777k, 3*177777k / c data right / 31420k, 3*0 / c data diver / 32020k, 3*0 / c data log10 / 40423k, 42023k, 50237k, 74776k / c c machine constants for the dec alpha c using g_float c c data dmach(1) / '0000000000000010'x / c data dmach(2) / 'ffffffffffff7fff'x / c data dmach(3) / '0000000000003cc0'x / c data dmach(4) / '0000000000003cd0'x / c data dmach(5) / '79ff509f44133ff3'x / c c machine constants for the dec alpha c using ieee_format c c data dmach(1) / '0010000000000000'x / c data dmach(2) / '7fefffffffffffff'x / c data dmach(3) / '3ca0000000000000'x / c data dmach(4) / '3cb0000000000000'x / c data dmach(5) / '3fd34413509f79ff'x / c c machine constants for the dec risc c c data small(1), small(2) / z'00000000', z'00100000'/ c data large(1), large(2) / z'ffffffff', z'7fefffff'/ c data right(1), right(2) / z'00000000', z'3ca00000'/ c data diver(1), diver(2) / z'00000000', z'3cb00000'/ c data log10(1), log10(2) / z'509f79ff', z'3fd34413'/ c c machine constants for the dec vax c using d_floating c (expressed in integer and hexadecimal) c the hex format below may not be suitable for unix systems c the integer format should be ok for unix systems c c data small(1), small(2) / 128, 0 / c data large(1), large(2) / -32769, -1 / c data right(1), right(2) / 9344, 0 / c data diver(1), diver(2) / 9472, 0 / c data log10(1), log10(2) / 546979738, -805796613 / c c data small(1), small(2) / z00000080, z00000000 / c data large(1), large(2) / zffff7fff, zffffffff / c data right(1), right(2) / z00002480, z00000000 / c data diver(1), diver(2) / z00002500, z00000000 / c data log10(1), log10(2) / z209a3f9a, zcff884fb / c c machine constants for the dec vax c using g_floating c (expressed in integer and hexadecimal) c the hex format below may not be suitable for unix systems c the integer format should be ok for unix systems c c data small(1), small(2) / 16, 0 / c data large(1), large(2) / -32769, -1 / c data right(1), right(2) / 15552, 0 / c data diver(1), diver(2) / 15568, 0 / c data log10(1), log10(2) / 1142112243, 2046775455 / c c data small(1), small(2) / z00000010, z00000000 / c data large(1), large(2) / zffff7fff, zffffffff / c data right(1), right(2) / z00003cc0, z00000000 / c data diver(1), diver(2) / z00003cd0, z00000000 / c data log10(1), log10(2) / z44133ff3, z79ff509f / c c machine constants for the elxsi 6400 c (assuming real*8 is the default double precision) c c data small(1), small(2) / '00100000'x,'00000000'x / c data large(1), large(2) / '7fefffff'x,'ffffffff'x / c data right(1), right(2) / '3cb00000'x,'00000000'x / c data diver(1), diver(2) / '3cc00000'x,'00000000'x / c data log10(1), log10(2) / '3fd34413'x,'509f79ff'x / c c machine constants for the harris 220 c c data small(1), small(2) / '20000000, '00000201 / c data large(1), large(2) / '37777777, '37777577 / c data right(1), right(2) / '20000000, '00000333 / c data diver(1), diver(2) / '20000000, '00000334 / c data log10(1), log10(2) / '23210115, '10237777 / c c machine constants for the honeywell 600/6000 series c c data small(1), small(2) / o402400000000, o000000000000 / c data large(1), large(2) / o376777777777, o777777777777 / c data right(1), right(2) / o604400000000, o000000000000 / c data diver(1), diver(2) / o606400000000, o000000000000 / c data log10(1), log10(2) / o776464202324, o117571775714 / c c machine constants for the hp 730 c c data dmach(1) / z'0010000000000000' / c data dmach(2) / z'7fefffffffffffff' / c data dmach(3) / z'3ca0000000000000' / c data dmach(4) / z'3cb0000000000000' / c data dmach(5) / z'3fd34413509f79ff' / c c machine constants for the hp 2100 c three word double precision option with ftn4 c c data small(1), small(2), small(3) / 40000b, 0, 1 / c data large(1), large(2), large(3) / 77777b, 177777b, 177776b / c data right(1), right(2), right(3) / 40000b, 0, 265b / c data diver(1), diver(2), diver(3) / 40000b, 0, 276b / c data log10(1), log10(2), log10(3) / 46420b, 46502b, 77777b / c c machine constants for the hp 2100 c four word double precision option with ftn4 c c data small(1), small(2) / 40000b, 0 / c data small(3), small(4) / 0, 1 / c data large(1), large(2) / 77777b, 177777b / c data large(3), large(4) / 177777b, 177776b / c data right(1), right(2) / 40000b, 0 / c data right(3), right(4) / 0, 225b / c data diver(1), diver(2) / 40000b, 0 / c data diver(3), diver(4) / 0, 227b / c data log10(1), log10(2) / 46420b, 46502b / c data log10(3), log10(4) / 76747b, 176377b / c c machine constants for the hp 9000 c c data small(1), small(2) / 00040000000b, 00000000000b / c data large(1), large(2) / 17737777777b, 37777777777b / c data right(1), right(2) / 07454000000b, 00000000000b / c data diver(1), diver(2) / 07460000000b, 00000000000b / c data log10(1), log10(2) / 07764642023b, 12047674777b / c c machine constants for the ibm 360/370 series, c the xerox sigma 5/7/9, the sel systems 85/86, and c the perkin elmer (interdata) 7/32. c c data small(1), small(2) / z00100000, z00000000 / c data large(1), large(2) / z7fffffff, zffffffff / c data right(1), right(2) / z33100000, z00000000 / c data diver(1), diver(2) / z34100000, z00000000 / c data log10(1), log10(2) / z41134413, z509f79ff / c c machine constants for the ibm pc c assumes that all arithmetic is done in double precision c on 8088, i.e., not in 80 bit form for the 8087. c c data small(1) / 2.23d-308 / c data large(1) / 1.79d+308 / c data right(1) / 1.11d-16 / c data diver(1) / 2.22d-16 / c data log10(1) / 0.301029995663981195d0 / c c machine constants for the ibm rs 6000 c c data dmach(1) / z'0010000000000000' / c data dmach(2) / z'7fefffffffffffff' / c data dmach(3) / z'3ca0000000000000' / c data dmach(4) / z'3cb0000000000000' / c data dmach(5) / z'3fd34413509f79ff' / c c machine constants for the intel i860 c c data dmach(1) / z'0010000000000000' / c data dmach(2) / z'7fefffffffffffff' / c data dmach(3) / z'3ca0000000000000' / c data dmach(4) / z'3cb0000000000000' / c data dmach(5) / z'3fd34413509f79ff' / c c machine constants for the pdp-10 (ka processor) c c data small(1), small(2) / "033400000000, "000000000000 / c data large(1), large(2) / "377777777777, "344777777777 / c data right(1), right(2) / "113400000000, "000000000000 / c data diver(1), diver(2) / "114400000000, "000000000000 / c data log10(1), log10(2) / "177464202324, "144117571776 / c c machine constants for the pdp-10 (ki processor) c c data small(1), small(2) / "000400000000, "000000000000 / c data large(1), large(2) / "377777777777, "377777777777 / c data right(1), right(2) / "103400000000, "000000000000 / c data diver(1), diver(2) / "104400000000, "000000000000 / c data log10(1), log10(2) / "177464202324, "476747767461 / c c machine constants for pdp-11 fortran supporting c 32-bit integers (expressed in integer and octal). c c data small(1), small(2) / 8388608, 0 / c data large(1), large(2) / 2147483647, -1 / c data right(1), right(2) / 612368384, 0 / c data diver(1), diver(2) / 620756992, 0 / c data log10(1), log10(2) / 1067065498, -2063872008 / c c data small(1), small(2) / o00040000000, o00000000000 / c data large(1), large(2) / o17777777777, o37777777777 / c data right(1), right(2) / o04440000000, o00000000000 / c data diver(1), diver(2) / o04500000000, o00000000000 / c data log10(1), log10(2) / o07746420232, o20476747770 / c c machine constants for pdp-11 fortran supporting c 16-bit integers (expressed in integer and octal). c c data small(1), small(2) / 128, 0 / c data small(3), small(4) / 0, 0 / c data large(1), large(2) / 32767, -1 / c data large(3), large(4) / -1, -1 / c data right(1), right(2) / 9344, 0 / c data right(3), right(4) / 0, 0 / c data diver(1), diver(2) / 9472, 0 / c data diver(3), diver(4) / 0, 0 / c data log10(1), log10(2) / 16282, 8346 / c data log10(3), log10(4) / -31493, -12296 / c c data small(1), small(2) / o000200, o000000 / c data small(3), small(4) / o000000, o000000 / c data large(1), large(2) / o077777, o177777 / c data large(3), large(4) / o177777, o177777 / c data right(1), right(2) / o022200, o000000 / c data right(3), right(4) / o000000, o000000 / c data diver(1), diver(2) / o022400, o000000 / c data diver(3), diver(4) / o000000, o000000 / c data log10(1), log10(2) / o037632, o020232 / c data log10(3), log10(4) / o102373, o147770 / c c machine constants for the silicon graphics c c data small(1), small(2) / z'00100000', z'00000000' / c data large(1), large(2) / z'7fefffff', z'ffffffff' / c data right(1), right(2) / z'3ca00000', z'00000000' / c data diver(1), diver(2) / z'3cb00000', z'00000000' / c data log10(1), log10(2) / z'3fd34413', z'509f79ff' / c c machine constants for the sun c c data dmach(1) / z'0010000000000000' / c data dmach(2) / z'7fefffffffffffff' / c data dmach(3) / z'3ca0000000000000' / c data dmach(4) / z'3cb0000000000000' / c data dmach(5) / z'3fd34413509f79ff' / c c machine constants for the sun c using the -r8 compiler option c c data dmach(1) / z'00010000000000000000000000000000' / c data dmach(2) / z'7ffeffffffffffffffffffffffffffff' / c data dmach(3) / z'3f8e0000000000000000000000000000' / c data dmach(4) / z'3f8f0000000000000000000000000000' / c data dmach(5) / z'3ffd34413509f79fef311f12b35816f9' / c c machine constants for the sun 386i c c data small(1), small(2) / z'fffffffd', z'000fffff' / c data large(1), large(2) / z'ffffffb0', z'7fefffff' / c data right(1), right(2) / z'000000b0', z'3ca00000' / c data diver(1), diver(2) / z'ffffffcb', z'3cafffff' c data log10(1), log10(2) / z'509f79e9', z'3fd34413' / c c machine constants for the univac 1100 series ftn compiler c c data small(1), small(2) / o000040000000, o000000000000 / c data large(1), large(2) / o377777777777, o777777777777 / c data right(1), right(2) / o170540000000, o000000000000 / c data diver(1), diver(2) / o170640000000, o000000000000 / c data log10(1), log10(2) / o177746420232, o411757177572 / c if (i .lt. 1 .or. i .gt. 5) call error('d1mach', + 'i out of bounds',' ') c d1mach = dmach(i) return c end *else c real function s1mach (i) c ****************************************************************** c return floating point machine dependent constants. c used by slatec library routines. c c s1mach can be used to obtain machine-dependent parameters for the c local machine environment. it is a function subprogram with one c (input) argument, and can be referenced as follows: c c a = s1mach(i) c c where i=1,...,5. the (output) value of a above is determined by c the (input) value of i. the results for various values of i are c discussed below. c c s1mach(1) = b**(emin-1), the smallest positive magnitude. c s1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. c s1mach(3) = b**(-t), the smallest relative spacing. c s1mach(4) = b**(1-t), the largest relative spacing. c s1mach(5) = log10(b) c c assume single precision numbers are represented in the t-digit, c base-b form c c sign (b**e)*( (x(1)/b) + ... + (x(t)/b**t) ) c c where 0 .le. x(i) .lt. b for i=1,...,t, 0 .lt. x(1), and c emin .le. e .le. emax. c c the values of b, t, emin and emax are provided in i1mach as c follows: c c i1mach(10) = b, the base. c i1mach(11) = t, the number of base-b digits. c i1mach(12) = emin, the smallest exponent e. c i1mach(13) = emax, the largest exponent e. c c to alter this function for a particular environment, the desired c set of data statements should be activated by removing the c from c column 1. also, the values of s1mach(1) - s1mach(4) should be c checked for consistency with the local operating system. c ****************************************************************** integer small(2) integer large(2) integer right(2) integer diver(2) integer log10(2) c real rmach(5) save rmach c equivalence (rmach(1),small(1)) equivalence (rmach(2),large(1)) equivalence (rmach(3),right(1)) equivalence (rmach(4),diver(1)) equivalence (rmach(5),log10(1)) c c machine constants for the amiga c absoft fortran compiler using the 68020/68881 compiler option c c data small(1) / z'00800000' / c data large(1) / z'7f7fffff' / c data right(1) / z'33800000' / c data diver(1) / z'34000000' / c data log10(1) / z'3e9a209b' / c c machine constants for the amiga c absoft fortran compiler using software floating point c c data small(1) / z'00800000' / c data large(1) / z'7effffff' / c data right(1) / z'33800000' / c data diver(1) / z'34000000' / c data log10(1) / z'3e9a209b' / c c machine constants for the apollo c c data small(1) / 16#00800000 / c data large(1) / 16#7fffffff / c data right(1) / 16#33800000 / c data diver(1) / 16#34000000 / c data log10(1) / 16#3e9a209b / c c machine constants for the burroughs 1700 system c c data rmach(1) / z400800000 / c data rmach(2) / z5ffffffff / c data rmach(3) / z4e9800000 / c data rmach(4) / z4ea800000 / c data rmach(5) / z500e730e8 / c c machine constants for the burroughs 5700/6700/7700 systems c c data rmach(1) / o1771000000000000 / c data rmach(2) / o0777777777777777 / c data rmach(3) / o1311000000000000 / c data rmach(4) / o1301000000000000 / c data rmach(5) / o1157163034761675 / c c machine constants for the cdc 170/180 series using nos/ve c c data rmach(1) / z"3001800000000000" / c data rmach(2) / z"4ffefffffffffffe" / c data rmach(3) / z"3fd2800000000000" / c data rmach(4) / z"3fd3800000000000" / c data rmach(5) / z"3fff9a209a84fbcf" / c c machine constants for the cdc 6000/7000 series c c data rmach(1) / 00564000000000000000b / c data rmach(2) / 37767777777777777776b / c data rmach(3) / 16414000000000000000b / c data rmach(4) / 16424000000000000000b / c data rmach(5) / 17164642023241175720b / c c machine constants for the celerity c1260 c c data small(1) / z'00800000' / c data large(1) / z'7f7fffff' / c data right(1) / z'33800000' / c data diver(1) / z'34000000' / c data log10(1) / z'3e9a209b' / c c machine constants for the convex c using the -fn compiler option c c data rmach(1) / z'00800000' / c data rmach(2) / z'7fffffff' / c data rmach(3) / z'34800000' / c data rmach(4) / z'35000000' / c data rmach(5) / z'3f9a209b' / c c machine constants for the convex c using the -fi compiler option c c data rmach(1) / z'00800000' / c data rmach(2) / z'7f7fffff' / c data rmach(3) / z'33800000' / c data rmach(4) / z'34000000' / c data rmach(5) / z'3e9a209b' / c c machine constants for the convex c using the -p8 or -pd8 compiler option c c data rmach(1) / z'0010000000000000' / c data rmach(2) / z'7fffffffffffffff' / c data rmach(3) / z'3cc0000000000000' / c data rmach(4) / z'3cd0000000000000' / c data rmach(5) / z'3ff34413509f79ff' / c c machine constants for the cray c c data rmach(1) / 200034000000000000000b / c data rmach(2) / 577767777777777777776b / c data rmach(3) / 377224000000000000000b / c data rmach(4) / 377234000000000000000b / c data rmach(5) / 377774642023241175720b / c c machine constants for the data general eclipse s/200 c note - it may be appropriate to include the following card - c static rmach(5) c c data small / 20k, 0 / c data large / 77777k, 177777k / c data right / 35420k, 0 / c data diver / 36020k, 0 / c data log10 / 40423k, 42023k / c c machine constants for the dec alpha c using g_float c c data rmach(1) / '00000080'x / c data rmach(2) / 'ffff7fff'x / c data rmach(3) / '00003480'x / c data rmach(4) / '00003500'x / c data rmach(5) / '209b3f9a'x / c c machine constants for the dec alpha c using ieee_float c c data rmach(1) / '00800000'x / c data rmach(2) / '7f7fffff'x / c data rmach(3) / '33800000'x / c data rmach(4) / '34000000'x / c data rmach(5) / '3e9a209b'x / c c machine constants for the dec risc c c data rmach(1) / z'00800000' / c data rmach(2) / z'7f7fffff' / c data rmach(3) / z'33800000' / c data rmach(4) / z'34000000' / c data rmach(5) / z'3e9a209b' / c c machine constants for the dec vax c (expressed in integer and hexadecimal) c the hex format below may not be suitable for unix systems c the integer format should be ok for unix systems c c data small(1) / 128 / c data large(1) / -32769 / c data right(1) / 13440 / c data diver(1) / 13568 / c data log10(1) / 547045274 / c c data small(1) / z00000080 / c data large(1) / zffff7fff / c data right(1) / z00003480 / c data diver(1) / z00003500 / c data log10(1) / z209b3f9a / c c machine constants for the elxsi 6400 c (assuming real*4 is the default real) c c data small(1) / '00800000'x / c data large(1) / '7f7fffff'x / c data right(1) / '33800000'x / c data diver(1) / '34000000'x / c data log10(1) / '3e9a209b'x / c c machine constants for the harris 220 c c data small(1), small(2) / '20000000, '00000201 / c data large(1), large(2) / '37777777, '00000177 / c data right(1), right(2) / '20000000, '00000352 / c data diver(1), diver(2) / '20000000, '00000353 / c data log10(1), log10(2) / '23210115, '00000377 / c c machine constants for the honeywell 600/6000 series c c data rmach(1) / o402400000000 / c data rmach(2) / o376777777777 / c data rmach(3) / o714400000000 / c data rmach(4) / o716400000000 / c data rmach(5) / o776464202324 / c c machine constants for the hp 730 c c data rmach(1) / z'00800000' / c data rmach(2) / z'7f7fffff' / c data rmach(3) / z'33800000' / c data rmach(4) / z'34000000' / c data rmach(5) / z'3e9a209b' / c c machine constants for the hp 2100 c 3 word double precision with ftn4 c c data small(1), small(2) / 40000b, 1 / c data large(1), large(2) / 77777b, 177776b / c data right(1), right(2) / 40000b, 325b / c data diver(1), diver(2) / 40000b, 327b / c data log10(1), log10(2) / 46420b, 46777b / c c machine constants for the hp 2100 c 4 word double precision with ftn4 c c data small(1), small(2) / 40000b, 1 / c data large(1), large(2) / 77777b, 177776b / c data right(1), right(2) / 40000b, 325b / c data diver(1), diver(2) / 40000b, 327b / c data log10(1), log10(2) / 46420b, 46777b / c c machine constants for the hp 9000 c c data small(1) / 00004000000b / c data large(1) / 17677777777b / c data right(1) / 06340000000b / c data diver(1) / 06400000000b / c data log10(1) / 07646420233b / c c machine constants for the ibm 360/370 series, c the xerox sigma 5/7/9, the sel systems 85/86 and c the perkin elmer (interdata) 7/32. c c data rmach(1) / z00100000 / c data rmach(2) / z7fffffff / c data rmach(3) / z3b100000 / c data rmach(4) / z3c100000 / c data rmach(5) / z41134413 / c c machine constants for the ibm pc c c data small(1) / 1.18e-38 / c data large(1) / 3.40e+38 / c data right(1) / 0.595e-07 / c data diver(1) / 1.19e-07 / c data log10(1) / 0.30102999566 / c c machine constants for the ibm rs 6000 c c data rmach(1) / z'00800000' / c data rmach(2) / z'7f7fffff' / c data rmach(3) / z'33800000' / c data rmach(4) / z'34000000' / c data rmach(5) / z'3e9a209b' / c c machine constants for the intel i860 c c data rmach(1) / z'00800000' / c data rmach(2) / z'7f7fffff' / c data rmach(3) / z'33800000' / c data rmach(4) / z'34000000' / c data rmach(5) / z'3e9a209b' / c c machine constants for the pdp-10 (ka or ki processor) c c data rmach(1) / "000400000000 / c data rmach(2) / "377777777777 / c data rmach(3) / "146400000000 / c data rmach(4) / "147400000000 / c data rmach(5) / "177464202324 / c c machine constants for pdp-11 fortran supporting c 32-bit integers (expressed in integer and octal). c c data small(1) / 8388608 / c data large(1) / 2147483647 / c data right(1) / 880803840 / c data diver(1) / 889192448 / c data log10(1) / 1067065499 / c c data rmach(1) / o00040000000 / c data rmach(2) / o17777777777 / c data rmach(3) / o06440000000 / c data rmach(4) / o06500000000 / c data rmach(5) / o07746420233 / c c machine constants for pdp-11 fortran supporting c 16-bit integers (expressed in integer and octal). c c data small(1), small(2) / 128, 0 / c data large(1), large(2) / 32767, -1 / c data right(1), right(2) / 13440, 0 / c data diver(1), diver(2) / 13568, 0 / c data log10(1), log10(2) / 16282, 8347 / c c data small(1), small(2) / o000200, o000000 / c data large(1), large(2) / o077777, o177777 / c data right(1), right(2) / o032200, o000000 / c data diver(1), diver(2) / o032400, o000000 / c data log10(1), log10(2) / o037632, o020233 / c c machine constants for the silicon graphics c c data rmach(1) / z'00800000' / c data rmach(2) / z'7f7fffff' / c data rmach(3) / z'33800000' / c data rmach(4) / z'34000000' / c data rmach(5) / z'3e9a209b' / c c machine constants for the sun c c data rmach(1) / z'00800000' / c data rmach(2) / z'7f7fffff' / c data rmach(3) / z'33800000' / c data rmach(4) / z'34000000' / c data rmach(5) / z'3e9a209b' / c c machine constants for the sun c using the -r8 compiler option c c data rmach(1) / z'0010000000000000' / c data rmach(2) / z'7fefffffffffffff' / c data rmach(3) / z'3ca0000000000000' / c data rmach(4) / z'3cb0000000000000' / c data rmach(5) / z'3fd34413509f79ff' / c c machine constants for the univac 1100 series c c data rmach(1) / o000400000000 / c data rmach(2) / o377777777777 / c data rmach(3) / o146400000000 / c data rmach(4) / o147400000000 / c data rmach(5) / o177464202324 / c c machine constants for the z80 microprocessor c c data small(1), small(2) / 0, 256/ c data large(1), large(2) / -1, -129/ c data right(1), right(2) / 0, 26880/ c data diver(1), diver(2) / 0, 27136/ c data log10(1), log10(2) / 8347, 32538/ c if (i .lt. 1 .or. i .gt. 5) call error('s1mach', + 'i out of bounds',' ') c s1mach = rmach(i) return c end *endif c ------------------------------------------------------------------ c end of slatec routines c function rann(r) c ****************************************************************** c random number generator. c r=0. for next number, other values set the seed. c random number generators tend to be machine dependent. c ****************************************************************** k=nint(r) rann=rand(k) return end c *ident up87 */ viewr -- 15jul97 -- fix problem with right-hand log axes (kapl) *d viewr.2100,2112 fvy=origen dvy=cycles logy=1 ymin=yo ymax=yo+asize */ viewr -- 15jul97 -- clean up unused variables *d viewr.289,290 *d viewr.292 *d viewr.612 call closz(infile) *ident up88 */ plotr -- 15jul97 -- fix right-hand axis option (barnett, kapl) */ and uninitialized variable *i plotr.488 rstep=z(3) *d plotr.1576 if (iabs(iplot).gt.1) go to 611 *ident up89 */ acer -- 15jul97 -- fix photon reaction list (kosako, sumitomo) *d acer.6822 2 xss(loct+1),xss(loct+n),xss(loc1+10),nint(xss(loc1+9)) *ident up90 */ broadr -- 27jul97 -- compute and write out various thermal */ integrals, thermal cross sections, and */ resonance integrals when broadening to */ the first temperature. note that it was */ necessary to include the endf tape in */ the input instructions to get nubar. *i broadr.26 c * * c * while doing the first temperature, broadr computes a number * c * of thermal quantities and resonance integrals. values for * c * both 0.0253 ev and the first temperature in ev (tev) are * c * printed out. integrals are calculated at tev only. * *i broadr.34 c * nendf input endf tape (for thermal nubar only) * *i broadr.103 data bk/8.61735e-5/ *d broadr.124,125 if (ntty.gt.0) write(ntty,'(/'' enter nendf, nin, nout.'')') nz=3 *d broadr.127,128 nendf=nint(z(1)) nin=nint(z(2)) nout=nint(z(3)) *i broadr.134 call openz(nendf,0) *d broadr.168,169 write(nsyso,30) nendf,nin,nout,mat1,ntemp2,istart,istrap, 1 temp1,errthn,thnmx,errmax,errint *i broadr.177 c c ***search input endf tape for mf1/mt452, total nubar call repoz(nendf) call tpidio(nendf,0,0,a(iscr),nb,nw) call findf(mat1,1,0,nendf) inutot=0 lnu=0 101 call contio(nendf,0,0,a(iscr),nb,nw) if (mfh.ne.1) go to 107 if (mth.ne.452) go to 106 lnu=l2h if (lnu.eq.2) go to 103 call listio(nendf,0,0,a(iscr),nb,nw) nw=6+n1h call reserv('nutot',nw,inutot,a) do 102 i=1,nw 102 a(inutot+i-1)=a(iscr+i-1) go to 107 103 call tab1io(nendf,0,0,a(iscr),nb,nw) nw=6+2*n1h+2*n2h call reserv('nutot',nw,inutot,a) l1=inutot 104 do 105 i=1,nw 105 a(l1+i-1)=a(iscr+i-1) if (nb.eq.0) go to 107 l1=l1+nw call moreio(nendf,0,0,a(iscr),nb,nw) go to 104 106 call tosend(nendf,0,0,a(iscr)) go to 101 107 continue *i broadr.373 c c ***write out thermal quantities for first temperature eone=0.5 etwo=2.e7 tev=tempk*bk if (it.gt.1) go to 2250 write(nsyso,'(/'' thermal quantities at'',f6.1,'' K ='', 1 f7.4,'' eV''/ 2 '' -----------------------------------------'')') 3 tempk,tev llf=0 llc=0 do 2241 j=1,nreac if (mtr(j).eq.18) llf=j+1 if (mtr(j).eq.102) llc=j+1 2241 continue fint=0. cint=0. alint=0. etint=0. v1int=0. ssf=0. slf=0. ssc=0. slc=0. elast=0. j=0 2242 j=j+1 call finda(j,tt,ntx,inew,a(ibufn),nbuf) enow=tt(1) c thermal cross sections at 0.0253 ev if (elast.lt.0.0253.and.enow.ge.0.0253) then if (llf.gt.0) then ss=slf+(0.0253-elast)*(tt(llf)-slf)/(enow-elast) write(nsyso,'( 1 '' fission xsec at 0.0253:'',1p,e12.4)') ss if (lnu.eq.1) then fnu=a(inutot+6) else ir=1 ip=2 call terpa(fnu,0.0253,xnext,idis,a(inutot),ip,ir) endif write(nsyso,'( 1 '' fission nubar at 0.0253:'',1p,e12.4)') fnu endif if (llc.gt.0) then ss=slc+(0.0253-elast)*(tt(llc)-slc)/(enow-elast) write(nsyso,'( 1 '' capture xsec at 0.0253:'',1p,e12.4)') ss endif endif c thermal cross sections at tev if (elast.lt.tev.and.enow.ge.tev) then if (llf.gt.0) then ss=slf+(tev-elast)*(tt(llf)-slf)/(enow-elast) ftev=ss write(nsyso,'( 1 '' fission xsec at tev:'',1p,e12.4)') ss if (lnu.eq.1) then fnu=a(inutot+6) else ir=1 ip=2 call terpa(fnu,tev,xnext,idis,a(inutot),ip,ir) endif write(nsyso,'( 1 '' fission nubar at tev:'',1p,e12.4)') fnu endif if (llc.gt.0) then ss=slc+(tev-elast)*(tt(llc)-slc)/(enow-elast) ctev=ss write(nsyso,'( 1 '' capture xsec at tev:'',1p,e12.4)') ss endif endif c fission nubar at this energy fnu=0. if (llf.gt.0) then if (lnu.eq.1) then fnu=a(inutot+6) else ir=1 ip=2 call terpa(fnu,enow,xnext,idis,a(inutot),ip,ir) endif endif c thermal integrals if (enow.lt.10.0) then if (llc.gt.0) then fnow=enow*exp(-enow/tev) if (j.gt.1) then cint=cint+0.5*(fnow*tt(llc)+flast*slc)*(enow-elast) endif flast=fnow endif if (llf.gt.0) then fnow=enow*exp(-enow/tev) if (j.gt.1) then fint=fint+0.5*(fnow*tt(llf)+flast*slf)*(enow-elast) alint=alint+0.5*(fnow*tt(llc)/tt(llf)+flast*slc/slf) 1 *(enow-elast) etint=etint+0.5*(fnow*fnu*tt(llf)/(tt(llf)+tt(llc)) 1 +flast*fnul*slf/(slf+slc))*(enow-elast) v1int=v1int+0.5*(fnow*(fnu*tt(llf)-tt(llf)-tt(llc)) 1 +flast*(fnul*slf-slf-slc))*(enow-elast) endif flast=fnow endif endif c resonance integrals if (elast.lt.eone.and.enow.ge.eone) then if (llf.gt.0) then ss=slf+(eone-elast)*(tt(llf)-slf)/(enow-elast) ssf=0.5*(tt(llf)/enow+ss/elast)*(enow-eone) endif if (llc.gt.0) then ss=slc+(eone-elast)*(tt(llc)-slc)/(enow-elast) ssc=0.5*(tt(llc)/enow+ss/elast)*(enow-eone) endif endif if (elast.ge.eone) then if (llf.gt.0) ssf=ssf+0.5*(tt(llf)/enow+slf/elast) 1 *(enow-elast) if (llc.gt.0) ssc=ssc+0.5*(tt(llc)/enow+slc/elast) 1 *(enow-elast) endif c continue the energy loop elast=enow fnul=fnu if (llf.gt.0) slf=tt(llf) if (llc.gt.0) slc=tt(llc) if (j.ge.n2out) go to 2243 go to 2242 c print out the results 2243 cint=cint/tev**2 write(nsyso,'( 1 '' thermal capture integral:'',1p,e12.4)') cint write(nsyso,'( 1 '' thermal capture g-factor:'',1p,e12.4)') 2 1.12838*cint/ctev write(nsyso,'( 1 '' capture resonance integral:'',1p,e12.4)') ssc if (llf.gt.0) then fint=fint/tev**2 alint=alint/tev**2 etint=etint/tev**2 v1int=v1int/tev**2 write(nsyso,'( 1 '' thermal fission integral:'',1p,e12.4)') fint write(nsyso,'( 1 '' thermal fission g-factor:'',1p,e12.4)') 2 1.12838*fint/ftev write(nsyso,'( 1 '' thermal alpha integral:'',1p,e12.4)') alint write(nsyso,'( 1 '' thermal eta integral:'',1p,e12.4)') etint write(nsyso,'( 1 '' thermal k1 integral:'',1p,e12.4)') v1int write(nsyso,'( 1 '' fission resonance integral:'',1p,e12.4)') ssf endif write(nsyso, 1 '('' -----------------------------------------'')') 2250 continue *i broadr.503 call closz(nendf) *d broadr.516 30 format(/40h unit for input endf tape ............. ,i10/ x 40h unit for input pendf tape ............ ,i10/ */ broadr -- 27jul97 -- make sure to save needed variables *i broadr.782 save ks,es,js,ss,tt,sn,dl *ident up91 */ groupr -- 27jul97 -- allow particle production matrices to be */ computed when the reactions are given as */ charged-particle discrete levels fully */ described using mf4/mt600-850 (or 700-799), */ and not by mf6. proposed by trkov. */ fix some other problems with auto loops. *d up4.9 dimension ir(64),ip(7),i2(17) *d groupr.955 character*8 n2(17) *d groupr.958,960 data i2/16,17,18,6,8,21,22,23,24,25,26,31,32,33,34,35,36/ data n2/'gamma','gamma','gamma','neutron','neutron', 1 'proton','deuteron','triton','he3','alpha','recoil', 2 'proton','deuteron','triton','he3','alpha','recoil'/ *d up4.20 data nreac/64/,npart/17/,nproj/7/ *i groupr.3399 common/util/npage,iverf character*40 com *d groupr.3423 1 (mtd.ge.51.and.mtd.lt.91)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.lt.6.and. 1 (mtd.ge.700.and.mtd.lt.719)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.lt.6.and. 1 (mtd.ge.720.and.mtd.lt.739)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.lt.6.and. 1 (mtd.ge.740.and.mtd.lt.759)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.lt.6.and. 1 (mtd.ge.760.and.mtd.lt.779)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.lt.6.and. 1 (mtd.ge.780.and.mtd.lt.799)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.ge.6.and. 1 (mtd.ge.600.and.mtd.lt.649)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.ge.6.and. 1 (mtd.ge.650.and.mtd.lt.699)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.ge.6.and. 1 (mtd.ge.700.and.mtd.lt.749)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.ge.6.and. 1 (mtd.ge.750.and.mtd.lt.799)) go to 400 if (mfd.ge.31.and.mfd.le.36.and.iverf.ge.6.and. 1 (mtd.ge.800.and.mtd.lt.849)) go to 400 *d groupr.3424 write(com,'(''do not know how to handle mf,mt: '', 1 i2,'','',i3)') mfd,mtd call error('getff',com,' ') *d groupr.6376 if (mth.eq.2.or.(mth.ge.50.and.mth.lt.91)) za2=1. *d groupr.6378,6382 if (mth.ge.700.and.mth.lt.719) za2=1001. if (mth.ge.720.and.mth.lt.739) za2=1002. if (mth.ge.740.and.mth.lt.759) za2=1003. if (mth.ge.760.and.mth.lt.779) za2=2003. if (mth.ge.780.and.mth.lt.799) za2=2004. *d groupr.6384,6388 313 if (mth.ge.600.and.mth.lt.649) za2=1001. if (mth.ge.650.and.mth.lt.699) za2=1002. if (mth.ge.700.and.mth.lt.749) za2=1003. if (mth.ge.750.and.mth.lt.799) za2=2003. if (mth.ge.800.and.mth.lt.849) za2=2004. *d groupr.6395 call mess('conver',strng,'only mf4/mf5 provided') go to 119 *d groupr.6397 izat=nint(c1h) jza2=nint(za2) jzar=izat+izap-jza2 *d groupr.6399 if (jza2.ne.1001) go to 835 *d groupr.6405 go to 855 *d groupr.6408 go to 855 *d groupr.6409 835 if (jza2.ne.1002) go to 840 *d groupr.6415 go to 855 *d groupr.6418 go to 855 *d groupr.6419 840 if (jza2.ne.1003) go to 845 *d groupr.6425 go to 855 *d groupr.6428 go to 855 *d groupr.6429 845 if (jza2.ne.2003) go to 850 *d groupr.6435 go to 855 *d groupr.6438 go to 855 *d groupr.6439 850 if (jza2.ne.2004) go to 855 *d groupr.6445 go to 855 *d groupr.6448 *d groupr.6449 855 if (jzar.le.2004) go to 119 */ groupr -- 27jul97 -- be careful of comparisons at bragg edges *d groupr.5843 if (e.lt..999999*ebrag) go to 630 */ groupr -- 27jul97 -- remove unused variable *d groupr.3828 */ groupr -- 27jul97 -- be careful to save needed variables *d groupr.2584 save enext,elast,flst,slst *d groupr.2964 save ip,lbuf,alo,ahi *d groupr.3106 save lfs,mt,nsig *d groupr.3402 save ifirst,nyl,nfl,igmin *d groupr.3832 save idis,iyss,izss,jjss,jloss,nss *d groupr.5421 save elo,ehi,nlo,nhi,flo,fhi *i groupr.5566 save iaes,nwmax *d groupr.5871 save li,iloca *d groupr.6192 save awr,loca *d groupr.7225 */ groupr -- 27jul97 -- fix a special case that can lead to */ uninitialized values of sig. *d groupr.3171 en=enext if (nz.eq.1) go to 310 call getunr(mtt,e,en,sig(1,il),a) 310 continue *ident up92 */ gaspr -- 28jul97 -- flag be-8 residuals to turn into two alphas. */ this is to fix the alpha production for */ be9(n,2n) in endf. a more general solution */ that carefully looks for differences between */ the gases implied by the mt number and what */ is given explicitly in mf6 would be desireable. *i up14.227 if (izr.eq.4008) izg=1 *i up14.441 if (izr.eq.4008) y207=y207+2. *ident up93 */ purr -- 28jul97 -- put the missing sort and search routines */ into purr. simple-minded coding. */ move the random numer routine to njoy */ since they tend to be machine dependent. *i purr.435 call closz(-nscr) *d purr.2114 c do 120 k=1,n-1 do 110 j=k+1,n if (x(k).le.x(j)) go to 110 xt=x(k) yt=y(k) x(k)=x(j) y(k)=y(j) x(j)=xt y(j)=yt 110 continue 120 continue *d purr.2121 c search the xarray for x.ge.xarray(i) and x.lt.xarray(i+1) c return i=1 and k=2 if x is below the lower limit. c return i=n and k=3 if x is above the upper limit. *d purr.2124 c if (x.lt.xarray(1)) go to 140 if (x.gt.xarray(n)) go to 150 i1=1 i2=n 110 if (i1+1.eq.i2) go to 130 if (x.lt.xarray((i1+i2)/2)) go to 120 i1=(i1+i2)/2 go to 110 120 i2=(i1+i2)/2 go to 110 130 i=i1 k=1 return 140 i=1 k=2 return 150 i=n k=3 *d purr.2127,2136 */purr -- 28jul97 -- fix limit tests on the variances *d purr.1740 if (abs(argt).lt.0.) argt=0. *d purr.1743 if (abs(arge).lt.0.) arge=0. *d purr.1746 if (abs(argf).lt.0.) argf=0. *d purr.1749 if (abs(argc).lt.0.) argc=0. */ purr -- 28jul97 -- check for competitive reaction */ assume that it is mt=51 for now *i purr.189 icomp=0 *i purr.200 sigx=bkgz(1)-bkgz(2)-bkgz(3)-bkgz(4) if (sigx.lt.1.e-5) sigx=0. if (sigx.gt.0.) icomp=1 *i purr.374 c assume competitive reaction is mt=51 for now if (icomp.ne.0) a(n+9)=51 *d purr.1330,1331 sigx=bkg(1)-bkg(2)-bkg(3)-bkg(4) if (iprint.gt.0) write(nsyso,'(/,1p,''e='',e11.4, 1 3x,''spot='',e11.4,3x,''dbar='',e11.4,3x,''sigx='',e11.4/ *d purr.1333 3 ''capture'',8x,''time'')') e,spot,dbart,sigx */ purr -- 28jul97 -- increase the scratch space *d purr.84 maxscr=10000 */ purr -- 28jul97 -- fix some problems with the directory *d purr.233 if (nx.gt.0.and.new152.gt.0) a(iscr+5)=a(iscr+5)+1. if (nx.gt.0.and.new153.gt.0) a(iscr+5)=a(iscr+5)+1. *d purr.257 ncds=2+(ncds-1)/6 *ident up94 */ acer -- 28jul97 -- add unresolved tables to ace files by reading */ the special section mt=153 added by purr. *d acer.1150 *d acer.1163 300 call afend(nout,0) *d acer.4547 1 gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, 2 iurpt,jxsd(9) *i acer.4599 nurd=0 iurd=0 iurpt=0 *d acer.4603 if (kfis.eq.0) go to 155 *d acer.4666 155 call findf(matd,2,0,nin) 156 call contio(nin,0,0,a(iscr),nb,nw) *d acer.4670 go to 156 *d acer.4672 write(nsyso,'(/'' found mt=153 with unresolved-range'', 1 '' probability tables'')') call listio(nin,0,0,a(iscr),nb,nw) nurd=n1h+6 call reserv('urd',nurd,iurd,a) i1=1 161 do 162 i=1,nw 162 a(iurd-1+i1-1+i)=a(iscr-1+i) if (nb.eq.0) go to 163 i1=i1+nw call moreio(nin,0,0,a(iscr),nb,nw) go to 161 163 continue call tosend(nin,0,0,a(iscr)) go to 156 *i acer.5695 c c ***store unresolved-range probability tables c ***after energy distributions and before gamma data 600 if (nurd.eq.0) go to 604 iurpt=next nure=nint(a(iurd+5)) xss(next)=nure nurb=nint(a(iurd+4)) nurb=(nurb/nure-1)/5 mtxx=nint(a(iurd+3)) xss(next+1)=nurb xss(next+2)=2 xss(next+3)=mtxx xss(next+4)=0 xss(next+5)=1 next=next+6 do 602 ie=1,nure jj=iurd+6+(ie-1)*(1+5*nurb) xss(next-1+ie)=sigfig(a(jj),ndigit,0)*1.e-6 ll=next-1+nure+(ie-1)*6*nurb do 601 ib=1,nurb if (ib.eq.1) xss(ll+ib)=a(jj+ib) if (ib.gt.1) xss(ll+ib)=xss(ll+ib-1)+a(jj+ib) xss(ll+nurb+ib)=a(jj+nurb+ib) xss(ll+2*nurb+ib)=a(jj+2*nurb+ib) xss(ll+3*nurb+ib)=a(jj+3*nurb+ib) xss(ll+4*nurb+ib)=a(jj+4*nurb+ib) xss(ll+5*nurb+ib)=1. 601 continue 602 continue next=next+nure*(1+6*nurb) *d acer.5698 604 if (mf1x(1).eq.0.and.mf1x(2).eq.0) go to 635 *d acer.6240 1 gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, 2 iurpt,jxsd(9) *d acer.6262 1 (jxs(i),i=1,23),hk *d acer.6302,6305 *i acer.6758 c c ***print unresolved-range probability tables if (iurpt.eq.0) go to 399 write(nsyso,'(1h1/'' unresolved-range probability tables''/ 1 '' -----------------------------------'')') nure=nint(xss(iurpt)) nurb=nint(xss(iurpt+1)) lurt=nint(xss(iurpt+2)) luri=nint(xss(iurpt+3)) lura=nint(xss(iurpt+4)) lurf=nint(xss(iurpt+5)) write(nsyso,'(/'' number of energies: '',i6/ 1 '' number of bins: '',i6/ 2 '' interpolation law: '',i6/ 3 '' inelastic reaction: '',i6/ 4 '' absorption reaction:'',i6)') 5 nure,nurb,lurt,luri,lura if (lurf.eq.0) write(nsyso,'( 1 '' tables are cross sections'')') if (lurf.eq.1) write(nsyso,'( 1 '' tables are factors'')') do 398 ie=1,nure write(nsyso,'(/'' energy='',1p,e12.4)') xss(iurpt+5+ie) write(nsyso,'('' bin prob tot elas'', 1 '' fiss capt heat''/ 2 '' --- ------ ---------- ----------'', 3 '' ----------- ---------- ----------'')') do 397 ib=1,nurb ll=iurpt+5+nure+(ie-1)*6*nurb write(nsyso,'(i6,f9.4,1p,5e12.4)') ib,xss(ll+ib), 2 xss(ll+nurb+ib),xss(ll+2*nurb+ib),xss(ll+3*nurb+ib), 3 xss(ll+4*nurb+ib),xss(ll+5*nurb+ib) 397 continue 398 continue *d acer.6759 399 if (gpd.eq.0.or.negn.eq.0) go to 405 *d acer.7016 h 40x,2hyp,i10/39x,3hfis,i10/39x,3hend,i10/ i 37x,5hiurpt,i10///6x,5hhk---,a70) *d acer.7523 1 gpd,mtrp,lsigp,sigp,landp,andp,ldlwp,dlwp,yp,fis,end, 2 iurpt,jxsd(9) *i acer.7985 c c ***unresolved-range probability-table block if (iurpt.eq.0) go to 433 l=iurpt if (nout.ne.1) nure=nint(xss(l)) if (nout.eq.1) nure=iss(l) call typen(l,nout,1) l=l+1 if (nout.ne.1) nurb=nint(xss(l)) if (nout.eq.1) nurb=iss(l) call typen(l,nout,1) l=l+1 if (nout.ne.1) lurt=nint(xss(l)) if (nout.eq.1) lurt=iss(l) call typen(l,nout,1) l=l+1 if (nout.ne.1) luri=nint(xss(l)) if (nout.eq.1) luri=iss(l) call typen(l,nout,1) l=l+1 if (nout.ne.1) lura=nint(xss(l)) if (nout.eq.1) lura=iss(l) call typen(l,nout,1) l=l+1 if (nout.ne.1) lurf=nint(xss(l)) if (nout.eq.1) lurf=iss(l) call typen(l,nout,1) l=l+1 n=nure*(1+6*nurb) do 432 i=1,n call typen(l,nout,2) l=l+1 432 continue 433 continue */ acer -- 28jul97 -- minor fixes and unused variables *d acer.6214 *i acer.6229 c *d acer.3392 *d acer.8771 dimension ind(4),b(4),c(4) *d acer.9760 *d acer.9954 *d acer.9959,9960 *d acer.10240 *d acer.10246 *i acer.11290 if (zmax.le.0.) go to 890 */ acer -- 28jul97 -- increase storage to allow for unresolved *d acer.188 data namax/30000/, nidmax/27/ *d acer.180 common/astore/a(30000) *d acer.468 common/astore/a(30000) *d acer.4556 common/astore/a(30000) *d acer.6249 common/astore/a(30000) *d acer.8336 common/astore/a(30000) *d acer.8652 common/astore/a(30000) *d acer.9033 common/astore/a(30000) *d acer.9320 common/astore/a(30000) */ acer -- 28jul97 -- fix bad parameter lists in calls *d acer.645,646 call tofend(nine,noute,0,a(iscr)) call tofend(nine,noute,0,a(iscr)) *d acer.713 call tofend(nine,noute,0,a(iscr)) *d acer.924,925 call tofend(ninp,noutp,0,a(iscr)) call tofend(ninp,noutp,0,a(iscr)) */ acer -- 30jul97 -- remove some obsolete coding that causes */ trouble due to unset variables. *d acer.3032,3037 *ident up95 */ moder -- 28jul97 -- allow moder to process mf2/mt153 from purr */ for unresolved-range probability tables *d moder.531,532 c ***special point-unresolved and probability-table formats 200 if (mt.ne.152.and.mt.ne.153) 1 call error('file2','illegal mt.',' ') *ident up96 */ dtfr -- 28jul97 -- use real variables for all hollerith quantities. */ many workstations do integer arithemetic only */ with 32 bits, which leads to problems when */ integer hollrith fields are used with compiler */ options like "-r8". *d dtfr.88 real*8 hednam,hisnam,hz *d dtfr.95 common/dtf2/hednam(53),nedmax,jped(53),mted(53),multed(53),ids(53) *d dtfr.501 real*8 hednam,hmtid,hblank,hword,hnabs,hnusf,hntotl,hz *d dtfr.507 common/dtf2/hednam(53),nedmax,jped(53),mted(53),multed(53),ids(53) *d dtfr.511,513 dimension hmtid(50),kmted(50),kjped(50),kmultd(50) dimension z(50) dimension hz(1) equivalence (hz(1),z(1)) *d dtfr.514,515 data hblank/6h / data hnusf/6hnusigf/,hnabs/6habsorp/,hntotl/5htotal/ *d dtfr.523 data hmtid/5h els,5h ins,5h n2n,5h n3n,5h ngm,5h nal, *d dtfr.612 110 hednam(i)=hmtid(i) *d dtfr.637 132 hednam(i)=hz(i) *d dtfr.657 hword=hblank *d dtfr.662 hword=hednam(jedit) *d dtfr.667 150 write(nsyso,70) hword,jped(i),mted(i),multed(i) *d dtfr.671 hednam(iptotl-1)=hnusf *d dtfr.674 hednam(iptotl-2)=hnabs *d dtfr.677 hednam(iptotl)=hntotl *d dtfr.726 real*8 hednam,hisnam,hmti,hdat *d dtfr.732,733 common/dtf2/hednam(53),nedmax,jped(53),mted(53),multed(53),ids(53) common/dtf3/hisnam,mat,jz,dtemp *d dtfr.760,761 if (nout.gt.0) write(nout,25) hisnam,ng,ned,id(1),id(2),hdat if (iprint.eq.1) write(nsyso,26) hisnam,ng,ned,id(1),id(2),hdat *d dtfr.776 hmti=hednam(j) *d dtfr.789,790 170 if (nout.gt.0) write(nout,70) (dat(i),i=1,6),hisnam,hmti,iseq if (iprint.eq.1) write(nsyso,71) (dat(i),i=1,6),hisnam,hmti,iseq *d dtfr.801,802 if (nout.gt.0) write(nout,30) hisnam,l,ltabn,ng if (iprint.eq.1) write(nsyso,31) hisnam,l,ltabn,ng *d dtfr.816,817 230 if (nout.gt.0) write(nout,40) (dat(i),i=1,6),hisnam,l,iseq if (iprint.eq.1) write(nsyso,40) (dat(i),i=1,6),hisnam,l,iseq *d dtfr.826,827 if (nout.gt.0) write(nout,35) hisnam,l,ngp,ng if (iprint.eq.1) write(nsyso,35) hisnam,l,ngp,ng *d dtfr.841,842 280 if (nout.gt.0) write(nout,40) (dat(i),i=1,6),hisnam,l,iseq if (iprint.eq.1) write(nsyso,40) (dat(i),i=1,6),hisnam,l,iseq *d dtfr.881 real*8 hednam,hisnam,hedn *d dtfr.887,888 common/dtf2/hednam(53),nedmax,jped(53),mted(53),multed(53),ids(53) common/dtf3/hisnam,matd,jz,dtemp *d dtfr.917 hedn=hednam(jpos) *d dtfr.919 write(labelz,10) hisnam,hedn *d dtfr.1188 real*8 hisnam *d dtfr.1194 common/dtf3/hisnam,mat,jz,dtemp *d dtfr.1234,1235 if (iphph.eq.0) write(ititle,30) hisnam,l if (iphph.eq.1) write(ititle,40) hisnam,l *d dtfr.1318 real*8 hisnam *d dtfr.1325 common/dtf3/hisnam,mat,jz,dtemp *d dtfr.1332 write(ititle,10) hisnam,ip-1 */ dtfr -- 28jul97 -- remove unused variables *d dtfr.896 character nchar(5)*1,labelz*16,l1*8 *d dtfr.899,900 *d dtfr.1036 *ident up97 */ matxsr -- 28jul97 -- make sure all hollerith variables are real */ for use on workstations (see above). *d matxsr.388,389 *d matxsr.398,399 dimension hz(1) equivalence (z(1),hz(1)) *i matxsr.413 c *d matxsr.470 110 z(i)=z(i+1) *d matxsr.520,521 *d matxsr.759,760 *d matxsr.925,926 *d matxsr.1316,1317 *d matxsr.1489,1490 *d matxsr.1705,1706 *d matxsr.1798,1799 *d matxsr.1818,1819 *ident up98 */ resxsr -- 28jul97 -- make sure all hollerith variables are real */ for use on workstations (see above). *d resxsr.187,188 *ident up99 */ unresr --28jul97 -- fix problem with the generation of the complex */ probability integral table that can lead to */ differences on different machines. */ make sure word alignment is ok in common. *d unresr.1043 common/wtabl/tr(62,62),ti(62,62),aimw,ax,rki,rew,y ki=nint(rki) *d unresr.1107 common/wtabl/tr(62,62),ti(62,62),aimw,ax,rki,rew,y1 *i unresr.1127 rki=0. *d unresr.1164 common/wtabl/tr(62,62),ti(62,62),aimw,ax,rki,rew,y1 *d unresr.1198 abrez=abs(rez) if (abrez+aimz.ne.0.) go to 20 *d unresr.1205 *ident up100 */ reconr -- 28jul97 -- fix problem with the generation of the complex */ probability integral table that can lead to */ differences on different machines. *d reconr.3992 abrez=abs(rez) if (abrez+aimz.ne.0.) go to 20 *d reconr.3999 *ident up101 */ njoy -- 28jul97 -- njoy gets its energy grids by dividing ranges */ in half. make sure rounding behavior in sigfig */ rounds numbers ending in 5 down to help keep */ the energy grids consistent on different machines. *d njoy.2766 data ten,rnd/10.0d0,0.499d0/ *d njoy.2768 data ten,rnd/10.0,0.499/ *i njoy.2769 save ndigal,n1 */ njoy -- 28jul97 -- fix obsolete comments about code conversion *d njoy.108 c * wordio -- set to activate word-addressable io * c * (lanl cray unicos only. see acer) * */ njoy -- 28jul97 -- make this patch from the upmachines file permanent *d njoy.128,129 if (iopt.eq.1) ntty=6 nsyse=6 nsyso=7 open(nsyso,file='output') *ident up102 */ heatr -- 28jul97 -- make the energy grid in the heatr listing */ come out the same on different machines. *i heatr.868 elst=0.99999*elst */ heatr -- 28jul97 -- be sure that variables are properly saved *i heatr.1170 save en,damn,el,daml *d heatr.3057 save elo,ehi,nlo,nhi,flo,fhi,ltt *i heatr.3818 save lf,z,awr */ heatr -- 28jul97 -- fix uninitialized variables *i heatr.658 n6=0 *i heatr.3632 lqx=0 *d heatr.3639 if (nqa.eq.0) go to 143 *d heatr.3645 143 call capdam(0.,damn,q,za,awr,mt) *ident up103 */ errorr -- 30jul31 -- update the save statements needed to run */ errorr without static memory allocation. *i errorr.1479 save mtlast,ngt,iz *i errorr.3108 save idisc,enext,elast,flst,slst *i errorr.3890 save nsig *ident up104 */ gaminr -- 30jul97 -- fix up save statements to allow */ gaminr to work without static allocation *i gaminr.702 save ip,ir *i gaminr.757 save nq,enext,elast,slst,flst *i gaminr.959 save nsig *i gaminr.988 save npff,zz *ident up105 */ leapr -- 30jul97 -- remove unused variables *d leapr.1142 *ident vers */ update version number and date to correspond to last ident *d njoy.8 c * version 94.105 -- 30 jul 97 * *d njoy.291 data vers/'94.105'/