* *-----XS35G---------------------------------------------------------- * real*8 function wtoxs35g(ndim,x) implicit real*8 (a-h,o-z) * character*1,ocoul,opeak,oqcd,ockm,om,osm character*2,ofs character*4,otype * parameter(ninv=10,npos=512) * common/wtmod/om common/wtmp/zrm common/wtfs/ofs common/wtii/iint common/wtqcd/als common/wtdis/dist common/wtsmod/osm common/wtps/opeak common/wtkount/ik common/wtckm/ockm common/wtistrf/isf common/wtaqcd/oqcd common/wtcqcd/iqcd common/wtickm/ickm common/wtlmsb/qcdl common/wtqcdz/alsz common/wtsf/ix0,it0 common/wtcoul/ocoul common/wtchi/hch(36) common/wtipt/ifz(44) common/wticuts/iac(4) common/wtisa/isaa,isab common/wtvckm/vckm(3,3) common/wthx/xshmx(npos) common/wtochannel/otype common/wtparh/xaph(ninv) common/wttc/itc,itcc,itcn common/wtpmxh/xmxh(npos,9) common/wtncc/chf2,chfp2,conc(10) common/wtcchannel/chu,chup,chd,chdp,fcuc,fcdc common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi common/wtfmass/em,rmm,tm,rnm,uqm,dqm,cqm,sqm,bqm,tqm,dmy common/wtacchannel/omchu,opchu,omchup,opchup,omchdp,opchdp, # omchd,opchd,hchup,hchu,hchdp,hchd common/wtcpar/alpha,hbet,hbeti,omhb,eob,d0gl,g8,tfact,pih,alw, # eta,feta,beta,g2,tfacth common/wtapar/ars,s,rwm,rwm2,rwg,rwmg,swg,swgs,opswgs,sth2,cth2, # hsth2,tsth2,scth2,asth2,tth2,rzm,rzm2,rzg,rzmg,szg, # szgs,opszgs,sth4,cth4,ve,vf,vfp,rbqm2,rszw,rszw2, # s0w,s0z common/wtsubreg/dsm,usm,dsp,usp,rl(6),rr(6),srl(6),sdsm,sdsp,vvl1, # vvl2,vvl3,ul,omul,suml common/wtcuts/aim(6),bim(6),ae(4),asa(4),bsa(4),afsa(6),bfsa(6), # ombsa(4),opbsa(4),teq,rae(4),omasa(4),opasa(4), # sg12,cg12,sg13,cg13,sg14,cg14,sg23,cg23,sg24, # cg24,sg34,cg34,sct120,sct130,sct140,sct230, # sct240,sct340,sgam(4),cgam(4) * dimension x(ndim) dimension bt1(2),bt2(2) dimension rru1(2),rru2(2) dimension sfur(2),sflr(2) dimension ret1(2),ret2(2) dimension ee(5),e(5),sg(5) dimension rrr(6),rrl(6),srrl(6) dimension bl(4),xbl(4),ss(4),cs(4) dimension tgc(15),tgn(16),otgn(16) dimension dpxs(2,2,2,9),epxs(2,2,2,9),cpxs(2,9),bpxs(2,9), # apxs(9) dimension rr1(2),rr2(2),rs1(2),rs2(2),rtp(2),rtm(2) dimension hfr(4),hgr(4),hnr(4),hor(4) * data ec2/-0.4999999963d0/,ec4/0.0416666418d0/, # ec6/-0.0013888397d0/,ec8/0.0000247609d0/, # ec10/-0.0000002605d0/ * external c02ajf,s09aaf,s07aaf external s21bbf,s21caf * *-----the order of integration is: * u, v, m_-^2, m_+^2, M_0^2, m_0^2, m^2, t_w, t_1 * * m_{+/-}^2 transformed for the resonating peaks6 * M_0^2,m_0^2 transformed for the resonating peaks * m^2 and t_1 transformed for the jacobian peaks * do ix=1,2 do it=1,2 do itt=1,2 do il=1,9 dpxs(ix,it,itt,il)= 0.d0 enddo enddo enddo enddo do it=1,2 do il=1,9 cpxs(it,il)= 0.d0 bpxs(it,il)= 0.d0 enddo enddo * if(ndim.eq.6) then if(itc.eq.1) then if(itcc.eq.1) then smx= x(1) sux= x(2) sdx= x(3) sfx= x(4) twx= x(5) t1x= x(6) else if(itcc.eq.2) then smx= x(1) spx= x(2) sux= x(3) sfx= x(4) twx= x(5) t1x= x(6) else if(itcc.eq.3) then smx= x(1) spx= x(2) sux= x(3) sdx= x(4) twx= x(5) t1x= x(6) endif else smx= x(1) sux= x(2) sdx= x(3) sfx= x(4) twx= x(5) t1x= x(6) endif else if(ndim.eq.8) then if(itc.eq.1) then if(itcc.eq.1) then uvx= x(1) vvx= x(2) smx= x(3) sux= x(4) sdx= x(5) sfx= x(6) twx= x(7) t1x= x(8) else if(itcc.eq.2) then uvx= x(1) vvx= x(2) smx= x(3) spx= x(4) sux= x(5) sfx= x(6) twx= x(7) t1x= x(8) else if(itcc.eq.3) then uvx= x(1) vvx= x(2) smx= x(3) spx= x(4) sux= x(5) sdx= x(6) twx= x(7) t1x= x(8) endif else uvx= x(1) vvx= x(2) smx= x(3) sux= x(4) sdx= x(5) sfx= x(6) twx= x(7) t1x= x(8) endif else if(ndim.eq.7) then smx= x(1) spx= x(2) sux= x(3) sdx= x(4) sfx= x(5) twx= x(6) t1x= x(7) else if(ndim.eq.9) then uvx= x(1) vvx= x(2) smx= x(3) spx= x(4) sux= x(5) sdx= x(6) sfx= x(7) twx= x(8) t1x= x(9) endif * ik= ik+1 rs= ars one= 1.d0 * *-----if a point is not allowed then the * result is set to zeron * iz= 1 * if(ndim.eq.6.or.ndim.eq.7) then ueps= 0.d0 uv= 1.d0 uvs= uv*uv ujc= 1.d0 veps= 0.d0 vv= 1.d0 vjc= 1.d0 else if(ndim.eq.8.or.ndim.eq.9) then * *-----independent invariants are initialized * first u and v variable * ueps= omul*(1.d0-uvx)**hbeti uv= 1.d0-ueps ujc= omul**hbet uvs= uv*uv * *-----limits for v * *-----from equal cuts on SA * if(iac(3).eq.1.and.isab.eq.1) then vvl4= ombsa(1)/opbsa(1)*uvs vvl= dmax1(vvl1,vvl2,vvl3,vvl4) else vvl= dmax1(vvl1,vvl2,vvl3) endif * *-----from E * vve= uv*(2.d0*suml-uv) vvll= dmax1(vvl,vve) * vvu1= uv if(iac(3).eq.1.and.isaa.eq.1) then vvu2= omasa(1)/opasa(1)*uvs vvu= dmin1(vvu1,vvu2) else vvu= uv endif uvl= uv-vvll * vkf= (uv-vvu)/uvl if(vkf.eq.0.d0) then veps= uvl*(1.d0-vvx)**hbeti else veps= uvl*(1.d0-(1.d0-vkf**hbet)*vvx)**hbeti endif vv= uv-veps avkf= 1.d0-vkf**hbet vjc= (1.d0-vvll/uv)**hbet*avkf endif * svv= sqrt(vv) vwmg= rwmg*vv vvs= vv*vv xm= uv xp= vv/uv xmop= xm/xp if(ndim.eq.7.or.ndim.eq.6) then xdf= 0.d0 else xdf= (ueps*(1.d0-ueps)-veps)/uv endif xdfs= xdf*xdf sh= vv*s * *-----Z parameters * rszm2= zm*zm/sh * *-----Z propagator (real part and imaginary part) * dz0= 1.d0-rszm2 dz= dz0*dz0+rszw2 rsz= dz0/dz omrz= (-rszm2*dz0+rszw2)/dz aisz= -rszw/dz haisz= scth2*aisz * *-----Reduced structure functions are computed with arguments xp,xmd * opxp= 1.d0+xp opxm= 1.d0+xm omxp= veps/uv omxm= ueps if(isf.eq.0) then stfp= 1.d0 stfm= 1.d0 else if(isf.gt.0) then if(omxp.eq.0) then stfp= d0gl else rcpx= 0.25d0*opxp*opxp rcpy= xp iflp= 1 rclp= s21baf(rcpx,rcpy,iflp) stfp= d0gl+eob*omxp**omhb*(-0.5d0*opxp+ # feta*(-4.d0*opxp*log(omxp)+ # 3.d0*opxp*log(xp)+4.d0*rclp-5.d0-xp)) endif if(omxm.eq.0) then stfm= d0gl else rcmx= 0.25d0*opxm*opxm rcmy= xm iflm= 1 rclm= s21baf(rcmx,rcmy,iflm) stfm= d0gl+eob*omxm**omhb*(-0.5d0*opxm+ # feta*(-4.d0*opxm*log(omxm)+ # 3.d0*opxm*log(xm)+4.d0*rclm-5.d0-xm)) endif endif * stf= stfp*stfm * *-----if there is no upper cut on some FS IM, then the maximum is allowed * do j=1,6 if(rr(j).eq.1.d0) then rrr(j)= rr(j) else rrr(j)= rr(j)/vv endif rrl(j)= rl(j)/vv srrl(j)= srl(j)/svv enddo * *-----cuts become special near xp = xm * if(abs(xdf).gt.1.d-15) then ieq= 1 bxe= vv/(ueps*(1.d0-ueps)-veps) if(xdf.gt.0.d0) then enc= 1.d0 else if(xdf.lt.0.d0) then enc= xmop endif else ieq= 0 bxe= 1.d0 endif if(ieq.eq.0.and.xm.le.teq) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif * if(ieq.eq.0.and.iac(2).ne.0.and.iac(4).ne.0) then sct12= sct120/vv sct13= sct130/vv sct14= sct140/vv sct23= sct230/vv sct24= sct240/vv sct34= sct340/vv else sct12= 0.d0 sct13= 0.d0 sct14= 0.d0 sct23= 0.d0 sct24= 0.d0 sct34= 0.d0 endif * *-----cuts on E * do j=1,4 if(ieq.eq.1) then bl(j)= 2.d0*rae(j)/xdf xbl(j)= 2.d0*rae(j)/xp else if(ieq.eq.0) then bl(j)= 2.d0*rae(j)/xm endif enddo * *-----cuts on SA * if(iac(3).ne.0) then do j=1,4 if(sgam(j).eq.1.d0) then ss(j)= 0.d0 else ss(j)= 1.d0+sgam(j)/(1.d0-sgam(j))*xmop ss(j)= 1.d0/ss(j) endif if(cgam(j).eq.0.d0) then cs(j)= 1.d0 else cs(j)= 1.d0+cgam(j)/(1.d0-cgam(j))*xmop cs(j)= 1.d0/cs(j) endif enddo endif * * *-----initialization of sm = m_-^2 * zma1= dsm zma2= vv*sct12 zmb1= usm zmb2= (svv-sdsp)*(svv-sdsp) zmb3= vv*(1.d0-sqrt(sct34))*(1.d0-sqrt(sct34)) if(ieq.eq.0) then zma3= vv*(bl(1)+bl(2)-1.d0) zmb4= vv*(1.d0-0.5d0*(bl(3)+bl(4)))* # (1.d0-0.5d0*(bl(3)+bl(4))) zmb5= vv*(1.d0-bl(3)) zmb6= vv*(1.d0-bl(4)) else if(ieq.eq.1) then zma3= vv*(-enc+xbl(1)+xbl(2)) zmb4= 0.25d0*vv*(1.d0+enc-xbl(3)-xbl(4))* # (1.d0+enc-xbl(3)-xbl(4)) zmb5= vv*(enc-xbl(3)) zmb6= vv*(enc-xbl(4)) endif xzma= dmax1(zma1,zma2,zma3) xzmb= dmin1(zmb1,zmb2,zmb3,zmb4,zmb5,zmb6) * *-----limits on sm from cuts on SA. Here for maximum security. Rare * if(iac(3).eq.0) then zma= xzma zmb= xzmb else if(ss(4).eq.ss(3).and.ss(2).eq.ss(1)) then if(ss(3).eq.ss(1)) then szma= xzma szmb= xzmb else if(ss(3).gt.ss(1)) then szmb= xzmb adsp= dsp/vv axszma= dmax1(adsp,sct34) axszma= vv*(axszma-(1.d0-ss(1)-ss(3))/ # (ss(3)-ss(1))) szma= dmax1(axszma,xzma) else if(ss(3).lt.ss(1)) then if(ss(3).lt.0.5d0) then szma= xzma axszmb= vv*((ss(3)-0.5d0)/(ss(3)-ss(1)))**2 szmb= dmin1(axszmb,xzmb) else iz= 0 ifz(2)= ifz(2)+1 go to 1 endif endif else szma= xzma szmb= xzmb endif if(cs(4).eq.cs(3).and.cs(2).eq.cs(1)) then if(cs(3).eq.cs(1)) then zma= szma zmb= szmb else if(cs(3).gt.cs(1)) then if(cs(3).gt.0.5d0) then zma= szma axczmb= vv*((cs(3)-0.5d0)/(cs(3)-cs(1)))**2 zmb= dmin1(axczmb,szmb) else iz= 0 ifz(3)= ifz(3)+1 go to 1 endif else if(cs(3).lt.cs(1)) then zmb= szmb adsp= dsp/vv axczma= dmax1(adsp,sct34) axczma= vv*(axczma-(1.d0-cs(1)-cs(3))/ # (cs(3)-cs(1))) zma= dmax1(axczma,szma) endif else zma= szma zmb= szmb endif endif * if((itc.eq.1.and.itcc.eq.1).or.(itc.eq.2)) then dzpa= dmax1(dsp,sct340) if(itc.eq.1) then dzmb= (dist/rs-sqrt(dzpa))*(dist/rs-sqrt(dzpa)) zmb= dmin1(zmb,dzmb) else if(itc.eq.2) then dzma= (dist/rs+sqrt(dzpa))*(dist/rs+sqrt(dzpa)) zma= dmax1(zma,dzma) dzmb= 0.25d0*(svv+dist/rs)*(svv+dist/rs) zmb= dmin1(zmb,dzmb) endif endif if(itc.eq.1.and.itcc.eq.3) then zmbd3= vv-0.5d0*dist*dist/s zmb= dmin1(zmb,zmbd3) endif * *-----test on sm * if(zmb.le.zma) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif * if(opeak.eq.'y') then zmas= zma-rwm2 zmbs= zmb-rwm2 atma= (zmas+swgs*zma)/rwmg atmb= (zmbs+swgs*zmb)/rwmg if(atma.gt.1.d0.and.atmb.gt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/vwmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/vwmg smjc0= (-atmb+atma)/vwmg else if(atma.gt.1.d0.and.atmb.lt.-1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/vwmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/vwmg smjc0= (-pi+atmb+atma)/vwmg else if(atma.gt.1.d0.and.abs(atmb).lt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/vwmg atmb= atan(atmb) zmbt= atmb/vwmg smjc0= (-pih+atmb+atma)/vwmg else if(atma.lt.-1.d0.and.atmb.gt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/vwmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/vwmg smjc0= (pi-atmb-atma)/vwmg else if(atma.lt.-1.d0.and.atmb.lt.-1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/vwmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/vwmg smjc0= (atmb-atma)/vwmg else if(atma.lt.-1.d0.and.abs(atmb).lt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/vwmg atmb= atan(atmb) zmbt= atmb/vwmg smjc0= (pih+atmb-atma)/vwmg else if(abs(atma).lt.1.d0.and.atmb.gt.1.d0) then atma= atan(atma) zmat= atma/vwmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/vwmg smjc0= (pih-atmb-atma)/vwmg else if(abs(atma).lt.1.d0.and.atmb.lt.-1.d0) then atma= atan(atma) zmat= atma/vwmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/vwmg smjc0= (-pih+atmb-atma)/vwmg else if(abs(atma).lt.1.d0.and.abs(atmb).lt.1.d0) then atma= atan(atma) zmat= atma/vwmg atmb= atan(atmb) zmbt= atmb/vwmg smjc0= (atmb-atma)/vwmg endif * zmv= smjc0*smx+zmat iftn= 1 atnm= vwmg*zmv sm= s0w/vv*(1.d0+swg*s07aaf(atnm,iftn)) if(iftn.ne.0) print 300 pmjac= 1.d0 smjc= vv*smjc0 * else if(opeak.eq.'n') then smjc0= zmb-zma sm= (smjc0*smx+zma)/vv pmjac= 1.d0/((vv*sm-rwm2)**2+(vv*sm*swg)**2) smjc= smjc0 endif if(sm.lt.0.d0) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif ssm= sqrt(sm) * 300 format(/' Unsuccesful call to S07AAF ') * *-----initialization of sp = m_+^2 * zpa1= dsp zpb1= usp zpb2= vv*(1.d0-ssm)*(1.d0-ssm) * *-----limits on sp from cuts on SA. Here for maximum security. Rare * if(iac(3).eq.0) then zpb= dmin1(zpb1,zpb2) zpa= zpa1 else if(ss(4).eq.ss(3).and.ss(2).eq.ss(1)) then if(ss(3).eq.ss(1)) then azpb= dmin1(zpb1,zpb2) azpa= zpa1 else if(ss(3).gt.ss(1)) then zpb3= vv*(sm+(1.d0-ss(1)-ss(3))/(ss(3)-ss(1))) azpb= dmin1(zpb1,zpb2,zpb3) azpa= zpa1 else if(ss(3).lt.ss(1)) then azpb= dmin1(zpb1,zpb2) zpa2= vv*(sm+(1.d0-ss(1)-ss(3))/(ss(3)-ss(1))) azpa= dmax1(zpa1,zpa2) endif else azpa= zpa1 azpb= dmin1(zpb1,zpb2) endif if(cs(4).eq.cs(3).and.cs(2).eq.cs(1)) then if(cs(3).eq.cs(1)) then zpa= azpa zpb= azpb else if(cs(3).gt.cs(1)) then zpb= azpb bzpa= vv*(sm+(1.d0-cs(1)-cs(3))/(cs(3)-cs(1))) zpa= dmax1(azpa,bzpa) else if(cs(3).lt.cs(1)) then zpa= azpa bzpb= vv*(sm+(1.d0-cs(1)-cs(3))/(cs(3)-cs(1))) zpb= dmin1(azpb,bzpb) endif else zpa= azpa zpb= azpb endif endif * if(ieq.eq.0) then zpel= vv*(-1.d0+bl(3)+bl(4)+sm) zpeu1= vv*(1.d0-bl(1)-bl(2)+sm) zpeu2= vv*(1.d0-bl(1)) zpeu3= vv*(1.d0-bl(2)) else if(ieq.eq.1) then zpel= vv*(sm-enc+xbl(3)+xbl(4)) zpeu1= vv*(sm+enc-xbl(1)-xbl(2)) zpeu2= vv*(enc-xbl(1)) zpeu3= vv*(enc-xbl(2)) endif zpa= dmax1(zpa,zpel) zpb= dmin1(zpb,zpeu1,zpeu2,zpeu3) zpap= vv*sct34 zpa= dmax1(zpa,zpap) if(itc.eq.1.and.itcc.eq.3) then zpbd3= vv*(1.d0-sm)-0.5d0*dist*dist/s zpb= dmin1(zpb,zpbd3) endif * *-----test on sp * if(zpb.le.zpa) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif * if((itc.eq.1.and.itcc.eq.1).or.(itc.eq.2)) then bdistl= (dist/rs-svv*ssm)*(dist/rs-svv*ssm)-zpa bdistu= zpb-(dist/rs-svv*ssm)*(dist/rs-svv*ssm) if(bdistl.le.0.d0.or.bdistu.le.0.d0) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif endif * if((itc.eq.1.and.itcc.eq.1).or.(itc.eq.2)) then sp= (dist/rs/svv-ssm)*(dist/rs/svv-ssm) ppjac= 2.d0*abs((dist/rs-svv*ssm))/ars/ # ((vv*sp-rwm2)**2+(vv*sp*swg)**2) spjc= 1.d0 else * if(opeak.eq.'y') then zpas= zpa-rwm2 zpbs= zpb-rwm2 atpa= (zpas+swgs*zpa)/rwmg atpb= (zpbs+swgs*zpb)/rwmg if(atpa.gt.1.d0.and.atpb.gt.1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/vwmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/vwmg spjc0= (-atpb+atpa)/vwmg else if(atpa.gt.1.d0.and.atpb.lt.-1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/vwmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/vwmg spjc0= (-pi+atpb+atpa)/vwmg else if(atpa.gt.1.d0.and.abs(atpb).lt.1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/vwmg atpb= atan(atpb) zpbt= atpb/vwmg spjc0= (-pih+atpb+atpa)/vwmg else if(atpa.lt.-1.d0.and.atpb.gt.1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/vwmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/vwmg spjc0= (pi-atpb-atpa)/vwmg else if(atpa.lt.-1.d0.and.atpb.lt.-1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/vwmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/vwmg spjc0= (atpb-atpa)/vwmg else if(atpa.lt.-1.d0.and.abs(atpb).lt.1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/vwmg atpb= atan(atpb) zpbt= atpb/vwmg spjc0= (pih+atpb-atpa)/vwmg else if(abs(atpa).lt.1.d0.and.atpb.gt.1.d0) then atpa= atan(atpa) zpat= atpa/vwmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/vwmg spjc0= (pih-atpb-atpa)/vwmg else if(abs(atpa).lt.1.d0.and.atpb.lt.-1.d0) then atpa= atan(atpa) zpat= atpa/vwmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/vwmg spjc0= (-pih+atpb-atpa)/vwmg else if(abs(atpa).lt.1.d0.and.abs(atpb).lt.1.d0) then atpa= atan(atpa) zpat= atpa/vwmg atpb= atan(atpb) zpbt= atpb/vwmg spjc0= (atpb-atpa)/vwmg endif * zpv= spjc0*spx+zpat iftn= 1 atnp= vwmg*zpv sp= rwm2/opszgs/vv*(1.d0+swg*s07aaf(atnp,iftn)) if(iftn.ne.0) print 300 ppjac= 1.d0 spjc= vv*spjc0 * else if(opeak.eq.'n') then spjc0= zpb-zpa sp= (spjc0*spx+zpa)/vv ppjac= 1.d0/((vv*sp-rwm2)**2+(vv*sp*swg)**2) spjc= spjc0 endif endif * if(sp.lt.0.d0) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif ssp= sqrt(sp) spmm= sp-sm smmp= sm-sp * cbw= -1.d0+sp-sm ifcr= 0 call c02ajf(one,cbw,sm,bt1,bt2,ifcr) if(bt1(2).ne.0.d0) then iz= 0 ifz(6)= ifz(6)+1 go to 1 endif * *-----Coul factors * if(ocoul.eq.'y') then betb= 1.d0-2.d0*(sp+sm)+(sp-sm)*(sp-sm) if(betb.le.0.d0) then iz= 0 ifz(7)= ifz(7)+1 go to 1 endif betb= sqrt(betb) bdel= abs(sp-sm) bmsr= 1.d0-4.d0*rwm2/vv bmsi= 4.d0*rwm*rwg/vv+1.d-20 abm= sqrt(bmsr*bmsr+bmsi*bmsi) bmr= sqrt(0.5d0*(abm+bmsr)) bmi= 0.5d0*bmsi/bmr acoulf= (bmr+bdel)*(bmr+bdel)+bmi*bmi-betb*betb acoulf= 0.5d0*acoulf/betb/bmi acoulf= atan(acoulf) coulf= 0.5d0*alpha*pi/betb*(1.d0-2.d0/pi*acoulf) else coulf= 0.d0 endif ssmpp= ssm+ssp ssmmp= ssm-ssp asup= 1.d0-ssmpp*ssmpp asum= 1.d0-ssmmp*ssmmp if(asup.lt.0.d0.or.asum.lt.0.d0) then iz= 0 ifz(8)= ifz(8)+1 go to 1 endif rasup= sqrt(asup) rasum= sqrt(asum) * *-----initialization of su = M_0^2 * *-----limits on su from cuts on FS IM * sulim= rrl(4) suuim1= rrr(4) suuim2= (1.d0-srrl(3))*(1.d0-srrl(3)) suuim= dmin1(suuim1,suuim2) * *-----limits on su from Delta_- > 0 (as derived from consistency * on sd limits) * suud1= 0.25d0*(rasup+rasum)*(rasup+rasum) suud2= 0.25d0*(1.d0+rasup)*(1.d0+rasup) * sul= sulim sul= dmax1(sul,sct23) if(ieq.eq.0) then sul1= bl(2)+bl(3)-1.d0 suu1= 1.d0-sp-bl(1) suu2= 1.d0-sm-bl(4) suu3= (1.d0-0.5d0*(bl(1)+bl(4)))* # (1.d0-0.5d0*(bl(1)+bl(4))) else if(ieq.eq.1) then sul1= xbl(2)+xbl(3)+1.d0-2.d0*enc suu1= enc-sp-xbl(1) suu2= enc-sm-xbl(4) suu3= (enc-0.5d0*(xbl(1)+xbl(4)))* # (enc-0.5d0*(xbl(1)+xbl(4))) endif sul= dmax1(sul,sul1) suu= dmin1(suuim,suud1,suud2,suu1,suu2,suu3) * sdlim= rrl(3) if(itc.eq.1.and.itcc.eq.2) then dsdl= dmax1(sdlim,sct140) dsuu= (dist/svv/rs-sqrt(dsdl))*(dist/svv/rs-sqrt(dsdl)) suu= dmin1(suu,dsuu) endif if(itc.eq.1.and.itcc.eq.3) then suud3= 1.d0-sm-sp-0.5d0*dist*dist/vv/s suu= dmin1(suu,suud3) endif * *-----test on su * if(suu.le.sul) then iz= 0 ifz(9)= ifz(9)+1 go to 1 endif * sujc= suu-sul su= sujc*sux+sul if(su.lt.0.d0) then iz= 0 ifz(9)= ifz(9)+1 go to 1 endif ssu= sqrt(su) * *-----initialization of sd = m_0^2 * *-----limits on sd from cuts on FS IM * sdlim= rrl(3) sduim1= rrr(3) sduim2= (1.d0-ssu)*(1.d0-ssu) sduim= dmin1(sduim1,sduim2) * *-----limits on sd from Delta_- > 0 * if(ssu.gt.rasup) then sdld= (ssu-rasup)*(ssu-rasup) else sdld= sdlim endif sdud1= (ssu+rasup)*(ssu+rasup) sdud2= (-ssu+rasum)*(-ssu+rasum) sdud= dmin1(sdud1,sdud2) * *-----limits on sd from cuts on SA. Here for maximum security. Rare * if(iac(3).ne.0.and.ss(4).eq.ss(1).and.ss(3).eq.ss(2)) then if(ss(2).eq.ss(1)) then asdu= dmin1(sduim,sdud) asdl= dmax1(sdlim,sdld) else if(ss(1).gt.ss(2)) then sdusa= su+(1.d0-ss(1)-ss(2))/(ss(1)-ss(2)) asdu= dmin1(sduim,sdud,sdusa) asdl= dmax1(sdlim,sdld) else if(ss(1).lt.ss(2)) then asdu= dmin1(sduim,sdud) sdlsa= su+(1.d0-ss(1)-ss(2))/(ss(1)-ss(2)) asdl= dmax1(sdlim,sdld,sdlsa) endif else asdu= dmin1(sduim,sdud) asdl= dmax1(sdlim,sdld) endif if(iac(3).ne.0.and.cs(4).eq.cs(1).and.cs(3).eq.cs(2)) then if(cs(2).eq.cs(1)) then sdl= asdl sdu= asdu else if(cs(1).gt.cs(2)) then sdu= asdu sdlsb= su+(1.d0-cs(1)-cs(2))/(cs(1)-cs(2)) sdl= dmax1(asdl,sdlsb) else if(cs(1).lt.cs(2)) then sdl= asdl sdusb= su+(1.d0-cs(1)-cs(2))/(cs(1)-cs(2)) sdu= dmin1(asdu,sdusb) endif else sdl= asdl sdu= asdu endif if(ieq.eq.0) then sdenl= -1.d0+bl(1)+bl(4)+su sdenu1= 1.d0-sp-bl(2) sdenu2= 1.d0-sm-bl(3) sdenu3= 1.d0-bl(2)-bl(3)+su else if(ieq.eq.1) then sdenl= su+1.d0-2.d0*enc+xbl(1)+xbl(4) sdenu1= enc-sp-xbl(2) sdenu2= enc-sm-xbl(3) sdenu3= su-1.d0+2.d0*enc-xbl(2)-xbl(3) endif sdl= dmax1(sdl,sdenl) sdu= dmin1(sdu,sdenu1,sdenu2,sdenu3) sdl= dmax1(sdl,sct14) if(itc.eq.1.and.itcc.eq.3) then sdld3= 1.d0-sm-sp-su-dist*dist/vv/s sdl= dmax1(sdl,sdld3) sdud3= 1.d0-sm-sp-su-0.5d0*dist*dist/vv/s sdu= dmin1(sdu,sdud3) endif * *-----test on sd * if(sdu.le.sdl) then iz= 0 ifz(10)= ifz(10)+1 go to 1 endif * if(itc.eq.1.and.itcc.eq.2) then bdistl= (dist/rs-svv*ssu)*(dist/rs-svv*ssu)-vv*sdl bdistu= vv*sdu-(dist/rs-svv*ssu)*(dist/rs-svv*ssu) if(bdistl.le.0.d0.or.bdistu.le.0.d0) then iz= 0 ifz(10)= ifz(10)+1 go to 1 endif endif * if(itc.eq.1.and.itcc.eq.2) then sd= (dist/rs/svv-ssu)*(dist/rs/svv-ssu) sdjc= 2.d0*abs((dist/rs-svv*ssu))/vv/ars else sdjc= sdu-sdl sd= sdjc*sdx+sdl endif if(sd.lt.0.d0) then iz= 0 ifz(10)= ifz(10)+1 go to 1 endif ssd= sqrt(sd) sdmu= sd-su sdmus= (1.d0+sdmu)*(1.d0+sdmu) * if(oqcd.eq.'y') then if(iqcd.eq.1) then qcdjn= (1.d0+0.5d0*alsz/pi*(fcuc-1.d0))* # (1.d0+0.5d0*alsz/pi*(fcdc-1.d0))-1.d0 else if(iqcd.eq.2) then nf= 5 scalu= sqrt(vv)*ssu*ars scald= sqrt(vv)*ssd*ars alsu= wtorals(qcdl,scalu,nf) alsd= wtorals(qcdl,scald,nf) qcdjn= (1.d0+0.5d0*alsu/pi*(fcuc-1.d0))* # (1.d0+0.5d0*alsd/pi*(fcdc-1.d0))-1.d0 else qcdjn= 0.d0 endif else qcdjn= 0.d0 endif * *-----initialization of sf = m^2 * *-----limits on sf from cuts on FS IM * sflim1= rrl(2) sfuim1= rrr(2) bsg= sm+sp+su+sd ombsg= 1.d0-bsg sflim2= ombsg-rrr(5) sfuim2= ombsg-rrl(5) sflim= dmax1(sflim1,sflim2) sfuim= dmin1(sfuim1,sfuim2) * *-----limits on sf from cuts on SA * tcuts= ss(1)-ss(2)+ss(3)-ss(4) tcutc= cs(1)-cs(2)+cs(3)-cs(4) if(iac(3).ne.0.and.tcuts.ne.0.d0.and.tcutc.ne.0.d0) then if(tcuts.gt.0.d0.and.tcutc.gt.0.d0) then sflsa= (1.d0-cs(2)-cs(4)-(cs(1)-cs(2))*sd- # (cs(3)-cs(4))*su-(cs(3)-cs(2))*sp- # (cs(1)-cs(4))*sm)/tcutc sfusa= (1.d0-ss(2)-ss(4)-(ss(1)-ss(2))*sd- # (ss(3)-ss(4))*su-(ss(3)-ss(2))*sp- # (ss(1)-ss(4))*sm)/tcuts asfl= dmax1(sflim,sflsa) asfu= dmin1(sfuim,sfusa) else if(tcuts.gt.0.d0.and.tcutc.lt.0.d0) then sfusa= (1.d0-ss(2)-ss(4)-(ss(1)-ss(2))*sd- # (ss(3)-ss(4))*su-(ss(3)-ss(2))*sp- # (ss(1)-ss(4))*sm)/tcuts sfusb= (1.d0-cs(2)-cs(4)-(cs(1)-cs(2))*sd- # (cs(3)-cs(4))*su-(cs(3)-cs(2))*sp- # (cs(1)-cs(4))*sm)/tcutc asfu= dmax1(sfuim,sfusa,sfusb) asfl= sflim else if(tcuts.lt.0.d0.and.tcutc.gt.0.d0) then sflsa= (1.d0-ss(2)-ss(4)-(ss(1)-ss(2))*sd- # (ss(3)-ss(4))*su-(ss(3)-ss(2))*sp- # (ss(1)-ss(4))*sm)/tcuts sflsb= (1.d0-cs(2)-cs(4)-(cs(1)-cs(2))*sd- # (cs(3)-cs(4))*su-(cs(3)-cs(2))*sp- # (cs(1)-cs(4))*sm)/tcutc asfl= dmax1(sflim,sflsa,sflsb) asfu= sfuim else if(tcuts.lt.0.d0.and.tcutc.lt.0.d0) then sflsa= (1.d0-ss(2)-ss(4)-(ss(1)-ss(2))*sd- # (ss(3)-ss(4))*su-(ss(3)-ss(2))*sp- # (ss(1)-ss(4))*sm)/tcuts sfusa= (1.d0-cs(2)-cs(4)-(cs(1)-cs(2))*sd- # (cs(3)-cs(4))*su-(cs(3)-cs(2))*sp- # (cs(1)-cs(4))*sm)/tcutc asfl= dmax1(sflim,sflsa) asfu= dmin1(sfuim,sfusa) endif else asfl= sflim asfu= sfuim endif * if(ieq.eq.0) then asfenl1= bl(1)-sm-sd asfenl2= bl(3)-sp-su asfenu1= 1.d0-bl(2)-sp-sd asfenu2= 1.d0-bl(4)-sm-su else if(ieq.eq.1) then asfenl1= 1.d0-enc-sm-sd+xbl(1) asfenl2= 1.d0-enc-sp-su+xbl(3) asfenu1= enc-sp-sd-xbl(2) asfenu2= enc-sm-su-xbl(4) endif asfl= dmax1(asfl,asfenl1,asfenl2) asfu= dmin1(asfu,asfenu1,asfenu2) aasfu= 1.d0-sm-sp-su-sd-sct24 asfl= dmax1(asfl,sct13) asfu= dmin1(asfu,aasfu) * if(iac(3).ne.0) then if(ss(4).ne.ss(3)) then if(ss(4).gt.ss(3)) then asfltw= -(1.d0-ss(3)*sp-ss(3)*su+ss(4)*sm+ # ss(4)*su-ss(4)-bt1(1))/(ss(4)-ss(3)) asfl= dmax1(asfl,asfltw) else if (ss(4).lt.ss(3)) then asfutw= -(1.d0-ss(3)*sp-ss(3)*su+ss(4)*sm+ # ss(4)*su-ss(4)-bt1(1))/(ss(4)-ss(3)) asfu= dmin1(asfu,asfutw) endif endif if(cs(1).ne.cs(2)) then if(cs(1).gt.cs(2)) then bsfltw= -(cs(1)*sm+cs(1)*sd-cs(2)*sp-cs(2)*sd+ # cs(2)-bt1(1))/(cs(1)-cs(2)) asfl= dmax1(asfl,bsfltw) else if(cs(1).lt.cs(2)) then bsfutw= -(cs(1)*sm+cs(1)*sd-cs(2)*sp-cs(2)*sd+ # cs(2)-bt1(1))/(cs(1)-cs(2)) asfu= dmin1(asfu,bsfutw) endif endif if(cs(4).ne.cs(3)) then if(cs(4).gt.cs(3)) then csfutw= (bt2(1)-1.d0+cs(3)*sp+cs(3)*su-cs(4)*sm- # cs(4)*su+cs(4))/(cs(4)-cs(3)) asfu= dmin1(asfu,csfutw) else if(cs(4).lt.cs(3)) then csfltw= (bt2(1)-1.d0+cs(3)*sp+cs(3)*su-cs(4)*sm- # cs(4)*su+cs(4))/(cs(4)-cs(3)) asfl= dmax1(asfl,csfltw) endif endif if(ss(1).ne.ss(2)) then if(ss(1).gt.ss(2)) then dsfutw= (bt2(1)-ss(1)*sm-ss(1)*sd+ss(2)*sp+ # ss(2)*sd-ss(2))/(ss(1)-ss(2)) asfu= dmin1(asfu,dsfutw) else if(ss(1).lt.ss(2)) then dsfltw= (bt2(1)-ss(1)*sm-ss(1)*sd+ss(2)*sp+ # ss(2)*sd-ss(2))/(ss(1)-ss(2)) asfl= dmax1(asfl,dsfltw) endif endif endif * *-----positivity of R^2 * scp= ssmpp*ssmpp scm= ssmmp*ssmmp snp= (ssu+ssd)*(ssu+ssd) snm= (ssu-ssd)*(ssu-ssd) rlp= ssu*ssd+ssp*ssm rlm= ssu*ssd-ssp*ssm bsgmo= bsg-1.d0 ombsg2= ombsg*ombsg rlps= rlp*rlp rlms= rlm*rlm edelp= ombsg2-4.d0*rlps edelm= ombsg2-4.d0*rlms edeld= 16.d0*ssu*ssd*ssp*ssm * *-----first Delta_- > 0 > Delta_+ with Sigma > or < 1/2 * then Delta_+ > 0 * *-----control * cnt1= scp+snm cnt2= scm+snp if(cnt1.gt.1.d0.or.cnt2.gt.1.d0) then iz= 0 ifz(11)= ifz(11)+1 go to 1 endif if(edelm.le.0.d0) then etest= edeld+edelp if(etest.gt.0.d0) then edelm= etest else iz= 0 ifz(12)= ifz(12)+1 go to 1 endif endif sedm= sqrt(edelm) ifcr= 0 call c02ajf(one,bsgmo,rlms,rr1,rr2,ifcr) if(rr1(2).ne.0.d0) then iz= 0 ifz(13)= ifz(13)+1 go to 1 endif ifcr= 0 call c02ajf(one,bsgmo,rlps,rs1,rs2,ifcr) * cnt3= scp+snp cnt4= scm+snm cbru= -1.d0 ccru= 0.5d0*bsg * *-----R^2 has two real roots and two complex conjugate roots * if(cnt3.gt.1.d0.or.cnt4.gt.1.d0) then if(bsg.gt.0.5d0) then iel= 1 sflr(1)= rr1(1) sfur(1)= rr2(1) sflr(2)= rr1(1) sfur(2)= rr2(1) else iel= 2 ifcr= 0 call c02ajf(one,cbru,ccru,rru1,rru2,ifcr) ru1= rru1(1)*rru1(1) ru2= rru2(1)*rru2(1) sflr(1)= rr1(1) sflr(2)= ru2 sfur(1)= ru1 sfur(2)= rr2(1) endif * *-----R^2 has four real roots * else if(cnt3.lt.1.d0.and.cnt4.lt.1.d0) then if(bsg.gt.0.5d0) then sflr(1)= rr1(1) sflr(2)= rs2(1) sfur(1)= rs1(1) sfur(2)= rr2(1) else ifcr= 0 call c02ajf(one,cbru,ccru,rru1,rru2,ifcr) ru1= rru1(1)*rru1(1) ru2= rru2(1)*rru2(1) sflr(1)= rr1(1) sfur(1)= dmin1(rs1(1),ru1) sflr(2)= dmax1(rs2(1),ru2) sfur(2)= rr2(1) endif endif * *-----the loop for transforming sf starts here * if(om.eq.'g') then itmn= it0 itmx= it0 else itmn= 1 itmx= 2 endif do it=itmn,itmx if(sflr(it).ge.asfl) then sfl= sflr(it) else sfl= asfl endif if(sfur(it).le.asfu) then sfu= sfur(it) else sfu= asfu endif * *-----test on sf * if(sfu.le.sfl) then iz= 0 ifz(14)= ifz(14)+1 go to 2 endif * if(itc.eq.1.and.itcc.eq.3) then ittm= 2 else ittm= 1 endif * do itt=1,ittm * if(itc.eq.1.and.itcc.eq.3) then distm= dist/svv/rs sbdist= 2.d0*(1.d0-sm-sp-su-sd)-distm*distm if(sbdist.le.0.d0) then iz= 0 ifz(14)= ifz(14)+1 go to 5 endif if(itt.eq.1) then bdist= 0.25d0*(distm-sqrt(sbdist))* # (distm-sqrt(sbdist)) else if(itt.eq.2) then bdist= 0.25d0*(distm+sqrt(sbdist))* # (distm+sqrt(sbdist)) endif bdistl= bdist-sfl bdistu= sfu-bdist if(bdistl.le.0.d0.or.bdistu.le.0.d0) then iz= 0 ifz(14)= ifz(14)+1 go to 5 endif sf= bdist ssf= sqrt(sf) pfjc= 2.d0/vv/rs*ssf*(distm-ssf)/sqrt(sbdist) sfjc0= sf*sf+(sm+sp+su+sd-1.d0)*sf+su*sd+sm*sp sfjc= 4.d0*sm*sp*su*sd-sfjc0*sfjc0 if(sfjc.le.0.d0) then iz= 0 ifz(14)= ifz(14)+1 go to 5 else if(iel.eq.1) then sfjc= 0.5d0*pfjc/sqrt(sfjc) else if(iel.eq.2) then sfjc= pfjc/sqrt(sfjc) endif endif else * *-----transformation for jacobian, first Delta_+ < 0, then Delta_+ > 0 * if(cnt3.gt.1.d0.or.cnt4.gt.1.d0) then er= rs1(1) es= abs(rs1(2)) er1= rr1(1) er2= rr2(1) ek2= edelm/edeld ek= sqrt(ek2) dog= -2.d0/sqrt(edeld) ecpl= (ombsg-2.d0*sfl)/sedm ecpu= (ombsg-2.d0*sfu)/sedm eql= ecpl*ecpl equ= ecpu*ecpu omecpl= 2.d0*(sfl-er1)/sedm es2pl= omecpl*(2.d0-omecpl) erl= 1.d0-ek2*es2pl espl= sqrt(es2pl) opecpu= 2.d0*(er2-sfu)/sedm es2pu= opecpu*(2.d0-opecpu) espu= sqrt(es2pu) eru= 1.d0-ek2*es2pu if(eql.eq.1) then sflt= 0.d0 else ifel= 1 sflt= -dog*espl*s21bbf(eql,erl,one,ifel) if(ifel.ne.0) then iz= 0 ifz(15)= ifz(15)+1 go to 2 endif endif if(equ.eq.1.d0) then sfut= 0.d0 else ifel= 1 sfut= -dog*espu*s21bbf(equ,eru,one,ifel) if(ifel.ne.0) then iz= 0 ifz(16)= ifz(16)+1 go to 2 endif endif if(iel.eq.1) then if(sfu.le.er) then efac= 0.5d0 sft= (sfut-sflt)*sfx+sflt ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(17)= ifz(17)+1 go to 2 endif sf= 0.5d0*(ombsg-sedm*elcn) sfjc= efac*(sfut-sflt) else if(sfl.ge.er) then efac= 0.5d0 sft= (sflt-sfut)*sfx+sfut ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(18)= ifz(18)+1 go to 2 endif sf= 0.5d0*(ombsg+sedm*elcn) sfjc= efac*(sflt-sfut) else efac= 1.d0 qbar= 0.d0 rbar= 1.d0-ek2 ifel= 1 sfbar= -dog*s21bbf(qbar,rbar,one,ifel) if(ifel.ne.0) then iz= 0 ifz(19)= ifz(19)+1 go to 2 endif if(it.eq.1) then sft= (sfbar-sflt)*sfx+sflt ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(20)= ifz(20)+1 go to 2 endif sf= 0.5d0*(ombsg-sedm*elcn) sfjc= efac*(sfbar-sflt) else if(it.eq.2) then sft= (sfbar-sfut)*sfx+sfut ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(21)= ifz(21)+1 go to 2 endif sf= 0.5d0*(ombsg+sedm*elcn) sfjc= efac*(sfbar-sfut) endif endif else if(iel.eq.2) then efac= 1.d0 if(it.eq.1) then sft= (sfut-sflt)*sfx+sflt ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(22)= ifz(22)+1 go to 2 endif sf= 0.5d0*(ombsg-sedm*elcn) sfjc= efac*(sfut-sflt) else if(it.eq.2) then sft= (sflt-sfut)*sfx+sfut ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(23)= ifz(23)+1 go to 2 endif sf= 0.5d0*(ombsg+sedm*elcn) sfjc= efac*(sflt-sfut) endif endif else if(cnt3.lt.1.d0.and.cnt4.lt.1.d0) then if(edelp.le.0.d0) then iz= 0 ifz(24)= ifz(24)+1 go to 2 endif sedp= sqrt(edelp) efac= 1.d0 es1= rs1(1) es2= rs2(1) er1= rr1(1) er2= rr2(1) ssed= sedm+sedp ek= (sedm-sedp)/ssed ek2= ek*ek dog= 2.d0/ssed if(it.eq.1) then es2pl= (er1-sfl)/(sfl-er2)/ek es2pu= (er1-sfu)/(sfu-er2)/ek eql= 1.d0-es2pl equ= 1.d0-es2pu erl= 1.d0-ek2*es2pl eru= 1.d0-ek2*es2pu else if(it.eq.2) then es2pl= (sfl-es2)/(sfl-es1)/ek es2pu= (sfu-es2)/(sfu-es1)/ek eql= 1.d0-es2pl equ= 1.d0-es2pu erl= 1.d0-ek2*es2pl eru= 1.d0-ek2*es2pu endif if(eql.eq.1.d0) then sflt= 0.d0 else ifel= 1 sflt= 2.d0*dog*sqrt(es2pl)* # s21bbf(eql,erl,one,ifel) if(ifel.ne.0) then iz= 0 ifz(25)= ifz(25)+1 go to 2 endif endif if(equ.eq.1.d0) then sfut= 0.d0 else ifel= 1 if(equ.lt.0.d0.and.abs(equ).lt.1.d-12) then equ= 0.d0 endif sfut= 2.d0*dog*sqrt(es2pu)* # s21bbf(equ,eru,one,ifel) if(ifel.ne.0) then iz= 0 ifz(26)= ifz(26)+1 go to 2 endif endif sft= (sfut-sflt)*sfx+sflt ifel= 1 asf= 0.5d0/dog*sft call s21caf(asf,ek2,elsn,elcn,edn,ifel) elsn2= elsn*elsn if(ifel.ne.0) then iz= 0 ifz(27)= ifz(27)+1 go to 2 endif if(it.eq.1) then sf= (er1+ek*elsn2*er2)/(1.d0+ek*elsn2) else if(it.eq.2) then sf= (es2-ek*elsn2*es1)/(1.d0-ek*elsn2) endif sfjc= efac*(sfut-sflt) endif * endif * *-----auxiliary quantities * sdpf= sd+sf e3= sp+su+sf e4= 1.d0+spmm-e3 e3p4= 1.d0+spmm e1= sm+sdpf e2= 1.d0+smmp-e1 e1p2= 1.d0+smmp e1p3= e1+e3 e1m2= 2.d0*e1-1.d0+spmm ep12= xp*e1*e2 ep1= xp*e1 ep2= xp*e2 ep3= xp*e3 ep4= xp*e4 e1t2= e1*e2 e1t3= e1*e3 e1t4= e1*e4 e2t3= e2*e3 e2t4= e2*e4 e3t4= e3*e4 if((e1p3*e1p3-4.d0*sf).lt.0.d0) then iz= 0 ifz(28)= ifz(28)+1 go to 2 endif skl2= sqrt(e1p3*e1p3-4.d0*sf) if((sdmus-4.d0*sd).lt.0.d0) then iz= 0 ifz(29)= ifz(29)+1 go to 2 endif skl3= sdmus-4.d0*sd skl3= sqrt(skl3) * *-----initialization of t_w * *-----limits on tw from positivity and SA * twlp1= 0.d0 twlp2= smmp twlp3= spmm-1.d0 twlp= dmax1(twlp1,twlp2,twlp3) twup= 1.d0 * *-----limits on tw from cuts on SA * if(iac(3).ne.0) then skl2m= 0.5d0*(e1p3-skl2) skl2p= 0.5d0*(e1p3+skl2) skl3p= -0.5d0*(1.d0+sdmu-skl3) skl3m= -0.5d0*(1.d0+sdmu+skl3) twlsa1= 1.d0-cs(3)*e3-cs(4)*e4 twlsa2= ss(1)*e1+ss(2)*e2 twlsa3= 1.d0-cs(3)*e3-cs(4)*e4-skl3p+skl3m twlsa4= 1.d0-2.d0*cs(3)*e3+skl2m+skl3m twlsa5= 1.d0-2.d0*cs(4)*e4-skl2p-skl3p twlsa6= 1.d0-cs(3)*e3-cs(4)*e4-skl2p+skl2m twusa1= 1.d0-ss(3)*e3-ss(4)*e4 twusa2= cs(1)*e1+cs(2)*e2 twusa3= 1.d0-ss(3)*e3-ss(4)*e4+skl3p-skl3m twusa4= 1.d0-2.d0*ss(4)*e4-skl2m-skl3m twusa5= 1.d0-2.d0*ss(3)*e3+skl2p+skl3p twusa6= 1.d0-ss(3)*e3-ss(4)*e4+skl2p-skl2m atwl= dmax1(twlp,twlsa1,twlsa2,twlsa3,twlsa4, # twlsa5,twlsa6) atwu= dmin1(twup,twusa1,twusa2,twusa3,twusa4, # twusa5,twusa6) else atwl= twlp atwu= twup endif * *-----limits on tw from E * if(ieq.eq.1) then atwle= 1.d0-bxe*e3p4+bl(3)+bl(4) atwue= bxe*e1p2-bl(1)-bl(2) if(xdf.gt.0.d0) then twle= atwle twue= atwue else if(xdf.lt.0.d0) then atwle1= bxe*e1-bl(1) atwle2= bxe*e2-bl(2) atwue1= 1.d0-bxe*e3+bl(3) atwue2= 1.d0-bxe*e4+bl(4) twle= dmax1(atwue,atwle1,atwle2) twue= dmin1(atwle,atwue1,atwue2) endif atwl= dmax1(atwl,twle) atwu= dmin1(atwu,twue) endif * *-----natural limits on tw * atwl= dmax1(atwl,bt1(1)) atwu= dmin1(atwu,bt2(1)) * *-----test on tw * twjc= atwu-atwl tw= twjc*twx+atwl pn= tw+sp-1.d0 omtw= 1.d0-tw * *-----initialization of t1 * *-----limits on t1 from positivity+SA * t1lp1= 0.d0 t1lp2= pn+sdpf t1up1= tw t1up2= sm+sdpf t1lp= dmax1(t1lp1,t1lp2) t1up= dmin1(t1up1,t1up2) * *-----limits on t1 from cuts on SA * if(iac(3).ne.0) then t1lc1= ss(1)*e1 t1lc2= tw-cs(2)*e2 t1lc3= ss(3)*e3-(omtw-0.5d0*(1.d0+sdmu-skl3)) t1lc4= -cs(4)*e4+0.5d0*(1.d0+sdmu-skl3) t1lc5= 0.5d0*(e1p3-skl2)-cs(3)*e3 t1lc6= 0.5d0*(e1p3-skl2)-omtw+ss(4)*e4 t1uc1= cs(1)*e1 t1uc2= tw-ss(2)*e2 t1uc3= cs(3)*e3-(omtw-0.5d0*(1.d0+sdmu+skl3)) t1uc4= -ss(4)*e4+0.5d0*(1.d0+sdmu+skl3) t1uc5= 0.5d0*(e1p3+skl2)-ss(3)*e3 t1uc6= 0.5d0*(e1p3+skl2)-omtw+cs(4)*e4 t1lc= dmax1(t1lc1,t1lc2,t1lc3,t1lc4,t1lc5,t1lc6) t1uc= dmin1(t1uc1,t1uc2,t1uc3,t1uc4,t1uc5,t1uc6) at1l= dmax1(t1lp,t1lc) at1u= dmin1(t1up,t1uc) else at1l= t1lp at1u= t1up endif * *-----limits on t1 from E * if(ieq.eq.1) then at1le= tw-bxe*e2+bl(2) at1ue= bxe*e1-bl(1) if(xdf.gt.0.d0) then t1le= at1le t1ue= at1ue else t1le= at1ue t1ue= at1le endif at1l= dmax1(at1l,t1le) at1u= dmin1(at1u,t1ue) endif * *-----positivity of (R')^2 / reality of roots for t3 * rp0= e1p2*e1p2-4.d0*sm if(rp0.lt.0.d0) then iz= 0 ifz(30)= ifz(30)+1 go to 2 endif srp0= sqrt(rp0) rp0e= -rp0 rp1= (e1*e1p2-2.d0*sm)*tw-sm*e1m2 rp1e= 2.d0*rp1 rp2= -(e1*tw-sm)*(e1*tw-sm) if(rp0e.eq.0.d0) then iz= 0 ifz(31)= ifz(31)+1 go to 2 endif ifct= 0 if(rp0e.ne.0.d0) then call c02ajf(rp0e,rp1e,rp2,ret1,ret2,ifct) rpds= 0.5d0*rp0*(ret2(1)-ret1(1)) t1l= dmax1(at1l,ret1(1)) t1u= dmin1(at1u,ret2(1)) else if(rp0e.eq.0.d0) then sret1= -rp2/rp1e if(rp1e.gt.0.d0) then t1l= dmax1(at1l,sret1) t1u= at1u else if(rp1e.lt.0.d0) then t1l= at1l t1u= dmin1(at1u,sret1) endif endif * *-----test on t1 * if(t1u.le.t1l) then iz= 01 ifz(31)= ifz(31)+1 go to 2 endif * *-----transformation for jacobian * if(rp0e.eq.0.d0) then taul= 2.d0/rp1e*sqrt(rp1e*t1l+rp2) taut= 2.d0/rp1e*sqrt(rp1e*t1u+rp2) t1jc= taut-taul t1= 0.25d0*rp1e*(t1jc*t1x+taul)**2-rp2/rp1e endif if(ret1(1).eq.t1l) then at1tl= -pih/srp0 else bt1tl= 1.d0+rp0/rpds*(ret1(1)-t1l) ifas= 1 at1tl= -s09aaf(bt1tl,ifas)/srp0 if(ifas.ne.0) print 200 endif if(ret2(1).eq.t1u) then at1tu= pih/srp0 else bt1tu= -1.d0+rp0/rpds*(ret2(1)-t1u) ifas= 1 at1tu= -s09aaf(bt1tu,ifas)/srp0 if(ifas.ne.0) print 200 endif if((at1tl+at1tu).eq.0.d0) then if(t1x.lt.1.d-3) then arc= pi*t1x arc2= arc*arc exc= arc2*(ec2+arc2*(ec4+arc2*(ec6+ # arc2*(ec8+arc2*ec10)))) t1= ret1(1)+0.5d0*(ret1(1)-ret2(1))*exc else if((1.d0-t1x).lt.1.d-3) then arc= pi*(1.d0-t1x) arc2= arc*arc exc= arc2*(ec2+arc2*(ec4+arc2*(ec6+ # arc2*(ec8+arc2*ec10)))) t1= ret2(1)-0.5d0*(ret1(1)-ret2(1))*exc else carc= cos(pi*t1x) t1= 0.5d0*(ret1(1)+ret2(1))+ # 0.5d0*(ret1(1)-ret2(1))*carc endif t1jc= pi/srp0 else t1tl= dmin1(at1tl,at1tu) t1tu= dmax1(at1tl,at1tu) t1jc= t1tu-t1tl t1t= t1jc*t1x+t1tl t1= (rp1+rpds*sin(srp0*t1t))/rp0 endif t1s= t1*t1 * 200 format(' Unsuccesful call to S09AAF ') * *-----test on t1 from FS A * if(ieq.eq.1.and.iac(4).ne.0.d0) then cnlct1= xp*(xm*sm-ep12*cg12)+xdf* # ep1*cg12*tw+xdf*cg12*t1*(ep2-ep1- # xdf*tw)+xdfs*cg12*t1s cnlst1= xp*(ep12*sg12-xm*sm)-xdf* # ep1*sg12*tw+xdf*sg12*t1*(ep1-ep2+ # xdf*tw)-xdfs*sg12*t1s if(cnlct1.lt.0.d0) then iz= 0 ifz(32)= ifz(32)+1 go to 2 else if(cnlst1.lt.0.d0) then iz= 0 ifz(33)= ifz(33)+1 go to 2 endif endif * *-----some vector components * t2= tw-t1 * *-----equation for xi is solved * e1s= e1*e1 e2s= e2*e2 e3s= e3*e3 e12= e1t2-2.d0*sm e13= e1t3-2.d0*sf e23= e2t3-2.d0*su e12s= e12*e12 e13s= e13*e13 e23s= e23*e23 xia= e1s*e2s-e12s xib= 2.d0*t1*(e2s*e13-e12*e23)+2.d0*t2*(e1s*e23- # e12*e13)-e1*e2s*e13+e1*e12*e23-e1s*e2*e23+ # e2*e12*e13 xic= 8.d0*t1*t2*(-e3s*e12+e13*e23)+4.d0*t1*(-e1* # e2s*e3s+e1*e23s+e2*e3s*e12-e2*e13*e23)+4.d0* # t1s*(e2s*e3s-e23s)+4.d0*t2*(e1*e3s*e12-e1* # e13*e23-e1s*e2*e3s+e2*e13s)+4.d0*t2*t2*(e1s* # e3s-e13s)-2.d0*e1t2*e3s*e12+2.d0*e1t2*e13* # e23+e1s*e2s*e3s+e3s*e12s-2.d0*e12*e13*e23 xib= 2.d0*xib if(xia.eq.0.d0) then if(xib.eq.0.d0) then iz= 0 ifz(34)= ifz(34)+1 go to 2 endif rtm(1)= -xic/xib rtp(1)= rtm(1) rtm(2)= 0.d0 rtp(2)= 0.d0 ixia= 0 else ixia= 1 ifc0= 0 call c02ajf(xia,xib,xic,rtm,rtp,ifc0) endif if(rtm(2).ne.0.d0) then iz= 0 ifz(35)= ifz(35)+1 go to 2 endif * *-----xi^+ and xi^- are computed * xip= 0.5d0*(e3-rtp(1)) xim= 0.5d0*(e3-rtm(1)) * *-----each integral becomes a sum of two terms * *-----loop over ix starts here * if(om.eq.'g') then ixmn= ix0 ixmx= ix0 else ixmn= 1 ixmx= 2 endif do ix=ixmn,ixmx * *-----q_3 is compared and x15 is selected * if(ix.eq.1) then t3= xip else if(ix.eq.2) then t3= xim endif * *-----The two integrands are computed * *-----further auxiliary quantities * edn1= ep1-xdf*t1 edn2= ep2-xdf*t2 edn3= ep3-xdf*t3 t4= omtw-t3 edn4= ep4-xdf*t4 * *-----collections of all limits on t3 * *-----from energy (or natural limits) * if(ieq.eq.1) then at3l1= omtw-bxe*e4+bl(4) at3u1= bxe*e3-bl(3) if(xdf.gt.0.d0) then t3l1= at3l1 t3u1= at3u1 else if(xdf.lt.0.d0) then t3l1= at3u1 t3u1= at3l1 endif else t3l1= 0.d0 t3u1= e3 endif * *-----natural limits * t3l2= -t1+0.5d0*(e1p3-skl2) t3u2= -t1+0.5d0*(e1p3+skl2) * t3l3= omtw+t1-0.5d0*(1.d0+sdmu+skl3) t3u3= omtw+t1-0.5d0*(1.d0+sdmu-skl3) * *-----from positivity on SA * t3l4= 0.d0 t3l5= sm+su+sf-tw t3u4= sp+su+sf t3u5= omtw * *-----from SA * if(iac(3).ne.0) then t3l6= ss(3)*e3 t3u6= cs(3)*e3 t3l7= omtw-cs(4)*e4 t3u7= omtw-ss(4)*e4 t3l= dmax1(t3l1,t3l2,t3l3,t3l4, # t3l5,t3l6,t3l7) t3u= dmin1(t3u1,t3u2,t3u3,t3u4, # t3u5,t3u6,t3u7) else t3l= dmax1(t3l1,t3l2,t3l3,t3l4,t3l5) t3u= dmin1(t3u1,t3u2,t3u3,t3u4,t3u5) endif * *-----limits on t3 are imposed * tlimt3= (t3u-t3)*(t3-t3l) if(t3u.lt.t3l) then iz= 0 ifz(36)= ifz(36)+1 go to 4 else if(tlimt3.lt.0.d0) then iz= 0 ifz(36)= ifz(36)+1 go to 4 endif * *-----non linear limits on t3,t4 are imposed * if(iac(4).ne.0.and.ieq.eq.1) then tnl13c= -cg13*edn1*edn3+vv*sf tnl13s= sg13*edn1*edn3-vv*sf tnl23c= -cg23*edn2*edn3+vv*su tnl23s= sg23*edn2*edn3-vv*su tnl14c= -cg14*edn1*edn4+vv*sd tnl14s= sg14*edn1*edn4-vv*sd sres= 1.d0-e1-e3+sf tnl24c= -cg24*edn2*edn4+vv*sres tnl24s= sg24*edn2*edn4-vv*sres tnl34c= -cg34*edn3*edn4+vv*sp tnl34s= sg34*edn3*edn4-vv*sp if(tnl13c.lt.0.d0.or.tnl13s.lt.0.d0.or. # tnl23c.lt.0.d0.or.tnl23s.lt.0.d0.or. # tnl14c.lt.0.d0.or.tnl14s.lt.0.d0.or. # tnl24c.lt.0.d0.or.tnl24s.lt.0.d0.or. # tnl34c.lt.0.d0.or.tnl34s.lt.0.d0) then iz= 0 ifz(37)= ifz(37)+1 go to 4 endif endif * *-----non linear constraints from FS A in the case xp = xm * if(iac(4).ne.0.d0.and.ieq.eq.0) then smr= 1.d0-sm-sp-su-sd-sf spc12= (-cg12*e1t2+sm)*(sg12*e1t2-sm) spc13= (-cg13*e1t3+sf)*(sg13*e1t3-sf) spc14= (-cg14*e1t4+sd)*(sg14*e1t4-sd) spc23= (-cg23*e2t3+su)*(sg23*e2t3-su) spc24= (-cg24*e2t4+smr)*(sg24*e2t4-smr) spc34= (-cg34*e3t4+sp)*(sg34*e3t4-sp) if(spc12.lt.0.d0.or.spc13.lt.0.d0.or. # spc14.lt.0.d0.or.spc23.lt.0.d0.or. # spc24.lt.0.d0.or.spc34.lt.0.d0) then iz= 0 ifz(38)= ifz(38)+1 go to 4 endif endif * *-----all invariants * x13= t1 x14= t2 x15= t3 x16= t4 x23= e1-t1 x24= e2-t2 x25= e3-t3 x26= e4-t4 x34= sm x35= sf x36= sd x45= su x46= 1.d0-e1-e3+sf x56= sp * *-----computes cross-section * *-----born matrix element is calculated at the reduced c.m. energy * *-----propagators for pair production diagrams * pfp= e4-1.d0 pfb= e1-1.d0 pfpb= e3-1.d0 pf= e2-1.d0 * *-----extra propagators * pp23= x23+rszm2 pp14= x14+rwm2/vv pp13= x13+rszm2 * *-----compensating single W propagators * wpcfr= sp-rwm2/vv wmcfr= sm-rwm2/vv wpcfi= sp*swg wmcfi= sm*swg * *-----Compensating double W propagator * wtcfr= wpcfr*wmcfr-sp*sm*swgs wtcfi= wpcfr*wmcfi+wmcfr*wpcfi * *-----The epsilons are computed in the order * epf(pp,pm,q1,q2),epf(pp,pm,q1,q3),epf(pp,pm,q1,q4), * epf(pp,pm,q2,q3),epf(pp,pm,q2,q4),epf(pp,pm,q3,q4), * epf(pp,q1,q2,q3),epf(pp,q1,q2,q4),epf(pp,q1,q3,q4), * epf(pp,q2,q3,q4),epf(pm,q1,q2,q3),epf(pm,q1,q2,q4), * epf(pm,q1,q3,q4),epf(pm,q2,q3,q4),epf(q1,q2,q3,q4) * x13s= x13*x13 x14s= x14*x14 x15s= x15*x15 x16s= x16*x16 x23s= x23*x23 x24s= x24*x24 x25s= x25*x25 x26s= x26*x26 x34s= x34*x34 x35s= x35*x35 x36s= x36*x36 x45s= x45*x45 x46s= x46*x46 x56s= x56*x56 * e> ee(1)= 2.d0*(x13*x14*x23*x24+x13*x24*x34+ # x14*x23*x34)-x13s*x24s-x14s*x23s-x34s ee(2)= 2.d0*(x13*x15*x23*x25+x13*x25*x35+ # x15*x23*x35)-x13s*x25s-x15s*x23s-x35s ee(3)= 2.d0*(x14*x15*x24*x25+x14*x25*x45+ # x15*x24*x45)-x14s*x25s-x15s*x24s-x45s ee(4)= 2.d0*(x13*x14*x35*x45+x13*x15*x34*x45+ # x14*x15*x34*x35)-x13s*x45s-x14s*x35s- # x15s*x34s ee(5)= 2.d0*(x23*x24*x35*x45+x23*x25*x34*x45+ # x24*x25*x34*x35)-x23s*x45s-x24s*x35s- # x25s*x34s * e(1)= 1.d0 e(2)= x13*x14*x23*x25+x13*x15*x23*x24+x13*(-2.d0* # x23*x45+x24*x35+x25*x34)-x14*x15*x23s+x14* # x23*x35+x15*x23*x34-x13s*x24*x25-x34*x35 e(3)= -x13*x14*x24*x25+x13*x15*x24s-x13*x24*x45- # x14*x15*x23*x24+x14*(-x23*x45+2.d0*x24*x35- # x25*x34)-x15*x24*x34+x14s*x23*x25+x34*x45 e(4)= x13*x14*(x23*x45+x24*x35-2.d0*x25*x34)+x13* # x15*x24*x34+x13*x34*x45+x14*x15*x23*x34+x14* # x34*x35-x15*x34s-x13s*x24*x45-x14s*x23*x35 e(5)= x13*(-x23*x24*x45-x24*x25*x34+x35*x24s)+x14* # (-x23*x24*x35-x23*x25*x34+x45*x23s)+x15* # 2.d0*x23*x24*x34-x23*x34*x45-x24*x34*x35+ # x25*x34s * *-----sign of eps_1*eps_i * ises= 0 sg(1)= 0.25d0 if(ee(1).lt.0.d0) then ises= ises+1 endif do i=2,5 if(abs(e(i)).lt.zrm) then ises= ises+1 else if(e(i).gt.zrm) then sg(i)= 0.25d0 else if(e(i).lt.-zrm) then sg(i)= -0.25d0 endif if(ee(i).lt.0.d0) then ises= ises+1 endif enddo * if(ises.eq.0) then ses1= sg(1)*sqrt(ee(1)) ses2= sg(2)*sqrt(ee(2)) ses3= sg(3)*sqrt(ee(3)) ses4= sg(4)*sqrt(ee(4)) ses5= sg(5)*sqrt(ee(5)) s1= ses1 s2= ses2 s3= -ses1-ses2 s4= ses3 s5= ses1-ses3 s6= ses2+ses3 s7= ses4 s8= ses1-ses4 s9= ses2+ses4 s10= ses3-ses4 s11= ses5 s12= -ses1-ses5 s13= -ses2+ses5 s14= -ses3-ses5 s15= -ses4-ses5 else ee(1)= 2.d0*(x13*x14*x23*x24+x13*x24*x34+ # x14*x23*x34)-x13s*x24s-x14s*x23s-x34s ee(2)= 2.d0*(x13*x16*x23*x26+x13*x26*x36+ # x16*x23*x36)-x13s*x26s-x16s*x23s-x36s ee(3)= 2.d0*(x14*x16*x24*x26+x14*x26*x46+ # x16*x24*x46)-x14s*x26s-x16s*x24s-x46s ee(4)= 2.d0*(x13*x14*x36*x46+x13*x16*x34*x46+ # x14*x16*x34*x36)-x13s*x46s-x14s*x36s- # x16s*x34s ee(5)= 2.d0*(x23*x24*x36*x46+x23*x26*x34*x46+ # x24*x26*x34*x36)-x23s*x46s-x24s*x36s- # x26s*x34s e(1)= 1.d0 e(2)= x13*x14*x23*x26+x13*x16*x23*x24+ # x13*(-2.d0*x23*x46+x24*x36+x26*x34)- # x14*x16*x23s+x14*x23*x36+x16*x23*x34- # x13s*x24*x26-x34*x36 e(3)= -x13*x14*x24*x26+x13*x16*x24s-x13* # x24*x46-x14*x16*x23*x24+x14*(-x23* # x46+2.d0*x24*x36-x26*x34)-x16*x24* # x34+x14s*x23*x26+x34*x46 e(4)= x13*x14*(x23*x46+x24*x36-2.d0*x26* # x34)+x13*x16*x24*x34+x13*x34*x46+ # x14*x16*x23*x34+x14*x34*x36-x16* # x34s-x13s*x24*x46-x14s*x23*x36 e(5)= x13*(-x23*x24*x46-x24*x26*x34+x36* # x24s)+x14*(-x23*x24*x36-x23*x26* # x34+x46*x23s)+x16*2.d0*x23*x24*x34- # x23*x34*x46-x24*x34*x36+x26*x34s ises= 0 sg(1)= 0.25d0 if(ee(1).lt.0.d0) then ises= ises+1 endif do i=2,5 if(abs(e(i)).lt.zrm) then ises= ises+1 else if(e(i).gt.zrm) then sg(i)= 0.25d0 else if(e(i).lt.-zrm) then sg(i)= -0.25d0 endif if(ee(i).lt.0.d0) then ises= ises+1 endif enddo if(ises.eq.0) then ses1= sg(1)*sqrt(ee(1)) ses2= sg(2)*sqrt(ee(2)) ses3= sg(3)*sqrt(ee(3)) ses4= sg(4)*sqrt(ee(4)) ses5= sg(5)*sqrt(ee(5)) s1= ses1 s2= -ses1-ses2 s3= ses2 s4= -ses1-ses3 s5= ses3 s6= -ses2-ses3 s7= ses1-ses4 s8= ses4 s9= -ses2-ses4 s10= -ses3+ses4 s11= -ses1-ses5 s12= ses5 s13= ses2-ses5 s14= ses3+ses5 s15= ses4+ses5 else ee(1)= 2.d0*(x13*x15*x23*x25+x13*x25*x35+ # x15*x23*x35)-x13s*x25s-x15s*x23s- # x35s ee(2)= 2.d0*(x13*x16*x23*x26+x13*x26*x36+ # x16*x23*x36)-x13s*x26s-x16s*x23s- # x36s ee(3)= 2.d0*(x15*x16*x25*x26+x15*x26*x56+ # x16*x25*x56)-x15s*x26s-x16s*x25s- # x56s ee(4)= 2.d0*(x13*x15*x36*x56+x13*x16*x35* # x56+x15*x16*x35*x36)-x13s*x56s- # x15s*x36s-x16s*x35s ee(5)= 2.d0*(x23*x25*x36*x56+x23*x26*x35* # x56+x25*x26*x35*x36)-x23s*x56s- # x25s*x36s-x26s*x35s * e(1)= x13*x14*x23*x25+x13*x15*x23*x24+ # x13*(-2.d0*x23*x45+x24*x35+x25*x34)- # x14*x15*x23s+x14*x23*x35+x15*x23* # x34-x13s*x24*x25-x34*x35 e(2)= x13*x14*x23*x26+x13*x16*x23*x24+ # x13*(-2.d0*x23*x46+x24*x36+x26*x34)- # x14*x16*x23s+x14*x23*x36+x16*x23* # x34-x13s*x24*x26-x34*x36 e(3)= -x13*x15*x24*x26+x13*x16*x24*x25+ # x13*(-x25*x46+x26*x45)+x14*x15*x23* # x26-x14*x16*x23*x25+x14*(x25*x36-x26* # x35)+x15*(-x23*x46+x24*x36)+x16*(x23* # x45-x24*x35)+x35*x46-x36*x45 e(4)= x13*x14*(x25*x36-x26*x35)+x13*x15* # (x23*x46-x26*x34)+x13*x16*(-x23*x45+ # x25*x34)+x13*(x35*x46-x36*x45)-x14* # x15*x23*x36+x14*x16*x23*x35+x15*x34* # x36-x16*x34*x35+x13s*(-x25*x46+x26* # x45) e(5)= x13*(-x23*x25*x46+x23*x26*x45+x24*x25* # x36-x24*x26*x35)+x15*(-x23*x24*x36- # x23*x26*x34+x46*x23s)+x16*(x23*x24* # x35+x23*x25*x34-x45*x23s)-x23*x35* # x46+x23*x36*x45-x25*x34*x36+x26*x34* # x35 * ises= 0 do i=1,5 if(abs(e(i)).lt.zrm) then ises= ises+1 else if(e(i).gt.zrm) then sg(i)= 0.25d0 else if(e(i).lt.-zrm) then sg(i)= -0.25d0 endif if(ee(i).lt.0.d0) then ises= ises+1 endif enddo if(ises.eq.0) then ses1= sg(1)*sqrt(ee(1)) ses2= sg(2)*sqrt(ee(2)) ses3= sg(3)*sqrt(ee(3)) ses4= sg(4)*sqrt(ee(4)) ses5= sg(5)*sqrt(ee(5)) s1= -ses1-ses2 s2= ses1 s3= ses2 s4= -ses1+ses3 s5= -ses2-ses3 s6= ses3 s7= -ses1+ses4 s8= -ses2-ses4 s9= ses4 s10= ses3-ses4 s11= ses1+ses5 s12= ses2-ses5 s13= ses5 s14= -ses3-ses5 s15= -ses4-ses5 else iz= 0 ifz(39)= ifz(39)+1 go to 4 endif endif endif * tgc(1)= x15*x24 tgc(2)= x34*x46 tgc(3)= x34/x46 tgc(4)= x24/x15 tgc(5)= x15/x25 tgc(6)= x15*x25 tgc(7)= x14*x34 tgc(8)= x25*x46 tgc(9)= x25/x46 tgc(10)= x14/x34 tgc(11)= x45/x36 tgc(12)= x14*x24 tgc(13)= x24/x14 tgc(14)= x45*x36 tgc(15)= x14/x25 * itgc= 0 do l=1,15 if(tgc(l).le.0.d0) then itgc= itgc+1 endif enddo if(itgc.ne.0) then iz= 0 ifz(40)= ifz(40)+1 go to 4 endif * gpna= sqrt(x15*x24) gpnb= sqrt(x34*x46) gpnc= sqrt(x34/x46) gpnd= sqrt(x24/x15) gpne= sqrt(x15/x25) gpnf= sqrt(x15*x25) gmna= sqrt(x14*x34) gmnb= sqrt(x25*x46) gmnc= sqrt(x25/x46) gmnd= sqrt(x14/x34) gmne= sqrt(x45/x36) gmnf= sqrt(x14*x24) gmng= sqrt(x24/x14) gmnh= sqrt(x45*x36) gmni= sqrt(x14/x25) * gc1= gpna/gpnb gc2= gpna*gpnc gc3= gpna/gpnc gc4= gpnd/gpnb gc5= 1.d0/gpna/gpnc gc6= 1.d0/gpnd/gpnc gc7= gpnd/gpnc gc8= gpnb/gpna gc9= gpnd*gpnc gc10= gpnb/gpnd gc11= gpna*gpnb gc12= gmnd/gmnb gc13= 1.d0/gmnc/gmna gc14= gmna/gmnb gc15= gmnd/gmnc gc16= 1.d0/gmnd/gmnc gc17= gmna*gmnb gc18= gmnc/gmnd gc19= gmnc/gmna gc20= gmna*gmnc gc21= gmnd*gmnb gc22= gmnd*gmnc gc23= gmnb/gmnd gc24= gmnb/gmna gc25= gpnc/gpnd gc26= 1.d0/gpna/gpnb gc27= gpnc/gpna gc28= 1.d0/gpnd/gpnb gc29= gpne/gmnh gc30= gmne/gpnf gc31= 1.d0/gpnf/gmne gc32= 1.d0/gpnf/gmnh gc33= gpne*gmne gc34= gpne/gmne gc35= gmnh/gpnf gc36= gmnh*gpne gc37= gpnb*gmni * *-----CC diagrams * *-----helicity a) * *-----conversion diagram without t-channel propagator * dcr= 2.d0*(gc1*x36*(x45-x14)+ # gc2*(x16-x56)+gc3*(x13-x35)) dci= 8.d0*gc1*(s8-s15) * *-----annihilation diagrams: common part * daarc= 2.d0*gc1*x36*x45-2.d0*gc2*x56+ # gc3*(-x35+1.5d0*x36)+2.d0*gc4* # (x13*x36*x45-x14*x35*x36)+gc5* # (-x13*x23*x45-0.5d0*x13*x25*x46+ # 0.5d0*x13*x26*x45+x14*x23*x35- # 0.5d0*x14*x23*x56+0.5d0*x14*x25* # x36-0.5d0*x14*x26*x35+0.5d0*x16* # x23*x45+0.5d0*x35*x46-0.5d0*x36* # x45)+gc6*(-x23*x45-1.5d0*x23* # x46)+gc7*(x13*x45+0.5d0*x13*x56- # x14*x35-0.5d0*x16*x35)+gc8*(x13* # x25-0.5d0*x16*x25-x35+0.5d0*x56)+ # 2.d0*gc9*(-x13*x56+x16*x35)+ # gc10*(x25+1.5d0*x26)+3.d0*gc11 daaic= -8.d0*gc1*s15+8.d0*gc4*s7*x36+ # 2.d0*gc5*(s2*x46-s5*x35-2.d0*s7* # x23+s7*x26+s14*x13)-2.d0*gc6*(2.d0* # s11+3.d0*s12)+2.d0*gc7*(2.d0*s7-s9)- # 4.d0*gc8*s2+8.d0*gc9*s9 * *-----pair production I: common part * dpp1arc= -gc1*x24*x36+gc2*x26+gc3*(x23+x36)+ # gc4*(x13*(x24*x56-x26*x45)-x14*(x23* # x56-x25*x36-x26*x35)+x16*(x23*x45-x24* # x35)-x36*x45)+gc5*(x13*(x25*x46-x26* # x45)+x14*(x23*x56-x25*x36+x26*x35)-x16* # x23*x45-x35*x46+x36*x45)-gc6*x23*x46+ # gc7*(-x13*x25-x13*x56+x16*x35+x35)+ # gc8*(x16*x25-x56)+gc9*(-x16*x25+x56)+ # gc10*x26 dpp1aic= 4.d0*gc1*s12+4.d0*gc4*(-x25*s8-x36* # s4+s15)+4.d0*gc5*(x25*s8-2.d0*x26*s7+ # x36*s4-x46*s2-s15)-4.d0*gc6*s12+4.d0* # gc7*s2+4.d0*gc8*s6-4.d0*gc9*s6 * if(ockm.eq.'y') then if(ickm.eq.1) then dpp1arc= dpp1arc*vckm(1,1)*vckm(1,1) dpp1aic= dpp1aic*vckm(1,1)*vckm(1,1) else if(ickm.eq.2) then dpp1arc= dpp1arc*vckm(1,2)*vckm(1,2) dpp1aic= dpp1aic*vckm(1,2)*vckm(1,2) else if(ickm.eq.3) then dpp1arc= dpp1arc*vckm(1,3)*vckm(1,3) dpp1aic= dpp1aic*vckm(1,3)*vckm(1,3) else if(ickm.eq.4) then dpp1arc= dpp1arc*vckm(2,1)*vckm(2,1) dpp1aic= dpp1aic*vckm(2,1)*vckm(2,1) else if(ickm.eq.5) then dpp1arc= dpp1arc*vckm(2,2)*vckm(2,2) dpp1aic= dpp1aic*vckm(2,2)*vckm(2,2) else if(ickm.eq.6) then dpp1arc= dpp1arc*vckm(2,3)*vckm(2,3) dpp1aic= dpp1aic*vckm(2,3)*vckm(2,3) endif endif * *-----pair production II: common part * dpp2arc= +2.d0*gc3*x13+2.d0*gc5*x23*(-x13* # x45+x14*x35)-2.d0*gc6*x14*x23+2.d0* # gc8*(x13*x25-x35)+2.d0*gc10 dpp2aic= 8.d0*(-gc5*x23*s7+gc6*s1-gc8*s2) if(ockm.eq.'y') then if(ickm.eq.1) then dpp2arc= dpp2arc*vckm(1,1)*vckm(1,1) dpp2aic= dpp2aic*vckm(1,1)*vckm(1,1) else if(ickm.eq.2) then dpp2arc= dpp2arc*vckm(1,2)*vckm(1,2) dpp2aic= dpp2aic*vckm(1,2)*vckm(1,2) else if(ickm.eq.3) then dpp2arc= dpp2arc*vckm(1,3)*vckm(1,3) dpp2aic= dpp2aic*vckm(1,3)*vckm(1,3) else if(ickm.eq.4) then dpp2arc= dpp2arc*vckm(2,1)*vckm(2,1) dpp2aic= dpp2aic*vckm(2,1)*vckm(2,1) else if(ickm.eq.5) then dpp2arc= dpp2arc*vckm(2,2)*vckm(2,2) dpp2aic= dpp2aic*vckm(2,2)*vckm(2,2) else if(ickm.eq.6) then dpp2arc= dpp2arc*vckm(2,3)*vckm(2,3) dpp2aic= dpp2aic*vckm(2,3)*vckm(2,3) endif endif * *-----pair production III: common part * dpp3arc= 2.d0*gc3*(x35-x13)+2.d0*gc6*(x14* # x23-x23*x45)+2.d0*gc10*(-1.d0+x25) dpp3aic= -8.d0*gc6*(s1+s11) if(ockm.eq.'y') then if(ickm.eq.1) then dpp3arc= dpp3arc*vckm(1,1)*vckm(1,1) dpp3aic= dpp3aic*vckm(1,1)*vckm(1,1) else if(ickm.eq.2) then dpp3arc= dpp3arc*vckm(1,2)*vckm(1,2) dpp3aic= dpp3aic*vckm(1,2)*vckm(1,2) else if(ickm.eq.3) then dpp3arc= dpp3arc*vckm(1,3)*vckm(1,3) dpp3aic= dpp3aic*vckm(1,3)*vckm(1,3) else if(ickm.eq.4) then dpp3arc= dpp3arc*vckm(2,1)*vckm(2,1) dpp3aic= dpp3aic*vckm(2,1)*vckm(2,1) else if(ickm.eq.5) then dpp3arc= dpp3arc*vckm(2,2)*vckm(2,2) dpp3aic= dpp3aic*vckm(2,2)*vckm(2,2) else if(ickm.eq.6) then dpp3arc= dpp3arc*vckm(2,3)*vckm(2,3) dpp3aic= dpp3aic*vckm(2,3)*vckm(2,3) endif endif * *-----pair production IV: common part * dpp4arc= gc1*x24*x36-gc2*x26-gc3*x23+ # gc4*(x13*(-x24*x56+x26*x45)+ # x14*(x23*x56-x25*x36-x26*x35)- # x16*(x23*x45-x24*x35)+x36*x45)+ # gc7*(x13*x25-2.d0*x13*x45+2.d0* # x14*x35-x35)+gc9*(x16*x25-x56)+ # 2.d0*gc11 dpp4aic= -4.d0*gc1*s12+4.d0*gc4*(x25*s8+x36* # s4-s15)-4.d0*gc7*(s2+2.d0*s7)+4.d0* # gc9*s6 if(ockm.eq.'y') then if(ickm.eq.1) then dpp4arc= dpp4arc*vckm(1,1)*vckm(1,1) dpp4aic= dpp4aic*vckm(1,1)*vckm(1,1) else if(ickm.eq.2) then dpp4arc= dpp4arc*vckm(1,2)*vckm(1,2) dpp4aic= dpp4aic*vckm(1,2)*vckm(1,2) else if(ickm.eq.3) then dpp4arc= dpp4arc*vckm(1,3)*vckm(1,3) dpp4aic= dpp4aic*vckm(1,3)*vckm(1,3) else if(ickm.eq.4) then dpp4arc= dpp4arc*vckm(2,1)*vckm(2,1) dpp4aic= dpp4aic*vckm(2,1)*vckm(2,1) else if(ickm.eq.5) then dpp4arc= dpp4arc*vckm(2,2)*vckm(2,2) dpp4aic= dpp4aic*vckm(2,2)*vckm(2,2) else if(ickm.eq.6) then dpp4arc= dpp4arc*vckm(2,3)*vckm(2,3) dpp4aic= dpp4aic*vckm(2,3)*vckm(2,3) endif endif * *-----complete diagrams, epsilon real and imag parts separated: * *-----complete conversion diagram: * dcr= -0.25d0*dcr dci= -0.25d0*dci * *-----complete annihilation diagrams: * adap= 0.5d0*(sth2*omrz+0.5d0*rsz) daar= -adap*daarc daare= 0.5d0*asth2*aisz*daaic daaie= -adap*daaic daai= -0.5d0*asth2*aisz*daarc * *-----complete pair production I-IV: * hcpd1= 1.d0-tsth2*(omchdp+hchdp) hcpd2= 1.d0-tsth2*(omchd+hchd) hcpu3= -1.d0+tsth2*(opchup-hchup) hcpu4= -1.d0+tsth2*(opchu-hchu) * gcpd1= (1.d0-tsth2*opchdp-omrz*hcpd1)*scth2 gcpd2= (1.d0-tsth2*opchd-omrz*hcpd2)*scth2 gcpu3= (1.d0-tsth2*omchup+omrz*hcpu3)*scth2 gcpu4= (1.d0-tsth2*omchu+omrz*hcpu4)*scth2 * dpp1ar= gcpd1*dpp1arc dpp1are= -hcpd1*haisz*dpp1aic dpp1aie= gcpd1*dpp1aic dpp1ai= hcpd1*haisz*dpp1arc dpp2ar= -gcpd2*dpp2arc dpp2are= hcpd2*haisz*dpp2aic dpp2aie= -gcpd2*dpp2aic dpp2ai= -hcpd2*haisz*dpp2arc dpp3ar= gcpu3*dpp3arc dpp3are= hcpu3*haisz*dpp3aic dpp3aie= gcpu3*dpp3aic dpp3ai= -hcpu3*haisz*dpp3arc dpp4ar= -gcpu4*dpp4arc dpp4are= -hcpu4*haisz*dpp4aic dpp4aie= -gcpu4*dpp4aic dpp4ai= hcpu4*haisz*dpp4arc * *-----compensating the missing W and the fermion propagators * d11ar= (dpp1ar*wpcfr-dpp1ai*wpcfi)/pfp+ # (dpp2ar*wmcfr-dpp2ai*wmcfi)/pfb+ # (dpp3ar*wpcfr-dpp3ai*wpcfi)/pfpb+ # (dpp4ar*wmcfr-dpp4ai*wmcfi)/pf d11are= (dpp1are*wpcfr-dpp1aie*wpcfi)/pfp+ # (dpp2are*wmcfr-dpp2aie*wmcfi)/pfb+ # (dpp3are*wpcfr-dpp3aie*wpcfi)/pfpb+ # (dpp4are*wmcfr-dpp4aie*wmcfi)/pf d11ai= (dpp1ar*wpcfi+dpp1ai*wpcfr)/pfp+ # (dpp2ar*wmcfi+dpp2ai*wmcfr)/pfb+ # (dpp3ar*wpcfi+dpp3ai*wpcfr)/pfpb+ # (dpp4ar*wmcfi+dpp4ai*wmcfr)/pf d11aie= (dpp1are*wpcfi+dpp1aie*wpcfr)/pfp+ # (dpp2are*wmcfi+dpp2aie*wmcfr)/pfb+ # (dpp3are*wpcfi+dpp3aie*wpcfr)/pfpb+ # (dpp4are*wmcfi+dpp4aie*wmcfr)/pf * pns= pn*pn darc= dcr/pn+daar-d11ar darec= daare-d11are daiec= dci/pn+daaie-d11aie daic= daai-d11ai * darc3= dcr/pn+daar darec3= daare daiec3= dci/pn+daaie daic3= daai * *-----helicity b) * * *-----annihilation diagrams: common part * dabrc= 2.d0*gc12*(x23*x36*x45-x24*x35* # x36)+gc13*(-x13*x23*x45+x13*x24* # x35-0.5d0*x13*x24*x56+0.5d0*x13* # x26*x45-0.5d0*x15*x23*x46+0.5d0* # x15*x24*x36+0.5d0*x16*x23*x45- # 0.5d0*x16*x24*x35+0.5d0*x35*x46- # 0.5d0*x36*x45)+2.d0*gc14*(-x23* # x56+x26*x35)+gc15*(x23*x45+0.5d0* # x23*x56-x24*x35-0.5d0*x26*x35)+ # gc16*(x15*x23-0.5d0*x15*x26-x35+ # 0.5d0*x56)+3.d0*gc17-2.d0*gc20* # x56+gc21*(-x35+1.5d0*x36)+2.d0* # gc22*x36*x45+gc23*(x15+1.5d0* # x16)+gc24*(-x13*x45-1.5d0*x13* # x46) dabic= 8.d0*gc12*x36*s11+2.d0*gc13*(x16*s11- # 2.d0*x23*s7+x23*s10+2.d0*x35*s1+x35*s5- # x46*s2)+8.d0*gc14*s13+2.d0*gc15*(2.d0* # s11-s13)-8.d0*gc18*s10-8.d0*gc19*x45*s8+ # 2.d0*gc24*(2.d0*s7-3.d0*s8) if(ockm.eq.'y') then if(ickm.eq.1) then dabrc= dabrc*vckm(1,1)*vckm(1,1) dabic= dabic*vckm(1,1)*vckm(1,1) else if(ickm.eq.2) then dabrc= dabrc*vckm(1,2)*vckm(1,2) dabic= dabic*vckm(1,2)*vckm(1,2) else if(ickm.eq.3) then dabrc= dabrc*vckm(1,3)*vckm(1,3) dabic= dabic*vckm(1,3)*vckm(1,3) else if(ickm.eq.4) then dabrc= dabrc*vckm(2,1)*vckm(2,1) dabic= dabic*vckm(2,1)*vckm(2,1) else if(ickm.eq.5) then dabrc= dabrc*vckm(2,2)*vckm(2,2) dabic= dabic*vckm(2,2)*vckm(2,2) else if(ickm.eq.6) then dabrc= dabrc*vckm(2,3)*vckm(2,3) dabic= dabic*vckm(2,3)*vckm(2,3) endif endif * *-----pair production I: common part * dpp1brc= gc12*(-x13*(x24*x56-x26*x45)+x14* # (x23*x56-x26*x35)+x15*x24*x36-x16* # (x23*x45-x24*x35)-x36*x45)+gc13* # (x13*(x24*x56-x26*x45)+x15*(x23* # x46-x24*x36)-x16*(x23*x45-x24*x35)- # x35*x46+x36*x45)+gc14*(-x15*x26+ # x56)+gc15*(-x15*x23-x23*x56+x26* # x35+x35)+gc16*(x15*x26-x56)+gc20* # x16+gc21*(x13+x36)+gc22*(-x14* # x36)+gc23*x16+gc24*(-x13*x46) dpp1bic= 4.d0*gc12*(-x14*s13-x16*s11+x23* # s10+x35*s5)+4.d0*gc13*(-x13*s14- # x26*s7+x56*s1)+4.d0*gc15*(-s2+s13)- # 4.d0*gc16*s6+4.d0*gc22*s8-4.d0* # gc24*s8 * if(ockm.eq.'y') then if(ickm.eq.1) then dpp1brc= dpp1brc*vckm(1,1)*vckm(1,1) dpp1bic= dpp1bic*vckm(1,1)*vckm(1,1) else if(ickm.eq.2) then dpp1brc= dpp1brc*vckm(1,2)*vckm(1,2) dpp1bic= dpp1bic*vckm(1,2)*vckm(1,2) else if(ickm.eq.3) then dpp1brc= dpp1brc*vckm(1,3)*vckm(1,3) dpp1bic= dpp1bic*vckm(1,3)*vckm(1,3) else if(ickm.eq.4) then dpp1brc= dpp1brc*vckm(2,1)*vckm(2,1) dpp1bic= dpp1bic*vckm(2,1)*vckm(2,1) else if(ickm.eq.5) then dpp1brc= dpp1brc*vckm(2,2)*vckm(2,2) dpp1bic= dpp1bic*vckm(2,2)*vckm(2,2) else if(ickm.eq.6) then dpp1brc= dpp1brc*vckm(2,3)*vckm(2,3) dpp1bic= dpp1bic*vckm(2,3)*vckm(2,3) endif endif * *-----pair production II: common part * dpp2brc= 2.d0*gc13*x13*(-x23*x45+x24*x35)+ # 2.d0*gc16*(x15*x23-x35)+2.d0*gc21* # x23+2.d0*gc23-2.d0*gc24*x13*x24 dpp2bic= 8.d0*gc13*(-x23*s7+x35*s1)-8.d0* # gc24*s1 if(ockm.eq.'y') then if(ickm.eq.1) then dpp2brc= dpp2brc*vckm(1,1)*vckm(1,1) dpp2bic= dpp2bic*vckm(1,1)*vckm(1,1) else if(ickm.eq.2) then dpp2brc= dpp2brc*vckm(1,2)*vckm(1,2) dpp2bic= dpp2bic*vckm(1,2)*vckm(1,2) else if(ickm.eq.3) then dpp2brc= dpp2brc*vckm(1,3)*vckm(1,3) dpp2bic= dpp2bic*vckm(1,3)*vckm(1,3) else if(ickm.eq.4) then dpp2brc= dpp2brc*vckm(2,1)*vckm(2,1) dpp2bic= dpp2bic*vckm(2,1)*vckm(2,1) else if(ickm.eq.5) then dpp2brc= dpp2brc*vckm(2,2)*vckm(2,2) dpp2bic= dpp2bic*vckm(2,2)*vckm(2,2) else if(ickm.eq.6) then dpp2brc= dpp2brc*vckm(2,3)*vckm(2,3) dpp2bic= dpp2bic*vckm(2,3)*vckm(2,3) endif endif * *-----production III: common part * dpp3brc= 2.d0*gc21*(-x23+x35)+2.d0*gc23* # (-1.d0+x15)+2.d0*gc24*x13*(x24-x45) dpp3bic= 8.d0*gc24*(s1-s7) if(ockm.eq.'y') then if(ickm.eq.1) then dpp3brc= dpp3brc*vckm(1,1)*vckm(1,1) dpp3bic= dpp3bic*vckm(1,1)*vckm(1,1) else if(ickm.eq.2) then dpp3brc= dpp3brc*vckm(1,2)*vckm(1,2) dpp3bic= dpp3bic*vckm(1,2)*vckm(1,2) else if(ickm.eq.3) then dpp3brc= dpp3brc*vckm(1,3)*vckm(1,3) dpp3bic= dpp3bic*vckm(1,3)*vckm(1,3) else if(ickm.eq.4) then dpp3brc= dpp3brc*vckm(2,1)*vckm(2,1) dpp3bic= dpp3bic*vckm(2,1)*vckm(2,1) else if(ickm.eq.5) then dpp3brc= dpp3brc*vckm(2,2)*vckm(2,2) dpp3bic= dpp3bic*vckm(2,2)*vckm(2,2) else if(ickm.eq.6) then dpp3brc= dpp3brc*vckm(2,3)*vckm(2,3) dpp3bic= dpp3bic*vckm(2,3)*vckm(2,3) endif endif * *-----pair production IV: common part * dpp4brc= gc12*(x13*(x24*x56-x26*x45)-x14* # (x23*x56-x26*x35)-x15*x24*x36+x16* # (x23*x45-x24*x35)+x36*x45)+gc14* # (x15*x26-x56)+gc15*(x15*x23-2*x23* # x45+2.d0*x24*x35-x35)+2.d0*gc17- # gc20*x16-gc21*x13+gc22*x14*x36 dpp4bic= 4.d0*gc12*(x14*s13+x16*s11-x23*s10- # x35*s5)+4.d0*gc15*(s2-2.d0*s11)- # 4.d0*gc22*s8 if(ockm.eq.'y') then if(ickm.eq.1) then dpp4brc= dpp4brc*vckm(1,1)*vckm(1,1) dpp4bic= dpp4bic*vckm(1,1)*vckm(1,1) else if(ickm.eq.2) then dpp4brc= dpp4brc*vckm(1,2)*vckm(1,2) dpp4bic= dpp4bic*vckm(1,2)*vckm(1,2) else if(ickm.eq.3) then dpp4brc= dpp4brc*vckm(1,3)*vckm(1,3) dpp4bic= dpp4bic*vckm(1,3)*vckm(1,3) else if(ickm.eq.4) then dpp4brc= dpp4brc*vckm(2,1)*vckm(2,1) dpp4bic= dpp4bic*vckm(2,1)*vckm(2,1) else if(ickm.eq.5) then dpp4brc= dpp4brc*vckm(2,2)*vckm(2,2) dpp4bic= dpp4bic*vckm(2,2)*vckm(2,2) else if(ickm.eq.6) then dpp4brc= dpp4brc*vckm(2,3)*vckm(2,3) dpp4bic= dpp4bic*vckm(2,3)*vckm(2,3) endif endif * *-----complete diagrams, epsilon parts separated: * *-----complete annihilation diagrams: * dabr= -hsth2*omrz*dabrc dabre= -hsth2*aisz*dabic dabie= -hsth2*omrz*dabic dabi= hsth2*aisz*dabrc * *-----complete pair production I-IV: * gcmd1= tth2*(-0.25d0-0.5d0*chdp+omrz*(0.25d0+ # chdp*hsth2)) gcmd2= tth2*(-0.25d0-0.5d0*chd+omrz*(0.25d0+ # chd*hsth2)) gcmu3= tth2*(-0.25d0+0.5d0*chup+omrz*(0.25d0- # chup*hsth2)) gcmu4= tth2*(-0.25d0+0.5d0*chu+omrz*(0.25d0- # chu*hsth2)) hcmd1= -tsth2*(1.d0+hchdp) hcmd2= -tsth2*(1.d0+hchd) hcmu3= tsth2*(1.d0-hchup) hcmu4= tsth2*(1.d0-hchu) * dpp1br= gcmd1*dpp1brc dpp1bre= -hcmd1*haisz*dpp1bic dpp1bie= gcmd1*dpp1bic dpp1bi= hcmd1*haisz*dpp1brc dpp2br= -gcmd2*dpp2brc dpp2bre= hcmd2*haisz*dpp2bic dpp2bie= -gcmd2*dpp2bic dpp2bi= -hcmd2*haisz*dpp2brc dpp3br= gcmu3*dpp3brc dpp3bre= hcmu3*haisz*dpp3bic dpp3bie= gcmu3*dpp3bic dpp3bi= -hcmu3*haisz*dpp3brc dpp4br= -gcmu4*dpp4brc dpp4bre= -hcmu4*haisz*dpp4bic dpp4bie= -gcmu4*dpp4bic dpp4bi= hcmu4*haisz*dpp4brc * *-----compensating the missing W and the fermion propagators * d11br= (dpp1br*wpcfr-dpp1bi*wpcfi)/pfp+ # (dpp2br*wmcfr-dpp2bi*wmcfi)/pfb+ # (dpp3br*wpcfr-dpp3bi*wpcfi)/pfpb+ # (dpp4br*wmcfr-dpp4bi*wmcfi)/pf d11bre= (dpp1bre*wpcfr-dpp1bie*wpcfi)/pfp+ # (dpp2bre*wmcfr-dpp2bie*wmcfi)/pfb+ # (dpp3bre*wpcfr-dpp3bie*wpcfi)/pfpb+ # (dpp4bre*wmcfr-dpp4bie*wmcfi)/pf d11bi= (dpp1br*wpcfi+dpp1bi*wpcfr)/pfp+ # (dpp2br*wmcfi+dpp2bi*wmcfr)/pfb+ # (dpp3br*wpcfi+dpp3bi*wpcfr)/pfpb+ # (dpp4br*wmcfi+dpp4bi*wmcfr)/pf d11bie= (dpp1bre*wpcfi+dpp1bie*wpcfr)/pfp+ # (dpp2bre*wmcfi+dpp2bie*wmcfr)/pfb+ # (dpp3bre*wpcfi+dpp3bie*wpcfr)/pfpb+ # (dpp4bre*wmcfi+dpp4bie*wmcfr)/pf * * *-----the square of h= b, inclusive of the compensating * nu propagator * dbrc= dabr-d11br dbrec= dabre-d11bre dbiec= dabie-d11bie dbic= dabi-d11bi * dbrc3= dabr dbrec3= dabre dbiec3= dabie dbic3= dabi * *-----NC diagrams * *-----Conversion for helicity sets * * pp pm q1 q2 q3 q4 ==> pp pm q1 q2 q3 q4 * * + - + - + - a + - + - + - b * - + - + - + b - + - + - + f * + - - + - + c + - - + - + g * - + + - + - d - + + - + - h * + - + - - + e + - + + - - i * - + - + + - f - + - - + + l * + - - + + - h + - - - + + m * - + + - - + g - + + + - - n * *-----Re-initialization of variables * otgn(1)= x15*x24 otgn(2)= x34*x46 otgn(3)= x34/x46 otgn(4)= x24/x15 otgn(5)= x15/x25 otgn(6)= x15*x25 otgn(7)= x14*x25 otgn(8)= x14*x34 otgn(9)= x25*x46 otgn(10)= x25/x46 otgn(11)= x14/x34 otgn(12)= x45/x36 otgn(13)= x14*x24 otgn(14)= x24/x14 otgn(15)= x45*x36 otgn(16)= x14/x25 * iotgn= 0 do l=1,16 if(otgn(l).le.0.d0) then iotgn= iotgn+1 endif enddo if(iotgn.ne.0) then iz= 0 ifz(41)= ifz(41)+1 go to 4 endif * ogpna= sqrt(otgn(1)) ogpnb= sqrt(otgn(2)) ogpnc= sqrt(otgn(3)) ogpnd= sqrt(otgn(4)) ogpne= sqrt(otgn(5)) ogpnf= sqrt(otgn(6)) ogpng= sqrt(otgn(7)) ogmna= sqrt(otgn(8)) ogmnb= sqrt(otgn(9)) ogmnc= sqrt(otgn(10)) ogmnd= sqrt(otgn(11)) ogmne= sqrt(otgn(12)) ogmnf= sqrt(otgn(13)) ogmng= sqrt(otgn(14)) ogmnh= sqrt(otgn(15)) ogmni= sqrt(otgn(16)) * ogn1= ogpna/ogpnb ogn2= ogpna*ogpnc ogn3= ogpna/ogpnc ogn4= ogpnd/ogpnb ogn5= 1.d0/ogpna/ogpnc ogn6= 1.d0/ogpnd/ogpnc ogn7= ogpnd/ogpnc ogn8= ogpnb/ogpna ogn9= ogpnd*ogpnc ogn10= ogpnb/ogpnd ogn11= ogpna*ogpnb ogn12= ogmnd/ogmnb ogn13= 1.d0/ogmnc/ogmna ogn14= ogmna/ogmnb ogn15= ogmnd/ogmnc ogn16= 1.d0/ogmnd/ogmnc ogn17= ogmna*ogmnb ogn18= ogmnc/ogmnd ogn19= ogmnc/ogmna ogn20= ogmna*ogmnc ogn21= ogmnd*ogmnb ogn22= ogmnd*ogmnc ogn23= ogmnb/ogmnd ogn24= ogmnb/ogmna ogn25= ogpnc/ogpnd ogn26= 1.d0/ogpna/ogpnb ogn27= ogpnc/ogpna ogn28= 1.d0/ogpnd/ogpnb ogn29= ogpne/ogmnh ogn30= ogmne/ogpnf ogn31= 1.d0/ogpnf/ogmne ogn32= 1.d0/ogpnf/ogmnh ogn33= ogpne*ogmne ogn34= ogpne/ogmne ogn35= ogmnh/ogpnf ogn36= ogmnh*ogpne ogn37= ogpnb*ogmni ogn38= ogpnc/ogpng ogn39= 1.d0/ogpng/ogpnb ogn40= ogmne/ogmnf ogn41= ogmng*ogmne ogn42= 1.d0/ogmnf/ogmnh ogn43= ogmng/ogmnh ogn44= ogmne/ogmng ogn45= 1.d0/ogmng/ogmnh ogn46= ogmnf/ogmnh ogn47= ogmnf*ogmne ogn48= ogmnh/ogmnf ogn49= 1.d0/ogmng/ogmne ogn50= ogmng*ogmnh ogn51= 1.d0/ogmnf/ogmne ogn52= ogmnh/ogmng ogn53= ogmnf*ogmnh ogn54= ogmnf/ogmne ogn55= 1.d0/ogpnb*ogmni ogn56= 1.d0/ogpnc/ogpng ogn57= ogpnc*ogmni ogn58= 1.d0/ogpnc*ogmni ogn59= ogpnb/ogpng ogn60= ogpnb*ogpng ogn61= ogpnc/ogmni ogn62= 1.d0/ogpnb/ogmni ogn63= ogpnc*ogpng ogn64= 1.d0/ogpnc*ogpng ogn65= 1.d0/ogpnb*ogpng ogn66= ogpnb/ogmni ogn67= 1.d0/ogpnc/ogmni ogn68= ogpne/ogmne ogn69= 1.d0/ogpnf*ogmnh ogn70= 1.d0/ogmne*ogmng * y13= x13 y14= x16 y15= x15 y16= x14 y23= x23 y24= x26 y25= x25 y26= x24 y34= x36 y35= x35 y36= x34 y45= x56 y46= x46 y56= x45 * y13s= y13*y13 y14s= y14*y14 y15s= y15*y15 y16s= y16*y16 y23s= y23*y23 y24s= y24*y24 y25s= y25*y25 y26s= y26*y26 y34s= y34*y34 y35s= y35*y35 y36s= y36*y36 y45s= y45*y45 y46s= y46*y46 y56s= y56*y56 * w1= s3 w2= s2 w3= s1 w4= -s6 w5= -s5 w6= -s4 w7= -s9 w8= -s8 w9= -s7 w10= -s10 w11= -s13 w12= -s12 w13= -s11 w14= -s14 w15= -s15 * ysm= sd ysd= sm ysp= su ysu= sp ytw= t1+t4 * ye1= e1 ye2= 1.d0+ysm-ysp-ye1 ye3= e3 ye4= 1.d0+ysp-ysm-ye3 ypfpb= ye3-1.d0 ypfp= ye4-1.d0 ypfb= ye1-1.d0 ypf= ye2-1.d0 * ysmtp= ysm*ysp ypnp= ytw-ysm ypn= ytw+ysp-1.d0 * tgn(1)= y15*y24 tgn(2)= y34*y46 tgn(3)= y34/y46 tgn(4)= y24/y15 tgn(5)= y15/y25 tgn(6)= y15*y25 tgn(7)= y14*y25 tgn(8)= y14*y34 tgn(9)= y25*y46 tgn(10)= y25/y46 tgn(11)= y14/y34 tgn(12)= y45/y36 tgn(13)= y14*y24 tgn(14)= y24/y14 tgn(15)= y45*y36 tgn(16)= y14/y25 * itgn= 0 do l=1,16 if(tgn(l).le.0.d0) then itgn= itgn+1 endif enddo if(itgn.ne.0) then iz= 0 ifz(42)= ifz(42)+1 go to 4 endif * ygpna= sqrt(tgn(1)) ygpnb= sqrt(tgn(2)) ygpnc= sqrt(tgn(3)) ygpnd= sqrt(tgn(4)) ygpne= sqrt(tgn(5)) ygpnf= sqrt(tgn(6)) ygpng= sqrt(tgn(7)) ygmna= sqrt(tgn(8)) ygmnb= sqrt(tgn(9)) ygmnc= sqrt(tgn(10)) ygmnd= sqrt(tgn(11)) ygmne= sqrt(tgn(12)) ygmnf= sqrt(tgn(13)) ygmng= sqrt(tgn(14)) ygmnh= sqrt(tgn(15)) ygmni= sqrt(tgn(16)) * gn1= ygpna/ygpnb gn2= ygpna*ygpnc gn3= ygpna/ygpnc gn4= ygpnd/ygpnb gn5= 1.d0/ygpna/ygpnc gn6= 1.d0/ygpnd/ygpnc gn7= ygpnd/ygpnc gn8= ygpnb/ygpna gn9= ygpnd*ygpnc gn10= ygpnb/ygpnd gn11= ygpna*ygpnb gn12= ygmnd/ygmnb gn13= 1.d0/ygmnc/ygmna gn14= ygmna/ygmnb gn15= ygmnd/ygmnc gn16= 1.d0/ygmnd/ygmnc gn17= ygmna*ygmnb gn18= ygmnc/ygmnd gn19= ygmnc/ygmna gn20= ygmna*ygmnc gn21= ygmnd*ygmnb gn22= ygmnd*ygmnc gn23= ygmnb/ygmnd gn24= ygmnb/ygmna gn25= ygpnc/ygpnd gn26= 1.d0/ygpna/ygpnb gn27= ygpnc/ygpna gn28= 1.d0/ygpnd/ygpnb gn29= ygpne/ygmnh gn30= ygmne/ygpnf gn31= 1.d0/ygpnf/ygmne gn32= 1.d0/ygpnf/ygmnh gn33= ygpne*ygmne gn34= ygpne/ygmne gn35= ygmnh/ygpnf gn36= ygmnh*ygpne gn37= ygpnb*ygmni gn38= ygpnc/ygpng gn39= 1.d0/ygpng/ygpnb gn40= ygmne/ygmnf gn41= ygmng*ygmne gn42= 1.d0/ygmnf/ygmnh gn43= ygmng/ygmnh gn44= ygmne/ygmng gn45= 1.d0/ygmng/ygmnh gn46= ygmnf/ygmnh gn47= ygmnf*ygmne gn48= ygmnh/ygmnf gn49= 1.d0/ygmng/ygmne gn50= ygmng*ygmnh gn51= 1.d0/ygmnf/ygmne gn52= ygmnh/ygmng gn53= ygmnf*ygmnh gn54= ygmnf/ygmne gn55= 1.d0/gpnb*gmni gn55= 1.d0/ygpnb*ygmni gn56= 1.d0/ygpnc/ygpng gn57= ygpnc*ygmni gn58= 1.d0/ygpnc*ygmni gn59= ygpnb/ygpng gn60= ygpnb*ygpng gn61= ygpnc/ygmni gn62= 1.d0/ygpnb/ygmni gn63= ygpnc*ygpng gn64= 1.d0/ygpnc*ygpng gn65= 1.d0/ygpnb*ygpng gn66= ygpnb/ygmni gn67= 1.d0/ygpnc/ygmni gn68= ygpne/ygmne gn69= 1.d0/ygpnf*ygmnh gn70= 1.d0/ygmne*ygmng * xc1r= 16.d0*(gn12*(y13*y24*y56-y13*y26*y45-y14* # y23*y56-y14*y25*y36+y14*y26*y35-y15*y24*y36+ # y16*y23*y45-y16*y24*y35+y36*y45)+gn13*(-y13* # y24*y56-y13*y25*y46+y13*y26*y45-y15*y23*y46+ # y15*y24*y36+y16*y23*y45-y16*y24*y35+y35*y46- # y36*y45)+gn14*(y15*y26+y16*y25-y56)+gn15*(y13* # y25+y15*y23+y23*y56+y25*y36-y26*y35-y35)+gn16* # (-y15*y26+y16*y25+y56)) xc1i= 64.d0*(w1*gn12*y56+w1*gn13*(-2.d0*y15+y56)+ # 2.d0*w5*gn38*(-y15+y56)-w6*gn14+w6*gn16+w7*gn13* # y26+2.d0*w8*gn39*y24*(y15-y56)-w8*gn13*y25+w9* # gn12*y24-w10*gn12*y23+w11*gn12*y16+w12*gn12*(-y15+ # 2.d0*y56)-w13*gn15+w14*gn13*y13) xc2r= 16.d0*(ogn55*(x13*x24*x56-x13*x26*x45-x14* # x23*x56-x14*x25*x36+x14*x26*x35-x15* # x24*x36+x16*x23*x45-x16*x24*x35+x36* # x45)+ogn57*(x15*x26+x16*x25-x56)+ogn58* # (x13*x25+x15*x23-2.d0*x23*x45+2.d0* # x24*x35-x35)-2.d0*ogn37*x25) xc2i= 64.d0*(s2*ogn58-s5*ogn55*x35+s8*ogn55*x25- # s10*ogn55*x23+s11*ogn55*x16-2.d0*s11* # ogn58+s13*ogn55*x14) cmod= xc1r*xc1r+xc1i*xc1i phr= (xc2r*xc1r+xc2i*xc1i)/cmod phie= (-xc2r*xc1i+xc2i*xc1r)/cmod * *-----NC helicity a-b) * *-----Pair production I: common part * p1abrc= 32.d0*(gn13*y13*y25*(y24-y45)+gn15*y25* # (-y23+y35)+gn16*y25*(y15-1.d0)) p1abic= 128.d0*gn13*y25*(w1-w7) * *-----Pair production II: common part * p2abrc= 16.d0*(gn12*(-y13*y24*y56+y13*y26*y45+ # y14*y23*y56-y14*y25*y36-y14*y26*y35+y15* # y24*y36-y16*y23*y45+y16*y24*y35-y36*y45)+ # gn13*(y13*y24*y56-y13*y25*y46-y13*y26*y45+ # y15*y23*y46-y15*y24*y36-y16*y23*y45+y16* # y24*y35-y35*y46+y36*y45)+gn14*(-y15*y26+ # y16*y25+y56)+gn15*(y13*y25-y15*y23-y23*y56+ # y25*y36+y26*y35+y35)+gn16*(y15*y26+y16*y25- # y56)) p2abic= 64.d0*(w1*gn13*y56-w2*gn15+w5*gn12*y35-w6* # gn16-w7*gn13*y26+w8*gn12*y25-w8*gn13*y25+w10* # gn12*y23-w11*gn12*y16-w13*gn12*y14+w13*gn15- # w14*gn13*y13) * *-----Pair production III: common part * p3abrc= 16.d0*(gn12*(y13*y24*y56-y13*y26*y45-y14* # y23*y56+y14*y25*y36+y14*y26*y35-y15*y24* # y36+y16*y23*y45-y16*y24*y35+y36*y45)+gn14* # (y15*y26-y16*y25-y56)+gn15*(-y13*y25+y15* # y23-2.d0*y23*y45+2.d0*y24*y35-y35)+2.d0* # gn37*y25) p3abic= 64.d0*(w2*gn15-w5*gn12*y35-w8*gn12*y25- # w10*gn12*y23+w11*gn12*y16-2.d0*w11*gn15+ # w13*gn12*y14) * *-----Pair production IV: common part * p4abrc= 32.d0*(gn13*y13*(-y23*y45-y24*y25+ # y24*y35)+gn15*y23*y25+gn16*(y15*y23+ # y25-y35)) p4abic= 128.d0*gn13*((y35-y25)*w1-y23*w7) * *-----NC helicity c-d) * *-----Pair production I: common part * p1cdrc= 32.d0*(gn3*(y13-y35)+gn6*y23* # (-y14+y45)+gn10*(1.d0-y25)) p1cdic= -128.d0*gn6*(w1+w11) * *-----Pair production II: common part * p2cdrc= 16.d0*(gn1*y24*y36-gn2*y26-gn3* # (y23+y36)+gn4*(-y13*y24*y56+y13* # y26*y45+y14*y23*y56-y14*y25*y36- # y14*y26*y35-y16*y23*y45+y16*y24* # y35+y36*y45)+gn5*(-y13*y25*y46+ # y13*y26*y45-y14*y23*y56+y14*y25* # y36-y14*y26*y35+y16*y23*y45+y35* # y46-y36*y45)+gn6*(y23*y46)+gn7* # (y13*y25+y13*y56-y16*y35-y35)+ # gn8*(-y16*y25+y56)+gn9*(y16*y25- # y56)-gn10*y26) p2cdic= 64.d0*(-w2*gn5*y46+w2*gn7-w4* # gn4*y36+w4*gn5*y36+w6*gn8-w6*gn9- # 2.d0*w7*gn5*y26-w8*gn4*y25+w8*gn5* # y25+w12*gn1-w12*gn6+w15*gn4-w15* # gn5) * *-----Pair production III: common part * p3cdrc= 16.d0*(-gn1*y24*y36+gn2*y26+gn3* # y23+gn4*(y13*y24*y56-y13*y26*y45-y14* # y23*y56+y14*y25*y36+y14*y26*y35+y16* # y23*y45-y16*y24*y35-y36*y45)+gn7*(- # y13*y25+2.d0*y13*y45-2.d0*y14*y35+ # y35)+gn9*(-y16*y25+y56)-2.d0*gn11) p3cdic= 64.d0*(-w2*gn7+w4*gn4*y36+w6*gn9- # 2.d0*w7*gn7+w8*gn4*y25-w12*gn1-w15* # gn4) * *-----Pair production IV: common part * p4cdrc= 32.d0*(-gn3*y13+gn5*y23*(y13* # y45-y14*y35)+gn6*y14*y23+gn8*(- # y13*y25+y35)-gn10) p4cdic= 128.d0*(w1*gn6-w2*gn8-w7*gn5*y23) * *-----NC helicity e-f) * *-----Pair production I: common part * p1efrc= 32.d0*(-gn48*y45-gn49*y14*y25+ # gn50*y15+gn52*(1.d0+y25)+gn54*y15) p1efic= 128.d0*(gn49-gn48)*w4 * *-----Pair production II: common part * p2efrc= 32.d0*(gn40*(y23*y46-y26*y34)+ # gn41*(y13*y26-y16*y23)-gn48*y46+ # gn50*y16+gn52*y26) p2efic= 128.d0*(w1*gn40*y26+w5*gn40* # y23-w5*gn48) * *-----Pair production III: common part * p3efrc= 32.d0*(gn49*y14*y25-gn52+2.d0* # gn53-gn54*y15) p3efic= -128.d0*w4*gn49 * *-----Pair production IV: common part * p4efrc= 32.d0*(gn40*(-y23*y46+y26*y34)+ # gn41*(-y13*y26+y16*y23)-gn48*y34+ # gn50*y13+gn52*y23) p4efic= 64.d0*(w1*gn42*(y34*y56+2.d0* # y35*y46)-w1*gn43*y56-w2*gn42*y34* # y46-w2*gn43*y46-w4*gn51*y34+2.d0* # w5*gn42*y34*y35-w5*gn43*y35-w6* # gn43*y34-w7*gn43*y26-w8*gn42*y25* # y34+2.d0*w8*gn43*y25-w9*gn43* # y34-w10*gn42*y23*y34+w10*gn43* # y23+w11*gn42*(y16*y34+2.d0*y46)- # w11*gn43*y16+2.d0*w13*gn45*y34- # 2.d0*w13*gn46-2.d0*w14*gn42* # y34+w14*gn43*y13+w15*gn42*y34- # 2.d0*w15*gn43*y13+2.d0*w15*gn45* # y23) * *-----NC helicity g-h) * *-----Pair production I: common part * p1ghrc= 32.d0*(gn31*y14*y25s-gn34*y24*y25- # gn35*y25+2.d0*gn36*y25) p1ghic= 128.d0*w4*gn31*y25 * *-----Pair production II: common part * p2ghrc= 32.d0*(gn30*(y13*y56-y16*y35)+gn33* # (-y13*y26+y16*y23)+gn35*(y16*y25-y56)+ # gn36*y26) p2ghic= 128.d0*(w2*gn30*y16+w6*gn30*y13-w6* # gn35+w7*gn32*(y16*y25-0.5d0*y25*y26)- # w8*gn29*y25+0.5d0*w8*gn32*y25s+w9*gn32* # y25*(y14-0.5d0*y24)+w10*gn32*y25*(-y13+ # 0.5d0*y23)+0.5d0*w11*gn32*y16*y25-0.5d0* # w12*gn29*y25+0.5d0*w13*gn32*y14*y25- # 0.5d0*w14*gn32*y13*y25) * *-----Pair production III: common part * p3ghrc= 32.d0*(-gn31*y14*y25s+gn34*y24*y25+ # gn35*(y14*y25+y25-y45)+gn36*y24) p3ghic= 128.d0*w4*(gn35-gn31*y25) * *-----Pair production IV: common part * p4ghrc= 32.d0*(gn30*(-y13*y56+y16*y35)+ # gn33*(y13*y26-y16*y23)+gn35*(y13* # y25-y35)+gn36*y23) p4ghic= 128.d0*(-w2*gn30*y16+w2*gn35-w6* # gn30*y13) * *-----complete diagrams, epsilon real and imag parts separated: * *-----compensating single gluon propagators * gpcfr= ysp gmcfr= ysm * *-----Compensating double gluon propagator * gtcfr= ysp*ysm sdtu= ysp*ysm pnp= ytw-ysm ypn= ytw+ysp-1.d0 * *-----complete diagrams, epsilon real and imag parts separated: * *-----All PP1-PP2 gamma-gluon * cotggm= conc(6) cp1ggr= cotggm/ypfpb*gpcfr cp2ggr= -cotggm/ypfp*gpcfr * p1aggr= -cp1ggr*p1abrc p1aggie= -cp1ggr*p1abic * p1bggr= -p1aggr p1bggie= p1aggie * p1cggr= -cp1ggr*p1cdrc p1cggie= -cp1ggr*p1cdic * p1dggr= -p1cggr p1dggie= p1cggie * p1eggr= -cp1ggr*p1efrc p1eggie= -cp1ggr*p1efic * p1fggr= -p1eggr p1fggie= p1eggie * p1gggr= -cp1ggr*p1ghrc p1gggie= -cp1ggr*p1ghic * p1hggr= -p1gggr p1hggie= p1gggie * p2aggr= -cp2ggr*p2abrc p2aggie= -cp2ggr*p2abic * p2bggr= -p2aggr p2bggie= p2aggie * p2cggr= -cp2ggr*p2cdrc p2cggie= -cp2ggr*p2cdic * p2dggr= -p2cggr p2dggie= p2cggie * p2eggr= -cp2ggr*p2efrc p2eggie= -cp2ggr*p2efic * p2fggr= -p2eggr p2fggie= p2eggie * p2gggr= -cp2ggr*p2ghrc p2gggie= -cp2ggr*p2ghic * p2hggr= -p2gggr p2hggie= p2gggie * *-----All PP1 Z-gluon * cp1zg= conc(4)/ypfpb * do i=1,4 hfr(i)= hch(i+4)*cp1zg*gpcfr enddo * ap1azgr= hfr(1)*p1abrc ap1azgie= hfr(1)*p1abic p1azgr= ap1azgr*rsz p1azgre= -ap1azgie*aisz p1azgie= ap1azgie*rsz p1azgi= ap1azgr*aisz * ap1bzgr= -hfr(2)*p1abrc ap1bzgie= hfr(2)*p1abic p1bzgr= ap1bzgr*rsz p1bzgre= -ap1bzgie*aisz p1bzgie= ap1bzgie*rsz p1bzgi= ap1bzgr*aisz * ap1czgr= hfr(3)*p1cdrc ap1czgie= hfr(3)*p1cdic p1czgr= ap1czgr*rsz p1czgre= -ap1czgie*aisz p1czgie= ap1czgie*rsz p1czgi= ap1czgr*aisz * ap1dzgr= -hfr(4)*p1cdrc ap1dzgie= hfr(4)*p1cdic p1dzgr= ap1dzgr*rsz p1dzgre= -ap1dzgie*aisz p1dzgie= ap1dzgie*rsz p1dzgi= ap1dzgr*aisz * ap1ezgr= hfr(3)*p1efrc ap1ezgie= hfr(3)*p1efic p1ezgr= ap1ezgr*rsz p1ezgre= -ap1ezgie*aisz p1ezgie= ap1ezgie*rsz p1ezgi= ap1ezgr*aisz * ap1fzgr= -hfr(4)*p1efrc ap1fzgie= hfr(4)*p1efic p1fzgr= ap1fzgr*rsz p1fzgre= -ap1fzgie*aisz p1fzgie= ap1fzgie*rsz p1fzgi= ap1fzgr*aisz * ap1gzgr= hfr(1)*p1ghrc ap1gzgie= hfr(1)*p1ghic p1gzgr= ap1gzgr*rsz p1gzgre= -ap1gzgie*aisz p1gzgie= ap1gzgie*rsz p1gzgi= ap1gzgr*aisz * ap1hzgr= -hfr(2)*p1ghrc ap1hzgie= hfr(2)*p1ghic p1hzgr= ap1hzgr*rsz p1hzgre= -ap1hzgie*aisz p1hzgie= ap1hzgie*rsz p1hzgi= ap1hzgr*aisz * *-----All PP2 Z-gluon * cp2zg= -conc(4)/ypfp * do i=1,4 hgr(i)= hch(i+4)*cp2zg*gpcfr enddo * ap2azgr= hgr(1)*p2abrc ap2azgie= hgr(1)*p2abic p2azgr= ap2azgr*rsz p2azgre= -ap2azgie*aisz p2azgie= ap2azgie*rsz p2azgi= ap2azgr*aisz * ap2bzgr= -hgr(2)*p2abrc ap2bzgie= hgr(2)*p2abic p2bzgr= ap2bzgr*rsz p2bzgre= -ap2bzgie*aisz p2bzgie= ap2bzgie*rsz p2bzgi= ap2bzgr*aisz * ap2czgr= hgr(3)*p2cdrc ap2czgie= hgr(3)*p2cdic p2czgr= ap2czgr*rsz p2czgre= -ap2czgie*aisz p2czgie= ap2czgie*rsz p2czgi= ap2czgr*aisz * ap2dzgr= -hgr(4)*p2cdrc ap2dzgie= hgr(4)*p2cdic p2dzgr= ap2dzgr*rsz p2dzgre= -ap2dzgie*aisz p2dzgie= ap2dzgie*rsz p2dzgi= ap2dzgr*aisz * ap2ezgr= hgr(3)*p2efrc ap2ezgie= hgr(3)*p2efic p2ezgr= ap2ezgr*rsz p2ezgre= -ap2ezgie*aisz p2ezgie= ap2ezgie*rsz p2ezgi= ap2ezgr*aisz * ap2fzgr= -hgr(4)*p2efrc ap2fzgie= hgr(4)*p2efic p2fzgr= ap2fzgr*rsz p2fzgre= -ap2fzgie*aisz p2fzgie= ap2fzgie*rsz p2fzgi= ap2fzgr*aisz * ap2gzgr= hgr(1)*p2ghrc ap2gzgie= hgr(1)*p2ghic p2gzgr= ap2gzgr*rsz p2gzgre= -ap2gzgie*aisz p2gzgie= ap2gzgie*rsz p2gzgi= ap2gzgr*aisz * ap2hzgr= -hgr(2)*p2ghrc ap2hzgie= hgr(2)*p2ghic p2hzgr= ap2hzgr*rsz p2hzgre= -ap2hzgie*aisz p2hzgie= ap2hzgie*rsz p2hzgi= ap2hzgr*aisz * *-----All PP3-PP4 gamma-gluon * cp3ggr= conc(7)/ypf*gmcfr cp4ggr= -conc(7)/ypfb*gmcfr * p3aggr= cp3ggr*p3abrc p3aggie= cp3ggr*p3abic * p3bggr= -p3aggr p3bggie= p3aggie * p3cggr= cp3ggr*p3cdrc p3cggie= cp3ggr*p3cdic * p3dggr= -p3cggr p3dggie= p3cggie * p3eggr= cp3ggr*p3efrc p3eggie= cp3ggr*p3efic * p3fggr= -p3eggr p3fggie= p3eggie * p3gggr= cp3ggr*p3ghrc p3gggie= cp3ggr*p3ghic * p3hggr= -p3gggr p3hggie= p3gggie * p4aggr= cp4ggr*p4abrc p4aggie= cp4ggr*p4abic * p4bggr= -p4aggr p4bggie= p4aggie * p4cggr= cp4ggr*p4cdrc p4cggie= cp4ggr*p4cdic * p4dggr= -p4cggr p4dggie= p4cggie * p4eggr= cp4ggr*p4efrc p4eggie= cp4ggr*p4efic * p4fggr= -p4eggr p4fggie= p4eggie * p4gggr= cp4ggr*p4ghrc p4gggie= cp4ggr*p4ghic * p4hggr= -p4gggr p4hggie= p4gggie * *-----All PP3 Z-gluon * cp3zg= -conc(4)/ypf * do i=1,4 hnr(i)= hch(i)*cp3zg*gmcfr enddo * ap3azgr= hnr(1)*p3abrc ap3azgie= hnr(1)*p3abic p3azgr= ap3azgr*rsz p3azgre= -ap3azgie*aisz p3azgie= ap3azgie*rsz p3azgi= ap3azgr*aisz * ap3bzgr= -hnr(2)*p3abrc ap3bzgie= hnr(2)*p3abic p3bzgr= ap3bzgr*rsz p3bzgre= -ap3bzgie*aisz p3bzgie= ap3bzgie*rsz p3bzgi= ap3bzgr*aisz * ap3czgr= hnr(3)*p3cdrc ap3czgie= hnr(3)*p3cdic p3czgr= ap3czgr*rsz p3czgre= -ap3czgie*aisz p3czgie= ap3czgie*rsz p3czgi= ap3czgr*aisz * ap3dzgr= -hnr(4)*p3cdrc ap3dzgie= hnr(4)*p3cdic p3dzgr= ap3dzgr*rsz p3dzgre= -ap3dzgie*aisz p3dzgie= ap3dzgie*rsz p3dzgi= ap3dzgr*aisz * ap3ezgr= hnr(1)*p3efrc ap3ezgie= hnr(1)*p3efic p3ezgr= ap3ezgr*rsz p3ezgre= -ap3ezgie*aisz p3ezgie= ap3ezgie*rsz p3ezgi= ap3ezgr*aisz * ap3fzgr= -hnr(2)*p3efrc ap3fzgie= hnr(2)*p3efic p3fzgr= ap3fzgr*rsz p3fzgre= -ap3fzgie*aisz p3fzgie= ap3fzgie*rsz p3fzgi= ap3fzgr*aisz * ap3gzgr= hnr(3)*p3ghrc ap3gzgie= hnr(3)*p3ghic p3gzgr= ap3gzgr*rsz p3gzgre= -ap3gzgie*aisz p3gzgie= ap3gzgie*rsz p3gzgi= ap3gzgr*aisz * ap3hzgr= -hnr(4)*p3ghrc ap3hzgie= hnr(4)*p3ghic p3hzgr= ap3hzgr*rsz p3hzgre= -ap3hzgie*aisz p3hzgie= ap3hzgie*rsz p3hzgi= ap3hzgr*aisz * *-----All PP4 Z-gluon * cp4zg= conc(4)/ypfb * do i=1,4 hor(i)= hch(i)*cp4zg*gmcfr enddo * ap4azgr= hor(1)*p4abrc ap4azgie= hor(1)*p4abic p4azgr= ap4azgr*rsz p4azgre= -ap4azgie*aisz p4azgie= ap4azgie*rsz p4azgi= ap4azgr*aisz * ap4bzgr= -hor(2)*p4abrc ap4bzgie= hor(2)*p4abic p4bzgr= ap4bzgr*rsz p4bzgre= -ap4bzgie*aisz p4bzgie= ap4bzgie*rsz p4bzgi= ap4bzgr*aisz * ap4czgr= hor(3)*p4cdrc ap4czgie= hor(3)*p4cdic p4czgr= ap4czgr*rsz p4czgre= -ap4czgie*aisz p4czgie= ap4czgie*rsz p4czgi= ap4czgr*aisz * ap4dzgr= -hor(4)*p4cdrc ap4dzgie= hor(4)*p4cdic p4dzgr= ap4dzgr*rsz p4dzgre= -ap4dzgie*aisz p4dzgie= ap4dzgie*rsz p4dzgi= ap4dzgr*aisz * ap4ezgr= hor(1)*p4efrc ap4ezgie= hor(1)*p4efic p4ezgr= ap4ezgr*rsz p4ezgre= -ap4ezgie*aisz p4ezgie= ap4ezgie*rsz p4ezgi= ap4ezgr*aisz * ap4fzgr= -hor(2)*p4efrc ap4fzgie= hor(2)*p4efic p4fzgr= ap4fzgr*rsz p4fzgre= -ap4fzgie*aisz p4fzgie= ap4fzgie*rsz p4fzgi= ap4fzgr*aisz * ap4gzgr= hor(3)*p4ghrc ap4gzgie= hor(3)*p4ghic p4gzgr= ap4gzgr*rsz p4gzgre= -ap4gzgie*aisz p4gzgie= ap4gzgie*rsz p4gzgi= ap4gzgr*aisz * ap4hzgr= -hor(4)*p4ghrc ap4hzgie= hor(4)*p4ghic p4hzgr= ap4hzgr*rsz p4hzgre= -ap4hzgie*aisz p4hzgie= ap4hzgie*rsz p4hzgi= ap4hzgr*aisz * darn= (p1aggr+p1azgr+p2aggr+p2azgr+ # p3aggr+p3azgr+p4aggr+p4azgr) daren= (p1azgre+p2azgre+p3azgre+p4azgre) dain= (p1azgi+p2azgi+p3azgi+p4azgi) daien= (p1aggie+p1azgie+p2aggie+p2azgie+ # p3aggie+p3azgie+p4aggie+p4azgie) * dbrn= (p1bggr+p1bzgr+p2bggr+p2bzgr+ # p3bggr+p3bzgr+p4bggr+p4bzgr) dbren= (p1bzgre+p2bzgre+p3bzgre+p4bzgre) dbin= (p1bzgi+p2bzgi+p3bzgi+p4bzgi) dbien= (p1bggie+p1bzgie+p2bggie+p2bzgie+ # p3bggie+p3bzgie+p4bggie+p4bzgie) * dcrn= (p1cggr+p1czgr+p2cggr+p2czgr+ # p3cggr+p3czgr+p4cggr+p4czgr) dcren= (p1czgre+p2czgre+p3czgre+p4czgre) dcin= (p1czgi+p2czgi+p3czgi+p4czgi) dcien= (p1cggie+p1czgie+p2cggie+p2czgie+ # p3cggie+p3czgie+p4cggie+p4czgie) * ddrn= (p1dggr+p1dzgr+p2dggr+p2dzgr+ # p3dggr+p3dzgr+p4dggr+p4dzgr) ddren= (p1dzgre+p2dzgre+p3dzgre+p4dzgre) ddin= (p1dzgi+p2dzgi+p3dzgi+p4dzgi) ddien= (p1dggie+p1dzgie+p2dggie+p2dzgie+ # p3dggie+p3dzgie+p4dggie+p4dzgie) * dern= (p1eggr+p1ezgr+p2eggr+p2ezgr+ # p3eggr+p3ezgr+p4eggr+p4ezgr) deren= (p1ezgre+p2ezgre+p3ezgre+p4ezgre) dein= (p1ezgi+p2ezgi+p3ezgi+p4ezgi) deien= (p1eggie+p1ezgie+p2eggie+p2ezgie+ # p3eggie+p3ezgie+p4eggie+p4ezgie) * dfrn= (p1fggr+p1fzgr+p2fggr+p2fzgr+ # p3fggr+p3fzgr+p4fggr+p4fzgr) dfren= (p1fzgre+p2fzgre+p3fzgre+p4fzgre) dfin= (p1fzgi+p2fzgi+p3fzgi+p4fzgi) dfien= (p1fggie+p1fzgie+p2fggie+p2fzgie+ # p3fggie+p3fzgie+p4fggie+p4fzgie) * dgrn= (p1gggr+p1gzgr+p2gggr+p2gzgr+ # p3gggr+p3gzgr+p4gggr+p4gzgr) dgren= (p1gzgre+p2gzgre+p3gzgre+p4gzgre) dgin= (p1gzgi+p2gzgi+p3gzgi+p4gzgi) dgien= (p1gggie+p1gzgie+p2gggie+p2gzgie+ # p3gggie+p3gzgie+p4gggie+p4gzgie) * dhrn= (p1hggr+p1hzgr+p2hggr+p2hzgr+ # p3hggr+p3hzgr+p4hggr+p4hzgr) dhren= (p1hzgre+p2hzgre+p3hzgre+p4hzgre) dhin= (p1hzgi+p2hzgi+p3hzgi+p4hzgi) dhien= (p1hggie+p1hzgie+p2hggie+p2hzgie+ # p3hggie+p3hzgie+p4hggie+p4hzgie) * *-----CC and NC diagrams are comensated with double Z and W propagators * adarn= phr*darn-phie*daien adaren= phr*daren-phie*dain adaien= phr*daien+phie*darn adain= phr*dain+phie*daren * dar= gtcfr*darc dare= gtcfr*darec daie= gtcfr*daiec dai= gtcfr*daic * dar3= gtcfr*darc3 dare3= gtcfr*darec3 daie3= gtcfr*daiec3 dai3= gtcfr*daic3 * dbr11= gtcfr*dbrc dbre11= gtcfr*dbrec dbie11= gtcfr*dbiec dbi11= gtcfr*dbic * dbr24= wtcfr*adarn-wtcfi*adain dbre24= wtcfr*adaren-wtcfi*adaien dbie24= wtcfr*adaien+wtcfi*adaren dbi24= wtcfr*adain+wtcfi*adarn * dbr= gtcfr*dbrc- # wtcfr*adarn+wtcfi*adain dbre= gtcfr*dbrec- # wtcfr*adaren+wtcfi*adaien dbie= gtcfr*dbiec- # wtcfr*adaien-wtcfi*adaren dbi= gtcfr*dbic- # wtcfr*adain-wtcfi*adarn * dbr3= gtcfr*dbrc3 dbre3= gtcfr*dbrec3 dbie3= gtcfr*dbiec3 dbi3= gtcfr*dbic3 * dfr= wtcfr*dbrn-wtcfi*dbin dfre= wtcfr*dbren-wtcfi*dbien dfie= wtcfr*dbien+wtcfi*dbren dfi= wtcfr*dbin+wtcfi*dbrn * dgr= wtcfr*dcrn-wtcfi*dcin dgre= wtcfr*dcren-wtcfi*dcien dgie= wtcfr*dcien+wtcfi*dcren dgi= wtcfr*dcin+wtcfi*dcrn * dhr= wtcfr*ddrn-wtcfi*ddin dhre= wtcfr*ddren-wtcfi*ddien dhie= wtcfr*ddien+wtcfi*ddren dhi= wtcfr*ddin+wtcfi*ddrn * dir= wtcfr*dern-wtcfi*dein dire= wtcfr*deren-wtcfi*deien diie= wtcfr*deien+wtcfi*deren dii= wtcfr*dein+wtcfi*dern * dlr= wtcfr*dfrn-wtcfi*dfin dlre= wtcfr*dfren-wtcfi*dfien dlie= wtcfr*dfien+wtcfi*dfren dli= wtcfr*dfin+wtcfi*dfrn * dmr= wtcfr*dhrn-wtcfi*dhin dmre= wtcfr*dhren-wtcfi*dhien dmie= wtcfr*dhien+wtcfi*dhren dmi= wtcfr*dhin+wtcfi*dhrn * dnr= wtcfr*dgrn-wtcfi*dgin dnre= wtcfr*dgren-wtcfi*dgien dnie= wtcfr*dgien+wtcfi*dgren dni= wtcfr*dgin+wtcfi*dgrn * fgg= pi*als/g2/sqrt(chf2*chfp2)/sth2 fggs= fgg*fgg das= 0.d0 qcdc= 1.d0+qcdjn fggs= fggs*qcdc dbs= 32.d0*(fggs*dbr24*dbr24-fgg*dbr11*dbr24+ # fggs*dbre24*dbre24-fgg*dbre11*dbre24+ # fggs*dbie24*dbie24-fgg*dbie11*dbie24+ # fggs*dbi24*dbi24-fgg*dbi11*dbi24) dfs= 32.d0*fggs*(dfr*dfr+dfre*dfre+ # dfie*dfie+dfi*dfi) dgs= 32.d0*fggs*(dgr*dgr+dgre*dgre+ # dgie*dgie+dgi*dgi) dhs= 32.d0*fggs*(dhr*dhr+dhre*dhre+ # dhie*dhie+dhi*dhi) dis= 32.d0*fggs*(dir*dir+dire*dire+ # diie*diie+dii*dii) dls= 32.d0*fggs*(dlr*dlr+dlre*dlre+ # dlie*dlie+dli*dli) dms= 32.d0*fggs*(dmr*dmr+dmre*dmre+ # dmie*dmie+dmi*dmi) dns= 32.d0*fggs*(dnr*dnr+dnre*dnre+ # dnie*dnie+dni*dni) * 4 if(iz.eq.0) then do il=1,9 dpxs(ix,it,itt,il)= 0.d0 enddo iz= 1 else tjac= ujc*vjc*smjc*spjc*sujc*sdjc* # sfjc*twjc*t1jc*vv tjacp= tjac*pmjac*ppjac/sdtu/sdtu* # stf/s dpxs(ix,it,itt,1)= tjacp*das dpxs(ix,it,itt,2)= tjacp*dbs dpxs(ix,it,itt,3)= tjacp*dfs dpxs(ix,it,itt,4)= tjacp*dgs dpxs(ix,it,itt,5)= tjacp*dhs dpxs(ix,it,itt,6)= tjacp*dis dpxs(ix,it,itt,7)= tjacp*dls dpxs(ix,it,itt,8)= tjacp*dms dpxs(ix,it,itt,9)= tjacp*dns endif * *-----end of ix loop * enddo * 5 if(iz.eq.0) then do i=1,9 do ix=1,2 epxs(ix,it,itt,i)= 0.d0 enddo enddo iz= 1 else do i=1,9 do ix=1,2 epxs(ix,it,itt,i)= dpxs(ix,it,itt,i) enddo enddo endif * *-----end of itt loop * enddo * do i=1,9 cpxs(it,i)= 0.d0 do itt=1,ittm cpxs(it,i)= cpxs(it,i)+epxs(1,it,itt,i)+ # epxs(2,it,itt,i) enddo enddo * 2 if(iz.eq.0) then do il=1,9 bpxs(it,il)= 0.d0 enddo iz= 1 else do il=1,9 bpxs(it,il)= cpxs(it,il) enddo endif * *-----end on it loop * enddo * 1 if(iz.eq.0) then do il=1,9 apxs(il)= 0.d0 enddo iz= 1 else do il=1,9 apxs(il)= bpxs(1,il)+bpxs(2,il) enddo endif * tapxs= 0.d0 do il=1,9 tapxs= tapxs+apxs(il) enddo if(tapxs.lt.0.d0) then ifz(43)= ifz(43)+1 resf= 0.d0 else resf= tapxs endif * wtoxs35g= tfact*resf * if(om.eq.'g') then if(osm.eq.'n') then jp= iwtopos(ndim,x) if(wtoxs35g.gt.xshmx(jp)) then xshmx(jp)= wtoxs35g do l=1,9 xmxh(jp,l)= x(l) enddo endif endif xaph(1)= xm xaph(2)= xp xaph(3)= sm xaph(4)= sp xaph(5)= su xaph(6)= sd xaph(7)= sf xaph(8)= tw xaph(9)= t1 xaph(10)= t3 endif * return end * *-----WTOXSN64----------------------------------------------------------- * real*8 function wtoxsn64(ndim,x) implicit real*8 (a-h,o-z) * character*1,opeak,oqcd,om,osm,ostop,omssm,opglu,oint character*2,ofs character*4,otype * parameter(ninv=10,npos=512,ifmax=10000) * common/wtmod/om common/wtmp/zrm common/wtfs/ofs common/wtqcd/als common/wtoi/oint common/wtii/iint common/wtim/ostop common/wtsmod/osm common/wtps/opeak common/wtkount/ik common/wtdis/dist common/wtqcdz/alsz common/wtsp/psg(4) common/wtistrf/isf common/wtaqcd/oqcd common/wtsf/ix0,it0 common/wtpqcd/opglu common/wtmssmo/omssm common/wtchi/hch(36) common/wtipt/ifz(44) common/wtnf/ifl(npos) common/wticuts/iac(4) common/wtisa/isaa,isab common/wtochannel/otype common/wthx/xshmx(npos) common/wtmatx/colf(8,8) common/wtparh/xaph(ninv) common/wttc/itc,itcc,itcn common/wtpmxh/xmxh(npos,9) common/wtstor/stry(npos,ifmax) common/wtncc/chf2,chfp2,conc(10) common/wtmssmi/am,tbeta,rmu,scalm,bat,bab common/wtnclr/vel,ver,velr,vfl,vfr,vfpl,vfpr common/wtnchannel/chf,chfp,tif,tifp,fcun,fcdn common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi common/wtfmass/em,rmm,tm,rnm,uqm,dqm,cqm,sqm,bqm,tqm,dmy common/wtcpar/alpha,hbet,hbeti,omhb,eob,d0gl,g8,tfact,pih,alw, # eta,feta,beta,g2,tfacth common/wtapar/ars,s,rwm,rwm2,rwg,rwmg,swg,swgs,opswgs,sth2,cth2, # hsth2,tsth2,scth2,asth2,tth2,rzm,rzm2,rzg,rzmg,szg, # szgs,opszgs,sth4,cth4,ve,vf,vfp,rbqm2,rszw,rszw2, # s0w,s0z common/wtsubreg/dsm,usm,dsp,usp,rl(6),rr(6),srl(6),sdsm,sdsp,vvl1, # vvl2,vvl3,ul,omul,suml common/wtcuts/aim(6),bim(6),ae(4),asa(4),bsa(4),afsa(6),bfsa(6), # ombsa(4),opbsa(4),teq,rae(4),omasa(4),opasa(4), # sg12,cg12,sg13,cg13,sg14,cg14,sg23,cg23,sg24, # cg24,sg34,cg34,sct120,sct130,sct140,sct230, # sct240,sct340,sgam(4),cgam(4) common/wtmssm/ams,shm,shms,bhm,bhms,sbeta,cbeta,salpha,calpha, # sbma,cbma,rshm,rshm2,rshg,rshmg,sshg,sshgs, # opsshgs,rbhm,rbhm2,rbhg,rbhmg,sbhg,sbhgs,opsbhgs, # ram,ram2,rag,ramg,sag,sags,opsags * dimension flow(4) dimension tgn(16) dimension x(ndim) dimension bt1(2),bt2(2) dimension rru1(2),rru2(2) dimension sfur(2),sflr(2) dimension ret1(2),ret2(2) dimension ee(5),e(5),sg(5) dimension rrr(6),rrl(6),srrl(6) dimension bl(4),xbl(4),ss(4),cs(4) dimension dpxs(2,2,2),epxs(2,2,2),cpxs(2),bpxs(2) dimension rr1(2),rr2(2),rs1(2),rs2(2),rtp(2),rtm(2) dimension har(4),hdr(4),her(4),hfr(4),hgr(4),hhr(8), # hir(8),hapr(4),hc(8) dimension hai(4),hdi(4),hei(4),hfi(4),hgi(4),hhi(8), # hii(8),hapi(4) * dimension dsh(12) dimension dcfr(4),dcfi(4) dimension xcrc(4,6),xcic(4,6) dimension ycrc(4,12),ycic(4,12) dimension zcrc(4,12),zcic(4,12) dimension dd3hr(4),dd3hre(4),dd3hie(4),dd3hi(4) dimension dd4hr(4),dd4hre(4),dd4hie(4),dd4hi(4) dimension aephr(4,12),aephie(4,12),omephr(4,12),sephie(4,12), # tephr(4,12),ephie(4,12),ephr(4,12) dimension crc(4,6),cic(4,6),p1rc(4,6),p1ic(4,6) dimension p2rc(4,6),p2ic(4,6) dimension cggr(4,12),cggre(4,12),cggie(4,12),cggi(4,12) dimension cgzr(4,12),cgzre(4,12),cgzie(4,12),cgzi(4,12) dimension czgr(4,12),czgre(4,12),czgie(4,12),czgi(4,12) dimension czzr(4,12),czzie(4,12) dimension p1ggr(4,12),p1ggre(4,12),p1ggie(4,12),p1ggi(4,12) dimension p1gzr(4,12),p1gzre(4,12),p1gzie(4,12),p1gzi(4,12) dimension p1zgr(4,12),p1zgre(4,12),p1zgie(4,12),p1zgi(4,12) dimension p1zzr(4,12),p1zzre(4,12),p1zzie(4,12),p1zzi(4,12) dimension p2ggr(4,12),p2ggre(4,12),p2ggie(4,12),p2ggi(4,12) dimension p2gzr(4,12),p2gzre(4,12),p2gzie(4,12),p2gzi(4,12) dimension p2zgr(4,12),p2zgre(4,12),p2zgie(4,12),p2zgi(4,12) dimension p2zzr(4,12),p2zzre(4,12),p2zzie(4,12),p2zzi(4,12) dimension ap1azgr(4,12),ap1azgre(4,12),ap1azgie(4,12), # ap1azgi(4,12) dimension ap1bzgr(4,12),ap1bzgre(4,12),ap1bzgie(4,12), # ap1bzgi(4,12) dimension ap1czgr(4,12),ap1czgre(4,12),ap1czgie(4,12), # ap1czgi(4,12) dimension ap1dzgr(4,12),ap1dzgre(4,12),ap1dzgie(4,12), # ap1dzgi(4,12) dimension ap1ezgr(4,12),ap1ezgre(4,12),ap1ezgie(4,12), # ap1ezgi(4,12) dimension ap1fzgr(4,12),ap1fzgre(4,12),ap1fzgie(4,12), # ap1fzgi(4,12) dimension ap1gzgr(4,12),ap1gzgre(4,12),ap1gzgie(4,12), # ap1gzgi(4,12) dimension ap1hzgr(4,12),ap1hzgre(4,12),ap1hzgie(4,12), # ap1hzgi(4,12) dimension ap2azgr(4,12),ap2azgre(4,12),ap2azgie(4,12), # ap2azgi(4,12) dimension ap2bzgr(4,12),ap2bzgre(4,12),ap2bzgie(4,12), # ap2bzgi(4,12) dimension ap2czgr(4,12),ap2czgre(4,12),ap2czgie(4,12), # ap2czgi(4,12) dimension ap2dzgr(4,12),ap2dzgre(4,12),ap2dzgie(4,12), # ap2dzgi(4,12) dimension ap2ezgr(4,12),ap2ezgre(4,12),ap2ezgie(4,12), # ap2ezgi(4,12) dimension ap2fzgr(4,12),ap2fzgre(4,12),ap2fzgie(4,12), # ap2fzgi(4,12) dimension ap2gzgr(4,12),ap2gzgre(4,12),ap2gzgie(4,12), # ap2gzgi(4,12) dimension ap2hzgr(4,12),ap2hzgre(4,12),ap2hzgie(4,12), # ap2hzgi(4,12) dimension ap1azzr(4,12),ap1azzre(4,12),ap1azzie(4,12), # ap1azzi(4,12) dimension ap1bzzr(4,12),ap1bzzre(4,12),ap1bzzie(4,12), # ap1bzzi(4,12) dimension ap1czzr(4,12),ap1czzre(4,12),ap1czzie(4,12), # ap1czzi(4,12) dimension ap1dzzr(4,12),ap1dzzre(4,12),ap1dzzie(4,12), # ap1dzzi(4,12) dimension ap1ezzr(4,12),ap1ezzre(4,12),ap1ezzie(4,12), # ap1ezzi(4,12) dimension ap1fzzr(4,12),ap1fzzre(4,12),ap1fzzie(4,12), # ap1fzzi(4,12) dimension ap1gzzr(4,12),ap1gzzre(4,12),ap1gzzie(4,12), # ap1gzzi(4,12) dimension ap1hzzr(4,12),ap1hzzre(4,12),ap1hzzie(4,12), # ap1hzzi(4,12) dimension ap2azzr(4,12),ap2azzre(4,12),ap2azzie(4,12), # ap2azzi(4,12) dimension ap2bzzr(4,12),ap2bzzre(4,12),ap2bzzie(4,12), # ap2bzzi(4,12) dimension ap2czzr(4,12),ap2czzre(4,12),ap2czzie(4,12), # ap2czzi(4,12) dimension ap2dzzr(4,12),ap2dzzre(4,12),ap2dzzie(4,12), # ap2dzzi(4,12) dimension ap2ezzr(4,12),ap2ezzre(4,12),ap2ezzie(4,12), # ap2ezzi(4,12) dimension ap2fzzr(4,12),ap2fzzre(4,12),ap2fzzie(4,12), # ap2fzzi(4,12) dimension ap2gzzr(4,12),ap2gzzre(4,12),ap2gzzie(4,12), # ap2gzzi(4,12) dimension ap2hzzr(4,12),ap2hzzre(4,12),ap2hzzie(4,12), # ap2hzzi(4,12) dimension adhelr(4,12),adhelre(4,12),adhelie(4,12),adheli(4,12) dimension dhelr(12),dhelre(12),dhelie(12),dheli(12) dimension pcggr(4,12),pcgzr(4,12),pczgr(4,12),pczzr(4,12), # pp1zzr(4,12),pp1zpr(4,12),pp1zgr(4,12),pp1pzr(4,12), # pp1ppr(4,12),pp1pgr(4,12),pp2zzr(4,12),pp2zpr(4,12), # pp2zgr(4,12),pp2pzr(4,12),pp2ppr(4,12),pp2pgr(4,12) dimension pcggre(4,12),pcgzre(4,12),pczgre(4,12),pczzre(4,12), # pp1zzre(4,12),pp1zpre(4,12),pp1zgre(4,12),pp1pzre(4,12), # pp1ppre(4,12),pp1pgre(4,12),pp2zzre(4,12),pp2zpre(4,12), # pp2zgre(4,12),pp2pzre(4,12),pp2ppre(4,12),pp2pgre(4,12) dimension pcggie(4,12),pcgzie(4,12),pczgie(4,12),pczzie(4,12), # pp1zzie(4,12),pp1zpie(4,12),pp1zgie(4,12),pp1pzie(4,12), # pp1ppie(4,12),pp1pgie(4,12),pp2zzie(4,12),pp2zpie(4,12), # pp2zgie(4,12),pp2pzie(4,12),pp2ppie(4,12),pp2pgie(4,12) dimension pcggi(4,12),pcgzi(4,12),pczgi(4,12),pczzi(4,12), # pp1zzi(4,12),pp1zpi(4,12),pp1zgi(4,12),pp1pzi(4,12), # pp1ppi(4,12),pp1pgi(4,12),pp2zzi(4,12),pp2zpi(4,12), # pp2zgi(4,12),pp2pzi(4,12),pp2ppi(4,12),pp2pgi(4,12) dimension qdr(8,12),qdre(8,12),qdie(8,12),qdi(8,12) dimension fqdr(8,12),fqdre(8,12),fqdie(8,12),fqdi(8,12) * data ec2/-0.4999999963d0/,ec4/0.0416666418d0/, # ec6/-0.0013888397d0/,ec8/0.0000247609d0/, # ec10/-0.0000002605d0/ * external c02ajf,s09aaf,s07aaf external s21bbf,s21caf * *-----the order of integration is: * u, v, m_-^2, m_+^2, M_0^2, m_0^2, m^2, t_w, t_1 * * m_{+/-}^2 transformed for the resonating peaks * M_0^2,m_0^2 transformed for the resonating peaks * m^2 and t_1 transformed for the jacobian peaks * do ix=1,2 do it=1,2 do itt=1,2 dpxs(ix,it,itt)= 0.d0 enddo enddo enddo do it=1,2 cpxs(it)= 0.d0 bpxs(it)= 0.d0 enddo * if(ofs.eq.'qq'.and.ndim.eq.9) then if(opglu.eq.'y') then cfgg= pi*als/g2/chf2/sth2 else cfgg= 0.d0 endif else cfgg= 0.d0 endif if(ofs.eq.'qq'.and.oqcd.eq.'y') then qcdjac= (1.d0+alsz/pi)*(1.d0+alsz/pi) else qcdjac= 1.d0 endif * do ip=1,4 do ii=1,6 crc(ip,ii)= 0.d0 cic(ip,ii)= 0.d0 xcrc(ip,ii)= 0.d0 xcic(ip,ii)= 0.d0 p1rc(ip,ii)= 0.d0 p1ic(ip,ii)= 0.d0 p2rc(ip,ii)= 0.d0 p2ic(ip,ii)= 0.d0 cggr(ip,ii)=0.d0 cgzr(ip,ii)=0.d0 czgr(ip,ii)= 0.d0 czzr(ip,ii)= 0.d0 p1ggr(ip,ii)= 0.d0 p2ggr(ip,ii)= 0.d0 p1gzr(ip,ii)= 0.d0 p2gzr(ip,ii)= 0.d0 p1zgr(ip,ii)= 0.d0 p2zgr(ip,ii)= 0.d0 p1zzr(ip,ii)= 0.d0 p2zzr(ip,ii)=0.d0 cggi(ip,ii)= 0.d0 cgzi(ip,ii)= 0.d0 czgi(ip,ii)= 0.d0 p1ggi(ip,ii)= 0.d0 p2ggi(ip,ii)= 0.d0 p1gzi(ip,ii)= 0.d0 p2gzi(ip,ii)= 0.d0 p1zgi(ip,ii)= 0.d0 p2zgi(ip,ii)= 0.d0 p1zzi(ip,ii)= 0.d0 p2zzi(ip,ii)= 0.d0 cggre(ip,ii)= 0.d0 cgzre(ip,ii)= 0.d0 czgre(ip,ii)= 0.d0 p1ggre(ip,ii)= 0.d0 p2ggre(ip,ii)= 0.d0 p1gzre(ip,ii)= 0.d0 p2gzre(ip,ii)= 0.d0 p1zgre(ip,ii)= 0.d0 p2zgre(ip,ii)= 0.d0 p1zzre(ip,ii)= 0.d0 p2zzre(ip,ii)= 0.d0 cggie(ip,ii)= 0.d0 cgzie(ip,ii)= 0.d0 czgie(ip,ii)= 0.d0 czzie(ip,ii)= 0.d0 p1ggie(ip,ii)= 0.d0 p2ggie(ip,ii)= 0.d0 p1gzie(ip,ii)= 0.d0 p2gzie(ip,ii)= 0.d0 p1zgie(ip,ii)= 0.d0 p2zgie(ip,ii)= 0.d0 p1zzie(ip,ii)= 0.d0 p2zzie(ip,ii)= 0.d0 enddo enddo * do ip=1,4 do ii=1,12 ephr(ip,ii)= 1.d0 ephie(ip,ii)= 0.d0 adhelr(ip,ii)= 0.d0 adhelre(ip,ii)= 0.d0 adhelie(ip,ii)= 0.d0 adheli(ip,ii)= 0.d0 enddo enddo * if(ndim.eq.6) then if(itc.eq.1) then if(itcc.eq.1) then smx= x(1) sux= x(2) sdx= x(3) sfx= x(4) twx= x(5) t1x= x(6) else if(itcc.eq.2) then smx= x(1) spx= x(2) sux= x(3) sfx= x(4) twx= x(5) t1x= x(6) else if(itcc.eq.3) then smx= x(1) spx= x(2) sux= x(3) sdx= x(4) twx= x(5) t1x= x(6) endif else smx= x(1) sux= x(2) sdx= x(3) sfx= x(4) twx= x(5) t1x= x(6) endif else if(ndim.eq.8) then if(itc.eq.1) then if(itcc.eq.1) then uvx= x(1) vvx= x(2) smx= x(3) sux= x(4) sdx= x(5) sfx= x(6) twx= x(7) t1x= x(8) else if(itcc.eq.2) then uvx= x(1) vvx= x(2) smx= x(3) spx= x(4) sux= x(5) sfx= x(6) twx= x(7) t1x= x(8) else if(itcc.eq.3) then uvx= x(1) vvx= x(2) smx= x(3) spx= x(4) sux= x(5) sdx= x(6) twx= x(7) t1x= x(8) endif else uvx= x(1) vvx= x(2) smx= x(3) sux= x(4) sdx= x(5) sfx= x(6) twx= x(7) t1x= x(8) endif else if(ndim.eq.7) then smx= x(1) spx= x(2) sux= x(3) sdx= x(4) sfx= x(5) twx= x(6) t1x= x(7) else if(ndim.eq.9) then uvx= x(1) vvx= x(2) smx= x(3) spx= x(4) sux= x(5) sdx= x(6) sfx= x(7) twx= x(8) t1x= x(9) endif * ik= ik+1 rs= ars one= 1.d0 * *-----if a point is not allowed then the * result is set to zero * iz= 1 * if(ndim.eq.6.or.ndim.eq.7) then ueps= 0.d0 uv= 1.d0 uvs= uv*uv ujc= 1.d0 veps= 0.d0 vv= 1.d0 vjc= 1.d0 else if(ndim.eq.8.or.ndim.eq.9) then * *-----independent invariants are initialized * first u and v variable * ueps= omul*(1.d0-uvx)**hbeti uv= 1.d0-ueps ujc= omul**hbet uvs= uv*uv * *-----limits for v * *-----from equal cuts on SA * if(iac(3).eq.1.and.isab.eq.1) then vvl4= ombsa(1)/opbsa(1)*uvs vvl= dmax1(vvl1,vvl2,vvl3,vvl4) else vvl= dmax1(vvl1,vvl2,vvl3) endif * *-----from E * vve= uv*(2.d0*suml-uv) vvll= dmax1(vvl,vve) * vvu1= uv if(iac(3).eq.1.and.isaa.eq.1) then vvu2= omasa(1)/opasa(1)*uvs vvu= dmin1(vvu1,vvu2) else vvu= uv endif uvl= uv-vvll * vkf= (uv-vvu)/uvl if(vkf.eq.0.d0) then veps= uvl*(1.d0-vvx)**hbeti else veps= uvl*(1.d0-(1.d0-vkf**hbet)*vvx)**hbeti endif vv= uv-veps avkf= 1.d0-vkf**hbet vjc= (1.d0-vvll/uv)**hbet*avkf endif * svv= sqrt(vv) vj= sqrt(vv**3) vzmg= rzmg*vv vvs= vv*vv xm= uv xp= vv/uv xmop= xm/xp if(ndim.eq.7.or.ndim.eq.6) then xdf= 0.d0 else xdf= (ueps*(1.d0-ueps)-veps)/uv endif xdfs= xdf*xdf sh= vv*s * *-----Z parameters * rszm2= zm*zm/sh * *-----Z propagator (real part and imaginary part) * dsz0= 1.d0-rszm2 dsz= dsz0*dsz0+rszw2 rsz= dsz0/dsz aisz= -rszw/dsz * *-----Reduced structure functions are computed with arguments xp,xm * opxp= 1.d0+xp opxm= 1.d0+xm omxp= veps/uv omxm= ueps if(isf.eq.0) then stfp= 1.d0 stfm= 1.d0 else if(isf.gt.0) then if(omxp.eq.0) then stfp= d0gl else rcpx= 0.25d0*opxp*opxp rcpy= xp iflp= 1 rclp= s21baf(rcpx,rcpy,iflp) stfp= d0gl+eob*omxp**omhb*(-0.5d0*opxp+ # feta*(-4.d0*opxp*log(omxp)+ # 3.d0*opxp*log(xp)+4.d0*rclp-5.d0-xp)) endif if(omxm.eq.0) then stfm= d0gl else rcmx= 0.25d0*opxm*opxm rcmy= xm iflm= 1 rclm= s21baf(rcmx,rcmy,iflm) stfm= d0gl+eob*omxm**omhb*(-0.5d0*opxm+ # feta*(-4.d0*opxm*log(omxm)+ # 3.d0*opxm*log(xm)+4.d0*rclm-5.d0-xm)) endif endif * stf= stfp*stfm * *-----if there is no upper cut on some FS IM, then the maximum is allowed * do j=1,6 if(rr(j).eq.1.d0) then rrr(j)= rr(j) else rrr(j)= rr(j)/vv endif rrl(j)= rl(j)/vv srrl(j)= srl(j)/svv enddo * *-----cuts become special near xp = xm * if(abs(xdf).gt.1.d-15) then ieq= 1 bxe= vv/(ueps*(1.d0-ueps)-veps) if(xdf.gt.0.d0) then enc= 1.d0 else if(xdf.lt.0.d0) then enc= xmop endif else ieq= 0 bxe= 1.d0 endif if(ieq.eq.0.and.xm.le.teq) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif * if(ieq.eq.0.and.iac(2).ne.0.and.iac(4).ne.0) then sct12= sct120/vv sct13= sct130/vv sct14= sct140/vv sct23= sct230/vv sct24= sct240/vv sct34= sct340/vv else sct12= 0.d0 sct13= 0.d0 sct14= 0.d0 sct23= 0.d0 sct24= 0.d0 sct34= 0.d0 endif * *-----cuts on Es * do j=1,4 if(ieq.eq.1) then bl(j)= 2.d0*rae(j)/xdf xbl(j)= 2.d0*rae(j)/xp else if(ieq.eq.0) then bl(j)= 2.d0*rae(j)/xm endif enddo * *-----cuts on SA * if(iac(3).ne.0) then do j=1,4 if(sgam(j).eq.1.d0) then ss(j)= 0.d0 else ss(j)= 1.d0+sgam(j)/(1.d0-sgam(j))*xmop ss(j)= 1.d0/ss(j) endif if(cgam(j).eq.0.d0) then cs(j)= 1.d0 else cs(j)= 1.d0+cgam(j)/(1.d0-cgam(j))*xmop cs(j)= 1.d0/cs(j) endif enddo endif * *-----initialization of sm = m_-^2 * zma1= dsm zma2= vv*sct12 zmb1= usm zmb2= (svv-sdsp)*(svv-sdsp) zmb3= vv*(1.d0-sqrt(sct34))*(1.d0-sqrt(sct34)) if(ieq.eq.0) then zma3= vv*(bl(1)+bl(2)-1.d0) zmb4= vv*(1.d0-0.5d0*(bl(3)+bl(4)))* # (1.d0-0.5d0*(bl(3)+bl(4))) zmb5= vv*(1.d0-bl(3)) zmb6= vv*(1.d0-bl(4)) else if(ieq.eq.1) then zma3= vv*(-enc+xbl(1)+xbl(2)) zmb4= 0.25d0*vv*(1.d0+enc-xbl(3)-xbl(4))* # (1.d0+enc-xbl(3)-xbl(4)) zmb5= vv*(enc-xbl(3)) zmb6= vv*(enc-xbl(4)) endif xzma= dmax1(zma1,zma2,zma3) xzmb= dmin1(zmb1,zmb2,zmb3,zmb4,zmb5,zmb6) * *-----limits on sm from cuts on SA. Here for maximum security. Rare * if(iac(3).eq.0) then zma= xzma zmb= xzmb else if(ss(4).eq.ss(3).and.ss(2).eq.ss(1)) then if(ss(3).eq.ss(1)) then szma= xzma szmb= xzmb else if(ss(3).gt.ss(1)) then szmb= xzmb adsp= dsp/vv axszma= dmax1(adsp,sct34) axszma= vv*(axszma-(1.d0-ss(1)-ss(3))/ # (ss(3)-ss(1))) szma= dmax1(axszma,xzma) else if(ss(3).lt.ss(1)) then if(ss(3).lt.0.5d0) then szma= xzma axszmb= vv*((ss(3)-0.5d0)/(ss(3)-ss(1)))**2 szmb= dmin1(axszmb,xzmb) else iz= 0 ifz(2)= ifz(2)+1 go to 1 endif endif else szma= xzma szmb= xzmb endif if(cs(4).eq.cs(3).and.cs(2).eq.cs(1)) then if(cs(3).eq.cs(1)) then zma= szma zmb= szmb else if(cs(3).gt.cs(1)) then if(cs(3).gt.0.5d0) then zma= szma axczmb= vv*((cs(3)-0.5d0)/(cs(3)-cs(1)))**2 zmb= dmin1(axczmb,szmb) else iz= 0 ifz(3)= ifz(3)+1 go to 1 endif else if(cs(3).lt.cs(1)) then zmb= szmb adsp= dsp/vv axczma= dmax1(adsp,sct34) axczma= vv*(axczma-(1.d0-cs(1)-cs(3))/ # (cs(3)-cs(1))) zma= dmax1(axczma,szma) endif else zma= szma zmb= szmb endif endif * if((itc.eq.1.and.itcc.eq.1).or.(itc.eq.2)) then dzpa= dmax1(dsp,sct340) if(itc.eq.1) then dzmb= (dist/rs-sqrt(dzpa))*(dist/rs-sqrt(dzpa)) zmb= dmin1(zmb,dzmb) else if(itc.eq.2) then dzma= (dist/rs+sqrt(dzpa))*(dist/rs+sqrt(dzpa)) zma= dmax1(zma,dzma) dzmb= 0.25d0*(svv+dist/rs)*(svv+dist/rs) zmb= dmin1(zmb,dzmb) endif endif if(itc.eq.1.and.itcc.eq.3) then zmbd3= vv-0.5d0*dist*dist/s zmb= dmin1(zmb,zmbd3) endif * *-----test on sm * if(zmb.le.zma) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif * if(opeak.eq.'y') then zmas= zma-rzm2 zmbs= zmb-rzm2 atma= (zmas+szgs*zma)/rzmg atmb= (zmbs+szgs*zmb)/rzmg if(atma.gt.1.d0.and.atmb.gt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/vzmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/vzmg smjc0= (-atmb+atma)/vzmg else if(atma.gt.1.d0.and.atmb.lt.-1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/vzmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/vzmg smjc0= (-pi+atmb+atma)/vzmg else if(atma.gt.1.d0.and.abs(atmb).lt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/vzmg atmb= atan(atmb) zmbt= atmb/vzmg smjc0= (-pih+atmb+atma)/vzmg else if(atma.lt.-1.d0.and.atmb.gt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/vzmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/vzmg smjc0= (pi-atmb-atma)/vzmg else if(atma.lt.-1.d0.and.atmb.lt.-1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/vzmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/vzmg smjc0= (atmb-atma)/vzmg else if(atma.lt.-1.d0.and.abs(atmb).lt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/vzmg atmb= atan(atmb) zmbt= atmb/vzmg smjc0= (pih+atmb-atma)/vzmg else if(abs(atma).lt.1.d0.and.atmb.gt.1.d0) then atma= atan(atma) zmat= atma/vzmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/vzmg smjc0= (pih-atmb-atma)/vzmg else if(abs(atma).lt.1.d0.and.atmb.lt.-1.d0) then atma= atan(atma) zmat= atma/vzmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/vzmg smjc0= (-pih+atmb-atma)/vzmg else if(abs(atma).lt.1.d0.and.abs(atmb).lt.1.d0) then atma= atan(atma) zmat= atma/vzmg atmb= atan(atmb) zmbt= atmb/vzmg smjc0= (atmb-atma)/vzmg endif * zmv= smjc0*smx+zmat iftn= 1 atnm= vzmg*zmv sm= s0z/vv*(1.d0+szg*s07aaf(atnm,iftn)) if(iftn.ne.0) print 300 pmjac= 1.d0 smjc= vv*smjc0 * else if(opeak.eq.'n') then smjc0= zmb-zma sm= (smjc0*smx+zma)/vv pmjac= 1.d0/((vv*sm-rzm2)**2+(vv*sm*szg)**2) smjc= smjc0 endif if(sm.lt.0.d0) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif ssm= sqrt(sm) * 300 format(/' Unsuccesful call to S07AAF ') * *-----initialization of sp = m_+^2 * zpa1= dsp zpb1= usp zpb2= vv*(1.d0-ssm)*(1.d0-ssm) * *-----limits on sp from cuts on SA. Here for maximum security. Rare * if(iac(3).eq.0) then zpb= dmin1(zpb1,zpb2) zpa= zpa1 else if(ss(4).eq.ss(3).and.ss(2).eq.ss(1)) then if(ss(3).eq.ss(1)) then azpb= dmin1(zpb1,zpb2) azpa= zpa1 else if(ss(3).gt.ss(1)) then zpb3= vv*(sm+(1.d0-ss(1)-ss(3))/(ss(3)-ss(1))) azpb= dmin1(zpb1,zpb2,zpb3) azpa= zpa1 else if(ss(3).lt.ss(1)) then azpb= dmin1(zpb1,zpb2) zpa2= vv*(sm+(1.d0-ss(1)-ss(3))/(ss(3)-ss(1))) azpa= dmax1(zpa1,zpa2) endif else azpa= zpa1 azpb= dmin1(zpb1,zpb2) endif if(cs(4).eq.cs(3).and.cs(2).eq.cs(1)) then if(cs(3).eq.cs(1)) then zpa= azpa zpb= azpb else if(cs(3).gt.cs(1)) then zpb= azpb bzpa= vv*(sm+(1.d0-cs(1)-cs(3))/(cs(3)-cs(1))) zpa= dmax1(azpa,bzpa) else if(cs(3).lt.cs(1)) then zpa= azpa bzpb= vv*(sm+(1.d0-cs(1)-cs(3))/(cs(3)-cs(1))) zpb= dmin1(azpb,bzpb) endif else zpa= azpa zpb= azpb endif endif * if(ieq.eq.0) then zpel= vv*(-1.d0+bl(3)+bl(4)+sm) zpeu1= vv*(1.d0-bl(1)-bl(2)+sm) zpeu2= vv*(1.d0-bl(1)) zpeu3= vv*(1.d0-bl(2)) else if(ieq.eq.1) then zpel= vv*(sm-enc+xbl(3)+xbl(4)) zpeu1= vv*(sm+enc-xbl(1)-xbl(2)) zpeu2= vv*(enc-xbl(1)) zpeu3= vv*(enc-xbl(2)) endif zpa= dmax1(zpa,zpel) zpb= dmin1(zpb,zpeu1,zpeu2,zpeu3) zpap= vv*sct34 zpa= dmax1(zpa,zpap) if(itc.eq.1.and.itcc.eq.3) then zpbd3= vv*(1.d0-sm)-0.5d0*dist*dist/s zpb= dmin1(zpb,zpbd3) endif * *-----test on sp * if(zpb.le.zpa) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif * if((itc.eq.1.and.itcc.eq.1).or.(itc.eq.2)) then bdistl= (dist/rs-svv*ssm)*(dist/rs-svv*ssm)-zpa bdistu= zpb-(dist/rs-svv*ssm)*(dist/rs-svv*ssm) if(bdistl.le.0.d0.or.bdistu.le.0.d0) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif endif * if((itc.eq.1.and.itcc.eq.1).or.(itc.eq.2)) then sp= (dist/rs/svv-ssm)*(dist/rs/svv-ssm) ppjac= 2.d0*abs((dist/rs-svv*ssm))/ars/ # ((vv*sp-rzm2)**2+(vv*sp*szg)**2) spjc= 1.d0 else * if(opeak.eq.'y') then zpas= zpa-rzm2 zpbs= zpb-rzm2 atpa= (zpas+szgs*zpa)/rzmg atpb= (zpbs+szgs*zpb)/rzmg if(atpa.gt.1.d0.and.atpb.gt.1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/vzmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/vzmg spjc0= (-atpb+atpa)/vzmg else if(atpa.gt.1.d0.and.atpb.lt.-1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/vzmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/vzmg spjc0= (-pi+atpb+atpa)/vzmg else if(atpa.gt.1.d0.and.abs(atpb).lt.1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/vzmg atpb= atan(atpb) zpbt= atpb/vzmg spjc0= (-pih+atpb+atpa)/vzmg else if(atpa.lt.-1.d0.and.atpb.gt.1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/vzmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/vzmg spjc0= (pi-atpb-atpa)/vzmg else if(atpa.lt.-1.d0.and.atpb.lt.-1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/vzmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/vzmg spjc0= (atpb-atpa)/vzmg else if(atpa.lt.-1.d0.and.abs(atpb).lt.1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/vzmg atpb= atan(atpb) zpbt= atpb/vzmg spjc0= (pih+atpb-atpa)/vzmg else if(abs(atpa).lt.1.d0.and.atpb.gt.1.d0) then atpa= atan(atpa) zpat= atpa/vzmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/vzmg spjc0= (pih-atpb-atpa)/vzmg else if(abs(atpa).lt.1.d0.and.atpb.lt.-1.d0) then atpa= atan(atpa) zpat= atpa/vzmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/vzmg spjc0= (-pih+atpb-atpa)/vzmg else if(abs(atpa).lt.1.d0.and.abs(atpb).lt.1.d0) then atpa= atan(atpa) zpat= atpa/vzmg atpb= atan(atpb) zpbt= atpb/vzmg spjc0= (atpb-atpa)/vzmg endif * zpv= spjc0*spx+zpat iftn= 1 atnp= vzmg*zpv sp= s0z/vv*(1.d0+szg*s07aaf(atnp,iftn)) if(iftn.ne.0) print 300 ppjac= 1.d0 spjc= vv*spjc0 * else if(opeak.eq.'n') then spjc0= zpb-zpa sp= (spjc0*spx+zpa)/vv ppjac= 1.d0/((vv*sp-rzm2)**2+(vv*sp*szg)**2) spjc= spjc0 endif * endif if(sp.lt.0.d0) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif ssp= sqrt(sp) spmm= sp-sm smmp= sm-sp * cbw= -1.d0+sp-sm ifcr= 0 call c02ajf(one,cbw,sm,bt1,bt2,ifcr) if(bt1(2).ne.0.d0) then iz= 0 ifz(6)= ifz(6)+1 go to 1 endif * ssmpp= ssm+ssp ssmmp= ssm-ssp asup= 1.d0-ssmpp*ssmpp asum= 1.d0-ssmmp*ssmmp if(asup.lt.0.d0.or.asum.lt.0.d0) then iz= 0 ifz(7)= ifz(7)+1 go to 1 endif rasup= sqrt(asup) rasum= sqrt(asum) * *-----initialization of su = M_0^2 * *-----limits on su from cuts on FS IM * sulim= rrl(4) suuim1= rrr(4) suuim2= (1.d0-srrl(3))*(1.d0-srrl(3)) suuim= dmin1(suuim1,suuim2) * *-----limits on su from Delta_- > 0 (as derived from consistency * on sd limits) * suud1= 0.25d0*(rasup+rasum)*(rasup+rasum) suud2= 0.25d0*(1.d0+rasup)*(1.d0+rasup) * sul= sulim sul= dmax1(sul,sct23) if(ieq.eq.0) then sul1= bl(2)+bl(3)-1.d0 suu1= 1.d0-sp-bl(1) suu2= 1.d0-sm-bl(4) suu3= (1.d0-0.5d0*(bl(1)+bl(4)))* # (1.d0-0.5d0*(bl(1)+bl(4))) else if(ieq.eq.1) then sul1= xbl(2)+xbl(3)+1.d0-2.d0*enc suu1= enc-sp-xbl(1) suu2= enc-sm-xbl(4) suu3= (enc-0.5d0*(xbl(1)+xbl(4)))* # (enc-0.5d0*(xbl(1)+xbl(4))) endif sul= dmax1(sul,sul1) suu= dmin1(suuim,suud1,suud2,suu1,suu2,suu3) sdlim= rrl(3) * if(itc.eq.1.and.itcc.eq.2) then dsdl= dmax1(sdlim,sct140) dsuu= (dist/svv/rs-sqrt(dsdl))*(dist/svv/rs-sqrt(dsdl)) suu= dmin1(suu,dsuu) endif if(itc.eq.1.and.itcc.eq.3) then suud3= 1.d0-sm-sp-0.5d0*dist*dist/vv/s suu= dmin1(suu,suud3) endif * *-----test on su * if(suu.le.sul) then iz= 0 ifz(8)= ifz(8)+1 go to 1 endif * if(opeak.eq.'y') then zuas= vv*sul-rzm2 zubs= vv*suu-rzm2 atua= (zuas+vv*szgs*sul)/rzmg atub= (zubs+vv*szgs*suu)/rzmg if(atua.gt.1.d0.and.atub.gt.1.d0) then atua= 1.d0/atua atua= atan(atua) zuat= (pih-atua)/vzmg atub= 1.d0/atub atub= atan(atub) zubt= (pih-atub)/vzmg sujc0= (-atub+atua)/vzmg else if(atua.gt.1.d0.and.atub.lt.-1.d0) then atua= 1.d0/atua atua= atan(atua) zuat= (pih-atua)/vzmg atub= -1.d0/atub atub= atan(atub) zubt= (-pih+atub)/vzmg sujc0= (-pi+atub+atua)/vzmg else if(atua.gt.1.d0.and.abs(atub).lt.1.d0) then atua= 1.d0/atua atua= atan(atua) zuat= (pih-atua)/vzmg atub= atan(atub) zubt= atub/vzmg sujc0= (-pih+atub+atua)/vzmg else if(atua.lt.-1.d0.and.atub.gt.1.d0) then atua= -1.d0/atua atua= atan(atua) zuat= (-pih+atua)/vzmg atub= 1.d0/atub atub= atan(atub) zubt= (pih-atub)/vzmg sujc0= (pi-atub-atua)/vzmg else if(atua.lt.-1.d0.and.atub.lt.-1.d0) then atua= -1.d0/atua atua= atan(atua) zuat= (-pih+atua)/vzmg atub= -1.d0/atub atub= atan(atub) zubt= (-pih+atub)/vzmg sujc0= (atub-atua)/vzmg else if(atua.lt.-1.d0.and.abs(atub).lt.1.d0) then atua= -1.d0/atua atua= atan(atua) zuat= (-pih+atua)/vzmg atub= atan(atub) zubt= atub/vzmg sujc0= (pih+atub-atua)/vzmg else if(abs(atua).lt.1.d0.and.atub.gt.1.d0) then atua= atan(atua) zuat= atua/vzmg atub= 1.d0/atub atub= atan(atub) zubt= (pih-atub)/vzmg sujc0= (pih-atub-atua)/vzmg else if(abs(atua).lt.1.d0.and.atub.lt.-1.d0) then atua= atan(atua) zuat= atua/vzmg atub= -1.d0/atub atub= atan(atub) zubt= (-pih+atub)/vzmg sujc0= (-pih+atub-atua)/vzmg else if(abs(atua).lt.1.d0.and.abs(atub).lt.1.d0) then atua= atan(atua) zuat= atua/vzmg atub= atan(atub) zubt= atub/vzmg sujc0= (atub-atua)/vzmg endif * zuv= sujc0*sux+zuat iftn= 1 atnu= vzmg*zuv su= s0z/vv*(1.d0+szg*s07aaf(atnu,iftn)) if(iftn.ne.0) print 300 pujac= 1.d0 * else if(opeak.eq.'n') then sujc0= suu-sul su= sujc0*sux+sul pujac= 1.d0/((vv*su-rzm2)**2+(vv*su*szg)**2) endif sujc= vv*sujc0 if(su.lt.0.d0) then iz= 0 ifz(8)= ifz(8)+1 go to 1 endif ssu= sqrt(su) * *-----initialization of sd = m_0^2 * *-----limits on sd from cuts on FS IM * sdlim1= rrl(3) sdlim2= 1.d0-rrr(2)-rrr(5)-sm-sp-su sdlim= dmax1(sdlim1,sdlim2) sduim1= rrr(3) sduim2= (1.d0-ssu)*(1.d0-ssu) sduim3= 1.d0-rrl(2)-rrl(5)-sm-sp-su sduim= dmin1(sduim1,sduim2,sduim3) * *-----limits on sd from Delta_- > 0 * if(ssu.gt.rasup) then sdld= (ssu-rasup)*(ssu-rasup) else sdld= sdlim endif sdud1= (ssu+rasup)*(ssu+rasup) sdud2= (-ssu+rasum)*(-ssu+rasum) sdud= dmin1(sdud1,sdud2) * *-----limits on sd from cuts on SA. Here for maximum security. Rare * if(iac(3).ne.0.and.ss(4).eq.ss(1).and.ss(3).eq.ss(2)) then if(ss(2).eq.ss(1)) then asdu= dmin1(sduim,sdud) asdl= dmax1(sdlim,sdld) else if(ss(1).gt.ss(2)) then sdusa= su+(1.d0-ss(1)-ss(2))/(ss(1)-ss(2)) asdu= dmin1(sduim,sdud,sdusa) asdl= dmax1(sdlim,sdld) else if(ss(1).lt.ss(2)) then asdu= dmin1(sduim,sdud) sdlsa= su+(1.d0-ss(1)-ss(2))/(ss(1)-ss(2)) asdl= dmax1(sdlim,sdld,sdlsa) endif else asdu= dmin1(sduim,sdud) asdl= dmax1(sdlim,sdld) endif if(iac(3).ne.0.and.cs(4).eq.cs(1).and.cs(3).eq.cs(2)) then if(cs(2).eq.cs(1)) then sdl= asdl sdu= asdu else if(cs(1).gt.cs(2)) then sdu= asdu sdlsb= su+(1.d0-cs(1)-cs(2))/(cs(1)-cs(2)) sdl= dmax1(asdl,sdlsb) else if(cs(1).lt.cs(2)) then sdl= asdl sdusb= su+(1.d0-cs(1)-cs(2))/(cs(1)-cs(2)) sdu= dmin1(asdu,sdusb) endif else sdl= asdl sdu= asdu endif * if(ieq.eq.0) then sdenl= -1.d0+bl(1)+bl(4)+su sdenu1= 1.d0-sp-bl(2) sdenu2= 1.d0-sm-bl(3) sdenu3= 1.d0-bl(2)-bl(3)+su else if(ieq.eq.1) then sdenl= su+1.d0-2.d0*enc+xbl(1)+xbl(4) sdenu1= enc-sp-xbl(2) sdenu2= enc-sm-xbl(3) sdenu3= su-1.d0+2.d0*enc-xbl(2)-xbl(3) endif sdl= dmax1(sdl,sdenl) sdu= dmin1(sdu,sdenu1,sdenu2,sdenu3) sdl= dmax1(sdl,sct14) if(itc.eq.1.and.itcc.eq.3) then sdld3= 1.d0-sm-sp-su-dist*dist/vv/s sdl= dmax1(sdl,sdld3) sdud3= 1.d0-sm-sp-su-0.5d0*dist*dist/vv/s sdu= dmin1(sdu,sdud3) endif * *-----test on sd * if(sdu.le.sdl) then iz= 0 ifz(9)= ifz(9)+1 go to 1 endif * if(itc.eq.1.and.itcc.eq.2) then bdistl= (dist/rs-svv*ssu)*(dist/rs-svv*ssu)-vv*sdl bdistu= vv*sdu-(dist/rs-svv*ssu)*(dist/rs-svv*ssu) if(bdistl.le.0.d0.or.bdistu.le.0.d0) then iz= 0 ifz(9)= ifz(9)+1 go to 1 endif endif * if(itc.eq.1.and.itcc.eq.2) then sd= (dist/rs/svv-ssu)*(dist/rs/svv-ssu) sdjc= 2.d0*abs((dist/rs-svv*ssu))/ars/ # ((vv*sd-rzm2)**2+(vv*sd*szg)**2) pdjac= 1.d0 else if(opeak.eq.'y') then zdas= vv*sdl-rzm2 zdbs= vv*sdu-rzm2 atda= (zdas+vv*szgs*sdl)/rzmg atdb= (zdbs+vv*szgs*sdu)/rzmg if(atda.gt.1.d0.and.atdb.gt.1.d0) then atda= 1.d0/atda atda= atan(atda) zdat= (pih-atda)/vzmg atdb= 1.d0/atdb atdb= atan(atdb) zdbt= (pih-atdb)/vzmg sdjc0= (-atdb+atda)/vzmg else if(atda.gt.1.d0.and.atdb.lt.-1.d0) then atda= 1.d0/atda atda= atan(atda) zdat= (pih-atda)/vzmg atdb= -1.d0/atdb atdb= atan(atdb) zdbt= (-pih+atdb)/vzmg sdjc0= (-pi+atdb+atda)/vzmg else if(atda.gt.1.d0.and.abs(atdb).lt.1.d0) then atda= 1.d0/atda atda= atan(atda) zdat= (pih-atda)/vzmg atdb= atan(atdb) zdbt= atdb/vzmg sdjc0= (-pih+atdb+atda)/vzmg else if(atda.lt.-1.d0.and.atdb.gt.1.d0) then atda= -1.d0/atda atda= atan(atda) zdat= (-pih+atda)/vzmg atdb= 1.d0/atdb atdb= atan(atdb) zdbt= (pih-atdb)/vzmg sdjc0= (pi-atdb-atda)/vzmg else if(atda.lt.-1.d0.and.atdb.lt.-1.d0) then atda= -1.d0/atda atda= atan(atda) zdat= (-pih+atda)/vzmg atdb= -1.d0/atdb atdb= atan(atdb) zdbt= (-pih+atdb)/vzmg sdjc0= (atdb-atda)/vzmg else if(atda.lt.-1.d0.and.abs(atdb).lt.1.d0) then atda= -1.d0/atda atda= atan(atda) zdat= (-pih+atda)/vzmg atdb= atan(atdb) zdbt= atdb/vzmg sdjc0= (pih+atdb-atda)/vzmg else if(abs(atda).lt.1.d0.and.atdb.gt.1.d0) then atda= atan(atda) zdat= atda/vzmg atdb= 1.d0/atdb atdb= atan(atdb) zdbt= (pih-atdb)/vzmg sdjc0= (pih-atdb-atda)/vzmg else if(abs(atda).lt.1.d0.and.atdb.lt.-1.d0) then atda= atan(atda) zdat= atda/vzmg atdb= -1.d0/atdb atdb= atan(atdb) zdbt= (-pih+atdb)/vzmg sdjc0= (-pih+atdb-atda)/vzmg else if(abs(atda).lt.1.d0.and.abs(atdb).lt.1.d0) then atda= atan(atda) zdat= atda/vzmg atdb= atan(atdb) zdbt= atdb/vzmg sdjc0= (atdb-atda)/vzmg endif * zdv= sdjc0*sdx+zdat iftn= 1 atnd= vzmg*zdv sd= s0z/vv*(1.d0+szg*s07aaf(atnd,iftn)) if(iftn.ne.0) print 300 pdjac= 1.d0 * else if(opeak.eq.'n') then sdjc0= sdu-sdl sd= sdjc0*sdx+sdl pdjac= 1.d0/((vv*sd-rzm2)**2+(vv*sd*szg)**2) endif sdjc= vv*sdjc0 * endif if(sd.lt.0.d0) then iz= 0 ifz(9)= ifz(9)+1 go to 1 endif ssd= sqrt(sd) sdmu= sd-su sdmus= (1.d0+sdmu)*(1.d0+sdmu) * *-----initialization of sf = m^2 * *-----limits on sf from cuts on FS IM * sflim1= rrl(2) sfuim1= rrr(2) bsg= sm+sp+su+sd ombsg= 1.d0-bsg sflim2= ombsg-rrr(5) sfuim2= ombsg-rrl(5) sflim= dmax1(sflim1,sflim2) sfuim= dmin1(sfuim1,sfuim2) * *-----limits on sf from cuts on SA * tcuts= ss(1)-ss(2)+ss(3)-ss(4) tcutc= cs(1)-cs(2)+cs(3)-cs(4) if(iac(3).ne.0.and.tcuts.ne.0.d0.and.tcutc.ne.0.d0) then if(tcuts.gt.0.d0.and.tcutc.gt.0.d0) then sflsa= (1.d0-cs(2)-cs(4)-(cs(1)-cs(2))*sd- # (cs(3)-cs(4))*su-(cs(3)-cs(2))*sp- # (cs(1)-cs(4))*sm)/tcutc sfusa= (1.d0-ss(2)-ss(4)-(ss(1)-ss(2))*sd- # (ss(3)-ss(4))*su-(ss(3)-ss(2))*sp- # (ss(1)-ss(4))*sm)/tcuts asfl= dmax1(sflim,sflsa) asfu= dmin1(sfuim,sfusa) else if(tcuts.gt.0.d0.and.tcutc.lt.0.d0) then sfusa= (1.d0-ss(2)-ss(4)-(ss(1)-ss(2))*sd- # (ss(3)-ss(4))*su-(ss(3)-ss(2))*sp- # (ss(1)-ss(4))*sm)/tcuts sfusb= (1.d0-cs(2)-cs(4)-(cs(1)-cs(2))*sd- # (cs(3)-cs(4))*su-(cs(3)-cs(2))*sp- # (cs(1)-cs(4))*sm)/tcutc asfu= dmin1(sfuim,sfusa,sfusb) asfl= sflim else if(tcuts.lt.0.d0.and.tcutc.gt.0.d0) then sflsa= (1.d0-ss(2)-ss(4)-(ss(1)-ss(2))*sd- # (ss(3)-ss(4))*su-(ss(3)-ss(2))*sp- # (ss(1)-ss(4))*sm)/tcuts sflsb= (1.d0-cs(2)-cs(4)-(cs(1)-cs(2))*sd- # (cs(3)-cs(4))*su-(cs(3)-cs(2))*sp- # (cs(1)-cs(4))*sm)/tcutc asfl= dmax1(sflim,sflsa,sflsb) asfu= sfuim else if(tcuts.lt.0.d0.and.tcutc.lt.0.d0) then sflsa= (1.d0-ss(2)-ss(4)-(ss(1)-ss(2))*sd- # (ss(3)-ss(4))*su-(ss(3)-ss(2))*sp- # (ss(1)-ss(4))*sm)/tcuts sfusa= (1.d0-cs(2)-cs(4)-(cs(1)-cs(2))*sd- # (cs(3)-cs(4))*su-(cs(3)-cs(2))*sp- # (cs(1)-cs(4))*sm)/tcutc asfl= dmax1(sflim,sflsa) asfu= dmin1(sfuim,sfusa) endif else asfl= sflim asfu= sfuim endif * if(ieq.eq.0) then asfenl1= bl(1)-sm-sd asfenl2= bl(3)-sp-su asfenu1= 1.d0-bl(2)-sp-sd asfenu2= 1.d0-bl(4)-sm-su else if(ieq.eq.1) then asfenl1= 1.d0-enc-sm-sd+xbl(1) asfenl2= 1.d0-enc-sp-su+xbl(3) asfenu1= enc-sp-sd-xbl(2) asfenu2= enc-sm-su-xbl(4) endif asfl= dmax1(asfl,asfenl1,asfenl2) asfu= dmin1(asfu,asfenu1,asfenu2) aasfu= 1.d0-sm-sp-su-sd-sct24 asfl= dmax1(asfl,sct13) asfu= dmin1(asfu,aasfu) * if(iac(3).ne.0) then if(ss(4).ne.ss(3)) then if(ss(4).gt.ss(3)) then asfltw= -(1.d0-ss(3)*sp-ss(3)*su+ss(4)*sm+ # ss(4)*su-ss(4)-bt1(1))/(ss(4)-ss(3)) asfl= dmax1(asfl,asfltw) else if (ss(4).lt.ss(3)) then asfutw= -(1.d0-ss(3)*sp-ss(3)*su+ss(4)*sm+ # ss(4)*su-ss(4)-bt1(1))/(ss(4)-ss(3)) asfu= dmin1(asfu,asfutw) endif endif if(cs(1).ne.cs(2)) then if(cs(1).gt.cs(2)) then bsfltw= -(cs(1)*sm+cs(1)*sd-cs(2)*sp-cs(2)*sd+ # cs(2)-bt1(1))/(cs(1)-cs(2)) asfl= dmax1(asfl,bsfltw) else if(cs(1).lt.cs(2)) then bsfutw= -(cs(1)*sm+cs(1)*sd-cs(2)*sp-cs(2)*sd+ # cs(2)-bt1(1))/(cs(1)-cs(2)) asfu= dmin1(asfu,bsfutw) endif endif if(cs(4).ne.cs(3)) then if(cs(4).gt.cs(3)) then csfutw= (bt2(1)-1.d0+cs(3)*sp+cs(3)*su-cs(4)*sm- # cs(4)*su+cs(4))/(cs(4)-cs(3)) asfu= dmin1(asfu,csfutw) else if(cs(4).lt.cs(3)) then csfltw= (bt2(1)-1.d0+cs(3)*sp+cs(3)*su-cs(4)*sm- # cs(4)*su+cs(4))/(cs(4)-cs(3)) asfl= dmax1(asfl,csfltw) endif endif if(ss(1).ne.ss(2)) then if(ss(1).gt.ss(2)) then dsfutw= (bt2(1)-ss(1)*sm-ss(1)*sd+ss(2)*sp+ # ss(2)*sd-ss(2))/(ss(1)-ss(2)) asfu= dmin1(asfu,dsfutw) else if(ss(1).lt.ss(2)) then dsfltw= (bt2(1)-ss(1)*sm-ss(1)*sd+ss(2)*sp+ # ss(2)*sd-ss(2))/(ss(1)-ss(2)) asfl= dmax1(asfl,dsfltw) endif endif endif * *-----positivity of R^2 * scp= ssmpp*ssmpp scm= ssmmp*ssmmp snp= (ssu+ssd)*(ssu+ssd) snm= (ssu-ssd)*(ssu-ssd) rlp= ssu*ssd+ssp*ssm rlm= ssu*ssd-ssp*ssm bsgmo= bsg-1.d0 ombsg2= ombsg*ombsg rlps= rlp*rlp rlms= rlm*rlm edelp= ombsg2-4.d0*rlps edelm= ombsg2-4.d0*rlms edeld= 16.d0*ssu*ssd*ssp*ssm * *-----first Delta_- > 0 > Delta_+ with Sigma > or < 1/2 * then Delta_+ > 0 * *-----control * cnt1= scp+snm cnt2= scm+snp if(cnt1.gt.1.d0.or.cnt2.gt.1.d0) then iz= 0 ifz(10)= ifz(10)+1 go to 1 endif if(edelm.le.0.d0) then etest= edeld+edelp if(etest.gt.0.d0) then edelm= etest else iz= 0 ifz(11)= ifz(11)+1 go to 1 endif endif sedm= sqrt(edelm) ifcr= 0 call c02ajf(one,bsgmo,rlms,rr1,rr2,ifcr) if(rr1(2).ne.0.d0) then iz= 0 ifz(12)= ifz(12)+1 go to 1 endif ifcr= 0 call c02ajf(one,bsgmo,rlps,rs1,rs2,ifcr) * cnt3= scp+snp cnt4= scm+snm cbru= -1.d0 ccru= 0.5d0*bsg * *-----R^2 has two real roots and two complex conjugate roots * if(cnt3.gt.1.d0.or.cnt4.gt.1.d0) then if(bsg.gt.0.5d0) then iel= 1 sflr(1)= rr1(1) sfur(1)= rr2(1) sflr(2)= rr1(1) sfur(2)= rr2(1) else iel= 2 ifcr= 0 call c02ajf(one,cbru,ccru,rru1,rru2,ifcr) ru1= rru1(1)*rru1(1) ru2= rru2(1)*rru2(1) sflr(1)= rr1(1) sflr(2)= ru2 sfur(1)= ru1 sfur(2)= rr2(1) endif * *-----R^2 has four real roots * else if(cnt3.lt.1.d0.and.cnt4.lt.1.d0) then if(bsg.gt.0.5d0) then sflr(1)= rr1(1) sflr(2)= rs2(1) sfur(1)= rs1(1) sfur(2)= rr2(1) else ifcr= 0 call c02ajf(one,cbru,ccru,rru1,rru2,ifcr) ru1= rru1(1)*rru1(1) ru2= rru2(1)*rru2(1) sflr(1)= rr1(1) sfur(1)= dmin1(rs1(1),ru1) sflr(2)= dmax1(rs2(1),ru2) sfur(2)= rr2(1) endif endif * *-----the loop for transforming sf starts here * if(om.eq.'g') then itmn= it0 itmx= it0 else itmn= 1 itmx= 2 endif do it=itmn,itmx if(sflr(it).ge.asfl) then sfl= sflr(it) else sfl= asfl endif if(sfur(it).le.asfu) then sfu= sfur(it) else sfu= asfu endif * *-----test on sf * if(sfu.le.sfl) then iz= 0 ifz(13)= ifz(13)+1 go to 2 endif * if(itc.eq.1.and.itcc.eq.3) then ittm= 2 else ittm= 1 endif * do itt=1,ittm * if(itc.eq.1.and.itcc.eq.3) then distm= dist/svv/rs sbdist= 2.d0*(1.d0-sm-sp-su-sd)-distm*distm if(sbdist.le.0.d0) then iz= 0 ifz(13)= ifz(13)+1 go to 5 endif if(itt.eq.1) then bdist= 0.25d0*(distm-sqrt(sbdist))* # (distm-sqrt(sbdist)) else if(itt.eq.2) then bdist= 0.25d0*(distm+sqrt(sbdist))* # (distm+sqrt(sbdist)) endif bdistl= bdist-sfl bdistu= sfu-bdist if(bdistl.le.0.d0.or.bdistu.le.0.d0) then iz= 0 ifz(13)= ifz(13)+1 go to 5 endif sf= bdist ssf= sqrt(sf) pfjc= 2.d0/vv/rs*ssf*(distm-ssf)/sqrt(sbdist) sfjc0= sf*sf+(sm+sp+su+sd-1.d0)*sf+su*sd+sm*sp sfjc= 4.d0*sm*sp*su*sd-sfjc0*sfjc0 if(sfjc.le.0.d0) then iz= 0 ifz(13)= ifz(13)+1 go to 5 else if(iel.eq.1) then sfjc= 0.5d0*pfjc/sqrt(sfjc) else if(iel.eq.2) then sfjc= pfjc/sqrt(sfjc) endif endif else * *-----transformation for jacobian, first Delta_+ < 0, then Delta_+ > 0 * if(cnt3.gt.1.d0.or.cnt4.gt.1.d0) then er= rs1(1) es= abs(rs1(2)) er1= rr1(1) er2= rr2(1) ek2= edelm/edeld ek= sqrt(ek2) dog= -2.d0/sqrt(edeld) ecpl= (ombsg-2.d0*sfl)/sedm ecpu= (ombsg-2.d0*sfu)/sedm eql= ecpl*ecpl equ= ecpu*ecpu omecpl= 2.d0*(sfl-er1)/sedm es2pl= omecpl*(2.d0-omecpl) erl= 1.d0-ek2*es2pl espl= sqrt(es2pl) opecpu= 2.d0*(er2-sfu)/sedm es2pu= opecpu*(2.d0-opecpu) espu= sqrt(es2pu) eru= 1.d0-ek2*es2pu if(eql.eq.1) then sflt= 0.d0 else ifel= 1 sflt= -dog*espl*s21bbf(eql,erl,one,ifel) if(ifel.ne.0) then iz= 0 ifz(14)= ifz(14)+1 go to 2 endif endif if(equ.eq.1.d0) then sfut= 0.d0 else ifel= 1 sfut= -dog*espu*s21bbf(equ,eru,one,ifel) if(ifel.ne.0) then iz= 0 ifz(15)= ifz(15)+1 go to 2 endif endif if(iel.eq.1) then if(sfu.le.er) then efac= 0.5d0 sft= (sfut-sflt)*sfx+sflt ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(16)= ifz(16)+1 go to 2 endif sf= 0.5d0*(ombsg-sedm*elcn) sfjc= efac*(sfut-sflt) else if(sfl.ge.er) then efac= 0.5d0 sft= (sflt-sfut)*sfx+sfut ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(17)= ifz(17)+1 go to 2 endif sf= 0.5d0*(ombsg+sedm*elcn) sfjc= efac*(sflt-sfut) else efac= 1.d0 qbar= 0.d0 rbar= 1.d0-ek2 ifel= 1 sfbar= -dog*s21bbf(qbar,rbar,one,ifel) if(ifel.ne.0) then iz= 0 ifz(18)= ifz(18)+1 go to 2 endif if(it.eq.1) then sft= (sfbar-sflt)*sfx+sflt ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(19)= ifz(19)+1 go to 2 endif sf= 0.5d0*(ombsg-sedm*elcn) sfjc= efac*(sfbar-sflt) else if(it.eq.2) then sft= (sfbar-sfut)*sfx+sfut ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(20)= ifz(20)+1 go to 2 endif sf= 0.5d0*(ombsg+sedm*elcn) sfjc= efac*(sfbar-sfut) endif endif else if(iel.eq.2) then efac= 1.d0 if(it.eq.1) then sft= (sfut-sflt)*sfx+sflt ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(21)= ifz(21)+1 go to 2 endif sf= 0.5d0*(ombsg-sedm*elcn) sfjc= efac*(sfut-sflt) else if(it.eq.2) then sft= (sflt-sfut)*sfx+sfut ifel= 1 asf= -sft/dog call s21caf(asf,ek2,elsn,elcn,edn,ifel) if(ifel.ne.0) then iz= 0 ifz(22)= ifz(22)+1 go to 2 endif sf= 0.5d0*(ombsg+sedm*elcn) sfjc= efac*(sflt-sfut) endif endif else if(cnt3.lt.1.d0.and.cnt4.lt.1.d0) then if(edelp.le.0.d0) then iz= 0 ifz(23)= ifz(23)+1 go to 2 endif sedp= sqrt(edelp) efac= 1.d0 es1= rs1(1) es2= rs2(1) er1= rr1(1) er2= rr2(1) ssed= sedm+sedp ek= (sedm-sedp)/ssed ek2= ek*ek dog= 2.d0/ssed if(it.eq.1) then es2pl= (er1-sfl)/(sfl-er2)/ek es2pu= (er1-sfu)/(sfu-er2)/ek eql= 1.d0-es2pl equ= 1.d0-es2pu erl= 1.d0-ek2*es2pl eru= 1.d0-ek2*es2pu else if(it.eq.2) then es2pl= (sfl-es2)/(sfl-es1)/ek es2pu= (sfu-es2)/(sfu-es1)/ek eql= 1.d0-es2pl equ= 1.d0-es2pu erl= 1.d0-ek2*es2pl eru= 1.d0-ek2*es2pu endif if(eql.eq.1.d0) then sflt= 0.d0 else ifel= 1 sflt= 2.d0*dog*sqrt(es2pl)* # s21bbf(eql,erl,one,ifel) if(ifel.ne.0) then iz= 0 ifz(24)= ifz(24)+1 go to 2 endif endif if(equ.eq.1.d0) then sfut= 0.d0 else ifel= 1 if(equ.lt.0.d0.and.abs(equ).lt.1.d-12) then equ= 0.d0 endif sfut= 2.d0*dog*sqrt(es2pu)* # s21bbf(equ,eru,one,ifel) if(ifel.ne.0) then iz= 0 ifz(25)= ifz(25)+1 go to 2 endif endif sft= (sfut-sflt)*sfx+sflt ifel= 1 asf= 0.5d0/dog*sft call s21caf(asf,ek2,elsn,elcn,edn,ifel) elsn2= elsn*elsn if(ifel.ne.0) then iz= 0 ifz(26)= ifz(26)+1 go to 2 endif if(it.eq.1) then sf= (er1+ek*elsn2*er2)/(1.d0+ek*elsn2) else if(it.eq.2) then sf= (es2-ek*elsn2*es1)/(1.d0-ek*elsn2) endif sfjc= efac*(sfut-sflt) endif * endif * *-----auxiliary quantities * sdpf= sd+sf e3= sp+su+sf e4= 1.d0+spmm-e3 e3p4= 1.d0+spmm e1= sm+sdpf e2= 1.d0+smmp-e1 e1p2= 1.d0+smmp e1p3= e1+e3 e1m2= 2.d0*e1-1.d0+spmm ep1= xp*e1 ep2= xp*e2 ep3= xp*e3 ep4= xp*e4 e1t2= e1*e2 e1t3= e1*e3 e1t4= e1*e4 e2t3= e2*e3 e2t4= e2*e4 e3t4= e3*e4 ep12= xp*e1t2 if((e1p3*e1p3-4.d0*sf).lt.0.d0) then iz= 0 ifz(27)= ifz(27)+1 go to 2 endif skl2= sqrt(e1p3*e1p3-4.d0*sf) if((sdmus-4.d0*sd).lt.0.d0) then iz= 0 ifz(28)= ifz(28)+1 go to 2 endif skl3= sdmus-4.d0*sd skl3= sqrt(skl3) * * *-----initialization of t_w * *-----limits on tw from positivity and SA * twlp1= 0.d0 twlp2= smmp twlp3= spmm-1.d0 twlp= dmax1(twlp1,twlp2,twlp3) twup= 1.d0 * *-----limits on tw from cuts on SA * if(iac(3).ne.0) then skl2m= 0.5d0*(e1p3-skl2) skl2p= 0.5d0*(e1p3+skl2) skl3p= -0.5d0*(1.d0+sdmu-skl3) skl3m= -0.5d0*(1.d0+sdmu+skl3) twlsa1= 1.d0-cs(3)*e3-cs(4)*e4 twlsa2= ss(1)*e1+ss(2)*e2 twlsa3= 1.d0-cs(3)*e3-cs(4)*e4-skl3p+skl3m twlsa4= 1.d0-2.d0*cs(3)*e3+skl2m+skl3m twlsa5= 1.d0-2.d0*cs(4)*e4-skl2p-skl3p twlsa6= 1.d0-cs(3)*e3-cs(4)*e4-skl2p+skl2m twusa1= 1.d0-ss(3)*e3-ss(4)*e4 twusa2= cs(1)*e1+cs(2)*e2 twusa3= 1.d0-ss(3)*e3-ss(4)*e4+skl3p-skl3m twusa4= 1.d0-2.d0*ss(4)*e4-skl2m-skl3m twusa5= 1.d0-2.d0*ss(3)*e3+skl2p+skl3p twusa6= 1.d0-ss(3)*e3-ss(4)*e4+skl2p-skl2m atwl= dmax1(twlp,twlsa1,twlsa2,twlsa3,twlsa4, # twlsa5,twlsa6) atwu= dmin1(twup,twusa1,twusa2,twusa3,twusa4, # twusa5,twusa6) else atwl= twlp atwu= twup endif * *-----limits on tw from E * if(ieq.eq.1) then atwle= 1.d0-bxe*e3p4+bl(3)+bl(4) atwue= bxe*e1p2-bl(1)-bl(2) if(xdf.gt.0.d0) then twle= atwle twue= atwue else if(xdf.lt.0.d0) then atwle1= bxe*e1-bl(1) atwle2= bxe*e2-bl(2) atwue1= 1.d0-bxe*e3+bl(3) atwue2= 1.d0-bxe*e4+bl(4) twle= dmax1(atwue,atwle1,atwle2) twue= dmin1(atwle,atwue1,atwue2) endif atwl= dmax1(atwl,twle) atwu= dmin1(atwu,twue) endif * *-----natural limits on tw * atwl= dmax1(atwl,bt1(1)) atwu= dmin1(atwu,bt2(1)) * *-----test on tw * if(atwu.le.atwl) then iz= 0 ifz(29)= ifz(29)+1 go to 2 endif * twjc= atwu-atwl tw= twjc*twx+atwl omtw= 1.d0-tw * *-----initialization of t1 * *-----limits on t1 from positivity+SA * t1lp1= 0.d0 t1lp2= tw+sp-1.d0+sdpf t1up1= tw t1up2= sm+sdpf t1lp= dmax1(t1lp1,t1lp2) t1up= dmin1(t1up1,t1up2) * *-----limits on t1 from cuts on SA * if(iac(3).ne.0) then t1lc1= ss(1)*e1 t1lc2= tw-cs(2)*e2 t1lc3= ss(3)*e3-(omtw-0.5d0*(1.d0+sdmu-skl3)) t1lc4= -cs(4)*e4+0.5d0*(1.d0+sdmu-skl3) t1lc5= 0.5d0*(e1p3-skl2)-cs(3)*e3 t1lc6= 0.5d0*(e1p3-skl2)-omtw+ss(4)*e4 t1uc1= cs(1)*e1 t1uc2= tw-ss(2)*e2 t1uc3= cs(3)*e3-(omtw-0.5d0*(1.d0+sdmu+skl3)) t1uc4= -ss(4)*e4+0.5d0*(1.d0+sdmu+skl3) t1uc5= 0.5d0*(e1p3+skl2)-ss(3)*e3 t1uc6= 0.5d0*(e1p3+skl2)-omtw+cs(4)*e4 t1lc= dmax1(t1lc1,t1lc2,t1lc3,t1lc4,t1lc5,t1lc6) t1uc= dmin1(t1uc1,t1uc2,t1uc3,t1uc4,t1uc5,t1uc6) at1l= dmax1(t1lp,t1lc) at1u= dmin1(t1up,t1uc) else at1l= t1lp at1u= t1up endif * *-----limits on t1 from E * if(ieq.eq.1) then at1le= tw-bxe*e2+bl(2) at1ue= bxe*e1-bl(1) if(xdf.gt.0.d0) then t1le= at1le t1ue= at1ue else t1le= at1ue t1ue= at1le endif at1l= dmax1(at1l,t1le) at1u= dmin1(at1u,t1ue) endif * *-----positivity of (R')^2 / reality of roots for t3 * rp0= e1p2*e1p2-4.d0*sm if(rp0.lt.0.d0) then iz= 0 ifz(30)= ifz(30)+1 go to 2 endif srp0= sqrt(rp0) rp0e= -rp0 rp1= (e1*e1p2-2.d0*sm)*tw-sm*e1m2 rp1e= 2.d0*rp1 rp2= -(e1*tw-sm)*(e1*tw-sm) if(rp0e.eq.0.d0) then iz= 0 ifz(31)= ifz(31)+1 go to 2 endif ifct= 0 if(rp0e.ne.0.d0) then call c02ajf(rp0e,rp1e,rp2,ret1,ret2,ifct) rpds= 0.5d0*rp0*(ret2(1)-ret1(1)) t1l= dmax1(at1l,ret1(1)) t1u= dmin1(at1u,ret2(1)) else if(rp0e.eq.0.d0) then sret1= -rp2/rp1e if(rp1e.gt.0.d0) then t1l= dmax1(at1l,sret1) t1u= at1u else if(rp1e.lt.0.d0) then t1l= at1l t1u= dmin1(at1u,sret1) endif endif * *-----test on t1 * if(t1u.le.t1l) then iz= 0 ifz(31)= ifz(31)+1 go to 2 endif * *-----transformation for jacobian * if(rp0e.eq.0.d0) then taul= 2.d0/rp1e*sqrt(rp1e*t1l+rp2) taut= 2.d0/rp1e*sqrt(rp1e*t1u+rp2) t1jc= taut-taul t1= 0.25d0*rp1e*(t1jc*t1x+taul)**2-rp2/rp1e endif if(ret1(1).eq.t1l) then at1tl= -pih/srp0 else bt1tl= 1.d0+rp0/rpds*(ret1(1)-t1l) ifas= 1 at1tl= -s09aaf(bt1tl,ifas)/srp0 if(ifas.ne.0) print 200 endif if(ret2(1).eq.t1u) then at1tu= pih/srp0 else bt1tu= -1.d0+rp0/rpds*(ret2(1)-t1u) ifas= 1 at1tu= -s09aaf(bt1tu,ifas)/srp0 if(ifas.ne.0) print 200 endif if((at1tl+at1tu).eq.0.d0) then if(t1x.lt.1.d-3) then arc= pi*t1x arc2= arc*arc exc= arc2*(ec2+arc2*(ec4+arc2*(ec6+ # arc2*(ec8+arc2*ec10)))) t1= ret1(1)+0.5d0*(ret1(1)-ret2(1))*exc else if((1.d0-t1x).lt.1.d-3) then arc= pi*(1.d0-t1x) arc2= arc*arc exc= arc2*(ec2+arc2*(ec4+arc2*(ec6+ # arc2*(ec8+arc2*ec10)))) t1= ret2(1)-0.5d0*(ret1(1)-ret2(1))*exc else carc= cos(pi*t1x) t1= 0.5d0*(ret1(1)+ret2(1))+ # 0.5d0*(ret1(1)-ret2(1))*carc endif t1jc= pi/srp0 else t1tl= dmin1(at1tl,at1tu) t1tu= dmax1(at1tl,at1tu) t1jc= t1tu-t1tl t1t= t1jc*t1x+t1tl t1= (rp1+rpds*sin(srp0*t1t))/rp0 endif t1s= t1*t1 * 200 format(' Unsuccesful call to S09AAF ') * *-----test on t1 from FS A * if(ieq.eq.1.and.iac(4).ne.0.d0) then cnlct1= xp*(xm*sm-ep12*cg12)+xdf* # ep1*cg12*tw+xdf*cg12*t1*(ep2-ep1- # xdf*tw)+xdfs*cg12*t1s cnlst1= xp*(ep12*sg12-xm*sm)-xdf* # ep1*sg12*tw+xdf*sg12*t1*(ep1-ep2+ # xdf*tw)-xdfs*sg12*t1s if(cnlct1.lt.0.d0) then iz= 0 ifz(32)= ifz(32)+1 go to 2 else if(cnlst1.lt.0.d0) then iz= 0 ifz(33)= ifz(33)+1 go to 2 endif endif * * *-----some vector components * t2= tw-t1 * *-----equation for xi is solved * e1s= e1*e1 e2s= e2*e2 e3s= e3*e3 e12= e1t2-2.d0*sm e13= e1t3-2.d0*sf e23= e2t3-2.d0*su e12s= e12*e12 e13s= e13*e13 e23s= e23*e23 xia= e1s*e2s-e12s xib= 2.d0*t1*(e2s*e13-e12*e23)+2.d0*t2*(e1s*e23- # e12*e13)-e1*e2s*e13+e1*e12*e23-e1s*e2*e23+ # e2*e12*e13 xic= 8.d0*t1*t2*(-e3s*e12+e13*e23)+4.d0*t1*(-e1* # e2s*e3s+e1*e23s+e2*e3s*e12-e2*e13*e23)+4.d0* # t1s*(e2s*e3s-e23s)+4.d0*t2*(e1*e3s*e12-e1* # e13*e23-e1s*e2*e3s+e2*e13s)+4.d0*t2*t2*(e1s* # e3s-e13s)-2.d0*e1t2*e3s*e12+2.d0*e1t2*e13* # e23+e1s*e2s*e3s+e3s*e12s-2.d0*e12*e13*e23 xib= 2.d0*xib if(xia.eq.0.d0) then if(xib.eq.0.d0) then iz= 0 ifz(34)= ifz(34)+1 go to 2 endif rtm(1)= -xic/xib rtp(1)= rtm(1) rtm(2)= 0.d0 rtp(2)= 0.d0 ixia= 0 else ixia= 1 ifc0= 0 call c02ajf(xia,xib,xic,rtm,rtp,ifc0) endif if(rtm(2).ne.0.d0) then iz= 0 ifz(35)= ifz(35)+1 go to 2 endif * *-----xi^+ and xi^- are computed * xip= 0.5d0*(e3-rtp(1)) xim= 0.5d0*(e3-rtm(1)) * *-----each integral becomes a sum of two terms * *-----loop over ix starts here * if(om.eq.'g') then ixmn= ix0 ixmx= ix0 else ixmn= 1 ixmx= 2 endif do ix=ixmn,ixmx * *-----q_3 is compared and x15 is selected * if(ix.eq.1) then t3= xip else if(ix.eq.2) then t3= xim endif * *-----The two integrands are computed * *-----further auxiliary quantities * edn1= ep1-xdf*t1 edn2= ep2-xdf*t2 edn3= ep3-xdf*t3 t4= omtw-t3 edn4= ep4-xdf*t4 * *-----collections of all limits on t3 * *-----from energy (or natural limits) * if(ieq.eq.1) then at3l1= omtw-bxe*e4+bl(4) at3u1= bxe*e3-bl(3) if(xdf.gt.0.d0) then t3l1= at3l1 t3u1= at3u1 else if(xdf.lt.0.d0) then t3l1= at3u1 t3u1= at3l1 endif else t3l1= 0.d0 t3u1= e3 endif * *-----natural limits * t3l2= -t1+0.5d0*(e1p3-skl2) t3u2= -t1+0.5d0*(e1p3+skl2) * t3l3= omtw+t1-0.5d0*(1.d0+sdmu+skl3) t3u3= omtw+t1-0.5d0*(1.d0+sdmu-skl3) * *-----from positivity on SA * t3l4= 0.d0 t3l5= sm+su+sf-tw t3u4= sp+su+sf t3u5= omtw * *-----from SA * if(iac(3).ne.0) then t3l6= ss(3)*e3 t3u6= cs(3)*e3 t3l7= omtw-cs(4)*e4 t3u7= omtw-ss(4)*e4 t3l= dmax1(t3l1,t3l2,t3l3,t3l4, # t3l5,t3l6,t3l7) t3u= dmin1(t3u1,t3u2,t3u3,t3u4, # t3u5,t3u6,t3u7) else t3l= dmax1(t3l1,t3l2,t3l3,t3l4,t3l5) t3u= dmin1(t3u1,t3u2,t3u3,t3u4,t3u5) endif * *-----limits on t3 are imposed * tlimt3= (t3u-t3)*(t3-t3l) if(t3u.lt.t3l) then iz= 0 ifz(36)= ifz(36)+1 go to 4 else if(tlimt3.lt.0.d0) then iz= 0 ifz(36)= ifz(36)+1 go to 4 endif * *-----non linear limits on t3,t4 are imposed * if(iac(4).ne.0.and.ieq.eq.1) then tnl13c= -cg13*edn1*edn3+vv*sf tnl13s= sg13*edn1*edn3-vv*sf tnl23c= -cg23*edn2*edn3+vv*su tnl23s= sg23*edn2*edn3-vv*su tnl14c= -cg14*edn1*edn4+vv*sd tnl14s= sg14*edn1*edn4-vv*sd sres= 1.d0-e1-e3+sf tnl24c= -cg24*edn2*edn4+vv*sres tnl24s= sg24*edn2*edn4-vv*sres tnl34c= -cg34*edn3*edn4+vv*sp tnl34s= sg34*edn3*edn4-vv*sp if(tnl13c.lt.0.d0.or.tnl13s.lt.0.d0.or. # tnl23c.lt.0.d0.or.tnl23s.lt.0.d0.or. # tnl14c.lt.0.d0.or.tnl14s.lt.0.d0.or. # tnl24c.lt.0.d0.or.tnl24s.lt.0.d0.or. # tnl34c.lt.0.d0.or.tnl34s.lt.0.d0) then iz= 0 ifz(37)= ifz(37)+1 go to 4 endif endif * *-----non linear constraints from FS A in the case xp = xm * if(iac(4).ne.0.d0.and.ieq.eq.0) then smr= 1.d0-sm-sp-su-sd-sf spc12= (-cg12*e1t2+sm)*(sg12*e1t2-sm) spc13= (-cg13*e1t3+sf)*(sg13*e1t3-sf) spc14= (-cg14*e1t4+sd)*(sg14*e1t4-sd) spc23= (-cg23*e2t3+su)*(sg23*e2t3-su) spc24= (-cg24*e2t4+smr)*(sg24*e2t4-smr) spc34= (-cg34*e3t4+sp)*(sg34*e3t4-sp) if(spc12.lt.0.d0.or.spc13.lt.0.d0.or. # spc14.lt.0.d0.or.spc23.lt.0.d0.or. # spc24.lt.0.d0.or.spc34.lt.0.d0) then iz= 0 ifz(38)= ifz(38)+1 go to 4 endif endif * *-----all invariants * x13= t1 x14= t2 x15= t3 x16= t4 x23= e1-t1 x24= e2-t2 x25= e3-t3 x26= e4-t4 x34= sm x35= sf x36= sd x45= su x46= 1.d0-e1-e3+sf x56= sp * *-----computes cross-section * *-----born matrix element is calculated at the reduced c.m. energy * *-----The epsilons are computed in the order * epf(pp,pm,q1,q2),epf(pp,pm,q1,q3),epf(pp,pm,q1,q4), * epf(pp,pm,q2,q3),epf(pp,pm,q2,q4),epf(pp,pm,q3,q4), * epf(pp,q1,q2,q3),epf(pp,q1,q2,q4),epf(pp,q1,q3,q4), * epf(pp,q2,q3,q4),epf(pm,q1,q2,q3),epf(pm,q1,q2,q4), * epf(pm,q1,q3,q4),epf(pm,q2,q3,q4),epf(q1,q2,q3,q4) * x13s= x13*x13 x14s= x14*x14 x15s= x15*x15 x16s= x16*x16 x23s= x23*x23 x24s= x24*x24 x25s= x25*x25 x26s= x26*x26 x34s= x34*x34 x35s= x35*x35 x36s= x36*x36 x45s= x45*x45 x46s= x46*x46 x56s= x56*x56 * ee(1)= 2.d0*(x13*x14*x23*x24+x13*x24*x34+ # x14*x23*x34)-x13s*x24s-x14s*x23s-x34s ee(2)= 2.d0*(x13*x15*x23*x25+x13*x25*x35+ # x15*x23*x35)-x13s*x25s-x15s*x23s-x35s ee(3)= 2.d0*(x14*x15*x24*x25+x14*x25*x45+ # x15*x24*x45)-x14s*x25s-x15s*x24s-x45s ee(4)= 2.d0*(x13*x14*x35*x45+x13*x15*x34*x45+ # x14*x15*x34*x35)-x13s*x45s-x14s*x35s- # x15s*x34s ee(5)= 2.d0*(x23*x24*x35*x45+x23*x25*x34*x45+ # x24*x25*x34*x35)-x23s*x45s-x24s*x35s- # x25s*x34s * e(1)= 1.d0 e(2)= x13*x14*x23*x25+x13*x15*x23*x24+x13*(-2.d0* # x23*x45+x24*x35+x25*x34)-x14*x15*x23s+x14* # x23*x35+x15*x23*x34-x13s*x24*x25-x34*x35 e(3)= -x13*x14*x24*x25+x13*x15*x24s-x13*x24*x45- # x14*x15*x23*x24+x14*(-x23*x45+2.d0*x24*x35- # x25*x34)-x15*x24*x34+x14s*x23*x25+x34*x45 e(4)= x13*x14*(x23*x45+x24*x35-2.d0*x25*x34)+x13* # x15*x24*x34+x13*x34*x45+x14*x15*x23*x34+x14* # x34*x35-x15*x34s-x13s*x24*x45-x14s*x23*x35 e(5)= x13*(-x23*x24*x45-x24*x25*x34+x35*x24s)+x14* # (-x23*x24*x35-x23*x25*x34+x45*x23s)+x15* # 2.d0*x23*x24*x34-x23*x34*x45-x24*x34*x35+ # x25*x34s * *-----sign of eps_1*eps_i * ises= 0 sg(1)= 0.25d0 if(ee(1).lt.0.d0) then ises= ises+1 endif do i=2,5 if(abs(e(i)).lt.zrm) then ises= ises+1 else if(e(i).gt.zrm) then sg(i)= 0.25d0 else if(e(i).lt.-zrm) then sg(i)= -0.25d0 endif if(ee(i).lt.0.d0) then ises= ises+1 endif enddo * if(ises.eq.0) then ses1= sg(1)*sqrt(ee(1)) ses2= sg(2)*sqrt(ee(2)) ses3= sg(3)*sqrt(ee(3)) ses4= sg(4)*sqrt(ee(4)) ses5= sg(5)*sqrt(ee(5)) s1= ses1 s2= ses2 s3= -ses1-ses2 s4= ses3 s5= ses1-ses3 s6= ses2+ses3 s7= ses4 s8= ses1-ses4 s9= ses2+ses4 s10= ses3-ses4 s11= ses5 s12= -ses1-ses5 s13= -ses2+ses5 s14= -ses3-ses5 s15= -ses4-ses5 else ee(1)= 2.d0*(x13*x14*x23*x24+x13*x24*x34+ # x14*x23*x34)-x13s*x24s-x14s*x23s-x34s ee(2)= 2.d0*(x13*x16*x23*x26+x13*x26*x36+ # x16*x23*x36)-x13s*x26s-x16s*x23s-x36s ee(3)= 2.d0*(x14*x16*x24*x26+x14*x26*x46+ # x16*x24*x46)-x14s*x26s-x16s*x24s-x46s ee(4)= 2.d0*(x13*x14*x36*x46+x13*x16*x34*x46+ # x14*x16*x34*x36)-x13s*x46s-x14s*x36s- # x16s*x34s ee(5)= 2.d0*(x23*x24*x36*x46+x23*x26*x34*x46+ # x24*x26*x34*x36)-x23s*x46s-x24s*x36s- # x26s*x34s e(1)= 1.d0 e(2)= x13*x14*x23*x26+x13*x16*x23*x24+ # x13*(-2.d0*x23*x46+x24*x36+x26*x34)- # x14*x16*x23s+x14*x23*x36+x16*x23*x34- # x13s*x24*x26-x34*x36 e(3)= -x13*x14*x24*x26+x13*x16*x24s-x13* # x24*x46-x14*x16*x23*x24+x14*(-x23* # x46+2.d0*x24*x36-x26*x34)-x16*x24* # x34+x14s*x23*x26+x34*x46 e(4)= x13*x14*(x23*x46+x24*x36-2.d0*x26* # x34)+x13*x16*x24*x34+x13*x34*x46+ # x14*x16*x23*x34+x14*x34*x36-x16* # x34s-x13s*x24*x46-x14s*x23*x36 e(5)= x13*(-x23*x24*x46-x24*x26*x34+x36* # x24s)+x14*(-x23*x24*x36-x23*x26* # x34+x46*x23s)+x16*2.d0*x23*x24*x34- # x23*x34*x46-x24*x34*x36+x26*x34s ises= 0 sg(1)= 0.25d0 if(ee(1).lt.0.d0) then ises= ises+1 endif do i=2,5 if(abs(e(i)).lt.zrm) then ises= ises+1 else if(e(i).gt.zrm) then sg(i)= 0.25d0 else if(e(i).lt.-zrm) then sg(i)= -0.25d0 endif if(ee(i).lt.0.d0) then ises= ises+1 endif enddo if(ises.eq.0) then ses1= sg(1)*sqrt(ee(1)) ses2= sg(2)*sqrt(ee(2)) ses3= sg(3)*sqrt(ee(3)) ses4= sg(4)*sqrt(ee(4)) ses5= sg(5)*sqrt(ee(5)) s1= ses1 s2= -ses1-ses2 s3= ses2 s4= -ses1-ses3 s5= ses3 s6= -ses2-ses3 s7= ses1-ses4 s8= ses4 s9= -ses2-ses4 s10= -ses3+ses4 s11= -ses1-ses5 s12= ses5 s13= ses2-ses5 s14= ses3+ses5 s15= ses4+ses5 else ee(1)= 2.d0*(x13*x15*x23*x25+x13*x25*x35+ # x15*x23*x35)-x13s*x25s-x15s*x23s- # x35s ee(2)= 2.d0*(x13*x16*x23*x26+x13*x26*x36+ # x16*x23*x36)-x13s*x26s-x16s*x23s- # x36s ee(3)= 2.d0*(x15*x16*x25*x26+x15*x26*x56+ # x16*x25*x56)-x15s*x26s-x16s*x25s- # x56s ee(4)= 2.d0*(x13*x15*x36*x56+x13*x16*x35* # x56+x15*x16*x35*x36)-x13s*x56s- # x15s*x36s-x16s*x35s ee(5)= 2.d0*(x23*x25*x36*x56+x23*x26*x35* # x56+x25*x26*x35*x36)-x23s*x56s- # x25s*x36s-x26s*x35s * e(1)= x13*x14*x23*x25+x13*x15*x23*x24+ # x13*(-2.d0*x23*x45+x24*x35+x25*x34)- # x14*x15*x23s+x14*x23*x35+x15*x23* # x34-x13s*x24*x25-x34*x35 e(2)= x13*x14*x23*x26+x13*x16*x23*x24+ # x13*(-2.d0*x23*x46+x24*x36+x26*x34)- # x14*x16*x23s+x14*x23*x36+x16*x23* # x34-x13s*x24*x26-x34*x36 e(3)= -x13*x15*x24*x26+x13*x16*x24*x25+ # x13*(-x25*x46+x26*x45)+x14*x15*x23* # x26-x14*x16*x23*x25+x14*(x25*x36-x26* # x35)+x15*(-x23*x46+x24*x36)+x16*(x23* # x45-x24*x35)+x35*x46-x36*x45 e(4)= x13*x14*(x25*x36-x26*x35)+x13*x15* # (x23*x46-x26*x34)+x13*x16*(-x23*x45+ # x25*x34)+x13*(x35*x46-x36*x45)-x14* # x15*x23*x36+x14*x16*x23*x35+x15*x34* # x36-x16*x34*x35+x13s*(-x25*x46+x26* # x45) e(5)= x13*(-x23*x25*x46+x23*x26*x45+x24*x25* # x36-x24*x26*x35)+x15*(-x23*x24*x36- # x23*x26*x34+x46*x23s)+x16*(x23*x24* # x35+x23*x25*x34-x45*x23s)-x23*x35* # x46+x23*x36*x45-x25*x34*x36+x26*x34* # x35 * ises= 0 do i=1,5 if(abs(e(i)).lt.zrm) then ises= ises+1 else if(e(i).gt.zrm) then sg(i)= 0.25d0 else if(e(i).lt.-zrm) then sg(i)= -0.25d0 endif if(ee(i).lt.0.d0) then ises= ises+1 endif enddo if(ises.eq.0) then ses1= sg(1)*sqrt(ee(1)) ses2= sg(2)*sqrt(ee(2)) ses3= sg(3)*sqrt(ee(3)) ses4= sg(4)*sqrt(ee(4)) ses5= sg(5)*sqrt(ee(5)) s1= -ses1-ses2 s2= ses1 s3= ses2 s4= -ses1+ses3 s5= -ses2-ses3 s6= ses3 s7= -ses1+ses4 s8= -ses2-ses4 s9= ses4 s10= ses3-ses4 s11= ses1+ses5 s12= ses2-ses5 s13= ses5 s14= -ses3-ses5 s15= -ses4-ses5 else iz= 0 ifz(39)= ifz(39)+1 go to 4 endif endif endif * *-----Loops over permutations start here * do ip=1,4 if(ip.eq.1) then y13= x13 y14= x14 y15= x15 y16= x16 y23= x23 y24= x24 y25= x25 y26= x26 y34= x34 y35= x35 y36= x36 y45= x45 y46= x46 y56= x56 ys1= s1 ys2= s2 ys3= s3 ys4= s4 ys5= s5 ys6= s6 ys7= s7 ys8= s8 ys9= s9 ys10= s10 ys11= s11 ys12= s12 ys13= s13 ys14= s14 ys15= s15 ysm= sm ysp= sp ysu= su ysd= sd ytw= t1+t2 j1= 1 j2= 2 j3= 3 j4= 4 j5= 5 j6= 6 j7= 7 j8= 8 l1= 1 l2= 2 l3= 3 l4= 4 i3= 3 i4= 4 else if(ip.eq.2) then y13= x15 y14= x14 y15= x13 y16= x16 y23= x25 y24= x24 y25= x23 y26= x26 y34= x45 y35= x35 y36= x56 y45= x34 y46= x46 y56= x36 ys1= -s4 ys2= -s2 ys3= s6 ys4= -s1 ys5= s5 ys6= s3 ys7= -s7 ys8= -s10 ys9= -s9 ys10= -s8 ys11= -s11 ys12= -s14 ys13= -s13 ys14= -s12 ys15= -s15 ysm= su ysp= sd ysu= sm ysd= sp ytw= t3+t2 j1= 1 j2= 2 j3= 3 j4= 4 j5= 9 j6= 10 j7= 11 j8= 12 l1= 1 l2= 2 l3= 5 l4= 6 i3= 5 i4= 6 else if(ip.eq.3) then y13= x13 y14= x16 y15= x15 y16= x14 y23= x23 y24= x26 y25= x25 y26= x24 y34= x36 y35= x35 y36= x34 y45= x56 y46= x46 y56= x45 ys1= s3 ys2= s2 ys3= s1 ys4= -s6 ys5= -s5 ys6= -s4 ys7= -s9 ys8= -s8 ys9= -s7 ys10= -s10 ys11= -s13 ys12= -s12 ys13= -s11 ys14= -s14 ys15= -s15 ysm= sd ysp= su ysu= sp ysd= sm ytw= t1+t4 j1= 1 j2= 2 j3= 3 j4= 4 j5= 11 j6= 12 j7= 9 j8= 10 l1= 1 l2= 2 l3= 6 l4= 5 i3= 6 i4= 5 else if(ip.eq.4) then y13= x15 y14= x16 y15= x13 y16= x14 y23= x25 y24= x26 y25= x23 y26= x24 y34= x56 y35= x35 y36= x45 y45= x36 y46= x46 y56= x34 ys1= s6 ys2= -s2 ys3= -s4 ys4= -s3 ys5= -s5 ys6= s1 ys7= s9 ys8= s10 ys9= s7 ys10= s8 ys11= s13 ys12= s14 ys13= s11 ys14= s12 ys15= s15 ysm= sp ysp= sm ysu= sd ysd= su ytw= t3+t4 j1= 1 j2= 2 j3= 3 j4= 4 j5= 7 j6= 8 j7= 5 j8= 6 l1= 1 l2= 2 l3= 4 l4= 3 i3= 4 i4= 3 endif * y13s= y13*y13 y14s= y14*y14 y15s= y15*y15 y16s= y16*y16 y23s= y23*y23 y24s= y24*y24 y25s= y25*y25 y26s= y26*y26 y34s= y34*y34 y35s= y35*y35 y36s= y36*y36 y45s= y45*y45 y46s= y46*y46 y56s= y56*y56 smtp= ysm*ysp pn= ytw+ysp-1.d0 zpcfr= ysp-rzm2/vv zmcfr= ysm-rzm2/vv zpcfi= ysp*szg zmcfi= ysm*szg * *-----Compensating double Z propagator * ztcfr= zpcfr*zmcfr-ysp*ysm*szgs ztcfi= zpcfr*zmcfi+zmcfr*zpcfi * *-----propagators for pair production diagrams * pfpb= y15+y25-1.d0 pfp= y16+y26-1.d0 * tgn(1)= y15*y24 tgn(2)= y34*y46 tgn(3)= y34/y46 tgn(4)= y24/y15 tgn(5)= y15/y25 tgn(6)= y15*y25 tgn(7)= y14*y25 tgn(8)= y14*y34 tgn(9)= y25*y46 tgn(10)= y25/y46 tgn(11)= y14/y34 tgn(12)= y45/y36 tgn(13)= y14*y24 tgn(14)= y24/y14 tgn(15)= y45*y36 tgn(16)= y14/y25 * itgn= 0 do l=1,16 if(tgn(l).le.0.d0) then itgn= itgn+1 endif enddo if(itgn.ne.0) then iz= 0 ifz(40)= ifz(40)+1 go to 4 endif * gpna= sqrt(tgn(1)) gpnb= sqrt(tgn(2)) gpnc= sqrt(tgn(3)) gpnd= sqrt(tgn(4)) gpne= sqrt(tgn(5)) gpnf= sqrt(tgn(6)) gpng= sqrt(tgn(7)) gmna= sqrt(tgn(8)) gmnb= sqrt(tgn(9)) gmnc= sqrt(tgn(10)) gmnd= sqrt(tgn(11)) gmne= sqrt(tgn(12)) gmnf= sqrt(tgn(13)) gmng= sqrt(tgn(14)) gmnh= sqrt(tgn(15)) gmni= sqrt(tgn(16)) * gn1= gpna/gpnb gn2= gpna*gpnc gn3= gpna/gpnc gn4= gpnd/gpnb gn5= 1.d0/gpna/gpnc gn6= 1.d0/gpnd/gpnc gn7= gpnd/gpnc gn8= gpnb/gpna gn9= gpnd*gpnc gn10= gpnb/gpnd gn11= gpna*gpnb gn12= gmnd/gmnb gn13= 1.d0/gmnc/gmna gn14= gmna/gmnb gn15= gmnd/gmnc gn16= 1.d0/gmnd/gmnc gn17= gmna*gmnb gn18= gmnc/gmnd gn19= gmnc/gmna gn20= gmna*gmnc gn21= gmnd*gmnb gn22= gmnd*gmnc gn23= gmnb/gmnd gn24= gmnb/gmna gn25= gpnc/gpnd gn26= 1.d0/gpna/gpnb gn27= gpnc/gpna gn28= 1.d0/gpnd/gpnb gn29= gpne/gmnh gn30= gmne/gpnf gn31= 1.d0/gpnf/gmne gn32= 1.d0/gpnf/gmnh gn33= gpne*gmne gn34= gpne/gmne gn35= gmnh/gpnf gn36= gmnh*gpne gn37= gpnb*gmni gn38= gpnc/gpng gn39= 1.d0/gpng/gpnb gn40= gmne/gmnf gn41= gmng*gmne gn42= 1.d0/gmnf/gmnh gn43= gmng/gmnh gn44= gmne/gmng gn45= 1.d0/gmng/gmnh gn46= gmnf/gmnh gn47= gmnf*gmne gn48= gmnh/gmnf gn49= 1.d0/gmng/gmne gn50= gmng*gmnh gn51= 1.d0/gmnf/gmne gn52= gmnh/gmng gn53= gmnf*gmnh gn54= gmnf/gmne gn55= 1.d0/gpnb*gmni gn56= 1.d0/gpnc/gpng gn57= gpnc*gmni gn58= 1.d0/gpnc*gmni gn59= gpnb/gpng gn60= gpnb*gpng gn61= gpnc/gmni gn62= 1.d0/gpnb/gmni gn63= gpnc*gpng gn64= 1.d0/gpnc*gpng gn65= 1.d0/gpnb*gpng gn66= gpnb/gmni gn67= 1.d0/gpnc/gmni gn68= gpne/gmne gn69= 1.d0/gpnf*gmnh gn70= 1.d0/gmne*gmng * *-----Few common combinations * p1= y13*y14 p4= y13*y25 p7= y13*y26 p9= y13*y45 p10= y13*y46 p11= y13*y56 p12= y14*y16 p13= y14*y23 p15= y14*y25 p16= y14*y25s p17= y14*y26 p18= y14*y35 p20= y14*y36 p23= y15*y23 p24= y15*y24 p25= y15*y26 p29= y16*y23 p31= y16*y25 p33= y16*y34 p34= y16*y35 p41= y23*y45 p42= y23*y46 p43= y23*y56 p45= y24*y25 p46= y24*y35 p47= y24*y36 p48= y24*y56 p49= y25*y26 p50= y25*y34 p51= y25*y35 p52= y25*y36 p54= y25*y46 p55= y25*y56 p56= y26*y34 p57= y26*y35 p61= y26*y45 p67= y34*y56 p71= y35*y46 p73= y36*y45 * u4= y13*p48 u5= p4*y46 u7= p7*y45 u8= y13*p73 u13= p13*y56 u15= p15*y35 u16= p15*y36 u17= p15*y56 u18= p17*y35 u19= p18*y36 u21= p23*y46 u22= p24*y36 u23= p25*y34 u24= p29*y45 u25= y16*p46 u26= p31*y34 * w1= p7-p29 w2= p9-p18 w3= p42-p56 w4= p11-p34 w5= p31-y56 w8= p67-p71 w9= p43-p57 *-----Conversion for helicity sets * *---Permutation 1, 1 <-> 3 * * pp pm q1 q2 q3 q4 ==> pp pm q1 q2 q3 q4 * * + - + - + - a + - + - + - a * - + - + - + b - + - + - + b * + - - + - + c + - - + - + c * - + + - + - d - + + - + - d * + - + - - + e + - - - + + i * - + - + + - f - + + + - - j * + - - + + - g + - + + - - l * - + + - - + h - + - - + + m * *---Permutation 2, 2 <-> 4 * * pp pm q1 q2 q3 q4 ==> pp pm q1 q2 q3 q4 * * + - + - + - a + - + - + - a * - + - + - + b - + - + - + b * + - - + - + c + - - + - + c * - + + - + - d - + + - + - d * + - + - - + e + - + + - - l * - + - + + - f - + - - + + m * + - - + + - g + - - - + + i * - + + - - + h - + + + - - j * *---Permutation 3, 1 <-> 3,2 <-> 4 * * pp pm q1 q2 q3 q4 ==> pp pm q1 q2 q3 q4 * * + - + - + - a + - + - + - a * - + - + - + b - + - + - + b * + - - + - + c + - - + - + c * - + + - + - d - + + - + - d * + - + - - + e + - - + + - g * - + - + + - f - + + - - + h * + - - + + - g + - + - - + e * - + + - - + h - + - + + - f * * a-b = 1, c-d = 2, e-f = 3, g-h = 4, i-j = 5, l-m = 6 * *-----helicity a-b) * *-----Conversion diagram 1: common part * crc(ip,1)= 16.d0*(gn12*(u4-u7-u13-u16+u18-u22+u24-u25+p73)+gn13* # (-u4-u5+u7-u21+u22+u24-u25+p71-p73)+gn14*(p25+w5)+ # gn15*(p4+p23+w9+p52-y35)+gn16*(-p25+p31+y56)) * cic(ip,1)= 64.d0*(ys1*gn12*y56+ys1*gn13*(-2.d0*y15+y56)+2.d0*ys5* # gn38*(-y15+y56)-ys6*gn14+ys6*gn16+ys7*gn13*y26+2.d0* # ys8*gn39*y24*(y15-y56)-ys8*gn13*y25+ys9*gn12*y24-ys10* # gn12*y23+ys11*gn12*y16+ys12*gn12*(-y15+2.d0*y56)-ys13* # gn15+ys14*gn13*y13) * if(ip.eq.1) then xcrc(1,1)= crc(1,1) xcic(1,1)= cic(1,1) xcrc(3,1)= 16.d0*(gn55*(u4-u7-u13-u16+u18-y15*p47+u24-u25+ # p73)+gn57*(p25+w5)+gn58*(p4+p23-2.d0*p41+2.d0* # p46-y35)-2.d0*gn37*y25) xcic(3,1)= 64.d0*(ys2*gn58-ys5*gn55*y35+ys8*gn55*y25-ys10* # gn55*y23+ys11*gn55*y16-2.d0*ys11*gn58+ys13*gn55* # y14) xcrc(2,1)= 32.d0*(-gn55*u16-gn56*u5+gn57*p31+gn58*(p4+p52)+ # gn59*p31) xcic(2,1)= 128.d0*(ys8*gn55*y25-ys8*gn56*y25) xcrc(4,1)= 32.d0*(-gn12*u16+gn14*p31+gn15*p4-2.d0*gn37*y25) xcic(4,1)= 128.d0*ys8*gn12*y25 endif * *-----Pair production I: common part * p1rc(ip,1)= 32.d0*(gn13*p4*(y24-y45)+gn15*y25*(-y23+y35)+gn16* # y25*(y15-1.d0)) p1ic(ip,1)= 128.d0*gn13*y25*(ys1-ys7) * *-----Pair production II: common part * p2rc(ip,1)= 16.d0*(gn12*(-u4+u7+u13-u16-u18+u22-u24+u25-p73)+ # gn13*(u4-u5-u7+u21-u22-u24+u25-p71+p73)+gn14*(-p25+ # p31+y56)+gn15*(p4-p23-w9+p52+y35)+gn16*(p25+w5)) p2ic(ip,1)= 64.d0*(ys1*gn13*y56-ys2*gn15+ys5*gn12*y35-ys6* # gn16-ys7*gn13*y26+ys8*gn12*y25-ys8*gn13*y25+ys10* # gn12*y23-ys11*gn12*y16-ys13*gn12*y14+ys13*gn15- # ys14*gn13*y13) * *-----helicity c-d) * *-----Conversion diagram 1: common part * crc(ip,2)= 32.d0*(gn1*y36*(y14-y45)+gn2*(-y16+y56)+gn3*(-y13+ # y35)) cic(ip,2)= 128.d0*gn1*(ys8-ys15) * if(ip.eq.1) then xcrc(1,2)= crc(1,2) xcic(1,2)= cic(1,2) xcrc(3,2)= 32.d0*(gn1*(p20-p73)+gn2*(-y16+y56)+gn6*(-p13+ # p41)+gn10*(1.d0-y25)) xcic(3,2)= -128.d0*(ys1*gn6-ys8*gn1+ys11*gn6+ys15*gn1) xcrc(2,2)= 32.d0*(gn1*p20-gn2*y16-gn3*y13+gn4*(u8-u19)-gn9* # w4) xcic(2,2)= 128.d0*(-ys7*gn4*y36+ys8*gn1-ys9*gn9) xcrc(4,2)= 32.d0*(gn1*p20-gn2*y16+gn4*y36*w2-gn5*y23*w2-gn6* # p13+gn8*(p4-y35)-gn9*w4+gn10) xcic(4,2)= 128.d0*(ys1*gn5*y35+ys5*gn25-ys8*gn4*y35+ys11* # gn5*y13+ys12*gn28*y14+ys15*gn4*y13) endif * *-----Pair production I: common part * p1rc(ip,2)= 32.d0*(gn3*(y13-y35)+gn6*y23*(-y14+y45)+gn10*(1.d0- # y25)) p1ic(ip,2)= -128.d0*gn6*(ys1+ys11) * *-----Pair production II: common part * p2rc(ip,2)= 16.d0*(gn1*p47-gn2*y26-gn3*(y23+y36)+gn4*(-u4+u7+ # u13-u16-u18-u24+u25+p73)+gn5*(-u5+u7-u13+u16-u18+ # u24+p71-p73)+gn6*(p42)+gn7*(p4+w4-y35)-gn8*w5+gn9* # w5-gn10*y26) p2ic(ip,2)= 64.d0*(-ys2*gn5*y46+ys2*gn7-ys4*gn4*y36+ys4*gn5* # y36+ys6*gn8-ys6*gn9-2.d0*ys7*gn5*y26-ys8*gn4*y25+ # ys8*gn5*y25+ys12*gn1-ys12*gn6+ys15*gn4-ys15*gn5) * *-----helicity e-f) * *-----Conversion diagram 1: common part * crc(ip,i3)= 16.d0*(gn40*(u5-u7-u21+u23+u24-u26+w8)-gn41*w4+ # gn44*(w1-w9)+gn45*(-u5+u13-u18-u21+u23+u26-w8)+ # gn46*w4+gn48*y45+gn49*p15-gn50*y15-gn52*(1.d0+ # y25)-gn54*y15) cic(ip,i3)= 64.d0*(-ys1*gn40*y56+ys3*gn44+ys4*gn48-ys4*gn49- # ys5*gn40*y35+ys7*gn45*y26+ys9*gn41-ys10*gn45*y23+ # ys12*gn45*y15+ys13*gn44-ys13*gn45*y14+ys15*gn40) * if(ip.eq.1) then xcrc(1,3)= crc(1,3) xcic(1,3)= cic(1,3) xcrc(3,6)= 32.d0*(gn1*(-p20+p73)+gn3*(y13-y35)+gn10*(-1.d0+ # y25)+gn25*(p17-p61)) xcic(3,6)= 128.d0*(-ys5*gn25+ys8*gn1+ys14*gn25-ys15*gn1) xcrc(2,5)= 32.d0*(gn38*u26+gn55*u16-gn57*(p31+p52)-gn58*p4- # gn59*p4) xcic(2,5)= 128.d0*(-ys8*gn38*y25+ys8*gn55*y25) xcrc(4,4)= 32.d0*(gn29*y25*(-p10+p33)+gn31*u15+gn32*p15* # w4-gn34*p50-gn35*p4) xcic(4,4)= 128.d0*(ys7*gn31*y25-ys8*gn29*y25+ys9*gn32*p15) endif * *-----Pair production I: common part * p1rc(ip,i3)= 32.d0*(-gn48*y45-gn49*p15+gn50*y15+gn52*(1.d0+ # y25)+gn54*y15) p1ic(ip,i3)= 128.d0*(gn49-gn48)*ys4 * *-----Pair production II: common part * p2rc(ip,i3)= 32.d0*(gn40*w3+gn41*w1-gn48*y46+gn50*y16+gn52*y26) p2ic(ip,i3)= 128.d0*(ys1*gn40*y26+ys5*gn40*y23-ys5*gn48) * *-----helicity g-h) * *-----Conversion diagram 1: common part * crc(ip,i4)= 32.d0*(gn29*(-u5+u26)-gn30*w4-gn31*u17+gn32*(p1* # p55-p12*p51)+gn33*w1+gn34*p54+gn35*y56-gn36*y26) cic(ip,i4)= 128.d0*(-ys2*gn30*y16-ys6*gn30*y13+ys6*gn35-ys7* # gn32*p31-ys10*gn31*y25+ys10*gn32*p4) * if(ip.eq.1) then xcrc(1,4)= crc(1,4) xcic(1,4)= cic(1,4) xcrc(3,5)= 16.d0*(gn55*(u4-u7-u13+u16+u18+u22+u24-u25-p73)+ # gn57*(-p25-w5-2.d0*p48+2.d0*p61)+gn58*(-p4-p23+ # y35)+2.d0*gn37*y25) xcic(3,5)= 64.d0*(-ys1*gn55*y56+ys6*gn57+ys7*gn55*y26+ys8* # gn55*y25+ys13*gn55*y14-ys14*gn55*y13+2.d0*ys14* # gn57) xcrc(2,6)= 32.d0*(-gn1*p20+gn2*y16+gn3*y13+gn4*(p20*y56-y16* # p73)-gn7*w4) xcic(2,6)= 128.d0*(ys8*gn1-ys9*gn7+ys10*gn4*y36) xcrc(4,3)= 16.d0*(gn44*(w1+2.d0*w3)+gn45*(-u5+u13-u18-u21+ # u23+u26-w8)+gn46*w4-gn49*p15+gn52-2.d0*gn53+gn54* # y15) xcic(4,3)= 64.d0*(ys3*gn44+ys4*gn49+ys7*gn45*y26-ys10*gn45* # y23-2.d0*ys12*gn44+ys12*gn45*y15-ys13*gn45*y14) endif * *-----Pair production I: common part * p1rc(ip,i4)= 32.d0*(gn31*p16-gn34*p45-gn35*y25+2.d0*gn36*y25) p1ic(ip,i4)= 128.d0*ys4*gn31*y25 * *-----Pair production II: common part * p2rc(ip,i4)= 32.d0*(gn30*w4-gn33*w1+gn35*w5+gn36*y26) p2ic(ip,i4)= 128.d0*(ys2*gn30*y16+ys6*gn30*y13-ys6*gn35+ys7* # gn32*(p31-0.5d0*p49)-ys8*gn29*y25+0.5d0*ys8*gn32* # y25s+ys9*gn32*y25*(y14-0.5d0*y24)+ys10*gn32*y25* # (-y13+0.5d0*y23)+0.5d0*ys11*gn32*p31-0.5d0*ys12* # gn29*y25+0.5d0*ys13*gn32*p15-0.5d0*ys14*gn32*p4) * *-----complete diagrams, epsilon real and imag parts separated: * *-----Conversion gamma-gamma * ccgg= -conc(1)/smtp/pn * ccggr= ccgg*ztcfr ccggi= ccgg*ztcfi * cggr(ip,j1)= ccggr*crc(ip,l1) cggre(ip,j1)= -ccggi*cic(ip,l1) cggie(ip,j1)= ccggr*cic(ip,l1) cggi(ip,j1)= ccggi*crc(ip,l1) * cggr(ip,j2)= -cggr(ip,j1) cggre(ip,j2)= cggre(ip,j1) cggie(ip,j2)= cggie(ip,j1) cggi(ip,j2)= -cggi(ip,j1) * cggr(ip,j3)= ccggr*crc(ip,l2) cggre(ip,j3)= -ccggi*cic(ip,l2) cggie(ip,j3)= ccggr*cic(ip,l2) cggi(ip,j3)= ccggi*crc(ip,l2) * cggr(ip,j4)= -cggr(ip,j3) cggre(ip,j4)= cggre(ip,j3) cggie(ip,j4)= cggie(ip,j3) cggi(ip,j4)= -cggi(ip,j3) * cggr(ip,j5)= ccggr*crc(ip,l3) cggre(ip,j5)= -ccggi*cic(ip,l3) cggie(ip,j5)= ccggr*cic(ip,l3) cggi(ip,j5)= ccggi*crc(ip,l3) * cggr(ip,j6)= -cggr(ip,j5) cggre(ip,j6)= cggre(ip,j5) cggie(ip,j6)= cggie(ip,j5) cggi(ip,j6)= -cggi(ip,j5) * cggr(ip,j7)= ccggr*crc(ip,l4) cggre(ip,j7)= -ccggi*cic(ip,l4) cggie(ip,j7)= ccggr*cic(ip,l4) cggi(ip,j7)= ccggi*crc(ip,l4) * cggr(ip,j8)= -cggr(ip,j7) cggre(ip,j8)= cggre(ip,j7) cggie(ip,j8)= cggie(ip,j7) cggi(ip,j8)= -cggi(ip,j7) * *-----Conversion gamma-Z * ccgz= conc(3)/ysp/pn * do i=1,4 har(i)= hch(i)*ccgz*zpcfr hai(i)= hch(i)*ccgz*zpcfi enddo * cgzr(ip,j1)= har(1)*crc(ip,l1) cgzre(ip,j1)= -hai(1)*cic(ip,l1) cgzie(ip,j1)= har(1)*cic(ip,l1) cgzi(ip,j1)= hai(1)*crc(ip,l1) * cgzr(ip,j2)= -har(2)*crc(ip,l1) cgzre(ip,j2)= -hai(2)*cic(ip,l1) cgzie(ip,j2)= har(2)*cic(ip,l1) cgzi(ip,j2)= -hai(2)*crc(ip,l1) * cgzr(ip,j3)= har(3)*crc(ip,l2) cgzre(ip,j3)= -hai(3)*cic(ip,l2) cgzie(ip,j3)= har(3)*cic(ip,l2) cgzi(ip,j3)= hai(3)*crc(ip,l2) * cgzr(ip,j4)= -har(4)*crc(ip,l2) cgzre(ip,j4)= -hai(4)*cic(ip,l2) cgzie(ip,j4)= har(4)*cic(ip,l2) cgzi(ip,j4)= -hai(4)*crc(ip,l2) * cgzr(ip,j5)= har(1)*crc(ip,l3) cgzre(ip,j5)= -hai(1)*cic(ip,l3) cgzie(ip,j5)= har(1)*cic(ip,l3) cgzi(ip,j5)= hai(1)*crc(ip,l3) * cgzr(ip,j6)= -har(2)*crc(ip,l3) cgzre(ip,j6)= -hai(2)*cic(ip,l3) cgzie(ip,j6)= har(2)*cic(ip,l3) cgzi(ip,j6)= -hai(2)*crc(ip,l3) * cgzr(ip,j7)= har(3)*crc(ip,l4) cgzre(ip,j7)= -hai(3)*cic(ip,l4) cgzie(ip,j7)= har(3)*cic(ip,l4) cgzi(ip,j7)= hai(3)*crc(ip,l4) * cgzr(ip,j8)= -har(4)*crc(ip,l4) cgzre(ip,j8)= -hai(4)*cic(ip,l4) cgzie(ip,j8)= har(4)*cic(ip,l4) cgzi(ip,j8)= -hai(4)*crc(ip,l4) * *-----Conversion Z-gamma * cczg= conc(2)/ysm/pn * do i=1,4 ip4= i+4 hapr(i)= hch(ip4)*cczg*zmcfr hapi(i)= hch(ip4)*cczg*zmcfi enddo * czgr(ip,j1)= hapr(1)*crc(ip,l1) czgre(ip,j1)= -hapi(1)*cic(ip,l1) czgie(ip,j1)= hapr(1)*cic(ip,l1) czgi(ip,j1)= hapi(1)*crc(ip,l1) * czgr(ip,j2)= -hapr(2)*crc(ip,l1) czgre(ip,j2)= -hapi(2)*cic(ip,l1) czgie(ip,j2)= hapr(2)*cic(ip,l1) czgi(ip,j2)= -hapi(2)*crc(ip,l1) * czgr(ip,j3)= hapr(3)*crc(ip,l2) czgre(ip,j3)= -hapi(3)*cic(ip,l2) czgie(ip,j3)= hapr(3)*cic(ip,l2) czgi(ip,j3)= hapi(3)*crc(ip,l2) * czgr(ip,j4)= -hapr(4)*crc(ip,l2) czgre(ip,j4)= -hapi(4)*cic(ip,l2) czgie(ip,j4)= hapr(4)*cic(ip,l2) czgi(ip,j4)= -hapi(4)*crc(ip,l2) * czgr(ip,j5)= hapr(3)*crc(ip,l3) czgre(ip,j5)= -hapi(3)*cic(ip,l3) czgie(ip,j5)= hapr(3)*cic(ip,l3) czgi(ip,j5)= hapi(3)*crc(ip,l3) * czgr(ip,j6)= -hapr(4)*crc(ip,l3) czgre(ip,j6)= -hapi(4)*cic(ip,l3) czgie(ip,j6)= hapr(4)*cic(ip,l3) czgi(ip,j6)= -hapi(4)*crc(ip,l3) * czgr(ip,j7)= hapr(1)*crc(ip,l4) czgre(ip,j7)= -hapi(1)*cic(ip,l4) czgie(ip,j7)= hapr(1)*cic(ip,l4) czgi(ip,j7)= hapi(1)*crc(ip,l4) * czgr(ip,j8)= -hapr(2)*crc(ip,l4) czgre(ip,j8)= -hapi(2)*cic(ip,l4) czgie(ip,j8)= hapr(2)*cic(ip,l4) czgi(ip,j8)= -hapi(2)*crc(ip,l4) * *-----Conversion Z-Z * do i=1,8 ip8= i+8 hc(i)= -hch(ip8)*conc(5)/pn enddo * czzr(ip,j1)= hc(1)*crc(ip,l1) czzie(ip,j1)= hc(1)*cic(ip,l1) * czzr(ip,j2)= -hc(2)*crc(ip,l1) czzie(ip,j2)= hc(2)*cic(ip,l1) * czzr(ip,j3)= hc(7)*crc(ip,l2) czzie(ip,j3)= hc(7)*cic(ip,l2) * czzr(ip,j4)= -hc(8)*crc(ip,l2) czzie(ip,j4)= hc(8)*cic(ip,l2) * czzr(ip,j5)= hc(3)*crc(ip,l3) czzie(ip,j5)= hc(3)*cic(ip,l3) * czzr(ip,j6)= -hc(4)*crc(ip,l3) czzie(ip,j6)= hc(4)*cic(ip,l3) * czzr(ip,j7)= hc(5)*crc(ip,l4) czzie(ip,j7)= hc(5)*cic(ip,l4) * czzr(ip,j8)= -hc(6)*crc(ip,l4) czzie(ip,j8)= hc(6)*cic(ip,l4) * *-----All PP1-PP2 gamma-gamma(gluon) * cp12gg= conc(6)/ysm cp1ggr= -cp12gg/pfpb*ztcfr cp1ggi= -cp12gg/pfpb*ztcfi cp2ggr= cp12gg/pfp*ztcfr cp2ggi= cp12gg/pfp*ztcfi * p1ggr(ip,j1)= cp1ggr*p1rc(ip,l1) p1ggre(ip,j1)= -cp1ggi*p1ic(ip,l1) p1ggie(ip,j1)= cp1ggr*p1ic(ip,l1) p1ggi(ip,j1)= cp1ggi*p1rc(ip,l1) * p1ggr(ip,j2)= -p1ggr(ip,j1) p1ggre(ip,j2)= p1ggre(ip,j1) p1ggie(ip,j2)= p1ggie(ip,j1) p1ggi(ip,j2)= -p1ggi(ip,j1) * p1ggr(ip,j3)= cp1ggr*p1rc(ip,l2) p1ggre(ip,j3)= -cp1ggi*p1ic(ip,l2) p1ggie(ip,j3)= cp1ggr*p1ic(ip,l2) p1ggi(ip,j3)= cp1ggi*p1rc(ip,l2) * p1ggr(ip,j4)= -p1ggr(ip,j3) p1ggre(ip,j4)= p1ggre(ip,j3) p1ggie(ip,j4)= p1ggie(ip,j3) p1ggi(ip,j4)= -p1ggi(ip,j3) * p1ggr(ip,j5)= cp1ggr*p1rc(ip,l3) p1ggre(ip,j5)= -cp1ggi*p1ic(ip,l3) p1ggie(ip,j5)= cp1ggr*p1ic(ip,l3) p1ggi(ip,j5)= cp1ggi*p1rc(ip,l3) * p1ggr(ip,j6)= -p1ggr(ip,j5) p1ggre(ip,j6)= p1ggre(ip,j5) p1ggie(ip,j6)= p1ggie(ip,j5) p1ggi(ip,j6)= -p1ggi(ip,j5) * p1ggr(ip,j7)= cp1ggr*p1rc(ip,l4) p1ggre(ip,j7)= -cp1ggi*p1ic(ip,l4) p1ggie(ip,j7)= cp1ggr*p1ic(ip,l4) p1ggi(ip,j7)= cp1ggi*p1rc(ip,l4) * p1ggr(ip,j8)= -p1ggr(ip,j7) p1ggre(ip,j8)= p1ggre(ip,j7) p1ggie(ip,j8)= p1ggie(ip,j7) p1ggi(ip,j8)= -p1ggi(ip,j7) * p2ggr(ip,j1)= cp2ggr*p2rc(ip,l1) p2ggre(ip,j1)= -cp2ggi*p2ic(ip,l1) p2ggie(ip,j1)= cp2ggr*p2ic(ip,l1) p2ggi(ip,j1)= -cp2ggi*p2rc(ip,l1) * p2ggr(ip,j2)= -p2ggr(ip,j1) p2ggre(ip,j2)= p2ggre(ip,j1) p2ggie(ip,j2)= p2ggie(ip,j1) p2ggi(ip,j2)= -p2ggi(ip,j1) * p2ggr(ip,j3)= cp2ggr*p2rc(ip,l2) p2ggre(ip,j3)= -cp2ggi*p2ic(ip,l2) p2ggie(ip,j3)= cp2ggr*p2ic(ip,l2) p2ggi(ip,j3)= cp2ggi*p2rc(ip,l2) * p2ggr(ip,j4)= -p2ggr(ip,j3) p2ggre(ip,j4)= p2ggre(ip,j3) p2ggie(ip,j4)= p2ggie(ip,j3) p2ggi(ip,j4)= -p2ggi(ip,j3) * p2ggr(ip,j5)= cp2ggr*p2rc(ip,l3) p2ggre(ip,j5)= -cp2ggi*p2ic(ip,l3) p2ggie(ip,j5)= cp2ggr*p2ic(ip,l3) p2ggi(ip,j5)= cp2ggi*p2rc(ip,l3) * p2ggr(ip,j6)= -p2ggr(ip,j5) p2ggre(ip,j6)= p2ggre(ip,j5) p2ggie(ip,j6)= p2ggie(ip,j5) p2ggi(ip,j6)= -p2ggi(ip,j5) * p2ggr(ip,j7)= cp2ggr*p2rc(ip,l4) p2ggre(ip,j7)= -cp2ggi*p2ic(ip,l4) p2ggie(ip,j7)= cp2ggr*p2ic(ip,l4) p2ggi(ip,j7)= cp2ggi*p2rc(ip,l4) * p2ggr(ip,j8)= -p2ggr(ip,j7) p2ggre(ip,j8)= p2ggre(ip,j7) p2ggie(ip,j8)= p2ggie(ip,j7) p2ggi(ip,j8)= -p2ggi(ip,j7) * *-----All PP1 gamma-Z * cp1gz= -conc(3)/pfpb * do i=1,4 ip16= i+16 hdr(i)= hch(ip16)*cp1gz*zpcfr hdi(i)= hch(ip16)*cp1gz*zpcfi enddo * p1gzr(ip,j1)= hdr(3)*p1rc(ip,l1) p1gzre(ip,j1)= -hdi(3)*p1ic(ip,l1) p1gzie(ip,j1)= hdr(3)*p1ic(ip,l1) p1gzi(ip,j1)= hdi(3)*p1rc(ip,l1) * p1gzr(ip,j2)= -hdr(4)*p1rc(ip,l1) p1gzre(ip,j2)= -hdi(4)*p1ic(ip,l1) p1gzie(ip,j2)= hdr(4)*p1ic(ip,l1) p1gzi(ip,j2)= -hdi(4)*p1rc(ip,l1) * p1gzr(ip,j3)= hdr(4)*p1rc(ip,l2) p1gzre(ip,j3)= -hdi(4)*p1ic(ip,l2) p1gzie(ip,j3)= hdr(4)*p1ic(ip,l2) p1gzi(ip,j3)= hdi(4)*p1rc(ip,l2) * p1gzr(ip,j4)= -hdr(3)*p1rc(ip,l2) p1gzre(ip,j4)= -hdi(3)*p1ic(ip,l2) p1gzie(ip,j4)= hdr(3)*p1ic(ip,l2) p1gzi(ip,j4)= -hdi(3)*p1rc(ip,l2) * p1gzr(ip,j5)= hdr(2)*p1rc(ip,l3) p1gzre(ip,j5)= -hdi(2)*p1ic(ip,l3) p1gzie(ip,j5)= hdr(2)*p1ic(ip,l3) p1gzi(ip,j5)= hdi(2)*p1rc(ip,l3) * p1gzr(ip,j6)= -hdr(1)*p1rc(ip,l3) p1gzre(ip,j6)= -hdi(1)*p1ic(ip,l3) p1gzie(ip,j6)= hdr(1)*p1ic(ip,l3) p1gzi(ip,j6)= -hdi(1)*p1rc(ip,l3) * p1gzr(ip,j7)= hdr(1)*p1rc(ip,l4) p1gzre(ip,j7)= -hdi(1)*p1ic(ip,l4) p1gzie(ip,j7)= hdr(1)*p1ic(ip,l4) p1gzi(ip,j7)= hdi(1)*p1rc(ip,l4) * p1gzr(ip,j8)= -hdr(2)*p1rc(ip,l4) p1gzre(ip,j8)= -hdi(2)*p1ic(ip,l4) p1gzie(ip,j8)= hdr(2)*p1ic(ip,l4) p1gzi(ip,j8)= -hdi(2)*p1rc(ip,l4) * *-----All PP2 gamma-Z * cp2gz= conc(3)/pfp * do i=1,4 ip16= i+16 her(i)= hch(ip16)*cp2gz*zpcfr hei(i)= hch(ip16)*cp2gz*zpcfi enddo * p2gzr(ip,j1)= her(3)*p2rc(ip,l1) p2gzre(ip,j1)= -hei(3)*p2ic(ip,l1) p2gzie(ip,j1)= her(3)*p2ic(ip,l1) p2gzi(ip,j1)= hei(3)*p2rc(ip,l1) * p2gzr(ip,j2)= -her(4)*p2rc(ip,l1) p2gzre(ip,j2)= -hei(4)*p2ic(ip,l1) p2gzie(ip,j2)= her(4)*p2ic(ip,l1) p2gzi(ip,j2)= -hei(4)*p2rc(ip,l1) * p2gzr(ip,j3)= her(4)*p2rc(ip,l2) p2gzre(ip,j3)= -hei(4)*p2ic(ip,l2) p2gzie(ip,j3)= her(4)*p2ic(ip,l2) p2gzi(ip,j3)= hei(4)*p2rc(ip,l2) * p2gzr(ip,j4)= -her(3)*p2rc(ip,l2) p2gzre(ip,j4)= -hei(3)*p2ic(ip,l2) p2gzie(ip,j4)= her(3)*p2ic(ip,l2) p2gzi(ip,j4)= -hei(3)*p2rc(ip,l2) * p2gzr(ip,j5)= her(2)*p2rc(ip,l3) p2gzre(ip,j5)= -hei(2)*p2ic(ip,l3) p2gzie(ip,j5)= her(2)*p2ic(ip,l3) p2gzi(ip,j5)= hei(2)*p2rc(ip,l3) * p2gzr(ip,j6)= -her(1)*p2rc(ip,l3) p2gzre(ip,j6)= -hei(1)*p2ic(ip,l3) p2gzie(ip,j6)= her(1)*p2ic(ip,l3) p2gzi(ip,j6)= -hei(1)*p2rc(ip,l3) * p2gzr(ip,j7)= her(1)*p2rc(ip,l4) p2gzre(ip,j7)= -hei(1)*p2ic(ip,l4) p2gzie(ip,j7)= her(1)*p2ic(ip,l4) p2gzi(ip,j7)= hei(1)*p2rc(ip,l4) * p2gzr(ip,j8)= -her(2)*p2rc(ip,l4) p2gzre(ip,j8)= -hei(2)*p2ic(ip,l4) p2gzie(ip,j8)= her(2)*p2ic(ip,l4) p2gzi(ip,j8)= -hei(2)*p2rc(ip,l4) * *-----All PP1 Z-gamma(gluon) * cp1zg= conc(4)/ysm/pfpb * do i=1,4 ip4= i+4 hfr(i)= hch(ip4)*cp1zg*ztcfr hfi(i)= hch(ip4)*cp1zg*ztcfi enddo * ap1azgr(ip,l1)= hfr(1)*p1rc(ip,l1) ap1azgre(ip,l1)= -hfi(1)*p1ic(ip,l1) ap1azgie(ip,l1)= hfr(1)*p1ic(ip,l1) ap1azgi(ip,l1)= hfi(1)*p1rc(ip,l1) p1zgr(ip,j1)= ap1azgr(ip,l1)*rsz- # ap1azgi(ip,l1)*aisz p1zgre(ip,j1)= ap1azgre(ip,l1)*rsz- # ap1azgie(ip,l1)*aisz p1zgie(ip,j1)= ap1azgie(ip,l1)*rsz+ # ap1azgre(ip,l1)*aisz p1zgi(ip,j1)= ap1azgi(ip,l1)*rsz+ # ap1azgr(ip,l1)*aisz * ap1bzgr(ip,l1)= -hfr(2)*p1rc(ip,l1) ap1bzgre(ip,l1)= -hfi(2)*p1ic(ip,l1) ap1bzgie(ip,l1)= hfr(2)*p1ic(ip,l1) ap1bzgi(ip,l1)= -hfi(2)*p1rc(ip,l1) p1zgr(ip,j2)= ap1bzgr(ip,l1)*rsz- # ap1bzgi(ip,l1)*aisz p1zgre(ip,j2)= ap1bzgre(ip,l1)*rsz- # ap1bzgie(ip,l1)*aisz p1zgie(ip,j2)= ap1bzgie(ip,l1)*rsz+ # ap1bzgre(ip,l1)*aisz p1zgi(ip,j2)= ap1bzgi(ip,l1)*rsz+ # ap1bzgr(ip,l1)*aisz * ap1czgr(ip,l2)= hfr(3)*p1rc(ip,l2) ap1czgre(ip,l2)= -hfi(3)*p1ic(ip,l2) ap1czgie(ip,l2)= hfr(3)*p1ic(ip,l2) ap1czgi(ip,l2)= hfi(3)*p1rc(ip,l2) p1zgr(ip,j3)= ap1czgr(ip,l2)*rsz- # ap1czgi(ip,l2)*aisz p1zgre(ip,j3)= ap1czgre(ip,l2)*rsz- # ap1czgie(ip,l2)*aisz p1zgie(ip,j3)= ap1czgie(ip,l2)*rsz+ # ap1czgre(ip,l2)*aisz p1zgi(ip,j3)= ap1czgi(ip,l2)*rsz+ # ap1czgr(ip,l2)*aisz * ap1dzgr(ip,l2)= -hfr(4)*p1rc(ip,l2) ap1dzgre(ip,l2)= -hfi(4)*p1ic(ip,l2) ap1dzgie(ip,l2)= hfr(4)*p1ic(ip,l2) ap1dzgi(ip,l2)= -hfi(4)*p1rc(ip,l2) p1zgr(ip,j4)= ap1dzgr(ip,l2)*rsz- # ap1dzgi(ip,l2)*aisz p1zgre(ip,j4)= ap1dzgre(ip,l2)*rsz- # ap1dzgie(ip,l2)*aisz p1zgie(ip,j4)= ap1dzgie(ip,l2)*rsz+ # ap1dzgre(ip,l2)*aisz p1zgi(ip,j4)= ap1dzgi(ip,l2)*rsz+ # ap1dzgr(ip,l2)*aisz * ap1ezgr(ip,l3)= hfr(3)*p1rc(ip,l3) ap1ezgre(ip,l3)= -hfi(3)*p1ic(ip,l3) ap1ezgie(ip,l3)= hfr(3)*p1ic(ip,l3) ap1ezgi(ip,l3)= hfi(3)*p1rc(ip,l3) p1zgr(ip,j5)= ap1ezgr(ip,l3)*rsz- # ap1ezgi(ip,l3)*aisz p1zgre(ip,j5)= ap1ezgre(ip,l3)*rsz- # ap1ezgie(ip,l3)*aisz p1zgie(ip,j5)= ap1ezgie(ip,l3)*rsz+ # ap1ezgre(ip,l3)*aisz p1zgi(ip,j5)= ap1ezgi(ip,l3)*rsz+ # ap1ezgr(ip,l3)*aisz * ap1fzgr(ip,l3)= -hfr(4)*p1rc(ip,l3) ap1fzgre(ip,l3)= -hfi(4)*p1ic(ip,l3) ap1fzgie(ip,l3)= hfr(4)*p1ic(ip,l3) ap1fzgi(ip,l3)= -hfi(4)*p1rc(ip,l3) p1zgr(ip,j6)= ap1fzgr(ip,l3)*rsz- # ap1fzgi(ip,l3)*aisz p1zgre(ip,j6)= ap1fzgre(ip,l3)*rsz- # ap1fzgie(ip,l3)*aisz p1zgie(ip,j6)= ap1fzgie(ip,l3)*rsz+ # ap1fzgre(ip,l3)*aisz p1zgi(ip,j6)= ap1fzgi(ip,l3)*rsz+ # ap1fzgr(ip,l3)*aisz * ap1gzgr(ip,l4)= hfr(1)*p1rc(ip,l4) ap1gzgre(ip,l4)= -hfi(1)*p1ic(ip,l4) ap1gzgie(ip,l4)= hfr(1)*p1ic(ip,l4) ap1gzgi(ip,l4)= hfi(1)*p1rc(ip,l4) p1zgr(ip,j7)= ap1gzgr(ip,l4)*rsz- # ap1gzgi(ip,l4)*aisz p1zgre(ip,j7)= ap1gzgre(ip,l4)*rsz- # ap1gzgie(ip,l4)*aisz p1zgie(ip,j7)= ap1gzgie(ip,l4)*rsz+ # ap1gzgre(ip,l4)*aisz p1zgi(ip,j7)= ap1gzgi(ip,l4)*rsz+ # ap1gzgr(ip,l4)*aisz * ap1hzgr(ip,l4)= -hfr(2)*p1rc(ip,l4) ap1hzgre(ip,l4)= -hfi(2)*p1ic(ip,l4) ap1hzgie(ip,l4)= hfr(2)*p1ic(ip,l4) ap1hzgi(ip,l4)= -hfi(2)*p1rc(ip,l4) p1zgr(ip,j8)= ap1hzgr(ip,l4)*rsz- # ap1hzgi(ip,l4)*aisz p1zgre(ip,j8)= ap1hzgre(ip,l4)*rsz- # ap1hzgie(ip,l4)*aisz p1zgie(ip,j8)= ap1hzgie(ip,l4)*rsz+ # ap1hzgre(ip,l4)*aisz p1zgi(ip,j8)= ap1hzgi(ip,l4)*rsz+ # ap1hzgr(ip,l4)*aisz * *-----All PP2 Z-gamma(gluon) * cp2zg= -conc(4)/ysm/pfp * do i=1,4 ip4= i+4 hgr(i)= hch(ip4)*cp2zg*ztcfr hgi(i)= hch(ip4)*cp2zg*ztcfi enddo * ap2azgr(ip,l1)= hgr(1)*p2rc(ip,l1) ap2azgre(ip,l1)= -hgi(1)*p2ic(ip,l1) ap2azgie(ip,l1)= hgr(1)*p2ic(ip,l1) ap2azgi(ip,l1)= hgi(1)*p2rc(ip,l1) p2zgr(ip,j1)= ap2azgr(ip,l1)*rsz- # ap2azgi(ip,l1)*aisz p2zgre(ip,j1)= ap2azgre(ip,l1)*rsz- # ap2azgie(ip,l1)*aisz p2zgie(ip,j1)= ap2azgie(ip,l1)*rsz+ # ap2azgre(ip,l1)*aisz p2zgi(ip,j1)= ap2azgi(ip,l1)*rsz+ # ap2azgr(ip,l1)*aisz * ap2bzgr(ip,l1)= -hgr(2)*p2rc(ip,l1) ap2bzgre(ip,l1)= -hgi(2)*p2ic(ip,l1) ap2bzgie(ip,l1)= hgr(2)*p2ic(ip,l1) ap2bzgi(ip,l1)= -hgi(2)*p2rc(ip,l1) p2zgr(ip,j2)= ap2bzgr(ip,l1)*rsz- # ap2bzgi(ip,l1)*aisz p2zgre(ip,j2)= ap2bzgre(ip,l1)*rsz- # ap2bzgie(ip,l1)*aisz p2zgie(ip,j2)= ap2bzgie(ip,l1)*rsz+ # ap2bzgre(ip,l1)*aisz p2zgi(ip,j2)= ap2bzgi(ip,l1)*rsz+ # ap2bzgr(ip,l1)*aisz * ap2czgr(ip,l2)= hgr(3)*p2rc(ip,l2) ap2czgre(ip,l2)= -hgi(3)*p2ic(ip,l2) ap2czgie(ip,l2)= hgr(3)*p2ic(ip,l2) ap2czgi(ip,l2)= hgi(3)*p2rc(ip,l2) p2zgr(ip,j3)= ap2czgr(ip,l2)*rsz- # ap2czgi(ip,l2)*aisz p2zgre(ip,j3)= ap2czgre(ip,l2)*rsz- # ap2czgie(ip,l2)*aisz p2zgie(ip,j3)= ap2czgie(ip,l2)*rsz+ # ap2czgre(ip,l2)*aisz p2zgi(ip,j3)= ap2czgi(ip,l2)*rsz+ # ap2czgr(ip,l2)*aisz * ap2dzgr(ip,l2)= -hgr(4)*p2rc(ip,l2) ap2dzgre(ip,l2)= -hgi(4)*p2ic(ip,l2) ap2dzgie(ip,l2)= hgr(4)*p2ic(ip,l2) ap2dzgi(ip,l2)= -hgi(4)*p2rc(ip,l2) p2zgr(ip,j4)= ap2dzgr(ip,l2)*rsz- # ap2dzgi(ip,l2)*aisz p2zgre(ip,j4)= ap2dzgre(ip,l2)*rsz- # ap2dzgie(ip,l2)*aisz p2zgie(ip,j4)= ap2dzgie(ip,l2)*rsz+ # ap2dzgre(ip,l2)*aisz p2zgi(ip,j4)= ap2dzgi(ip,l2)*rsz+ # ap2dzgr(ip,l2)*aisz * ap2ezgr(ip,l3)= hgr(3)*p2rc(ip,l3) ap2ezgre(ip,l3)= -hgi(3)*p2ic(ip,l3) ap2ezgie(ip,l3)= hgr(3)*p2ic(ip,l3) ap2ezgi(ip,l3)= hgi(3)*p2rc(ip,l3) p2zgr(ip,j5)= ap2ezgr(ip,l3)*rsz- # ap2ezgi(ip,l3)*aisz p2zgre(ip,j5)= ap2ezgre(ip,l3)*rsz- # ap2ezgie(ip,l3)*aisz p2zgie(ip,j5)= ap2ezgie(ip,l3)*rsz+ # ap2ezgre(ip,l3)*aisz p2zgi(ip,j5)= ap2ezgi(ip,l3)*rsz+ # ap2ezgr(ip,l3)*aisz * ap2fzgr(ip,l3)= -hgr(4)*p2rc(ip,l3) ap2fzgre(ip,l3)= -hgi(4)*p2ic(ip,l3) ap2fzgie(ip,l3)= hgr(4)*p2ic(ip,l3) ap2fzgi(ip,l3)= -hgi(4)*p2rc(ip,l3) p2zgr(ip,j6)= ap2fzgr(ip,l3)*rsz- # ap2fzgi(ip,l3)*aisz p2zgre(ip,j6)= ap2fzgre(ip,l3)*rsz- # ap2fzgie(ip,l3)*aisz p2zgie(ip,j6)= ap2fzgie(ip,l3)*rsz+ # ap2fzgre(ip,l3)*aisz p2zgi(ip,j6)= ap2fzgi(ip,l3)*rsz+ # ap2fzgr(ip,l3)*aisz * ap2gzgr(ip,l4)= hgr(1)*p2rc(ip,l4) ap2gzgre(ip,l4)= -hgi(1)*p2ic(ip,l4) ap2gzgie(ip,l4)= hgr(1)*p2ic(ip,l4) ap2gzgi(ip,l4)= hgi(1)*p2rc(ip,l4) p2zgr(ip,j7)= ap2gzgr(ip,l4)*rsz- # ap2gzgi(ip,l4)*aisz p2zgre(ip,j7)= ap2gzgre(ip,l4)*rsz- # ap2gzgie(ip,l4)*aisz p2zgie(ip,j7)= ap2gzgie(ip,l4)*rsz+ # ap2gzgre(ip,l4)*aisz p2zgi(ip,j7)= ap2gzgi(ip,l4)*rsz+ # ap2gzgr(ip,l4)*aisz * ap2hzgr(ip,l4)= -hgr(2)*p2rc(ip,l4) ap2hzgre(ip,l4)= -hgi(2)*p2ic(ip,l4) ap2hzgie(ip,l4)= hgr(2)*p2ic(ip,l4) ap2hzgi(ip,l4)= -hgi(2)*p2rc(ip,l4) p2zgr(ip,j8)= ap2hzgr(ip,l4)*rsz- # ap2hzgi(ip,l4)*aisz p2zgre(ip,j8)= ap2hzgre(ip,l4)*rsz- # ap2hzgie(ip,l4)*aisz p2zgie(ip,j8)= ap2hzgie(ip,l4)*rsz+ # ap2hzgre(ip,l4)*aisz p2zgi(ip,j8)= ap2hzgi(ip,l4)*rsz+ # ap2hzgr(ip,l4)*aisz * *-----All PP1 Z-Z * cp1zz= conc(5)/pfpb * do i=1,8 ip20= i+20 hhr(i)= hch(ip20)*cp1zz*zpcfr hhi(i)= hch(ip20)*cp1zz*zpcfi enddo * ap1azzr(ip,l1)= hhr(3)*p1rc(ip,l1) ap1azzre(ip,l1)= -hhi(3)*p1ic(ip,l1) ap1azzie(ip,l1)= hhr(3)*p1ic(ip,l1) ap1azzi(ip,l1)= hhi(3)*p1rc(ip,l1) p1zzr(ip,j1)= ap1azzr(ip,l1)*rsz- # ap1azzi(ip,l1)*aisz p1zzre(ip,j1)= ap1azzre(ip,l1)*rsz- # ap1azzie(ip,l1)*aisz p1zzie(ip,j1)= ap1azzie(ip,l1)*rsz+ # ap1azzre(ip,l1)*aisz p1zzi(ip,j1)= ap1azzi(ip,l1)*rsz+ # ap1azzr(ip,l1)*aisz * ap1bzzr(ip,l1)= -hhr(4)*p1rc(ip,l1) ap1bzzre(ip,l1)= -hhi(4)*p1ic(ip,l1) ap1bzzie(ip,l1)= hhr(4)*p1ic(ip,l1) ap1bzzi(ip,l1)= -hhi(4)*p1rc(ip,l1) p1zzr(ip,j2)= ap1bzzr(ip,l1)*rsz- # ap1bzzi(ip,l1)*aisz p1zzre(ip,j2)= ap1bzzre(ip,l1)*rsz- # ap1bzzie(ip,l1)*aisz p1zzie(ip,j2)= ap1bzzie(ip,l1)*rsz+ # ap1bzzre(ip,l1)*aisz p1zzi(ip,j2)= ap1bzzi(ip,l1)*rsz+ # ap1bzzr(ip,l1)*aisz * ap1czzr(ip,l2)= hhr(5)*p1rc(ip,l2) ap1czzre(ip,l2)= -hhi(5)*p1ic(ip,l2) ap1czzie(ip,l2)= hhr(5)*p1ic(ip,l2) ap1czzi(ip,l2)= hhi(5)*p1rc(ip,l2) p1zzr(ip,j3)= ap1czzr(ip,l2)*rsz- # ap1czzi(ip,l2)*aisz p1zzre(ip,j3)= ap1czzre(ip,l2)*rsz- # ap1czzie(ip,l2)*aisz p1zzie(ip,j3)= ap1czzie(ip,l2)*rsz+ # ap1czzre(ip,l2)*aisz p1zzi(ip,j3)= ap1czzi(ip,l2)*rsz+ # ap1czzr(ip,l2)*aisz * ap1dzzr(ip,l2)= -hhr(6)*p1rc(ip,l2) ap1dzzre(ip,l2)= -hhi(6)*p1ic(ip,l2) ap1dzzie(ip,l2)= hhr(6)*p1ic(ip,l2) ap1dzzi(ip,l2)= -hhi(6)*p1rc(ip,l2) p1zzr(ip,j4)= ap1dzzr(ip,l2)*rsz- # ap1dzzi(ip,l2)*aisz p1zzre(ip,j4)= ap1dzzre(ip,l2)*rsz- # ap1dzzie(ip,l2)*aisz p1zzie(ip,j4)= ap1dzzie(ip,l2)*rsz+ # ap1dzzre(ip,l2)*aisz p1zzi(ip,j4)= ap1dzzi(ip,l2)*rsz+ # ap1dzzr(ip,l2)*aisz * ap1ezzr(ip,l3)= hhr(8)*p1rc(ip,l3) ap1ezzre(ip,l3)= -hhi(8)*p1ic(ip,l3) ap1ezzie(ip,l3)= hhr(8)*p1ic(ip,l3) ap1ezzi(ip,l3)= hhi(8)*p1rc(ip,l3) p1zzr(ip,j5)= ap1ezzr(ip,l3)*rsz- # ap1ezzi(ip,l3)*aisz p1zzre(ip,j5)= ap1ezzre(ip,l3)*rsz- # ap1ezzie(ip,l3)*aisz p1zzie(ip,j5)= ap1ezzie(ip,l3)*rsz+ # ap1ezzre(ip,l3)*aisz p1zzi(ip,j5)= ap1ezzi(ip,l3)*rsz+ # ap1ezzr(ip,l3)*aisz * ap1fzzr(ip,l3)= -hhr(7)*p1rc(ip,l3) ap1fzzre(ip,l3)= -hhi(7)*p1ic(ip,l3) ap1fzzie(ip,l3)= hhr(7)*p1ic(ip,l3) ap1fzzi(ip,l3)= -hhi(7)*p1rc(ip,l3) p1zzr(ip,j6)= ap1fzzr(ip,l3)*rsz- # ap1fzzi(ip,l3)*aisz p1zzre(ip,j6)= ap1fzzre(ip,l3)*rsz- # ap1fzzie(ip,l3)*aisz p1zzie(ip,j6)= ap1fzzie(ip,l3)*rsz+ # ap1fzzre(ip,l3)*aisz p1zzi(ip,j6)= ap1fzzi(ip,l3)*rsz+ # ap1fzzr(ip,l3)*aisz * ap1gzzr(ip,l4)= hhr(1)*p1rc(ip,l4) ap1gzzre(ip,l4)= -hhi(1)*p1ic(ip,l4) ap1gzzie(ip,l4)= hhr(1)*p1ic(ip,l4) ap1gzzi(ip,l4)= hhi(1)*p1rc(ip,l4) p1zzr(ip,j7)= ap1gzzr(ip,l4)*rsz- # ap1gzzi(ip,l4)*aisz p1zzre(ip,j7)= ap1gzzre(ip,l4)*rsz- # ap1gzzie(ip,l4)*aisz p1zzie(ip,j7)= ap1gzzie(ip,l4)*rsz+ # ap1gzzre(ip,l4)*aisz p1zzi(ip,j7)= ap1gzzi(ip,l4)*rsz+ # ap1gzzr(ip,l4)*aisz * ap1hzzr(ip,l4)= -hhr(2)*p1rc(ip,l4) ap1hzzre(ip,l4)= -hhi(2)*p1ic(ip,l4) ap1hzzie(ip,l4)= hhr(2)*p1ic(ip,l4) ap1hzzi(ip,l4)= -hhi(2)*p1rc(ip,l4) p1zzr(ip,j8)= ap1hzzr(ip,l4)*rsz- # ap1hzzi(ip,l4)*aisz p1zzre(ip,j8)= ap1hzzre(ip,l4)*rsz- # ap1hzzie(ip,l4)*aisz p1zzie(ip,j8)= ap1hzzie(ip,l4)*rsz+ # ap1hzzre(ip,l4)*aisz p1zzi(ip,j8)= ap1hzzi(ip,l4)*rsz+ # ap1hzzr(ip,l4)*aisz * *-----All PP2 Z-Z * cp2zz= -conc(5)/pfp * do i=1,8 ip20= i+20 hir(i)= hch(ip20)*cp2zz*zpcfr hii(i)= hch(ip20)*cp2zz*zpcfi enddo * ap2azzr(ip,l1)= hir(3)*p2rc(ip,l1) ap2azzre(ip,l1)= -hii(3)*p2ic(ip,l1) ap2azzie(ip,l1)= hir(3)*p2ic(ip,l1) ap2azzi(ip,l1)= hii(3)*p2rc(ip,l1) p2zzr(ip,j1)= ap2azzr(ip,l1)*rsz- # ap2azzi(ip,l1)*aisz p2zzre(ip,j1)= ap2azzre(ip,l1)*rsz- # ap2azzie(ip,l1)*aisz p2zzie(ip,j1)= ap2azzie(ip,l1)*rsz+ # ap2azzre(ip,l1)*aisz p2zzi(ip,j1)= ap2azzi(ip,l1)*rsz+ # ap2azzr(ip,l1)*aisz * ap2bzzr(ip,l1)= -hir(4)*p2rc(ip,l1) ap2bzzre(ip,l1)= -hii(4)*p2ic(ip,l1) ap2bzzie(ip,l1)= hir(4)*p2ic(ip,l1) ap2bzzi(ip,l1)= -hii(4)*p2rc(ip,l1) p2zzr(ip,j2)= ap2bzzr(ip,l1)*rsz- # ap2bzzi(ip,l1)*aisz p2zzre(ip,j2)= ap2bzzre(ip,l1)*rsz- # ap2bzzie(ip,l1)*aisz p2zzie(ip,j2)= ap2bzzie(ip,l1)*rsz+ # ap2bzzre(ip,l1)*aisz p2zzi(ip,j2)= ap2bzzi(ip,l1)*rsz+ # ap2bzzr(ip,l1)*aisz * ap2czzr(ip,l2)= hir(5)*p2rc(ip,l2) ap2czzre(ip,l2)= -hii(5)*p2ic(ip,l2) ap2czzie(ip,l2)= hir(5)*p2ic(ip,l2) ap2czzi(ip,l2)= hii(5)*p2rc(ip,l2) p2zzr(ip,j3)= ap2czzr(ip,l2)*rsz- # ap2czzi(ip,l2)*aisz p2zzre(ip,j3)= ap2czzre(ip,l2)*rsz- # ap2czzie(ip,l2)*aisz p2zzie(ip,j3)= ap2czzie(ip,l2)*rsz+ # ap2czzre(ip,l2)*aisz p2zzi(ip,j3)= ap2czzi(ip,l2)*rsz+ # ap2czzr(ip,l2)*aisz * ap2dzzr(ip,l2)= -hir(6)*p2rc(ip,l2) ap2dzzre(ip,l2)= -hii(6)*p2ic(ip,l2) ap2dzzie(ip,l2)= hir(6)*p2ic(ip,l2) ap2dzzi(ip,l2)= -hii(6)*p2rc(ip,l2) p2zzr(ip,j4)= ap2dzzr(ip,l2)*rsz- # ap2dzzi(ip,l2)*aisz p2zzre(ip,j4)= ap2dzzre(ip,l2)*rsz- # ap2dzzie(ip,l2)*aisz p2zzie(ip,j4)= ap2dzzie(ip,l2)*rsz+ # ap2dzzre(ip,l2)*aisz p2zzi(ip,j4)= ap2dzzi(ip,l2)*rsz+ # ap2dzzr(ip,l2)*aisz * ap2ezzr(ip,l3)= hir(8)*p2rc(ip,l3) ap2ezzre(ip,l3)= -hii(8)*p2ic(ip,l3) ap2ezzie(ip,l3)= hir(8)*p2ic(ip,l3) ap2ezzi(ip,l3)= hii(8)*p2rc(ip,l3) p2zzr(ip,j5)= ap2ezzr(ip,l3)*rsz- # ap2ezzi(ip,l3)*aisz p2zzre(ip,j5)= ap2ezzre(ip,l3)*rsz- # ap2ezzie(ip,l3)*aisz p2zzie(ip,j5)= ap2ezzie(ip,l3)*rsz+ # ap2ezzre(ip,l3)*aisz p2zzi(ip,j5)= ap2ezzi(ip,l3)*rsz+ # ap2ezzr(ip,l3)*aisz * ap2fzzr(ip,l3)= -hir(7)*p2rc(ip,l3) ap2fzzre(ip,l3)= -hii(7)*p2ic(ip,l3) ap2fzzie(ip,l3)= hir(7)*p2ic(ip,l3) ap2fzzi(ip,l3)= -hii(7)*p2rc(ip,l3) p2zzr(ip,j6)= ap2fzzr(ip,l3)*rsz- # ap2fzzi(ip,l3)*aisz p2zzre(ip,j6)= ap2fzzre(ip,l3)*rsz- # ap2fzzie(ip,l3)*aisz p2zzie(ip,j6)= ap2fzzie(ip,l3)*rsz+ # ap2fzzre(ip,l3)*aisz p2zzi(ip,j6)= ap2fzzi(ip,l3)*rsz+ # ap2fzzr(ip,l3)*aisz * ap2gzzr(ip,l4)= hir(1)*p2rc(ip,l4) ap2gzzre(ip,l4)= -hii(1)*p2ic(ip,l4) ap2gzzie(ip,l4)= hir(1)*p2ic(ip,l4) ap2gzzi(ip,l4)= hii(1)*p2rc(ip,l4) p2zzr(ip,j7)= ap2gzzr(ip,l4)*rsz- # ap2gzzi(ip,l4)*aisz p2zzre(ip,j7)= ap2gzzre(ip,l4)*rsz- # ap2gzzie(ip,l4)*aisz p2zzie(ip,j7)= ap2gzzie(ip,l4)*rsz+ # ap2gzzre(ip,l4)*aisz p2zzi(ip,j7)= ap2gzzi(ip,l4)*rsz+ # ap2gzzr(ip,l4)*aisz * ap2hzzr(ip,l4)= -hir(2)*p2rc(ip,l4) ap2hzzre(ip,l4)= -hii(2)*p2ic(ip,l4) ap2hzzie(ip,l4)= hir(2)*p2ic(ip,l4) ap2hzzi(ip,l4)= -hii(2)*p2rc(ip,l4) p2zzr(ip,j8)= ap2hzzr(ip,l4)*rsz- # ap2hzzi(ip,l4)*aisz p2zzre(ip,j8)= ap2hzzre(ip,l4)*rsz- # ap2hzzie(ip,l4)*aisz p2zzie(ip,j8)= ap2hzzie(ip,l4)*rsz+ # ap2hzzre(ip,l4)*aisz p2zzi(ip,j8)= ap2hzzi(ip,l4)*rsz+ # ap2hzzr(ip,l4)*aisz * *-----Loops over permutations ends here * enddo * do ip=1,4 ycrc(ip,1)= xcrc(ip,1) ycic(ip,1)= xcic(ip,1) ycrc(ip,2)= -xcrc(ip,1) ycic(ip,2)= xcic(ip,1) ycrc(ip,3)= xcrc(ip,2) ycic(ip,3)= xcic(ip,2) ycrc(ip,4)= -xcrc(ip,2) ycic(ip,4)= xcic(ip,2) ycrc(ip,5)= xcrc(ip,3) ycic(ip,5)= xcic(ip,3) ycrc(ip,6)= -xcrc(ip,3) ycic(ip,6)= xcic(ip,3) ycrc(ip,7)= xcrc(ip,4) ycic(ip,7)= xcic(ip,4) ycrc(ip,8)= -xcrc(ip,4) ycic(ip,8)= xcic(ip,4) ycrc(ip,9)= xcrc(ip,5) ycic(ip,9)= xcic(ip,5) ycrc(ip,10)= -xcrc(ip,5) ycic(ip,10)= xcic(ip,5) ycrc(ip,11)= xcrc(ip,6) ycic(ip,11)= xcic(ip,6) ycrc(ip,12)= -xcrc(ip,6) ycic(ip,12)= xcic(ip,6) * zcrc(ip,1)= crc(ip,1) zcic(ip,1)= cic(ip,1) zcrc(ip,2)= -crc(ip,1) zcic(ip,2)= cic(ip,1) zcrc(ip,3)= crc(ip,2) zcic(ip,3)= cic(ip,2) zcrc(ip,4)= -crc(ip,2) zcic(ip,4)= cic(ip,2) zcrc(ip,5)= crc(ip,3) zcic(ip,5)= cic(ip,3) zcrc(ip,6)= -crc(ip,3) zcic(ip,6)= cic(ip,3) zcrc(ip,7)= crc(ip,4) zcic(ip,7)= cic(ip,4) zcrc(ip,8)= -crc(ip,4) zcic(ip,8)= cic(ip,4) zcrc(ip,9)= crc(ip,5) zcic(ip,9)= cic(ip,5) zcrc(ip,10)= -crc(ip,5) zcic(ip,10)= cic(ip,5) zcrc(ip,11)= crc(ip,6) zcic(ip,11)= cic(ip,6) zcrc(ip,12)= -crc(ip,6) zcic(ip,12)= cic(ip,6) enddo * do ip=1,4 do ih=1,12 cmod= zcrc(ip,ih)*zcrc(ip,ih)+ # zcic(ip,ih)*zcic(ip,ih) if(cmod.eq.0.d0) then ephr(ip,ih)= 1.d0 ephie(ip,ih)= 0.d0 else aephr(ip,ih)= (ycrc(ip,ih)*zcrc(ip,ih)+ # ycic(ip,ih)*zcic(ip,ih))/ # cmod aephie(ip,ih)= (-ycrc(ip,ih)*zcic(ip,ih)+ # ycic(ip,ih)*zcrc(ip,ih))/ # cmod omephr(ip,ih)= 1.d0-aephr(ip,ih) tephr(ip,ih)= 1.d0-aephr(ip,ih)*aephr(ip,ih) if(aephie(ip,ih).lt.zrm) then sephie(ip,ih)= -1.d0 else if(aephie(ip,ih).gt.zrm) then sephie(ip,ih)= +1.d0 else if(abs(aephie(ip,ih)).lt.zrm) then sephie(ip,ih)= 0.d0 endif if(tephr(ip,ih).gt.0.d0.and. # omephr(ip,ih).gt.1.d-6) then ephie(ip,ih)= sephie(ip,ih)*sqrt(1.d0- # aephr(ip,ih)*aephr(ip,ih)) ephr(ip,ih)= aephr(ip,ih) else if(tephr(ip,ih).gt.0.d0.and. # omephr(ip,ih).lt.1.d-6) then ephie(ip,ih)= sephie(ip,ih)*sqrt(2.d0* # omephr(ip,ih))*(1.d0-0.25d0* # omephr(ip,ih)*(1.d0+ # omephr(ip,ih)/8.d0)) ephr(ip,ih)= aephr(ip,ih) else ephie(ip,ih)= 0.d0 ephr(ip,ih)= 1.d0 endif endif enddo enddo * dpcfr= sp-rzm2/vv dmcfr= sm-rzm2/vv dpcfi= sp*szg dmcfi= sm*szg dmpcfr= dpcfr*dmcfr-dpcfi*dmcfi dmpcfi= dpcfr*dmcfi+dpcfi*dmcfr ducfr= su-rzm2/vv ddcfr= sd-rzm2/vv ducfi= su*szg ddcfi= sd*szg dudcfr= ducfr*ddcfr-ducfi*ddcfi dudcfi= ducfr*ddcfi+ducfi*ddcfr qcfr= dmpcfr*dudcfr-dmpcfi*dudcfi qcfi= dmpcfr*dudcfi+dmpcfi*dudcfr dcfr(1)= dudcfr dcfr(4)= dudcfr dcfi(1)= dudcfi dcfi(4)= dudcfi dcfr(2)= dmpcfr dcfr(3)= dmpcfr dcfi(2)= dmpcfi dcfi(3)= dmpcfi if(ofs.eq.'ll') then do ih=1,12 do ip=1,4 adhelr(ip,ih)= dcfr(ip)*( # cggr(ip,ih)+cgzr(ip,ih)+ # czgr(ip,ih)+czzr(ip,ih)+ # p1ggr(ip,ih)+p2ggr(ip,ih)+ # p1gzr(ip,ih)+p2gzr(ip,ih)+ # p1zgr(ip,ih)+p2zgr(ip,ih)+ # p1zzr(ip,ih)+p2zzr(ip,ih))- # dcfi(ip)*( # cggi(ip,ih)+cgzi(ip,ih)+ # czgi(ip,ih)+ # p1ggi(ip,ih)+p2ggi(ip,ih)+ # p1gzi(ip,ih)+p2gzi(ip,ih)+ # p1zgi(ip,ih)+p2zgi(ip,ih)+ # p1zzi(ip,ih)+p2zzi(ip,ih)) adhelre(ip,ih)= dcfr(ip)*( # cggre(ip,ih)+cgzre(ip,ih)+ # czgre(ip,ih)+ # p1ggre(ip,ih)+p2ggre(ip,ih)+ # p1gzre(ip,ih)+p2gzre(ip,ih)+ # p1zgre(ip,ih)+p2zgre(ip,ih)+ # p1zzre(ip,ih)+p2zzre(ip,ih))- # dcfi(ip)*( # cggie(ip,ih)+cgzie(ip,ih)+ # czgie(ip,ih)+czzie(ip,ih)+ # p1ggie(ip,ih)+p2ggie(ip,ih)+ # p1gzie(ip,ih)+p2gzie(ip,ih)+ # p1zgie(ip,ih)+p2zgie(ip,ih)+ # p1zzie(ip,ih)+p2zzie(ip,ih)) adhelie(ip,ih)= dcfr(ip)*( # cggie(ip,ih)+cgzie(ip,ih)+ # czgie(ip,ih)+czzie(ip,ih)+ # p1ggie(ip,ih)+p2ggie(ip,ih)+ # p1gzie(ip,ih)+p2gzie(ip,ih)+ # p1zgie(ip,ih)+p2zgie(ip,ih)+ # p1zzie(ip,ih)+p2zzie(ip,ih))+ # dcfi(ip)*( # cggre(ip,ih)+cgzre(ip,ih)+ # czgre(ip,ih)+ # p1ggre(ip,ih)+p2ggre(ip,ih)+ # p1gzre(ip,ih)+p2gzre(ip,ih)+ # p1zgre(ip,ih)+p2zgre(ip,ih)+ # p1zzre(ip,ih)+p2zzre(ip,ih)) adheli(ip,ih)= dcfr(ip)*( # cggi(ip,ih)+cgzi(ip,ih)+ # czgi(ip,ih)+ # p1ggi(ip,ih)+p2ggi(ip,ih)+ # p1gzi(ip,ih)+p2gzi(ip,ih)+ # p1zgi(ip,ih)+p2zgi(ip,ih)+ # p1zzi(ip,ih)+p2zzi(ip,ih))+ # dcfi(ip)*( # cggr(ip,ih)+cgzr(ip,ih)+ # czgr(ip,ih)+czzr(ip,ih)+ # p1ggr(ip,ih)+p2ggr(ip,ih)+ # p1gzr(ip,ih)+p2gzr(ip,ih)+ # p1zgr(ip,ih)+p2zgr(ip,ih)+ # p1zzr(ip,ih)+p2zzr(ip,ih)) enddo enddo * do ih=1,12 dhelr(ih)= 0.d0 dhelre(ih)= 0.d0 dhelie(ih)= 0.d0 dheli(ih)= 0.d0 do ip=1,4 dhelr(ih)= dhelr(ih)+vj*psg(ip)*( # ephr(ip,ih)*adhelr(ip,ih)- # ephie(ip,ih)*adhelie(ip,ih)) dhelre(ih)= dhelre(ih)+vj*psg(ip)*( # ephr(ip,ih)*adhelre(ip,ih)- # ephie(ip,ih)*adheli(ip,ih)) dhelie(ih)= dhelie(ih)+vj*psg(ip)*( # ephr(ip,ih)*adhelie(ip,ih)+ # ephie(ip,ih)*adhelr(ip,ih)) dheli(ih)= dheli(ih)+vj*psg(ip)*( # ephr(ip,ih)*adheli(ip,ih)+ # ephie(ip,ih)*adhelre(ip,ih)) enddo enddo * ds= 0.d0 do ih=1,12 ds= ds+dhelr(ih)*dhelr(ih)+ # dhelre(ih)*dhelre(ih)+ # dhelie(ih)*dhelie(ih)+ # dheli(ih)*dheli(ih) enddo endif * if(ofs.eq.'qq') then if(oint.eq.'y') then if(iint.eq.0) then do i=1,4 flow(i)= 1.d0 enddo else if(iint.eq.1) then flow(1)= 1.d0 flow(2)= 0.d0 flow(3)= 1.d0 flow(4)= 0.d0 else if(iint.eq.2) then flow(1)= 0.d0 flow(2)= 1.d0 flow(3)= 0.d0 flow(4)= 1.d0 endif else do i=1,4 flow(i)= 1.d0 enddo endif * *-----Phases are applied * do ih=1,12 do ip=1,4 ephr(ip,ih)= ephr(ip,ih)*flow(ip) ephie(ip,ih)= ephie(ip,ih)*flow(ip) * pcggr(ip,ih)= ephr(ip,ih)*cggr(ip,ih)-ephie(ip,ih)* # cggie(ip,ih) pcgzr(ip,ih)= ephr(ip,ih)*cgzr(ip,ih)-ephie(ip,ih)* # cgzie(ip,ih) pczgr(ip,ih)= ephr(ip,ih)*czgr(ip,ih)-ephie(ip,ih)* # czgie(ip,ih) pczzr(ip,ih)= ephr(ip,ih)*czzr(ip,ih)-ephie(ip,ih)* # czzie(ip,ih) pp1zzr(ip,ih)= ephr(ip,ih)*p1zzr(ip,ih)-ephie(ip,ih)* # p1zzie(ip,ih) pp1zpr(ip,ih)= ephr(ip,ih)*p1zgr(ip,ih)-ephie(ip,ih)* # p1zgie(ip,ih) pp1zgr(ip,ih)= (ephr(ip,ih)*p1zgr(ip,ih)-ephie(ip,ih)* # p1zgie(ip,ih))*cfgg pp1pzr(ip,ih)= ephr(ip,ih)*p1gzr(ip,ih)-ephie(ip,ih)* # p1gzie(ip,ih) pp1ppr(ip,ih)= ephr(ip,ih)*p1ggr(ip,ih)-ephie(ip,ih)* # p1ggie(ip,ih) pp1pgr(ip,ih)= (ephr(ip,ih)*p1ggr(ip,ih)-ephie(ip,ih)* # p1ggie(ip,ih))*cfgg pp2zzr(ip,ih)= ephr(ip,ih)*p2zzr(ip,ih)-ephie(ip,ih)* # p2zzie(ip,ih) pp2zpr(ip,ih)= ephr(ip,ih)*p2zgr(ip,ih)-ephie(ip,ih)* # p2zgie(ip,ih) pp2zgr(ip,ih)= (ephr(ip,ih)*p2zgr(ip,ih)-ephie(ip,ih)* # p2zgie(ip,ih))*cfgg pp2pzr(ip,ih)= ephr(ip,ih)*p2gzr(ip,ih)-ephie(ip,ih)* # p2gzie(ip,ih) pp2ppr(ip,ih)= ephr(ip,ih)*p2ggr(ip,ih)-ephie(ip,ih)* # p2ggie(ip,ih) pp2pgr(ip,ih)= (ephr(ip,ih)*p2ggr(ip,ih)-ephie(ip,ih)* # p2ggie(ip,ih))*cfgg * pcggre(ip,ih)= ephr(ip,ih)*cggre(ip,ih)-ephie(ip,ih)* # cggi(ip,ih) pcgzre(ip,ih)= ephr(ip,ih)*cgzre(ip,ih)-ephie(ip,ih)* # cgzi(ip,ih) pczgre(ip,ih)= ephr(ip,ih)*czgre(ip,ih)-ephie(ip,ih)* # czgi(ip,ih) pczzre(ip,ih)= 0.d0 pp1zzre(ip,ih)= ephr(ip,ih)*p1zzre(ip,ih)-ephie(ip,ih)* # p1zzi(ip,ih) pp1zpre(ip,ih)= ephr(ip,ih)*p1zgre(ip,ih)-ephie(ip,ih)* # p1zgi(ip,ih) pp1zgre(ip,ih)= (ephr(ip,ih)*p1zgre(ip,ih)-ephie(ip,ih)* # p1zgi(ip,ih))*cfgg pp1pzre(ip,ih)= ephr(ip,ih)*p1gzre(ip,ih)-ephie(ip,ih)* # p1gzi(ip,ih) pp1ppre(ip,ih)= ephr(ip,ih)*p1ggre(ip,ih)-ephie(ip,ih)* # p1ggi(ip,ih) pp1pgre(ip,ih)= (ephr(ip,ih)*p1ggre(ip,ih)-ephie(ip,ih)* # p1ggi(ip,ih))*cfgg pp2zzre(ip,ih)= ephr(ip,ih)*p2zzre(ip,ih)-ephie(ip,ih)* # p2zzi(ip,ih) pp2zpre(ip,ih)= ephr(ip,ih)*p2zgre(ip,ih)-ephie(ip,ih)* # p2zgi(ip,ih) pp2zgre(ip,ih)= (ephr(ip,ih)*p2zgre(ip,ih)-ephie(ip,ih)* # p2zgi(ip,ih))*cfgg pp2pzre(ip,ih)= ephr(ip,ih)*p2gzre(ip,ih)-ephie(ip,ih)* # p2gzi(ip,ih) pp2ppre(ip,ih)= ephr(ip,ih)*p2ggre(ip,ih)-ephie(ip,ih)* # p2ggi(ip,ih) pp2pgre(ip,ih)= (ephr(ip,ih)*p2ggre(ip,ih)-ephie(ip,ih)* # p2ggi(ip,ih))*cfgg * pcggie(ip,ih)= ephr(ip,ih)*cggie(ip,ih)+ephie(ip,ih)* # cggr(ip,ih) pcgzie(ip,ih)= ephr(ip,ih)*cgzie(ip,ih)+ephie(ip,ih)* # cgzr(ip,ih) pczgie(ip,ih)= ephr(ip,ih)*czgie(ip,ih)+ephie(ip,ih)* # czgr(ip,ih) pczzie(ip,ih)= ephr(ip,ih)*czzie(ip,ih)+ephie(ip,ih)* # czzr(ip,ih) pp1zzie(ip,ih)= ephr(ip,ih)*p1zzie(ip,ih)+ephie(ip,ih)* # p1zzr(ip,ih) pp1zpie(ip,ih)= ephr(ip,ih)*p1zgie(ip,ih)+ephie(ip,ih)* # p1zgr(ip,ih) pp1zgie(ip,ih)= (ephr(ip,ih)*p1zgie(ip,ih)+ephie(ip,ih)* # p1zgr(ip,ih))*cfgg pp1pzie(ip,ih)= ephr(ip,ih)*p1gzie(ip,ih)+ephie(ip,ih)* # p1gzr(ip,ih) pp1ppie(ip,ih)= ephr(ip,ih)*p1ggie(ip,ih)+ephie(ip,ih)* # p1ggr(ip,ih) pp1pgie(ip,ih)= (ephr(ip,ih)*p1ggie(ip,ih)+ephie(ip,ih)* # p1ggr(ip,ih))*cfgg pp2zzie(ip,ih)= ephr(ip,ih)*p2zzie(ip,ih)+ephie(ip,ih)* # p2zzr(ip,ih) pp2zpie(ip,ih)= ephr(ip,ih)*p2zgie(ip,ih)+ephie(ip,ih)* # p2zgr(ip,ih) pp2zgie(ip,ih)= (ephr(ip,ih)*p2zgie(ip,ih)+ephie(ip,ih)* # p2zgr(ip,ih))*cfgg pp2pzie(ip,ih)= ephr(ip,ih)*p2gzie(ip,ih)+ephie(ip,ih)* # p2gzr(ip,ih) pp2ppie(ip,ih)= ephr(ip,ih)*p2ggie(ip,ih)+ephie(ip,ih)* # p2ggr(ip,ih) pp2pgie(ip,ih)= (ephr(ip,ih)*p2ggie(ip,ih)+ephie(ip,ih)* # p2ggr(ip,ih))*cfgg * pcggi(ip,ih)= ephr(ip,ih)*cggi(ip,ih)+ephie(ip,ih)* # cggre(ip,ih) pcgzi(ip,ih)= ephr(ip,ih)*cgzi(ip,ih)+ephie(ip,ih)* # cgzre(ip,ih) pczgi(ip,ih)= ephr(ip,ih)*czgi(ip,ih)+ephie(ip,ih)* # czgre(ip,ih) pczzi(ip,ih)= 0.d0 pp1zzi(ip,ih)= ephr(ip,ih)*p1zzi(ip,ih)+ephie(ip,ih)* # p1zzre(ip,ih) pp1zpi(ip,ih)= ephr(ip,ih)*p1zgi(ip,ih)+ephie(ip,ih)* # p1zgre(ip,ih) pp1zgi(ip,ih)= (ephr(ip,ih)*p1zgi(ip,ih)+ephie(ip,ih)* # p1zgre(ip,ih))*cfgg pp1pzi(ip,ih)= ephr(ip,ih)*p1gzi(ip,ih)+ephie(ip,ih)* # p1gzre(ip,ih) pp1ppi(ip,ih)= ephr(ip,ih)*p1ggi(ip,ih)+ephie(ip,ih)* # p1ggre(ip,ih) pp1pgi(ip,ih)= (ephr(ip,ih)*p1ggi(ip,ih)+ephie(ip,ih)* # p1ggre(ip,ih))*cfgg pp2zzi(ip,ih)= ephr(ip,ih)*p2zzi(ip,ih)+ephie(ip,ih)* # p2zzre(ip,ih) pp2zpi(ip,ih)= ephr(ip,ih)*p2zgi(ip,ih)+ephie(ip,ih)* # p2zgre(ip,ih) pp2zgi(ip,ih)= (ephr(ip,ih)*p2zgi(ip,ih)+ephie(ip,ih)* # p2zgre(ip,ih))*cfgg pp2pzi(ip,ih)= ephr(ip,ih)*p2gzi(ip,ih)+ephie(ip,ih)* # p2gzre(ip,ih) pp2ppi(ip,ih)= ephr(ip,ih)*p2ggi(ip,ih)+ephie(ip,ih)* # p2ggre(ip,ih) pp2pgi(ip,ih)= (ephr(ip,ih)*p2ggi(ip,ih)+ephie(ip,ih)* # p2ggre(ip,ih))*cfgg enddo enddo * *-----Diagrams with the same color structure are added * do ih=1,12 qdr(1,ih)= pcggr(1,ih)+pcgzr(1,ih)+pczgr(1,ih)+pczzr(1,ih)+ # pp1zzr(1,ih)+pp1zpr(1,ih)+pp1pzr(1,ih)+pp1ppr(1,ih)+ # pp2zzr(1,ih)+pp2zpr(1,ih)+pp2pzr(1,ih)+pp2ppr(1,ih) qdr(2,ih)= pp1pgr(1,ih)+pp1zgr(1,ih)+pp2pgr(1,ih)+pp2zgr(1,ih) qdr(3,ih)= -pcggr(2,ih)-pcgzr(2,ih)-pczgr(2,ih)-pczzr(2,ih)- # pp1zzr(2,ih)-pp1zpr(2,ih)-pp1pzr(2,ih)-pp1ppr(2,ih)- # pp2zzr(2,ih)-pp2zpr(2,ih)-pp2pzr(2,ih)-pp2ppr(2,ih) qdr(4,ih)= -pp1pgr(2,ih)-pp1zgr(2,ih)-pp2pgr(2,ih)-pp2zgr(2,ih) qdr(5,ih)= -pcggr(3,ih)-pcgzr(3,ih)-pczgr(3,ih)-pczzr(3,ih)- # pp1zzr(3,ih)-pp1zpr(3,ih)-pp1pzr(3,ih)-pp1ppr(3,ih)- # pp2zzr(3,ih)-pp2zpr(3,ih)-pp2pzr(3,ih)-pp2ppr(3,ih) qdr(6,ih)= -pp1pgr(3,ih)-pp1zgr(3,ih)-pp2pgr(3,ih)-pp2zgr(3,ih) qdr(7,ih)= pcggr(4,ih)+pcgzr(4,ih)+pczgr(4,ih)+pczzr(4,ih)+ # pp1zzr(4,ih)+pp1zpr(4,ih)+pp1pzr(4,ih)+pp1ppr(4,ih)+ # pp2zzr(4,ih)+pp2zpr(4,ih)+pp2pzr(4,ih)+pp2ppr(4,ih) qdr(8,ih)= pp1pgr(4,ih)+pp1zgr(4,ih)+pp2pgr(4,ih)+pp2zgr(4,ih) * qdre(1,ih)= pcggre(1,ih)+pcgzre(1,ih)+pczgre(1,ih)+ # pczzre(1,ih)+pp1zzre(1,ih)+pp1zpre(1,ih)+ # pp1pzre(1,ih)+pp1ppre(1,ih)+pp2zzre(1,ih)+ # pp2zpre(1,ih)+pp2pzre(1,ih)+pp2ppre(1,ih) qdre(2,ih)= pp1pgre(1,ih)+pp1zgre(1,ih)+pp2pgre(1,ih)+ # pp2zgre(1,ih) qdre(3,ih)= -pcggre(2,ih)-pcgzre(2,ih)-pczgre(2,ih)- # pczzre(2,ih)-pp1zzre(2,ih)-pp1zpre(2,ih)- # pp1pzre(2,ih)-pp1ppre(2,ih)-pp2zzre(2,ih)- # pp2zpre(2,ih)-pp2pzre(2,ih)-pp2ppre(2,ih) qdre(4,ih)= -pp1pgre(2,ih)-pp1zgre(2,ih)-pp2pgre(2,ih)- # pp2zgre(2,ih) qdre(5,ih)= -pcggre(3,ih)-pcgzre(3,ih)-pczgre(3,ih)- # pczzre(3,ih)-pp1zzre(3,ih)-pp1zpre(3,ih)- # pp1pzre(3,ih)-pp1ppre(3,ih)-pp2zzre(3,ih)- # pp2zpre(3,ih)-pp2pzre(3,ih)-pp2ppre(3,ih) qdre(6,ih)= -pp1pgre(3,ih)-pp1zgre(3,ih)-pp2pgre(3,ih)- # pp2zgre(3,ih) qdre(7,ih)= pcggre(4,ih)+pcgzre(4,ih)+pczgre(4,ih)+ # pczzre(4,ih)+pp1zzre(4,ih)+pp1zpre(4,ih)+ # pp1pzre(4,ih)+pp1ppre(4,ih)+pp2zzre(4,ih)+ # pp2zpre(4,ih)+pp2pzre(4,ih)+pp2ppre(4,ih) qdre(8,ih)= pp1pgre(4,ih)+pp1zgre(4,ih)+pp2pgre(4,ih)+ # pp2zgre(4,ih) * qdie(1,ih)= pcggie(1,ih)+pcgzie(1,ih)+pczgie(1,ih)+ # pczzie(1,ih)+pp1zzie(1,ih)+pp1zpie(1,ih)+ # pp1pzie(1,ih)+pp1ppie(1,ih)+pp2zzie(1,ih)+ # pp2zpie(1,ih)+pp2pzie(1,ih)+pp2ppie(1,ih) qdie(2,ih)= pp1pgie(1,ih)+pp1zgie(1,ih)+pp2pgie(1,ih)+ # pp2zgie(1,ih) qdie(3,ih)= -pcggie(2,ih)-pcgzie(2,ih)-pczgie(2,ih)- # pczzie(2,ih)-pp1zzie(2,ih)-pp1zpie(2,ih)- # pp1pzie(2,ih)-pp1ppie(2,ih)-pp2zzie(2,ih)- # pp2zpie(2,ih)-pp2pzie(2,ih)-pp2ppie(2,ih) qdie(4,ih)= -pp1pgie(2,ih)-pp1zgie(2,ih)-pp2pgie(2,ih)- # pp2zgie(2,ih) qdie(5,ih)= -pcggie(3,ih)-pcgzie(3,ih)-pczgie(3,ih)- # pczzie(3,ih)-pp1zzie(3,ih)-pp1zpie(3,ih)- # pp1pzie(3,ih)-pp1ppie(3,ih)-pp2zzie(3,ih)- # pp2zpie(3,ih)-pp2pzie(3,ih)-pp2ppie(3,ih) qdie(6,ih)= -pp1pgie(3,ih)-pp1zgie(3,ih)-pp2pgie(3,ih)- # pp2zgie(3,ih) qdie(7,ih)= pcggie(4,ih)+pcgzie(4,ih)+pczgie(4,ih)+ # pczzie(4,ih)+pp1zzie(4,ih)+pp1zpie(4,ih)+ # pp1pzie(4,ih)+pp1ppie(4,ih)+pp2zzie(4,ih)+ # pp2zpie(4,ih)+pp2pzie(4,ih)+pp2ppie(4,ih) qdie(8,ih)= pp1pgie(4,ih)+pp1zgie(4,ih)+pp2pgie(4,ih)+ # pp2zgie(4,ih) * qdi(1,ih)= pcggi(1,ih)+pcgzi(1,ih)+pczgi(1,ih)+pczzi(1,ih)+ # pp1zzi(1,ih)+pp1zpi(1,ih)+pp1pzi(1,ih)+pp1ppi(1,ih)+ # pp2zzi(1,ih)+pp2zpi(1,ih)+pp2pzi(1,ih)+pp2ppi(1,ih) qdi(2,ih)= pp1pgi(1,ih)+pp1zgi(1,ih)+pp2pgi(1,ih)+pp2zgi(1,ih) qdi(3,ih)= -pcggi(2,ih)-pcgzi(2,ih)-pczgi(2,ih)-pczzi(2,ih)- # pp1zzi(2,ih)-pp1zpi(2,ih)-pp1pzi(2,ih)-pp1ppi(2,ih)- # pp2zzi(2,ih)-pp2zpi(2,ih)-pp2pzi(2,ih)-pp2ppi(2,ih) qdi(4,ih)= -pp1pgi(2,ih)-pp1zgi(2,ih)-pp2pgi(2,ih)-pp2zgi(2,ih) qdi(5,ih)= -pcggi(3,ih)-pcgzi(3,ih)-pczgi(3,ih)-pczzi(3,ih)- # pp1zzi(3,ih)-pp1zpi(3,ih)-pp1pzi(3,ih)-pp1ppi(3,ih)- # pp2zzi(3,ih)-pp2zpi(3,ih)-pp2pzi(3,ih)-pp2ppi(3,ih) qdi(6,ih)= -pp1pgi(3,ih)-pp1zgi(3,ih)-pp2pgi(3,ih)-pp2zgi(3,ih) qdi(7,ih)= pcggi(4,ih)+pcgzi(4,ih)+pczgi(4,ih)+pczzi(4,ih)+ # pp1zzi(4,ih)+pp1zpi(4,ih)+pp1pzi(4,ih)+pp1ppi(4,ih)+ # pp2zzi(4,ih)+pp2zpi(4,ih)+pp2pzi(4,ih)+pp2ppi(4,ih) qdi(8,ih)= pp1pgi(4,ih)+pp1zgi(4,ih)+pp2pgi(4,ih)+pp2zgi(4,ih) enddo * do ih=1,12 fqdr(1,ih)= (dcfr(1)*qdr(1,ih)-dcfi(1)*qdi(1,ih))*vj fqdr(2,ih)= (dcfr(1)*qdr(2,ih)-dcfi(1)*qdi(2,ih))*vj fqdr(3,ih)= (dcfr(2)*qdr(3,ih)-dcfi(2)*qdi(3,ih))*vj fqdr(4,ih)= (dcfr(2)*qdr(4,ih)-dcfi(2)*qdi(4,ih))*vj fqdr(5,ih)= (dcfr(3)*qdr(5,ih)-dcfi(3)*qdi(5,ih))*vj fqdr(6,ih)= (dcfr(3)*qdr(6,ih)-dcfi(3)*qdi(6,ih))*vj fqdr(7,ih)= (dcfr(4)*qdr(7,ih)-dcfi(4)*qdi(7,ih))*vj fqdr(8,ih)= (dcfr(4)*qdr(8,ih)-dcfi(4)*qdi(8,ih))*vj fqdie(1,ih)= (dcfr(1)*qdie(1,ih)+dcfi(1)*qdre(1,ih))*vj fqdie(2,ih)= (dcfr(1)*qdie(2,ih)+dcfi(1)*qdre(2,ih))*vj fqdie(3,ih)= (dcfr(2)*qdie(3,ih)+dcfi(2)*qdre(3,ih))*vj fqdie(4,ih)= (dcfr(2)*qdie(4,ih)+dcfi(2)*qdre(4,ih))*vj fqdie(5,ih)= (dcfr(3)*qdie(5,ih)+dcfi(3)*qdre(5,ih))*vj fqdie(6,ih)= (dcfr(3)*qdie(6,ih)+dcfi(3)*qdre(6,ih))*vj fqdie(7,ih)= (dcfr(4)*qdie(7,ih)+dcfi(4)*qdre(7,ih))*vj fqdie(8,ih)= (dcfr(4)*qdie(8,ih)+dcfi(4)*qdre(8,ih))*vj fqdre(1,ih)= (dcfr(1)*qdre(1,ih)-dcfi(1)*qdie(1,ih))*vj fqdre(2,ih)= (dcfr(1)*qdre(2,ih)-dcfi(1)*qdie(2,ih))*vj fqdre(3,ih)= (dcfr(2)*qdre(3,ih)-dcfi(2)*qdie(3,ih))*vj fqdre(4,ih)= (dcfr(2)*qdre(4,ih)-dcfi(2)*qdie(4,ih))*vj fqdre(5,ih)= (dcfr(3)*qdre(5,ih)-dcfi(3)*qdie(5,ih))*vj fqdre(6,ih)= (dcfr(3)*qdre(6,ih)-dcfi(3)*qdie(6,ih))*vj fqdre(7,ih)= (dcfr(4)*qdre(7,ih)-dcfi(4)*qdie(7,ih))*vj fqdre(8,ih)= (dcfr(4)*qdre(8,ih)-dcfi(4)*qdie(8,ih))*vj fqdi(1,ih)= (dcfr(1)*qdi(1,ih)+dcfi(1)*qdr(1,ih))*vj fqdi(2,ih)= (dcfr(1)*qdi(2,ih)+dcfi(1)*qdr(2,ih))*vj fqdi(3,ih)= (dcfr(2)*qdi(3,ih)+dcfi(2)*qdr(3,ih))*vj fqdi(4,ih)= (dcfr(2)*qdi(4,ih)+dcfi(2)*qdr(4,ih))*vj fqdi(5,ih)= (dcfr(3)*qdi(5,ih)+dcfi(3)*qdr(5,ih))*vj fqdi(6,ih)= (dcfr(3)*qdi(6,ih)+dcfi(3)*qdr(6,ih))*vj fqdi(7,ih)= (dcfr(4)*qdi(7,ih)+dcfi(4)*qdr(7,ih))*vj fqdi(8,ih)= (dcfr(4)*qdi(8,ih)+dcfi(4)*qdr(8,ih))*vj enddo * do ih=1,12 dsh(ih)= 0.d0 do k=1,8 do kp=1,8 dsh(ih)= dsh(ih)+colf(k,kp)*(fqdr(k,ih)*fqdr(kp,ih)+ # fqdre(k,ih)*fqdre(kp,ih)+fqdie(k,ih)*fqdie(kp,ih)+ # fqdi(k,ih)*fqdi(kp,ih)) enddo enddo enddo * if(omssm.eq.'y') then xaa= 1.d0/x15/x25 xab= x25/x15 xac= 1.d0/xab xad= 1.d0/xaa xba= x45/x36 xbb= x36*x45 xbc= x36/x45 xbd= 1.d0/x14/x24 xca= x14/x24 xcb= 1.d0/xca xcc= 1.d0/xbd xcd= 1.d0/x15/x24 xda= x15/x24 xdb= 1.d0/xda xdc= 1.d0/xcd xdd= 1.d0/x34/x46 xef= x34/x46 xeg= x46/x34 xeh= 1.d0/xdd xfe= 1.d0/x14/x25 xff= x14/x25 xfg= x25/x14 xfh= 1.d0/xfe tgn1= xaa*xbb tgn2= xab*xbb tgn3= xac*xbb tgn4= xad*xbb tgn5= xbd*xbb tgn6= xcb*xbb tgn7= xca*xbb tgn8= xbd*xbb gh2= sqrt(tgn1) gh9= sqrt(tgn2) gh13= sqrt(tgn3) gh14= sqrt(tgn4) gh16= sqrt(tgn5) gh23= sqrt(tgn6) gh27= sqrt(tgn7) gh28= sqrt(tgn8) * d34hefr= gh16*(-x34+x45-x46)+gh23*(x13-x15+x16)+ # gh27*(x23-x25+x26)-2.d0*gh28 d34hefi= 4.d0*s1*gh16+4.d0*s4*gh16-4.d0*s5*gh16 * d3her= ver*d34hefr d3hei= ver*d34hefi d3hfr= vel*d34hefr d3hfi= -vel*d34hefi d4her= -ver*d34hefr d4hei= -ver*d34hefi d4hfr= -vel*d34hefr d4hfi= vel*d34hefi * d34hghr= gh2*(x35-x45+x56)+gh9*(-x13+x14-x16)+ # gh13*(-x23+x24-x26)+2.d0*gh14 d34hghi= -4.d0*s2*gh2+4.d0*s4*gh2+4.d0*s6*gh2 * d3hgr= ver*d34hghr d3hgi= ver*d34hghi d3hhr= vel*d34hghr d3hhi= -vel*d34hghi d4hgr= -ver*d34hghr d4hgi= -ver*d34hghi d4hhr= -vel*d34hghr d4hhi= vel*d34hghi * alpha1= -sbma*salpha/cbeta*tbeta alpha2= cbma*calpha/cbeta*tbeta alpha21= alpha2/alpha1 phur= (su-rshm2/vv)/ # (su-rshm2/vv)*(su-rshm2/vv)+(su*sshg)**2 phui= -su*sshg/ # (su-rshm2/vv)*(su-rshm2/vv)+(su*sshg)**2 phdr= (sd-rshm2/vv)/ # (sd-rshm2/vv)*(sd-rshm2/vv)+(sd*sshg)**2 phdi= -sd*sshg/ # (sd-rshm2/vv)*(sd-rshm2/vv)+(sd*sshg)**2 paur= (su-ram2/vv)/ # (su-ram2/vv)*(su-ram2/vv)+(su*sag)**2 paui= -su*sag/ # (su-ram2/vv)*(su-ram2/vv)+(su*sag)**2 padr= (sd-ram2/vv)/ # (sd-ram2/vv)*(sd-ram2/vv)+(sd*sag)**2 padi= -sd*sag/ # (sd-ram2/vv)*(sd-ram2/vv)+(sd*sag)**2 pr3r= phdr*paur-phdi*paui pr3i= phdr*paui+phdi*paur pr4r= phur*padr-phui*padi pr4i= phur*padi+phui*padr propu= (su-rbhm2/vv)*(su-rbhm2/vv)+(su*sbhg)**2 propd= (sd-rbhm2/vv)*(sd-rbhm2/vv)+(sd*sbhg)**2 addur= 1.d0+alpha21/propu*((su-rshm2/vv)*(su-rbhm2/vv)+ # su*su*sbhg*sshg) addui= alpha21/propu*su*((su-rshm2/vv)*sbhg-(su-rbhm2/vv)* # sshg) adddr= 1.d0+alpha21/propd*((sd-rshm2/vv)*(sd-rbhm2/vv)+ # sd*sd*sbhg*sshg) adddi= alpha21/propd*sd*((sd-rshm2/vv)*sbhg-(sd-rbhm2/vv)* # sshg) * bd3her= adddr*d3her bd3here= -adddi*d3hei bd3heie= adddr*d3hei bd3hei= adddi*d3her bd3hfr= adddr*d3hfr bd3hfre= -adddi*d3hfi bd3hfie= adddr*d3hfi bd3hfi= adddi*d3hfr bd3hgr= adddr*d3hgr bd3hgre= -adddi*d3hgi bd3hgie= adddr*d3hgi bd3hgi= adddi*d3hgr bd3hhr= adddr*d3hhr bd3hhre= -adddi*d3hhi bd3hhie= adddr*d3hhi bd3hhi= adddi*d3hhr * bd4her= addur*d4her bd4here= -addui*d4hei bd4heie= addur*d4hei bd4hei= addui*d4her bd4hfr= addur*d4hfr bd4hfre= -addui*d4hfi bd4hfie= addur*d4hfi bd4hfi= addui*d4hfr bd4hgr= addur*d4hgr bd4hgre= -addui*d4hgi bd4hgie= addur*d4hgi bd4hgi= addui*d4hgr bd4hhr= addur*d4hhr bd4hhre= -addui*d4hhi bd4hhie= addur*d4hhi bd4hhi= addui*d4hhr * cd3her= qcfr*bd3her-qcfi*bd3hei cd3here= qcfr*bd3here-qcfi*bd3heie cd3heie= qcfr*bd3heie+qcfi*bd3here cd3hei= qcfr*bd3hei+qcfi*bd3her cd3hfr= qcfr*bd3hfr-qcfi*bd3hfi cd3hfre= qcfr*bd3hfre-qcfi*bd3hfie cd3hfie= qcfr*bd3hfie+qcfi*bd3hfre cd3hfi= qcfr*bd3hfi+qcfi*bd3hfr cd3hgr= qcfr*bd3hgr-qcfi*bd3hgi cd3hgre= qcfr*bd3hgre-qcfi*bd3hgie cd3hgie= qcfr*bd3hgie+qcfi*bd3hgre cd3hgi= qcfr*bd3hgi+qcfi*bd3hgr cd3hhr= qcfr*bd3hhr-qcfi*bd3hhi cd3hhre= qcfr*bd3hhre-qcfi*bd3hhie cd3hhie= qcfr*bd3hhie+qcfi*bd3hhre cd3hhi= qcfr*bd3hhi+qcfi*bd3hhr * cd4her= qcfr*bd4her-qcfi*bd4hei cd4here= qcfr*bd4here-qcfi*bd4heie cd4heie= qcfr*bd4heie+qcfi*bd4here cd4hei= qcfr*bd4hei+qcfi*bd4her cd4hfr= qcfr*bd4hfr-qcfi*bd4hfi cd4hfre= qcfr*bd4hfre-qcfi*bd4hfie cd4hfie= qcfr*bd4hfie+qcfi*bd4hfre cd4hfi= qcfr*bd4hfi+qcfi*bd4hfr cd4hgr= qcfr*bd4hgr-qcfi*bd4hgi cd4hgre= qcfr*bd4hgre-qcfi*bd4hgie cd4hgie= qcfr*bd4hgie+qcfi*bd4hgre cd4hgi= qcfr*bd4hgi+qcfi*bd4hgr cd4hhr= qcfr*bd4hhr-qcfi*bd4hhi cd4hhre= qcfr*bd4hhre-qcfi*bd4hhie cd4hhie= qcfr*bd4hhie+qcfi*bd4hhre cd4hhi= qcfr*bd4hhi+qcfi*bd4hhr * dd3hr(1)= (pr3r*cd3her-pr3i*cd3hei)*rsz- # (pr3r*cd3hei+pr3i*cd3her)*aisz dd3hre(1)= (pr3r*cd3here-pr3i*cd3heie)*rsz- # (pr3r*cd3heie+pr3i*cd3here)*aisz dd3hie(1)= (pr3r*cd3heie+pr3i*cd3here)*rsz+ # (pr3r*cd3here-pr3i*cd3heie)*aisz dd3hi(1)= (pr3r*cd3hei+pr3i*cd3her)*rsz+ # (pr3r*cd3her-pr3i*cd3hei)*aisz dd3hr(2)= (pr3r*cd3hfr-pr3i*cd3hfi)*rsz- # (pr3r*cd3hfi+pr3i*cd3hfr)*aisz dd3hre(2)= (pr3r*cd3hfre-pr3i*cd3hfie)*rsz- # (pr3r*cd3hfie+pr3i*cd3hfre)*aisz dd3hie(2)= (pr3r*cd3hfie+pr3i*cd3hfre)*rsz+ # (pr3r*cd3hfre-pr3i*cd3hfie)*aisz dd3hi(2)= (pr3r*cd3hfi+pr3i*cd3hfr)*rsz+ # (pr3r*cd3hfr-pr3i*cd3hfi)*aisz dd3hr(3)= (pr3r*cd3hgr-pr3i*cd3hgi)*rsz- # (pr3r*cd3hgi+pr3i*cd3hgr)*aisz dd3hre(3)= (pr3r*cd3hgre-pr3i*cd3hgie)*rsz- # (pr3r*cd3hgie+pr3i*cd3hgre)*aisz dd3hie(3)= (pr3r*cd3hgie+pr3i*cd3hgre)*rsz+ # (pr3r*cd3hgre-pr3i*cd3hgie)*aisz dd3hi(3)= (pr3r*cd3hgi+pr3i*cd3hgr)*rsz+ # (pr3r*cd3hgr-pr3i*cd3hgi)*aisz dd3hr(4)= (pr3r*cd3hhr-pr3i*cd3hhi)*rsz- # (pr3r*cd3hhi+pr3i*cd3hhr)*aisz dd3hre(4)= (pr3r*cd3hhre-pr3i*cd3hhie)*rsz- # (pr3r*cd3hhie+pr3i*cd3hhre)*aisz dd3hie(4)= (pr3r*cd3hhie+pr3i*cd3hhre)*rsz+ # (pr3r*cd3hhre-pr3i*cd3hhie)*aisz dd3hi(4)= (pr3r*cd3hhi+pr3i*cd3hhr)*rsz+ # (pr3r*cd3hhr-pr3i*cd3hhi)*aisz * dd4hr(1)= (pr4r*cd4her-pr4i*cd4hei)*rsz- # (pr4r*cd4hei+pr4i*cd4her)*aisz dd4hre(1)= (pr4r*cd4here-pr4i*cd4heie)*rsz- # (pr4r*cd4heie+pr4i*cd4here)*aisz dd4hie(1)= (pr4r*cd4heie+pr4i*cd4here)*rsz+ # (pr4r*cd4here-pr4i*cd4heie)*aisz dd4hi(1)= (pr4r*cd4hei+pr4i*cd4her)*rsz+ # (pr4r*cd4her-pr4i*cd4hei)*aisz dd4hr(2)= (pr4r*cd4hfr-pr4i*cd4hfi)*rsz- # (pr4r*cd4hfi+pr4i*cd4hfr)*aisz dd4hre(2)= (pr4r*cd4hfre-pr4i*cd4hfie)*rsz- # (pr4r*cd4hfie+pr4i*cd4hfre)*aisz dd4hie(2)= (pr4r*cd4hfie+pr4i*cd4hfre)*rsz+ # (pr4r*cd4hfre-pr4i*cd4hfie)*aisz dd4hi(2)= (pr4r*cd4hfi+pr4i*cd4hfr)*rsz+ # (pr4r*cd4hfr-pr4i*cd4hfi)*aisz dd4hr(3)= (pr4r*cd4hgr-pr4i*cd4hgi)*rsz- # (pr4r*cd4hgi+pr4i*cd4hgr)*aisz dd4hre(3)= (pr4r*cd4hgre-pr4i*cd4hgie)*rsz- # (pr4r*cd4hgie+pr4i*cd4hgre)*aisz dd4hie(3)= (pr4r*cd4hgie+pr4i*cd4hgre)*rsz+ # (pr4r*cd4hgre-pr4i*cd4hgie)*aisz dd4hi(3)= (pr4r*cd4hgi+pr4i*cd4hgr)*rsz+ # (pr4r*cd4hgr-pr4i*cd4hgi)*aisz dd4hr(4)= (pr4r*cd4hhr-pr4i*cd4hhi)*rsz- # (pr4r*cd4hhi+pr4i*cd4hhr)*aisz dd4hre(4)= (pr4r*cd4hhre-pr4i*cd4hhie)*rsz- # (pr4r*cd4hhie+pr4i*cd4hhre)*aisz dd4hie(4)= (pr4r*cd4hhie+pr4i*cd4hhre)*rsz+ # (pr4r*cd4hhre-pr4i*cd4hhie)*aisz dd4hi(4)= (pr4r*cd4hhi+pr4i*cd4hhr)*rsz+ # (pr4r*cd4hhr-pr4i*cd4hhi)*aisz * hacc= 1.d0/16.d0/cth2*tbeta*salpha/cbeta*cbma*rbqm2/rwm2 do ih=5,8 ihp= ih-4 do k=1,8 dsh(ih)= dsh(ih)+2.d0*colf(k,3)*(fqdr(k,ih)*dd3hr(ihp)+ # fqdre(k,ih)*dd3hre(ihp)+fqdie(k,ih)*dd3hie(ihp)+ # fqdi(k,ih)*dd3hi(ihp))*vj*hacc dsh(ih)= dsh(ih)+2.d0*colf(k,5)*(fqdr(k,ih)*dd4hr(ihp)+ # fqdre(k,ih)*dd4hre(ihp)+fqdie(k,ih)*dd4hie(ihp)+ # fqdi(k,ih)*dd4hi(ihp))*vj*hacc enddo enddo endif * ds= 0.d0 do ih=1,12 ds= ds+dsh(ih) enddo * endif * 4 if(iz.eq.0) then dpxs(ix,it,itt)= 0.d0 iz= 1 else tjac= ujc*vjc*smjc*spjc*sujc*sdjc* # sfjc*twjc*t1jc*pmjac*ppjac* # pujac*pdjac*qcdjac dpxs(ix,it,itt)= 0.25d0*tjac*stf*ds/s endif * *-----end of ix loop * enddo * 5 if(iz.eq.0) then do ix=1,2 epxs(ix,it,itt)= 0.d0 enddo iz= 1 else do ix=1,2 epxs(ix,it,itt)= dpxs(ix,it,itt) enddo endif * *-----end of itt loop * enddo * cpxs(it)= 0.d0 do itt=1,ittm cpxs(it)= cpxs(it)+epxs(1,it,itt)+ # epxs(2,it,itt) enddo * 2 if(iz.eq.0) then bpxs(it)= 0.d0 iz= 1 else bpxs(it)= cpxs(it) endif * *-----end on it loop * enddo * 1 if(iz.eq.0) then apxs= 0.d0 iz= 1 else apxs= bpxs(1)+bpxs(2) endif * if(apxs.lt.0.d0) then ifz(41)= ifz(41)+1 resf= 0.d0 else resf= apxs endif * wtoxsn64= tfact*resf * if(om.eq.'g') then if(osm.eq.'n') then jp= iwtopos(ndim,x) if(ostop.eq.'s') then ifp= ifl(jp) if(wtoxsn64.ne.0.d0.and.ifp.lt.5000) then stry(jp,ifp)= wtoxsn64 if(wtoxsn64.gt.xshmx(jp)) then xshmx(jp)= wtoxsn64 endif ifl(jp)= ifl(jp)+1 else if(wtoxsn64.ne.0.d0.and.ifp.gt.5000) then if(wtoxsn64.gt.xshmx(jp)) then stry(jp,ifp)= wtoxsn64 * xshmx(jp)= wtoxsn64 ifl(jp)= ifl(jp)+1 endif endif else if(wtoxsn64.gt.xshmx(jp)) then xshmx(jp)= wtoxsn64 do l=1,9 xmxh(jp,l)= x(l) enddo endif endif endif xaph(1)= xm xaph(2)= xp xaph(3)= sm xaph(4)= sp xaph(5)= su xaph(6)= sd xaph(7)= sf xaph(8)= tw xaph(9)= t1 xaph(10)= t3 endif * return end *