+title. polrad 2.0 c c+keep,comcmp. c common/cmp/amp,amp2,ap,ap2,aml,aml2,al2,amc2,amh, c .amt,tara,tarz,fermom,amm,amn,chbar,barn,isf20 c c amp - proton mass; nuclear mass for ita=2 (elastic tail) c amp2=amp**2, ap=2.*amp, ap2=2.*amp**2 c aml - lepton mass c aml2=aml**2, al2=2.*aml**2 c amc2=(amp + m(pion) )**2 c amh - proton mass c amt - target mass c tara(tarz) - atomic number (charge) of nuvleus c fermom - fermi momentum of nuvleus c isf20 - number of structure function to be taken into account c c+keep,comsxy. c common/sxy/s,x,sx,sxp,y,ym,w2,als,alx,alm,aly, c .sqls,sqlx,sqly,sqlm,allm,an,tamin,tamax,xs,ys,tpl,tmi c c standard set of invariants is calculated in conkin c c+keep,comppi. c common/p/pi,pi2,alfa,i1(8),i2(8) c c pi = 3.14... pi2=pi**2 c alfa = fine structure constant c i1,i2 - integer work arrays c c+keep,compol. c common/pol/as,bs,cs,ae,be,ce,apn,apq,dk2ks,dksp1,dapks c c as,bs,cs,ae,be,ce - components of polarization vector c expanding on covariant basis in 4-dimensional space c leptons polarization vector xi = as k1 + bs k2 + cs p c leptons polarization vector eta = ae k1 + be k2 + ce p c c apn,apq,dk2ks,dksp1,dapks are scalar products c apn = eta.(k1+k2) apq = eta.(k1-k2) dksp1 = xi.p c dk2ks = k2.xi dapks = eta.xi c c+keep,comtail. c common/tail/un,pl,pn,qn,ita,isf1,isf2,isf3,ire c c pl,pn - polarization degrees of lepton and proton c qn - quadrupolarization degree of spin-one target c ita=1,2,3 corresponds to inelastic, elastic and quasielastic tails c isf1,isf2,isf3 - current numbers for sum over c contribution of structure functions: do isf=isf1,isf2,isf3 c ire - max order of fitting polynoms c c+keep,comweak,if=electroweak. c common/weak/amw,amw2,amz,amz2,amhi,amhi2,cw,sw,cw2,sw2,yz,dd(3),iw c +patch,polrad. +deck,common. +keep,comcmp. common/cmp/amp,amp2,ap,ap2,aml,aml2,al2,amc2,amh, .amt,tara,tarz,fermom,amm,amn,chbar,barn,isf20 +keep,comsxy. common/sxy/s,x,sx,sxp,y,ym,w2,als,alx,alm,aly, .sqls,sqlx,sqly,sqlm,allm,an,tamin,tamax,xs,ys,tpl,tmi +keep,comppi. common/p/pi,pi2,alfa,i1(8),i2(8) +keep,compol. common/pol/as,bs,cs,ae,be,ce,apn,apq,dk2ks,dksp1,dapks +keep,comtail. common/tail/un,pl,pn,qn,ita,isf1,isf2,isf3,ire,ich +keep,comweak,if=electroweak. common/weak/amw,amw2,amz,amz2,amhi,amhi2,cw,sw,cw2,sw2,yz,dd(3),iw +keep,commnk. parameter(j70=70) parameter(j9=9) parameter(j5=5) common/mnk/carr(j70,j9,j5),xarr(j70,j5),farr(j70,j9,j5) .,narr(j5),marr(j5),larr(j5) +keep,compar,if=targ_he3,targ_d. parameter(npar=3) common /comf/par(npar),chi2,ipara +keep,compar,if=targ_h. parameter(npar=2) common /comf/par(npar),chi2,ipara +deck,polrad. program polrad c c version 2.0 01.07.1996 c c implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. dimension tai(3),taip(3),tai2ll(3),si(2,3),si0(2,3),tls(2,3,4) +self,if=kin_net. parameter(nxfin=5) parameter(nyfin=36) dimension xnet(nxfin),xmas(nxfin*nyfin) dimension ynet(nyfin),ymas(nxfin*nyfin) data xnet/0.001, 0.01, 0.1, 0.5, 0.9/ data ynet/1d-2,1.5d-2,2d-2,3d-2,4d-2,5d-2,6d-2,7d-2,8d-2,9d-2, + 1d-1,1.25d-1,1.5d-1,1.75d-1, + 2d-1,3d-1,4d-1,5d-1,6d-1,6.5d-1,7d-1,7.5d-1, + 8d-1,8.25d-1,8.5d-1,8.75d-1,9d-1,.91d0, + .92d0,.93d0,.94d0,.95d0,.96d0,.97d0,.98d0,.99d0/ npoi=0 do iix=1,nxfin do iiy=1,nyfin npoi=npoi+1 xmas(npoi)=xnet(iix) ymas(npoi)=ynet(iiy) enddo enddo +self,if=kin_smc. parameter(npoi=11) dimension xmas(npoi) dimension ymas(npoi) data xmas/ . 0.009d0,0.015d0,0.025d0,0.035d0,0.050d0,0.079d0 .,0.123d0,0.173d0,0.241d0,0.343d0,0.470d0/ data ymas/ . -1.2d0,-1.7d0,-2.5d0,-3.1d0,-3.7d0,-4.6d0,-5.6d0, . -6.9d0,-9.0d0,-12.0d0,-15.5d0/ +self,if=kin_hermes. parameter(nxfin=8) parameter(nyfin=4) dimension xmas(nxfin*nyfin),iiymas(nyfin) dimension ymas(nxfin*nyfin),ynet(20) data iiymas/2,6,12,17/ .ynet/.07d0,.1d0,.15d0,.2d0,.25d0,.3d0,.35d0,.40d0,.45d0,.50d0 .,.55d0,.6d0,.65d0,.7d0,.73d0,.77d0,.8d0,.82d0,.84d0,.85d0/ npoi=0 e1=27.5 do iiy=1,nyfin xfmin=0.01 xfmax=0.85 ys=ynet(iiymas(iiy)) te1=0.02 te2=0.24 w12=1.7 q2min=0.8 xq=q2min/(2.*.938272*e1*ys) xt1=2.*e1*sin(te1/2.)**2*(1.-ys)/.938272/ys xt2=2.*e1*sin(te2/2.)**2*(1.-ys)/.938272/ys xw=1.-(w12-.938272**2)/e1/ys/2./.938272 xs1=max(xfmin,xt1,xq) xs2=min(xfmax,xt2,xw) do xs=xs1,xs2,(xs2-xs1)/(nxfin-1) npoi=npoi+1 xmas(npoi)=xs ymas(npoi)=ys enddo enddo +self,if=kin_e142. parameter(npoi=8) dimension xmas(npoi) dimension ymas(npoi) data xmas/ . 0.035d0,0.05d0,0.08d0,0.125d0,0.175d0 .,0.25d0,0.35d0,0.5d0/ data ymas/ . -1.1d0,-1.3d0,-1.6d0,-2.3d0,-2.7d0,-3.1d0 .,-3.4d0,-5.2d0/ +self,if=kin_own. dimension xmas(100) dimension ymas(100) +self,if=iter_pr. character*10 itdata parameter(np=100) dimension asdata(np),aslast(np),asprev(np),err(np),errfac(np) +seq,compar,if=minuit. +self,if=err_prop. dimension boe(npar),tae(npar),dpa(npar,np) +self,if=iter_pr,if=iter_pr_g2. dimension a2data(np),a2last(np),a2prev(np),er2(np) +self,if=iter_pr. character*41 it41(np) character*30 it30(np) +seq,commnk,if=iter_pr. dimension xmas(np) dimension ymas(np) data nit/1/ ! nit=1(-1) for 'old'('new') iteration formula +self,if=iter_pr,if=targ_h. data itdata /'itdat1.dat'/ +self,if=iter_pr,if=targ_d,if=pol_asym. data itdata /'itdat2.dat'/ +self,if=iter_pr,if=targ_d,if=qua_asym. data itdata /'itquad.dat'/ +self,if=iter_pr,if=targ_he3. data itdata /'itdat3.dat'/ppro/-0.028/pneu/0.86/ +self,if=iter_pr. c print *,' ire=' c read(*,*)ire ire=7 +self,if=iter_pr,if=-minuit. call remnk2(itdata,2,5,ire,4) +self,if=iter_pr,if=minuit. call remnk2(itdata,2,5,ire,5) +self,if=iter_pr,if=iter_pr_g2. call remnk2('itasm2.dat',5,5,ire,4) +self,if=iter_pr,if=-minuit. npoi=narr(2)-1 +self,if=minuit. npoi=narr(2) +self,if=iter_pr. do n=1,narr(2) xmas(n)=xarr(n,2) ymas(n)=farr(n,1,2) asdata(n)=farr(n,2,2) aslast(n)=farr(n,3,2) asprev(n)=farr(n,4,2) err(n)=farr(n,5,2) +self,if=iter_pr,if=iter_pr_g2. if(xmas(n).ne.xarr(n,5) .or. ymas(n).ne.farr(n,1,5)) . pause ' x or y in itdat1 and itasm2 are not coinside' a2data(n)=farr(n,2,5) a2last(n)=farr(n,3,5) a2prev(n)=farr(n,4,5) er2(n)=farr(n,5,5) +self,if=iter_pr. enddo +self,if=err_prop. call dpafun(npoi,xmas,aslast,err,dpa) +self. open(unit=8,file='input.dat',status='old') read(8,'(f10.3)')bmom read(8,'(f10.3)')tmom read(8,'(f10.3)')pl1 read(8,'(f10.3)')pn1 read(8,'(f10.3)')qn1 +self,if=kin_own. read(8,'(i10)')npoi read(8,'(10f8.4)')(xmas(i),i=1,npoi) read(8,'(10f8.4)')(ymas(i),i=1,npoi) +self. close(8) call titout('10.04.1997',bmom,tmom,pl1,pn1,qn1) +self,if=f2comfst. call remnk2('brassm.dat',1,9,9,1) +self,if=qua_asym. call remnk2('bb1fit.dat',4,1,3,4) +self. snuc=2.*(sqrt(tmom**2+amh*amh)*sqrt(bmom**2+aml2)+bmom*tmom) do 1 i=1,npoi xs=xmas(i) if(ymas(i).ge.0)then ys=ymas(i) y=snuc*xs*ys ! q2 else y=-ymas(i) ! q2 ys=y/(snuc*xs) endif write(9,998)xs,ys,snuc print 998,xs,ys,snuc yma=1d0/(1d0+amp**2*xs/snuc) ymi=(amc2-amp**2)/(snuc*(1d0-xs)) if(ys.gt.yma.or.ys.lt.ymi.or.xs.gt.1d0.or.xs.lt.0d0)then write(9,66) goto 1 endif call conkin(snuc,amh) c c delta is factorizing part of virtual and real leptonic bremsstrahlung c call deltas(delta,delinf,tr) do 10 il=1,1 do 10 in=1,3,2 si(il,in)=0d0 si0(il,in)=0d0 tls(il,in,1)=0d0 tls(il,in,2)=0d0 tls(il,in,3)=0d0 tls(il,in,4)=0d0 isf1=1 isf2=isf20 isf3=1 +self,if=cr_sec,born. un=1. pl=pl1 pn=pn1*(in-2) qn=qn1 +self,if=pol_asym,qua_asym. if(in.eq.1)then un=1. pl=pl1 pn=0. qn=0. isf1=1 isf2=2 elseif (in.eq.3)then +self,if=pol_asym. un=0. pl=pl1 pn=pn1 qn=0. isf1=3 isf2=4 +self,if=qua_asym. un=0. pl=0. pn=0. qn=qn1 isf1=1 isf2=8 +self,if=pol_asym,qua_asym. else stop endif +self. +self,if=-onlyin. do 30 ita=1,3 +self,if=onlyin. do 30 ita=1,1 +self,if=err_prop. ifine=0 if(ita.eq.1.and.in.eq.3)ifine=npar do ipara=ifine,0,-1 +self. write(9,'(10(1h*),'' ita = '',i2,10(1h*))')ita +self,if=targ_h. if(ita.eq.3)then tai(3)=0d0 write(9,'('' tai = 0.0 '')') goto 30 end if +self. c c sib is born cross section with polarized initial c lepton and proton c sia is contribution of anomalous magnetic moment. c if(ita.eq.1)then call bornin(sib,sia) endif +self,if=born. goto 30 +self. c c tai(1),tai(2),tai(3) are contributions of radiative tails: c 1 - inelastic c 2 - elastic c 3 - quasielastic c +self,if=exact,approx. if(ita.eq.2) call conkin(snuc,amt) call qqt(sib,tai(ita),taip(ita),tai2ll(ita)) if(ita.eq.2) call conkin(snuc,amh) +self,if=err_prop. if(ipara.ne.0)then tae(ipara)=tai(ita) boe(ipara)=sib endif enddo +self,if=-exact,if=-approx. tai(ita)=0. +self. 30 continue +self,if=-alpha2ll. extai1=exp(alfa/pi*delinf) extai2=((sx-y/tara)**2/s/(s-y/tara))**tr extai3=((sx-y)**2/s/(s-y))**tr +self,if=alpha2ll. extai1=1d0 extai2=1d0 extai3=1d0 delinf=0.d0 +self,if=-onlyin. sig=sib*extai1*(1.+alfa/pi*(delta-delinf))+sia . +tai(1)+(tai(2)*extai2+tai(3)*extai3)/tara +self,if=onlyin. sig=sib* (1.+alfa/pi*(delta-delinf)) . +tai(1) +self. si(il,in)=si(il,in)+sig si0(il,in)=si0(il,in)+sib tls(il,in,1)=tls(il,in,1)+tai(1) tls(il,in,2)=tls(il,in,2)+tai(2)/tara tls(il,in,3)=tls(il,in,3)+tai(3)/tara tls(il,in,4)=tls(il,in,4)+(sib*alfa/pi*delta+sia) if(in.eq.1)write(21,'(16g11.5)') . xs,ys,s,sib,sig,delta,tai(1) . ,tai(2)/tara,tai(3)/tara,tai2ll(1) . ,tai2ll(2)/tara,tai2ll(3)/tara,taip(1) . ,taip(2)/tara,taip(3)/tara +self,if=electroweak,if=f2g1grsv96. . ,vconew(1) +self. if(in.eq.3)write(23,'(16g11.5)') . xs,ys,s,sib,sig,delta,tai(1),tai(2)/tara,tai(3)/tara . ,tai2ll(1),tai2ll(2)/tara,tai2ll(3)/tara . ,taip(1),taip(2)/tara,taip(3)/tara +self,if=electroweak,if=f2g1grsv96. . ,vconew(1) +self. 10 continue c d factor ddf=ys*(2.-ys)/(ys*ys+2.*(1.-ys)*(1.+r1990(xs,y))) c c si (si0) is dis cross section for the corresponding target c aspop is polarized asymmetry including radiative corrections c asbor is born polarized asymmetry c del is total radiative correction c +self,if=born,cr_sec. if(abs(si0(1,1)-si0(1,3)).lt.1d-10)goto 111 tip=(tls(1,1,1)-tls(1,3,1))/(si0(1,1)-si0(1,3)) tep=(tls(1,1,2)-tls(1,3,2))/(si0(1,1)-si0(1,3)) tqp=(tls(1,1,3)-tls(1,3,3))/(si0(1,1)-si0(1,3)) tvp=(tls(1,1,4)-tls(1,3,4))/(si0(1,1)-si0(1,3)) 111 tiu=(tls(1,1,1)+tls(1,3,1))/(si0(1,1)+si0(1,3)) teu=(tls(1,1,2)+tls(1,3,2))/(si0(1,1)+si0(1,3)) tqu=(tls(1,1,3)+tls(1,3,3))/(si0(1,1)+si0(1,3)) tvu=(tls(1,1,4)+tls(1,3,4))/(si0(1,1)+si0(1,3)) aspop=(si(1,1)-si(1,3))/(si(1,1)+si(1,3))/ddf asbor=(si0(1,1)-si0(1,3))/(si0(1,1)+si0(1,3))/ddf +self,if=pol_asym,qua_asym. aspop=-si(1,3)/si(1,1)/ddf asbor=-si0(1,3)/si0(1,1)/ddf del= aspop-asbor tip=tls(1,3,1)/si(1,1)/ddf/asbor tep=tls(1,3,2)/si(1,1)/ddf/asbor tqp=tls(1,3,3)/si(1,1)/ddf/asbor tvp=tls(1,3,4)/si(1,1)/ddf/asbor tiu=tls(1,1,1)*si0(1,3)/si0(1,1)/si(1,1)/ddf/asbor teu=tls(1,1,2)*si0(1,3)/si0(1,1)/si(1,1)/ddf/asbor tqu=tls(1,1,3)*si0(1,3)/si0(1,1)/si(1,1)/ddf/asbor tvu=tls(1,1,4)*si0(1,3)/si0(1,1)/si(1,1)/ddf/asbor +self. c if ( abs(asbor).gt.1d-10) del=(aspop-asbor)/asbor del= aspop-asbor write(9,68)xs,si0(1,1),si0(1,2),si0(1,3),asbor write(9,68)xs,si (1,1),si (1,2),si (1,3),aspop write(7,69)xs,w2,y,asbor,aspop,del write(16,'(2f6.3,0pf7.2,7f7.2)')xs,ys,tip,tep,tqp, .tvp,tiu,teu,tqu,tvu +self,if=iter_pr. delabs=aspop-asbor +self,if=err_prop. error2=0. do jji=1,npoi taedpa=0. boedpa=0. do ipp=1,npar taedpa=taedpa+tae(ipp)*dpa(ipp,jji) boedpa=boedpa+boe(ipp)*dpa(ipp,jji) enddo +self,if=err_prop,if=targ_h,targ_d. errpol=-taedpa/si(1,1)/ddf efitb=-boedpa/si0(1,1)/ddf +self,if=err_prop,if=targ_he3. errpol=-taedpa/si(1,1)/ddf/fdilut(xs)/pneu efitb=-boedpa/si0(1,1)/ddf/fdilut(xs)/pneu +self,if=err_prop. errunp=(tls(1,1,1)+tls(1,1,2)+tls(1,1,3))/si(1,1)*efitb if(jji.ne.i)then error2=error2+(errpol * err(jji)/err(i))**2 else error2=error2+ (1.+errunp-errpol)**2 endif write(*,'(2i5,3g13.4)')i,jji,errunp,errpol,sqrt(error2) write(9,'(2i5,3g13.4)')i,jji,errunp,errpol,sqrt(error2) enddo errfac(i)=sqrt(error2) c write(9,'(4hboe:,3g14.4)')boe c write(9,'(4htae:,3g14.4)')tae c write(9,'(4hdpa:,3g14.4)')dpa write(9,'(4herr:,3g14.4)')errfac(i) +self,if=iter_pr,if=long. asprev(i)=aslast(i) if(nit.gt.0)then +self,if=iter_pr,if=long,if=targ_h,targ_d. aslast(i)=asdata(i)-delabs +self,if=iter_pr,if=long,if=targ_he3. aslast(i)=asdata(i)-delabs/fdilut(xs)/pneu +self,if=iter_pr,if=long. elseif(nit.lt.0)then dercfu=si(1,1)/si0(1,1)-1. dercfp=(-si(1,3)+si0(1,3))/si0(1,1) +self,if=iter_pr,if=long,if=targ_h,targ_d. aslast(i)=(1.+dercfu)*asdata(i) . -dercfp/ddf +self,if=iter_pr,if=long,if=targ_he3. df=fdilut(xs) aslast(i)=(1.+dercfu)*asdata(i) . -dercfp/ddf/df/pneu . +dercfu*(1.-df)*ppro*as1pro(xs)/pneu/df +self,if=iter_pr,if=long. endif +self,if=iter_pr,if=tran. a2prev(i)=a2last(i) a2last(i)=a2data(i)-delabs +self. 1 continue +self,if=iter_pr,if=long. open(unit=12,file=itdata,status='old') +self,if=iter_pr,if=tran. open(unit=12,file='itasm2',status='old') +self,if=iter_pr. ios=0 ii=0 do while(ios.eq.0) ii=ii+1 read(12,'(a41,a30)',iostat=ios)it41(ii),it30(ii) enddo close(12) ii=ii-1 write(*,72) k=0 +self,if=iter_pr,if=long. open(unit=12,file=itdata) +self,if=iter_pr,if=tran. open(unit=12,file='itasm2') +self,if=iter_pr. do i=1,ii if(it41(i)(1:1).eq.' '.or.it41(i)(1:1).eq.'0' . .and. k.lt.npoi)then k=k+1 +self,if=minuit. write(it30(i)(11:20),'(f10.5)')errfac(k) +self,if=iter_pr,if=long. write(12,'(a1,f6.3,f7.3,3f9.5,a30)')it41(i)(1:1), . xmas(k),ymas(k),asdata(k),aslast(k),asprev(k),it30(i) write(*,'(a1,f6.3,f7.3,3f9.5,a30)')it41(i)(1:1), . xmas(k),ymas(k),asdata(k),aslast(k),asprev(k),it30(i) +self,if=iter_pr,if=tran. write(12,'(a1,f6.3,f7.3,3f9.5,a30)')it41(i)(1:1), . xmas(k),ymas(k),a2data(k),a2last(k),a2prev(k),it30(i) write(*,'(a1,f6.3,f7.3,3f9.5,a30)')it41(i)(1:1), . xmas(k),ymas(k),a2data(k),a2last(k),a2prev(k),it30(i) +self,if=iter_pr. else write(12,'(a41,a30)')it41(i),it30(i) if(i.le.2) . write(*,'(a41,a30)')it41(i),it30(i) endif enddo close(12) +self. 66 format(1x,'kinematics') 68 format(1x,f7.3,3e15.5,2pf15.5) 69 format(1x,f7.3,2f8.1,2pf8.3,2f8.3) 998 format(' ****** x = ',f7.5,' y = ',f7.5,' s = ',g13.4,' ******') 72 format(//' ****** iteration procedure result table ******') 1000 end block data implicit real*8(a-h,o-z) +seq,comcmp. +seq,comppi. +seq,comweak,if=electroweak. data .amm/2.7928456d0/,amn/-1.913148d0/,chbar/.197328d0/,barn/.389379d6/ +self,if=muons. .aml/.105658d0/,aml2/.111637d-1/,al2/.0223274d0/, +self,if=elect. .aml/.511000d-3/,aml2/.261112d-6/,al2/.522240d-6/, +self,if=targ_h. .amt/.938272d0/, .tara/1d0/ .tarz/1d0/ .fermom/0d0/ .isf20/4/ +self,if=targ_d. .amt/1.87561d0/, .tara/2d0/ .tarz/1d0/ .fermom/.07d0/ .isf20/4/ +self,if=targ_he3. .amt/2.80833d0/, .tara/3d0/ .tarz/2d0/ .fermom/.164d0/ ! - ? .isf20/4/ +self,if=targ_c. .amt/11.18817d0/, .tara/12d0/ .tarz/6d0/ .fermom/.221d0/ .isf20/2/ +self,if=targ_o. .amt/14.90334d0/, .tara/16d0/ .tarz/8d0/ .fermom/.231d0/ .isf20/2/ +self,if=electroweak. .amz/91.2d0/,amw/80.6d0/,amhi/300d0/,sw2/0.225d0/,amz2/8317.44d0/, .amw2/6496.36d0/,amhi2/.9d5/,cw2/.775d0/,sw/.47434d0/,cw/.88d0/ +self,if=ew_onlyqed. .iw/1/ +self,if=-ew_onlyqed,if=electroweak. .iw/2/ +self. .pi/3.1415926d0/,pi2/9.869604d0/,alfa/.729735d-2/,amc2/1.151857d0/, .amp/.938272d0/,amh/.938272d0/, .i2/1,1,1,2,3,3,1,2/,i1/3,3,4,4,3,3,3,3/ end +deck,conkin. ****************** conkin ************************************* subroutine conkin(snuc,amtar) c set of kinematical constants implicit real*8(a-h,o-z) +seq,comcmp. +seq,compol. +seq,comsxy. +seq,comppi. +seq,comweak,if=electroweak. amp=amtar ap=2.*amp amp2=amp**2 ap2=2.*amp**2 s=snuc*amp/amh x=s*(1.-ys) sx=s-x sxp=s+x ym=y+al2 tpl=s**2+x**2 tmi=s**2-x**2 w2=amp2+s-y-x +self,if=electroweak. dd(1)=1./y dd(2)=1./(y+amz2) dd(3)=1./(y+amw2) yz=y+amz2 +self. als=s*s-al2*ap2 alx=x*x-al2*ap2 alm=y*y+4.*aml2*y aly=sx**2+4.*amp2*y sqls=dsqrt(als) sqlx=dsqrt(alx) sqly=dsqrt(aly) sqlm=dsqrt(alm) allm=dlog((sqlm+y)/(sqlm-y))/sqlm axy=pi*(s-x) an=2.*alfa**2/sqls*axy*barn*amh/amp c tamin=(sx-sqly)/ap2 tamax=(sx+sqly)/ap2 tamin=-y/amp2/tamax as=s/2./aml/sqls bs=0. cs=-aml/sqls +self,if=long. ae=amp/sqls be=0. ce=-s/ap/sqls +self,if=tran. sqn=dsqrt(s*x*y-aly*aml2-amp2*y*y) ae=(-s*x+ap2*ym)/sqls/sqn/2. be=sqls/sqn/2. ce=-(s*y+al2*sx)/sqls/sqn/2. +self. apq=-y*(ae-be)+ce*sx apn=(y+4.*aml2)*(ae+be)+ce*sxp dk2ks=as*ym+al2*bs+cs*x dksp1=as*s+bs*x+cs*ap2 dapks=2.*(al2*(as*ae+bs*be)+ap2*cs*ce+ym*(as*be+bs*ae) .+s*(as*ce+cs*ae)+x*(bs*ce+cs*be)) return end +deck,bornin. ****************** bornin ************************************* subroutine bornin(sibor,siamm) c c sibor is born cross section with polarized initial c lepton and polarized target c siamm is contribution of anomalous magnetic moment. c implicit real*8(a-h,o-z) +seq,comcmp. +seq,compol. +seq,comsxy. +seq,comppi. +seq,comtail. common/print/ipri1 dimension sfm0(8),tm(8) ipri1=1 call strf(0d0,0d0,sfm0) ipri1=0 tm(1)=-(2.*aml2-y) tm(2)=(-(amp2*y-s*x))/(2.*amp2) tm(3)=(2.*(apq*dk2ks-dapks*y)*aml)/amp tm(4)=apq/amp*(-(dk2ks*sx-2.*dksp1*y)*aml)/amp2 tm(7)=(-(4.*aml2+3.*apn**2-3.*apq**2+y))/2. tm(8)=apq/amp*(-3.*(apn*sxp-apq*sx))/(2.*ap) ek=(3.*apq**2-y)/amp2 tm(5)=-ek*tm(1) tm(6)=-ek*tm(2) ssum=0. do 1 isf=isf1,isf2,isf3 ppol=1. if(isf.eq.3.or.isf.eq.4)ppol=-pn if(isf.ge.5)ppol=qn/6 ssum=ssum+tm(isf)*sfm0(isf)*ppol 1 continue sibor=ssum*an/y/y*2. c c formula (4) of kukhto and shumeiko paper c cc res1=amp*ww1*(y+4.*aml2)-ww2*(s+x)**2/4./amp cc siamm=alfa/pi*al2*allm*(sibor+an*res1/y**2) siamm=0. return end +deck,deltas. ****************** deltas ************************************* subroutine deltas(delta,delinf,tr) c c delta is factorizing part of virtual and real leptonic bremsstrahlung c implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. del1=-ym*(alm*allm**2/2.+2.*fspen(2d0*sqlm/(y+sqlm))-pi2/2.)/sqlm del2=(3.*y/2.+4.*aml2)*allm-2. sum=vacpol(y) aj0=2.*(ym*allm-1.) deltai=aj0*dlog((w2-amc2)/aml/dsqrt(w2)) ss=x+y xx=s-y alss=ss**2-2.*w2*al2 alxx=xx**2-2.*w2*al2 sqlss=dsqrt(alss) sqlxx=dsqrt(alxx) allss=dlog((sqlss+ss)/(-sqlss+ss))/sqlss allxx=dlog((sqlxx+xx)/(-sqlxx+xx))/sqlxx dlm=dlog(y/aml2) sfpr=dlm**2/2.-dlm*dlog(ss*xx/aml2/w2) . -(dlog(ss/xx))**2/2.+fspen((s*x-y*amp2)/ss/xx)-pi2/3. delta0=(ss*allss+xx*allxx)/2.+sfpr delta=deltai+delta0+del1+del2+sum delinf=(dlm-1.)*dlog((w2-amc2)**2/ss/xx) tr=alfa/pi*(dlm-1.) +self,if=ew_onlyqed. write(9,'(a20,g11.4)')' del1 = ',del1 write(9,'(a20,g11.4)')' del2 = ',del2 write(9,'(a20,g11.4)')' suml = ',suml write(9,'(a20,g11.4)')' sumh = ',sumh write(9,'(a20,g11.4)')' delta0 = ',delta0 write(9,'(a20,g11.4)')' deltai = ',deltai +self. return end +deck,vacpol. double precision function vacpol(t) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comppi. dimension am2(3) c c am2 : squared masses of charge leptons c data am2/.26110d-6,.111637d-1,3.18301d0/ suml=0. do 10 i=1,3 a2=2.*am2(i) sqlmi=dsqrt(t*t+2.*a2*t) allmi=dlog((sqlmi+t)/(sqlmi-t))/sqlmi 10 suml=suml+2.*(t+a2)*allmi/3.-10./9.+4.*a2*(1.-a2*allmi)/3./t if(t.lt.1.d0)then aaa = -1.345d-9 bbb = -2.302d-3 ccc = 4.091 elseif(t.lt.64d0)then aaa = -1.512d-3 bbb = -2.822d-3 ccc = 1.218 else aaa = -1.1344d-3 bbb = -3.0680d-3 ccc = 9.9992d-1 endif sumh = -(aaa+bbb*log(1.+ccc*t)) *2*pi/alfa vacpol=suml+sumh end +deck,fspens. ****************** fspens ************************************* double precision function fspens(x) c c spence function c implicit real*8(a-h,o-z) f=0.d0 a=1.d0 an=0.d0 tch=1.d-16 1 an=an+1.d0 a=a*x b=a/an**2 f=f+b if(b-tch)2,2,1 2 fspens=f return end +deck,fspen. ****************** fspen ************************************** double precision function fspen(x) implicit real*8(a-h,o-z) data f1/1.644934d0/ if(x)8,1,1 1 if(x-.5d0)2,2,3 2 fspen=fspens(x) return 3 if(x-1d0)4,4,5 4 fspen=f1-dlog(x)*dlog(1d0-x+1d-10)-fspens(1d0-x) return 5 if(x-2d0)6,6,7 6 fspen=f1-.5*dlog(x)*dlog((x-1d0)**2/x)+fspens(1d0-1d0/x) return 7 fspen=2d0*f1-.5d0*dlog(x)**2-fspens(1d0/x) return 8 if(x+1d0)10,9,9 9 fspen=-.5d0*dlog(1d0-x)**2-fspens(x/(x-1d0)) return 10 fspen=-.5*dlog(1.-x)*dlog(x**2/(1d0-x))-f1+fspens(1d0/(1d0-x)) return end +deck,qqt,if=exact,approx. ****************** qqt **************************************** subroutine qqt(bo,tai,taip,tai2ll) implicit real*8(a-h,o-z) external rv2ln,rv2 +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. ep=1d-8 abb0=bo*pi/an/alfa +self,if=exact. tlnmin=dlog(tamin+y/sx) tlnmax=dlog(tamax+y/sx) tln0=dlog(y/sx) tlns=dlog(-y/s+y/sx) tlnp=dlog(y/x+y/sx) if(ita.ne.1)then c call qunc8(rv2,tamin,tamax,ep*abb0,ep,res2,er,nn2,fl2,3500) c call qunc8(rv2ln,tlnmin,tlnmax,ep*abb0,ep,res2,er,nn2,fl2,3500) call simpxx(tlnmin,tln0,200,1d-4,rv2ln,res1) call simpxx(tln0,tlnmax,100,1d-2,rv2ln,res2) tai=an*alfa/pi*(res1+res2) c write(*,9)tai,fl2,nn2 write(9,9)tai !,fl2,nn2 taip=0. else call qqint( 500,26000,3,1,5d-4,tai) +self,if=electroweak,if=f2g1sch. write(9,'(a20,g11.4)')' sib = ',sib call targws(sigws0,sigws1) +self,if=ew_onlyqed,if=f2g1sch. taip=sigws1 +self,if=-ew_onlyqed,if=electroweak,if=f2g1sch. taip=sigws0+sigws1 +self. end if c 9 format(' tai = ',e12.4,' fl = ',f6.2,' nn = ',i4) 9 format(' tai = ',e12.4) +self,if=approx,if=electroweak,if=f2g1grsv96. ich=2 taip=apptai(bo)+vconew(2) +self,if=-approx,if=electroweak,if=f2g1grsv96. ich=1 taip=apptai(bo)+vconew(2) +self,if=exact,if=approx,if=-electroweak. ich=0 taip=apptai(bo) if(abs(taip).gt.1d-10)otpr=tai/taip*100. write(*,19)otpr write(9,19)otpr 19 format(' tai(exact)/tai(approx)*100% = ',f8.3) +self,if=-exact,if=approx,electroweak,if=f2g1grsv96. tai=taip +self,if=exact,if=-approx,if=electroweak. tai=tai+taip +self,if=alpha2ll. ich=2 tai2ll=al2ll(tai) write(9,'(a8,2pg10.3)')' al2/al=',tai2ll/tai tai=tai+tai2ll +self. end +patch,exact. +deck,tails. ****************** tails ************************************** subroutine tails(ta,tm) implicit real*8(a-h,o-z) +seq,comcmp. +seq,compol. +seq,comsxy. +seq,comppi. common/bseo/ois,oir,oi12,eeis,eeir,eei12, . eei1i2,eb,eeb,tm3(6,4,3) dimension tm(8,6),ajm2(2),ajm3(3),ii(8) data ii/1,2,3,4,1,2,5,6/ b2=(-aly*ta+sxp*sx*ta+2.*sxp*y)/2. b1=(-aly*ta-sxp*sx*ta-2.*sxp*y)/2. c1=-(4.*(amp2*ta**2-sx*ta-y)*aml2-(s*ta+y)**2) c2=-(4.*(amp2*ta**2-sx*ta-y)*aml2-(ta*x-y)**2) bb=1./sqly sc1=dsqrt(c1) sc2=dsqrt(c2) bi12=(sxp*(sx*ta+2.*y))/(sc1*sc2*(sc1+sc2)) bi1pi2=1./sc2+1./sc1 bis=-b1/sc1/c1+b2/sc2/c2 bir=b2/sc2/c2+b1/sc1/c1 b1i=-b1/aly/sqly b11i=(3.*b1**2-aly*c1)/2./aly**2/sqly sps=as+bs spe=ae+be ccpe=(ae-be)*ta+2.*ce ccps=(as-bs)*ta+2.*cs sis=(2.*bi1pi2*sps+bir*sps*ta+bis*ccps)/2. sir=( (2.*bi12*sps*ta+bir*ccps+bis*sps*ta))/2. si12=(bi12*ccps+bi1pi2*sps)/2. eis=(2.*bi1pi2*spe+bir*spe*ta+bis*ccpe)/2. eir=( (2.*bi12*spe*ta+bir*ccpe+bis*spe*ta))/2. ei12=(bi12*ccpe+bi1pi2*spe)/2. ois=((2.*bi1pi2+bir*ta)*(ccpe*sps+ccps*spe)+(ccpe*ccps+ . spe*sps*ta**2)*bis+8.*bb*spe*sps+4.*bi12*spe*sps*ta**2)/ . 4. oir=( ((2.*bi12+bis)*(ccpe*sps+ccps*spe)*ta+(ccpe*ccps+ . spe*sps*ta**2)*bir+4.*bi1pi2*spe*sps*ta))/4. oi12=((ccpe*ccps+spe*sps*ta**2)*bi12+(ccpe*sps+ccps*spe)* . bi1pi2+4.*bb*spe*sps)/4. eeis=((ccpe**2+spe**2*ta**2)*bis+8.*bb*spe**2+4.*bi12*spe . **2*ta**2+4.*bi1pi2*ccpe*spe+2.*bir*ccpe*spe*ta)/4. eeir=( ((ccpe**2+spe**2*ta**2)*bir+4.*bi12*ccpe*spe*ta+4. . *bi1pi2*spe**2*ta+2.*bis*ccpe*spe*ta))/4. eei12=((ccpe**2+spe**2*ta**2)*bi12+4.*bb*spe**2+2.*bi1pi2 . *ccpe*spe)/4. ei1pi2=(4.*bb*spe+bi12*spe*ta**2+bi1pi2*ccpe)/2. eei1i2=((ccpe**2+spe**2*ta**2)*bi1pi2+4.*(2.*ccpe-spe*ta) . *bb*spe+8.*b1i*spe**2+2.*bi12*ccpe*spe*ta**2)/4. eb=((ccpe-spe*ta)*bb+2.*b1i*spe)/2. eeb=((ccpe-spe*ta)**2*bb+4.*(ccpe-spe*ta)*b1i*spe+4.*b11i . *spe**2)/4. call ffu(1,bb,bis,bir,bi12,bi1pi2,sir,sis,si12 .,eis,eir,ei12,ei1pi2,ta) call ffu(2,eb,eis,eir,ei12,ei1pi2,oir,ois,oi12 .,eeis,eeir,eei12,eei1i2,ta) call ffu(3,eeb,eeis,eeir,eei12,eei1i2,0d0,0d0,0d0 .,0d0,0d0,0d0,0d0,ta) ajm2(1)=apq/amp ajm2(2)=-1./amp ajm3(1)=(y-3.*apq**2)/amp2 ajm3(2)=6.*apq/amp2 ajm3(3)=-3./amp2 do 15 i=1,8 do 13 l=1,6 13 tm(i,l)=0 do 10 k=1,i2(i) ajk=1. if(i.eq.4.or.i.eq.8)ajk=ajm2(k) if(i.eq.5.or.i.eq.6)ajk=ajm3(k) do 10 j=k,i1(i)+k-1 tm(i,j)=tm(i,j)+tm3(ii(i),j-k+1,k)*ajk if((i.eq.5.or.i.eq.6).and.k.eq.2) . tm(i,j)=tm(i,j)+tm3(ii(i),j-k+1,1)*ta/amp2 10 continue 15 continue return end +deck,ffu. ****************** ffu **************************************** subroutine ffu(n,bb,bis,bir,bi12,bi1pi2,sir,sis,si12 . ,eis,eir,ei12,ei1pi2,ta) implicit real*8(a-h,o-z) +seq,comcmp. +seq,compol. +seq,comsxy. +seq,comppi. common/bseo/ois,oir,oi12,eeis,eeir,eei12, . eei1i2,eb,eeb,tm3(6,4,3) hi2=aml2*bis-ym*bi12 shi2=aml2*sis-ym*si12 ehi2=aml2*eis-ym*ei12 ohi2=aml2*ois-ym*oi12 goto(10,20,30)n 10 continue tm3(3,1,n)=(8.*(apq*dk2ks-dapks*y)*aml*hi2)/amp tm3(3,2,n)=(-2.*((2.*(bi12*dk2ks*ta-2.*shi2)*apq+(2.*shi2- . sir*y+sis*ym)*apn+4.*dapks*hi2*ta)-4.*((2.*ei12-eis)* . dk2ks-(si12-sis)*apn)*aml2)*aml)/amp tm3(3,3,n)=(2.*(((2.*si12+sir-sis)*apn*ta-2.*dk2ks*ei12*ta . -6.*ohi2-oir*y+ois*ym)-4.*aml2*oi12)*aml)/amp tm3(3,4,n)=(2.*(2.*oi12-oir+ois)*aml*ta)/amp tm3(5,1,n)=-2.*(4.*aml2+3.*apn**2-3.*apq**2+y)*hi2 tm3(5,2,n)=-2.*(6.*aml2*apn*eir-3.*apn**2*bi12*ta+3.*apn* . apq*bi1pi2+6.*apq*ehi2+hi2*ta) tm3(5,3,n)=-(24.*aml2*eei12-6.*apn*ei1pi2-6.*apq*ei12*ta- . 2.*bb-bi12*ta**2) 20 continue tm3(4,1,n)=(-4.*(dk2ks*sx-2.*dksp1*y)*aml*hi2)/amp2 tm3(4,2,n)=(((2.*(sxp-2.*sx)*shi2+2.*bi12*dk2ks*sx*ta+8.* . dksp1*hi2*ta-sir*sxp*y+sis*sxp*ym)-4.*(2.*bi12*dk2ks-bis* . dk2ks-si12*sxp+sis*sxp)*aml2)*aml)/amp2 tm3(4,3,n)=((((sxp*ta-ym)*sis-(sxp*ta-y)*sir+2.*bi12*dk2ks . *ta+6.*shi2-2.*si12*sxp*ta)+4.*aml2*si12)*aml)/amp2 tm3(4,4,n)=(-(2.*si12-sir+sis)*aml*ta)/amp2 tm3(6,1,n)=(-3.*(apn*sxp-apq*sx)*hi2)/amp tm3(6,2,n)=(-3.*(2.*(apn*bir+eir*sxp)*aml2-(2.*bi12*sxp*ta . -bi1pi2*sx)*apn+(bi1pi2*sxp+2.*hi2)*apq+2.*ehi2*sx))/(2.* . amp) tm3(6,3,n)=(-3.*(8.*aml2*ei12-apn*bi1pi2-apq*bi12*ta-ei12* . sx*ta-ei1pi2*sxp))/(2.*amp) 30 continue tm3(1,1,n)=-4.*(2.*aml2-y)*hi2 tm3(1,2,n)=4.*hi2*ta tm3(1,3,n)=-2.*(2.*bb+bi12*ta**2) tm3(2,1,n)=(((sxp**2-sx**2)-4.*amp2*y)*hi2)/(2.*amp2) tm3(2,2,n)=(2.*aml2*bir*sxp-4.*amp2*hi2*ta-bi12*sxp**2*ta+ . bi1pi2*sxp*sx+2.*hi2*sx)/(2.*amp2) tm3(2,3,n)=(2.*(2.*bb+bi12*ta**2)*amp2+4.*aml2*bi12-bi12* . sx*ta-bi1pi2*sxp)/(2.*amp2) return end +deck,qqint. ****************** qqint ************************************** subroutine qqint(mi,ma,it,ir,ot,res) implicit real*8(a-h,o-z) external rv2di,rv2dia +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. common/tttrr/ttr dimension am(2),bm(2),tlm(4),rrm(4),wrk(500) tlm(1)=log(xs+tamin) tlm(4)=log(xs+tamax) tlm(2)=log(xs-y/s) tlm(3)=log(xs+y/x) rrm(1)=1d-10 rrm(4)=w2-amc2-1d-10 rrm(2)=w2-1.5**2 rrm(3)=w2-1.215**2 res=0. do 10 i=1,it ii=i+1 if(i.eq.it)ii=4 am(1)=tlm(i) bm(1)=tlm(ii) do 10 j=1,ir jj=j+1 if(j.eq.ir)jj=4 if(rrm(jj).le.rrm(j))then rrm(jj)=rrm(j) tai=0. goto 11 endif am(2)=rrm(j) bm(2)=rrm(jj) id=1 mir=mi call d01fce(2,am,bm,mir,ma,rv2di,ot,otr,500,wrk,re,id) c call simpdo(am(1),bm(1),1d-2,100,am(2),bm(2),1d-3,200,rv2dia,re) tai=an*alfa/pi*re res=res+tai 11 write(9,'(1x,''tai:'',2i3,2g13.4,2i5)')i,j,tai,otr,mir,id c write(*,'(1x,''tai:'',2i3,2g13.4,2i5)')i,j,tai,otr,mir,id 10 continue write(9,'(1x,''result:'',g13.4)')res c write(*,'(1x,''result:'',g13.4)')res return end +deck,rv2di. ****************** rv2di ************************************** double precision function rv2dia(xx) implicit real*8(a-h,o-z) common/simpc/x dimension z(2) z(1)=x z(2)=xx rv2dia=rv2di(2,z) end double precision function rv2di(ndim,z) c c integrand (over ta ) c implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comtail. +seq,comppi. common/tttrr/ttr dimension sfm(8),sfm0(8),tm(8,6) dimension z(ndim) ta=ddexp(z(1))-xs r=z(2)/(1.+ta) call strf(0d0,0d0,sfm0) call tails(ta,tm) call strf(ta ,r,sfm) podinl=0. do 11 isf=isf1,isf2,isf3 ppol=1. if(isf.eq.3.or.isf.eq.4)ppol=-pn if(isf.ge.5)ppol=qn/6 do 1 irr=1,i1(isf)+i2(isf)-1 pp=sfm(isf) if(irr.eq.1.and.ita.eq.1)pp=pp-sfm0(isf)*(1.+r*ta/y)**2 pres=pp*r**(irr-2)/(y+r*ta)**2/2. podinl=podinl-tm(isf,irr)*pres*ppol 1 continue 11 continue rv2di=podinl*(xs+ta)/(1.+ta) c rv2di=0. 3 format(3e12.6,i6) return end +deck,rv2ln. ****************** rv2ln ************************************** double precision function rv2ln(taln) c c integrand (over ta ) c implicit real*8(a-h,o-z) external podinl +seq,comcmp. +seq,comsxy. +seq,comtail. common/amf2/taa,tm(8,6),sfm0(8) +seq,comppi. ta=ddexp(taln)-y/sx taa=ta cccc call strf(0d0,0d0,sfm0) call tails(ta,tm) rmin=1d-8 rmax=(w2-amc2)/(1.+ta) if(ita.eq.1)then c call qvnc8(podinl,rmin,rmax,1d-4,1d-9,res,er,nn,fl,3500) call dqn32(rmin,rmax,podinl,res) else aa=amt/amp if(ita.eq.3)aa=1. res=podinl((sx-y/aa)/(1d0+ta/aa))/(1.+ta/aa) /aa**2 endif rv2ln=res*(y/sx+ta) return end +deck,podinl. ****************** podinl ************************************* double precision function podinl(r) c c integrand (over r ) c implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comtail. +seq,comppi. common/amf2/ta,tm(8,6),sfm0(8) dimension sfm(8),iel(8) data iel/0,2,1,2,2,4,2,3/ call strf(ta ,r,sfm) podinl=0. do 11 isf=isf1,isf2,isf3 ppol=1. if(isf.eq.3.or.isf.eq.4)ppol=-pn if(isf.ge.5)ppol=qn/6 if(ita.eq.2)ppol=ppol*(amt/amp)**iel(isf) do 1 irr=1,i1(isf)+i2(isf)-1 pp=sfm(isf) if(irr.eq.1.and.ita.eq.1)pp=pp-sfm0(isf)*(1.+r*ta/y) pres=pp*r**(irr-2)/(y+r*ta)**2/2. podinl=podinl-tm(isf,irr)*pres*ppol 1 continue 11 continue aa=1. t=y+ta*(sx-y/aa)/(1d0+ta/aa) sxsx=(s**2+x**2)/s/x si=sxsx*(sfm(1)- .5 *sfm(2)) c write (10,'(1x,2f15.8,5f13.4)')ta,t,podinl,si t1=tm(1,1)/r+tm(1,2)+r*tm(1,3) t2=tm(2,1)/r+tm(2,2)+r*tm(2,3) c write (10,'(1x,2f15.8,5f13.4)')ta,t,sxsx,t1,t2 return end +deck,rv2. ****************** rv2 **************************************** double precision function rv2(ta) c c integrand (over ta ) c implicit real*8(a-h,o-z) external podinl +seq,comcmp. +seq,comsxy. +seq,comtail. common/amf2/taa,tm(8,6),sfm0(8) +seq,comppi. taa=ta cccc call strf(0d0,0d0,sfm0) call tails(ta,tm) rmin=1d-8 rmax=(w2-amc2)/(1.+ta) if(ita.eq.1)then c call qvnc8(podinl,rmin,rmax,1d-4,1d-9,res,er,nn,fl,3500) call dqn32(rmin,rmax,podinl,res) else aa=amt/amp if(ita.eq.3)aa=1. res=podinl((sx-y/aa)/(1d0+ta/aa))/(1.+ta/aa) /aa**2 endif rv2=res return end +patch, sirad. c definition of some common-dimension-parameter statements. +keep, impl. implicit real*8(a-h,o-z) +keep, energy. c ener - beam energy (gev) c sm - mass of scattered lepton (gev) c se - mass of another light lepton, giving contribution c to the polarization of the vacuum (gev) c st - mass of tau- lepton, giving contribution c to the polarization of the vacuum (gev) c sn - mass of the target nucleon (gev) c sh - mass of the registered hadron (gev) common /energy/ener,sm,se,st,sn,sh c plep=-1 corresponds to the helicity of lepton =-1 c pnuc=-1 corresponds to the helicity of nucleon =+1 c pnuc=+1 corresponds to the helicity of nucleon =-1 c plep = -1.d0 c pnuc = plep +keep, polar. common /polar/plep,pnuc +keep, kinlimqq. c e' > ens0 [gev] (e' - energy of scattered lepton) c q**2 > qq0 [(gev/c)**2] common /qso/qq0,ens0 +keep, kinlimz. c z0 - minimal value of z ( z > z0 ) c zmax - maximal value of z ( z < zmax ) common /zo/z0,zmax +keep, anglelim. c ftetmn - minimal value of sin(teta)**2/(2*pn) c ftetmx - maximal value of sin(teta)**2/(2*pn) c teta - the angle between the momentum of registered c hadron and the beam direction in lab. frame common /angle/ftetmn,ftetmx +keep, comval. c some often used variables. in particular ds and dp are the c unpolarized and polarized parts of the born cross section. common /cusedv/ss,pm,pe,pt,pn,px,x,y,z,qq,ds,dp,rio +keep, comvalr. c other often used variables. common /rnval/r3,r4,r5,r6,r7,r8,r9 +keep, intlim. c the limits defining the phase space of the emitted photon. common /rflim/rp,rm,tami,tam,tbm,tad,tau1,tau2,tbd,tbu +keep, comres. c some common results. in particular dcs and dcp are the c unpolarized and polarized parts of the radiative corrected c cross section. common /rez/dlvr,expn,wss,wsp,dcs,dcp +keep, comint. c epss is the absolute uncertainty of internal integrals c over the phase space of the emitted photon. c epsr is the relative uncertainty of calculated integrals. common /uncert/epss,epsr c ndim is the maximal number of points used to calculate c one-dimension integrals. c ier numbers the types of integrals over the c phase space of the emitted photon. common /numint/ndim,ier +keep, comiff. c iff is used for splitting the phase space of the emitted c photon on isotropic and nonisotropic parts. c ifpeak is used for splitting the cross section of the emitted c photon on contributions to the k1 and k2 peaks. common /iffemf/iff,ifpeak +keep, splnarr. c definition of arrays for spline approximation of the c fragmentation functions. common /dzii/xz,yq,bq,cq,dq parameter (nn=101) dimension xz(nn),yq(6,nn),bq(6,nn),cq(6,nn),dq(6,nn) +keep, alphapi. c aa is the fine structure constant. c pi is the constant pi. parameter (aa=0.72972d-2) parameter (pi=0.314159d1) +keep, inoutdim. c npmax defines maximum "x-,y(q**2)-,z-" dimensions of the input c and output arrays. parameter (npmax=1000) c npoi - number of used {x,y(q**2),z} - points common /point/npoi +keep, inarr. c xm, ym, zm, - input arrays of x,y(q**2),z values common /inarr/xm,ym,zm c definition of the input arrays. real*4 xm(npmax),ym(npmax),zm(npmax) +keep, someinty. call dqwnc8(fys,ymin,ymax,eps1,epsr,dys,er,nn,fer,ndim) ier=7 call nii(fer) call dqwnc8(f0ys,ymin,ymax,eps1,epsr,d0ys,er,nn,fer,ndim) ier=9 call nii(fer) +keep, beginning. call input ndim=10000 epsr=0.1d-3 +keep, dsnorm. data barn/0.389379d6/ dsnorm=barn*(2.d0*pi*aa**2)/ss +keep, crsec. c unpolarized cross section dscor=dsnorm*fys(y) c unpolarized born cross section dsborn=dsnorm*ds c polarized part of cross section dpcor=dsnorm*fyp(y) c polarized part of cross section dpborn=dsnorm*dp +keep, iycrsec. c unpolarized cross section dscor=dsnorm*dys c unpolarized born cross section dsborn=dsnorm*d0ys c polarized part of cross section dpcor=dsnorm*dyp c polarized part of cross section dpborn=dsnorm*d0yp +keep, asval. c born asymmetry a0val=(-dpborn/dsborn)*100. c measured asymmetry arval=(-dpcor/dscor)*100. c radiative correction for asymmetry dasval=(arval/a0val-1.)*100. +keep, corcrsec. c correction to the unpolarized cross section cords=(dscor/dsborn - 1.)*100. c correction to the polarized part of cross section cordp=(dpcor/dpborn - 1.)*100. +keep, ftetlim. c ftetmn - minimal value of sin(teta)**2/(2*pn) c ftetmx - maximal value of sin(teta)**2/(2*pn) c teta - the angle between the momentum of registered c hadron and the beam direction in lab. frame ftetmn=sin(tetmin)**2/(2.d0*pn) ftetmx=sin(tetmax)**2/(2.d0*pn) +keep, ylim. ymin1=qq0/ss/x ymin2=px/(1.d0-x)*(1.d0+1.d-7) ymin3=(1.d0-4.d0*pm*pn)/(1.d0+pn*x+(pm+ftetmx)/x) ymin=max(ymin1,ymin2,ymin3) ymin=ymin*(1.d0+1.d-9) ymax1=1.d0-ens0/ener ymax2=(1.d0-4.d0*pm*pn)/(1.d0+pn*x+(pm+ftetmn)/x) ymax=min(ymax1,ymax2) ymax=ymax*(1.d0-1.d-9) +keep, ylimits. x=xm(np) +seq, ylim. if(ymin.ge.ymax) then print 111, x 111 format(1x,'warning! point x =',e15.3, * 'lies out of the kinematics') go to 1 end if y=0.5d0*(ymax+ymin) qq=x*y +keep, xylimits. +seq, ylim. if(ymin.ge.y.or.y.ge.ymax) then print 112, x,y 112 format(1x,'warning! point x =',e15.6,' y =', * e15.6,'lies out of the kinematics') go to 1 end if +keep, blank. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +deck, mainprg. c main program. calculation of asymmetry or r(z). program sirad +cde, impl. +cde, energy. +cde, kinlimqq. +cde, kinlimz, if=intdz. +cde, anglelim. +cde, comval. +cde, comint. +seq, inoutdim. +seq, inarr. +seq, alphapi, if=-outfun_r. +self, if=outfun_a, if=intdy. external fys,fyp,f0ys,f0yp +self, if=outfun_r. external fys,f0ys common /dzif/ifdz ccc----------------------------------------------------------------------------- +self, if=outfun_a, if=-intdy, if=-intdz. +seq, beginning. +seq, dsnorm. write(7,'(1x,5x,''x'', 6x,''y'', 4x,''q**2'',6x,''z'', *6x,''A1'',5x,''rc a1'', *5x,''born'',5x,''meas'')') do 1 np=1,npoi z=zm(np) x=xm(np) if(ym(np).gt.0.d0) then y=ym(np) qq=x*y else qq=-ym(np)/ss y=qq/x endif +seq, xylimits. xval=x yval=y zval=z qqval=ss*qq +seq, crsec. +seq, corcrsec. +seq, asval. c virtual photon asymmetry a1 delf=y*(2.d0-y)/(y**2+2.d0*(1.d0-y-pn*qq)) a1val=arval/delf print 103, x,y,z,a1val,dasval,a0val,arval, * cords,cordp 103 format(1x,' x = ',e15.6/ * 1x,' y = ',e15.6/ * 1x,' z = ',e15.6/ * 1x,' a1 = ',e15.6/ * 1x,'das = ',e15.6/ * 1x,' a0 = ',e15.6/ * 1x,' ar = ',e15.6/ * 1x,' ds = ',e15.6/ * 1x,' dp = ',e15.6//) write(7,'(1x,4F7.3,4f9.3)') xval,yval,qqval,zval, *a1val,dasval,a0val,arval write(21,'(1x,4f7.3,2f9.3)') xval,yval,qqval,zval, *cords,dscor write(23,'(1x,4f7.3,2f9.3)') xval,yval,qqval,zval, *cordp,dpcor 1 continue ccc------------------------------------------------------------------------- +self, if=outfun_a, if=intdy, if=-intdz. +seq, beginning. +seq, dsnorm. write(7,'(1x,5x,''x'',6x,''z'', *8x,''rc A1'', *5x,''born'',5x,''meas'')') do 1 np=1,npoi z=zm(np) +seq, ylimits. call dos eps1=dabs(ds)*1.d-4 call dop eps2=dabs(dp)*1.d-4 +seq, someinty. call dqwnc8(fyp,ymin,ymax,eps2,epsr,dyp,er,nn,fer,ndim) ier=8 call nii(fer) call dqwnc8(f0yp,ymin,ymax,eps2,epsr,d0yp,er,nn,fer,ndim) ier=10 call nii(fer) xval=x zval=z +seq, iycrsec. +seq, corcrsec. +seq, asval. print 101, x,z,dasval,a0val,arval, * cords,cordp 101 format(1x,' x = ',e15.6/ * 1x,' z = ',e15.6/ * 1x,'das = ',e15.6/ * 1x,' a0 = ',e15.6/ * 1x,' ar = ',e15.6/ * 1x,' ds = ',e15.6/ * 1x,' dp = ',e15.6//) write(7,'(1x,2f7.3,3f9.3)') xval,zval, *dasval,a0val,arval write(21,'(1x,2f7.3,2f9.3)') xval,zval, *cords,dscor write(23,'(1x,2f7.3,2f9.3)') xval,zval, *cordp,dpcor 1 continue ccc---------------------------------------------------------------------------- +self, if=outfun_a, if=-intdy, if=intdz. +seq, beginning. +seq, dsnorm. write(7,'(1x,5x,''x'',6x,''y'',4x,''q**2'', *6x,''A1'',5x,''rc A1'', *5x,''born'',5x,''meas'')') call idzi z=z0 do 1 np=1,npoi x=xm(np) if(ym(np).gt.0.d0) then y=ym(np) qq=x*y else qq=-ym(np)/ss y=qq/x endif +seq, xylimits. xval=x yval=y qqval=ss*qq +seq, crsec. +seq, corcrsec. +seq, asval. c virtual photon asymmetry a1 delf=y*(2.d0-y)/(y**2+2.d0*(1.d0-y-pn*qq)) a1val=arval/delf print 103, x,y,a1val,dasval,a0val,arval, * cords,cordp 103 format(1x,' x = ',e15.6/ * 1x,' y = ',e15.6/ * 1x,' a1 = ',e15.6/ * 1x,'das = ',e15.6/ * 1x,' a0 = ',e15.6/ * 1x,' ar = ',e15.6/ * 1x,' ds = ',e15.6/ * 1x,' dp = ',e15.6//) write(7,'(1x,3f7.3,4f9.3)') xval,yval,qqval, *a1val,dasval,a0val,arval write(21,'(1x,3f7.3,2f9.3)') xval,yval,qqval, *cords,dscor write(23,'(1x,3f7.3,2f9.3)') xval,yval,qqval, *cordp,dpcor 1 continue ccc---------------------------------------------------------------------------- +self, if=outfun_a, if=intdy, if=intdz. +seq, beginning. +seq, dsnorm. write(7,'(1x,5x,''x'', *6x,''rc A1'', *5x,''born'',4x,''meas'')') call idzi z=z0 do 1 np=1,npoi +seq, ylimits. call dos eps1=dabs(ds)*1.d-4 call dop eps2=dabs(dp)*1.d-4 +seq, someinty. call dqwnc8(fyp,ymin,ymax,eps2,epsr,dyp,er,nn,fer,ndim) ier=8 call nii(fer) call dqwnc8(f0yp,ymin,ymax,eps2,epsr,d0yp,er,nn,fer,ndim) ier=10 call nii(fer) xval=x +seq, iycrsec. +seq, corcrsec. +seq, asval. print 101, x,dasval,a0val,arval, * cords,cordp 101 format(1x,' x = ',e15.6/ * 1x,'das = ',e15.6/ * 1x,' a0 = ',e15.6/ * 1x,' ar = ',e15.6/ * 1x,' ds = ',e15.6/ * 1x,' dp = ',e15.6//) write(7,'(1x,f7.3,3f9.3)') xval, *dasval,a0val,arval write(21,'(1x,f7.3,2f9.3)') xval, *cords,dscor write(23,'(1x,f7.3,2f9.3)') xval, *cordp,dpcor 1 continue ccc--------------------------------------------------------------------------- +self, if=outfun_r. +seq, beginning. write(7,'(1x,5x,''x'',6x,''z'', *8x,''r(z)'',2x,''rc r(z)''3x,''born r'')') do 1 np=1,npoi z=zm(np) +seq, ylimits. call dos eps1=dabs(ds)*1.d-4 ifdz=1 +seq, someinty. rr2=dys r02=d0ys ifdz=ifdz+1 +seq, someinty. rr1=dys r01=d0ys xval=x zval=z c value r(z) rval=(rr1/rr2)*100. c value r(z) in the born approximation r0val=(r01/r02)*100. c rc for r(z) drval=(rval/r0val-1.)*100. print 102, x,z,rval,drval,r0val 102 format(1x,' x = ',e15.6/ * 1x,' z = ',e15.6/ * 1x,' r = ',e15.6/ * 1x,' dr = ',e15.6/ * 1x,' r0 = ',e15.6//) write(7,'(1x, 5e15.6)') xval,zval, *rval,drval,r0val 1 continue ccc---------------------------------------------------------------------------- +self. close (unit=22) stop end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +deck, comvar. c subroutine comvar defines some often used variables and c the limits for the phase space of the emitted photon. subroutine comvar +cde, impl. +cde, comval. +cde, comvalr. +cde, anglelim. +cde, intlim. +cde, comres. +cde, polar, if=eweak. +seq, alphapi. +self, if=eweak. external dz +self. r1=1.d0-qq**2-y*(1.d0-qq) r2=1.d0-y-pn*qq r3=1.d0-y+qq r4=1.d0-qq r5=1.d0-y r6=y+2.d0*pn r7=1.d0-2.d0*x r8=pn*x r9=pn+y-qq tam=y*(1.d0-x) - px d=y**2+4.d0*pn*qq sqd=dsqrt(d) arr=2.d0*r9 rp=(2.d0*pn+y+sqd)/arr rm=(2.d0*pn+y-sqd)/arr tbm=y*(1.d0-z) d3=y*(x*r2-pm*(4.d0*r8+y)) dfr=dsqrt(d3/ftetmx) tam1=r4*(y-dfr) if(tam1.le.0.d0) tam1=1.d-40 tam2=r3*(y-dfr)/(1.d0-y+dfr) if(tam2.le.0.d0) tam2=1.d-40 tau1=min(tam,tam1,tbm/rm) tau2=min(tam,tam2,tbm/rm) tami=min(tau1,tau2,tbm/rp) tad=tami*1.d-7 rio=1.d0/sqd slm=dlog(qq/pm) sle=dlog(qq/pe) c contribution of tau-lepton to the vacuum polarization altau=dsqrt(qq**2+4.d0*pt*qq) slt=dlog((altau+qq)/(altau-qq))/altau vptau=2.d0/3.d0*(qq+2.d0*pt)*slt - 10.d0/9.d0 + +(8.d0/3.d0)*(pt/qq)*(1.d0-2.d0*pt*slt) c c contribution of the quarks to the vacuum polarization c calculates the subroutine vpqrk c rvr=-0.5d0*dlog(r3/r4)**2 + 13.d0/6.d0*slm + 2.d0/3.d0* *sle - 38.d0/9.d0 + vptau + (pi/aa)*vpqrk(ss*qq) + +fsp(r2/r1) - pi**2/6.d0 dlvr=aa/pi*((slm-1.d0)*dlog(tami**2/r1) + rvr) expn=(tami**2/r1)**(aa/pi*(slm-1.d0)) wss=0.d0 wsp=0.d0 +self, if=eweak. c qlep corresponds to the charge of lepton c plep=-1 corresponds to the helicity of lepton =-1 c pnuc=-1 corresponds to the helicity of nucleon =+1 c pnuc=+1 corresponds to the helicity of nucleon =-1 qlep = 1.d0 c plep = -1.d0 c pnuc = plep c mean value of the weak "unpolarized" part of ds. wss=(dsws(qlep,plep,pnuc,dz)+ +dsws(qlep,plep,-pnuc,dz))/2.d0 +self, if=eweak, if=-outfun_r. c mean value of the weak "polarized" part of ds. wsp=(dsws(qlep,plep,pnuc,dz)- -dsws(qlep,plep,-pnuc,dz))/2.d0 +self. return end ccc---------------------------------------------------------------------------- +deck, vpqrk. c subroutine vpqrk calculates c contribution of the quarks to the vacuum polarization: c 2*re(prop. of foton) function vpqrk(qsq) +cde, impl. dqsq = dsqrt(qsq) if(dqsq.le.2.d0) then a = 0.d0 b = 0.00228770d0 c = 4.08041425d0 else if(dqsq.le.4.d0) then a = 0.d0 b = 0.00251507d0 c = 3.09624477d0 else if(dqsq.le.10.d0) then a = 0.d0 b = 0.00279328d0 c = 2.07463133d0 else if(dqsq.le.91.2d0) then a = 0.00122270d0 b = 0.00296694d0 c = 1.d0 else if(dqsq.le.1.d5) then a = 0.00164178d0 b = 0.00292051d0 c = 1.d0 else print '(1x, ''the value q**2 is too large to fit the * contribution of the quarks to the vacuum polarization'')' stop end if vpqrk = 2.d0*(a + b*dlog(1.d0 + c*dabs(qsq))) return end ccc----------------------------------------------------------------------------- +deck, fsp. c fsp(x) is the spence function function fsp(x) +cde, impl. data f1/1.644934/ if(x)8,1,1 1 if(x-.5)2,2,3 2 fsp=fsp1(x) return 3 if(x-1.)4,4,5 4 fsp=f1-dlog(x)*dlog(1.-x+1.e-10)-fsp1(1.-x) return 5 if(x-2.)6,6,7 6 fsp=f1-.5*dlog(x)*dlog((x-1.)**2/x)+fsp1(1.-1./x) return 7 fsp=2.*f1-.5*dlog(x)**2-fsp1(1./x) return 8 if(x+1.)10,9,9 9 fsp=-.5*dlog(1.-x)**2-fsp1(x/(x-1.)) return 10 fsp=-.5*dlog(1.-x)*dlog(x**2/(1.-x))-f1+fsp1(1./(1.-x)) return end ccc----------------------------------------------------------------------------- +deck, fsp1. c fsp1(x) is necessary for the spence function calculation function fsp1(x) +cde, impl. f=0.0 a=1. an=0.0 tch=1.e-16 1 an=an+1. a=a*x b=a/an**2 f=f+b if(b-tch)2,2,1 2 fsp1=f return end ccc----------------------------------------------------------------------------- +deck, exhh. c subroutine exhh makes exchange of variables for c smoothing the integrand. subroutine exhh(ts,v,d,tb,ggs) +cde, impl. +cde, intlim. x(ts)=(ts-v)/d f(ts)=dlog(x(ts)+dsqrt(x(ts)**2+1.d0)) fu=f(tbu) fd=f(tbd) abs=((ts-tbd)*fu+(tbu-ts)*fd)/(tbu-tbd) tb=v+d*dsinh(abs) ggs=(fu-fd)*d*dcosh(abs)/(tbu-tbd) if(tb.gt.tbu) tb=tbu if(tb.lt.tbd) tb=tbd return end ccc----------------------------------------------------------------------------- +deck, qxt. c subroutine qxt defines some variables used for integration c over the phase space of the emitted photon. subroutine qxt(ta,tb,qqt,xt,yt,zt,rt,ytp) +cde, impl. +cde, comval. qqt=qq+ta-tb yt=y-tb xt=qqt/yt zt=z*y/yt rt=ta-tb ytp=y+tb return end ccc----------------------------------------------------------------------------- +deck, integ. c subroutine integ defines some integrals c over azimuthal angle of the emitted photon. subroutine integ(ta,tb,ri1,ri2,q1,q2,qd1,qd2) +cde, impl. +cde, comval. +cde, comvalr. a=ta-r4*tb b=r5*ta-r3*tb c=4.d0*pm*(r6*ta*tb - pn*ta*ta - r9*tb*tb) rd1=dsqrt(a**2+c) rd2=dsqrt(b**2+c) ri1=1.d0/rd1 ri2=1.d0/rd2 q1=y*((1.d0+2.d0*r8)*ta-(r7+x*r6)*tb)*ri1**3 q2=y*((r5-2.d0*r8)*ta-(r5*r7-x*r6)*tb)*ri2**3 rd0=dsqrt(qq*(qq + 4.d0*pm))*ta dlc=4.d0*pm*(qq*(ta+tb) + pn*(ta-tb) - y*tb) qd1=(-r4*((1.d0+qq)*ta-r4*tb) + dlc)/ /(rd0*(rd1+rd0))*ri1 qd2=(-r3*((r5-qq)*ta-r3*tb) + dlc)/ /(rd0*(rd2+rd0))*ri2 return end ccc----------------------------------------------------------------------------- +deck, sigma. c function sigma defines usual for qpm contraction of c fragmentation and distribution functions function sigma(x,z,qq2,qu) +cde, impl. dimension fq(3),uds(6),dhz(6) fq(1)=2.d0/3.d0 fq(2)=1.d0/3.d0 fq(3)=1.d0/3.d0 call qu(x,qq2,uds) call dz(z,dhz) sg=0.d0 do 1 i=1,3 ii=2*i iii=ii-1 1 sg=sg+fq(i)**2*(uds(iii)*dhz(iii)+uds(ii)*dhz(ii)) sigma=sg return end ccc----------------------------------------------------------------------------- +deck, nii. c subroutine nii checks the error code when the integrals c over the phase space of the emitted photon are calculated. subroutine nii(fer) +cde, impl. common /numint/ndim,ier if(fer.ne.0.d0) then print '(1x,''warning! the integral of type '',i2/ *1x,''is not calculated correctly ,fl = '',e15.8)', ier,fer pause end if return end ccc----------------------------------------------------------------------------- +deck, dz. c subroutine dz defines the fragmentation functions. subroutine dz(zi,dhz) +cde, impl. dimension dhz(6) +cde, kinlimz, if=intdz. +seq, splnarr, if=intdz. z=zi if(dabs(1.d0-z).lt.1.d-12) z=z-1.d-9 +self, if=intdz. yty=z0/z do i=1,6 dhz(i)=seval(6,nn,i,z,xz,yq,bq,cq,dq)*yty end do +self, if=-intdz. call fitdz(z,dhz) +self. return end ccc----------------------------------------------------------------------------- +deck, fitdz. c subroutine fitdz defines fit for the fragmentation functions. subroutine fitdz(z,dhz) +cde, impl. dimension dhz(6) +self, if=outfun_r. common /dzif/ifdz goto(1,2), ifdz +self, if=ffrg_aub, if=pi_plus, outfun_r. c j.j. aubert et all. phys. lett. v. 160b. p.417 pi+ 1 dpu=0.7d0*(1.d0-z)**1.75d0/z dpd=dpu*(1.d0-z)/(1.d0+z) dhz(1)=dpu dhz(2)=dpd dhz(3)=dpd dhz(4)=dpu dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_aub, if=pi_minus, outfun_r. c j.j. aubert et all. phys. lett. v. 160b. p.417 pi- 2 dpu=0.7d0*(1.d0-z)**1.75d0/z dpd=dpu*(1.d0-z)/(1.d0+z) dhz(1)=dpd dhz(2)=dpu dhz(3)=dpu dhz(4)=dpd dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_aub, if=pi_zero. c j.j. aubert et all. phys. lett. v. 160b. p.417 pi^0 dpu=0.7d0*(1.d0-z)**1.75d0/z dpd=dpu*(1.d0-z)/(1.d0+z) dpmid=(dpu+dpd)/2.d0 dhz(1)=dpmid dhz(2)=dpmid dhz(3)=dpmid dhz(4)=dpmid dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_aub, if=pi_diff. c j.j. aubert et all. phys. lett. v. 160b. p.417 pi+ - pi- dpu=0.7d0*(1.d0-z)**1.75d0/z dpd=dpu*(1.d0-z)/(1.d0+z) dp=dpu-dpd dhz(1)=+dp dhz(2)=-dp dhz(3)=-dp dhz(4)=+dp dhz(5)=0.d0 dhz(6)=0.d0 +self, if=ffrg_cmb, if=pi_plus, outfun_r. c campbell b.a. can. j. phys. 1982. v.60 p.939 pi+ 1 dpd=0.488d0*(1.d0-z)**2/z dpu=0.4247d0*z**0.65d0*(1.d0-z)**1.1d0/z+dpd dhz(1)=dpu dhz(2)=dpd dhz(3)=dpd dhz(4)=dpu dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_cmb, if=pi_minus, outfun_r. c campbell b.a. can. j. phys. 1982. v.60 p.939 pi- 2 dpd=0.488d0*(1.d0-z)**2/z dpu=0.4247d0*z**0.65d0*(1.d0-z)**1.1d0/z+dpd dhz(1)=dpd dhz(2)=dpu dhz(3)=dpu dhz(4)=dpd dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_cmb, if=pi_zero. c campbell b.a. can. j. phys. 1982. v.60 p.939 pi- dpd=0.488d0*(1.d0-z)**2/z dpu=0.4247d0*z**0.65d0*(1.d0-z)**1.1d0/z+dpd dpmid=(dpu+dpd)/2.d0 dhz(1)=dpmid dhz(2)=dpmid dhz(3)=dpmid dhz(4)=dpmid dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_cmb, if=pi_diff. c campbell b.a. can. j. phys. 1982. v.60 p.939 pi+ - pi- dpd=0.488d0*(1.d0-z)**2/z dpu=0.4247d0*z**0.65d0*(1.d0-z)**1.1d0/z+dpd dp=dpu-dpd dhz(1)=+dp dhz(2)=-dp dhz(3)=-dp dhz(4)=+dp dhz(5)=0.d0 dhz(6)=0.d0 +self, if=ffrg_cmb, if=k_minus. c campbell b.a. can. j. phys. 1982. v.60 p.939 k- dku=0.368d0*(1.d0-z)**2.5d0 dkau=0.2124d0*z**(-0.35d0)*(1.d0-z)**1.1d0+dku dks=0.4247d0*z**(-0.35d0)*(1.d0-z)**1.1d0+dku dhz(1)=dku dhz(2)=dkau dhz(3)=dku dhz(4)=dku dhz(5)=dks dhz(6)=dku +self, if=ffrg_cmb, if=k_zero_bar. c campbell b.a. can. j. phys. 1982. v.60 p.939 k_zero_bar dku=0.368d0*(1.d0-z)**2.5d0 dkau=0.2124d0*z**(-0.35d0)*(1.d0-z)**1.1d0+dku dks=0.4247d0*z**(-0.35d0)*(1.d0-z)**1.1d0+dku dhz(1)=dku dhz(2)=dku dhz(3)=dku dhz(4)=dkau dhz(5)=dks dhz(6)=dku +self, if=ffrg_cmb, if=k_plus. c campbell b.a. can. j. phys. 1982. v.60 p.939 k+ dku=0.368d0*(1.d0-z)**2.5d0 dkau=0.2124d0*z**(-0.35d0)*(1.d0-z)**1.1d0+dku dks=0.4247d0*z**(-0.35d0)*(1.d0-z)**1.1d0+dku dhz(1)=dkau dhz(2)=dku dhz(3)=dku dhz(4)=dku dhz(5)=dku dhz(6)=dks +self, if=ffrg_cmb, if=k_zero. c campbell b.a. can. j. phys. 1982. v.60 p.939 k_zero dku=0.368d0*(1.d0-z)**2.5d0 dkau=0.2124d0*z**(-0.35d0)*(1.d0-z)**1.1d0+dku dks=0.4247d0*z**(-0.35d0)*(1.d0-z)**1.1d0+dku dhz(1)=dku dhz(2)=dku dhz(3)=dkau dhz(4)=dku dhz(5)=dku dhz(6)=dks +self, if=ffrg_arn, if=proton. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 proton dimension xz(11),yq(2,11),bq(2,11),cq(2,11),dq(2,11) data xz/ *0.09, 0.13, 0.18, 0.25, 0.35, *0.45, 0.55, 0.65, 0.75, 0.85, 1./ +self, if=ffrg_arn, if=proton, if=targ_h. data ((yq(i,j), j=1,11),i=1,2)/ *0.0195, 0.1551, 0.2205, 0.2367, 0.2270, *0.1132, 0.0676, 0.0435, 0.0244, 0.0064, 0.0, *0.0118, 0.1128, 0.1545, 0.1202, 0.0389, *0.0242, 0.0128, 0.0021, 0.0058, 0.0010, 0.0/ +self, if=ffrg_arn, if=proton, if=targ_d. data ((yq(i,j), j=1,11),i=1,2)/ *0.0051, 0.1617, 0.2168, 0.1604, 0.2265, *0.0819, 0.0551, 0.0360, 0.0165, 0.0094, 0.0, *0.0129, 0.0928, 0.1991, 0.1133, 0.0445, *0.0269, 0.0175, 0.0098, 0.0105, 0.0078, 0.0/ +self, if=ffrg_arn, if=proton, if=targ_he3. data ((yq(i,j), j=1,11),i=1,2)/ *0.0117, 0.1582, 0.2189, 0.1949, 0.2268, *0.0964, 0.0619, 0.0398, 0.0195, 0.0073, 0.0, *0.0122, 0.1026, 0.1701, 0.1172, 0.0414, *0.0280, 0.0147, 0.0030, 0.0073, 0.0012, 0.0/ +self, if=ffrg_arn, if=proton. do i=1,2 call spline(2,11,i,xz,yq,bq,cq,dq) end do dpu=seval(2,11,1,z,xz,yq,bq,cq,dq) dpd=seval(2,11,2,z,xz,yq,bq,cq,dq) dhz(1)=dpu dhz(2)=dpd dhz(3)=dpu dhz(4)=dpd dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_arn, if=a_proton. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 antiproton dimension xz(11),yq(2,11),bq(2,11),cq(2,11),dq(2,11) data xz/ *0.09, 0.13, 0.18, 0.25, 0.35, *0.45, 0.55, 0.65, 0.75, 0.85, 1./ +self, if=ffrg_arn, if=a_proton, if=targ_h. data ((yq(i,j), j=1,11),i=1,2)/ *0.0195, 0.1551, 0.2205, 0.2367, 0.2270, *0.1132, 0.0676, 0.0435, 0.0244, 0.0064, 0.0, *0.0118, 0.1128, 0.1545, 0.1202, 0.0389, *0.0242, 0.0128, 0.0021, 0.0058, 0.0010, 0.0/ +self, if=ffrg_arn, if=a_proton, if=targ_d. data ((yq(i,j), j=1,11),i=1,2)/ *0.0051, 0.1617, 0.2168, 0.1604, 0.2265, *0.0819, 0.0551, 0.0360, 0.0165, 0.0094, 0.0, *0.0129, 0.0928, 0.1991, 0.1133, 0.0445, *0.0269, 0.0175, 0.0098, 0.0105, 0.0078, 0.0/ +self, if=ffrg_arn, if=a_proton, if=targ_he3. data ((yq(i,j), j=1,11),i=1,2)/ *0.0117, 0.1582, 0.2189, 0.1949, 0.2268, *0.0964, 0.0619, 0.0398, 0.0195, 0.0073, 0.0, *0.0122, 0.1026, 0.1701, 0.1172, 0.0414, *0.0280, 0.0147, 0.0030, 0.0073, 0.0012, 0.0/ +self, if=ffrg_arn, if=a_proton. do i=1,2 call spline(2,11,i,xz,yq,bq,cq,dq) end do dpu=seval(2,11,1,z,xz,yq,bq,cq,dq) dpd=seval(2,11,2,z,xz,yq,bq,cq,dq) dhz(1)=dpd dhz(2)=dpu dhz(3)=dpd dhz(4)=dpu dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_arn, if=k_minus. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 k- dimension xz(10),yq(2,10),bq(2,10),cq(2,10),dq(2,10) data xz/ *0.08, 0.13, 0.18, 0.25, 0.35, *0.45, 0.55, 0.65, 0.75, 1./ +self, if=ffrg_arn, if=k_minus, if=targ_h. data ((yq(i,j), j=1,10),i=1,2)/ *0.456, 0.396, 0.678, 0.425, 0.238, *0.167, 0.093, 0.055, 0.054, 0.0, *0.424, 0.312, 0.276, 0.133, 0.098, *0.040, 0.021, 0.017, 0.014, 0.0/ +self, if=ffrg_arn, if=k_minus, if=targ_d. data ((yq(i,j), j=1,10),i=1,2)/ *0.363, 0.610, 0.543, 0.457, 0.287, *0.167, 0.125, 0.113, 0.119, 0.0, *1.154, 0.460, 0.289, 0.217, 0.114, *0.071, 0.039, 0.036, 0.028, 0.0/ +self, if=ffrg_arn, if=k_minus, if=targ_he3. data ((yq(i,j), j=1,10),i=1,2)/ *0.448, 0.448, 0.614, 0.436, 0.253, *0.167, 0.102, 0.064, 0.038, 0.0, *0.496, 0.355, 0.282, 0.156, 0.103, *0.048, 0.025, 0.022, 0.016, 0.0/ +self, if=ffrg_arn, if=k_minus. do i=1,2 call spline(2,10,i,xz,yq,bq,cq,dq) end do dkau=seval(2,10,1,z,xz,yq,bq,cq,dq) dku=seval(2,10,2,z,xz,yq,bq,cq,dq) dks=dkau dhz(1)=dku dhz(2)=dkau dhz(3)=dku dhz(4)=dku dhz(5)=dks dhz(6)=dku +self, if=ffrg_arn, if=k_zero_bar. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 k_zero_bar dimension xz(10),yq(2,10),bq(2,10),cq(2,10),dq(2,10) data xz/ *0.08, 0.13, 0.18, 0.25, 0.35, *0.45, 0.55, 0.65, 0.75, 1./ +self, if=ffrg_arn, if=k_zero_bar, if=targ_h. data ((yq(i,j), j=1,10),i=1,2)/ *0.456, 0.396, 0.678, 0.425, 0.238, *0.167, 0.093, 0.055, 0.054, 0.0, *0.424, 0.312, 0.276, 0.133, 0.098, *0.040, 0.021, 0.017, 0.014, 0.0/ +self, if=ffrg_arn, if=k_zero_bar, if=targ_d. data ((yq(i,j), j=1,10),i=1,2)/ *0.363, 0.610, 0.543, 0.457, 0.287, *0.167, 0.125, 0.113, 0.119, 0.0, *1.154, 0.460, 0.289, 0.217, 0.114, *0.071, 0.039, 0.036, 0.028, 0.0/ +self, if=ffrg_arn, if=k_zero_bar, if=targ_he3. data ((yq(i,j), j=1,10),i=1,2)/ *0.448, 0.448, 0.614, 0.436, 0.253, *0.167, 0.102, 0.064, 0.038, 0.0, *0.496, 0.355, 0.282, 0.156, 0.103, *0.048, 0.025, 0.022, 0.016, 0.0/ +self, if=ffrg_arn, if=k_zero_bar. do i=1,2 call spline(2,10,i,xz,yq,bq,cq,dq) end do dkau=seval(2,10,1,z,xz,yq,bq,cq,dq) dku=seval(2,10,2,z,xz,yq,bq,cq,dq) dks=dkau dhz(1)=dku dhz(2)=dku dhz(3)=dku dhz(4)=dkau dhz(5)=dks dhz(6)=dku +self, if=ffrg_arn, if=k_plus. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 k+ dimension xz(10),yq(2,10),bq(2,10),cq(2,10),dq(2,10) data xz/ *0.08, 0.13, 0.18, 0.25, 0.35, *0.45, 0.55, 0.65, 0.75, 1./ +self, if=ffrg_arn, if=k_plus, if=targ_h. data ((yq(i,j), j=1,10),i=1,2)/ *0.456, 0.396, 0.678, 0.425, 0.238, *0.167, 0.093, 0.055, 0.054, 0.0, *0.424, 0.312, 0.276, 0.133, 0.098, *0.040, 0.021, 0.017, 0.014, 0.0/ +self, if=ffrg_arn, if=k_plus, if=targ_d. data ((yq(i,j), j=1,10),i=1,2)/ *0.363, 0.610, 0.543, 0.457, 0.287, *0.167, 0.125, 0.113, 0.119, 0.0, *1.154, 0.460, 0.289, 0.217, 0.114, *0.071, 0.039, 0.036, 0.028, 0.0/ +self, if=ffrg_arn, if=k_plus, if=targ_he3. data ((yq(i,j), j=1,10),i=1,2)/ *0.448, 0.448, 0.614, 0.436, 0.253, *0.167, 0.102, 0.064, 0.038, 0.0, *0.496, 0.355, 0.282, 0.156, 0.103, *0.048, 0.025, 0.022, 0.016, 0.0/ +self, if=ffrg_arn, if=k_plus. do i=1,2 call spline(2,10,i,xz,yq,bq,cq,dq) end do dkau=seval(2,10,1,z,xz,yq,bq,cq,dq) dku=seval(2,10,2,z,xz,yq,bq,cq,dq) dks=dkau dhz(1)=dkau dhz(2)=dku dhz(3)=dku dhz(4)=dku dhz(5)=dku dhz(6)=dks +self, if=ffrg_arn, if=k_zero. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 k_zero dimension xz(10),yq(2,10),bq(2,10),cq(2,10),dq(2,10) data xz/ *0.08, 0.13, 0.18, 0.25, 0.35, *0.45, 0.55, 0.65, 0.75, 1./ +self, if=ffrg_arn, if=k_zero, if=targ_h. data ((yq(i,j), j=1,10),i=1,2)/ *0.456, 0.396, 0.678, 0.425, 0.238, *0.167, 0.093, 0.055, 0.054, 0.0, *0.424, 0.312, 0.276, 0.133, 0.098, *0.040, 0.021, 0.017, 0.014, 0.0/ +self, if=ffrg_arn, if=k_zero, if=targ_d. data ((yq(i,j), j=1,10),i=1,2)/ *0.363, 0.610, 0.543, 0.457, 0.287, *0.167, 0.125, 0.113, 0.119, 0.0, *1.154, 0.460, 0.289, 0.217, 0.114, *0.071, 0.039, 0.036, 0.028, 0.0/ +self, if=ffrg_arn, if=k_zero, if=targ_he3. data ((yq(i,j), j=1,10),i=1,2)/ *0.448, 0.448, 0.614, 0.436, 0.253, *0.167, 0.102, 0.064, 0.038, 0.0, *0.496, 0.355, 0.282, 0.156, 0.103, *0.048, 0.025, 0.022, 0.016, 0.0/ +self, if=ffrg_arn, if=k_zero. do i=1,2 call spline(2,10,i,xz,yq,bq,cq,dq) end do dkau=seval(2,10,1,z,xz,yq,bq,cq,dq) dku=seval(2,10,2,z,xz,yq,bq,cq,dq) dks=dkau dhz(1)=dku dhz(2)=dku dhz(3)=dkau dhz(4)=dku dhz(5)=dku dhz(6)=dks +self, if=ffrg_arn, if=pi_plus. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 pi+ dimension xz(12),yq(2,12),bq(2,12),cq(2,12),dq(2,12) data xz/ *0.03, 0.07, 0.12, 0.17, 0.24, 0.35, *0.45, 0.55, 0.65, 0.75, 0.85, 1./ +self, if=ffrg_arn, if=pi_plus, if=targ_h. data ((yq(i,j), j=1,12),i=1,2)/ *3.485, 5.746, 4.262, 2.835, 1.736, 0.825, *0.523, 0.275, 0.196, 0.094, 0.051, 0.0, *2.871, 5.089, 3.294, 2.031, 1.033, 0.448, *0.224, 0.091, 0.046, 0.033, 0.013, 0.0/ +self, if=ffrg_arn, if=pi_plus, if=targ_d. data ((yq(i,j), j=1,12),i=1,2)/ *3.519, 5.976, 3.897, 2.922, 1.736, 1.040, *0.582, 0.318, 0.139, 0.075, 0.032, 0.0, *2.744, 4.424, 3.444, 2.020, 1.057, 0.396, *0.209, 0.108, 0.061, 0.079, 0.050, 0.0/ +self, if=ffrg_arn, if=pi_plus, if=targ_he3. data ((yq(i,j), j=1,12),i=1,2)/ *3.495, 5.819, 4.139, 2.862, 1.736, 0.886, *0.542, 0.288, 0.172, 0.087, 0.044, 0.0, *2.832, 4.866, 3.340, 2.028, 1.040, 0.434, *0.220, 0.095, 0.050, 0.042, 0.019, 0.0/ +self, if=ffrg_arn, if=pi_plus. do i=1,2 call spline(2,12,i,xz,yq,bq,cq,dq) end do dpu=seval(2,12,1,z,xz,yq,bq,cq,dq) dpd=seval(2,12,2,z,xz,yq,bq,cq,dq) dhz(1)=dpu dhz(2)=dpd dhz(3)=dpd dhz(4)=dpu dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_arn, if=pi_minus. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 pi- dimension xz(12),yq(2,12),bq(2,12),cq(2,12),dq(2,12) data xz/ *0.03, 0.07, 0.12, 0.17, 0.24, 0.35, *0.45, 0.55, 0.65, 0.75, 0.85, 1./ +self, if=ffrg_arn, if=pi_minus, if=targ_h. data ((yq(i,j), j=1,12),i=1,2)/ *3.485, 5.746, 4.262, 2.835, 1.736, 0.825, *0.523, 0.275, 0.196, 0.094, 0.051, 0.0, *2.871, 5.089, 3.294, 2.031, 1.033, 0.448, *0.224, 0.091, 0.046, 0.033, 0.013, 0.0/ +self, if=ffrg_arn, if=pi_minus, if=targ_d. data ((yq(i,j), j=1,12),i=1,2)/ *3.519, 5.976, 3.897, 2.922, 1.736, 1.040, *0.582, 0.318, 0.139, 0.075, 0.032, 0.0, *2.744, 4.424, 3.444, 2.020, 1.057, 0.396, *0.209, 0.108, 0.061, 0.079, 0.050, 0.0/ +self, if=ffrg_arn, if=pi_minus, if=targ_he3. data ((yq(i,j), j=1,12),i=1,2)/ *3.495, 5.819, 4.139, 2.862, 1.736, 0.886, *0.542, 0.288, 0.172, 0.087, 0.044, 0.0, *2.832, 4.866, 3.340, 2.028, 1.040, 0.434, *0.220, 0.095, 0.050, 0.042, 0.019, 0.0/ +self, if=ffrg_arn, if=pi_minus. do i=1,2 call spline(2,12,i,xz,yq,bq,cq,dq) end do dpu=seval(2,12,1,z,xz,yq,bq,cq,dq) dpd=seval(2,12,2,z,xz,yq,bq,cq,dq) dhz(1)=dpd dhz(2)=dpu dhz(3)=dpu dhz(4)=dpd dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_arn, if=pi_zero. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 pi_zero dimension xz(12),yq(2,12),bq(2,12),cq(2,12),dq(2,12) data xz/ *0.03, 0.07, 0.12, 0.17, 0.24, 0.35, *0.45, 0.55, 0.65, 0.75, 0.85, 1./ +self, if=ffrg_arn, if=pi_zero, if=targ_h. data ((yq(i,j), j=1,12),i=1,2)/ *3.485, 5.746, 4.262, 2.835, 1.736, 0.825, *0.523, 0.275, 0.196, 0.094, 0.051, 0.0, *2.871, 5.089, 3.294, 2.031, 1.033, 0.448, *0.224, 0.091, 0.046, 0.033, 0.013, 0.0/ +self, if=ffrg_arn, if=pi_zero, if=targ_d. data ((yq(i,j), j=1,12),i=1,2)/ *3.519, 5.976, 3.897, 2.922, 1.736, 1.040, *0.582, 0.318, 0.139, 0.075, 0.032, 0.0, *2.744, 4.424, 3.444, 2.020, 1.057, 0.396, *0.209, 0.108, 0.061, 0.079, 0.050, 0.0/ +self, if=ffrg_arn, if=pi_zero, if=targ_he3. data ((yq(i,j), j=1,12),i=1,2)/ *3.495, 5.819, 4.139, 2.862, 1.736, 0.886, *0.542, 0.288, 0.172, 0.087, 0.044, 0.0, *2.832, 4.866, 3.340, 2.028, 1.040, 0.434, *0.220, 0.095, 0.050, 0.042, 0.019, 0.0/ +self, if=ffrg_arn, if=pi_zero. do i=1,2 call spline(2,12,i,xz,yq,bq,cq,dq) end do dpu=seval(2,12,1,z,xz,yq,bq,cq,dq) dpd=seval(2,12,2,z,xz,yq,bq,cq,dq) dpmid=(dpu+dpd)/2.d0 dhz(1)=dpmid dhz(2)=dpmid dhz(3)=dpmid dhz(4)=dpmid dhz(5)=dpd dhz(6)=dpd +self, if=ffrg_arn, if=pi_diff. c arneodo m. et al. nuclear phys. 1989. v.b321 p.541 pi+ - pi- dimension xz(12),yq(2,12),bq(2,12),cq(2,12),dq(2,12) data xz/ *0.03, 0.07, 0.12, 0.17, 0.24, 0.35, *0.45, 0.55, 0.65, 0.75, 0.85, 1./ +self, if=ffrg_arn, if=pi_diff, if=targ_h. data ((yq(i,j), j=1,12),i=1,2)/ *3.485, 5.746, 4.262, 2.835, 1.736, 0.825, *0.523, 0.275, 0.196, 0.094, 0.051, 0.0, *2.871, 5.089, 3.294, 2.031, 1.033, 0.448, *0.224, 0.091, 0.046, 0.033, 0.013, 0.0/ +self, if=ffrg_arn, if=pi_diff, if=targ_d. data ((yq(i,j), j=1,12),i=1,2)/ *3.519, 5.976, 3.897, 2.922, 1.736, 1.040, *0.582, 0.318, 0.139, 0.075, 0.032, 0.0, *2.744, 4.424, 3.444, 2.020, 1.057, 0.396, *0.209, 0.108, 0.061, 0.079, 0.050, 0.0/ +self, if=ffrg_arn, if=pi_diff, if=targ_he3. data ((yq(i,j), j=1,12),i=1,2)/ *3.495, 5.819, 4.139, 2.862, 1.736, 0.886, *0.542, 0.288, 0.172, 0.087, 0.044, 0.0, *2.832, 4.866, 3.340, 2.028, 1.040, 0.434, *0.220, 0.095, 0.050, 0.042, 0.019, 0.0/ +self, if=ffrg_arn, if=pi_diff. do i=1,2 call spline(2,12,i,xz,yq,bq,cq,dq) end do dpu=seval(2,12,1,z,xz,yq,bq,cq,dq) dpd=seval(2,12,2,z,xz,yq,bq,cq,dq) dp=dpu-dpd dhz(1)=+dp dhz(2)=-dp dhz(3)=-dp dhz(4)=+dp dhz(5)=0.d0 dhz(6)=0.d0 +self. return end ccc----------------------------------------------------------------------------- +deck, dos. c subroutine dos defines unpolarized born cross section. subroutine dos +cde, impl. +cde, comval. external qs ds=(2.d0*(1.d0/y-1.d0-pn*x)+y)*sigma(x,z,ss*qq,qs)/qq return end ccc----------------------------------------------------------------------------- +deck, fys. c function fys defines the sum of cross sections with the target c polarization vector parallel and antiparallel to the momentum c vector of the incident lepton. radiative effects are included. function fys(yi) +cde, impl. +cde, comval. +cde, intlim. +cde, comres. +cde, comint. +cde, comiff. external fcs +seq, alphapi. y=yi qq=x*y call comvar call dos eps=dabs(ds)*1.d-4 if(tau1.gt.1.d-7) then epss=eps/tau1 ifpeak=1 iff=1 call dqunc8(fcs,tad,tami,eps,epsr,csa1,er,nn,fera,ndim) ier=11 call nii(fera) iff=2 call dqunc8(fcs,tami,tau1,eps,epsr,csb1,er,nn,ferb,ndim) ier=21 call nii(ferb) cs1=csa1+csb1 else cs1=0.d0 end if if(tau2.gt.1.d-7) then epss=eps/tau2 ifpeak=2 iff=1 call dqunc8(fcs,tad,tami,eps,epsr,csa2,er,nn,fera,ndim) ier=12 call nii(fera) iff=2 call dqunc8(fcs,tami,tau2,eps,epsr,csb2,er,nn,ferb,ndim) ier=22 call nii(ferb) cs2=csa2+csb2 else cs2=0.d0 end if cs=cs1+cs2 dcs=ds+(aa/pi*cs/ds+dlvr)*expn*ds fys=dcs+wss return end ccc----------------------------------------------------------------------------- +deck, f0ys, if=intdy. c function f0ys defines the sum of cross sections with the target c polarization vector parallel and antiparallel to the momentum c vector of the incident lepton. radiative effects are not included. function f0ys(yi) +cde, impl. +cde, comval. y=yi qq=x*y call dos f0ys=ds return end ccc----------------------------------------------------------------------------- +deck, fcs. c function fcs is the integrand of the unpolarized c part of bremssrahlung cross section over invariant c variable corresponding to the energy of the emitted c photon. function fcs(ta) +cde, impl. +cde, comval. +cde, comvalr. +cde, intlim. +cde, comint. common /vd/v1,d1,v2,d2 common /t/ttt external frs ttt=ta a1=r4**2-4.d0*pm*r9 a2=r3**2-4.d0*pm*r9 b1=-2.d0*ta*(r4-2.d0*pm*r6) b2=-2.d0*ta*(r3*r5-2.d0*pm*r6) v1=-b1/a1/2.d0 v2=-b2/a2/2.d0 c1=(1.d0-4.d0*pm*pn)*ta**2 c2=(r5**2-4.d0*pm*pn)*ta**2 d1=dsqrt((c1*a1-b1**2/4.d0)/a1**2) d2=dsqrt((c2*a2-b2**2/4.d0)/a2**2) tbd=ta*rm tbu=ta*rp if(tbu.gt.tbm) tbu=tbm if(tbu-tbd)1,2,1 2 fcs=0.d0 go to 3 1 call dqvnc8(frs,tbd,tbu,epss,epsr,fcs,er,nn,fer,ndim) ier=5 call nii(fer) 3 return end ccc----------------------------------------------------------------------------- +deck, frs. c function frs is the integrand of the unpolarized c part of bremssrahlung cross section over invariant c variable corresponding to the polar angle of the c emitted photon. function frs(ts) +cde, impl. +cde, comval. +cde, comvalr. +cde, comiff. common /vd/v1,d1,v2,d2 common /t/ttt external qs ta=ttt goto(1,2), ifpeak 1 call exhh(ts,v1,d1,tb,gs1) call qxt(ta,tb,qqt,xt,yt,zt,rt,ytp) call integ(ta,tb,ri1,ri2,q1,q2,qd1,qd2) frs1=qqt/yt**2*((-2.d0*pm*q1-ri1-qq*qd1)* *(r5*(1.d0-tb)-pn*qqt+yt**2/2.d0)- *qq*qd1*(r5+tb-pn*qqt+yt**2/2.d0)- *(1.d0+y*r8)*ri1-pn*rio)+0.5d0*(qq*ri1+rio) frs1=frs1*(y/qqt)**2/yt*sigma(xt,zt,ss*qqt,qs) if(iff.eq.1) frs1=frs1-(-qq*qd1-pm*q1)*ds frs=frs1*gs1 return 2 call exhh(ts,v2,d2,tb,gs2) call qxt(ta,tb,qqt,xt,yt,zt,rt,ytp) call integ(ta,tb,ri1,ri2,q1,q2,qd1,qd2) frs2=qqt/yt**2*((-2.d0*pm*q2+ri2+qq*qd2)* *(r5+tb-pn*qqt+yt**2/2.d0)+ *qq*qd2*(r5*(1.d0-tb)-pn*qqt+yt**2/2.d0)+ *(r5**2+y*r8)*ri2-pn*rio)+0.5d0*(-qq*ri2+rio) frs2=frs2*(y/qqt)**2/yt*sigma(xt,zt,ss*qqt,qs) if(iff.eq.1) frs2=frs2-(qq*qd2-pm*q2)*ds frs=frs2*gs2 return end ccc----------------------------------------------------------------------------- +deck, qs. c subroutine qs defines fits for the unpolarized quarks c distribution functions. subroutine qs(xi,qq2,uds) +cde, impl. dimension uds(6),pdf(-6:6) x=xi if(dabs(1.d0-x).lt.1.d-12) x=x-1.d-9 +self,if=f2g1grsv96,if=targ_h. q2m=min(1d4,max(qq2,0.40d0)) q=sqrt(q2m) call pgrv(1,pdf,x, q) uds(1)=pdf(1)/x uds(2)=pdf(-1)/x uds(3)=pdf(2)/x uds(4)=pdf(-2)/x uds(5)=pdf(3)/x uds(6)=pdf(-3)/x return +self,if=f2g1grsv96,if=targ_d. q2m=min(1d4,max(qq2,0.40d0)) q=sqrt(q2m) call pgrv(1,pdf,x, q) uds(1)=(pdf(1)+pdf(2))/x uds(2)=(pdf(-1)+pdf(-2))/x uds(3)=(pdf(1)+pdf(2))/x uds(4)=(pdf(-1)+pdf(-2))/x uds(5)=2.*pdf(3)/x uds(6)=2.*pdf(-3)/x return +self,if=f2g1grsv96,if=targ_he3. q2m=min(1d4,max(qq2,0.40d0)) q=sqrt(q2m) call pgrv(1,pdf,x, q) uds(1)=(2.*pdf(1)+pdf(2))/x uds(2)=(2.*pdf(-1)+pdf(-2))/x uds(3)=(pdf(1)+2.*pdf(2))/x uds(4)=(pdf(-1)+2.*pdf(-2))/x uds(5)=3.*pdf(3)/x uds(6)=3.*pdf(-3)/x return +self, if=f2g1grsv96, if=outfun_r. q2m=min(1d4,max(qq2,0.40d0)) q=sqrt(q2m) call pgrv(1,pdf,x, q) uds(1)=(pdf(1)-pdf(2))/x uds(2)=0. uds(3)=(pdf(2)-pdf(1))/x uds(4)=0. uds(5)=0. uds(6)=0. return +self, if=qdstr_gu, if=targ_h. c s.gupta, et al. z. phys. c. v46. p.111. (1990) (q2 = 5 gev2) c model 1 (i) c for h 31 x1=1.d0-x**1.51d0 uv=1.78d0*x1**3.5d0*x**(-0.5d0) dv=0.67d0*x1**4.5d0*x**(-0.6d0) s=0.364d0*(1.d0-x)**8.54/x c=0.445d0*s uds(1)=uv+s uds(2)=s uds(3)=dv+s uds(4)=s uds(5)=c uds(6)=c return +self, if=qdstr_gu, if=targ_d. c s.gupta, et al. z. phys. c. v46. p.111. (1990) (q2 = 5 gev2) c model 1 (i) c for d 32 x1=1.d0-x**1.51d0 uv=1.78d0*x1**3.5d0*x**(-0.5d0) dv=0.67d0*x1**4.5d0*x**(-0.6d0) s=0.364d0*(1.d0-x)**8.54/x c=0.445d0*s s2=2.d0*s c2=2.d0*c udv=uv+dv uds(1)=udv+s2 uds(2)=s2 uds(3)=udv+s2 uds(4)=s2 uds(5)=c2 uds(6)=c2 return +self, if=qdstr_gu, if=targ_he3. c s.gupta, et al. z. phys. c. v46. p.111. (1990) (q2 = 5 gev2) c model 1 (i) c for he 33 x1=1.d0-x**1.51d0 uv=1.78d0*x1**3.5d0*x**(-0.5d0) dv=0.67d0*x1**4.5d0*x**(-0.6d0) s=0.364d0*(1.d0-x)**8.54/x c=0.445d0*s s3=3.d0*s c3=3.d0*c uds(1)=uv+uv+dv+s3 uds(2)=s3 uds(3)=dv+dv+uv+s3 uds(4)=s3 uds(5)=c3 uds(6)=c3 return +self, if=qdstr_gu, if=outfun_r. c s.gupta, et al. z. phys. c. v46. p.111. (1990) (q2 = 5 gev2) c model 1 (i) c for p - n 53 x1=1.d0-x**1.51d0 uv=1.78d0*x1**3.5d0*x**(-0.5d0) dv=0.67d0*x1**4.5d0*x**(-0.6d0) s=0.d0 uds(1)=uv-dv uds(2)=s uds(3)=dv-uv uds(4)=s uds(5)=s uds(6)=s return +self. end ccc----------------------------------------------------------------------------- +deck, dop, if=-outfun_r. c subroutine dop defines polarized born cross section. subroutine dop +cde, impl. +cde, comval. external qp dp=(y-2.d0)*sigma(x,z,ss*qq,qp)/qq return end ccc----------------------------------------------------------------------------- +deck, fyp, if=-outfun_r. c function fyp defines the difference of cross sections with the c target polarization vector parallel and antiparallel to the c momentum vector of the incident lepton. radiative effects are c included. function fyp(yi) +cde, impl. +cde, comval. +cde, intlim. +cde, comres. +cde, comint. +cde, comiff. +cde, polar. external fcp +seq, alphapi. y=yi qq=x*y call comvar call dop eps=dabs(dp)*1.d-4 if(tau1.gt.1.d-7) then epss=eps/tau1 ifpeak=1 iff=1 call dqunc8(fcp,tad,tami,eps,epsr,cpa1,er,nn,fera,ndim) ier=31 call nii(fera) iff=2 call dqunc8(fcp,tami,tau1,eps,epsr,cpb1,er,nn,ferb,ndim) ier=41 call nii(ferb) cp1=cpa1+cpb1 else cp1=0.d0 end if if(tau2.gt.1.d-7) then epss=eps/tau2 ifpeak=1 iff=1 call dqunc8(fcp,tad,tami,eps,epsr,cpa2,er,nn,fera,ndim) ier=32 call nii(fera) iff=2 call dqunc8(fcp,tami,tau2,eps,epsr,cpb2,er,nn,ferb,ndim) ier=42 call nii(ferb) cp2=cpa2+cpb2 else cp2=0.d0 end if cp=cp1+cp2 dcp=dp+(aa/pi*cp/dp+dlvr)*expn*dp c plep = -1.d0 c pnuc = plep fyp=plep*pnuc*dcp+wsp return end ccc----------------------------------------------------------------------------- +deck, f0yp, if=intdy, if=-outfun_r. c function f0yp defines the difference of cross sections with the c target polarization vector parallel and antiparallel to the c momentum vector of the incident lepton. radiative effects are c not included. function f0yp(yi) +cde, impl. +cde, comval. y=yi qq=x*y call dop c plep = -1.d0 c pnuc = plep f0yp=plep*pnuc*dp return end ccc----------------------------------------------------------------------------- +deck, fcp, if=-outfun_r. c function fcp is the integrand of the polarized part of c bremssrahlung cross section over invariant variable c corresponding to the energy of the emitted photon. function fcp(ta) +cde, impl. +cde, comval. +cde, comvalr. +cde, intlim. +cde, comint. common /vd/v1,d1,v2,d2 common /t/ttt external frp ttt=ta a1=r4**2-4.d0*pm*r9 a2=r3**2-4.d0*pm*r9 b1=-2.d0*ta*(r4-2.d0*pm*r6) b2=-2.d0*ta*(r3*r5-2.d0*pm*r6) v1=-b1/a1/2.d0 v2=-b2/a2/2.d0 c1=(1.d0-4.d0*pm*pn)*ta**2 c2=(r5**2-4.d0*pm*pn)*ta**2 d1=dsqrt((c1*a1-b1**2/4.d0)/a1**2) d2=dsqrt((c2*a2-b2**2/4.d0)/a2**2) tbd=ta*rm tbu=ta*rp if(tbu.gt.tbm) tbu=tbm if(tbu-tbd)1,2,1 2 fcp=0.d0 go to 3 1 call dqvnc8(frp,tbd,tbu,epss,epsr,fcp,er,nn,fer,ndim) ier=6 call nii(fer) 3 return end ccc----------------------------------------------------------------------------- +deck, frp, if=-outfun_r. c function frp is the integrand of the polarized c part of bremssrahlung cross section over invariant c variable corresponding to the polar angle of the c emitted photon. function frp(ts) +cde, impl. +cde, comval. +cde, comiff. common /vd/v1,d1,v2,d2 common /t/ttt external qp ta=ttt goto(1,2), ifpeak 1 call exhh(ts,v1,d1,tb,gs1) call qxt(ta,tb,qqt,xt,yt,zt,rt,ytp) call integ(ta,tb,ri1,ri2,q1,q2,qd1,qd2) frp1=1.d0/yt*((-pm*q1-qq*qd1)*(qq*yt-2.d0*qqt)- *qq**2*tb*qd1- *(qq*(ytp-1.d0)+rt*(ytp/2.d0-1.d0))*ri1) frp1=frp1*(y/qqt)**2/yt*sigma(xt,zt,ss*qqt,qp) if(iff.eq.1) frp1=frp1-(-qq*qd1-pm*q1)*dp frp=frp1*gs1 return 2 call exhh(ts,v2,d2,tb,gs2) call qxt(ta,tb,qqt,xt,yt,zt,rt,ytp) call integ(ta,tb,ri1,ri2,q1,q2,qd1,qd2) frp2=1.d0/yt*((-pm*q2+qq*qd2)*(qq*yt-2.d0*qqt)- *pm*yt*rt*q2+qq**2*tb*qd2+ *(qq*(y+yt-1.d0)+rt*(yt/2.d0-1.d0))*ri2) frp2=frp2*(y/qqt)**2/yt*sigma(xt,zt,ss*qqt,qp) if(iff.eq.1) frp2=frp2-(qq*qd2-pm*q2)*dp frp=frp2*gs2 return end ccc----------------------------------------------------------------------------- +deck, qp, if=-outfun_r. c subroutine qp defines fits for the polarized quarks c distribution functions. subroutine qp(xi,qq2,uds) +cde, impl. dimension uds(6) x=xi if(dabs(1.d0-x).lt.1.d-12) x=x-1.d-9 +self,if=f2g1grsv96,if=targ_h. q2m=min(1d4,max(qq2,0.40d0)) call parpol(3,x,q2m, uv, dv, qb, st, gl, a1p, a1n,a1d) uds(1)=(uv+qb)/x uds(2)=qb/x uds(3)=(dv+qb)/x uds(4)=qb/x uds(5)=st/x uds(6)=st/x return +self,if=f2g1grsv96,if=targ_d. q2m=min(1d4,max(qq2,0.40d0)) call parpol(3,x,q2m, uv, dv, qb, st, gl, a1p, a1n,a1d) pd=0.043d0 ps=1.d0-pd df=ps-0.5d0*pd uds(1)=(uv+dv+2.*qb)*df/x uds(2)=2.*qb*df/x uds(3)=(uv+dv+2.*qb)*df/x uds(4)=2.*qb*df/x uds(5)=2.*st*df/x uds(6)=2.*st*df/x return +self,if=f2g1grsv96,if=targ_he3. q2m=min(1d4,max(qq2,0.40d0)) call parpol(3,x,q2m, uv, dv, qb, st, gl, a1p, a1n,a1d) p1=0.890d0 p2=0.007d0 p3=0.007d0 p4=0.048d0 p5=0.048d0 df1=p1+(p2+p3-p4-p5)/3.d0 df2=(2.d0/3.d0)*(p2+p3-p4-p5) df3=p1+p2+p3-p4-p5 uds(1)=(df2*uv+df1*dv+df3*qb)/x uds(2)=qb*df3/x uds(3)=(df1*uv+df2*dv+df3*qb)/x uds(4)=qb*df3/x uds(5)=st*df3/x uds(6)=st*df3/x return +self, if=qdstr_gu, if=targ_h. c s.gupta, et al. z. phys. c. v46. p.111. (1990) (q2 = 5 gev2) c model 1 (i) c for h 41 x1=1.d0-x**1.51d0 uv=1.78d0*x1**3.5d0*x**(-0.5d0) dv=0.67d0*x1**4.5d0*x**(-0.6d0) rs=-0.119d0*(1.d0-x)**8.54*x**(-0.51d0) rc=0.445d0*rs cos=1.d0/(1.d0+0.258d0*dsqrt(1.d0-x)/x**0.1d0) uds(1)=cos*(uv-2.d0/3.d0*dv)+rs uds(2)=rs uds(3)=cos*(-1.d0/3.d0)*dv+rs uds(4)=rs uds(5)=rc uds(6)=rc return +self, if=qdstr_gu, if=targ_d. c s.gupta, et al. z. phys. c. v46. p.111. (1990) (q2 = 5 gev2) c model 1 (i) c for d 42 x1=1.d0-x**1.51d0 uv=1.78d0*x1**3.5d0*x**(-0.5d0) dv=0.67d0*x1**4.5d0*x**(-0.6d0) rs=-0.119d0*(1.d0-x)**8.54*x**(-0.51d0) rc=0.445d0*rs cos=1.d0/(1.d0+0.258d0*dsqrt(1.d0-x)/x**0.1d0) uvd=cos*(uv-2.d0/3.d0*dv) dvd=cos*(-1.d0/3.d0)*dv pd=0.043d0 ps=1.d0-pd df=ps-0.5d0*pd rsd=2.d0*df*rs rcd=2.d0*df*rc udvd=(uvd+dvd)*df uds(1)=udvd+rsd uds(2)=rsd uds(3)=udvd+rsd uds(4)=rsd uds(5)=rcd uds(6)=rcd return +self, if=qdstr_gu, if=targ_he3. c s.gupta, et al. z. phys. c. v46. p.111. (1990) (q2 = 5 gev2) c model 1 (i) c for he 43 x1=1.d0-x**1.51d0 uv=1.78d0*x1**3.5d0*x**(-0.5d0) dv=0.67d0*x1**4.5d0*x**(-0.6d0) rs=-0.119d0*(1.d0-x)**8.54*x**(-0.51d0) rc=0.445d0*rs cos=1.d0/(1.d0+0.258d0*dsqrt(1.d0-x)/x**0.1d0) uvd=cos*(uv-2.d0/3.d0*dv) dvd=cos*(-1.d0/3.d0)*dv p1=0.890d0 p2=0.007d0 p3=0.007d0 p4=0.048d0 p5=0.048d0 df1=p1+(p2+p3-p4-p5)/3.d0 df2=(2.d0/3.d0)*(p2+p3-p4-p5) df3=p1+p2+p3-p4-p5 rsh=rs*df3 rch=rc*df3 uds(1)=dvd*df1+uvd*df2+rsh uds(2)=rsh uds(3)=uvd*df1+dvd*df2+rsh uds(4)=rsh uds(5)=rch uds(6)=rch return +self. end ccc----------------------------------------------------------------------------- +deck, z0_exh, if=eweak. c function dsws in this deck is the lowest-order electroweak c cross section apart from the pure electromagnetic part. function dsws(ql,poll,poln,dz) +cde, impl. +cde, comval. dimension qss(6),dhz(6),a(3,2),v(3),fq(3) +self, if=-outfun_r. dimension qpp(6) +self. +seq, alphapi. c gf is the fermi coupling constant parameter (gf=1.16637d-5) c rmzo is the z-boson mass parameter (rmzo=91.161d0) parameter (rmz2=rmzo**2) c stw is the weak mixing angle parameter (stw=0.2259d0) g=gf/(2.d0*dsqrt(2.d0)*pi*aa) rmz=rmz2/ss cgv=-0.5d0+2.d0*stw cga=-0.5d0 a(1,1)=0.5d0 a(2,1)=-0.5d0 a(3,1)=-0.5d0 v(1)=0.5d0-4.d0/3.d0*stw v(2)=-0.5d0+2.d0/3.d0*stw v(3)=v(2) fq(1)=2.d0/3.d0 fq(2)=1.d0/3.d0 fq(3)=1.d0/3.d0 r=g*qq*ss*rmz/(qq+rmz) y1=(1.d0-y)**2 ri1=1.d0+y1 ri2=1.d0-y1 y2=2.d0-y gv=cgv+ql*poll*cga ga=-ql*cga-poll*cgv cva=cgv**2+cga**2 cva2=2.d0*cgv*cga rv=cva+ql*poll*cva2 ra=-ql*cva2-poll*cva call qs(x,ss*qq,qss) +self, if=-outfun_r. call qp(x,ss*qq,qpp) +self. call dz(z,dhz) dsws=0.d0 do 1 i=1,3 a(i,2)=-a(i,1) do 1 j=1,2 n=2*(i-1)+j qsn=qss(n) qpn=0.d0 +self, if=-outfun_r. qpn=qpp(n) +self. dzn=dhz(n) ai=a(i,j) vi=v(i) fqi=fq(i) sva=vi**2+ai**2 va=2.d0*vi*ai dsws=dsws+dzn*r/qq**2* *(qsn*x*(-2.d0*fqi*(vi*gv*ri1+ai*ga*ri2)+ +r*(sva*rv*ri1+va*ra*ri2))+ +poln*qpn*(-2.d0*fqi*(ai*gv*x*ri1+vi*ga*qq*y2)+ +r*(va*rv*x*ri1+sva*ra*qq*y2))) 1 continue return end ccc----------------------------------------------------------------------------- +deck, input. c subroutine input creates input arrays of x-,y-,z-values, c defines beam energy and assigns the meaning to lepton and c target nucleon masses. subroutine input +cde, impl. +cde, energy. +cde, kinlimqq. +cde, kinlimz, if=intdz. +cde, anglelim. +cde, comval. +cde, polar. +seq, inoutdim. +seq, inarr. c sm - mass of scattered lepton (gev) c se - mass of another light lepton, giving contribution c to the polarization of the vacuum (gev) c st - mass of tau- lepton, giving contribution c to the polarization of the vacuum (gev) c sn - mass of the target nucleon (gev) c sh - mass of the registered hadron (gev) data sm/0.510999d-3/ data se/105.658d-3/ data st/1784.1d-3/ data sn/0.938272d0/ +self, if=pi_plus,pi_minus,pi_diff,outfun_r. data sh/0.1395675d0/ +self, if=pi_zero. data sh/0.1349739d0/ +self, if=k_plus,k_minus. data sh/0.493646d0/ +self, if=k_zero,k_zero_bar. data sh/0.497671d0/ +self. c e' > ens0 [gev] (e' - energy of scattered lepton) c q**2 > qq0 [(gev/c)**2] data ens0 /5.0/ data qq0 /1.0/ c xmin - minimal value of x ( x > xmin ) c xmax - maximal value of x ( x < xmax ) data xmin/0.02/ data xmax/0.8/ c z0 - minimal value of z ( z > z0 ) c zmax - maximal value of z ( z < zmax ) data z0 /0.1/ data zmax /1.0/ if(zmax.eq.1.d0) zmax=zmax*(1.d0-1.d-9) c tetmin - minimal value of teta c tetmax - maximal value of teta c teta - the angle between the momentum of registered c hadron and the beam direction in lab. frame data tetmin /0.040/ data tetmax /0.170/ ccc============================================================================= open(8,file='input.dat',status='old') read(8,'(f10.3)')bmom read(8,'(f10.3)')tmom read(8,'(f10.3)')plep read(8,'(f10.3)')pnuc read(8,'(f10.3)')qn snuc=2.*(sqrt(tmom**2+sn**2)*sqrt(bmom**2+sm**2)+bmom*tmom) ener=snuc/(2.d0*sn) call titout('10.04.1997',bmom,tmom,plep,pnuc,qn) +self, if=-kin_net. read(8,'(i10)')npoi read(8,'(10f8.4)')(xm(i),i=1,npoi) +self, if=-kin_net, if=-intdy. read(8,'(10f8.4)')(ym(i),i=1,npoi) +self, if=-kin_net, if=-intdz. read(8,'(10f8.4)')(zm(i),i=1,npoi) ccc============================================================================= +self, if=kin_net. c {iu,ju,ku} - number of used {x,y,z}- values data iu,ju,ku/10,1,3/ +self, if=intdy, if=kin_net. ju=1 +self, if=intdz, if=kin_net. ku=1 ccc============================================================================= +self. ss=2.d0*sn*ener smm=sm**2 see=se**2 stt=st**2 snn=sn**2 sxx=(sn+sh)**2 pm=smm/ss pe=see/ss pt=stt/ss pn=snn/ss px=sxx/ss-pn ftetmn=0.d0 ftetmx=1.d0/(2.d0*pn) +seq, ftetlim, if=cuts. ccc============================================================================= +self, if=kin_net. iii=0 do 8 i=1,iu do 8 j=1,ju do 8 k=1,ku np=(i-1)*ju*ku+(j-1)*ku+k - iii +self, if=intdy, if=kin_net. hx=(xmax-xmin)/(iu+1) xm(np)=xmin+hx*i +self, if=-intdy, if=kin_net. c y - bin ymin1=(qq0/ss/xmax) ymin2=px/(1.d0-xmin) ymin=max(ymin1,ymin2) ymax=1.d0-ens0/ener hy=(ymax-ymin)/(ju+1) y=ymin+hy*j c x - bin xmin1=qq0/ss/y xmax1=1.d0-px/y vay=1.d0-4.d0*pn*pm-y vayd=sqrt(vay**2 - 4.d0*pn*pm*y) xmin2=(vay-vayd)/(2.d0*pn*y) xmax2=(vay+vayd)/(2.d0*pn*y) xmin3=max(xmin2,xmin1,xmin) xmax3=min(xmax2,xmax1,xmax) if(xmax3.gt.xmin3) then hx=(xmax3-xmin3)/(iu+1) xm(np)=xmin3+hx*i ym(np)=y else iii=iii+1 go to 8 end if +self, if=-intdz, if=kin_net. c z - bin hz=(zmax-z0)/(ku+1) zm(np)=z0+hz*k +self, if=kin_net. 8 continue c npoi - number of used {x,y,z}- points npoi=iu*ju*ku-iii +self. end ccc----------------------------------------------------------------------------- +deck, idzi, if=intdz. c subrotine idzi creates the fit for effective fragmentation c function by means of numerical integration of the c fragmentation function and following spline approximation. subroutine idzi +cde, impl. +cde, kinlimz. +seq, splnarr. common /idqg/iqq external dzdqg nn1=nn-1 hx=(1.d0 - z0)/nn1 xz(nn)=1.d0 do j=1, nn1 jj=101-j jjj=jj+1 xz(jj)=xz(jjj)-hx if(xz(jj).lt.z0) xz(jj)=z0 end do do i=1,6 iqq=i yq(i,nn)=0.d0 do j=1,100 jj=101-j jjj=jj+1 xn=xz(jj) xm=xz(jjj) call dqg32(xn,xm,dzdqg,rq) yq(i,jj)=yq(i,jjj)+rq end do call spline(6,nn,i,xz,yq,bq,cq,dq) end do return end ccc----------------------------------------------------------------------------- +deck, dzdqg, if=intdz. function dzdqg(z) +cde, impl. dimension dhz(6) common /idqg/iqq call fitdz(z,dhz) dzdqg=dhz(iqq) return end ccc----------------------------------------------------------------------------- ccc----------------------------------------------------------------------------- +deck, spline. c subroutine spline creates cubic spline approximation. subroutine spline(m,n,ii,x,y,b,c,d) +cde, impl. dimension x(n),y(m,n),b(m,n),c(m,n),d(m,n) nm1=n-1 if(n.lt.2) return if(n.lt.3) go to 50 d(ii,1)=x(2)-x(1) c(ii,2)=(y(ii,2)-y(ii,1))/d(ii,1) do 10 i=2,nm1 d(ii,i)=x(i+1)-x(i) b(ii,i)=2.d0*(d(ii,i-1)+d(ii,i)) c(ii,i+1)=(y(ii,i+1)-y(ii,i))/d(ii,i) c(ii,i)=c(ii,i+1)-c(ii,i) 10 continue b(ii,1)=-d(ii,1) b(ii,n)=-d(ii,n-1) c(ii,1)=0.d0 c(ii,n)=0.d0 if(n.eq.3) go to 15 c(ii,1)=c(ii,3)/(x(4)-x(2))-c(ii,2)/(x(3)-x(1)) c(ii,n)=c(ii,n-1)/(x(n)-x(n-2))-c(ii,n-2)/ 1(x(n-1)-x(n-3)) c(ii,1)=c(ii,1)*d(ii,1)**2/(x(4)-x(1)) c(ii,n)=-c(ii,n)*d(ii,n-1)**2/(x(n)-x(n-3)) 15 do 20 i=2,n t=d(ii,i-1)/b(ii,i-1) b(ii,i)=b(ii,i)-t*d(ii,i-1) c(ii,i)=c(ii,i)-t*c(ii,i-1) 20 continue c(ii,n)=c(ii,n)/b(ii,n) do 30 ib=1,nm1 i=n-ib c(ii,i)=(c(ii,i)-d(ii,i)*c(ii,i+1))/b(ii,i) 30 continue b(ii,n)=(y(ii,n)-y(ii,nm1))/d(ii,nm1)+d(ii,nm1)* 1(c(ii,nm1)+2.d0*c(ii,n)) do 40 i=1,nm1 b(ii,i)=(y(ii,i+1)-y(ii,i))/d(ii,i)-d(ii,i)*(c(ii,i+1) 1+2.d0*c(ii,i)) d(ii,i)=(c(ii,i+1)-c(ii,i))/d(ii,i) c(ii,i)=3.d0*c(ii,i) 40 continue c(ii,n)=3.d0*c(ii,n) d(ii,n)=d(ii,n-1) return 50 b(ii,1)=(y(ii,2)-y(ii,1))/(x(2)-x(1)) c(ii,1)=0.d0 d(ii,1)=0.d0 b(ii,2)=b(ii,1) c(ii,2)=0.d0 d(ii,2)=0.d0 return end ccc----------------------------------------------------------------------------- +deck, seval. c subroutine seval calculates the value of function created c by means of cubic spline approximation. function seval(m,n,ii,u,x,y,b,c,d) implicit real*8(a-h,o-z) dimension x(n),y(m,n),b(m,n),c(m,n),d(m,n) data i/1/ if(i.gt.n) i=1 if(u.lt.x(i)) go to 10 if(u.le.x(i+1)) go to 30 10 i=1 j=n+1 20 k=(i+j)/2 if(u.lt.x(k)) j=k if(u.ge.x(k)) i=k if(j.gt.i+1) go to 20 30 dx=u-x(i) seval=y(ii,i)+dx*(b(ii,i)+dx*(c(ii,i)+dx*d(ii,i))) return end +patch,strffun. +deck,strf,if=polrad. subroutine strf(ta,rr,sfm) c c the programm calculates deep inelastic (ita=1), c elastic (ita=2), quasielastic (ita=3) structure functions c in kinematical point (ta,rr). c rr=sx-tt, c ta=(t-y)/rr, c where tt=t+amf2-amp2, amf2 is invarint mass of final hadrons c implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comtail. common/print/ipri1 dimension sfm(8) t=y+rr*ta if(ita.eq.1)then tt=sx-rr amf2=tt-t+amp2 aks=t/tt anu=tt/ap epsi=ap2/tt g1=0.d0 g2=0.d0 if(un.gt.1d-10)then f1=f1sfun(aks,t) f2=f2sfun(aks,t) else f1=0.d0 f2=0.d0 endif if(pn.gt.1d-10)then g1=g1sfun(aks,t) g2=g2sfun(aks,t) else g1=0.d0 g2=0.d0 endif +self,if=targ_d. if(qn.gt.1d-10)then call b14sf(aks,t,b1,b2,b3,b4) else +self. b1=0.d0 b2=0.d0 b3=0.d0 b4=0.d0 +self,if=targ_d. endif +self,if=iter_pr,if=qua_asym. b1=fitfun(aks,2,3)/2.*f1 b2=2.*aks*b1 +self. goto 10 endif c c tarn,tarz,tara are n,z,a of the nucleus c epsi=ap2/t tarn=tara-tarz c c tf is t in fermi**(-2) c tf=t/chbar**2 c c gep,gmp are electric and magnetic form factors of proton c s.i.bilenkaya et al pisma zhetf 19(1974)613 c call ffpro(t,gep,gmp) if(ita.eq.2)then tau=t/4./amt**2 tau1=1.+tau +self,if=targ_h. f1=2.*amp2*tau*gmp**2 f2=4.*amp2*tau*(gep**2+tau*gmp**2)/tau1 g1=amp2*tau*2.*gmp*(gep+tau*gmp)/tau1 g2=2.*amp2*tau**2*gmp*(gep-gmp)/tau1 +self,if=targ_d. call ffdeu(t,fcdeu,fmdeu,fqdeu) fc=fcdeu*amt fm=fmdeu*amt fq=fqdeu*amt f1=4./3.*tau*tau1*fm**2 f2=4./9.*tau*(8.*tau**2*fq**2+6.*tau*fm**2+9.*fc**2) g1=-1./3.*tau*fm*(2.*tau*fq+6.*fc+3.*tau*fm) g2=-1./3.*tau**2*fm*(2.*tau*fq+6*fc-3.*fm) b1=2.*tau**2*fm**2 b2=4.*fm**2*tau**2+ . 16./3.*tau**3/tau1*(tau*fq+3.*fc-3.*fm)*fq b3=-4./3.*(3.*tau+2.)*fm**2*tau**2+ . 16./9.*tau**3/tau1*(tau*fq+3.*fc-3.*fm)*fq b4=4./3.*(6.*tau+1.)*fm**2*tau**2+ . 16./9.*tau**3/tau1*(tau*fq+3.*fc+3.*(3.*tau+2.)*fm)*fq +self,if=targ_he3. call ffhe3(t,ge,gm) f1=2.*amt**2*tau*gm**2 f2=4.*amt**2*tau*(ge**2+tau*gm**2)/tau1 g1=amt**2*tau*2.*gm*(ge+tau*gm)/tau1 g2=2.*amt**2*tau**2*gm*(ge-gm)/tau1 +self,if=targ_c,targ_o. call ffco(t,ff) f1=0d0 f2=4.*amp2*tau*(tarz*ff)**2 g1=0d0 g2=0d0 +self. else if(ita.eq.3)then tau=t/4./amp**2 tau1=1.+tau call ffquas(t,geun,gmun,gepo,gmpo) f1=2.*amp2*tau*gmun**2 f2=4.*amp2*tau*(geun**2+tau*gmun**2)/tau1 g1=amp2*tau*2.*gmpo*(gepo+tau*gmpo)/tau1 g2=2.*amp2*tau**2*gmpo*(gepo-gmpo)/tau1 +self,if=targ_d. b1=0. b2=0. b3=0. b4=0. +self. endif 10 continue sfm(1)=un*f1+qn/6.*b1 sfm(2)=epsi*(un*f2+qn/6.*b2) sfm(3)=epsi*(g1+g2) sfm(4)=epsi**2*g2 sfm(5)=epsi**2*b1 sfm(6)=epsi**3*(b2/3.+b3+b4) sfm(7)=epsi*(b2/3.-b3) sfm(8)=epsi**2*(b2/3.-b4) return end +deck,f1sfun,if=polrad. ********************** f1sfun *********************************** double precision function f1sfun(aks,t) implicit real*8(a-h,o-z) +seq,comcmp. f2=f2sfun(aks,t) +self,if=-f1qpm. anu=t/ap/aks f1sfun=amp*(1.+anu**2/t)*f2/anu/(1.+r1990(aks,t)) +self,if=f1qpm. f1sfun=f2/2./aks +self. end +deck,f2sfun,if=polrad. ********************** f2sfun *********************************** double precision function f2sfun(aks,t) implicit real*8(a-h,o-z) +seq,comcmp. +self,if=f2g1grsv96. dimension pdf(-6:6),fqn(6),iiq(6) data fqn/2.,-1.,2.,-1.,2.,-1./ data iiq/2,1,4,3,6,5/ q2m=min(1d4,max(t,0.40d0)) q=sqrt(q2m) call pgrv(1,pdf,aks, q) f2p=0d0 f2n=0d0 do i=1,6 ii=iiq(i) f2n=f2n+fqn(i)**2/9d0*(pdf(ii)+pdf(-ii) ) if(i.le.2)ii=i f2p=f2p+fqn(i)**2/9d0*(pdf(ii)+pdf(-ii) ) enddo f2d=(f2p+f2n)/2. amf2=t/aks-t+amp2 wei=portn(t,0d0,0.4d0)*portn(amf2,amc2,1.232d0) f2d=wei*f2d f2p=wei*f2p +self,if=f2g1sch. call schaf(aks,g1p,g1n,f2psch,f2nsch,0.25d0,0.19d0) f2p=f2psch f2d=(f2psch+f2nsch)/2. +self,if=f2nmc_d8. f2p=df2h8(t,aks) f2d=df2d8(t,aks) +self,if=f2comfst. call comfst(aks,t,f2p,f2d) +self,if=targ_h. f2sfun=f2p +self,if=targ_d. f2sfun=f2d +self,if=targ_he3. f2sfun=(f2p+2d0*f2d)/3d0 +self,if=targ_c,targ_o. c f2=f2d*(-.45*aks+1.07-.45*ddexp(-44.00d0*aks)) f2sfun=f2d*ranucl(aks,tara) +self. end +deck,r1990,if=polrad. ********************** r1990 ************************************ double precision function r1990(aks,tc) implicit real*8(a-h,o-z) +seq,comcmp. +self,if=r_eq_0. r1990=0. +self,if=-r_eq_0. t=tc +self,if=f2nmc_d8,if=-r_eq_0. if(tc.lt..35d0)t=0.35 +self,if=-r_eq_0. teta=1.+12.*t/(1.+t)*(.125**2/(aks**2+.125**2)) zn=teta/log(t/.04) ra=.0672*zn+.4671/(t**4+1.8979**4)**(.25d0) rb=.0635*zn+.5747/t-.3534/(t**2+.09) rc=.0599*zn+.5088/sqrt((t-5.*(1.-aks)**5)**2+2.1081**2) rrr=(ra+rb+rc)/3. +self,if=f2nmc_d8,if=-r_eq_0. r1990=rrr +self,if=-f2nmc_d8,if=-r_eq_0. wei=portn(t,.3d0,.4d0) amf2=t/aks-t+amp2 r1990=rrr*wei+(1.-wei)*.18*portn(amf2,1.44d0,1.76d0) +self. return end +deck,g1sfun,if=polrad. ********************** g1sfun *********************************** double precision function g1sfun(aks,t) implicit real*8(a-h,o-z) +seq,comcmp. +self,if=f2g1sch,if=-iter_pr. call schaf(aks,g1p,g1n,f2psch,f2nsch,0.25d0,0.19d0) +self,if=f2g1grsv96,if=-iter_pr. q2m=min(1d4,max(t,0.40d0)) iset=3 call parpol (iset, aks,q2m, uv, dv, qb, st, gl, a1p, a1n,a1d) g1p=.5*(4./9.*uv+1./9.*dv+10./9.*qb+2./9.*st)/aks g1n=.5*(4./9.*dv+1./9.*uv+10./9.*qb+2./9.*st)/aks amf2=t/aks-t+amp2 wei=portn(t,0d0,0.4d0)*portn(amf2,amc2,1.232d0) g1p=wei*g1p g1n=wei*g1n +self,if=targ_h,if=f2g1sch,f2g1grsv96,if=-iter_pr. g1sfun=g1p +self,if=targ_d,if=f2g1sch,f2g1grsv96,if=-iter_pr. pddeu=0.043d0 g1sfun=(1d0-1.5d0*pddeu)*(g1p+g1n)/2d0 +self,if=targ_he3,if=f2g1sch,f2g1grsv96,if=-iter_pr. ppro=-0.028d0 pneu=0.86d0 g1sfun=(pneu*g1n+2d0*ppro*g1p)/3d0 +self,if=g1asym,if=targ_h,if=-iter_pr. c a1p=1.90202d-2+aks**(-1.16312d-3)*(1d0-ddexp(-1.84517*aks)) a1p=1.1092*aks**(-.13658)*(1d0-ddexp(-1.3258*aks)) g1sfun=a1p*f1sfun(aks,t) +self,if=g1asym,if=targ_d,if=-iter_pr. adeu=8.2885d0 bdeu=3.23589d-2 cdeu=.142777d0 a1d=(ddexp(-adeu*aks)-1d0)*(bdeu**(cdeu)-aks**(cdeu)) c a1d=0.15225*aks**(.92104)*(1d0-ddexp(-15.272*aks)) g1sfun=a1d*f1sfun(aks,t) +self,if=targ_he3,if=g1asym,if=-iter_pr. c a1he3=-0.01589*aks**(-.663)*(1d0-ddexp(-5.96*aks)) dz= 1./2.*log(1.+exp(2.0-1000.*aks)) dfn=1. df2nf2p=0.67225*(1.0-aks)**1.6254-0.15436*aks**0.048301 1 +(.41979+.047331*dz-0.17816*dz**2) df=dfn*(1./((2./df2nf2p)+1)) a1nue=0.00024-.00463*(aks**0.1+aks**0.5) . -3.48645*aks+1.59218*aks**1.5 . +8.59393*aks**2-5.74029*aks**3 a1he3=a1nue*df g1sfun=a1he3*f1sfun(aks,t) +self,if=iter_pr,if=targ_h,targ_d. as=fitfun(aks,2,3) g1sfun=as*f1sfun(aks,t) +self,if=iter_pr,if=targ_he3. +seq,compar,if=err_prop. data ppro/-0.028/pneu/0.86/ asn=shainv(aks) asp=as1pro(aks) fd=fdilut(aks) +self,if=err_prop,if=targ_he3. if(ipara.ne.0)asp=0. +self,if=iter_pr,if=targ_he3. ashe3=pneu*fd*asn+ppro*(1.-fd)*asp g1sfun=ashe3*f1sfun(aks,t) +self. end +deck,g2sfun,if=polrad. ********************** g2sfun *********************************** double precision function g2sfun(aks,t) implicit real*8(a-h,o-z) +seq,comcmp. +self,if=g2_ww. common/g2ww/tww external g1scal +self,if=g2_eq_0. g2sfun=0. +self,if=g2_ww. tww=t aksm=t/(1.08**2+t-amp2) if(aksm.gt.aks)then call dqg32(log(aks),log(aksm),g1scal,g2wwa) else g2wwa=0d0 endif g2sfun=-g1sfun(aks,t)+g2wwa +self,if=iter_pr_g2. asym1=fitfun(aks,2,3) asym2=fitfun(aks,5,3) gam=sqrt(t)/anu g1=f1*(asym1+gam*asym2)/(1.+gam**2) g2=f1*(asym2-gam*asym1)/gam/(1.+gam**2) +self. end +self,if=g2_ww. double precision function g1scal(aksl) implicit real*8(a-h,o-z) common/g2ww/tww aks=exp(aksl) g1scal=g1sfun(aks,tww) end +deck,as1pro,if=targ_he3,if=polrad,if=iter_pr. ********************** as1pro *********************************** double precision function as1pro(dx) implicit real*8(a-h,o-z) as1pro=1.90202d-2+DX**(-1.16312d-3)*(1.-EXP(-1.84517*DX) ) end +deck,fdilut,if=targ_he3,if=polrad,if=iter_pr. ********************** fdilut *********************************** double precision function fdilut(aks) implicit real*8(a-h,o-z) dZ= 1./2.*LOG(1.+EXP(2.0-1000.*aks)) dfn=1. df2nf2p=0.67225*(1.0-aks)**1.6254-0.15436*aks**0.048301 . +(.41979+.047331*dz-0.17816*dz**2) fdilut=dfn*(1./((2./df2nf2p)+1)) end +deck,b14sf,if=targ_d,if=polrad. ********************** b14sf *********************************** subroutine b14sf(aks,t,b1,b2,b3,b4) implicit real*8(a-h,o-z) +self,if=targ_d. b1hoo=fitfun(aks,4,1) b1=b1hoo/2. +self,if=iter_pr,if=qua_asym. b1=fitfun(aks,2,3)/2.*f1sfun(aks,t) +self. b2=2.*aks*b1 b3=0. b4=0. end +deck,comfst,if=f2comfst,if=polrad. ********************** comfst ************************************ subroutine comfst(aks,t,f2p,f2d) implicit real*8(a-h,o-z) +seq,comcmp. common/kkk/kod(2) dimension f2(2),a(7,2),b(4,2),c(4,2),anst(5),ast(4),pw1(5),pw2(5) data a/-0.02778d0, 2.926d0, 1.0362d0 . ,-1.840d0, 8.123d0,-13.074d0, 6.215d0 . ,-0.04858d0, 2.863d0, 0.8367d0,-2.532d0 . ,9.145d0,-12.504d0,5.473d0/ data b/ 0.285d0,-2.694d0, 0.0188d0, 0.0274d0, . -0.008d0,-2.227d0,0.0551d0,0.0570d0/ data c/-1.413d0, 9.366d0,-37.94d0,47.10d0, .-1.509d0, 8.553d0,-31.20d0, 39.98d0/ data zll2/0.0625d0/ data anst/1.0621d0, -2.2594d0, 10.54d0, -15.8277d0, 6.7931d0/ data ast/1.01688d0,-2.73701d0,10.2482d0, -18.3009d0/ data pw1/0.9004d0,-0.0262d0,-6.0915d0,15.8103d0,-12.8660d0/ data pw2/-0.0035d0,-0.2333d0,1.7832d0,-5.0908d0,4.6070d0/ data p1/0.2d0/,p2/0.4d0/, . bt1/5.5d0/,bt2/6.5d0/,bw2/4d0/ . ot1/28d0/,ot2/33d0/,ow2/7d0/ amf2=t/aks-t+amp2 do i=1,2 f2comf=0. f2stei=0. if (t.ge.p1) then ak1=1.-aks aa=aks**a(1,i)*(1.-aks)**a(2,i)*(a(3,i)+a(4,i) .*ak1+a(5,i)*ak1**2+a(6,i)*ak1**3+a(7,i)*ak1**4) bb=b(1,i)+b(2,i)*aks+b(3,i)/(aks+b(4,i)) cc=c(1,i)*aks+c(2,i)*aks**2+c(3,i)*aks**3+c(4,i)*aks**4 f2comf=aa*(dlog(t/zll2)/dlog(20.d0/zll2))**bb*(1.+cc/t) endif if (t.le.p2) then os=1.+amf2/t ge2=1./((1.+.61*t)*(1.+2.31*t)*(1.+.04*t))**2 gm2 = 7.7841*ge2 tau=t/4./amp2 w2el=(ge2+tau*gm2)/(1.+tau) sr=0. do 20 ik=1,5 20 sr=sr+anst(ik)*(1.-1./os)**(ik+2) f2stei =(1.-w2el)*sr if(i.eq.2)then xz=1./os af=polino(xz,ast,4) otst=(1.+af)*supst(t)/2. f2stei=f2stei*otst endif endif wei=portn(t,p1,p2) f2(i)=f2comf*wei+(1.-wei)*f2stei if (t.lt.bt2 .and. amf2.lt.bw2 .and. i.eq.1)then f2b=f2bras(t,amf2,aks) if (amf2-amc2.ge.t/bt2*(bw2-amc2))then bw1=amc2+bt1/bt2*(bw2-amc2) wei=(amf2-bw1)/(bw2-bw1) else wei=(t-bt1)/(bt2-bt1) endif wei=portn(wei,0d0,1d0) f2(i)=wei*f2(i)+(1.-wei)*f2b endif enddo f2p=f2(1) if (f2p.ne.0)oo=f2(2)/f2(1) if (t.lt.ot2 .and. amf2.lt.ow2 .and. f2p.ne.0)then fwi=polino(aks,pw1,5)+polino(aks,pw2,5)*log(t) otwit=(1.+fwi)/2. if (amf2-amc2.ge.t/ot2*(ow2-amc2))then ow1=amc2+ot1/ot2*(ow2-amc2) wei=(amf2-ow1)/(ow2-ow1) else wei=(t-ot1)/(ot2-ot1) endif wei=portn(wei,0d0,1d0) oo=f2(2)/f2(1) oo=wei*oo+(1.-wei)*otwit oo=max(0.5d0,oo) oo=min(1.0d0,oo) endif f2d=f2p*oo return end +deck,ranucl,if=targ_c,targ_o,if=polrad. double precision function ranucl(x,an) implicit real*8(a-h,o-z) c c 'a' dependence of the structure functions ratio c r=f2(nucleus)/f2(deuteron) is represented by formulas c of barshay and rein, z.phys.c 46 (1990) 215, c with the normalization parameter bnorm=1 c c 'x' dependence of the ratio r and normalisation parameters c pam(1-3) for a dependence were found from the fit of c he, li, c, ca, cu, xe and pb data in the range 0.001< x< 0.7 c done in june 1995 by g.smirnov: phys. lett. b364 (1995) 87. c dimension pam(3), pamer(3) data pam/ 0.130, 0.456, 0.773/ data pamer/ 0.004, 0.017, 0.020/ data b1,b2,b3,b4,b5/1., 1.145, 0.93, 0.88, 0.59/ c if(an.le.4.5)then pam(1)=0.02934 pam(2)=0.1046 pam(3)=0.2360 endif bnorm = 1.0 d1 = an**(1./3.) d2 = an**(2./3.) d3 = an d4 = an**(4./3.) d5 = an**(5./3.) ser = 1. - b1/d1 -b2/d2 + b3/d3 + b4/d4 - b5/d5 c del1 = bnorm*ser c aa = x**(pam(1)*del1) bb = 1.0 + pam(2)*del1 cc = x*pam(3)*del1 c ranucl = aa*bb*(1.0 - cc) x0=0.8 cb=15. db=1. c ranucl=ranucl+(-x0**pam(1)*(1.+pam(2))*(1.-pam(3)*x0)+1.) c . *exp(-cb*(x0-x)**db) c if(x.gt.0.79 .and. ranucl.gt.1.)ranucl=1. end +deck,parpol,if=f2g1grsv96. ********************************************************************* * * * polarized radiatively generated lo and nlo parton densities * * and dis asymmetries * * * * m. gluck, e. reya, m. stratmann and w. vogelsang, * * (phys. rev. d53 (1996) 4775) * * problems/questions to vogelsang@v2.rl.ac.uk * * or to strat@hal1.physik.uni-dortmund.de * * * * input: iset = number of the parton set : * * iset = 1 'standard' scenario, next-to-leading order * * (ms-bar) * * (data file 'stdnloa1.grid' unit=11, to be * * defined by the user ) * * iset = 2 'valence' scenario, next-to-leading order * * (ms-bar) * * (data file 'valnloa1.grid' unit=22, to be * * defined by the user ) * * iset = 3 'standard' scenario, leading order * * (data file 'stdloa1.grid' unit=33, to be * * defined by the user ) * * iset = 4 'valence' scenario, leading order * * (data file 'valloa1.grid' unit=44, to be * * defined by the user ) * * * * x = bjorken-x (between 1.e-4 and 1) * * q2 = scale in gev**2 (between 0.4 and 1.e4) * * (for values outside the allowed range the program * * writes a warning and extrapolates to the x and * * q2 values requested) * * * * output: uv = x * ( delta u - delta u(bar) ), * * dv = x * ( delta d - delta d(bar) ), * * qb = x * polarized light sea, * * qb= x * ( (delta u(bar) + delta d(bar))/2 ) * * st = x * delta strange = x * delta strange(bar) * * gl = x * delta gluon * * * * ( for the parton distributions always x times * * the distribution is returned ) * * * * a1p = a1-proton * * a1n = a1-neutron * * a1d = a1-deuteron * * * * the sets are the result of a combined fit to * * data for the spin asymmetries a_1 (p,n,d) * * * * note: no charm is included * * * * common: the main program or the calling routine has to have * * a common block common / intini / iini , and iini * * has always to be zero when parpol is called for the * * first time or when 'iset' has been changed. * * * ********************************************************************* * subroutine parpol (iset, x, q2, uv, dv, qb, st, gl, a1p, a1n, 1 a1d) implicit double precision (a-h,o-z) parameter (npart=8, nx=42, nq=25, narg=2) dimension xuvf(nx,nq), xdvf(nx,nq), xqbf(nx,nq), 1 xsf(nx,nq), xgf(nx,nq), xapf(nx,nq), xanf(nx,nq), 2 xadf(nx,nq), parton (npart,nq,nx-1), 3 qs(nq), xb(nx), xt(narg), na(narg), arrf(nx+nq) common / intini / iini save xuvf, xdvf, xqbf, xsf, xgf, xapf, xanf, xadf, na, arrf *...bjorken-x and q**2 values of the grid : data qs / 0.4d0, 0.5d0, 0.6d0, 0.75d0, 1.0d0, 1 1.25d0, 1.5d0, 2.d0, 2.5d0, 1 4.0d0, 6.4d0, 1.0d1, 1.5d1, 2.5d1, 4.0d1, 6.4d1, 2 1.0d2, 1.8d2, 3.2d2, 5.8d2, 1.0d3, 1.8d3, 3 3.2d3, 5.8d3, 1.0d4 / data xb / 1.d-4, 1.5d-4, 2.2d-4, 3.2d-4, 4.8d-4, 7.d-4, 2 1.d-3, 1.5d-3, 2.2d-3, 3.2d-3, 4.8d-3, 7.d-3, 3 1.d-2, 1.5d-2, 2.2d-2, 3.2d-2, 5.0d-2, 7.5d-2, 4 0.1, 0.125, 0.15, 0.175, 0.2, 0.225, 0.25, 0.275, 5 0.3, 0.325, 0.35, 0.375, 0.4, 0.45, 0.5, 0.55, 6 0.6, 0.65, 0.7, 0.75, 0.8, 0.85, 0.9, 1.0 / *...check of x and q2 values : if ( (x.lt.1.0d-4) .or. (x.gt.1.0d0) ) then write(6,91) 91 format (2x,'parton interpolation: x out of range') c goto 60 endif if ( (q2.lt.0.4d0) .or. (q2.gt.1.d4) ) then write(6,92) 92 format (2x,'parton interpolation: q2 out of range') c goto 60 endif *...initialization : * selection and reading of the grid : * file - no. = 11 for nlo 'standard' scenario ( first number in the * grid: 1.040e-03 ) * file - no. = 22 for nlo 'valence' scenario ( first number in the * grid: 9.740e-04 ) * file - no. = 33 for lo 'standard' scenario ( first number in the * grid: 1.731e-03 ) * file - no. = 44 for lo 'valence' scenario ( first number in the * grid: 1.846e-03 ) if (iini.ne.0) goto 16 if (iset.eq.1) then iiread=11 open(unit=11,file='stdnloa1.gri',status='old') else if (iset.eq.2) then iiread=22 open(unit=22,file='valnloa1.gri',status='old') else if (iset.eq.3) then iiread=33 open(unit=33,file='stdloa1.gri',status='old') else if (iset.eq.4) then iiread=44 open(unit=44,file='valloa1.gri',status='old') else write(6,93) 93 format (2x,'parton interpolation: iset out of range') goto 60 end if c do 15 m = 1, nx-1 do 15 n = 1, nq read(iiread,90) parton(1,n,m), parton(2,n,m), parton(3,n,m), 1 parton(4,n,m), parton(5,n,m), parton(6,n,m), 2 parton(7,n,m), parton(8,n,m) 90 format (8(1pe10.3)) 15 continue c iini = 1 *....arrays for the interpolation subroutine : do 10 iq = 1, nq do 20 ix = 1, nx-1 xb0 = xb(ix) xb1 = 1.d0-xb(ix) xuvf(ix,iq) = parton(1,iq,ix) / (xb1**3 * xb0**0.7) xdvf(ix,iq) = parton(2,iq,ix) / (xb1**4 * xb0**0.6) xqbf(ix,iq) = parton(3,iq,ix) / (xb1**7 * xb0**0.3) xsf(ix,iq) = parton(4,iq,ix) / (xb1**7 * xb0**0.3) xgf(ix,iq) = parton(5,iq,ix) / (xb1**10 * xb0**0.3) xapf(ix,iq) = parton(6,iq,ix) / xb0 xanf(ix,iq) = parton(7,iq,ix) / xb0 xadf(ix,iq) = parton(8,iq,ix) / xb0 20 continue xuvf(nx,iq) = 0.d0 xdvf(nx,iq) = 0.d0 xqbf(nx,iq) = 0.d0 xsf(nx,iq) = 0.d0 xgf(nx,iq) = 0.d0 xapf(nx,iq) = 0.d0 xanf(nx,iq) = 0.d0 xadf(nx,iq) = 0.d0 10 continue na(1) = nx na(2) = nq do 30 ix = 1, nx arrf(ix) = dlog(xb(ix)) 30 continue do 40 iq = 1, nq arrf(nx+iq) = dlog(qs(iq)) 40 continue 16 continue *...interpolation : xt(1) = dlog(x) xt(2) = dlog(q2) uv = dfint(narg,xt,na,arrf,xuvf) * (1.d0-x)**3 * x**0.7 dv = dfint(narg,xt,na,arrf,xdvf) * (1.d0-x)**4 * x**0.6 qb = dfint(narg,xt,na,arrf,xqbf) * (1.d0-x)**7 * x**0.3 st = dfint(narg,xt,na,arrf,xsf) * (1.d0-x)**7 * x**0.3 gl = dfint(narg,xt,na,arrf,xgf) * (1.d0-x)**10 * x**0.3 a1p = dfint(narg,xt,na,arrf,xapf) * x a1n = dfint(narg,xt,na,arrf,xanf) * x a1d = dfint(narg,xt,na,arrf,xadf) * x 60 return end * *...cern library routine e104 (interpolation) : * function dfint(narg,arg,nent,ent,table) implicit double precision (a-h,o-z) dimension arg(5),nent(5),ent(67),table(1050) dimension d(5),ncomb(5),ient(5) kd=1 m=1 ja=1 do 5 i=1,narg ncomb(i)=1 jb=ja-1+nent(i) do 2 j=ja,jb if (arg(i).le.ent(j)) go to 3 2 continue j=jb 3 if (j.ne.ja) go to 4 j=j+1 4 jr=j-1 d(i)=(ent(j)-arg(i))/(ent(j)-ent(jr)) ient(i)=j-ja kd=kd+ient(i)*m m=m*nent(i) 5 ja=jb+1 dfint=0.d0 10 fac=1.d0 iadr=kd ifadr=1 do 15 i=1,narg if (ncomb(i).eq.0) go to 12 fac=fac*(1.d0-d(i)) go to 15 12 fac=fac*d(i) iadr=iadr-ifadr 15 ifadr=ifadr*nent(i) dfint=dfint+fac*table(iadr) il=narg 40 if (ncomb(il).eq.0) go to 80 ncomb(il)=0 if (il.eq.narg) go to 10 il=il+1 do 50 k=il,narg 50 ncomb(k)=1 go to 10 80 il=il-1 if(il.ne.0) go to 40 return end +deck,pgrv,if=f2g1grsv96. subroutine pgrv (iset,pdf,x, q) c c sun may 14 20:29:29 met 1995 c implicit real*8 (a-h,o-z) dimension pdf(-6:6) c q2=q*q c if(iset.eq.1) call pgrvlo (x, q2, uv, dv, del, udb, sb, gl) if(iset.eq.1) call pgrvhl (x, q2, cb, bb) if(iset.eq.2) call pgrvho (x, q2, uv, dv, del, udb, sb, gl) if(iset.eq.2) call pgrvhh (x, q2, cb, bb) if(iset.eq.3) call pgrvdi (x, q2, uv, dv, del, udb, sb, gl) c db = 0.5d+00*( del+udb) ub = 0.5d+00*(-del+udb) pdf(1) = uv + ub pdf(2) = dv + db pdf(3) = sb pdf(4) = cb pdf(5) = bb pdf(6) = 0.0d+00 pdf(-1)= ub pdf(-2)= db pdf(-3)= sb pdf(-4)= cb pdf(-5)= bb pdf(-6)= 0.0d+00 pdf(0) = gl c return end c* subroutine pgrvlo (x, q2, uv, dv, del, udb, sb, gl) * ---------------------------------------------------- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * g r v - p r o t o n - p a r a m e t r i z a t i o n s * * * * 1994 update * * * * for a detailed explanation see * * m. glueck, e.reya, a.vogt : * * do-th 94/24 = desy 94-206 * * (to appear in z. phys. c) * * * * the parametrizations are fitted to the evolved partons for * * q**2 / gev**2 between 0.4 and 1.e6 * * x between 1.e-5 and 1. * * large-x regions, where the distribution under consideration * * is negligibly small, were excluded from the fit. * * * * heavy quark thresholds q(h) = m(h) in the beta function : * * m(c) = 1.5, m(b) = 4.5 * * corresponding lambda(f) values in gev for q**2 > m(h)**2 : * * lo : lambda(3) = 0.232, lambda(4) = 0.200, * * lambda(5) = 0.153, * * nlo : lambda(3) = 0.248, lambda(4) = 0.200, * * lambda(5) = 0.131. * * the number of active quark flavours is nf = 3 everywhere * * except in the beta function, i.e. the heavy quarks c,b,... * * are not present as partons in the q2-evolution. * * if needed, heavy quark densities can be taken from the 1991 * * grv parametrization. * * * * nlo distributions are given in ms-bar factorization scheme * * (subroutine grv94ho) as well as in the dis scheme (grv94di), * * the leading order parametrization is provided by "grv94lo". * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *...input parameters : * * x = momentum fraction * q2 = scale q**2 in gev**2 * *...output (always x times the distribution) : * * uv = u(val) = u - u(bar) * dv = d(val) = d - d(bar) * del = d(bar) - u(bar) * udb = u(bar) + d(bar) * sb = s = s(bar) * gl = gluon * *...lo parametrization : * implicit double precision (a - z) mu2 = 0.23 lam2 = 0.2322 * 0.2322 s = dlog (dlog(q2/lam2) / dlog(mu2/lam2)) ds = dsqrt (s) s2 = s * s s3 = s2 * s *...uv : nu = 2.284 + 0.802 * s + 0.055 * s2 aku = 0.590 - 0.024 * s bku = 0.131 + 0.063 * s au = -0.449 - 0.138 * s - 0.076 * s2 bu = 0.213 + 2.669 * s - 0.728 * s2 cu = 8.854 - 9.135 * s + 1.979 * s2 du = 2.997 + 0.753 * s - 0.076 * s2 uv = pfv (x, nu, aku, bku, au, bu, cu, du) *...dv : nd = 0.371 + 0.083 * s + 0.039 * s2 akd = 0.376 bkd = 0.486 + 0.062 * s ad = -0.509 + 3.310 * s - 1.248 * s2 bd = 12.41 - 10.52 * s + 2.267 * s2 cd = 6.373 - 6.208 * s + 1.418 * s2 dd = 3.691 + 0.799 * s - 0.071 * s2 dv = pfv (x, nd, akd, bkd, ad, bd, cd, dd) *...del : ne = 0.082 + 0.014 * s + 0.008 * s2 ake = 0.409 - 0.005 * s bke = 0.799 + 0.071 * s ae = -38.07 + 36.13 * s - 0.656 * s2 be = 90.31 - 74.15 * s + 7.645 * s2 ce = 0.0 de = 7.486 + 1.217 * s - 0.159 * s2 del = pfv (x, ne, ake, bke, ae, be, ce, de) *...udb : alx = 1.451 bex = 0.271 akx = 0.410 - 0.232 * s bkx = 0.534 - 0.457 * s agx = 0.890 - 0.140 * s bgx = -0.981 cx = 0.320 + 0.683 * s dx = 4.752 + 1.164 * s + 0.286 * s2 ex = 4.119 + 1.713 * s esx = 0.682 + 2.978 * s udb = pfw (x, s, alx, bex, akx, bkx, agx, bgx, cx, dx, ex, esx) *...sb : als = 0.914 bes = 0.577 aks = 1.798 - 0.596 * s as = -5.548 + 3.669 * ds - 0.616 * s bs = 18.92 - 16.73 * ds + 5.168 * s dst = 6.379 - 0.350 * s + 0.142 * s2 est = 3.981 + 1.638 * s ess = 6.402 sb = pfws (x, s, als, bes, aks, as, bs, dst, est, ess) *...gl : alg = 0.524 beg = 1.088 akg = 1.742 - 0.930 * s bkg = - 0.399 * s2 ag = 7.486 - 2.185 * s bg = 16.69 - 22.74 * s + 5.779 * s2 cg = -25.59 + 29.71 * s - 7.296 * s2 dg = 2.792 + 2.215 * s + 0.422 * s2 - 0.104 * s3 eg = 0.807 + 2.005 * s esg = 3.841 + 0.316 * s gl = pfw (x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg) return end subroutine pgrvho (x, q2, uv, dv, del, udb, sb, gl) * ---------------------------------------------------- * *...nlo parametrization (ms(bar)) : * implicit double precision (a - z) mu2 = 0.34 lam2 = 0.248 * 0.248 s = dlog (dlog(q2/lam2) / dlog(mu2/lam2)) ds = dsqrt (s) s2 = s * s s3 = s2 * s *...uv : nu = 1.304 + 0.863 * s aku = 0.558 - 0.020 * s bku = 0.183 * s au = -0.113 + 0.283 * s - 0.321 * s2 bu = 6.843 - 5.089 * s + 2.647 * s2 - 0.527 * s3 cu = 7.771 - 10.09 * s + 2.630 * s2 du = 3.315 + 1.145 * s - 0.583 * s2 + 0.154 * s3 uv = pfv (x, nu, aku, bku, au, bu, cu, du) *...dv : nd = 0.102 - 0.017 * s + 0.005 * s2 akd = 0.270 - 0.019 * s bkd = 0.260 ad = 2.393 + 6.228 * s - 0.881 * s2 bd = 46.06 + 4.673 * s - 14.98 * s2 + 1.331 * s3 cd = 17.83 - 53.47 * s + 21.24 * s2 dd = 4.081 + 0.976 * s - 0.485 * s2 + 0.152 * s3 dv = pfv (x, nd, akd, bkd, ad, bd, cd, dd) *...del : ne = 0.070 + 0.042 * s - 0.011 * s2 + 0.004 * s3 ake = 0.409 - 0.007 * s bke = 0.782 + 0.082 * s ae = -29.65 + 26.49 * s + 5.429 * s2 be = 90.20 - 74.97 * s + 4.526 * s2 ce = 0.0 de = 8.122 + 2.120 * s - 1.088 * s2 + 0.231 * s3 del = pfv (x, ne, ake, bke, ae, be, ce, de) *...udb : alx = 0.877 bex = 0.561 akx = 0.275 bkx = 0.0 agx = 0.997 bgx = 3.210 - 1.866 * s cx = 7.300 dx = 9.010 + 0.896 * ds + 0.222 * s2 ex = 3.077 + 1.446 * s esx = 3.173 - 2.445 * ds + 2.207 * s udb = pfw (x, s, alx, bex, akx, bkx, agx, bgx, cx, dx, ex, esx) *...sb : als = 0.756 bes = 0.216 aks = 1.690 + 0.650 * ds - 0.922 * s as = -4.329 + 1.131 * s bs = 9.568 - 1.744 * s dst = 9.377 + 1.088 * ds - 1.320 * s + 0.130 * s2 est = 3.031 + 1.639 * s ess = 5.837 + 0.815 * s sb = pfws (x, s, als, bes, aks, as, bs, dst, est, ess) *...gl : alg = 1.014 beg = 1.738 akg = 1.724 + 0.157 * s bkg = 0.800 + 1.016 * s ag = 7.517 - 2.547 * s bg = 34.09 - 52.21 * ds + 17.47 * s cg = 4.039 + 1.491 * s dg = 3.404 + 0.830 * s eg = -1.112 + 3.438 * s - 0.302 * s2 esg = 3.256 - 0.436 * s gl = pfw (x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg) return end subroutine pgrvdi (x, q2, uv, dv, del, udb, sb, gl) * ---------------------------------------------------- * *...nlo parametrization (dis) : * implicit double precision (a - z) mu2 = 0.34 lam2 = 0.248 * 0.248 s = dlog (dlog(q2/lam2) / dlog(mu2/lam2)) ds = dsqrt (s) s2 = s * s s3 = s2 * s *...uv : nu = 2.484 + 0.116 * s + 0.093 * s2 aku = 0.563 - 0.025 * s bku = 0.054 + 0.154 * s au = -0.326 - 0.058 * s - 0.135 * s2 bu = -3.322 + 8.259 * s - 3.119 * s2 + 0.291 * s3 cu = 11.52 - 12.99 * s + 3.161 * s2 du = 2.808 + 1.400 * s - 0.557 * s2 + 0.119 * s3 uv = pfv (x, nu, aku, bku, au, bu, cu, du) *...dv : nd = 0.156 - 0.017 * s akd = 0.299 - 0.022 * s bkd = 0.259 - 0.015 * s ad = 3.445 + 1.278 * s + 0.326 * s2 bd = -6.934 + 37.45 * s - 18.95 * s2 + 1.463 * s3 cd = 55.45 - 69.92 * s + 20.78 * s2 dd = 3.577 + 1.441 * s - 0.683 * s2 + 0.179 * s3 dv = pfv (x, nd, akd, bkd, ad, bd, cd, dd) *...del : ne = 0.099 + 0.019 * s + 0.002 * s2 ake = 0.419 - 0.013 * s bke = 1.064 - 0.038 * s ae = -44.00 + 98.70 * s - 14.79 * s2 be = 28.59 - 40.94 * s - 13.66 * s2 + 2.523 * s3 ce = 84.57 - 108.8 * s + 31.52 * s2 de = 7.469 + 2.480 * s - 0.866 * s2 del = pfv (x, ne, ake, bke, ae, be, ce, de) *...udb : alx = 1.215 bex = 0.466 akx = 0.326 + 0.150 * s bkx = 0.956 + 0.405 * s agx = 0.272 bgx = 3.794 - 2.359 * ds cx = 2.014 dx = 7.941 + 0.534 * ds - 0.940 * s + 0.410 * s2 ex = 3.049 + 1.597 * s esx = 4.396 - 4.594 * ds + 3.268 * s udb = pfw (x, s, alx, bex, akx, bkx, agx, bgx, cx, dx, ex, esx) *...sb : als = 0.175 bes = 0.344 aks = 1.415 - 0.641 * ds as = 0.580 - 9.763 * ds + 6.795 * s - 0.558 * s2 bs = 5.617 + 5.709 * ds - 3.972 * s dst = 13.78 - 9.581 * s + 5.370 * s2 - 0.996 * s3 est = 4.546 + 0.372 * s2 ess = 5.053 - 1.070 * s + 0.805 * s2 sb = pfws (x, s, als, bes, aks, as, bs, dst, est, ess) *...gl : alg = 1.258 beg = 1.846 akg = 2.423 bkg = 2.427 + 1.311 * s - 0.153 * s2 ag = 25.09 - 7.935 * s bg = -14.84 - 124.3 * ds + 72.18 * s cg = 590.3 - 173.8 * s dg = 5.196 + 1.857 * s eg = -1.648 + 3.988 * s - 0.432 * s2 esg = 3.232 - 0.542 * s gl = pfw (x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg) return end function pfv (x, n, ak, bk, a, b, c, d) * -------------------------------------- * *...functional forms of the parametrizations : * implicit double precision (a - z) dx = dsqrt (x) pfv = n * x**ak * (1.+ a*x**bk + x * (b + c*dx)) * (1.- x)**d return end function pfw (x, s, al, be, ak, bk, a, b, c, d, e, es) * ----------------------------------------------------- implicit double precision (a - z) lx = dlog (1./x) pfw = (x**ak * (a + x * (b + x*c)) * lx**bk + s**al 1 * dexp (-e + dsqrt (es * s**be * lx))) * (1.- x)**d return end * function pfws (x, s, al, be, ak, ag, b, d, e, es) * ------------------------------------------------ implicit double precision (a - z) dx = dsqrt (x) lx = dlog (1./x) pfws = s**al / lx**ak * (1.+ ag*dx + b*x) * (1.- x)**d 1 * dexp (-e + dsqrt (es * s**be * lx)) return end * * >>>>>>>>> use only for c & b * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * g r v - p r o t o n - p a r a m e t r i z a t i o n s * * * * for a detailed explanation see : * * m. glueck, e.reya, a.vogt : do-th 91/07 * * (published in z.phys. c53 (1992) 127) * * * * the parametrizations are fitted to the parton distributions * * for q ** 2 between mu ** 2 (= 0.25 / 0.30 gev ** 2 in lo * * / ho) and 1.e8 gev ** 2 and for x between 1.e-5 and 1. * * regions, where the distribution under consideration is neg- * * ligible, i.e. below about 1.e-4, were excluded from the fit. * * * * heavy quark thresholds q(h) = m(h) : * * m(c) = 1.5, m(b) = 4.5, m(t) = 100 gev * * * * corresponding lambda(f) values for f active flavours : * * lo : lambda(3) = 0.232, lambda(4) = 0.200, * * lambda(5) = 0.153, lambda(6) = 0.082 gev * * ho : lambda(3) = 0.248, lambda(4) = 0.200, * * lambda(5) = 0.131, lambda(6) = 0.053 gev * * * * ho distribution refer to the ms-bar scheme of bardeen et al. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *...input parameters : * * x = momentum fraction * q2 = scale q**2 in gev**2 * *...output : * * udv = u(val) + d(val) * dv = d(val) * gl = gluon * udb = u(bar) = d(bar) = u(sea) = d(sea) * sb = s = s(bar) * cb = c = c(bar) * bb = b = b(bar) * *...lo parametrization : * subroutine pgrvhl (x, q2, cb, bb) implicit double precision (a - z) mu2 = 0.25 lam2 = 0.232 * 0.232 s = dlog (dlog(q2/lam2) / dlog(mu2/lam2)) s2 = s * s s3 = s2 * s *...x * (uv + dv) : nud = 0.663 + 0.191 * s - 0.041 * s2 + 0.031 * s3 akud = 0.326 agud = -1.97 + 6.74 * s - 1.96 * s2 bud = 24.4 - 20.7 * s + 4.08 * s2 dud = 2.86 + 0.70 * s - 0.02 * s2 udv = pfv1(x, nud, akud, agud, bud, dud) *...x * dv : nd = 0.579 + 0.283 * s + 0.047 * s2 akd = 0.523 - 0.015 * s agd = 2.22 - 0.59 * s - 0.27 * s2 bd = 5.95 - 6.19 * s + 1.55 * s2 dd = 3.57 + 0.94 * s - 0.16 * s2 dv = pfv1(x, nd, akd, agd, bd, dd) *...x * g : alg = 0.558 beg = 1.218 akg = 1.00 - 0.17 * s bkg = 0.0 agg = 0.0 + 4.879 * s - 1.383 * s2 bgg = 25.92 - 28.97 * s + 5.596 * s2 cg = -25.69 + 23.68 * s - 1.975 * s2 dg = 2.537 + 1.718 * s + 0.353 * s2 eg = 0.595 + 2.138 * s esg = 4.066 gl = pfw1(x, s, alg, beg, akg, bkg, agg, bgg, cg, dg, eg, esg) *...x * ubar = x * dbar : alu = 1.396 beu = 1.331 aku = 0.412 - 0.171 * s bku = 0.566 - 0.496 * s agu = 0.363 bgu = -1.196 cu = 1.029 + 1.785 * s - 0.459 * s2 du = 4.696 + 2.109 * s eu = 3.838 + 1.944 * s esu = 2.845 udb = pfw1(x, s, alu, beu, aku, bku, agu, bgu, cu, du, eu, esu) *...x * sbar = x * s : ss = 0.0 als = 0.803 bes = 0.563 aks = 2.082 - 0.577 * s ags = -3.055 + 1.024 * s ** 0.67 bs = 27.4 - 20.0 * s ** 0.154 ds = 6.22 est = 4.33 + 1.408 * s ess = 8.27 - 0.437 * s sb = pfws1(x, s, ss, als, bes, aks, ags, bs, ds, est, ess) *...x * cbar = x * c : sc = 0.888 alc = 1.01 bec = 0.37 akc = 0.0 agc = 0.0 bc = 4.24 - 0.804 * s dc = 3.46 + 1.076 * s ec = 4.61 + 1.490 * s esc = 2.555 + 1.961 * s cb = pfws1(x, s, sc, alc, bec, akc, agc, bc, dc, ec, esc) *...x * bbar = x * b : sbo = 1.351 alb = 1.00 beb = 0.51 akb = 0.0 agb = 0.0 bbo = 1.848 db = 2.929 + 1.396 * s eb = 4.71 + 1.514 * s esb = 4.02 + 1.239 * s bb = pfws1(x, s, sbo, alb, beb, akb, agb, bbo, db, eb, esb) return end * *...ho paramertrization : * subroutine pgrvhh (x, q2, cb, bb) implicit double precision (a - z) mu2 = 0.3 lam2 = 0.248 * 0.248 s = dlog (dlog(q2/lam2) / dlog(mu2/lam2)) ds = dsqrt (s) s2 = s * s s3 = s2 * s *...x * (uv + dv) : nud = 0.330 + 0.151 * s - 0.059 * s2 + 0.027 * s3 akud = 0.285 agud = -2.28 + 15.73 * s - 4.58 * s2 bud = 56.7 - 53.6 * s + 11.21 * s2 dud = 3.17 + 1.17 * s - 0.47 * s2 + 0.09 * s3 udv = pfv1(x, nud, akud, agud, bud, dud) *...x * dv : nd = 0.459 + 0.315 * ds + 0.515 * s akd = 0.624 - 0.031 * s agd = 8.13 - 6.77 * ds + 0.46 * s bd = 6.59 - 12.83 * ds + 5.65 * s dd = 3.98 + 1.04 * s - 0.34 * s2 dv = pfv1(x, nd, akd, agd, bd, dd) *...x * g : alg = 1.128 beg = 1.575 akg = 0.323 + 1.653 * s bkg = 0.811 + 2.044 * s agg = 0.0 + 1.963 * s - 0.519 * s2 bgg = 0.078 + 6.24 * s cg = 30.77 - 24.19 * s dg = 3.188 + 0.720 * s eg = -0.881 + 2.687 * s esg = 2.466 gl = pfw1(x, s, alg, beg, akg, bkg, agg, bgg, cg, dg, eg, esg) *...x * ubar = x * dbar : alu = 0.594 beu = 0.614 aku = 0.636 - 0.084 * s bku = 0.0 agu = 1.121 - 0.193 * s bgu = 0.751 - 0.785 * s cu = 8.57 - 1.763 * s du = 10.22 + 0.668 * s eu = 3.784 + 1.280 * s esu = 1.808 + 0.980 * s udb = pfw1(x, s, alu, beu, aku, bku, agu, bgu, cu, du, eu, esu) *...x * sbar = x * s : ss = 0.0 als = 0.756 bes = 0.101 aks = 2.942 - 1.016 * s ags = -4.60 + 1.167 * s bs = 9.31 - 1.324 * s ds = 11.49 - 1.198 * s + 0.053 * s2 est = 2.630 + 1.729 * s ess = 8.12 sb = pfws1(x, s, ss, als, bes, aks, ags, bs, ds, est, ess) *...x * cbar = x * c : sc = 0.820 alc = 0.98 bec = 0.0 akc = -0.625 - 0.523 * s agc = 0.0 bc = 1.896 + 1.616 * s dc = 4.12 + 0.683 * s ec = 4.36 + 1.328 * s esc = 0.677 + 0.679 * s cb = pfws1(x, s, sc, alc, bec, akc, agc, bc, dc, ec, esc) *...x * bbar = x * b : sbo = 1.297 alb = 0.99 beb = 0.0 akb = 0.0 - 0.193 * s agb = 0.0 bbo = 0.0 db = 3.447 + 0.927 * s eb = 4.68 + 1.259 * s esb = 1.892 + 2.199 * s bb = pfws1(x, s, sbo, alb, beb, akb, agb, bbo, db, eb, esb) return end * *...functional forms of the parametrizations : * function pfv1(x, n, ak, ag, b, d) implicit double precision (a - z) dx = dsqrt (x) pfv1= n * x**ak * (1.+ ag*dx + b*x) * (1.- x)**d return end * function pfw1(x, s, al, be, ak, bk, ag, bg, c, d, e, es) implicit double precision (a - z) lx = dlog (1./x) pfw1= (x**ak * (ag + x * (bg + x*c)) * lx**bk + s**al 1 * dexp (-e + dsqrt (es * s**be * lx))) * (1.- x)**d return end * function pfws1(x, s, st, al, be, ak, ag, b, d, e, es) implicit double precision (a - z) dx = dsqrt (x) lx = dlog (1./x) if (s .le. st) then pfws1= 0.0 else pfws1= (s-st)**al / lx**ak * (1.+ ag*dx + b*x) * (1.- x)**d 1 * dexp (-e + dsqrt (es * s**be * lx)) end if return end +deck,ffpro,if=polrad. ****************** ffpro ************************************** subroutine ffpro(t,gep,gmp) implicit real*8(a-h,o-z) +seq,comcmp. gep=1.2742/(1.+t/0.6394**2)-.2742/(1.+t/1.582**2) gmp=(1.3262/(1.+t/0.6397**2)-.3262/(1.+t/1.3137**2))*amm c gep=1./((1.+.61*t)*(1.+2.31*t)*(1.+.04*t)) c gmp=amm*gep end +deck,ffdeu,if=targ_d,if=polrad. ****************** ffdeu ************************************** subroutine ffdeu(t,gc,gm,gq) implicit real*8(a-h,o-z) parameter (c2i3 = 6.6666666666666667d-1) ! 2/3 dimension a(4),b(4),c(4) dimension al2ar(4),be2ar(4),ga2ar(4) data amd/1.8756280D0/chbar/0.19732858d0/ data amp/0.9382796D0/ data dmu/0.857406d0/dqu/25.84d0/ gd2=1d0/(1.d0+t/4./0.8952**2)**4 eta=t/4.d0/amd**2 gd2e=gd2/(2d0*eta+1d0) sq2e=sqrt(2d0*eta) al2ar(1)=1.8591*chbar**2 al2ar(4)=2d0*amd*0.58327d0 be2ar(1)=19.586*chbar**2 be2ar(4)=2d0*amd*0.1d0 ga2ar(1)=1.0203*chbar**2 ga2ar(4)=2d0*amd*0.17338d0 do i=2,3 al2ar(i)=al2ar(1)+(al2ar(4)-al2ar(1))/3d0*(i-1) be2ar(i)=be2ar(1)+(be2ar(4)-be2ar(1))/3d0*(i-1) ga2ar(i)=ga2ar(1)+(ga2ar(4)-ga2ar(1))/3d0*(i-1) enddo a(1)=2.4818*chbar**2 a(2)=-10.850*chbar**2 a(3)=6.4416*chbar**2 a(4)=al2ar(4)*(1d0-a(2)/al2ar(2)-a(3)/al2ar(3)-a(1)/al2ar(1)) b(1)=-1.7654*chbar b(2)=6.7874*chbar bzn=1d0/be2ar(4)-1d0/be2ar(3) bbb=(2d0-dmu*amd/amp)/2d0/sqrt(2d0)/amd b(3)=(b(1)/be2ar(1)+b(2)/be2ar(2)-b(1)/be2ar(4)-b(2)/be2ar(4) . -bbb)/bzn b(4)=-(b(1)/be2ar(1)+b(2)/be2ar(2)-b(1)/be2ar(3)-b(2)/be2ar(3) . -bbb)/bzn ccc=(1d0-dmu*amd/amp-dqu)/4./amd**2 c(1)=-0.053830d0 znc2=ga2ar(1)*(ga2ar(3)*ga2ar(4)-ga2ar(2)*ga2ar(3) . +ga2ar(2)**2-ga2ar(2)*ga2ar(4)) c(2)=-ga2ar(2)/znc2*(c(1)*( .ga2ar(3)*ga2ar(4)-ga2ar(1)*ga2ar(3)+ga2ar(1)**2-ga2ar(1)*ga2ar(4) .)-ccc*ga2ar(3)*ga2ar(4)*ga2ar(1) ) znc3=ga2ar(1)*(ga2ar(3)-ga2ar(2))*(ga2ar(4)-ga2ar(3)) c(3)=ga2ar(3)/znc3*(c(1)*( .ga2ar(2)*ga2ar(4)-ga2ar(1)*ga2ar(4)+ga2ar(1)**2-ga2ar(1)*ga2ar(2) .)-ccc*ga2ar(2)*ga2ar(4)*ga2ar(1) ) znc4=ga2ar(1)*(ga2ar(4)-ga2ar(2))*(ga2ar(4)-ga2ar(3)) c(4)=-ga2ar(4)/znc4*(c(1)*( .ga2ar(2)*ga2ar(3)-ga2ar(1)*ga2ar(3)+ga2ar(1)**2-ga2ar(1)*ga2ar(2) .)-ccc*ga2ar(2)*ga2ar(3)*ga2ar(1) ) g00=0d0 gp0=0d0 gpm=0d0 sqt=sqrt(t) do i=1,4 g00=g00+a(i)/(al2ar(i)+t) gp0=gp0+sqt*b(i)/(be2ar(i)+t) gpm=gpm+t*c(i)/(ga2ar(i)+t) enddo gc=gd2e*( (1d0-c2i3*eta)*g00+4d0*c2i3*sq2e*gp0 . +c2i3*(2d0*eta-1d0)*gpm) gm=gd2e*(2d0*g00+2d0*(2d0*eta-1d0)/sq2e*gp0-2d0*gpm) gq=gd2e*(-g00+2d0/sq2e*gp0-(1d0+1d0/eta)*gpm) end +deck,ffhe3,if=polrad. ****************** ffhe3 ************************************** subroutine ffhe3(t,ge,gm) implicit real*8(a-h,o-z) +seq,comcmp. tf=t/chbar**2 qf=sqrt(tf) a=.675 b=.366 c=.836 am=.654 bm=.456 cm=.821 d=-6.78d-3 p=.9 q0=3.98 f0=ddexp(-a**2*qf**2) - b**2*qf**2*ddexp(-c**2*qf**2) fm=ddexp(-am**2*qf**2) - bm**2*qf**2*ddexp(-cm**2*qf**2) df=d*ddexp(-((qf-q0)/p)**2) ge=(f0+df)*tarz gm=fm*tara * (-2.13) end +deck,ffco,if=polrad. ****************** ffco ************************************** subroutine ffco(t,ff) c c j.e. bailey et al nucl. phys. b151(1979)367 c implicit real*8(a-h,o-z) +seq,comcmp. tf=t/chbar**2 am=(tarz-2.)/3. xm=1.07*dsqrt(tf)*tara**(1./3.) um=3.*(2.+5.*am)/(2.*(2.+3.*am)) ff=(1.-am*xm**2/(2.*um*(2.+3.*am)))*ddexp(-xm**2/(4d0*um)) ff=max(ff,0d0) end +deck,ffquas,if=polrad. ****************** ffquas ************************************** subroutine ffquas(t,geun,gmun,gepo,gmpo) implicit real*8(a-h,o-z) +seq,comcmp. call ffpro(t,gep,gmp) tf=t/chbar**2 tau=t/4./amp**2 tau1=1.+tau c c t. de forest and d.j. valecka adv. in phys. 15(1966) no.57 c +self,if=-targ_d. supele=1. supmag=1. if(t.le.(2.d0*fermom)**2)then sqrat=dsqrt(t)/fermom supele=0.75*sqrat-sqrat**3/16. supmag=supele endif +self,if=targ_d. supele=supst(t) c qbold=sqrt(t*tau1) c supele=1.-dsbern(qbold)**2 supmag=supele +self. geun=gep*dsqrt(supele*tarz) tarn=tara-tarz gmun=gep*dsqrt(supmag*(tarz*amm**2+tarn*amn**2)) +self,if=targ_d. gepo=geun gmpo=gmun +self,if=targ_he3. gepo=0. tarn=tara-tarz gmpo=gep*dsqrt(supmag*( tarn*amn**2)) +self,if=targ_c,targ_o. gepo=0. gmpo=0. +self. end +deck,schaf,if=polrad. ****************** schaf ************************************** subroutine schaf(aks,g1p,g1n,f2p,f2n,a10,au0) c c g1p,g1n are polarized structure function from c a.schafer phys.lett. b208(1988)175 c implicit real*8(a-h,o-z) data a7/7.00d0/ xuv =2.75033*aks**(.588d0)*(1d0-aks)**(2.69d0) xdv =8.52617*aks**(1.03d0)*(1d0-aks)**(6.87d0) a0=xuv-xdv/2d0 a1=1.5d0*xdv f2p=4./9.*a0+2./9.*a1 f2n=1./9.*a0+1./3.*a1 fu0=1./(1.+au0*aks**(-.588)*(1.-aks)**2) fu1=1./(1.+a10*au0*aks**(-.588)*(1.-aks)**2) fd0=1./(1.+a7*au0*aks**(-1.03)*(1.-aks)**2) fd1=1./(1.+a7*a10*au0*aks**(-1.03)*(1.-aks)**2) g1p=(4./9.*a0*fu0+2./27.*(-2./3.*fd1+1./3.*fd0)*a1+ . 4./27.*(-2./3.*fu1+1./3.*fu0)*a1)/2./aks g1n=(1./9.*a0*fd0+8./27.*(-2./3.*fu1+1./3.*fu0)*a1+ . 1./27.*(-2./3.*fd1+1./3.*fd0)*a1)/2./aks return end +deck,supst,if=polrad. ********************** supst ************************************ double precision function supst(t) implicit real*8(a-h,o-z) data chbar/.197328d0/ c c tf is t in fermi**(-2) c tf=t/chbar**2 c c s.stein et al phys. rev. 12(1975)1884 (appendix 1) c sqtf=dsqrt(tf) delff=(datan(sqtf/.93d0)-2.*datan(sqtf/3.19d0)+ . datan(sqtf/5.45d0))*1.580d0/sqtf delff=dmax1(0.d0,delff) supele=1.-delff**2 supst=dmax1(0.d0,supele) return end +deck,portn. ********************** portn ************************************ double precision function portn(x,x10,x20) implicit real*8(a-h,o-z) x1=min(x10,x20) x2=max(x10,x20) if(x.le.x1) portn=0. if(x.ge.x2) portn=1. if(x.gt.x1.and.x.lt.x2)portn=(x-x1)**2*(3.*x2-2.*x-x1)/(x2-x1)**3 return end +deck,polino. ********************** polino ************************************ double precision function polino(x,c,l) implicit real*8(a-h,o-z) dimension c(l) sa=c(l) do 45 ia=2,l 45 sa=sa*x+c(l-ia+1) polino=sa return end +deck,f2bras,if=f2comfst,if=polrad. ********************** f2bras ************************************ double precision function f2bras(t,amf2,aks) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. data cw /3471.16d0/,w2min/1.2321d0/ tt=t/aks anu=tt/ap xb=s-t+amp2-amf2 sn=t*amp2/s/xb cn=1.-sn tn=sn/cn veps=1./(1.+2.*tn*(1.+anu**2/t)) hm=max(w2min,amf2) sqhm=sqrt(hm) if(veps.gt.0.9d0)then aaa=fitfun(sqhm,1,1) bbb=fitfun(sqhm,1,2) ccc=fitfun(sqhm,1,3) else if(veps.gt.0.6d0)then aaa=fitfun(sqhm,1,4) bbb=fitfun(sqhm,1,5) ccc=fitfun(sqhm,1,6) else aaa=fitfun(sqhm,1,7) bbb=fitfun(sqhm,1,8) ccc=fitfun(sqhm,1,9) end if gd2=1./(1.+t/.71)**4 anb=(hm+t-amp2)/ap xmq=sqrt(anb**2+t) xmq0=(hm-amp2)/ap aal=log(xmq/xmq0) eee=aaa+bbb*aal+ccc*abs(aal)**3 svtot=gd2*ddexp(eee) stot=((amf2-hm)/(w2min-amc2)+1.)*svtot cw11=cw/0.389/1d6 r=r1990(aks,t) rf1 =cw11*(amf2-amp2)/(1.+veps*r)*stot f2bras =anu/ap*t/(t+anu**2)*(1.+r)*rf1 return end +deck,beta. function beta(z,w) implicit real*8(a-h,o-z) beta=exp(gammln(z)+gammln(w)-gammln(z+w)) return end double precision function gammln(xx) implicit real*8(a-h,o-z) dimension cof(6) data cof,stp/76.18009173d0,-86.50532033d0,24.01409822d0, * -1.231739516d0,.120858003d-2,-.536382d-5,2.50662827465d0/ data half,one,fpf/0.5d0,1.0d0,5.5d0/ x=xx-one tmp=x+fpf tmp=(x+half)*log(tmp)-tmp ser=one do 11 j=1,6 x=x+one ser=ser+cof(j)/x 11 continue gammln=tmp+log(stp*ser) return end double precision function dgamma(xx) implicit real*8(a-h,o-z) dgamma=exp(gammln(xx)) end +deck,ddexp. ****************** ddexp ************************************** double precision function ddexp(x) implicit real*8(a-h,o-z) ddexp=0. if(x.gt.-50.)ddexp=exp(x) return end +deck,df2d8,if=polrad. double precision function df2d8(dq2,dx) *:=====================================================================: *: : *: author: m.dueren last update: 06.03.1991 : *: tested: yes : *: : *: arguments: dq2,dx: double prec. input xbj,q2 : *: df2h8* double prec f2 output : *: : *: called by: mkf2 : *: : *: action: calculate f2 structure function of the deuteron : *: nmc fit of dis-region with 8 parameters : *: data of nmc (1992), slac,bcdms : *: : *: parametrized with a1,bi (i=1...4) as : *: : *: f2_dis(x,q2) ~prop. : *: [1/b(n1,n2)*x**n1*(1-x)**n2 + 1/3*n3*(1-x)**n4 ] : *: *s(x,q2) : *: with x = (q2+m_a)/(2m*nu + m_b**2) : *: ni= ai+bi*s : *: s = ln(ln(q2+m_a**2)/lambda)/ln(..q2_0): *: reference: : *: the new muon collaboration : *: nuclear physics b 371 (1992) 3-31 : *:=====================================================================: c implicit double precision (d) c c c *** d1,...,d8 = 8 param of nmc, slac, bcdms (92) c *** d9,...,d10 = 2 parameters: (1 for resonance) + (1 for background) c *** daw,dbw = weizmann variable in bodek's d2 fit c values: daw=1.512(gev2), dbw=0.351(gev2) c ref: bodek et al., p.r.d20(1979)1427. c see p.1495, eq(5.1) and table viii c c *** dl2 = lamda**2 = 0.2**2 = 0.04 (gev2) c *** q0**2 = 2 gev2 ... (2+0.351)/0.04 = 58.771 c *** fit by y.m.(25-nov-88 19h43m14s) c data d1,d2,d3,d4,d5,d6,d7,d8 : ,d9,d10 : ,daw,dbw c c f2 from nmc, slac, bcdms - data (92) : /.764053,-.171774,3.48979,.611064,.946086 : ,1.06818,13.8472,-2.40967 c resonance-region : ,.89456,.16452 : ,1.512, .351 / c c df2d8=1.d-30 dw2 = .8803686078d0+dq2*(1.d0/dx-1.d0) dwmas = dsqrt(dw2) ddw = (dwmas-1.03d0) c c *** ddw = w - (resonance threshold - smearing 0f 0.05 gev) c *** lamda(qcd) = 0.2 gev c if(ddw.le.0.d0) return c c *** use weizmann variable for low q2 c *** values: daweiz=1.512(gev2), dbweiz=0.351(gev2) c *** ref: bodek et al., p.r.d20(1979)1427. c *** see p.1495, eq(5.1) and table viii c dq2w=dq2+dbw dxw=dq2w/(dq2/dx+daw) c dsbar = dlog(dlog(dq2w/.04d0)) - 1.404555751d0 c detav1 = d1+d2*dsbar detav2 = d3+d4*dsbar detas1 = d5+d6*dsbar detas2 = d7+d8*dsbar c dxw1=1.d0-dxw de1=detav1 de2=detav2+1.d0 c c *** supression bue to "quark sum rule" c *** sup.fact.= 1 - gd**2, with gd=nucleon dipole f.f. c *** further supression due to low w phase space volume c den1=(1.d0+dq2/.71d0) dgd2=1.d0/den1**4 dssum = (1.d0-dgd2) ds = dssum * (1.d0-dexp(-4.177d0*ddw)) c df2d8 = : ( .83333333333333*dgamma(de1+de2)/dgamma(de1)/dgamma(de2) : *dxw**detav1*dxw1**detav2 : + .33333333333333*detas1*dxw1**detas2 ) * ds c c *** resonance contribution c dres = 0.d0 c dres2=0.d0 c dres3=0.d0 c c *** lorentzian resonance ( small fermi-smearing effect) c *** gamma(fermi)=0.0883 gev c *** gamma(d2) = sqrt ( gamma(h2)**2 + gamma(fermi)**2 ) c 1.232**2 = 1.518 c 1.520**2 = 2.310 c 1.681**2 = 2.826 c 1.232**2 * 0.15**2 = 0.0342 c 1.520**2 * 0.14**2 = 0.0453 c 1.681**2 * 0.14**2 = 0.0554 c if (dwmas .le. 2.3d0) then dres1 = d9**2*dexp(-(dwmas-1.232d0)**2/.0053d0) : /den1**3 c dres2 = d10**2/( (dw2-2.310d0)**2 + 0.0453d0 ) c : * dgd2 c dres3 = d11**2/( (dw2-2.826d0)**2 + 0.0554d0 ) c : * dgd2 c endif c c *** background under resonances c c mp**2 = 0.8803686078 c mp**2-m(pi)**2=0.8608892416 c *** dqs = momentum of one pion, decaying from the resonance, in cm c frame c dw2m = (dwmas+.05d0)**2 dqs=dsqrt((dw2m+0.8608892416d0)**2/4.d0/dw2m-0.8803686078d0) dbg = (d10**2*dqs ) : * dexp(-0.5d0*ddw**2) / den1 dres=(dres1 + dbg) * dssum endif c c *** total f2 of d2 c df2d8 = df2d8 + dres c if (df2d8.gt.0d0) return df2d8 = 1.d-30 return end +deck,df2h8,if=polrad. double precision function df2h8(dq2,dx) *:=====================================================================: *: : *: author: m.dueren last update: 06.03.1991 : *: tested: yes : *: : *: arguments: dq2,dx: double prec. input xbj,q2 : *: df2h8* double prec f2 output : *: : *: called by: mkf2 : *: : *: action: calculate f2 structure function of the proton : *: nmc fit of dis-region with 8 parameters : *: data of nmc (1992)slac,bcdms : *: : *: parametrized with a1,bi (i=1...4) as : *: : *: f2_dis(x,q2) ~prop. : *: [1/b(n1,n2)*x**n1*(1-x)**n2 + 1/3*n3*(1-x)**n4 ] : *: *s(x,q2) : *: with x = (q2+m_a)/(2m*nu + m_b**2) : *: ni= ai+bi*s : *: s = ln(ln(q2+m_a**2)/lambda)/ln(..q2_0): *: reference: : *: the new muon collaboration : *: nuclear physics b 371 (1992) 3-31 : *:=====================================================================: c implicit double precision (d) * c *** d1,...,d8 = 8 param of nmc, slac, bcdms (92) c *** d9,...,d10 = 2 parameters: (1 for resonance) + (1 for background) c *** daw,dbw = weizmann variable in bodek's d2 fit c values: daw=1.512(gev2), dbw=0.351(gev2) c ref: bodek et al., p.r.d20(1979)1427. c see p.1495, eq(5.1) and table viii c c *** dl2 = lamda**2 = 0.2**2 = 0.04 (gev2) c *** q0**2 = 2 gev2 ... (2+0.351)/0.04 = 58.771 c *** fit by y.m.(25-nov-88 19h43m14s) * data d1,d2,d3,d4,d5,d6,d7,d8 : ,d9,d10,d11,d12,d13,d14 : ,d15,d16 : ,daw,dbw c f2 from nmc, slac, bcdms data '92 (final) : /.886627,-.11191,3.3951,1.04064,1.02702,1.40335,12.4577,- : .100622 c resonance-region: : ,.1179, .044735, .038445, .27921, 8.8228d-5, 6.2099d-5 : ,1.421,1.2582 : ,1.642, .376/ c df2h8 =1.d-30 dw2 = .8803686078d0+dq2*(1.d0/dx-1.d0) dwmas = dsqrt(dw2) ddw = (dwmas-1.08d0) c c *** ddw = w - (resonance threshold) c *** lamda(qcd) = d2: 0.20 gev c *** lamda(qcd) = h2: 0.15 gev c if(ddw.le.0.d0) return c c *** use weizmann variable for low q2 c *** values = d2 : daweiz=1.512(gev2), dbweiz=0.351(gev2) c *** values = h2 : daweiz=1.642(gev2), dbweiz=0.376(gev2) c *** ref: bodek et al., p.r.d20(1979)1427. c *** see p.1495, eq(5.1) and table viii c dq2w=dq2+dbw dxw=dq2w/(dq2/dx+daw) dsbar=dlog(dlog(dq2w/.0225d0)) - 1.538942135d0 c dsbar=dlog(dlog(dq2w/.0225d0)/dlog((2.d0+dbw)/.0225d0)) c dsbar = dlog(dlog(dq2w/.04d0)) - 1.404555751d0 detav1 = d1+d2*dsbar detav2 = d3+d4*dsbar detas1 = d5+d6*dsbar detas2 = d7+d8*dsbar c dxw1=1.d0-dxw de1=detav1 de2=detav2+1.d0 c c *** supression due to "quark sum rule" c *** sup.fact.= 1 - gd**2, with gd=nucleon dipole f.f. c *** further supression due to low w phase space volume c den1=(1.d0+dq2/.71d0) dgd2=1.d0/den1**4 dssum = (1.d0-dgd2) dsthr = 1.d0 if( ddw .le. 5.0d0) then dtemp = dexp(ddw*3.98213222d0) dsthr = (dtemp-1.d0)/(dtemp+1.d0) endif ds = dssum * dsthr c df2h8 = : ( .83333333333333*dgamma(de1+de2)/dgamma(de1)/dgamma(de2) : *dxw**detav1*dxw1**detav2 : + .33333333333333*detas1*dxw1**detas2 ) * ds c c *** resonance region c dres = 0.d0 if(ddw .le. 5.0d0) then c c *** >>> + background under the resonance c c *** appropriate kinematic variables c ... dqs = momentum of one pion in pi-nucleon c.m.-system c in the case of single pion production c *** n.b. dqs = 0 at w = 1.08gev (inelastic threshold) c mp**2 = 0.8803686078 c mp**2-m(pi)**2=0.8608892416 c dqs2 = (dw2+0.8608892416d0)**2/4.d0/dw2 - 0.8803686078d0 dqs = dsqrt(dqs2) c c *** >>> + resonance shape c c *** lorentzian resonance c *** this includes the w**2-dependence of the res.width. c c *** appropriate kinematic variables c 1) correction to res.width due to resonance threshold c ... dqs = momentum of one pion in pi-nucleon c.m.-system c in the case of single pion production c 2) correction to res.width due to the q2-dependence c ... dks = momentum of virtual photon in pi-n c.m.-system c if(ddw .le. 1.d0) then c dks2 = : (dw2+0.8803686078d0+dq2)**2/4.d0/dw2 - 0.8803686078d0 dks = dsqrt(dks2) c c *** resonance form factor (effective guess!) c dresff = 1. / den1**(d15**2) c c *** 1236 c wres**2 = 1.232**2 = 1.518 c (wres*gamma)**2 = 1.232**2 * 0.119**2 = 0.02149 c dw2r = 1.518d0 dqsr2 = : (dw2r+0.8608892416d0)**2/4.d0/dw2r - 0.8803686078d0 dqsr = dsqrt(dqsr2) dksr2 = : (dw2r+0.8803686078+dq2)**2/4./dw2r - 0.8803686078 ddcorr = (dqs/dqsr) * (1.+.16/dqsr2)/(1.+.16/dqs2) dncorr = ddcorr * (dksr2+.16)/(dks2+.16) ddcorr = ddcorr**2 dres1 = d9**2 * dncorr : /( (dw2-1.518d0)**2 + 0.02149d0*ddcorr ) c c *** 1520 c wres**2 = 1.520**2 = 2.310 c (wres*gamma)**2 = 1.520**2 * 0.097**2 = 0.02127 c n.b. q2-dependence of the width is neglected c dw2r = 2.310d0 dqsr2 = : (dw2r+0.8608892416d0)**2/4.d0/dw2r - 0.8803686078d0 ddcorr = dqs2/dqsr2 dres2 = d10**2 * ddcorr : / ( (dw2-2.310d0)**2 + 0.02127d0*ddcorr ) c c *** 1681 c wres**2 = 1.681**2 = 2.826 c (wres*gamma)**2 = 1.681**2 * 0.105**2 = 0.03115 c n.b. q2-dependence of the width is neglected c dw2r = 2.826d0 dqsr2 = : (dw2r+0.8608892416d0)**2/4.d0/dw2r - 0.8803686078d0 dqsr = dsqrt(dqsr2) ddcorr = ( dqs/dqsr )**3 dres3 = d11**2 * ddcorr : / ( (dw2-2.826d0)**2 + 0.03115d0*ddcorr ) c c c *** sum of all resonances c * resonance form factor(q2-dependence) c dres = (dres1 +dres2 +dres3)*dresff c c *** end of resonance calculation (only if ddw < 1.0 gev) c endif c c *** background under the resonances c n.b. exp(-0.92**2*3.5393817) = 0.05 c dbgff = dq2val/dxval /den1**(dp(16)**2) c dbgff = 1. / den1**(d16**2) dbg = (d12**2*dsqrt(dqs) +d13**2*dqs +d14**2*dqs2 ) : * dbgff * dexp(-0.5d0*ddw**2) c c *** (resonance region) = ( (resonance) + (background) ) c * dssum(=suppression) c dres = (dres + dbg) * dssum c c *** end of resonance calculation c endif c c *** (total) = (qcd part) + (resonance region) c df2h8 = df2h8 + dres c if(df2h8 .gt. 0.d0) return c df2h8=1.d-30 return end +deck,titout. ************ titout ************************** subroutine titout(date,bmom,tmom,pl1,pn1,qn) implicit real*8(a-h,o-z) character*10 date character*12 switch(100) dimension lsw(100) +self,if=polrad. open(unit=16,file='tails.dat') open(unit=9,file='all.dat') +self. open(unit=7,file='asm.dat') open(unit=21,file='allu.dat') open(unit=23,file='allp.dat') write(7,1)date +self,if=polrad. write(9,1)date write(16,1)date write(16,2) write(9,3) 2 format(/' the file contains information about quantities'/ .' delta (see (42) of smc/7/93)') 3 format(/' the file contains work information about'/ .' contribution of tails') write( 9,43) write(16,43) +self. 1 format(1x,'program polrad20 version from ',a10) write( 7,4) 4 format(/' the file gives born asymmetry, observed asymmetry'/ .' and radiative correstion') write( 7,43) 43 format(/' the following switches are active') nsw=0 +self,if=polrad. nsw=nsw+1 switch(nsw)='polrad' lsw(nsw)=6 +self,if=sirad. nsw=nsw+1 switch(nsw)='sirad' lsw(nsw)=5 +self,if=strffun. nsw=nsw+1 switch(nsw)='strffun' lsw(nsw)=7 +self,if=integrat. nsw=nsw+1 switch(nsw)='integrat' lsw(nsw)=8 +self,if=polrad_add. nsw=nsw+1 switch(nsw)='polrad_add' lsw(nsw)=10 +self,if=fits2. nsw=nsw+1 switch(nsw)='fits2' lsw(nsw)=5 +self,if=alpha2ll. nsw=nsw+1 switch(nsw)='alpha2ll' lsw(nsw)=8 +self,if=exact. nsw=nsw+1 switch(nsw)='exact' lsw(nsw)=5 +self,if=approx. nsw=nsw+1 switch(nsw)='approx' lsw(nsw)=6 +self,if=elect. nsw=nsw+1 switch(nsw)='elect' lsw(nsw)=5 +self,if=muons. nsw=nsw+1 switch(nsw)='muons' lsw(nsw)=5 +self,if=long. nsw=nsw+1 switch(nsw)='long' lsw(nsw)=4 +self,if=tran. nsw=nsw+1 switch(nsw)='long' lsw(nsw)=4 +self,if=iter_pr. nsw=nsw+1 switch(nsw)='iter_pr' lsw(nsw)=7 +self,if=minuit. nsw=nsw+1 switch(nsw)='minuit' lsw(nsw)=6 +self,if=err_prop. nsw=nsw+1 switch(nsw)='err_prop' lsw(nsw)=8 +self,if=iter_pr_g2. nsw=nsw+1 switch(nsw)='iter_pr_g2' lsw(nsw)=10 +self,if=kin_net. nsw=nsw+1 switch(nsw)='kin_net' lsw(nsw)=7 +self,if=kin_smc. nsw=nsw+1 switch(nsw)='kin_smc' lsw(nsw)=7 +self,if=kin_hermes. nsw=nsw+1 switch(nsw)='kin_hermes' lsw(nsw)=10 +self,if=kin_e142. nsw=nsw+1 switch(nsw)='kin_e142' lsw(nsw)=8 +self,if=kin_own. nsw=nsw+1 switch(nsw)='kin_own' lsw(nsw)=7 +self,if=targ_h. nsw=nsw+1 switch(nsw)='targ_h' lsw(nsw)=6 +self,if=targ_d. nsw=nsw+1 switch(nsw)='targ_d' lsw(nsw)=6 +self,if=targ_he3. nsw=nsw+1 switch(nsw)='targ_he3' lsw(nsw)=8 +self,if=targ_c. nsw=nsw+1 switch(nsw)='targ_c' lsw(nsw)=6 +self,if=targ_o. nsw=nsw+1 switch(nsw)='targ_o' lsw(nsw)=6 +self,if=f2nmc_d8. nsw=nsw+1 switch(nsw)='f2nmc_d8' lsw(nsw)=8 +self,if=f2comfst. nsw=nsw+1 switch(nsw)='f2comfst' lsw(nsw)=8 +self,if=f2g1sch. nsw=nsw+1 switch(nsw)='f2g1sch' lsw(nsw)=7 +self,if=f2g1grsv96. nsw=nsw+1 switch(nsw)='f2g1grsv96' lsw(nsw)=10 +self,if=f1qpm. nsw=nsw+1 switch(nsw)='f1qpm' lsw(nsw)=5 +self,if=r_eq_0. nsw=nsw+1 switch(nsw)='r_eq_0' lsw(nsw)=6 +self,if=g1asym. nsw=nsw+1 switch(nsw)='g1asym' lsw(nsw)=6 +self,if=qdstr_gu. nsw=nsw+1 switch(nsw)='qdstr_gu' lsw(nsw)=8 +self,if=g2_eq_0. nsw=nsw+1 switch(nsw)='g2_eq_0' lsw(nsw)=7 +self,if=g2_ww. nsw=nsw+1 switch(nsw)='g2_ww' lsw(nsw)=5 +self,if=ffrg_aub. nsw=nsw+1 switch(nsw)='ffrg_aub' lsw(nsw)=8 +self,if=ffrg_cmb. nsw=nsw+1 switch(nsw)='ffrg_cmb' lsw(nsw)=8 +self,if=ffrg_arn. nsw=nsw+1 switch(nsw)='ffrg_arn' lsw(nsw)=8 +self,if=born. nsw=nsw+1 switch(nsw)='born' lsw(nsw)=4 +self,if=pol_asym. nsw=nsw+1 switch(nsw)='pol_asym' lsw(nsw)=8 +self,if=qua_asym. nsw=nsw+1 switch(nsw)='qua_asym' lsw(nsw)=8 +self,if=cr_sec. nsw=nsw+1 switch(nsw)='cr_sec' lsw(nsw)=6 +self,if=onlyin. nsw=nsw+1 switch(nsw)='onlyin' lsw(nsw)=6 +self,if=outfun_a. nsw=nsw+1 switch(nsw)='outfun_a' lsw(nsw)=8 +self,if=outfun_r. nsw=nsw+1 switch(nsw)='outfun_r' lsw(nsw)=8 +self,if=intdy. nsw=nsw+1 switch(nsw)='intdy' lsw(nsw)=5 +self,if=intdz. nsw=nsw+1 switch(nsw)='intdz' lsw(nsw)=5 +self,if=cuts. nsw=nsw+1 switch(nsw)='cuts' lsw(nsw)=4 +self,if=electroweak. nsw=nsw+1 switch(nsw)='electroweak' lsw(nsw)=11 +self,if=ew_onlyqed. nsw=nsw+1 switch(nsw)='ew_onlyqed' lsw(nsw)=10 +self,if=ew_onlylep. nsw=nsw+1 switch(nsw)='ew_onlylep' lsw(nsw)=10 +self,if=eweak. nsw=nsw+1 switch(nsw)='eweak' lsw(nsw)=5 +self,if=proton. nsw=nsw+1 switch(nsw)='proton' lsw(nsw)=6 +self,if=a_proton. nsw=nsw+1 switch(nsw)='a_proton' lsw(nsw)=8 +self,if=k_minus. nsw=nsw+1 switch(nsw)='k_minus' lsw(nsw)=7 +self,if=k_zero_bar. nsw=nsw+1 switch(nsw)='k_zero_bar' lsw(nsw)=9 +self,if=k_plus. nsw=nsw+1 switch(nsw)='k_plus' lsw(nsw)=6 +self,if=k_zero. nsw=nsw+1 switch(nsw)='k_zero' lsw(nsw)=6 +self,if=pi_minus. nsw=nsw+1 switch(nsw)='pi_minus' lsw(nsw)=8 +self,if=pi_plus. nsw=nsw+1 switch(nsw)='pi_plus' lsw(nsw)=7 +self,if=pi_zero. nsw=nsw+1 switch(nsw)='pi_zero' lsw(nsw)=7 +self,if=pi_diff. nsw=nsw+1 switch(nsw)='pi_diff' lsw(nsw)=7 +self. isw=0 do while(isw.lt.nsw) isw0=isw+1 icc=3 do while(icc.le.71) if(isw.eq.nsw)goto 449 isw=isw+1 icc=icc+lsw(isw)+1 enddo isw=isw-1 449 write(7,420)(switch(iisw)(1:lsw(iisw)+1),iisw=isw0,isw) +self,if=polrad. write(9,420)(switch(iisw)(1:lsw(iisw)+1),iisw=isw0,isw) write(16,420)(switch(iisw)(1:lsw(iisw)+1),iisw=isw0,isw) +self. enddo 420 format(3x,15a) write( 7,6) write( 7,7) write( 7,8) +self,if=polrad. write( 9,6) write( 9,7) write( 9,8) write(16,6) write(16,7) write(16,8) +self,if=elect. 6 format(/' leptons are electrons') +self,if=muons. 6 format(/' leptons are muons') +self,if=targ_h. 7 format(' target is proton') +self,if=targ_d. 7 format(' target is deuteron') +self,if=targ_he3. 7 format(' target is helium-3') +self,if=targ_c. 7 format(' target is carbon') +self,if=targ_o. 7 format(' target is oxygen') +self,if=long. 8 format(' target is longitudinally polarized') +self,if=tran. 8 format(' target is transversally polarized') +self. write(7,9)bmom,tmom,pl1,pn1,qn 9 format(' bmom = ',f5.1/' tmom = ',f5.1 . /' pl = ',f4.2,' pn = ',f4.2,' qn = ',f4.2) write( 7,11) 11 format(/' a is in %') +self,if=polrad. write(9,9)bmom,tmom,pl1,pn1,qn write(16,9)bmom,tmom,pl1,pn1,qn write(16,10) write(16,12) 10 format(/' d is in %') 12 format(/' x',6x,'y',3x,' d _i_p ',' d_e_p ',' d_q_p ', .' d_v_p ',' d_i_u ',' d_e_u ',' d_q_u ',' d_v_u ') write( 7,13) 13 format(/' x',6x,'w2',7x,'q2',2x .,'a(born) ',' a(obs) ',' del(%) ') +self. return end +patch,fits2. +deck,remnk2. subroutine remnk2(nfile,kod,ist,m,l) implicit real*8(a-h,o-z) +seq,commnk. c common/mnk/c0(70,9,5),x(70,5),f(70,9,5),n(5),marr(5),larr(5) logical*1 fircol(j70) common/logic/ fircol character test*1,nfile*10,frm(j5)*13 dimension a(10,11),x0(j70),f0(j70),c(j70),w(j70) dimension istbe(j5),isten(j5),istep(j5) data istbe/1,3,1,1,3/,isten/9,3,4,1,3/,istep/1,1,1,1,1/ data frm/'( 1x ,10f7.3)', . '(2f7.3,4f9.5)','(f6.1,4f13.6)','(2f11.4)', . '(2f7.3,4f9.5)'/ if(kod.gt.j5)pause marr(kod)=m larr(kod)=l print *,nfile open(unit=12,file=nfile,status='old') i=0 ios=0 do while(ios.eq.0) read(12,'(t1,a1)',iostat=ios,end=10)test if(ios.lt.0)test=' ' if(test.eq.' '.or.test.eq.'0')then backspace(12) i=i+1 read(12,frm(kod),iostat=ios)xarr(i,kod) . ,(farr(i,k,kod),k=1,ist) fircol(i)=.true. if(test.eq.'0')fircol(i)=.false. endif enddo 10 narr(kod)=i close(12) do iii=istbe(kod),isten(kod),istep(kod) if(larr(kod).eq.0)goto 99 im=0 do i=1,narr(kod) if(l.ne.4.or.fircol(i))then im=im+1 w(im)=1. if(l.eq.5.and.kod.eq.2)w(im)=farr(i,5,kod) x0(im)=xarr(i,kod) f0(im)=farr(i,iii,kod) endif enddo if(larr(kod).ge.1 .and. larr(kod).le.3)then call gram(narr(kod),m,l,x0,f0,a,w) call gauss(m,a,c) else if(larr(kod).eq.4)then m=im-1 marr(kod)=m call coefsp(m,x0,f0,c) +self,if=minuit. else if(larr(kod).eq.5)then m=im call minsta(m,f0,w,x0,ier) +self. endif do i=1,m carr(i,iii,kod)=c(i) c print *,c(i) enddo 99 continue if(kod.eq.1 .or. kod.eq.3)goto98 open(15,file='fit.dat') xbeg=xarr(1,kod) xfin=max(xarr(narr(kod),kod),xarr(narr(kod)-1,kod)) step=(xfin-xbeg)/100. do xcurr=xbeg,xfin,step ffunk=fitfun(xcurr,kod,iii) write(15,'(1x,2g11.4)')xcurr,ffunk enddo close(15) open(15,file='data.dat') do i=1,narr(kod) write(15,'(1x,2g11.4)')xarr(i,kod),farr(i,iii,kod) enddo close(15) write(*,*)nfile,kod,iii pause 98 continue enddo return end +deck,fitfun. double precision function fitfun(x1,kod,ist) implicit real*8(a-h,o-z) dimension t(10) +seq,commnk. dimension x0(j70),f0(j70) logical*1 fircol(j70) common/logic/ fircol c common/mnk/c(70,9,5),x(70,5),f(70,9,5),narr(5),m(5),larr(5) lar=larr(kod) if(kod.eq.1 .and. ist.ne.2 .and. ist.ne.3)lar=0 im=0 do i=1,narr(kod) if(lar.ne.4.or.fircol(i))then im=im+1 x0(im)=xarr(i,kod) f0(im)=farr(i,ist,kod) endif enddo if(lar.eq.0)then do l=1,narr(kod)-1 do i=1,narr(kod)-l if(x0(i).gt.x0(i+1))then workx=x0(i) x0(i)=x0(i+1) x0(i+1)=workx worky=f0(i) f0(i)=f0(i+1) f0(i+1)=worky endif enddo enddo mar=3 fitfun=divdif(f0,x0,narr(kod),x1,mar) else if(lar.ge.1 .and. lar.le.3 )then s=carr(1,ist,kod) call bas(narr(kod),marr(kod),lar,x1,xarr(1,kod),t) do i=2,marr(kod) s=s+carr(i,ist,kod)*t(i) enddo fitfun=s else if(lar.eq.4)then i=2 31 if(x1.le.x0(i)) goto 32 i=i+1 if(i.ne.marr(kod)+2)goto 31 32 j=i-1 a=f0(j) b=x0(j) q=x0(i)-b r=x1-b p=carr(i,ist,kod) d=carr(i+1,ist,kod) b=(f0(i)-a)/q-(d+2.*p)*q/3. d=(d-p)/q*r p1=b+r*(2.*p+d) p2=2.*(p+d) fitfun=a+r*(b+r*(p+d/3.)) +self,if=minuit. else if(lar.eq.5)then fitfun=shainv(x1) +self. end if return end +deck,amnk. double precision function amnk(kod,x1,ist) implicit real*8(a-h,o-z) +seq,commnk. c common/mnk/c(70,9,5),x(70,5),f(70,9,5),n(5),m(5),l(5) dimension t(10) s=carr(1,ist,kod) call bas(narr(kod),marr(kod),larr(kod),x1,xarr(1,kod),t) do i=2,marr(kod) s=s+carr(i,ist,kod)*t(i) enddo amnk=s return end +deck,adidi. double precision function adidi(kod,m,x1,ist) implicit real*8(a-h,o-z) +seq,commnk. c common/mnk/c0(70,9,5),x(70,5),f(70,9,5),n(5),marr(5),larr(5) dimension x0(j70),f0(j70) do i=1,narr(kod) x0(i)=xarr(i,kod) f0(i)=farr(i,ist,kod) enddo do l=1,narr(kod)-1 do i=1,narr(kod)-l if(x0(i).gt.x0(i+1))then workx=x0(i) x0(i)=x0(i+1) x0(i+1)=workx worky=f0(i) f0(i)=f0(i+1) f0(i+1)=worky endif enddo enddo adidi=divdif(f0,x0,narr(kod),x1,m) return end +deck,gram. subroutine gram(n,m,l,x,f,a,w) implicit real*8(a-h,o-z) +seq,commnk. dimension x(j70),f(j70),a(10,11),p(10,j70),t(10),w(j70) do 21 i=1,n call bas(n,m,l,x(i),x,t) do 21 j=1,m 21 p(j,i)=t(j) do 24 k=1,m do 23 j=k,m s=0.0 r=0.0 do 22 i=1,n q=p(k,i) s=s+q*p(j,i)*w(i) 22 if(j.eq.m)r=r+q*f(i)*w(i) a(k,j)=s 23 a(j,k)=s 24 a(k,m+1)=r return end +deck,gauss. subroutine gauss(n,a,x) implicit real*8(a-h,o-z) dimension x(10),a(10,11) n1=n+1 do 32 k=1,n k1=k+1 s=a(k,k) do 31 j=k1,n1 31 a(k,j)=a(k,j)/s do 32 i=k1,n r=a(i,k) do 32 j=k1,n1 32 a(i,j)=a(i,j)-a(k,j)*r x(n)=a(n,n+1) do 34 i=n-1,1,-1 s=a(i,n+1) do 33 j=i+1,n 33 s=s-a(i,j)*x(j) 34 x(i)=s return end +deck,fi. subroutine fi(n,m,l,c,x,x1,s) implicit real*8(a-h,o-z) dimension c(m),x(n),t(10) s=c(1) call bas(n,m,l,x1,x,t) do i=2,m s=s+c(i)*t(i) enddo return end +deck,bas. subroutine bas(n,m,l,x1,x,t) implicit real*8(a-h,o-z) dimension x(n),t(m) z=2.*(x1-x(1))/(x(n)-x(1))-1.0 t(1)=1.0 t(2)=z do k=2,m-1 r=z*t(k) if(l.eq.1)r=r-t(k-1)/4. if(l.eq.2)r=2.*r-t(k-1) if(l.eq.3)r=((k+k+1)*r-k*t(k-1))/(k+1) t(k+1)=r enddo return end +deck,coefsp. subroutine coefsp(n,x,f,c) implicit real*8(a-h,o-z) +seq,commnk. dimension x(j70),f(j70),c(j70),u(j70) u(2)=0. c(2)=0. do 21 i=3,n+1 j=i-1 m=j-1 a=x(i)-x(j) b=x(j)-x(m) r=2.*(a+b)-b*c(j) c(i)=a/r 21 u(i)=(3.*((f(i)-f(j))/a-(f(j)-f(m))/b)-b*u(j))/r c(n+1)=u(n+1) do 22 i=n,3,-1 22 c(i)=u(i)-c(i)*c(i+1) return end +deck,divdif. function divdif(f,a,nn,x,mm) implicit real*8(a-h,o-z) +seq,commnk. dimension a(j70),f(j70),t(20),d(20) logical extra c logical mflag,rflag data mmax/10/ c c tabular interpolation using symmetrically placed argument points. c c start. find subscript ix of x in array a. *ak if( (nn.lt.2) .or. (mm.lt.1) ) go to 20 n=nn m=min0(mm,mmax,n-1) mplus=m+1 ix=0 iy=n+1 if(a(1).gt.a(n)) go to 4 c (search increasing arguments.) 1 mid=(ix+iy)/2 if(x.ge.a(mid)) go to 2 iy=mid go to 3 c (if true.) 2 ix=mid 3 if(iy-ix.gt.1) go to 1 go to 7 c (search decreasing arguments.) 4 mid=(ix+iy)/2 if(x.le.a(mid)) go to 5 iy=mid go to 6 c (if true.) 5 ix=mid 6 if(iy-ix.gt.1) go to 4 c c copy reordered interpolation points into (t(i),d(i)), setting c *extra* to true if m+2 points to be used. 7 npts=m+2-mod(m,2) ip=0 l=0 go to 9 8 l=-l if(l.ge.0) l=l+1 9 isub=ix+l if((1.le.isub).and.(isub.le.n)) go to 10 c (skip point.) npts=mplus go to 11 c (insert point.) 10 ip=ip+1 t(ip)=a(isub) d(ip)=f(isub) 11 if(ip.lt.npts) go to 8 extra=npts.ne.mplus c c replace d by the leading diagonal of a divided-difference table, sup- c plemented by an extra line if *extra* is true. do 14 l=1,m if(.not.extra) go to 12 isub=mplus-l d(m+2)=(d(m+2)-d(m))/(t(m+2)-t(isub)) 12 i=mplus do 13 j=l,m isub=i-l d(i)=(d(i)-d(i-1))/(t(i)-t(isub)) i=i-1 13 continue 14 continue c c evaluate the newton interpolation formula at x, averaging two values c of last difference if *extra* is true. sum=d(mplus) if(extra) sum=0.5*(sum+d(m+2)) j=m do 15 l=1,m sum=d(j)+(x-t(j))*sum j=j-1 15 continue divdif=sum return end +deck,minsta,if=minuit. subroutine minsta(nt,as,eas,x,ier) implicit double precision (a-h,o-z) c external fcn,futil external fcn dimension as(nt),eas(nt),x(nt) common /datamin/asc(100),easc(100),xc(100),ntc +seq,compar. dimension nprm(npar),stval(npar),step(npar) . ,pmin(npar),pmax(npar) +self,if=targ_h. character*10 chnam(3)!/' aa =',' bb =',' cc ='/ data !stval/1.90202d-2,-1.16312d-3,1.84517d0/ . pmin/npar*-1000./ . pmax/npar*1000./ . step/npar*0.0001/ data chnam/' aa =',' bb =',' cc ='/ +self,if=targ_d. character*10 chnam(3)!/' aa =',' bb =',' cc ='/ data stval/8.2885d0,3.23589d-2,.142777d0 / . pmin/-1000.,-1000.,-1000./ . pmax/1000.,1000.,1000./ . step/npar*0.0001/ data chnam/' aa =',' bb =',' cc ='/ +self,if=targ_he3. character*10 chnam(3)!/'a10 =','au0 =',' a7 ='/ data stval/1.008,0.3154,94.3079/ c data stval/0.25,0.19,7./ . pmin/0.00006,0.00006,0.00005/ . pmax/10.88,112.88,135./ . step/npar*0.0001/ data chnam/'a10 =','au0 =',' a7 ='/ +self. * * init minuit and read param. * do i=1,nt asc(i)=as(i) easc(i)=eas(i) xc(i)=x(i) c write(9,'(1x,i3,3g11.4)')i,xc(i),asc(i),easc(i) enddo ntc=nt +self,if=targ_h. if(npar.eq.1)then stval(1)=0.725 elseif(npar.eq.2)then stval(1)=1.000 stval(2)=0.725 elseif(npar.eq.3)then stval(1)=1.90202d-2 stval(2)=-1.16312d-3 stval(3)=1.84517d0 endif +self. call mninit(5,6,7) argl=-1. call mnexcm(fcn,'set pri',argl,1,ierf,0) argl=0. call mnexcm(fcn,'set nowarn',argl,1,ierf,0) do i=1,npar nprm(i)=i call mnparm(nprm(i),chnam(i),stval(i),step(i) . ,pmin(i),pmax(i),ier) if(ier.ne.0) then write(6,'(a13)') 'unable to define param :',i stop endif enddo * title call mnseti(' minuit for minim. spin asymmetry') * set strategy (0,1,3) argl=2. call mnexcm(fcn,'set str',argl,1,ierf,0) * call migrad argl=0. call mnexcm(fcn,'migrad',argl,1,ierf,0) if(ierf.ne.0)then ier=8 return endif * call minos c argl=10. c call mnexcm(fcn,'minos',argl,1,ierf,0) c argl=1. c call mnexcm(fcn,'sho fcn',am1,1,ierf,0) * ouptut results write(*,'(1x,8hchi^2 = ,f6.2)')chi2 do i=1,npar call mnpout(nprm(i),chnam(i),stvali,stepi . ,pmin(i),pmax(i),ierf) write(*,'(1x,a5,f7.4,5h +/- ,f7.4)') . chnam(i),stvali,stepi enddo end * * function fcn * subroutine fcn(npara,grad,fval,apar,iflag,futil) * implicit double precision (a-h,o-z) +seq,compar. common /datamin/as(100),eas(100),x(100),nt dimension grad(npara),apar(npara) external futil if(npara.ne.npar)stop 'npara.ne.npar' do inp=1,npara par(inp)=apar(inp) enddo if(iflag.eq.1)then endif if(iflag.eq.2)then endif fval=0. do i=1,nt a1=as(i) x1=x(i) da1=eas(i) fa1=shainv(x1) fval=fval+((a1-fa1)/da1)**2. enddo if(iflag.eq.3)then endif chi2=fval/(nt-3) c write(*,*) ' chisquare/dof=',chi1 return end c---------------------------------------------------------------- subroutine futil implicit double precision (a-h,o-z) return end c---------------------------------------------------------------- subroutine intrac implicit double precision (a-h,o-z) return end double precision function shainv(aks) implicit double precision (a-h,o-z) +seq,compar. dimension df1as(npar),df2as(npar,npar) call as1dif(aks,npar,par,as,df1as,df2as) if(ipara.eq.0)then shainv=as else shainv=df1as(ipara) endif return end subroutine as1dif(x,npar,par,as,df1as,df2as) implicit real*8(a-h,o-z) dimension par(npar),df1as(npar),df2as(npar,npar) +self,if=targ_h. if(npar.eq.3)then fiecx=exp(-par(3)*x) xb=x**par(2) xlog=log(x) as=par(1)+xb*(1d0-fiecx) df1as(1)=1. df1as(2)=xb*xlog*(-fiecx+1.) df1as(3)=xb*fiecx*x df2as(1,1)=0. df2as(2,1)=0. df2as(3,1)=0. df2as(1,2)=0. df2as(2,2)=xb*xlog**2*(-fiecx+1.) df2as(3,2)=xb*xlog*fiecx*x df2as(1,3)=0. df2as(2,3)=xb*xlog*fiecx*x df2as(3,3)=-xb*fiecx*x**2 elseif(npar.eq.2)then xb=x**par(2) as=par(1)*xb df1as(1)=xb df1as(2)=as*log(x) df2as(1,1)=0d0 df2as(2,1)=xb*log(x) df2as(1,2)=xb*log(x) df2as(2,2)=as*log(x)**2 elseif(npar.eq.1)then as=x**par(1) df1as(1)=as*log(x) df2as(1,1)=as*log(x)**2 endif +self,if=targ_d. a=par(1) b=par(2) c=par(3) fieax=exp(-a*x) bc=b**c xc=x**c dlx=log(x) dlb=log(b) as=(fieax-1.)*(bc-xc) DF1AS(1)=-(BC-XC)*FIEAX*X DF1AS(2)=((FIEAX-1.)*BC*C)/B DF1AS(3)=(BC*DLB-DLX*XC)*(FIEAX-1.) DF2AS(1,1)=(BC-XC)*FIEAX*X**2 DF2AS(2,1)=(-BC*C*FIEAX*X)/B DF2AS(3,1)=-(BC*DLB-DLX*XC)*FIEAX*X DF2AS(1,2)=(-BC*C*FIEAX*X)/B DF2AS(2,2)=((C-1.)*(FIEAX-1.)*BC*C)/B**2 DF2AS(3,2)=((C*DLB+1.)*(FIEAX-1.)*BC)/B DF2AS(1,3)=-(BC*DLB-DLX*XC)*FIEAX*X DF2AS(2,3)=((C*DLB+1.)*(FIEAX-1.)*BC)/B DF2AS(3,3)=(BC*DLB**2-DLX**2*XC)*(FIEAX-1.) +self,if=targ_he3. auq=.588 adq=1.03 buq=2.69 bdq=6.89 a10=par(1) au0=par(2) a7=par(3) xuv =2./beta(auq,buq+1.)*x**auq*(1d0-x)**buq xdv =1./beta(adq,bdq+1.)*x**adq*(1d0-x)**bdq a0=xuv-xdv/2d0 a1=1.5d0*xdv f2=1./9.*a0+1./3.*a1 xu=x**(-auq)*(1.-x)**2 xd=x**(-adq)*(1.-x)**2 fu0=1./(1.+au0*xu) fu1=1./(1.+a10*au0*xu) fd0=1./(1.+a7*au0*xd) fd1=1./(1.+a7*a10*au0*xd) as=(1./9.*a0*fd0+8./27.*(-2./3.*fu1+1./3.*fu0)*a1+ . 1./27.*(-2./3.*fd1+1./3.*fd0)*a1)/f2 DF1AS(1)=(2.*(A7*FD1**2*XD+8.*FU1**2*XU)*A1*AU0)/(81.*F2) DF1AS(2)=(-((9.*A0+A1)*A7*FD0**2*XD-2.*(A7*FD1**2*XD+8.* . FU1**2*XU)*A10*A1+8.*A1*FU0**2*XU))/(81.*F2) DF1AS(3)=(-((9.*A0+A1)*FD0**2-2.*A10*A1*FD1**2)*AU0*XD)/( . 81.*F2) DF2AS(1,1)=(-4.*(A7**2*FD1**3*XD**2+8.*FU1**3*XU**2)*A1* . AU0**2)/(81.*F2) DF2AS(2,1)=(-2.*(2.*(A7**2*FD1**3*XD**2+8.*FU1**3*XU**2)* . A10*AU0-A7*FD1**2*XD-8.*FU1**2*XU)*A1)/(81.*F2) DF2AS(3,1)=(-2.*(A10*A7*AU0*XD-1.)*A1*AU0*FD1**3*XD)/(81.* . F2) DF2AS(1,2)=(-2.*(2.*(A7**2*FD1**3*XD**2+8.*FU1**3*XU**2)* . A10*AU0-A7*FD1**2*XD-8.*FU1**2*XU)*A1)/(81.*F2) DF2AS(2,2)=(2.*((9.*A0+A1)*A7**2*FD0**3*XD**2-2.*(A7**2* . FD1**3*XD**2+8.*FU1**3*XU**2)*A10**2*A1+8.*A1*FU0**3*XU** . 2))/(81.*F2) DF2AS(3,2)=((2.*((9.*A0+A1)*FD0**3-2.*A10**2*A1*FD1**3)*A7 . *AU0*XD-(9.*A0+A1)*FD0**2+2.*A10*A1*FD1**2)*XD)/(81.*F2) DF2AS(1,3)=(-2.*(A10*A7*AU0*XD-1.)*A1*AU0*FD1**3*XD)/(81.* . F2) DF2AS(2,3)=(((9.*A0+A1)*(A7*AU0*XD-1.)*FD0**3-4.*A10**2*A1 . *A7*AU0*FD1**3*XD+2.*A10*A1*FD1**2)*XD)/(81.*F2) DF2AS(3,3)=(2.*((9.*A0+A1)*FD0**3-2.*A10**2*A1*FD1**3)*AU0 . **2*XD**2)/(81.*F2) +self. end subroutine dpafun(n,x,as,err,dpa) implicit real*8(a-h,o-z) +seq,compar. dimension x(n),as(n),err(n),dpa(npar,n) dimension d1(npar),d2(npar,npar) dimension am(npar,npar),rev(npar,npar) do k=1,npar do m=1,npar sum=0. do i=1,n call as1dif(x(i),npar,par,f,d1,d2) sum=sum+(as(i)*d2(k,m)-f*d2(k,m)-d1(k)*d1(m))/err(i)**2 enddo Am(k,m)=sum enddo enddo call trirev(npar,am,rev,ier) if(ier.ne.0)stop 'det=0' do j=1,n call as1dif(x(j),npar,par,f,d1,d2) do k=1,npar sum=0. do m=1,npar sum=sum-d1(m)/err(j)**2*rev(m,k) enddo dpa(k,j)=sum enddo enddo end subroutine trirev(n,d,c,ier) implicit real*8(a-h,o-z) dimension c(n,n),d(n,n) ier=0 do 11 i=1,n do 11 j=1,n 11 c(i,j)=0d0 if(n.eq.1)then DETD= d(1,1) if(abs(detd).le.1d-13)then ier=1 return endif elseif(n.eq.2)then DETD= d(2,2)*d(1,1) - d(2,1)*d(1,2) if(abs(detd).le.1d-13)then ier=1 return endif c(1,1)=d(2,2)/DETD c(1,2)=-d(1,2)/DETD c(2,1)=-d(2,1)/DETD c(2,2)=d(1,1)/DETD elseif(n.eq.3)then DETD= D(3,3)*D(2,2)*D(1,1)-D(3,3)*D(2,1)*D(1,2)-D(3,2)*D(2, . 3)*D(1,1)+D(3,2)*D(2,1)*D(1,3)+D(3,1)*D(2,3)*D(1,2)-D(3,1 . )*D(2,2)*D(1,3) if(abs(detd).le.1d-13)then ier=1 return endif C(1,1)=(D(3,3)*D(2,2)-D(3,2)*D(2,3))/DETD C(1,2)=(-D(3,3)*D(1,2)+D(3,2)*D(1,3))/DETD C(1,3)=(D(2,3)*D(1,2)-D(2,2)*D(1,3))/DETD C(2,1)=(-D(3,3)*D(2,1)+D(3,1)*D(2,3))/DETD C(2,2)=(D(3,3)*D(1,1)-D(3,1)*D(1,3))/DETD C(2,3)=(-D(2,3)*D(1,1)+D(2,1)*D(1,3))/DETD C(3,1)=(D(3,2)*D(2,1)-D(3,1)*D(2,2))/DETD C(3,2)=(-D(3,2)*D(1,1)+D(3,1)*D(1,2))/DETD C(3,3)=(D(2,2)*D(1,1)-D(2,1)*D(1,2))/DETD endif end +patch,integrat. c there are modules necessary for integration over the c phase space of the emitted photon and over the variable c y in this patch. integrators dqunc8, dqvnc8, dqwnc8 are c identical and based on the newton-cotes method of the c eighth order. +keep, automat. automatic c,d,e,f,h,i,j,k,m,n,p,q,s,ar,t,fn,v,w,x,lm,z,xn,st +keep, dqnc8. implicit real*8 (a-h,o-z) dimension h(31),f(16),v(8,30),z(8,30),x(16) parameter (l=6) parameter (wd = 5.0d-1) parameter (wn = 2.79082892416225747d-1) parameter (w1 = 1.66151675485008798d+0) parameter (w2 =-2.61869488536155201d-1) parameter (w3 = 2.96183421516754830d+0) parameter (w4 =-1.28112874779541430d+0) c+seq, automat. lm=30 n=nx-1216 if(n.lt.200)n=200 r=0d0 fl=r er=fl nn=0 if(a.eq.b)return c=fl ar=fl k=nn m=1 xn=a x(16)=b p=fl fn=fun(xn) s=(b-a)*625d-4 x(8)=(a+b)*wd x(4)=(a+x(8))*wd x(12)=(x(8)+b)*wd x(2)=(a+x(4))*wd x(6)=(a+x(12))*wd x(10)=(x(4)+b)*wd x(14)=(x(12)+b)*wd do 25 j=2,16,2 25 f(j)=fun(x(j)) nn=9 30 x(1)=(xn+x(2))*wd f(1)=fun(x(1)) do 35 j=3,15,2 x(j)=(x(j-1)+x(j+1))*wd 35 f(j)=fun(x(j)) nn=nn+8 st=(x(16)-xn)*625d-4 q=((fn+f(8))*wn+(f(1)+f(7))*w1+ *(f(2)+f(6))*w2+(f(3)+f(5))*w3+ *f(4)*w4)*st h(k+1)=((f(8)+f(16))*wn+(f(9)+f(15))*w1+ *(f(10)+f(14))*w2+(f(11)+f(13))*w3+ *f(12)*w4)*st w=q+h(k+1) d=w-p ar=ar+d e=dabs(d)/1023d0 t=dmax1(ab,rl*dabs(ar))*(st/s) if(k.lt.1)go to 50 if(k.ge.lm)go to 62 if(nn.gt.n)go to 60 if(e.le.t)go to 70 50 m=2*m k=k+1 do 52 i=1,8 j=i+8 v(i,k)=f(j) 52 z(i,k)=x(j) p=q do 55 i=1,8 j=9-i f(2*j)=f(j) 55 x(2*j)=x(j) go to 30 60 n=2*n lm=l fl=fl+(b-xn)/(b-a) go to 70 62 fl=fl+1d0 70 r=r+w er=er+e c=c+d/1023d0 72 if(m.eq.2*(m/2))go to 75 m=m/2 k=k-1 go to 72 75 m=m+1 if(k.le.0)go to 80 p=h(k) xn=x(16) fn=f(16) do 78 i=1,8 f(2*i)=v(i,k) 78 x(2*i)=z(i,k) go to 30 80 r=r+c if(er.eq.0d0)return ar=dabs(r) 82 q=ar+er if(q.ne.ar)return er=2d0*er go to 82 end ccc----------------------------------------------------------------------------- +deck, dqunc8. subroutine dqunc8(fun,a,b,ab,rl,r,er,nn,fl,nx) +seq, dqnc8. +deck, dqvnc8. subroutine dqvnc8(fun,a,b,ab,rl,r,er,nn,fl,nx) +seq, dqnc8. +deck, dqwnc8, if=intdy. subroutine dqwnc8(fun,a,b,ab,rl,r,er,nn,fl,nx) +seq, dqnc8. +deck,d01fce. subroutine d01fce(ndim, a, b, minpts, maxpts, functn, eps, * acc, lenwrk, wrkstr, finval, ifail) implicit real*8(a-h,o-z) c mark 8 release. nag copyright 1979. c c adaptive multidimensional integration subroutine c c ********* parameters for d01fce **************************** c c input parameters c c ndim integer number of variables, must exceed 1 but c not exceed 15. c c a real array of lower limits, with dimension ndim c c b real array of upper limits, with dimension ndim c c minpts integer minimum number of integrand values to be c allowed, which must not exceed maxpts. c c maxpts integer maximum number of integrand values to be c allowed, which must be at least c 2**ndim+2*ndim**2+2*ndim+1. c c functn externally declared user defined real function c integrand. it must have parameters (ndim,z), c where z is a real array of dimension ndim. c c eps real required relative accuracy, must be greater c than zero c c lenwrk integer length of array wrkstr, must be at least c 2*ndim+4. c c ifail integer nag failure parameter c ifail=0 for hard fail c ifail=1 for soft fail c c output parameters c c minpts integer number of integrand values used by the c routine c c wrkstr real array of working storage of dimension (lenwrk). c c acc real estimated relative accuracy of finval c c finval real estimated value of integral c c ifail ifail=0 for normal exit, when estimated relative c less integaccuracy rand values used. c c ifail=1 if ndim.lt.2, ndim.gt.15, minpts.gt.maxpts, c maxpts.lt.2**ndim+2*ndim*(ndim+1)+1, eps.le.0 c or lenwrk.lt.2*ndim+4. c c ifail=2 if maxpts was too small for d01fce to obtain the c required relative accuracy eps. in this c case d01fce returns a value of finval c with estimated relative accuracy acc. c c ifail=3 if lenwrk too small for maxpts integrand c values. in this case d01fce returns a c value of finval with estimated accuracy c acc using the working storage c available, but acc will be greater c than eps. c c ************************************************************** c c .. scalar arguments .. * real eps, finval, acc * integer ifail, lenwrk, maxpts, minpts, ndim c .. array arguments .. ** real a(ndim), b(ndim), wrkstr(lenwrk) dimension a(ndim), b(ndim), wrkstr(lenwrk) c .. function arguments .. * real functn c .. c .. local scalars .. character*8 srname double precision * abserr, df1, df2, difmax, f1, f2, f3, f4, half, lamda2, * lamda4, lamda5, one, ratio, rgncmp, rgnerr, rgnert, rgnval, * rgnvlt, rgnvol, rlndim, sum1, sum2, sum3, sum4, sum5, two, * twondm, weit1, weit2, weit3, weit4, weit5, weitp1, weitp2, * weitp3, weitp4, zero integer dvaxes, dvaxis, dvflag, funcls, ierror, j, k, maxaxs, * mxrgns, pointr, rgncls, rulcls, sbrgns, subrgn, subtmp, * tpontp, tpontr c .. local arrays .. dimension center(15), dif(15), oldcnt(15), width(15), z(15) integer dvcntl(15), dvcntr(15) c .. function references .. * real sqrt, x02aae integer p01aae, x02bbe c .. data srname /' d01fce'/ data zero, one, two, half /0.d0, 1.d0, 2.d0, 0.5d0/ c c subroutine initialisation and parameter checking c if (ndim.lt.2 .or. ndim.gt.15) go to 560 if (minpts.gt.maxpts) go to 560 if (eps.le.zero) go to 560 if (lenwrk.lt.2*ndim+4) go to 560 funcls = 0 finval = zero abserr = zero twondm = two**ndim rgnvol = twondm dvflag = 1 fffff1 = float(x02bbe(one)) fffff2 = 1.0/x02aae(0.0d0) maxaxs = int(dmin1(fffff1,fffff2)) c maxaxs = int(amin1(float(x02bbe(one)),1.0/x02aae(0.0d0))) maxaxs = (maxaxs-ndim)/(ndim+1) mxrgns = lenwrk/(2*ndim+4) sbrgns = 0 rgnvlt = zero rgnert = zero do 20 j=1,ndim center(j) = (a(j)+b(j))*half dif(j) = zero width(j) = (b(j)-a(j))*half dvcntl(j) = 1 dvcntr(j) = 1 oldcnt(j) = center(j) rgnvol = rgnvol*width(j) 20 continue c c end subroutine initialisation c basic rule initialisation c rulcls = 2**ndim + 2*ndim*ndim + 2*ndim + 1 funcls = rulcls if (maxpts.lt.rulcls) go to 560 rlndim = ndim lamda2 = sqrt(9.0/70.0) lamda4 = sqrt(9.0/10.0) lamda5 = sqrt(9.0/19.0) weit1 = (12824.0-9120.0*rlndim+400.0*rlndim*rlndim)/19683.0 weit2 = 980.0/6561.0 weit3 = (1820.0-400.0*rlndim)/19683.0 weit4 = 200.0/19683.0 weit5 = 6859.0/19683.0/twondm weitp1 = (729.0-950.0*rlndim+50.0*rlndim**2)/729.0 weitp2 = 245.0/486.0 weitp3 = (265.0-100.0*rlndim)/1458.0 weitp4 = 25.0/729.0 ratio = (lamda2/lamda4)**2 c c end basic rule initialisation go to 100 c divide subregion with largest error and prepare to use c basic rule on each portion c 40 subrgn = 1 pointr = wrkstr(1) rgncls = rulcls rgnvol = twondm tpontr = pointr + 2 do 60 j=1,ndim tpontr = tpontr + 2 center(j) = wrkstr(tpontr-1) width(j) = wrkstr(tpontr) dvcntr(j) = 1 dvcntl(j) = 1 oldcnt(j) = center(j) rgnvol = rgnvol*width(j) 60 continue dvaxes = wrkstr(pointr+2) if (dvaxes.lt.0) go to 600 80 dvaxis = dvaxes dvaxes = dvaxis/(ndim+1) dvaxis = dvaxis - (ndim+1)*dvaxes dvcntl(dvaxis) = 2*dvcntl(dvaxis) rgncls = rgncls*2 if (dvaxes.gt.0) go to 80 if (funcls+rgncls.gt.maxpts) go to 580 if (rgncls/rulcls+sbrgns-1.gt.mxrgns) dvflag = 2 funcls = funcls + rgncls c print *,funcls abserr = abserr - wrkstr(pointr) finval = finval - wrkstr(pointr+1) c c begin basic rule 100 do 120 j=1,ndim z(j) = center(j) 120 continue sum1 = functn(ndim,z) sum2 = zero sum3 = zero do 140 j=1,ndim z(j) = center(j) - lamda2*width(j) f1 = functn(ndim,z) z(j) = center(j) + lamda2*width(j) f2 = functn(ndim,z) z(j) = center(j) - lamda4*width(j) f3 = functn(ndim,z) z(j) = center(j) + lamda4*width(j) f4 = functn(ndim,z) sum2 = sum2 + f1 + f2 sum3 = sum3 + f3 + f4 df1 = f1 + f2 - two*sum1 df2 = f3 + f4 - two*sum1 dif(j) = dif(j) + abs(df1-ratio*df2) z(j) = center(j) 140 continue sum4 = zero do 200 j=2,ndim z(j-1) = center(j-1) - lamda4*width(j-1) do 160 k=j,ndim z(k) = center(k) - lamda4*width(k) sum4 = sum4 + functn(ndim,z) z(k) = center(k) + lamda4*width(k) sum4 = sum4 + functn(ndim,z) z(k) = center(k) 160 continue z(j-1) = center(j-1) + lamda4*width(j-1) do 180 k=j,ndim z(k) = center(k) - lamda4*width(k) sum4 = sum4 + functn(ndim,z) z(k) = center(k) + lamda4*width(k) sum4 = sum4 + functn(ndim,z) z(k) = center(k) 180 continue z(j-1) = center(j-1) 200 continue sum5 = zero do 220 j=1,ndim z(j) = center(j) - lamda5*width(j) 220 continue 240 do 260 j=2,ndim if (z(j-1).lt.center(j-1)+width(j-1)) go to 280 z(j-1) = center(j-1) - lamda5*width(j-1) z(j) = z(j) + two*lamda5*width(j) 260 continue if (z(ndim).gt.center(ndim)+width(ndim)) go to 300 280 sum5 = sum5 + functn(ndim,z) z(1) = z(1) + two*lamda5*width(1) go to 240 300 rgnval = rgnvol*(weit1*sum1+weit2*sum2+weit3*sum3+weit4* * sum4+weit5*sum5) rgncmp = rgnvol*(weitp1*sum1+weitp2*sum2+weitp3*sum3+weitp4* * sum4) rgnerr = abs(rgnval-rgncmp) c c end basic rule c store results of basic rule application c rgnvlt = rgnvlt + rgnval rgnert = rgnert + rgnerr finval = finval + rgnval abserr = abserr + rgnerr if (dvflag.eq.0) go to 340 if (dvflag.eq.2) go to 500 pointr = mxrgns + sbrgns*(2*ndim+3) + 1 sbrgns = sbrgns + 1 wrkstr(sbrgns) = pointr subrgn = sbrgns tpontr = pointr + 2 do 320 j=1,ndim tpontr = tpontr + 2 wrkstr(tpontr-1) = center(j) wrkstr(tpontr) = width(j) 320 continue 340 wrkstr(pointr) = rgnert wrkstr(pointr+1) = rgnvlt c determine axis along which fourth difference is largest difmax = zero do 380 j=1,ndim if (difmax.gt.dif(j)) go to 360 difmax = dif(j) dvaxis = j 360 dif(j) = zero 380 continue tpontr = pointr + 2*(dvaxis+1) wrkstr(tpontr) = width(dvaxis)*half wrkstr(tpontr-1) = center(dvaxis) - wrkstr(tpontr) if (dvflag.ne.2) go to 400 dvaxes = wrkstr(pointr+2) if (dvaxes.gt.maxaxs) dvaxes = -1 dvaxis = dvaxis + (ndim+1)*dvaxes 400 wrkstr(pointr+2) = dvaxis if (dvflag.eq.1) go to 460 c determine the position in the parially ordered list of c the subregion which replaces most recently divided subregion 420 subtmp = 2*subrgn if (subtmp.gt.sbrgns) go to 480 tpontr = wrkstr(subtmp) if (subtmp.eq.sbrgns) go to 440 tpontp = wrkstr(subtmp+1) if (wrkstr(tpontr).ge.wrkstr(tpontp)) go to 440 subtmp = subtmp + 1 tpontr = tpontp 440 if (rgnert.ge.wrkstr(tpontr)) go to 480 wrkstr(subtmp) = pointr wrkstr(subrgn) = tpontr subrgn = subtmp go to 420 c when working storage is not used up, determine the c position in the partially ordered list for the description c of other portion(s) of most recently divided subregion 460 subtmp = subrgn/2 if (subtmp.lt.1) go to 480 tpontr = wrkstr(subtmp) if (rgnert.le.wrkstr(tpontr)) go to 480 wrkstr(subtmp) = pointr wrkstr(subrgn) = tpontr subrgn = subtmp go to 460 480 rgnvlt = zero rgnert = zero if (dvflag.eq.2) go to 540 dvflag = 1 - dvflag c count to determine the next part of the recently divided c subregion for application of the basic rule 500 center(1) = center(1) + two*width(1) dvcntr(1) = dvcntr(1) + 1 do 520 j=2,ndim if (dvcntr(j-1).le.dvcntl(j-1)) go to 100 dvcntr(j-1) = 1 center(j-1) = oldcnt(j-1) dvcntr(j) = dvcntr(j) + 1 center(j) = center(j) + two*width(j) 520 continue if (dvcntr(ndim).le.dvcntl(ndim)) go to 100 center(ndim) = oldcnt(ndim) if (dvflag.eq.2) go to 340 c c end ordering of basic rule results c make checks for possible termination of routine c 540 acc = abserr/abs(finval) if (acc.gt.eps .or. funcls.lt.minpts) go to 40 c c loop back to apply basic rule c c termination point, set ifail and return c ierror = 0 go to 620 560 ierror = 1 go to 620 580 ierror = 2 go to 620 600 ierror = 3 620 minpts = funcls ifail = p01aae(ifail,ierror,srname) return end double precision function x02aae(x) implicit real*8(a-h,o-z) c nag copyright 1975 c mark 4.5 release c+self,if=ibm. cc for ibm/360/370/3090 c data z/z3380000000000000/ c x02aae = z c for sun data z/1.1d-16/ x02aae = z c * eps * c returns the value eps where eps is the smallest c positive c number such that 1.0 + eps > 1.0 c the x parameter is not used c for icl 1900 c x02aae = 2.0**(-37.0) c+self,if=pc. c for pdp11 c x02aae=2.d0**(-23.d0) c+self. return end c integer function x02bbe(x) implicit real*8(a-h,o-z) c nag copyright 1975 c mark 4.5 release * real x c * maxint * c returns the largest integer representable on the computer c the x parameter is not used c for icl 1900 c x02bbe = 8388607 c for ibm,sun,vax,ibm pc/386/486 x02bbe = 2147483647 c for pdp11 c x02bbe=32767 return end integer function p01aae(ifail, error, srname) c mark 1 release. nag copyright 1971 c mark 3 revised c mark 4a revised, ier-45 c mark 4.5 revised c mark 7 revised (dec 1978) c returns the value of error or terminates the program. integer error, ifail, nout character*8 srname c test if no error detected if (error.eq.0) go to 20 c determine output unit for message call x04aae (0,nout) c test for soft failure if (mod(ifail,10).eq.1) go to 10 c hard failure write (nout,99999) srname, error c stopping mechanism may also differ stop c soft fail c test if error messages suppressed 10 if (mod(ifail/10,10).eq.0) go to 20 write (nout,99999) srname, error 20 p01aae = error return 99999 format (1h0, 38herror detected by nag library routine , a8, * 11h - ifail = , i5//) end subroutine x04aae(i,nerr) c mark 7 release. nag copyright 1978 c mark 7c revised ier-190 (may 1979) c if i = 0, sets nerr to current error message unit number c (stored in nerr1). c if i = 1, changes current error message unit number to c value specified by nerr. c c *** note *** c this routine assumes that the value of nerr1 is saved c between calls. in some implementations it may be c necessary to store nerr1 in a labelled common c block /ax04aa/ to achieve this. c c .. scalar arguments .. integer i, nerr c .. c .. local scalars .. integer nerr1 c .. data nerr1 /5/ if (i.eq.0) nerr = nerr1 if (i.eq.1) nerr1 = nerr return end +deck,dqg32. subroutine dqg32(xl,xu,fct,y) c c computation of integrals by means of 32-point gauss quadrature c formula, which integrates polynomials up to degree 63. c c double precision xl,xu,y,a,b,c,fct c a=.5d0*(xu+xl) b=xu-xl c=.49863193092474078d0*b y=.35093050047350483d-2*(fct(a+c)+fct(a-c)) c=.49280575577263417d0*b y=y+.8137197365452835d-2*(fct(a+c)+fct(a-c)) c=.48238112779375322d0*b y=y+.12696032654631030d-1*(fct(a+c)+fct(a-c)) c=.46745303796886984d0*b y=y+.17136931456510717d-1*(fct(a+c)+fct(a-c)) c=.44816057788302606d0*b y=y+.21417949011113340d-1*(fct(a+c)+fct(a-c)) c=.42468380686628499d0*b y=y+.25499029631188088d-1*(fct(a+c)+fct(a-c)) c=.39724189798397120d0*b y=y+.29342046739267774d-1*(fct(a+c)+fct(a-c)) c=.36609105937014484d0*b y=y+.32911111388180923d-1*(fct(a+c)+fct(a-c)) c=.33152213346510760d0*b y=y+.36172897054424253d-1*(fct(a+c)+fct(a-c)) c=.29385787862038116d0*b y=y+.39096947893535153d-1*(fct(a+c)+fct(a-c)) c=.25344995446611470d0*b y=y+.41655962113473378d-1*(fct(a+c)+fct(a-c)) c=.21067563806531767d0*b y=y+.43826046502201906d-1*(fct(a+c)+fct(a-c)) c=.16593430114106382d0*b y=y+.45586939347881942d-1*(fct(a+c)+fct(a-c)) c=.11964368112606854d0*b y=y+.46922199540402283d-1*(fct(a+c)+fct(a-c)) c=.7223598079139825d-1*b y=y+.47819360039637430d-1*(fct(a+c)+fct(a-c)) c=.24153832843869158d-1*b y=b*(y+.48270044257363900d-1*(fct(a+c)+fct(a-c))) return end c +deck,qunc8. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * subroutine qunc8(fun,a,b,ab,rl,r,er,nn,fl,nx) * * * * * * * * * * * * * * * * * * * * * * * * * * * * * implicit real*8 (a-h,o-z) dimension h(31),f(16),v(8,30),z(8,30),x(16) integer*4 m parameter (l=6) parameter (wd = 5.0d-1) parameter (wn = 2.79082892416225747d-1) parameter (w1 = 1.66151675485008798d+0) parameter (w2 =-2.61869488536155201d-1) parameter (w3 = 2.96183421516754830d+0) parameter (w4 =-1.28112874779541430d+0) lm=30 n=nx-1216 if(n.lt.200)n=200 r=0d0 fl=r er=fl nn=0 if(a.eq.b)return c=fl ar=fl k=nn m=1 xn=a x(16)=b p=fl fn=fun(xn) s=(b-a)*625d-4 x(8)=(a+b)*wd x(4)=(a+x(8))*wd x(12)=(x(8)+b)*wd x(2)=(a+x(4))*wd x(6)=(a+x(12))*wd x(10)=(x(4)+b)*wd x(14)=(x(12)+b)*wd do 25 j=2,16,2 25 f(j)=fun(x(j)) nn=9 30 x(1)=(xn+x(2))*wd f(1)=fun(x(1)) do 35 j=3,15,2 x(j)=(x(j-1)+x(j+1))*wd 35 f(j)=fun(x(j)) nn=nn+8 st=(x(16)-xn)*625d-4 q=((fn+f(8))*wn+(f(1)+f(7))*w1+ *(f(2)+f(6))*w2+(f(3)+f(5))*w3+ *f(4)*w4)*st h(k+1)=((f(8)+f(16))*wn+(f(9)+f(15))*w1+ *(f(10)+f(14))*w2+(f(11)+f(13))*w3+ *f(12)*w4)*st w=q+h(k+1) d=w-p ar=ar+d e=dabs(d)/1023d0 t=dmax1(ab,rl*dabs(ar))*(st/s) if(k.lt.1)go to 50 if(k.ge.lm)go to 62 if(nn.gt.n)go to 60 if(e.le.t)go to 70 50 m=2*m k=k+1 do 52 i=1,8 j=i+8 v(i,k)=f(j) 52 z(i,k)=x(j) p=q do 55 i=1,8 j=9-i f(2*j)=f(j) 55 x(2*j)=x(j) go to 30 60 n=2*n lm=l fl=fl+(b-xn)/(b-a) go to 70 62 fl=fl+1d0 70 r=r+w er=er+e c=c+d/1023d0 72 if(m.eq.2*(m/2))go to 75 m=m/2 k=k-1 go to 72 75 m=m+1 if(k.le.0)go to 80 p=h(k) xn=x(16) fn=f(16) do 78 i=1,8 f(2*i)=v(i,k) 78 x(2*i)=z(i,k) go to 30 80 r=r+c if(er.eq.0d0)return ar=dabs(r) 82 q=ar+er if(q.ne.ar)return er=2d0*er go to 82 end +deck,dqn32. subroutine dqn32(xl,xu,fct,y) c c double precision xl,xu,y,a,b,c,fct c a=.5d0*(xu+xl) b=xu-xl c=.49863193092474078d0*b y=.35093050047350483d-2*(fct(a+c)+fct(a-c)) c=.49280575577263417d0*b y=y+.8137197365452835d-2*(fct(a+c)+fct(a-c)) c=.48238112779375322d0*b y=y+.12696032654631030d-1*(fct(a+c)+fct(a-c)) c=.46745303796886984d0*b y=y+.17136931456510717d-1*(fct(a+c)+fct(a-c)) c=.44816057788302606d0*b y=y+.21417949011113340d-1*(fct(a+c)+fct(a-c)) c=.42468380686628499d0*b y=y+.25499029631188088d-1*(fct(a+c)+fct(a-c)) c=.39724189798397120d0*b y=y+.29342046739267774d-1*(fct(a+c)+fct(a-c)) c=.36609105937014484d0*b y=y+.32911111388180923d-1*(fct(a+c)+fct(a-c)) c=.33152213346510760d0*b y=y+.36172897054424253d-1*(fct(a+c)+fct(a-c)) c=.29385787862038116d0*b y=y+.39096947893535153d-1*(fct(a+c)+fct(a-c)) c=.25344995446611470d0*b y=y+.41655962113473378d-1*(fct(a+c)+fct(a-c)) c=.21067563806531767d0*b y=y+.43826046502201906d-1*(fct(a+c)+fct(a-c)) c=.16593430114106382d0*b y=y+.45586939347881942d-1*(fct(a+c)+fct(a-c)) c=.11964368112606854d0*b y=y+.46922199540402283d-1*(fct(a+c)+fct(a-c)) c=.7223598079139825d-1*b y=y+.47819360039637430d-1*(fct(a+c)+fct(a-c)) c=.24153832843869158d-1*b y=b*(y+.48270044257363900d-1*(fct(a+c)+fct(a-c))) return end c +deck,qvnc8. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * subroutine qvnc8(fun,a,b,ab,rl,r,er,nn,fl,nx) * * * * * * * * * * * * * * * * * * * * * * * * * * * * * implicit real*8 (a-h,o-z) dimension h(31),f(16),v(8,30),z(8,30),x(16) integer*4 m parameter (l=6) parameter (wd = 5.0d-1) parameter (wn = 2.79082892416225747d-1) parameter (w1 = 1.66151675485008798d+0) parameter (w2 =-2.61869488536155201d-1) parameter (w3 = 2.96183421516754830d+0) parameter (w4 =-1.28112874779541430d+0) lm=30 n=nx-1216 if(n.lt.200)n=200 r=0d0 fl=r er=fl nn=0 if(a.eq.b)return c=fl ar=fl k=nn m=1 xn=a x(16)=b p=fl fn=fun(xn) s=(b-a)*625d-4 x(8)=(a+b)*wd x(4)=(a+x(8))*wd x(12)=(x(8)+b)*wd x(2)=(a+x(4))*wd x(6)=(a+x(12))*wd x(10)=(x(4)+b)*wd x(14)=(x(12)+b)*wd do 25 j=2,16,2 25 f(j)=fun(x(j)) nn=9 30 x(1)=(xn+x(2))*wd f(1)=fun(x(1)) do 35 j=3,15,2 x(j)=(x(j-1)+x(j+1))*wd 35 f(j)=fun(x(j)) nn=nn+8 st=(x(16)-xn)*625d-4 q=((fn+f(8))*wn+(f(1)+f(7))*w1+ *(f(2)+f(6))*w2+(f(3)+f(5))*w3+ *f(4)*w4)*st h(k+1)=((f(8)+f(16))*wn+(f(9)+f(15))*w1+ *(f(10)+f(14))*w2+(f(11)+f(13))*w3+ *f(12)*w4)*st w=q+h(k+1) d=w-p ar=ar+d e=dabs(d)/1023d0 t=dmax1(ab,rl*dabs(ar))*(st/s) if(k.lt.1)go to 50 if(k.ge.lm)go to 62 if(nn.gt.n)go to 60 if(e.le.t)go to 70 50 m=2*m k=k+1 do 52 i=1,8 j=i+8 v(i,k)=f(j) 52 z(i,k)=x(j) p=q do 55 i=1,8 j=9-i f(2*j)=f(j) 55 x(2*j)=x(j) go to 30 60 n=2*n lm=l fl=fl+(b-xn)/(b-a) go to 70 62 fl=fl+1d0 70 r=r+w er=er+e c=c+d/1023d0 72 if(m.eq.2*(m/2))go to 75 m=m/2 k=k-1 go to 72 75 m=m+1 if(k.le.0)go to 80 p=h(k) xn=x(16) fn=f(16) do 78 i=1,8 f(2*i)=v(i,k) 78 x(2*i)=z(i,k) go to 30 80 r=r+c if(er.eq.0d0)return ar=dabs(r) 82 q=ar+er if(q.ne.ar)return er=2d0*er go to 82 end +deck,simps. subroutine simps(a1,b1,h1,reps1,aeps1,funct,x,ai,aih,aiabs) c simps c a1,b1 -the limits of integration c h1 -an initial step of integration c reps1,aeps1 - relative and absolute precision of integration c funct -a name of function subprogram for calculation of integrand + c x - an argument of the integrand c ai - the value of integral c aih- the value of integral with the step of integration c aiabs- the value of integral for module of the integrand c this subrogram calculates the definite integral with the relative or c absolute precision by simpson+s method with the automatical choice c of the step of integration c if aeps1 is very small(like 1.e-17),then calculation of integral c with reps1,and if reps1 is very small (like 1.e-10),then calculation c of integral with aeps1 c when aeps1=reps1=0. then calculation with the constant step h1 c implicit real*8(a-h,o-z) dimension f(7),p(5) h=dsign(h1,b1-a1) s=dsign(1.d0,h) a=a1 b=b1 ai=0.d0 aih=0.d0 aiabs=0.d0 p(2)=4.d0 p(4)=4.d0 p(3)=2.d0 p(5)=1.d0 if(b-a) 1,2,1 1 reps=dabs(reps1) aeps=dabs(aeps1) do 3 k=1,7 3 f(k)=10.d16 x=a c=0.d0 f(1)=funct(x)/3. 4 x0=x if((x0+4.*h-b)*s) 5,5,6 6 h=(b-x0)/4. if(h) 7,2,7 7 do 8 k=2,7 8 f(k)=10.d16 c=1.d0 5 di2=f(1) di3=dabs(f(1)) do 9 k=2,5 x=x+h if((x-b)*s) 23,24,24 24 x=b 23 if(f(k)-10.d16) 10,11,10 11 f(k)=funct(x)/3. 10 di2=di2+p(k)*f(k) 9 di3=di3+p(k)*abs(f(k)) di1=(f(1)+4.*f(3)+f(5))*2.*h di2=di2*h di3=di3*h if(reps) 12,13,12 13 if(aeps) 12,14,12 12 eps=dabs((aiabs+di3)*reps) if(eps-aeps) 15,16,16 15 eps=aeps 16 delta=dabs(di2-di1) if(delta-eps) 20,21,21 20 if(delta-eps/8.) 17,14,14 17 h=2.*h f(1)=f(5) f(2)=f(6) f(3)=f(7) do 19 k=4,7 19 f(k)=10.d16 go to 18 14 f(1)=f(5) f(3)=f(6) f(5)=f(7) f(2)=10.d16 f(4)=10.d16 f(6)=10.d16 f(7)=10.d16 18 di1=di2+(di2-di1)/15. ai=ai+di1 aih=aih+di2 aiabs=aiabs+di3 go to 22 21 h=h/2. f(7)=f(5) f(6)=f(4) f(5)=f(3) f(3)=f(2) f(2)=10.d16 f(4)=10.d16 x=x0 c=0.d0 go to 5 22 if(c) 2,4,2 2 return end subroutine simpxx(a,b,np,ep,func,res) implicit real*8 (a-h,o-z) external func step=(b-a)/np call simps(a,b,step,ep,1d-18,func,ra,res,r2,r3) end subroutine simpt(a1,b1,h1,reps1,aeps1,funct,x,ai,aih,aiabs) implicit real*8(a-h,o-z) dimension f(7),p(5) h=dsign(h1,b1-a1) s=dsign(1.d0,h) a=a1 b=b1 ai=0.d0 aih=0.d0 aiabs=0.d0 p(2)=4.d0 p(4)=4.d0 p(3)=2.d0 p(5)=1.d0 if(b-a) 1,2,1 1 reps=dabs(reps1) aeps=dabs(aeps1) do 3 k=1,7 3 f(k)=10.d16 x=a c=0.d0 f(1)=funct(x)/3. 4 x0=x if((x0+4.*h-b)*s) 5,5,6 6 h=(b-x0)/4. if(h) 7,2,7 7 do 8 k=2,7 8 f(k)=10.d16 c=1.d0 5 di2=f(1) di3=dabs(f(1)) do 9 k=2,5 x=x+h if((x-b)*s) 23,24,24 24 x=b 23 if(f(k)-10.d16) 10,11,10 11 f(k)=funct(x)/3. 10 di2=di2+p(k)*f(k) 9 di3=di3+p(k)*abs(f(k)) di1=(f(1)+4.*f(3)+f(5))*2.*h di2=di2*h di3=di3*h if(reps) 12,13,12 13 if(aeps) 12,14,12 12 eps=dabs((aiabs+di3)*reps) if(eps-aeps) 15,16,16 15 eps=aeps 16 delta=dabs(di2-di1) if(delta-eps) 20,21,21 20 if(delta-eps/8.) 17,14,14 17 h=2.*h f(1)=f(5) f(2)=f(6) f(3)=f(7) do 19 k=4,7 19 f(k)=10.d16 go to 18 14 f(1)=f(5) f(3)=f(6) f(5)=f(7) f(2)=10.d16 f(4)=10.d16 f(6)=10.d16 f(7)=10.d16 18 di1=di2+(di2-di1)/15. ai=ai+di1 aih=aih+di2 aiabs=aiabs+di3 go to 22 21 h=h/2. f(7)=f(5) f(6)=f(4) f(5)=f(3) f(3)=f(2) f(2)=10.d16 f(4)=10.d16 x=x0 c=0.d0 go to 5 22 if(c) 2,4,2 2 return end +deck,simpdo. subroutine simpdo(ain,afi,ep1,ii1,bin,bfi,ep2,ii2,fun,ai) c simps c a1,b1 -the limits of integration c h1 -an initial step of integration c reps1,aeps1 - relative and absolute precision of integration c funct -a name of function subprogram for calculation of integrand + c x - an argument of the integrand c ai - the value of integral c aih- the value of integral with the step of integration c aiabs- the value of integral for module of the integrand c this subrogram calculates the definite integral with the relative or c absolute precision by simpson+s method with the automatical choice c of the step of integration c if aeps1 is very small(like 1.e-17),then calculation of integral c with reps1,and if reps1 is very small (like 1.e-10),then calculation c of integral with aeps1 c when aeps1=reps1=0. then calculation with the constant step h1 c implicit real*8(a-h,o-z) dimension f(7),p(5) common/simpc/x external fun ! aku a1=ain ! aku b1=afi ! aku h1=(b1-a1)/ii1 ! aku reps1=ep1 ! aku aeps1=1d-18 ! aku h=dsign(h1,b1-a1) s=dsign(1.d0,h) a=a1 b=b1 ai=0.d0 aih=0.d0 aiabs=0.d0 p(2)=4.d0 p(4)=4.d0 p(3)=2.d0 p(5)=1.d0 if(b-a) 1,2,1 1 reps=dabs(reps1) aeps=dabs(aeps1) do 3 k=1,7 3 f(k)=10.d16 x=a c=0.d0 call simpxx(bin,bfi,ii2,ep2,fun,functx) ! aku *aku f(1)=funct(x)/3. ! aku f(1)=functx/3. ! aku 4 x0=x if((x0+4.*h-b)*s) 5,5,6 6 h=(b-x0)/4. if(h) 7,2,7 7 do 8 k=2,7 8 f(k)=10.d16 c=1.d0 5 di2=f(1) di3=dabs(f(1)) do 9 k=2,5 x=x+h if((x-b)*s) 23,24,24 24 x=b 23 if(f(k)-10.d16) 10,11,10 *aku 11 f(k)=funct(x)/3. 11 continue call simpxx(bin,bfi,ii2,ep2,fun,functx) ! aku *aku f(k)=funct(x)/3. ! aku f(k)=functx/3. ! aku 10 di2=di2+p(k)*f(k) 9 di3=di3+p(k)*abs(f(k)) di1=(f(1)+4.*f(3)+f(5))*2.*h di2=di2*h di3=di3*h if(reps) 12,13,12 13 if(aeps) 12,14,12 12 eps=dabs((aiabs+di3)*reps) if(eps-aeps) 15,16,16 15 eps=aeps 16 delta=dabs(di2-di1) if(delta-eps) 20,21,21 20 if(delta-eps/8.) 17,14,14 17 h=2.*h f(1)=f(5) f(2)=f(6) f(3)=f(7) do 19 k=4,7 19 f(k)=10.d16 go to 18 14 f(1)=f(5) f(3)=f(6) f(5)=f(7) f(2)=10.d16 f(4)=10.d16 f(6)=10.d16 f(7)=10.d16 18 di1=di2+(di2-di1)/15. ai=ai+di1 aih=aih+di2 aiabs=aiabs+di3 go to 22 21 h=h/2. f(7)=f(5) f(6)=f(4) f(5)=f(3) f(3)=f(2) f(2)=10.d16 f(4)=10.d16 x=x0 c=0.d0 go to 5 22 if(c) 2,4,2 2 return end +patch,polrad_add. +deck,apptai,if=approx,electroweak. double precision function apptai(bo) implicit real*8(a-h,o-z) external peak1,peak2,upre +self,if=approx. . ,elu,elp +self,if=targ_d,if=approx. . ,elq +self. +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. data ep/1d-7/ if(ita.eq.1) then ss=x+y xx=s-y sin0=alfa/pi*sigmab(1d0,1d0)* . ((log(y/aml2)-1.)*log(ss/s) . + log(ss/s)*log(ss/x) + log(xx/s)*log(xx/x) + .5*log(x/s)**2 . + fspen(ss/s) + fspen(ss/x) + fspen(xx/x) + fspen(xx/s) . - 2./3.*pi2) write(9,8)' sin0 ',sin0 zs=(1.-ys)/(1.-xs*ys) zp=1.-ys+xs*ys c call dqn32(zs,1d0,peak1,res1) call simpxx(zs+ep,1d0-ep,100,1d-3,peak1,res1) sink1=alfa/(2.*pi) *res1 write(9,8)' sink1',sink1 c call dqn32(zp,1d0,peak2,res2) call simpxx(zp+ep,1d0-ep,100,1d-3,peak2,res2) sink2=alfa/(2.*pi) *res2 write(9,8)' sink2',sink2 c call dqn32(xs,xt,peakt,rest) c sint=-2.*alfa**3*barn/s**2/x *rest sint=0. write(9,8)' sint ',sint call simpxx(xs+ep,1d0-ep,100,1d-2,upre,resr) c call qunc8(upre,xs+ep,1d0-ep,1d-7*bo,1d-5,resr,er,nn2,fl2,1500) sinr=2.*alfa**3*barn/s *resr write(9,9)' sinr ',sinr ,fl2,nn2 apptai=sin0+sink1+sink2+sint+sinr write(9,8)' appt ',apptai else ter=1. if(ita.eq.2)ter= amh/amp c eta1=xs**2/(4.*(1.-xs)) um=sx-y eta1=(um*(sx-sqly)+2.*amp2*y)/(8.*amp2*(um+amp2)) eta2=sx/4./amp2 yy1=(1.+(1.-ys)**2)/(1.-ys) siau=0. +self,if=approx. if(un.ge.1d-12)then call qunc8(elu,eta1,eta2,1d-9*bo,1d-7,relu,er,nn2,fl2,3500) siau=ter*alfa**3/s*barn*yy1*relu write(9,9)' siau ',siau ,fl2,nn2 endif +self. siap=0. +self,if=approx. if(pn.ge.1d-12 .and. pl.ge.1d-12)then call qunc8(elp,eta1,eta2,1d-9*bo,1d-7,relp,er,nn2,fl2,3500) +self,if=long,if=approx. yy2=ys*(2.-ys)/(1.-ys) siap=ter*alfa**3/s*barn*yy2*relp +self,if=tran,if=approx. xa=y/sx yy2t=xa*ys**2/(1.-ys)/sqrt((1.-ys)*y) *amp siap=ter*alfa**3/s*barn*yy2t*relp +self,if=approx. write(9,9)' siap ',siap ,fl2,nn2 endif +self. siaq=0. +self,if=targ_d. if(qn.ge.1d-12)then call qunc8(elq,eta1,eta2,1d-9*bo,1d-7,relq,er,nn2,fl2,3500) siaq=ter*alfa**3/s*barn*yy1*relq write(9,9)' siaq ',siaq ,fl2,nn2 endif +self. apptai=un*siau + pl*pn*siap + qn/6.*siaq write(9,8)' appt ',apptai endif 8 format(a6,e12.4) 9 format(a6,e12.4,' fl = ',f6.2,' nn = ',i4) end +deck,peak1,if=approx,electroweak. double precision function peak1(z) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. dl=log(y/aml2) dsz=sigmab(z,1d0) ds0=sigmab(1d0,1d0) peak1=(((1.+z**2)*dl-2.*z)*dsz-2.*(dl-1.)*ds0)/(1.-z) end +deck,peak2,if=approx,electroweak. double precision function peak2(z) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. dl=log(y/aml2) dsz=sigmab(1d0,z) ds0=sigmab(1d0,1d0) peak2=(((1.+z**2)*dl-2.*z)*dsz-2.*(dl-1.)*ds0)/(1.-z) end +deck,upre,if=approx,electroweak. double precision function upre(xi) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. common/usux/aksi,us,ux,ts,tx,fs(8),fx(8),ft(8),i,j external didqg dimension dlt(6),dlsl(6),dlxl(6),dlsk(6),dlxk(6),dly(6) . ,dtsk(6),dtxk(6),di(5,3) aksi=xi yx=y/xi xxi=xs/xi u=sx-yx tau=amp2+u/xi ux=s-yx us=x+yx ts=y*s/us tx=y*x/ux c t1=(u*(sx-sqly)+ap2*y)/2./tau t2=(u*(sx+sqly)+ap2*y)/2./tau t1=amp2*y**2/tau/t2 t0=t1 call strfp2(xi,ts,fs,0) call strfp2(xi,tx,fx,0) do i=1,6 dlt(i) =0d0 dlsl(i)=0d0 dlxl(i)=0d0 dlsk(i)=0d0 dlxk(i)=0d0 dly(i) =0d0 dtsk(i)=0d0 dtxk(i)=0d0 enddo do i=isf1,min(6,isf2) ji=4 +self,if=tran. if((i.eq.3.or.i.eq.4).and.pn.ge.1d-10)ji=5 +self. do j=1,ji +self,if=-f2g1sch. if(t0.lt.tx)then if(j.eq.4)then call qvnc8(didqg,t0+1d-7,tx-1d-7, . 1d-6,1d-4,di(j,1),er,nn2,fl2,500) else call dqg32(t0,tx,didqg,di(j,1)) endif c call dqg32(t0,tx,didqg,di(j,1)) call dqg32(tx,ts,didqg,di(j,2)) call dqg32(ts,t2,didqg,di(j,3)) else if(t0.lt.ts)then di(j,1)=0. call dqg32(t0,ts,didqg,di(j,2)) call dqg32(ts,t2,didqg,di(j,3)) else if(t0.lt.t2)then di(j,1)=0. di(j,2)=0. call dqg32(t0,t2,didqg,di(j,3)) else di(j,1)=0. di(j,2)=0. di(j,3)=0. endif +self,if=f2g1sch. di(j,1)=0. di(j,2)=0. di(j,3)=0. +self. enddo dlt(i)=(di(1,1) + di(1,2) + di(1,3))/sx dlsl(i)=(fs(i)*log(us**2/y/tau) . +di(2,1) + di(2,2) + di(2,3))/us dlxl(i)=(fx(i)*log(ux**2/y/tau) . +di(3,1) + di(3,2) + di(3,3))/ux dlsk(i)=(fs(i)*log(us**2/y/tau) . +di(1,1) + di(1,2) - di(1,3) . +di(2,1) + di(2,2) + di(2,3))/s dlxk(i)=(fx(i)*log(ux**2/y/tau) . +di(1,1) - di(1,2) - di(1,3) . +di(3,1) + di(3,2) + di(3,3))/x dly(i)=y*sxp/us/ux*(di(4,1) + di(4,2) + di(4,3)) if(ji.eq.5)then dtsk(i)=(di(5,1) + di(5,2) - di(5,3))/us dtxk(i)=(di(5,1) - di(5,2) - di(5,3))/ux endif enddo c bt1=3.*ep0*xxi**2-2.+6.*xxi c bt2=-4.*(ep0*xxi**2-1.)**2-15.*ep0*xxi**3+22.*xxi-26.*xxi**2 c bt3=-2.*(ep0*xxi**2-1.)**2- 6.*ep0*xxi**3+ 8.*xxi- 5.*xxi**2 c bt4=-4.*(ep0*xxi**2-1.)**2- 9.*ep0*xxi**3+10.*xxi- 6.*xxi**2 dl1f1=2.*dly(1)-dlsk(1)+dlsl(1)+dlxk(1)-dlxl(1)+2.*dlt(1) dl1b1=2.*dly(5)-dlsk(5)+dlsl(5)+dlxk(5)-dlxl(5)+2.*dlt(5) dl2f2=(-yx*sx+tpl)*dly(2)-(yx*x+tpl)*dlsk(2)+(-yx*s+tpl)*dlxk(2) dl2b2=(-yx*sx+tpl)*dly(6)-(yx*x+tpl)*dlsk(6)+(-yx*s+tpl)*dlxk(6) tlu=sx*dl1f1+sx/(xi*yx**2)*dl2f2 tlq=sx*dl1b1+sx/(xi*yx**2)*dl2b2 c ttu=tpl*ep0*(-4.*xi*ft(1)+ft(2))/(xi*s*x) c ttq=(xi*xxi**2*bt1*ft(5)+bt2*ft(6)/6. c . +bt3*ft(7)+bt4*ft(8))/(xi*s*x*xxi**2) +self,if=long. dl3g1=2.*sxp*dly(3)-(us+x)*dlsk(3)-yx*dlsl(3)+(s+ux)*dlxk(3) . -yx*dlxl(3) tlpl=-sx*dl3g1/yx g1x=fx(3) +self,if=long,if=electroweak. f1x=fx(1) call ffvapm(xi,tx,f1ew0,g1ew0,0) g1x=g1x-g1ew0 f1x=f1x-f1ew0 +self,if=long. txpl=2.*g1x*sx*u*(s+ux)/(ux*x*yx) +self,if=long,if=electroweak. txpl=txpl-2.*f1x*sx*u*(s**2+ux**2)/(ux*x*yx**2) +self,if=long. c ttpl=2.*sxp*ep0*(ft(3)*yx+2.*ft(4)*sx)/(s*x) c upre=(un*(tlu )+pl*pn*(tlpl +txpl)+qn/3.*(tlq ))/xi**2 upre=(tlu + tlpl+txpl + tlq)/xi**2 +self,if=tran. dl4g1=-4.*x*dly(3)+(2.*x-s)*dlsk(3)-us*dtsk(3)+(2.*yx-us)*dlsl(3) . -(x+2.*ux)*dlxk(3)-ux*dlxl(3)-ux*dtxk(3)+2.*sx*dlt(3) dl5g2=(sx*yx-sxp**2)*dly(4)+(s*sxp+2.*x*us)*dlsk(4)+us*x*dtsk(4) . -(2.*s*ux-sxp*x)*dlxk(4)-ux*s*dtxk(4) ggt1=ep0*xxi**2*(sx**2-2.*x**2)+tpl-xxi*(tpl-s*x) ggt2=-2.*ep0*xxi**2*(s*sx-x**2)-2.*(tpl+s*x)-xxi*(2.*tpl-s*x) sqsxy=sqrt(s*x*y) tlpt=xi*amp/sqsxy*sx*(dl4g1+2.*dl5g2/yx) txpt=4.*xi*amp*u*sx*(yx*fx(3)+2.*s*fx(4))/(x*yx*sqsxy) c ttpt=2.*xi*amp*sx*(-ft(3)*ggt1+ft(4)*ggt2/xxi)/(xxi*s*x*sqsxy) c upre=(un*(tlu )+pl*pn*(tlpt +txpt)-qn/6.*(tlq ))/xi**2 upre=(tlu + tlpt+txpt - 0.5*tlq)/xi**2 +self. c print *,xi,upre end +deck,didqg,if=approx,electroweak. double precision function didqg(t) implicit real*8(a-h,o-z) common/usux/xi,us,ux,ts,tx,fs(8),fx(8),ft(8),i,j dimension dm(6,7),f(8) call strfp2(xi,t,f,i) as=abs(t-ts) ax=abs(t-tx) zn=(us*as+ux*ax) dfs=f(i)-fs(i) dfx=f(i)-fx(i) dm(i,1)=f(i)/t dm(i,2)=dfs/as dm(i,3)=dfx/ax dm(i,4)=( ux*(t-tx)*dfs + us*(ts-t)*dfx )/as/ax/zn dm(i,5)=f(i)/t**2 didqg=dm(i,j) end +deck,strfp2. ************** strfp2 ******************************************* subroutine strfp2(xi,t,f,ifu) implicit real*8(a-h,o-z) dimension f(8) +seq,comtail. c ich=0 for QED born cross section c ich=1 for electroweak (without pure QED) born cross section c ich=2 for complete electroweak born cross section do 4 ik=1,4 4 f(ik)=0d0 +self,if=approx,alpha2ll. if(ich.eq.0 .or. ich.eq.2)then if(ifu.eq.0.or.ifu.eq.1)f(1)=un*f1sfun(xi,t) if(ifu.eq.0.or.ifu.eq.2)f(2)=un*f2sfun(xi,t) if(ifu.eq.0.or.ifu.eq.3)f(3)=pl*pn*g1sfun(xi,t) if(ifu.eq.0.or.ifu.eq.4)f(4)=pl*pn*g2sfun(xi,t) +self,if=targ_d,if=approx,alpha2ll. if((ifu.eq.0.or.ifu.eq.5.or.ifu.eq.6).and.qn.gt.1d-12)then call b14sf(xi,t,f(5),f(6),f(7),f(8)) do 14 ik=5,8 14 f(ik)=qn/3.*f(ik) endif +self,if=approx,alpha2ll. endif +self,if=long,if=electroweak. if(ich.eq.1 .or. ich.eq.2)then call ffvapm(xi,t,f1ew,g1ew,1) if(ifu.eq.0.or.ifu.eq.1)f(1)=f(1)+f1ew if(ifu.eq.0.or.ifu.eq.2)f(2)=f(2)+2.*xi*f1ew if(ifu.eq.0.or.ifu.eq.3)f(3)=f(3)+g1ew endif +self. end +deck,elu,if=approx. double precision function elu(eta) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. felu(f1,f2)=xxt*(f1**2+eta*f2**2)-(f1+f2)**2 xa=y/sx xx1=xa**2 + 4.*xa*eta - 4.*eta xxt=xx1/(2.*eta*xa**2) t=4.*amp2*eta if(ita.eq.2)then +self,if=targ_d. call ffdeu(t,fc,fm,fq) elu=((fc**2+8./9.*fq**2*eta**2+2./3.*fm**2*eta)*xxt . -2./3.*(1.+eta)*fm**2)/eta +self,if=targ_h. call ffpro(t,ge,gm) +self,if=targ_he3. call ffhe3(t,ge,gm) +self,if=targ_h,targ_he3. f2=(gm-ge)/(1.+eta) f1=gm-f2 elu=felu(f1,f2)/eta +self,if=targ_c,targ_o. call ffco(t,ff) elu=xxt*ff**2/eta +self. elseif(ita.eq.3)then call ffquas(t,geun,gmun,gepo,gmpo) f2=(gmun-geun)/(1.+eta) f1=gmun-f2 elu=felu(f1,f2)/eta endif end +deck,elp,if=approx. double precision function elp(eta) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. +self,if=long. felpl(f1,f2)=(f1+f2)*(xa*xxt*f1 - (f1+f2)) +self,if=tran. felpt(gg1,gg2) =gg1*(y1*(2.+xa/ys/eta)-(2.-ys)*xa/ys*xxt) . +gg2*((xa+2.*eta-2.*xa*y1**2+6.*eta*y1/ys)*xxt . -4.*y1/xa/ys*(1.+eta)) +self. xa=y/sx xx1=xa**2 + 4.*xa*eta - 4.*eta xxt=xx1/(2.*eta*xa**2) t=4.*amp2*eta if(ita.eq.2)then +self,if=targ_d. call ffdeu(t,fc,fm,fq) +self,if=targ_h. call ffpro(t,ge,gm) +self,if=targ_he3. call ffhe3(t,ge,gm) +self,if=targ_h,targ_he3. f2=(gm-ge)/(1.+eta) f1=gm-f2 +self,if=targ_d,if=long. elp=fm*(.5*(1.+eta)*fm-(fc+fq*eta/3.+fm*eta/2.)*xa*xxt)/eta +self,if=targ_h,targ_he3,if=long. elp=felpl(f1,f2)/eta +self,if=targ_h,targ_he3,if=tran. gg1=(f1+f2)**2 gg2=(f1+f2)*f2 +self,if=targ_d,if=tran. gg1=-.5*(1.+eta)*fm**2 gg2=fm*(fc+fq*eta/3.-fm/2.) +self,if=tran. y1=1./ys-1. elp=felpt(gg1,gg2)/eta +self. elseif(ita.eq.3)then call ffquas(t,geun,gmun,gepo,gmpo) f2=(gmpo-gepo)/(1.+eta) f1=gmpo-f2 +self,if=long. elp=felpl(f1,f2)/eta +self,if=tran. gg1=(f1+f2)**2 gg2=(f1+f2)*f2 y1=1./ys-1. elp=felpt(gg1,gg2)/eta +self. endif end +deck,elq,if=targ_d,if=approx. double precision function elq(eta) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. xa=y/sx xx1=xa**2 + 4.*xa*eta - 4.*eta xxt=xx1/(2.*eta*xa**2) t=4.*amp2*eta if(ita.eq.2)then call ffdeu(t,fc,fm,fq) elq=((1.+eta+(.75*xa**2-eta)*xxt)*fm**2 . -xxt*xx1/(1.+eta)*fq*(3.*fc+3.*eta*fm+eta*fq) . -2.*eta*xxt*fq*(4.*fc-3.*xa*fm+4./3.*eta*fq))/eta elseif(ita.eq.3)then c call ffquas(t,geun,gmun,gepo,gmpo) c f2=(gmun-geun)/(1.+eta) c f1=gmun-f2 elq=0. endif end +deck,sigmab. ****************** sigmab ************************************* double precision function sigmab(z1,z2) implicit real*8(a-h,o-z) +seq,comsxy. yst=1.-(1.-ys)/(z1*z2) xst=xs*ys/yst/z2 st=s*z1 sigmab=ys/(yst*z1*z2**2)*boursc(xst,yst,st) end +deck,boursc. ************** boursc ********************************************** double precision function boursc(xs,ys,s) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comtail. +seq,comppi. dimension tb(8),f(8) +self,if=targ_d. parameter (c2i3 = 6.6666666666666667d-1) ! 2/3 parameter (c4i3 = 1.3333333333333333d0 ) ! 4/3 +self. q2=s*xs*ys call strfp2(xs,q2,f,0) dmu=amp2*xs/s sxm2=1./ys-1.-dmu +self,if=long. tb(1)=xs*ys tb(2)=sxm2 tb(3)=-xs*ys*(1. + 2.*sxm2) tb(4)=4.*dmu*xs +self,if=long,if=targ_d. tb(5)=-xs*( ys+2.*dmu*(2.-3.*ys*sxm2)) tb(6)=(1.-1./ys+c4i3*dmu+dmu*sxm2*(c2i3/ys-3.-2.*dmu)) tb(7)=-dmu*(1.+4./ys*sxm2-6.*sxm2**2) tb(8)=dmu*sxm2*(2./ys-3.-6.*dmu) +self,if=tran. tb(1)=xs*ys tb(2)=sxm2 tb(3)=-2.*xs*ys*sqrt(dmu*sxm2) tb(4)=-4.*xs*sqrt(dmu*sxm2) +self,if=tran,if=targ_d. tb(5)=(.5*ys+2.*dmu*(1.- 3.*ys*sxm2)) tb(6)=(.5*(1./ys-1.)-c2i3*dmu+sxm2*dmu*(3.-c4i3/ys+2.*dmu)) tb(7)=dmu*(.5+2./ys*sxm2-6.*sxm2**2) tb(8)=dmu*sqm2*(3. -4./ys + 6.*dmu) +self. bour=0. do isf=isf1,isf2 c if(isf.eq.1.or.isf.eq.2)polst=un c if(isf.eq.3.or.isf.eq.4)polst=pn c if(isf.ge.5)polst=qn/3. c bour=bour+polst*tb(isf)*f(isf) bour=bour+tb(isf)*f(isf) enddo boursc=bour* 4.*alfa**2*pi/xs/q2*barn end +deck,al2ll,if=alpha2ll. double precision function al2ll(tai) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. external ra2iss,ra2ipp,ra2isp,ra2lss,ra2lpp,ra2fss,ra2fpp . ,elual2,elpal2 c dimension am(2),bm(2),wrk(500),amfer(3) dimension amfer(3) data amfer/5.11d-4,1.05658d-1,1.784d0/ep/1d-10/ zs=(1d0-ys)/(1d0-xs*ys) zp=1d0-ys+xs*ys dlm=dlog(y/aml2) if(ita.ne.1)then ter=1. if(ita.eq.2)ter= amh/amp c eta1=xs**2/(4.*(1.-xs)) um=sx-y eta1=(um*(sx-sqly)+2.*amp2*y)/(8.*amp2*(um+amp2)) eta2=sx/4./amp2 elsunp=0. if(un.ge.1d-12)then c call qunc8(elual2,eta1,eta2,1d-9*bo,1d-7,relu,er,nn2,fl2,3500) call simpxx(eta1,eta2,100,1d-2,elual2,relu) elsunp=ter*alfa**4/(2.*pi*s)*dlm*barn*relu c write(9,*)'elsunp',elsunp ,fl2,nn2 endif elspol=0. if(pn.ge.1d-12 .and. pl.ge.1d-12)then c call qunc8(elpal2,eta1,eta2,1d-9*bo,1d-7,relp,er,nn2,fl2,3500) call simpxx(eta1,eta2,100,1d-2,elpal2,relp) elspol=ter*alfa**4/(2.*pi*s)*dlm*barn*relp c write(9,*)'elspol',elspol,fl2,nn2 endif elsi0=alfa/pi*dlm*(log((sx-y)**2/s/x)+1.5d0)*tai al2ll=elsi0+elsunp+elspol else call simpxx(zp+ep,1d0-ep,100,1d-2,ra2ipp,repp) call simpxx(zs+ep,1d0-ep,100,1d-2,ra2iss,ress) ep4=1d-4 call simpxx(zs+ep4,1d0-ep4,100,1d-2,ra2isp,resp) sipp=alfa**2/8./pi2*dlm**2*repp siss=alfa**2/8./pi2*dlm**2*ress sisp=alfa**2/4./pi2*dlm**2*resp si00=sigmab(1d0,1d0) deltsp=2d0*log((1d0-zs)*(1d0-zp))+3d0 vacp=vacpol(y) de2in=alfa**2/8d0/pi2*( . 6.*vacp**2+2.*deltsp*dlm*vacp . +dlm**2*(deltsp**2 . +12d0*fspen(1d0-zs) +4d0*fspen(1.-zp) - 8d0/3d0*pi2)) call simpxx(zs+ep,1d0-4d0*aml*amp/s,100,1d-2,ra2lss,relss) call simpxx(zp+ep,1d0-4d0*aml*amp/s,100,1d-2,ra2lpp,relpp) silss=alfa**2/8./pi2*dlm**2*relss silpp=alfa**2/8./pi2*dlm**2*relpp sifss=0. sifpp=0. do j=1,3 amf=amfer(j) dlf=dlog(y/(amf**2)) zsfmax=1d0-4d0*amf*amp/s if (zs.lt.zsfmax) then call simpxx(zs+ep,zsfmax,100,1d-2,ra2fss,refss) else refss=0d0 endif delts=2d0*dlog((1d0-zs)*s/(4d0*amf*amp))*sigmab(1d0,1d0) sifss=sifss+alfa**2/12d0/pi2*dlf**2*(delts+refss) zpfmax=1d0-4*amf*amp/s if (zp.lt.zpfmax) then call simpxx(zp+ep,zpfmax,100,1d-2,ra2fpp,refpp) else refpp=0d0 endif deltp=2d0*dlog((1d0-zp)*s/(4d0*amf*amp))*sigmab(1d0,1d0) sifpp=sifpp+alfa**2/12d0/pi2*dlf**2*(deltp+refss) enddo al2ll=de2in*si00+siss+sipp+sisp .+silpp+silss .+sifpp+sifss c write(9,'(5h al2:,4g13.5)')siss,sipp,sisp end if write(9,'(1x,''al2ll='',g13.4)') al2ll end +deck, ra2ipp,if=alpha2ll. double precision function ra2ipp(z) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. sib=sigmab(1d0,z) si0=sigmab(1d0,1d0) zz=(1.d0-ys)/(z-xs*ys) c cl1=2.*log(1.-z)-log(z)+1.5 cl1=2.*log((1.-z)*(1.-zz))-log(z)+3. cl2=(1.+z)*log(z)-2.*(1.-z) desi=((1.+z**2)*sib-2.*si0)/(1.-z) ra2ipp=2.*cl1*desi+cl2*sib siv=sib*vacpol(y/z) siv0=si0*vacpol(y) vint=((1.+z**2)*siv-2.*siv0)/(1.-z) ra2ipp=ra2ipp+4.*vint/log(y/aml2) end +deck, ra2iss,if=alpha2ll. double precision function ra2iss(z) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. sib=sigmab(z,1d0) si0=sigmab(1d0,1d0) zz=(1.d0-ys+z*xs*ys)/z c cl1=2.*log(1.-z)-log(z)+1.5 cl1=2.*log((1.-z)*(1.-zz))-log(z)+3. cl2=(1.+z)*log(z)-2.*(1.-z) desi=((1.+z**2)*sib-2.*si0)/(1.-z) ra2iss=2.*cl1*desi+cl2*sib siv=sib*vacpol(y*z) siv0=si0*vacpol(y) vint=((1.+z**2)*siv-2.*siv0)/(1.-z) ra2iss=ra2iss+4.*vint/log(y/aml2) end +deck, elual2,if=alpha2ll. double precision function elual2(eta) implicit real*8(a-h,o-z) parameter (c2i3 = 6.6666666666666667d-1) ! 2/3 parameter (c8i9 = 8.8888888888888889d-1) ! 8/9 +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. xa=y/sx xx1=xa**2 + 4.*xa*eta - 4.*eta xxt=xx1/(2.*eta*xa**2) y1=1.-ys ypl= y1+1./y1 ymi=-y1+1./y1 feta=0.5*(1.+sqrt(1./eta+1.)) fln1=log(y1+xa*ys*feta) flny=log(xa*feta) flny1=log((1.-xa*ys*feta)/y1) dn1=1./(y1+xa*ys*feta) dny1=-1./(1.-xa*ys*feta) ot1=(1.-xa)/(1.-xa*feta) ot2=(1.-xa*ys*feta)/(1.-xa*ys) ot3=(y1+xa*ys*feta)/(y1+xa*ys) barlog=log(ot1**2*ot2*ot3) b= 2.*ypl*((xa/3.-3./xa)*feta-2./xa+7*c2i3/xa**2) b=b - c2i3*(2.*xa*feta+1./xa**2-6./xa) b=b + (xa/3.*(1.+4.*feta) -3.)*ys**2/(2.*y1*eta) b=b + 2.*(xa - 1.)*fln1*(1./y1+ypl)/xa**2 b=b + (2.*y1+ypl)*flny1/(2.*eta) b=b + (2./y1+ypl)*fln1/(2.*eta) b=b - 2.*ypl*flny/eta b=b + 2.*(xa - 1.)*flny1*(y1+ypl)/(xa**2) b=b + 2.*( xa*ys + y1)*dn1*y1/(ys*xa**2) b=b - ys*(dn1+dny1)/(2.*eta) b=b + 2.*( - ys*xa + 1.)*dny1/(ys*xa**2) ti1=b rr1u=ti1-2.*ypl*xxt*barlog b= (2.*xa*feta - 3.)*ys**2/y1 b=b+ (ypl+2./y1)*fln1- 4.*ypl*flny+ (ypl+2.*y1)*flny1 b=b- ys*dn1- ys*dny1 ti3=b rr2u=ti3-2.*ypl*barlog t=4.*amp2*eta if(ita.eq.2)then +self,if=targ_d. call ffdeu(t,fc,fm,fq) ff1u=fc**2+c8i9*fq**2*eta**2+c2i3*fm**2*eta ff2u= -c2i3*(1.+eta)*fm**2 +self,if=targ_h. call ffpro(t,ge,gm) +self,if=targ_he3. call ffhe3(t,ge,gm) +self,if=targ_h,targ_he3. f2=(gm-ge)/(1.+eta) f1=gm-f2 ff1u=f1**2+eta*f2**2 ff2u=-(f1+f2)**2 +self,if=targ_c,targ_o. call ffco(t,ff) ff1u=ff**2 ff2u=0d0 +self. elseif(ita.eq.3)then call ffquas(t,geun,gmun,gepo,gmpo) f2=(gmun-geun)/(1.+eta) f1=gmun-f2 ff1u=f1**2+eta*f2**2 ff2u=-(f1+f2)**2 endif elual2=(ff1u*rr1u+ff2u*rr2u)/eta end +deck, elpal2,if=alpha2ll,if=long. double precision function elpal2(eta) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. xa=y/sx xx1=xa**2 + 4.*xa*eta - 4.*eta xxt=xx1/(2.*eta*xa**2) y1=1.-ys ypl= y1+1./y1 ymi=-y1+1./y1 feta=0.5*(1.+sqrt(1./eta+1.)) fln1=log(y1+xa*ys*feta) flny=log(xa*feta) flny1=log((1.-xa*ys*feta)/y1) dn1=1./(y1+xa*ys*feta) dny1=-1./(1.-xa*ys*feta) ot1=(1.-xa)/(1.-xa*feta) ot2=(1.-xa*ys*feta)/(1.-xa*ys) ot3=(y1+xa*ys*feta)/(y1+xa*ys) barlog=log(ot1**2*ot2*ot3) b= - 2.*ymi*(-3./xa+1. + 2.*feta ) b=b + 2.*(ymi*(1.-1./xa)-1./y1/xa)*fln1 b=b + 2.*(ymi*(1.-1./xa)+y1/xa)*flny1 b=b + fln1*xa*( ymi/2. +ys/y1**2)/eta b=b - ypl*ymi*flny*xa/eta b=b + (ypl-ys/2./y1)*ys*flny1*xa/eta b=b + 2.*(ys + y1/xa)*dn1 b=b - ys**2*dn1*xa/(2.*y1*eta) b=b + 2.*(-ys+ 1./xa)*dny1 b=b - ys**2*dny1*xa/(2.*eta) ti2=b rr1p=ti2-2.*ymi*xa*xxt*barlog b=-ymi+ymi*fln1+ymi*flny1+ys*dn1-ys*dny1 ti4=b rr2p=ti4-2.*ymi*barlog t=4.*amp2*eta if(ita.eq.2)then +self,if=targ_d. call ffdeu(t,fc,fm,fq) ff1p=-(fc+fq*eta/3.+fm*eta/2.) ff2p=.5*(1.+eta)*fm**2 +self,if=targ_h. call ffpro(t,ge,gm) +self,if=targ_he3. call ffhe3(t,ge,gm) +self,if=targ_h,targ_he3. f2=(gm-ge)/(1.+eta) f1=gm-f2 ff1p=(f1+f2)*f1 ff2p=-(f1+f2)**2 +self. elseif(ita.eq.3)then call ffquas(t,geun,gmun,gepo,gmpo) f2=(gmpo-gepo)/(1.+eta) f1=gmpo-f2 ff1p=(f1+f2)*f1 ff2p=-(f1+f2)**2 +self. endif elpal2=(ff1p*rr1p+ff2p*rr2p)/eta end +deck, ra2lss,if=alpha2ll. double precision function ra2lss(z) implicit real*8(a-h,o-z) sib=sigmab(z,1d0) cl=2d0*(1d0+z)*log(z)+1d0-z+4d0/3d0*(1d0-z**3)*z ra2lss=cl*sib end +deck, ra2lpp,if=alpha2ll. double precision function ra2lpp(z) implicit real*8(a-h,o-z) sib=sigmab(1d0,z) cl=2*(1d0+z)*log(z)+1d0-z+4d0/3d0*(1d0-z**3)*z ra2lpp=cl*sib end +deck, ra2fss,if=alpha2ll. double precision function ra2fss(z) implicit real*8(a-h,o-z) sib=sigmab(z,1d0) si0=sigmab(1d0,1d0) ra2fss=((1d0+z**2)*sib-2d0*si0)/(1d0-z) end +deck, ra2fpp,if=alpha2ll. double precision function ra2fpp(z) implicit real*8(a-h,o-z) sib=sigmab(z,1d0) si0=sigmab(1d0,1d0) ra2fpp=((1d0+z**2)*sib-2d0*si0)/(1d0-z) end +deck,ra2isp,if=alpha2ll. double precision function ra2isp(z1) implicit real*8(a-h,o-z) +seq,comsxy. common/ra2i/zz1 external ra2jsp ep=1d-8 zz1=z1 zz=(1.d0-ys+z1*xs*ys)/z1 step=(1d0-zz-2.*ep)/100 call simpt(zz+ep,1d0-ep,step,1d-2,1d-18,ra2jsp,ra,ra2isp,r2,r3) c call simpxx(2,zz+ep,1d0-ep,100,1d-2,ra2jsp,ra2isp) end double precision function ra2jsp(z2) implicit real*8(a-h,o-z) common/ra2i/z1 ssi=0. ssi=ssi-2.d0*(1.d0+z2**2)*sigmab(1d0,z2) ssi=ssi-2.d0*(1.d0+z1**2)*sigmab(z1,1d0) ssi=ssi+(1.d0+z2**2)*(1.d0+z1**2)*sigmab(z1,z2) ssi=ssi+4d0*sigmab(1d0,1d0) ra2jsp=ssi/(1.d0-z1)/(1.d0-z2) end +deck,targws,if=electroweak,if=f2g1sch. subroutine targws(sigws0,sigws1) implicit real*8 (a-h,o-z) +seq,comtail. common/loc/unloc,pnloc,nucl +self,if=targ_h. unloc=un pnloc=pn nucl=1 call gws(sigws0,sigws1) +self,if=targ_d. cup=1d0/2d0 cpp=1d0/2d0 cun=1d0/2d0 cpn=1d0/2d0 +self,if=targ_he3. cup=2d0/3d0 cpp=0d0 cun=1d0/3d0 cpn=1d0 +self,if=targ_d,targ_he3. unloc=cup*un pnloc=cpp*pn nucl=1 call gws(sigwsp0,sigwsp1) unloc=cun*un pnloc=cpn*pn nucl=2 call gws(sigwsn0,sigwsn1) sigws0=sigwsp0+sigwsn0 sigws1=sigwsp1+sigwsn1 +self. end +deck,gws,if=electroweak,if=f2g1sch. subroutine gws(sigws0,sigws1) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. +seq,comweak. common/loc/unloc,pnloc,nucl external fxi dimension fqp(12),fqm(12) dimension dlamv(2,2),dlama(2,2) . ,rv(2,2),ra(2,2),drv(2,2),dra(2,2),rv3(3,3,2),ra3(3,3,2) . ,fqv(2,2),fqa(2,2),dfqv(2,2),dfqa(2,2),fqv3(3,3,2),fqa3(3,3,2) . ,fv(2,2),fa(2,2) . ,fq(12),t3(12),amq2(12),v1(3),v2(3),a1(3),a2(3) . ,dsibm(2,2),dsibmq(2,2),dsvlm(2,2) +self,if=-ew_onlylep. . ,dfv(2,2),dfa(2,2) . ,fv3(3,3,2),fa3(3,3,2) . ,dlt(3,3,2) . ,dsvqm(2,2) . ,t51(4),t52(4),tt1(4),tt2(4),lm1(4),lm2(4) data lm1/1,1,2,3/,lm2/1,2,2,3/ +self. call vercon(1.d0,-.5d0,-1d0,v1,v2,a1,a2,dlamv,dlama) call verts(1.d0,-y,v1,v2,a1,a2,aml2,1d0,1d0,1d0,-pl,rv,ra,drv,dra, . rv3,ra3) call distr(nucl,xs,y,fqp,fqm,fq,t3,amq2) do i=1,iw do j=1,iw fv(i,j)=0. fa(i,j)=0. +self,if=-ew_onlylep. dfv(i,j)=0. dfa(i,j)=0. +self. enddo enddo +self,if=-ew_onlylep. do l=1,iw**2 il=lm1(l) jl=lm2(l) do k=1,iw fv3(il,jl,k)=0. fa3(il,jl,k)=0. enddo enddo +self. delsi0=0. delsi1=0. delsi2=0. dlm=log(y/aml2) um=sx-y alv=log(um/y) alr=log(x/s) alsx=log(sx**2/s/x) do iq=1,12 if (iq.le.6) then cq=1.d0 else cq=-1.d0 endif call vercon(cq,t3(iq),fq(iq),v1,v2,a1,a2,dlamv,dlama) call verts(cq,-y,v1,v2,a1,a2,amq2(iq), . xs*fqp(iq),xs*fqm(iq),unloc,pnloc,fqv,fqa,dfqv,dfqa,fqv3,fqa3) dsibq=0. do i=1,iw do j=1,iw fv(i,j)= fv(i,j)+ fqv(i,j) fa(i,j)= fa(i,j)+ fqa(i,j) +self,if=-ew_onlylep. dfv(i,j)=dfv(i,j)+dfqv(i,j) dfa(i,j)=dfa(i,j)+dfqa(i,j) +self. dsibmq(i,j)=pi*alfa**2/2./s*dd(i)*dd(j)* . (tpl*rv(i,j)*fqv(i,j)+tmi*ra(i,j)*fqa(i,j)) dsibq=dsibq+ dsibmq(i,j) enddo enddo almb=log(y/amq2(iq)) delsi0=delsi0+((dlm-1.)*(2.*alv+alsx-dlm) . +.5*(dlm**2-alr**2-pi2/3.))*dsibq +self,if=-ew_onlylep. delsi1=delsi1+4.*fq(iq)*alr*alv*dsibq c delsi2=delsi2+fq(iq)**2*((almb-1.)*(2.*alv-.75-almb) c . +.25*alv-pi2/3.)*dsibq delsi2=delsi2+fq(iq)**2*((almb-1.)*(2.*alv-.75)+almb . +.25*alv-pi2/6.)*dsibq ************************************************************* * см. лист 28 deqed2=deqed2-.5*fq(iq)**2*((almb+alv)**2+pi2/3.)*dsibmq(1,1) delsi2=delsi2-.5*fq(iq)**2*((almb+alv)**2+pi2/3.)*dsibq ************************************************************* do l=1,iw**2 il=lm1(l) jl=lm2(l) do k=1,iw fv3(il,jl,k)=fv3(il,jl,k)+ fqv3(il,jl,k) fa3(il,jl,k)=fa3(il,jl,k)+ fqa3(il,jl,k) enddo enddo +self. enddo dsib=0. dsivl=0. dsivq=0. do i=1,iw do j=1,iw dsibm(i,j)=pi*alfa**2/2./s*dd(i)*dd(j)* . (tpl*rv(i,j)*fv(i,j)+tmi*ra(i,j)*fa(i,j)) dsib=dsib+ dsibm(i,j) dsvlm(i,j)= pi*alfa**2/2./s*dd(i)*dd(j)* . (tpl*drv(i,j)*fv(i,j)+tmi*dra(i,j)*fa(i,j)) dsivl=dsivl+ dsvlm(i,j) write(9,'(1x,a17,g11.4)')' dsvlm=',dsvlm(i,j) write(9,'(1x,a17,g11.4)')' dsivl=',dsivl +self,if=-ew_onlylep. dsvqm(i,j)= pi*alfa**2/2./s*dd(i)*dd(j)* . (tpl*rv(i,j)*dfv(i,j)+tmi*ra(i,j)*dfa(i,j)) dsivq=dsivq+ dsvqm(i,j) +self. enddo enddo eps=1d-13 c call qunc8(fxi,xs+eps,1d0,eps*dsib,eps,dsr,er,nn,fl,3500) call dqn32(xs,1d0,fxi,dsr) print *,'dsr=',dsr sigbox=0. +self,if=-ew_onlylep. sbs=xs*s tbs=-y ubs=-(1.-ys)*xs*s call tt5(tbs,sbs,t51,tt1) call tt5(tbs,ubs,t52,tt2) do l=1,iw**2 il=lm1(l) jl=lm2(l) cc=tt1(l)-tt2(l) c5=t51(l)+t52(l) do k=1,iw dlt(il,jl,k)=tpl*(rv3(il,jl,k)*fv3(il,jl,k)*cc . -rv3(il,jl,k)*fv3(il,jl,k)*c5) . +tmi*(ra3(il,jl,k)*fa3(il,jl,k)*cc . -ra3(il,jl,k)*fa3(il,jl,k)*c5) enddo ddcu=dd(1) if(l.eq.2)ddcu=dd(2) sigcur=-pi*alfa**2/s*(ddcu*dd(1)*dlt(il,jl,1)+ . ddcu*dd(2)*dlt(il,jl,2)) sigbox=sigbox+sigcur enddo +self. call sigall(-y,ppia,ppiaz,ppiz,ppiw,ppqed) +self,if=-ew_onlyqed. selfaz=0. do j=1,2 selfaz=selfaz + pi*alfa**2/2*s*dd(2)*dd(j)* .(tpl*(rv(1,j)*fv(2,j)+rv(2,j)*fv(1,j)) .+tmi*(ra(1,j)*fa(2,j)+ra(2,j)*fa(1,j))) enddo selfs=-2.*ppia*dsibm(1,1)-2.*(ppia+ppiz)*(dsibm(1,2)+dsibm(2,1)) . -2.*ppiz*dsibm(2,2)-2.*ppiaz*selfaz +self,if=ew_onlyqed. selfs=-2.*ppqed*dsibm(1,1) +self. +self,if=ew_onlyqed. sigws0=barn*dsib +self,if=-ew_onlyqed. sigws0=barn*(dsib-dsibm(1,1)) +self. sigv=barn*(selfs+dsivl+dsivq+sigbox) sigr=barn*(dsr+alfa/pi*(delsi0+delsi1+delsi2)) sigws1=sigv+sigr c+self,if=ew_onlyqed. ddss=dsibm(1,1)*alfa/pi write(9,'(a20,g11.4)')'ppia = ',ppia write(9,'(a20,g11.4)')'ppiaz = ',ppiaz write(9,'(a20,g11.4)')'ppiz = ',ppiz write(9,'(a20,g11.4)')'ppiw = ',ppiw write(9,'(a20,g11.4)')' dsivl/dsib = ',dsivl/ddss write(9,'(a20,g11.4)')' selfs/dsib = ',selfs/ddss write(9,'(a20,g11.4)')' delsi0/dsib= ',delsi0/ddss write(9,'(a20,g11.4)')' barn*dsib = ',barn*dsib write(9,'(a20,g11.4)')' barn*selfs = ',barn*selfs write(9,'(a20,g11.4)')' barn*dsivl = ',barn*dsivl write(9,'(a20,g11.4)')' barn*dsivq = ',barn*dsivq write(9,'(a20,g11.4)')' barn*sigbox= ',barn*sigbox write(9,'(a20,g11.4)')' barn*dsr = ',barn*dsr write(9,'(a20,g11.4)')' barn*dlt0 = ',barn*alfa/pi*delsi0 write(9,'(a20,g11.4)')' barn*dlt1 = ',barn*alfa/pi*delsi1 write(9,'(a20,g11.4)')' barn*dlt2 = ',barn*alfa/pi*delsi2 write(9,'(a20,g11.4)')' sigv = ',sigv write(9,'(a20,g11.4)')' sigr = ',sigr write(9,'(a20,g11.4)')' sigws1 = ',sigws1 c+self. end +deck,sigall,if=electroweak. subroutine sigall(s,ppia,ppiaz,ppiz,ppiw,ppqed) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comppi. +seq,comweak. dimension amfer(9),fqn(6),t3n(6) data amfer/5.11d-4,1.05658d-1,1.784d0 . ,.005d0,.007d0,1.5d0,.15d0,30.d0,4.5d0/ data fqn/2.,-1.,2.,-1.,2.,-1./ data t3n/.5,-.5,.5,-.5,.5,-.5/ suma=0. smma=0. sumaz=0. smmaz=0. sumz1=0. smmz1=0. sumz2=0. smmz2=0. sumw=0. smmw=0. sumwq=0. smmwq=0. *************************************** do i=1,3 *************************************** c do i=1,9 if(i.le.3)then qf=-1. vcf=-(1. - 4.*sw2)/4./sw/cw cl=1. else qf=fqn(i-3)/3. vcf=(t3n(i-3)-2.*sw2*qf)/2./sw/cw cl=3. endif qf2=qf**2 vcf2=vcf**2 acf2=1./16./sw2/cw2 amf=amfer(i) amf2=amf**2 suma=suma+cl*qf2*((2.*amf2+s)*fholl(s,amf2,amf2)-s/3.) smma=smma+cl*qf2*( 2.*amf2 *fholl(0d0,amf2,amf2) ) sumaz=sumaz+cl*vcf*qf*((2.*amf2+s)*fholl(s,amf2,amf2)-s/3.) smmaz=smmaz+cl*vcf*qf*( 2.*amf2 *fholl(0d0,amf2,amf2) ) sumz2=sumz2+cl*((vcf2+acf2)*((2.*amf2+s) . *fholl(s,amf2,amf2)-s/3.) . -3./8./cw2/sw2*amf2*fholl(s,amf2,amf2)) smmz2=smmz2+cl*((vcf2+acf2)*((2.*amf2+amz2) . *fholl(amz2,amf2,amf2)-amz2/3.) . -3./8./cw2/sw2*amf2*fholl(amz2,amf2,amf2)) if(i.le.3)then sumz1=sumz1+2.*acf2*s*(5./3.-log(abs(-s/amf2))) smmz1=smmz1+2.*acf2*amz2*(5./3.-log(abs(amz2/amf2))) sumw =sumw+(s-amf2/2.-amf2**2/2./s)*fholl(s,0.d0,amf2)+ . 2./3.*s-amf2/2. smmw=smmw+(amw2-amf2/2.-amf2**2/2./amw2) . *fholl(amw2,0.d0,amf2)+ . 2./3.*amw2-amf2/2. endif if(i.eq.4 .or. i.eq.6 .or. i.eq.8) then amq2u=amf2 amq2d=amfer(i+1)**2 ap=amq2u+amq2d am=amq2u-amq2d if(abs(am) .lt. 1d-10)then ratio=1./amq2u else ratio=log(amq2u/amq2d)/am endif sumwq=sumwq+cl*((s-ap/2.-am**2/2./s)* . fholl(s,amq2u,amq2d) . +(s-ap/2.)*(1.-ap*ratio/2.)-s/3.) smmwq=smmwq+cl*((amw2-ap/2.-am**2/2./amw2)* . fholl(amw2,amq2u,amq2d) . +(amw2-ap/2.)*(1.-ap*ratio/2.)-amw2/3.) endif enddo siga=alfa/(4.*pi)*(4./3.*suma-(3.*s+4.*amw2)*fholl(s,amw2,amw2)) sima=alfa/(4.*pi)*(4./3.*smma- 4.*amw2*fholl(0d0,amw2,amw2)) sigaz=alfa/(4.*pi)*(-4./3.*sumaz+ . 1./cw/sw*((3*cw2+1./6.)*s+(4.*cw2+4./3.)*amw2) . *fholl(s,amw2,amw2)+s/9.) simaz=alfa/(4.*pi)*(-4./3.*smmaz+ . 1./cw/sw*( 4.*cw2+4./3.)*amw2 . *fholl(0d0,amw2,amw2) ) sigz=alfa/(4.*pi)*(4./3.*sumz1+4./3.*sumz2 .+((-cw2**2*(80.*amw2+40.*s)+(cw2-sw2)**2*(8.*amw2+s) +12.*amw2) .*fholl(s,amw2,amw2) .+(10.*amz2-2.*amhi2+s+(amhi2-amz2)**2./s)*fholl(s,amhi2,amz2) .-2.*amhi2*log(amhi2/amw2)-2.*amz2*log(amz2/amw2) .+(10.*amz2-2.*amhi2+s)*(1.-0.5*((amhi2+amz2)/(amhi2-amz2)) .*log(amhi2/amz2)-0.5*log(amhi2*amz2/amw2**2)) .+2./3.*s*(1.+(cw2-sw2)**2-4.*cw**4)) /12./sw2/cw2) simz=alfa/(4.*pi)*(4./3.*smmz1+4./3.*smmz2 .+((-cw2**2*(80.*amw2+40.*amz2)+(cw2-sw2)**2*(8.*amw2+amz2) . +12.*amw2) .*fholl(amz2,amw2,amw2) .+(10.*amz2-2.*amhi2+amz2+(amhi2-amz2)**2./amz2) .*fholl(amz2,amhi2,amz2) .-2.*amhi2*log(amhi2/amw2)-2.*amz2*log(amz2/amw2) .+(10.*amz2-2.*amhi2+amz2)*(1.-0.5*((amhi2+amz2)/(amhi2-amz2)) .*log(amhi2/amz2)-0.5*log(amhi2*amz2/amw2**2)) .+2./3.*amz2*(1.+(cw2-sw2)**2-4.*cw**4)) /12./sw2/cw2) ****************************************************** * sumwq=0. ****************************************************** sigw =alfa/4./pi/sw2*(1./3.*sumw+1./3.*sumwq+ . (sw**4*amz2-cw2/3.*(7.*(amz2+amw2)+10.*s-2.*(amz2-amw2)**2/s) . -1./6.*(amw2+amz2-s/2.-1./2.*(amz2-amw2)**2/s)) . *fholl(s,amz2,amw2) . +sw2/3.*(-10.*s-4.*amw2+2.*amw2**2/s)*fholl(s,0.d0,amw2) . +1./6.*(5.*amw2-amhi2+s/2.+(amhi2-amw2)**2/2./s) . *fholl(s,amhi2,amw2) . +(cw2/3.*(3.*amz2+11.*amw2+10.*s)-amz2*sw**4 . +1./6.*(2*amw2-s/2.))*amz2/(amz2-amw2)*log(amz2/amw2) . -(2./3.*amw2+s/12.)*amhi2/(amhi2-amw2)*log(amhi2/amw2) . -cw2/3.*(7.*(amw2+amz2)+32./3.*s)+sw**4*amz2 . +1./6.*(4*amw2-amz2-amhi2+5./3.*s)-sw2/3.*(4*amw2+32./3.*s)) simw =alfa/4./pi/sw2*(1./3.*smmw+1./3.*smmwq+ . (sw**4*amz2-cw2/3.*(7.*(amz2+amw2)+10.*amw2 . -2.*(amz2-amw2)**2/amw2) . -1./6.*(amw2+amz2-amw2/2.-1./2.*(amz2-amw2)**2/amw2)) . *fholl(amw2,amz2,amw2) . +sw2/3.*(-10.*amw2-4.*amw2+2.*amw2)*fholl(amw2,0.d0,amw2) . +1./6.*(5.*amw2-amhi2+amw2/2.+(amhi2-amw2)**2/2./amw2) . *fholl(amw2,amhi2,amw2) . +(cw2/3.*(3.*amz2+11.*amw2+10.*amw2)-amz2*sw**4 . +1./6.*(2*amw2-amw2/2.))*amz2/(amz2-amw2)*log(amz2/amw2) . -(2./3.*amw2+amw2/12.)*amhi2/(amhi2-amw2)*log(amhi2/amw2) . -cw2/3.*(7.*(amw2+amz2)+32./3.*amw2)+sw**4*amz2 .+1./6.*(4*amw2-amz2-amhi2+5./3.*amw2)-sw2/3.*(4*amw2+32./3.*amw2)) dmw2=simw dmz2=simz dz2a=alfa/6./pi dz1a=dz2a-sw/cw*simaz/amz2 dro=dmz2/amz2-dmw2/amw2 dz2z=dz2a-2.*(cw2-sw2)/sw/cw*simaz/amz2+(cw2-sw2)/sw2*dro dz1z=dz2a-(3.*cw2-2.*sw2)/sw/cw*simaz/amz2+(cw2-sw2)/sw2*dro dz2w=dz2a-2.*cw/sw*simaz/amz2+cw2/sw2*dro dz1az=cw*sw/(cw2-sw2)*(dz1z-dz1a) dz2az=cw*sw/(cw2-sw2)*(dz2z-dz2a) rsiga=siga+dz2a*s rsigz=sigz-dmz2+dz2z*(s-amz2) rsigw=sigw-dmw2+dz2w*(s-amw2) rsigaz=sigaz-dz2az*s+(dz1az-dz2az)*amz2 ppia=rsiga/s ppiaz=rsigaz/s ppiz=rsigz/(s-amz2) ppiw=rsigw/(s-amw2) ppqed=alfa/3./pi * suma/s end +deck,vercon,if=electroweak. subroutine vercon(cq,t3,fq1,v1,v2,a1,a2,dlamv,dlama) implicit real*8(a-h,o-z) dimension v1(3),a1(3),v2(3),a2(3),dlamv(2,2),dlama(2,2) +seq,comweak. fq2=fq1-2.d0*t3 v1(1)=-fq1 v2(1)=-fq2 v1(2)=(t3-2.*sw2*fq1)/2./sw/cw v2(2)=(-t3-2.*sw2*fq2)/2./sw/cw v1(3)=1./2./sqrt(2d0)/sw v2(3)=1./2./sqrt(2d0)/sw a1(1)=0. a2(1)=0. a1(2)=t3/2./sw/cw a2(2)=-t3/2./sw/cw a1(3)=1./2./sqrt(2d0)/sw a2(3)=1./2./sqrt(2d0)/sw do i=1,2 do j=1,2 dlamv(i,j)=2.*(v1(i)*v1(j)+a1(i)*a1(j)) dlama(i,j)=2.*cq*(v1(i)*a1(j)+a1(i)*v1(j)) enddo enddo end subroutine verts(cq,s,v1,v2,a1,a2,amf2,fqp,fqm,u,p,fv,fa,dfv,dfa .,fv3,fa3) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comppi. +seq,comweak. dimension v1(3),a1(3),v2(3),a2(3),g(2) dimension lm1(4),lm2(4) dimension ddfv(2),ddfa(2) dimension dfv(2,2),dfa(2,2) dimension fv(2,2),fa(2,2) dimension fv3(3,3,2),fa3(3,3,2) data lm1/1,1,2,3/,lm2/1,2,2,3/ g(1)=1. g(2)=-cw/sw do i=1,iw do j=1,iw fv(i,j)=2.*(u*(v1(i)*v1(j)+a1(i)*a1(j))*fqp+ . p*cq*(v1(i)*a1(j)+a1(i)*v1(j))*fqm) fa(i,j)=2.*(u*cq*(v1(i)*a1(j)+a1(i)*v1(j))*fqp+ . p*(v1(i)*v1(j)+a1(i)*a1(j))*fqm) enddo enddo do ii=1,iw alva=v1(ii)*(v1(1)**2+a1(1)**2)+2.*a1(ii)*v1(1)*a1(1) alaa=a1(ii)*(v1(1)**2+a1(1)**2)+2.*v1(ii)*v1(1)*a1(1) alvz=v1(ii)*(v1(2)**2+a1(2)**2)+2.*a1(ii)*v1(2)*a1(2) alaz=a1(ii)*(v1(2)**2+a1(2)**2)+2.*v1(ii)*v1(2)*a1(2) alvw=v2(ii)*(v1(3)**2+a1(3)**2)+2.*a2(ii)*v1(3)*a1(3) alaw=a2(ii)*(v1(3)**2+a1(3)**2)+2.*v2(ii)*v1(3)*a1(3) +self,if=-ew_onlyqed. ddfv(ii)=alfa/4./pi*(alva *dlamb1(s,amf2) . +alvz *dlamb2(s,amz2)+alvw *dlamb2(s,amw2) . +3.*dsign(v1(1),1d0)*g(ii)*(v1(3)**2+a1(3)**2)*dlamb3(s,amw2)) ddfa(ii)=alfa/4./pi*(alaa *dlamb1(s,amf2) . +alaz *dlamb2(s,amz2)+alaw *dlamb2(s,amw2) . +3.*dsign(v1(1),1d0)*g(ii)*2.*v1(3)*a1(3)*dlamb3(s,amw2)) +self,if=ew_onlyqed. ddfv(ii)=alfa/4./pi* alva *dlamb1(s,amf2) ddfa(ii)=alfa/4./pi* alaa *dlamb1(s,amf2) +self. enddo do i=1,iw do j=1,iw ddlv=2.*(v1(i)*ddfv(j)+v1(j)*ddfv(i)+a1(i)*ddfa(j)+a1(j)*ddfa(i)) ddla=2.*cq*(v1(i)*ddfa(j)+v1(j)*ddfa(i) . +a1(i)*ddfv(j)+a1(j)*ddfv(i)) dfv(i,j) =u*ddlv*fqp+p*ddla*fqm dfa(i,j) =u*ddla*fqp+p*ddlv*fqm enddo enddo do l=1,iw**2 il=lm1(l) jl=lm2(l) if(l.eq .4)then fvcurr=2.*(u*(v1(3)*v1(3)+a1(3)*a1(3))*fqp+ . p*cq*(v1(3)*a1(3)+a1(3)*v1(3))*fqm) facurr=2.*(u*cq*(v1(3)*a1(3)+a1(3)*v1(3))*fqp+ . p*(v1(3)*v1(3)+a1(3)*a1(3))*fqm) else fvcurr=fv(il,jl) facurr=fa(il,jl) endif do k=1,iw fv3(il,jl,k)=v1(k)*fvcurr+a1(k)*fvcurr fa3(il,jl,k)=v1(k)*facurr+a1(k)*facurr enddo enddo end +deck,tt5,if=electroweak,if=f2g1sch. subroutine tt5(s,t,t5,tt) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comppi. +seq,comweak. dimension tt(4),t5(4) dln(x)=log(abs(x)) print *,' t1',1.-4.*amz2/s*(1+amz2/t) c x1z=1./2.*(1+sqrt(1.-4.*amz2/s*(1+amz2/t))) c x2z=1./2.*(1-sqrt(1.-4.*amz2/s*(1+amz2/t))) c x1w=1./2.*(1+sqrt(1.-4.*amw2/s*(1+amw2/t))) c x2w=1./2.*(1-sqrt(1.-4.*amw2/s*(1+amw2/t))) y1z=1./2.*(1+sqrt(1.-4.*amz2/s)) y2z=1./2.*(1-sqrt(1.-4.*amz2/s)) y1w=1./2.*(1+sqrt(1.-4.*amw2/s)) y2w=1./2.*(1-sqrt(1.-4.*amw2/s)) print *,' t2','s+t=',s+t t5(1)=alfa/4./pi*(s/2./(s+t)*dln(t/s) . -s*(s+2.*t)/4./(s+t)**2*(dln(t/s)+pi2)) print *,'t3' t5(2)=alfa/4./pi*(s-amz2)/2./(s+t)*(dln(t/(s-amz2)) . -amz2/s*dln(amz2/(amz2-s))+(s+2.*t+amz2)/(s+t)*( .fspen(s/amz2)-fspen(-t/amz2)+dln(-t/amz2)*dln((amz2-s)/(amz2+t)))) print *,'t4' t5(3)=0. c t5(3)=alfa/4./pi*s/(s+t)*((2.*t+s+amz2)/2./(s+t)*( c . fspen(1.+t/amz2)-pi2/6.-dln(-y1z/y2z)**2) c . +1./2.*dln(-t/amz2)+(y2z-y1z)/2.*dln(-y1z/y2z)+ c . (s+2.*t-4.*t*amz2/s+2.*amz2**2/t-2.*amz2**2/s) c . /2./(s+t)/(x2z+x1z)*(fspen(x1z/(x1z-y1z)) c . +fspen(x1z/(x1z-y2z))-fspen(x2z/(x2z-y2z)) c . -fspen(x2z/(x2z-y1z)))) print *,' t5' t5(4)=0. c t5(4)=alfa/4./pi*s/(s+t)*((2.*t+s+amw2)/2./(s+t)*( c . fspen(1.+t/amw2)-pi2/6.-dln(-y1w/y2w)**2) c . +1./2.*dln(-t/amw2)+(y2w-y1w)/2.*dln(-y1w/y2w)+ c . (s+2.*t-4.*t*amw2/s+2.*amw2**2/t-2.*amw2**2/s) c . /2./(s+t)/(x2w+x1w)*(fspen(x1w/(x1w-y1w)) c . +fspen(x1w/(x1w-y2w))-fspen(x2w/(x2w-y2w)) c . -fspen(x2w/(x2w-y1w)))) print *,' t6' tt(1)=t5(1) tt(2)=t5(2)+alfa/2./pi*(fspen((amz2+t)/t) . +1./2.*dln(t**2/s**2)*dln(amz2/(amz2-s)) . -dln(-t/s)*dln(amz2/t) ) print *,' t7' tt(3)=0. c tt(3)=t5(3)+alfa/2./pi*(2.*dln(-y1z/y2z)**2+2./(x1z-x2z) c . *(fspen(x1z/(x1z-y1z)) c . +fspen(x1z/(x1z-y2z))-fspen(x2z/(x2z-y2z)) c . -fspen(x2z/(x2z-y1z)))) print *,' t8' tt(4)=0. c tt(4)=t5(4)+alfa/2./pi*(2.*dln(-y1w/y2w)**2+2./(x1w-x2w) c . *(fspen(x1w/(x1w-y1w)) c . +fspen(x1w/(x1w-y2w))-fspen(x2w/(x2w-y2w)) c . -fspen(x2w/(x2w-y1w)))) print *,' t9' end +deck,fholl,if=electroweak. double precision function fholl(s,am1,am2) implicit real*8(a-h,o-z) if (s.eq.0) then fholl=0. else if (am1.eq.0.) then if (s.eq.am2) then fholl=1. else fholl=1.+(am2/s-1.)*log(abs(-s/am2+1.)) endif else a=(1.+(am1-am2)/s)/2. u=a**2-am1/s if (u.gt.0) then b=sqrt(u) q=(1./2.-a)*log(am2/am1) . +b*log((1.+1./(b-a))/(1.-1./(a+b)))-2. else b=sqrt(-u) q=(1./2.-a)*log(am2/am1) . +2*b*(atan((1.-a)/b)-atan(-a/b))-2. end if if (am2.eq.am1) then fholl=-q else fholl=-1.+0.5*(am1+am2)/(am1-am2)*log(am1/am2)-q end if end if end +deck,dlamb,if=electroweak. function dlamb1(s,am2) implicit real*8(a-h,o-z) +seq,comppi. c dlamb1=log(-s/am2)+log(-s/am2)**2+4.*(pi2/12.-1) dlamb1=0d0 end function dlamb2(s,am2) implicit real*8(a-h,o-z) +seq,comppi. w=am2/s dlamb2=-7./2.-2.*w-(2.*w+3.)*log(-w) . +2.*(1.+w)**2*(fspen(1.+1./w)-pi2/6.) end function dlamb3(s,am2) implicit real*8(a-h,o-z) +seq,comppi. w=am2/s sq=sqrt(1.-4.*w) sln=log((sq+1.)/(sq-1.)) dlamb3=5./6.-2.*w/3.+(2.*w+1.)/3.*sq*sln . +2./3.*w*(w+2.)*sln**2 end +deck,vconew,if=electroweak,if=f2g1grsv96. ************** vconew ********************************************** double precision function vconew(key) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comtail. +seq,comweak. +seq,comppi. call ffvapm(xs,y,f1ew,g1ew,key) vconew=2.*pi*alfa**2*xs/s/y**2*barn*( . (s**2+x**2)*f1ew . +(s**2-x**2)*g1ew ) end +deck,ffvapm,if=electroweak,if=f2g1grsv96. ************** ffvapm ********************************************** subroutine ffvapm(xi,t,f1ew,g1ew,key) implicit real*8(a-h,o-z) parameter (c1i3 = 3.3333333333333337d-1) ! 1/3 parameter (c2i3 = 6.6666666666666667d-1) ! 2/3 +seq,comcmp. +seq,comsxy. +seq,comtail. +seq,comweak. dimension fqp(12),fqm(12),fq(12),t3(12),amq2(12) . ,v1(3),v2(3),a1(3),a2(3),dlamv(2,2),dlama(2,2) . ,dlamvq(2,2),dlamaq(2,2) dimension cu(2),cp(2) dimension drv(2,2),dra(2,2) dimension rvar(2,2),raar(2,2) dimension ddrv(2,2),ddra(2,2) dimension rv3(3,3,2),ra3(3,3,2) +self,if=targ_h. data cu,cp,nnuc/1d0,0d0,1d0,0d0,1/ +self,if=targ_d. data cu,cp,nnuc/.5d0,.5d0,.5d0,.5d0,2/ +self,if=targ_he3. data cu,cp,nnuc/c2i3,c1i3,0d0,1d0,2/ +self. if(key.eq.0)then pll=0d0 else pll=pl endif call vercon(1.d0,-.5d0,-1d0,v1,v2,a1,a2,dlamv,dlama) chi=t/(t+amz2) if(key.eq.2)then call verts(1.d0,-y,v1,v2,a1,a2,aml2,1d0,1d0,1d0 . ,-pll,rvar,raar,drv,dra,rv3,ra3) call sigall(-y,ppia,ppiaz,ppiz,ppiw,ppqed) ddrv(1,1)=rvar(1,1)*(-2.*(ppia-ppqed)) . -2.*ppiaz*rvar(1,2)*chi+drv(1,1) ddrv(1,2)=rvar(1,2)*(1.-2.*(ppia+ppiz)) . -ppiaz*(rvar(1,1)+rvar(2,2)*chi)+drv(1,2) ddrv(2,1)=ddrv(1,2) ddrv(2,2)=rvar(2,2)*(1.-2.*ppiz)+drv(2,2)-2.*ppiz*rvar(2,2) ddra(1,1)=raar(1,1)*(-2.*(ppia-ppqed)) . +dra(1,1)-2.*ppiaz*raar(1,2)*chi ddra(1,2)=raar(1,2)*(1.-2.*(ppia+ppiz)) . -ppiaz*(raar(1,1)+raar(2,2)*chi)+dra(1,2) ddra(2,1)=ddra(1,2) ddra(2,2)=raar(2,2)*(1.-2.*ppiz)+dra(2,2)-2.*ppiz*raar(2,2) endif f1ew=0. g1ew=0. do nucl=1,nnuc unloc=cu(nucl)*un pnloc=cp(nucl)*pn call distr(nucl,xi,t,fqp,fqm,fq,t3,amq2) do iq=1,12 if (iq.le.6) then cq=1.d0 else cq=-1.d0 endif call vercon(cq,t3(iq),fq(iq),v1,v2,a1,a2,dlamvq,dlamaq) do i=1,iw do j=1,iw c if(i.ne.1.or.j.ne.1)then if(key.eq.2)then rvdd=ddrv(i,j) radd=ddra(i,j) else if(i.ne.1.or.j.ne.1)then rvdd=dlamv(i,j)-pll*dlama(i,j) radd=dlama(i,j)-pll*dlamv(i,j) else rvdd=0d0 radd=0d0 endif endif f1ew=f1ew+0.25*chi**(i+j-2)*rvdd* . (unloc*dlamvq(i,j)*fqp(iq)+pnloc*dlamaq(i,j)*fqm(iq)) g1ew=g1ew-0.25*chi**(i+j-2)*radd* . (unloc*dlamaq(i,j)*fqp(iq)+pnloc*dlamvq(i,j)*fqm(iq)) c endif enddo enddo enddo enddo amf2=t/xi-t+amp2 wei=portn(t,0d0,0.4d0)*portn(amf2,amc2,1.232d0) g1ew=g1ew*wei f1ew=f1ew*wei end +deck,distr,if=electroweak. subroutine distr(nuclon,x,t,fqp,fqm,fq,t3,amq2) implicit real*8(a-h,o-z) dimension fqp(12),fqm(12),fq(12),fqn(6),t3(12),t3n(6) dimension amq2(12),amq(6),iiq(6) +self,if=f2g1grsv96. dimension pdf(-6:6) +self. data iiq/1,2,4,3,6,5/ c u d c s t b data amq/.005,.007,1.5,.15,30.,4.5/ data fqn/2.,-1.,2.,-1.,2.,-1./ data t3n/.5,-.5,.5,-.5,.5,-.5/ +self,if=f2g1sch. call schaf(x,g1p,g1n,f2p,f2n,0.25d0,0.19d0) ux=.6*(4.*f2p-f2n)/x dx=.6*(4.*f2n-f2p)/x ur=1.2*(4.*g1p-g1n) dr=1.2*(4.*g1n-g1p) ssx=0. ssr=0. do i=1,6 fqp(i)=ssx fqm(i)=ssr fqp(i+6)=ssx fqm(i+6)=ssr if(nuclon.eq.1)then if (i.eq.1) fqp(i)=ux+ssx if (i.eq.1) fqm(i)=ur if (i.eq.2) fqp(i)=dx+ssx if (i.eq.2) fqm(i)=dr else if (i.eq.1) fqp(i)=dx+ssx if (i.eq.1) fqm(i)=dr if (i.eq.2) fqp(i)=ux+ssx if (i.eq.2) fqm(i)=ur endif +self,if=f2g1grsv96. q2m=min(1d4,max(t,0.40d0)) q=sqrt(q2m) call pgrv(1,pdf,x, q) call parpol(3,x,q2m, uv, dv, qb, st, gl, a1p, a1n,a1d) if(nuclon.eq.1)then fqm(1)=(uv+qb)/x fqm(2)=(dv+qb)/x iiq(1)=1 iiq(2)=2 else fqm(2)=(uv+qb)/x fqm(1)=(dv+qb)/x iiq(1)=2 iiq(2)=1 endif fqm(3)=0d0 fqm(4)=st/x fqm(5)=0d0 fqm(6)=0d0 fqm(7)=qb/x fqm(8)=qb/x fqm(9)=0d0 fqm(10)=st/x fqm(11)=0d0 fqm(12)=0d0 do i=1,6 fqp(i)=pdf(iiq(i))/x fqp(i+6)=pdf(-iiq(i))/x +self. fq(i)=fqn(i)/3. t3(i)=t3n(i) amq2(i)=amq(i)**2 fq(i+6)=-fq(i) t3(i+6)=t3(i) amq2(i+6)=amq2(i) enddo return end +deck,fxi,if=electroweak,if=f2g1sch. double precision function fxi(xi) implicit real*8(a-h,o-z) +seq,comcmp. +seq,comsxy. +seq,comppi. +seq,comtail. +seq,comweak. common/loc/unloc,pnloc,nucl dimension ddx(3) dimension v1(3),v2(3),a1(3),a2(3) dimension fqm(12),fqp(12),fqm0(12),fqp0(12) dimension t3(12),fq(12),dllvm(2,2),dllam(2,2),amq2(12) dimension dlqvm(2,2),dlqam(2,2) dimension dsl(2,2),dxl(2,2) dimension dlm(2,2),dla(2,2),dlas(2,2),dlx(2,2),dls(2,2),dlu(2,2) . ,dlt(2,2),dlus(2,2),dlux(2,2),ct(2,2),cs(2,2),cx(2,2),delta(2) data delta/1d0,0d0/ trl(s,x,us,ux,ts,tx,tsz,txz,dlsk,dlxk,dlxl) .= 1./y**2*(2.*(s**2 + us**2)*dlm(i,j)/u . -(s**2 + us**2)*dlsk/s . +tpl*dlxk/x - yx**2*dlxl/ux . -2.*(us**2*(ts/tsz)**nz+s**2*(tx/txz)**nz)/u . +yx**2*dlt(i,j)/sx . -u/(s*x)*(2.*x**2-u*(s+x))*delta(i)*delta(j)) +self,if=-ew_onlylep. trh(s,x,us)=dd(i)*dd(j)*(yx/u/sx**3)*(-s**2*tu*(2.-dluh) . +tpl*sx*u+s*x*u*yx+sx**2*us**2/2.) trlh(j,s,x,us,ux,dlsk,dlxk,dlxl,dlsu,dlxu,dx) .= 1./(xi*sx*u)*( -(s**2+us**2)*dlsk . -2.*s**2*dlsu + (s+x)*sx*dlxl + tpl*dlxk . +(s**2+us**2)*dlxu . +dlt(1,j)*yx*(x+us) + u*dlu(1,j)*(s+us) . -(4.*s*u-sx**2-2.*u**2*(s+x)/sx)*ct(1,j) + ux*sx*dx) +self. xs=y/sx ysc=sx/s yx=y/xi tu=sx**2+yx**2 u=sx-yx us=x+yx ux=s-yx tau=u+xi*amp2 usx=u/sx ts=y*s/us tx=y*x/ux tsz=ts+amz2 txz=tx+amz2 sxz=sx+amz2/xi ddx(1)=1./tx ddx(2)=1./txz ct(1,1)=1. cs(1,1)=(sx-2.*ts/xi)/us cx(1,1)=(sx-2.*tx/xi)/ux dlm(1,1)=log(y/aml2) dla(1,1)=s/us*log(xi*us**2/aml2/tau) dlas(1,1)=x/ux*log(xi*ux**2/aml2/tau) dls(1,1)=log(s**2/aml2/amp2) dlx(1,1)=log(x**2/aml2/amp2) dlr=log(x/s) dlu(1,1)=log(sx**2/amp2/xi/tau) dlt(1,1)=log(xi*(sx*u+amp2*y)**2/tau/amp2/y**2) dlus(1,1)=dls(1,1) dlux(1,1)=dlx(1,1) +self,if=-ew_onlyqed. dls(1,2)=(ts/tsz)*log(us**2*tsz**2/aml2/(amp2*yz**2+amz2*u*sxz)) dls(2,2)=(ts/tsz)*(dls(1,2)+amz2*(2./tsz-1./amz2-1./(xi*sxz))) dlx(1,2)=(tx/txz)*log(ux**2*txz**2/aml2/(amp2*yz**2+amz2*u*sxz)) dlx(2,2)=(tx/txz)*(dlx(1,2)+amz2*(2./txz-1./amz2-1./(xi*sxz))) dlt(1,2)=log((tau*amz2/xi+u*sx+amp2*y)/(tau*amz2/xi+y*amp2)) dlt(2,2)=dlt(1,2)-sx/sxz dlu(1,2)=sx/sxz*dlu(1,1)-amz2/(xi*sxz)*dlt(1,2) dlus(1,2)=sx/sxz*dls(1,1)-amz2*s*u/(x*y*sxz)*dlx(1,2) dlux(1,2)=sx/sxz*dlx(1,1)-amz2*x*u/(s*y*sxz)*dls(1,2) ct(1,2)=ct(1,1)-amz2/(xi*sx)*dlt(1,2) cs(1,2)=cs(1,1)-amz2/(xi*s)*dla(1,1)+amz2/(xi*s*y)*tsz*dls(1,2) cx(1,2)=cx(1,1)-amz2/(xi*x)*dlas(1,1)+amz2/(xi*x*y)*txz*dlx(1,2) do i=1,2 dlm(i,2)=y/yz*dlm(1,i)+u*amz2/2/yz*(dls(i,2)/s-dlx(i,2)/x) dla(i,2)= dla(1,i) - amz2/y*dls(i,2) dlas(i,2)= dlas(1,i) - amz2/y*dlx(i,2) enddo dlm(2,1) = dlm(1,2) dls(2,1) = dls(1,2) dlx(2,1) = dlx(1,2) dla(2,1) = dla(1,2) dlas(2,1)= dlas(1,2) dlu(2,1) = dlu(1,2) dlt(2,1) = dlt(1,2) dlus(2,1)= dlus(1,2) dlux(2,1)= dlux(1,2) cs(2,1) = cs(1,2) cx(2,1) = cx(1,2) ct(2,1) = ct(1,2) +self. do i=1,iw do j=1,iw dsl(i,j)=us/s*dla(i,j) dxl(i,j)=ux/x*dlas(i,j) enddo enddo tbpl = 2.*(s**2+ux**2)*u*x/(ux**3) tbml = 2.*(s**2-ux**2)*u*x/(ux**3) +self,if=-ew_onlylep. tbph = 2.*(s**2+x**2)*u*y/(xi*sx**3) tbmh = 2.*(s**2-x**2)*u*y/(xi*sx**3) +self. call vercon(1d0,-.5d0,-1d0,v1,v2,a1,a2,dllvm,dllam) call distr(nucl,xi,y,fqp,fqm,fq,t3,amq2) call distr(nucl,xs,y,fqp0,fqm0,fq,t3,amq2) fxi=0. do iq=1,12 cq=1. dlmq=log(y/amq2(iq)) dluh=log(xi**2*sx**2/amq2(iq)/(xi*u+amq2(iq))) dlmqh=log(y**2/amq2(iq)/(xi*u+amq2(iq))) call vercon(cq,t3(iq),fq(iq),v1,v2,a1,a2,dlqvm,dlqam) fxiq=0. do i=1,iw do j=1,iw dllv=dllvm(i,j) dlqv=dlqvm(i,j) dlla=dllam(i,j) dlqa=dlqam(i,j) nz=i+j-2 tpl0 =4.*tpl/u*dd(i)*dd(j)*(dlm(1,1)-1.) tml0 =4.*sx*sxp/u*dd(i)*dd(j)*(dlm(1,1)-1.) +self,if=-ew_onlylep. tph0 =4.*tpl/u*dd(i)*dd(j)*(dlmqh/2.-7./8.) tplh0=8.*tpl/u*dd(i)*dd(j)*dlr tmh0 =4.*sx*sxp/u*dd(i)*dd(j)*(dlmqh/2.-7./8.) tmlh0=8.*sx*sxp/u*dd(i)*dd(j)*dlr +self. rv=dllv - pl*dlla ra=dlla - pl*dllv fv=unloc*dlqv*xi*fqp(iq) + pnloc*dlqa*xi*fqm(iq) fv0=unloc*dlqv*xs*fqp0(iq) + pnloc*dlqa*xs*fqm0(iq) fa=unloc*dlqa*xi*fqp(iq) + pnloc*dlqv*xi*fqm(iq) fa0=unloc*dlqa*xs*fqp0(iq) + pnloc*dlqv*xs*fqm0(iq) tpl1=trl(s,x,us,ux,ts,tx,tsz,txz,dls(i,j),dlx(i,j),dxl(i,j)) . + trl(-x,-s,-ux,-us,tx,ts,txz,tsz,dlx(i,j),dls(i,j),dsl(i,j)) tml1=trl(s,x,us,ux,ts,tx,tsz,txz,dls(i,j),dlx(i,j),dxl(i,j)) . - trl(-x,-s,-ux,-us,tx,ts,txz,tsz,dlx(i,j),dls(i,j),dsl(i,j)) fxiadl=1./4.*alfa**3*pl*ddx(i)*ddx(j) *ysc* 1./xi* . (tbpl*dlla*fv + tbml*dllv*fa) fxil = 1./4.*alfa**3 *ysc * 1./xi* . (rv*(tpl1*fv-tpl0*fv0) + ra*(tml1*fa-tml0*fa0)) +self,if=ew_onlylep. fxih=0. fxilh=0. fxiadh=0. +self,if=-ew_onlylep. tph=trh(s,x,us) + trh(-x,-s,-ux) tmh=trh(s,x,us) - trh(-x,-s,-ux) trlhjs=trlh(j,s,x,us,ux,dls(1,j),dlx(1,j),dxl(1,j), . dlus(1,j),dlux(1,j),cx(1,j)) trlhjx=trlh(j,-x,-s,-ux,-us,dlx(1,j),dls(1,j),dsl(1,j), . dlux(1,j),dlus(1,j),-cs(1,j)) trlhis=trlh(i,s,x,us,ux,dls(1,i),dlx(1,i),dxl(1,i), . dlus(1,i),dlux(1,i),cx(1,i)) trlhix=trlh(i,-x,-s,-ux,-us,dlx(1,i),dls(1,i),dsl(1,i), . dlux(1,i),dlus(1,i),-cs(1,i)) tplh=.5*(dd(i)*(trlhjs-trlhjx)+dd(j)*(trlhis-trlhix)) tmlh=.5*(dd(i)*(trlhjs+trlhjx)+dd(j)*(trlhis+trlhix)) fxiadl=1./4.*alfa**3*pl*ddx(i)*ddx(j) *ysc*1./xi* . (tbpl*dlla*fv + tbml*dllv*fa) fxiadh=-1./4.*alfa**3*pnloc*dd(i)*dd(j)*ysc * 1./xi* . (tbph*rv*dlqa*xi*fqp(iq) + tbml*ra*dlqv*xi*fqm(iq)) fxil = 1./4.*alfa**3 *ysc * 1./xi* . (rv*(tpl1*fv-tpl0*fv0) + ra*(tml1*fa-tml0*fa0)) fxilh = 1./4.*alfa**3*fq(iq)*ysc * 1./xi* . (rv*(tplh*fv-tplh0*fv0) + ra*(tmlh*fa-tmlh0*fa0)) fxih = 1./4.*alfa**3*fq(iq)**2 *ysc * 1./xi* . (rv*(tph*fv-tph0*fv0) + ra*(tmh*fa-tmh0*fa0)) +self. fxiq=fxiq+fxil+fxilh+fxih+fxiadl+fxiadh c write(9,'(a8,g11.4)')' xi =',xi c write(9,'(a8,g11.4)')'fqp =',fqp(iq) c write(9,'(a8,g11.4)')'fqm =',fqm(iq) c write(9,'(a8,i2)')' iq =',iq c write(9,'(a8,g11.4)')'fxiq =',fxiq c write(9,'(a8,g11.4)')'fxil =',fxil c write(9,'(a8,g11.4)')'fxilh =',fxilh c write(9,'(a8,g11.4)')'fxih =',fxih c write(9,'(a8,g11.4)')'fxiadl=',fxiadl c write(9,'(a8,g11.4)')'fxiadh=',fxiadh c stop enddo enddo fxi=fxi+fxiq c write(9,'(a8,g11.4)')'fxi2 =',fxi enddo c stop end