* *-----WTOXSNH26----------------------------------------------------------- * real*8 function wtoxsnh26(ndim,x) implicit real*8 (a-h,o-z) character*1 oud,om,of parameter(npos=512) * common/wtfcd/of common/wtmod/om common/wtud/oud common/wtsfh/ip0 common/wtqcdz/alsz common/wthx/xshmx(npos) common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi * dimension x(ndim) * of= 'l' * if(om.eq.'e') then sign1= wtoxsh24(ndim,x) sign2= wtoxsh26(ndim,x) back= wtoxsn(ndim,x) wtoxsnh26= sign1+sign2+back else if(om.eq.'g') then if(ip0.eq.1) then sign1= wtoxsh24(ndim,x) else if(ip0.gt.1) then sign1= 0.d0 endif if(ip0.eq.2) then sign2= wtoxsh26(ndim,x) else if(ip0.ne.2) then sign2= 0.d0 endif if(ip0.eq.3) then back= wtoxsn(ndim,x) else if(ip0.ne.3) then back= 0.d0 endif wtoxsnh26= sign1+sign2+back endif * return end * *-----WTOXSNH24----------------------------------------------------------- * real*8 function wtoxsnh24(ndim,x) implicit real*8 (a-h,o-z) character*1 oud,om,of parameter(npos=512) * common/wtfcd/of common/wtmod/om common/wtud/oud common/wtsfh/ip0 common/wtqcdz/alsz common/wthx/xshmx(npos) common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi * dimension x(ndim) * of= 'l' * if(om.eq.'e') then if(oud.eq.'l') then sign= wtoxsh24(ndim,x) back= wtoxsn(ndim,x) wtoxsnh24= sign+back else if(oud.eq.'n') then sign= wtoxsh19(ndim,x) back= wtoxsn(ndim,x) wtoxsnh24= sign+back endif else if(om.eq.'g') then if(oud.eq.'l') then if(ip0.eq.2) then sign= 0.d0 else if(ip0.eq.1) then sign= wtoxsh24(ndim,x) endif if(ip0.eq.1) then back= 0.d0 else if(ip0.eq.2) then back= wtoxsn(ndim,x) endif wtoxsnh24= sign+back else if(oud.eq.'n') then if(ip0.eq.2) then sign= 0.d0 else sign= wtoxsh19(ndim,x) endif if(ip0.eq.1) then back= 0.d0 else back= wtoxsn(ndim,x) endif wtoxsnh24= sign+back endif endif * return end * *-----WTOXSNH19----------------------------------------------------------- * real*8 function wtoxsnh19(ndim,x) implicit real*8 (a-h,o-z) character*1 om parameter(npos=512) * common/wtmod/om common/wtsfh/ip0 common/wthx/xshmx(npos) common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi * dimension x(ndim) * if(om.eq.'e') then sign= wtoxsh19(ndim,x) back= wtoxsn(ndim,x) else if(om.eq.'g') then if(ip0.eq.2) then sign= 0.d0 else if(ip0.eq.1) then sign= wtoxsh19(ndim,x) endif if(ip0.eq.1) then back= 0.d0 else if(ip0.eq.2) then back= wtoxsn(ndim,x) endif endif * wtoxsnh19= sign+back * return end * *-----WTOXSNH49----------------------------------------------------------- * real*8 function wtoxsnh49(ndim,x) implicit real*8 (a-h,o-z) character*1 om parameter(npos=512) * common/wtmod/om common/wtsfh/ip0 common/wthx/xshmx(npos) common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi * dimension x(ndim) * if(om.eq.'e') then sign= wtoxsh49(ndim,x) back= wtoxsn(ndim,x) else if(om.eq.'g') then if(ip0.eq.2) then sign= 0.d0 else if(ip0.eq.1) then sign= wtoxsh49(ndim,x) endif if(ip0.eq.1) then back= 0.d0 else if(ip0.eq.2) then back= wtoxsn(ndim,x) endif endif * wtoxsnh49= sign+back * return end * *-----WTOXSNH32----------------------------------------------------------- * real*8 function wtoxsnh32(ndim,x) implicit real*8 (a-h,o-z) character*1 om,of parameter(npos=512) * common/wtfcd/of common/wtmod/om common/wtsfh/ip0 common/wthx/xshmx(npos) common/wtnchannel/chf,chfp,tif,tifp,fcun,fcdn common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi * dimension x(ndim) * of= 'q' * if(om.eq.'e') then sign= wtoxsh24(ndim,x) back= wtoxsn(ndim,x) backg= wtoxsng(ndim,x) wtoxsnh32= sign+back+backg else if(om.eq.'g') then if(ip0.eq.1) then sign= wtoxsh24(ndim,x) back= 0.d0 backg= 0.d0 else if(ip0.eq.2) then sign= 0.d0 back= wtoxsn(ndim,x) backg= 0.d0 else if(ip0.eq.3) then sign= 0.d0 back= 0.d0 backg= wtoxsng(ndim,x) endif wtoxsnh32= sign+back+backg endif * return end * *-----WTOXSNH64----------------------------------------------------------- * real*8 function wtoxsnh64(ndim,x) implicit real*8 (a-h,o-z) character*1 om parameter(npos=512) * common/wtihl/ih common/wtmod/om common/wtsfh/ip0 common/wthx/xshmx(npos) common/wtnchannel/chf,chfp,tif,tifp,fcun,fcdn common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi * dimension x(ndim) * if(om.eq.'e') then sign= 0.d0 do i=1,4 ih= i sign= sign+wtoxsh64(ndim,x) enddo back= wtoxsn64(ndim,x) wtoxsnh64= sign+back else if(om.eq.'g') then if(ip0.le.4) then ih= ip0 endif if(ip0.eq.1) then sign1= wtoxsh64(ndim,x) sign2= 0.d0 sign3= 0.d0 sign4= 0.d0 back= 0.d0 else if(ip0.eq.2) then sign1= 0.d0 sign2= wtoxsh64(ndim,x) sign3= 0.d0 sign4= 0.d0 back= 0.d0 else if(ip0.eq.3) then sign1= 0.d0 sign2= 0.d0 sign3= wtoxsh64(ndim,x) sign4= 0.d0 back= 0.d0 else if(ip0.eq.4) then sign1= 0.d0 sign2= 0.d0 sign3= 0.d0 sign4= wtoxsh64(ndim,x) back= 0.d0 else if(ip0.eq.5) then sign1= 0.d0 sign2= 0.d0 sign3= 0.d0 sign4= 0.d0 back= wtoxsn64(ndim,x) endif wtoxsnh64= sign1+sign2+sign3+sign4+back endif * return end * *-----WTOXSNSH64----------------------------------------------------------- * real*8 function wtoxsnsh64(ndim,x) implicit real*8 (a-h,o-z) character*1 om parameter(npos=512) * common/wtihl/ih common/wtmod/om common/wtsfh/ip0 common/wthx/xshmx(npos) common/wtnchannel/chf,chfp,tif,tifp,fcun,fcdn common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi * dimension x(ndim),sgn(8) * if(om.eq.'e') then sign= 0.d0 do i=1,4 ih= i sign= sign+wtoxsh64(ndim,x) enddo do i=1,4 ih= i sign= sign+wtoxsa64(ndim,x) enddo back= wtoxsn64(ndim,x) wtoxsnsh64= sign+back else if(om.eq.'g') then if(ip0.le.4) then ih= ip0 else if(ip0.gt.4.and.ip0.le.8) then ih= ip0-4 endif do i=1,8 sgn(i)= 0.d0 enddo if(ip0.le.4) then sgn(ip0)= wtoxsh64(ndim,x) back= 0.d0 else if(ip0.gt.4.and.ip0.le.8) then sgn(ip0)= wtoxsa64(ndim,x) back= 0.d0 else if(ip0.eq.9) then back= wtoxsn64(ndim,x) endif tots= 0.d0 do i=1,8 tots= tots+sgn(i) enddo wtoxsnsh64= tots+back endif * return end * *-----WTOXSSC----------------------------------------------------------- * real*8 function wtoxssc(ndim,x) implicit real*8 (a-h,o-z) character*1 om parameter(npos=512) * common/wtmod/om common/wtsfh/ip0 common/wthx/xshmx(npos) common/wtbpar/wm,zm,zg,gf,pi,pis,cfct,fcnt,ge,alphai,alwi * dimension x(ndim) * if(om.eq.'e') then sign= wtoxsc12(ndim,x) back= wtoxsc(ndim,x) else if(om.eq.'g') then if(ip0.eq.2) then sign= 0.d0 else if(ip0.eq.1) then sign= wtoxsc12(ndim,x) endif if(ip0.eq.1) then back= 0.d0 else if(ip0.eq.2) then back= wtoxsc(ndim,x) endif endif * wtoxssc= sign+back * return end * *-----WTOXSH24----------------------------------------------------------- * real*8 function wtoxsh24(ndim,x) implicit real*8 (a-h,o-z) character*1 om,osm,oqcd,of,omssm * parameter(ninv=10,npos=512) * common/wtfcd/of common/wtmod/om common/wtmp/zrm common/wtqcd/als common/wthiggs/hm common/wtsmod/osm common/wtkount/ik common/wtdis/dist common/wtqcdz/alsz common/wtaqcd/oqcd common/wtbme/bfact common/wtistrf/isf common/wtsf/ix0,it0 common/wtchi/hch(36) common/wtipt/ifz(44) common/wtmssmo/omssm common/wticuts/iac(4) common/wtisa/isaa,isab common/wthx/xshmx(npos) common/wtparh/xaph(ninv) common/wttc/itc,itcc,itcn common/wtpmxh/xmxh(npos,9) 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/wthapar/rhm,rhm2,rhg,rhmg,shg,shgs,opshgs 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 tgn(21) 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),cpxs(2),bpxs(2) dimension rr1(2),rr2(2),rs1(2),rs2(2),rtp(2),rtm(2) * 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 dpxs(ix,it)= 0.d0 enddo enddo do it=1,2 cpxs(it)= 0.d0 bpxs(it)= 0.d0 enddo * if(ndim.eq.6) then smx= x(1) sux= x(2) sdx= x(3) sfx= x(4) twx= x(5) t1x= x(6) 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.8) 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(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 * if(itc.eq.3) then omuld= 1.d0-(dist/rs+sqrt(dsm))*(dist/rs+sqrt(dsm)) omul= dmin1(omul,omuld) endif if(uvx.gt.1.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif 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) * if(itc.eq.3) then vvlld= (dist/rs+sqrt(dsm))*(dist/rs+sqrt(dsm)) vvll= dmax1(vvll,vvlld) endif * 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.lt.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else if(vkf.eq.0.d0) then if(vvx.gt.1.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else if(vvx.eq.1.d0) then veps= 0.d0 else veps= uvl*(1.d0-vvx)**hbeti endif avkf= 1.d0 else veps= uvl*(1.d0-(1.d0-vkf**hbet)*vvx)**hbeti avkf= 1.d0-vkf**hbet endif vv= uv-veps vjc0= 1.d0-vvll/uv if(vjc0.le.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else vjc= vjc0**hbet*avkf endif endif * if(vv.lt.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif svv= sqrt(vv) vzmg= rzmg*vv vhmg= rhmg*vv vshmg= rshmg*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 * *-----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 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.3) then dzmb= (svv-dist/rs)*(svv-dist/rs) zmb= dmin1(zmb,dzmb) endif * *-----test on sm * if(zmb.le.zma) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif * 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 if(sm.lt.0.d0) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif ssm= sqrt(sm) smjc= vv*smjc0 * 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 zpen= vv*(1.d0-bl(1)-bl(2)+sm) zmen= vv*(-1.d0+bl(3)+bl(4)+sm) zpa= dmax1(zpa,zmen) zpb= dmin1(zpb,zpen) 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)) zpa= dmax1(zpa,zpel) zpb= dmin1(zpb,zpeu1,zpeu2,zpeu3) endif zpap= vv*sct34 zpa= dmax1(zpa,zpap) * *-----test on sp * if(zpb.le.zpa) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif * if(itc.eq.3) then bdistl= dist*dist/s-zpa bdistu= zpb-dist*dist/s if(bdistl.le.0.d0.or.bdistu.le.0.d0) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif endif * if(omssm.eq.'n') then xrhm2= rhm2 xshg= shg xshgs= shgs xrhmg= rhmg xvhmg= vhmg xopshgs= opshgs else if(omssm.eq.'y') then xrhm2= rshm2 xshg= sshg xshgs= sshgs xrhmg= rshmg xvhmg= vshmg xopshgs= opsshgs endif if(itc.eq.3) then sp= (dist/rs/svv)**2 spjc= 2.d0*dist/s/((vv*sp-xrhm2)**2+ # (vv*sp*xshg)**2) else zpas= zpa-xrhm2 zpbs= zpb-xrhm2 atpa= (zpas+xshgs*zpa)/xrhmg atpb= (zpbs+xshgs*zpb)/xrhmg if(atpa.gt.1.d0.and.atpb.gt.1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/xvhmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/xvhmg spjc0= (-atpb+atpa)/xvhmg else if(atpa.gt.1.d0.and.atpb.lt.-1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/xvhmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/xvhmg spjc0= (-pi+atpb+atpa)/xvhmg else if(atpa.gt.1.d0.and.abs(atpb).lt.1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/xvhmg atpb= atan(atpb) zpbt= atpb/vhmg spjc0= (-pih+atpb+atpa)/xvhmg else if(atpa.lt.-1.d0.and.atpb.gt.1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/xvhmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/xvhmg spjc0= (pi-atpb-atpa)/xvhmg else if(atpa.lt.-1.d0.and.atpb.lt.-1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/xvhmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/xvhmg spjc0= (atpb-atpa)/xvhmg else if(atpa.lt.-1.d0.and.abs(atpb).lt.1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/xvhmg atpb= atan(atpb) zpbt= atpb/vhmg spjc0= (pih+atpb-atpa)/xvhmg else if(abs(atpa).lt.1.d0.and.atpb.gt.1.d0) then atpa= atan(atpa) zpat= atpa/xvhmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/xvhmg spjc0= (pih-atpb-atpa)/xvhmg else if(abs(atpa).lt.1.d0.and.atpb.lt.-1.d0) then atpa= atan(atpa) zpat= atpa/xvhmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/xvhmg spjc0= (-pih+atpb-atpa)/xvhmg else if(abs(atpa).lt.1.d0.and.abs(atpb).lt.1.d0) then atpa= atan(atpa) zpat= atpa/xvhmg atpb= atan(atpb) zpbt= atpb/xvhmg spjc0= (atpb-atpa)/xvhmg endif * zpv= spjc0*spx+zpat iftn= 1 atnp= xvhmg*zpv sp= xrhm2/xopshgs/vv*(1.d0+xshg*s07aaf(atnp,iftn)) if(iftn.ne.0) print 300 spjc= vv*spjc0 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 * smtp= sm*sp 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) * *-----test on su * if(suu.le.sul) then iz= 0 ifz(8)= ifz(8)+1 go to 1 endif * sujc= suu-sul su= sujc*sux+sul 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 * 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) * *-----test on sd * if(sdu.le.sdl) then iz= 0 ifz(9)= ifz(9)+1 go to 1 endif * sdjc= sdu-sdl sd= sdjc*sdx+sdl 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 * *-----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 * *-----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(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 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) 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 solved2 * 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 * tgn(1)= x14/x25/x36 tgn(2)= x14*x25*x36 tgn(3)= x24/x15/x36 tgn(4)= x15*x24*x36 tgn(5)= x14/x24/x34/x45*x46 tgn(6)= x14/x24/x34*x45/x46 tgn(7)= x14/x24*x34/x45*x46 tgn(8)= x14/x24*x34*x45/x46 tgn(9)= x14*x24/x34/x45*x46 tgn(10)= x14*x24/x34*x45/x46 tgn(11)= x45*x46/x15/x25/x34 tgn(12)= x45/x15/x25/x34/x46 tgn(13)= x34*x45/x15/x25/x46 tgn(14)= x25*x46/x15/x34/x45 tgn(15)= x25*x45/x15/x34/x46 tgn(16)= x15/x25/x34*x45/x46 tgn(17)= x25/x15/x34*x45*x46 tgn(18)= x25*x34*x45/x46/x15 tgn(19)= x15/x25/x34*x45*x46 tgn(20)= x15/x25*x34*x45/x46 tgn(21)= x15*x25*x34/x45*x46 * itgn= 0 do l=1,21 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 * gh1= sqrt(tgn(1)) gh2= sqrt(tgn(2)) gh3= sqrt(tgn(3)) gh4= sqrt(tgn(4)) gh5= sqrt(tgn(5)) gh6= sqrt(tgn(6)) gh7= sqrt(tgn(7)) gh8= sqrt(tgn(8)) gh9= sqrt(tgn(9)) gh10= sqrt(tgn(10)) gh11= sqrt(tgn(11)) gh12= sqrt(tgn(12)) gh13= sqrt(tgn(13)) gh14= sqrt(tgn(14)) gh15= sqrt(tgn(15)) gh16= sqrt(tgn(16)) gh17= sqrt(tgn(17)) gh18= sqrt(tgn(18)) gh19= sqrt(tgn(19)) gh20= sqrt(tgn(20)) gh21= sqrt(tgn(21)) * *-----Higgs Bremsstrahlung diagram: * *-----helicity h1-2) * hb12r= 4.d0*gh1*(-x23*x56+x26*x35)-4.d0*gh2 hb12i= 16.d0*s13*gh1 hb1r= 4.d0*hch(1)*hb12r hb1i= 4.d0*hch(1)*hb12i hb2r= 4.d0*hch(2)*hb12r hb2i= -4.d0*hch(2)*hb12i * *-----helicity h3-4) * hb34r= 4.d0*gh3*(-x13*x56+x16*x35)-4.d0*gh4 hb34i= -16.d0*s9*gh3 hb3r= 4.d0*hch(3)*hb34r hb3i= 4.d0*hch(3)*hb34i hb4r= 4.d0*hch(4)*hb34r hb4i= -4.d0*hch(4)*hb34i * *-----helicity h5-6) * hb56r= 4.d0*(gh7*x25-gh8*x26-gh9*x35+gh10*x36) hb56i= 16.d0*(s11*gh5-s12*gh6) hb5r= 4.d0*hch(1)*hb56r hb5i= 4.d0*hch(1)*hb56i hb6r= 4.d0*hch(2)*hb56r hb6i= -4.d0*hch(2)*hb56i * *-----helicity h7-8) * hb78r= -2.d0*gh11*x35+2.d0*gh12*(-x13*x24*x56+ # x13*x26*x45+x14*x23*x56-x14*x26*x35-x16* # x23*x45+x16*x24*x35+x36*x45)-2.d0*gh13*x56+ # 4.d0*gh14*x14*x35-2.d0*gh15*x14*x36-2.d0* # gh16*x24*x36-2.d0*gh17*x13+2.d0*gh18*x16+ # 2.d0*gh19*x23+2.d0*gh20*x26-4.d0*gh21 hb78i= 8.d0*(s2*gh11-s4*gh12*x36-s6*gh13+2.d0*s7*gh14- # s8*gh15-s12*gh16+s15*gh12) hb7r= 4.d0*hch(3)*hb78r hb7i= 4.d0*hch(3)*hb78i hb8r= 4.d0*hch(4)*hb78r hb8i= -4.d0*hch(4)*hb78i * *-----complete diagrams: * if(omssm.eq.'n') then hcf0= 1.d0 else if(omssm.eq.'y') then hcf0= -salpha/cbeta*sbma alpha1= -salpha/cbeta*sbma alpha2= calpha/cbeta*cbma alpha21= alpha2/alpha1 propp= (sp-rbhm2/vv)*(sp-rbhm2/vv)+(sp*sbhg)**2 addpr= 1.d0+alpha21/propp*((sp-rshm2/vv)*(sp-rbhm2/vv)+ # sp*sp*sbhg*sshg) addpi= alpha21/propp*sp*((sp-rshm2/vv)*sbhg-(sp-rbhm2/vv)* # sshg) endif hcf0s= hcf0*hcf0 hcf= rbqm2/vv/64.d0/cth4**2/dsz*hcf0s * *-----Total * if(omssm.eq.'n') then chb1r= hb1r chb1re= 0.d0 chb1ie= hb1i chb1i= 0.d0 chb2r= hb2r chb2re= 0.d0 chb2ie= hb2i chb2i= 0.d0 chb3r= hb3r chb3re= 0.d0 chb3ie= hb3i chb3i= 0.d0 chb4r= hb4r chb4re= 0.d0 chb4ie= hb4i chb4i= 0.d0 chb5r= hb5r chb5re= 0.d0 chb5ie= hb5i chb5i= 0.d0 chb6r= hb6r chb6re= 0.d0 chb6ie= hb6i chb6i= 0.d0 chb7r= hb7r chb7re= 0.d0 chb7ie= hb7i chb7i= 0.d0 chb8r= hb8r chb8re= 0.d0 chb8ie= hb8i chb8i= 0.d0 else if(omssm.eq.'y') then chb1r= addpr*hb1r chb1re= -addpi*hb1i chb1ie= addpr*hb1i chb1i= addpi*hb1r chb2r= addpr*hb2r chb2re= -addpi*hb2i chb2ie= addpr*hb2i chb2i= addpi*hb2r chb3r= addpr*hb3r chb3re= -addpi*hb3i chb3ie= addpr*hb3i chb3i= addpi*hb3r chb4r= addpr*hb4r chb4re= -addpi*hb4i chb4ie= addpr*hb4i chb4i= addpi*hb4r chb5r= addpr*hb5r chb5re= -addpi*hb5i chb5ie= addpr*hb5i chb5i= addpi*hb5r chb6r= addpr*hb6r chb6re= -addpi*hb6i chb6ie= addpr*hb6i chb6i= addpi*hb6r chb7r= addpr*hb7r chb7re= -addpi*hb7i chb7ie= addpr*hb7i chb7i= addpi*hb7r chb8r= addpr*hb8r chb8re= -addpi*hb8i chb8ie= addpr*hb8i chb8i= addpi*hb8r endif * dthr= chb1r*chb1r+chb2r*chb2r+chb3r*chb3r+chb4r*chb4r+ # chb5r*chb5r+chb6r*chb6r+chb7r*chb7r+chb8r*chb8r dthre= chb1re*chb1re+chb2re*chb2re+chb3re*chb3re+chb4re*chb4re+ # chb5re*chb5re+chb6re*chb6re+chb7re*chb7re+chb8re*chb8re dthie= chb1ie*chb1ie+chb2ie*chb2ie+chb3ie*chb3ie+chb4ie*chb4ie+ # chb5ie*chb5ie+chb6ie*chb6ie+chb7ie*chb7ie+chb8ie*chb8ie dthi= chb1i*chb1i+chb2i*chb2i+chb3i*chb3i+chb4i*chb4i+ # chb5i*chb5i+chb6i*chb6i+chb7i*chb7i+chb8i*chb8i dth= hcf*(dthr+dthre+dthie+dthi) * 4 if(iz.eq.0) then dpxs(ix,it)= 0.d0 iz= 1 else tjac= ujc*vjc*smjc*spjc*sujc*sdjc* # sfjc*twjc*t1jc*vv dpxs(ix,it)= tjac*stf*dth/s endif * *-----end of ix loop * enddo * cpxs(it)= dpxs(1,it)+dpxs(2,it) * 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 * if(oqcd.eq.'y') then nf= 5 if(omssm.eq.'n') then xhm= hm else if(omssm.eq.'y') then xhm= shm endif alsh= wtoralphas(wm,xhm,als,nf) if(omssm.eq.'n') then fqcd= 1.d0+alsh/pi*(17.d0/3.d0+(35.94d0-1.36d0*nf)* # alsh/pi) else if(omssm.eq.'y') then fqcd= 1.d0+17.d0/3.d0*alsh/pi endif if(of.eq.'q') then fqcd= fqcd*(1.d0+0.5d0*alsz/pi*(fcdn-1.d0)) endif else fqcd= 1.d0 endif * wtoxsh24= tfact*resf*bfact*fqcd * if(om.eq.'g') then if(osm.eq.'n') then jp= iwtopos(ndim,x) if(wtoxsh24.gt.xshmx(jp)) then xshmx(jp)= wtoxsh24 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 * *-----WTOXSH26----------------------------------------------------------- * real*8 function wtoxsh26(ndim,x) implicit real*8 (a-h,o-z) character*1 om,osm,oqcd,of,omssm * parameter(ninv=10,npos=512) * common/wtfcd/of common/wtmod/om common/wtmp/zrm common/wtqcd/als common/wthiggs/hm common/wtsmod/osm common/wtkount/ik common/wtdis/dist common/wtqcdz/alsz common/wtaqcd/oqcd common/wtbme/bfact common/wtistrf/isf common/wtsf/ix0,it0 common/wtipt/ifz(44) common/wtmssmo/omssm common/wticuts/iac(4) common/wtisa/isaa,isab common/wthx/xshmx(npos) common/wtparh/xaph(ninv) common/wttc/itc,itcc,itcn common/wtpmxh/xmxh(npos,9) 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/wthapar/rhm,rhm2,rhg,rhmg,shg,shgs,opshgs 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 tgn(58) 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),cpxs(2),bpxs(2) dimension rr1(2),rr2(2),rs1(2),rs2(2),rtp(2),rtm(2) * 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 dpxs(ix,it)= 0.d0 enddo enddo do it=1,2 cpxs(it)= 0.d0 bpxs(it)= 0.d0 enddo * if(ndim.eq.6) then smx= x(1) sux= x(2) sdx= x(3) sfx= x(4) twx= x(5) t1x= x(6) 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.8) 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(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 wm2= wm*wm tm2= tm*tm * *-----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 * if(itc.eq.3) then omuld= 1.d0-(dist/rs+sqrt(dsm))*(dist/rs+sqrt(dsm)) omul= dmin1(omul,omuld) endif if(uvx.gt.1.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif 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) * if(itc.eq.3) then vvlld= (dist/rs+sqrt(dsm))*(dist/rs+sqrt(dsm)) vvll= dmax1(vvll,vvlld) endif * 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.lt.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else if(vkf.eq.0.d0) then if(vvx.gt.1.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else if(vvx.eq.1.d0) then veps= 0.d0 else veps= uvl*(1.d0-vvx)**hbeti endif avkf= 1.d0 else veps= uvl*(1.d0-(1.d0-vkf**hbet)*vvx)**hbeti avkf= 1.d0-vkf**hbet endif vv= uv-veps vjc0= 1.d0-vvll/uv if(vjc0.le.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else vjc= vjc0**hbet*avkf endif endif * if(vv.lt.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif svv= sqrt(vv) vzmg= rzmg*vv vhmg= rhmg*vv vshmg= rshmg*vv vamg= ramg*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 * *-----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 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.3) then dzmb= (svv-dist/rs)*(svv-dist/rs) zmb= dmin1(zmb,dzmb) endif * *-----test on sm * if(zmb.le.zma) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif * zmas= zma-ram2 zmbs= zmb-ram2 atma= (zmas+sags*zma)/ramg atmb= (zmbs+sags*zmb)/ramg if(atma.gt.1.d0.and.atmb.gt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/vamg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/vamg smjc0= (-atmb+atma)/vamg else if(atma.gt.1.d0.and.atmb.lt.-1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/vamg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/vamg smjc0= (-pi+atmb+atma)/vamg else if(atma.gt.1.d0.and.abs(atmb).lt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/vamg atmb= atan(atmb) zmbt= atmb/vamg smjc0= (-pih+atmb+atma)/vamg else if(atma.lt.-1.d0.and.atmb.gt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/vamg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/vamg smjc0= (pi-atmb-atma)/vamg else if(atma.lt.-1.d0.and.atmb.lt.-1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/vamg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/vamg smjc0= (atmb-atma)/vamg else if(atma.lt.-1.d0.and.abs(atmb).lt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/vamg atmb= atan(atmb) zmbt= atmb/vamg smjc0= (pih+atmb-atma)/vamg else if(abs(atma).lt.1.d0.and.atmb.gt.1.d0) then atma= atan(atma) zmat= atma/vamg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/vamg smjc0= (pih-atmb-atma)/vamg else if(abs(atma).lt.1.d0.and.atmb.lt.-1.d0) then atma= atan(atma) zmat= atma/vamg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/vamg smjc0= (-pih+atmb-atma)/vamg else if(abs(atma).lt.1.d0.and.abs(atmb).lt.1.d0) then atma= atan(atma) zmat= atma/vamg atmb= atan(atmb) zmbt= atmb/vamg smjc0= (atmb-atma)/vamg endif * zmv= smjc0*smx+zmat iftn= 1 atnm= vamg*zmv s0a= ram2/opsags sm= s0a/vv*(1.d0+sag*s07aaf(atnm,iftn)) if(iftn.ne.0) print 300 if(sm.lt.0.d0) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif ssm= sqrt(sm) smjc= vv*smjc0 * * 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 zpen= vv*(1.d0-bl(1)-bl(2)+sm) zmen= vv*(-1.d0+bl(3)+bl(4)+sm) zpa= dmax1(zpa,zmen) zpb= dmin1(zpb,zpen) 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)) zpa= dmax1(zpa,zpel) zpb= dmin1(zpb,zpeu1,zpeu2,zpeu3) endif zpap= vv*sct34 zpa= dmax1(zpa,zpap) * *-----test on sp * if(zpb.le.zpa) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif * if(itc.eq.3) then bdistl= dist*dist/s-zpa bdistu= zpb-dist*dist/s 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.3) then sp= (dist/rs/svv)**2 spjc= 2.d0*dist/s/((vv*sp-rshm2)**2+ # (vv*sp*sshg)**2) else zpas= zpa-rshm2 zpbs= zpb-rshm2 atpa= (zpas+sshgs*zpa)/rshmg atpb= (zpbs+sshgs*zpb)/rshmg if(atpa.gt.1.d0.and.atpb.gt.1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/vshmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/vshmg spjc0= (-atpb+atpa)/vshmg else if(atpa.gt.1.d0.and.atpb.lt.-1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/vshmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/vshmg spjc0= (-pi+atpb+atpa)/vshmg else if(atpa.gt.1.d0.and.abs(atpb).lt.1.d0) then atpa= 1.d0/atpa atpa= atan(atpa) zpat= (pih-atpa)/vshmg atpb= atan(atpb) zpbt= atpb/vshmg spjc0= (-pih+atpb+atpa)/vshmg else if(atpa.lt.-1.d0.and.atpb.gt.1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/vshmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/vshmg spjc0= (pi-atpb-atpa)/vshmg else if(atpa.lt.-1.d0.and.atpb.lt.-1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/vshmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/vshmg spjc0= (atpb-atpa)/vshmg else if(atpa.lt.-1.d0.and.abs(atpb).lt.1.d0) then atpa= -1.d0/atpa atpa= atan(atpa) zpat= (-pih+atpa)/vshmg atpb= atan(atpb) zpbt= atpb/vshmg spjc0= (pih+atpb-atpa)/vshmg else if(abs(atpa).lt.1.d0.and.atpb.gt.1.d0) then atpa= atan(atpa) zpat= atpa/vshmg atpb= 1.d0/atpb atpb= atan(atpb) zpbt= (pih-atpb)/vshmg spjc0= (pih-atpb-atpa)/vshmg else if(abs(atpa).lt.1.d0.and.atpb.lt.-1.d0) then atpa= atan(atpa) zpat= atpa/vshmg atpb= -1.d0/atpb atpb= atan(atpb) zpbt= (-pih+atpb)/vshmg spjc0= (-pih+atpb-atpa)/vshmg else if(abs(atpa).lt.1.d0.and.abs(atpb).lt.1.d0) then atpa= atan(atpa) zpat= atpa/vshmg atpb= atan(atpb) zpbt= atpb/vshmg spjc0= (atpb-atpa)/vshmg endif * zpv= spjc0*spx+zpat iftn= 1 atnp= vshmg*zpv sp= rshm2/opsshgs/vv*(1.d0+sshg*s07aaf(atnp,iftn)) if(iftn.ne.0) print 300 spjc= vv*spjc0 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 * smtp= sm*sp 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) * *-----test on su * if(suu.le.sul) then iz= 0 ifz(8)= ifz(8)+1 go to 1 endif * sujc= suu-sul su= sujc*sux+sul 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 * 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(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) * *-----test on sd * sdjc= sdu-sdl sd= sdjc*sdx+sdl 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 * *-----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 * *-----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(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_wu * *-----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 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) 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 * 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 * tgn(1)= xaa*xba tgn(2)= xaa*xbb tgn(3)= xaa*xbc tgn(4)= xaa/xbb tgn(5)= xab*xba tgn(6)= xac/xbb tgn(7)= xab/xbb tgn(8)= xad/xbb tgn(9)= xab*xbb tgn(10)= xab*xbc tgn(11)= xac*xba tgn(12)= xac*xbc tgn(13)= xac*xbb tgn(14)= xad*xbb tgn(15)= xbd*xba tgn(16)= xbd*xbb tgn(17)= xbd*xbc tgn(18)= xbd/xbb tgn(19)= xcb*xba tgn(20)= xca/xbb tgn(21)= xcb/xbb tgn(22)= xbd/xbb tgn(23)= xcb*xbb tgn(24)= xcb*xbc tgn(25)= xca*xba tgn(26)= xca*xbc tgn(27)= xca*xbb tgn(28)= xbd*xbb tgn(29)= xcd*xeg tgn(30)= xcd*xeh tgn(31)= xcd*xef tgn(32)= xcd*xdd tgn(33)= xdb*xeg tgn(34)= xda*xdd tgn(35)= xdb*xdd tgn(36)= xdc*xdd tgn(37)= xdb*xeh tgn(38)= xdb*xef tgn(39)= xda*xeg tgn(40)= xda*xef tgn(41)= xda*xeh tgn(42)= xdc*xeh tgn(43)= xdc*xef tgn(44)= xfe*xeg tgn(45)= xfe*xeh tgn(46)= xfe*xef tgn(47)= xfe*xdd tgn(48)= xfg*xeg tgn(49)= xff*xdd tgn(50)= xfg*xdd tgn(51)= xfh*xdd tgn(52)= xfg*xeh tgn(53)= xfg*xef tgn(54)= xff*xeg tgn(55)= xff*xef tgn(56)= xff*xeh tgn(57)= xfh*xeh tgn(58)= xfh*xef * itgn= 0 do l=1,58 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 * gh1= sqrt(tgn(1)) gh2= sqrt(tgn(2)) gh3= sqrt(tgn(3)) gh4= sqrt(tgn(4)) gh5= sqrt(tgn(5)) gh6= sqrt(tgn(6)) gh7= sqrt(tgn(7)) gh8= sqrt(tgn(8)) gh9= sqrt(tgn(9)) gh10= sqrt(tgn(10)) gh11= sqrt(tgn(11)) gh12= sqrt(tgn(12)) gh13= sqrt(tgn(13)) gh14= sqrt(tgn(14)) gh15= sqrt(tgn(15)) gh16= sqrt(tgn(16)) gh17= sqrt(tgn(17)) gh18= sqrt(tgn(18)) gh19= sqrt(tgn(19)) gh20= sqrt(tgn(20)) gh21= sqrt(tgn(22)) gh22= sqrt(tgn(22)) gh23= sqrt(tgn(23)) gh24= sqrt(tgn(24)) gh25= sqrt(tgn(25)) gh26= sqrt(tgn(26)) gh27= sqrt(tgn(27)) gh28= sqrt(tgn(28)) gh29= sqrt(tgn(29)) gh30= sqrt(tgn(30)) gh31= sqrt(tgn(31)) gh32= sqrt(tgn(32)) gh33= sqrt(tgn(33)) gh34= sqrt(tgn(34)) gh35= sqrt(tgn(35)) gh36= sqrt(tgn(36)) gh37= sqrt(tgn(37)) gh38= sqrt(tgn(38)) gh39= sqrt(tgn(39)) gh40= sqrt(tgn(40)) gh41= sqrt(tgn(41)) gh42= sqrt(tgn(42)) gh43= sqrt(tgn(43)) gh44= sqrt(tgn(44)) gh45= sqrt(tgn(45)) gh46= sqrt(tgn(46)) gh47= sqrt(tgn(47)) gh48= sqrt(tgn(48)) gh49= sqrt(tgn(49)) gh50= sqrt(tgn(50)) gh51= sqrt(tgn(51)) gh52= sqrt(tgn(52)) gh53= sqrt(tgn(53)) gh54= sqrt(tgn(54)) gh55= sqrt(tgn(55)) gh56= sqrt(tgn(56)) gh57= sqrt(tgn(57)) gh58= sqrt(tgn(58)) * *-----Higgs Bremsstrahlung diagram:3G * *-----helicity h1-2) * hb12r= gh1*(-0.5d0*x13*x24*x56+0.5d0*x13*x26*x35+0.5d0* # x13*x26*x45-0.5d0*x13*x26*x56+0.5d0*x14*x23*x56- # 0.5d0*x14*x26*x35-0.5d0*x16*x23*x35-0.5d0*x16*x23* # x45+0.5d0*x16*x23*x56+0.5d0*x16*x24*x35+0.5d0*x34* # x56-0.5d0*x35*x46)+gh2*(0.5d0*x35+0.5d0*x45-0.5d0* # x56)+gh4*(-0.5d0*x13*x24*x35*x56+0.5d0*x13*x24*x56s+ # 0.5d0*x14*x23*x35*x56-0.5d0*x14*x23*x56s+0.5d0*x14* # x26*x35*x56-0.5d0*x14*x26*x35s-0.5d0*x16*x24*x35*x56+ # 0.5d0*x16*x24*x35s+0.5d0*x34*x35*x56-0.5d0*x34*x56s+ # 0.5d0*x35*x46*x56-0.5d0*x35s*x46)+gh5*(-0.5d0*x13* # x46+0.5d0*x16*x34)+gh6*(-x23*x34*x56+0.5d0*x23*x35* # x46+0.5d0*x23*x46*x56+0.5d0*x26*x34*x35+0.5d0*x26* # x34*x56-x26*x35*x46)+gh7*(0.5d0*x13*x35*x46-0.5d0* # x13*x46*x56-x14*x34*x56+x14*x35*x46-0.5d0*x16*x34* # x35+0.5d0*x16*x34*x56)+gh8*(x34*x56-x35*x46)+gh9* # (-x13-0.5d0*x14)+gh10*(0.5d0*x14*x35+0.5d0*x14*x56)+ # gh11*(0.5d0*x23*x46-0.5d0*x26*x34)+gh12*(-0.5d0* # x24*x35-0.5d0*x24*x56)+gh13*(-0.5d0*x24+x26)+gh14 hb12i= s1*gh1*(2.d0*x56)+s2*gh2*(-4)+ # s3*gh1*(2.d0*x35-2.d0*x56)+s4*gh3*(2.d0*x35+ # 2.d0*x56)+s6*gh1*(2.d0*x34)+s7*gh1*(-2.d0*x26)+ # s7*gh4*(-2.d0*x26*x35+2.d0*x26*x56)+s8*gh5*(2.d0)+ # s10*gh4*(2.d0*x23*x35-2.d0*x23*x56)+s12*gh6*(2.d0* # x35-2.d0*x56)+s13*gh1*(-2.d0*x14)+s13*gh4*(-2.d0* # x14*x35+2.d0*x14*x56)+s14*gh1*(2.d0*x13)+s15*gh6* # (-4.d0*x23+4.d0*x26)+s15*gh7*(-4.d0*x14)+s15*gh8* # (4.d0) hb1r= vel*hb12r hb1i= vel*hb12i hb2r= ver*hb12r hb2i= -ver*hb12i * *-----helicity h3-4) * hb34r= gh15*(-0.5d0*x13*x25*x46-0.5d0*x13*x26*x34+0.5d0* # x13*x26*x45+0.5d0*x13*x26*x46+0.5d0*x15*x23*x46- # 0.5d0*x15*x26*x34+0.5d0*x16*x23*x34-0.5d0*x16*x23* # x45-0.5d0*x16*x23*x46+0.5d0*x16*x25*x34+0.5d0*x34* # x56-0.5d0*x35*x46)+gh16*(-0.5d0*x34+0.5d0*x45+0.5d0* # x46)+gh18*(0.5d0*x13*x25*x34*x46-0.5d0*x13*x25*x46s- # 0.5d0*x15*x23*x34*x46+0.5d0*x15*x23*x46s-0.5d0*x15* # x26*x34*x46+0.5d0*x15*x26*x34s+0.5d0*x16*x25*x34*x46- # 0.5d0*x16*x25*x34s+0.5d0*x34*x35*x46+0.5d0*x34*x46* # x56-0.5d0*x34s*x56-0.5d0*x35*x46s)+gh19*(-0.5d0* # x13*x56+0.5d0*x16*x35)+gh20*(0.5d0*x23*x34*x56- # 0.5d0*x23*x46*x56-x25*x34*x56+x25*x35*x46-0.5d0* # x26*x34*x35+0.5d0*x26*x35*x46)+gh21*(0.5d0*x13* # x34*x56-x13*x35*x46+0.5d0*x13*x46*x56+0.5d0*x16* # x34*x35-x16*x34*x56+0.5d0*x16*x35*x46)+gh22*(x34* # x56-x35*x46)+gh23*(x13-0.5d0*x15)+gh24*(-0.5d0* # x15*x34-0.5d0*x15*x46)+gh25*(0.5d0*x23*x56-0.5d0* # x26*x35)+gh26*(0.5d0*x25*x34+0.5d0*x25*x46)+gh27* # (-0.5d0*x25-x26)+gh28 hb34i= s1*gh15*(-2.d0*x56)+s3*gh15*(2.d0*x34+2.d0*x46)+ # s4*gh17*(-2.d0*x34)+s5*gh18*(-2.d0*x35*x46)+ # s6*gh15*(-2.d0*x34)+s6*gh18*(2.d0*x34*x46)+ # s7*gh15*(2.d0*x26)+s7*gh18*(-2.d0*x26*x46)+ # s8*gh15*(-2.d0*x25+4.d0*x26)+s8*gh18*(2.d0* # x25*x34)+s9*gh21*(-2.d0*x34)+s11*gh18*(-2.d0* # x16*x34-2.d0*x16*x46)+s13*gh25*(2.d0)+s14*gh15* # (-2.d0*x13)+s14*gh18*(2.d0*x13*x34+4.d0*x16*x34)+ # s15*gh18*(-2.d0*x46)+s15*gh20*(4.d0*x25)+s15* # gh21*(-4.d0*x13)+s15*gh22*(-4.d0) hb3r= vel*hb34r hb3i= vel*hb34i hb4r= ver*hb34r hb4i= -ver*hb34i * *-----helicity h5-6) * hb56r= gh30*(0.5d0*x13*x25-x16*x25-0.5d0*x35+x56)+ # gh31*(-0.5d0*x13*x26*x45+0.5d0*x14*x23*x56- # 0.5d0*x14*x25*x36+0.5d0*x14*x26*x35-x14*x26*x56- # 0.5d0*x16*x23*x45+0.5d0*x16*x25*x34+x16*x26*x45- # 0.5d0*x34*x56+0.5d0*x36*x45)+gh38*(0.5d0*x13* # x56+x14*x56-0.5d0*x16*x35-x16*x45)+gh40*(-0.5d0* # x26*x34+x26*x45)+gh41*(0.5d0*x23-x25)+gh42+gh43* # (0.5d0*x36-x56) hb56i= s2*gh30*(2.d0)+s5*gh31*(-2.d0*x35+4*x56)+ # s7*gh31*(2.d0*x26)+s9*gh38*(2.d0)+s10* # gh38*(4.d0)+s12*gh40*(-2.d0)+s14*gh31* # (2.d0*x13-4.d0*x16)+s14*gh40*(-4.d0) hb5r= vel*hb56r hb5i= vel*hb56i hb6r= ver*hb56r hb6i= -ver*hb56i * *-----helicity h7-8) * hb78r= gh45*(0.5d0*x15*x23-x15*x26-0.5d0*x35+x56)+ # gh46*(0.5d0*x13*x24*x56-0.5d0*x13*x26*x45- # 0.5d0*x15*x24*x36+0.5d0*x15*x26*x34-0.5d0*x16* # x23*x45+0.5d0*x16*x24*x35-x16*x24*x56+x16*x26*x45- # 0.5d0*x34*x56+0.5d0*x36*x45)+gh52*(0.5d0*x13-x15)+ # gh53*(-0.5d0*x16*x34+x16*x45)+gh55*(0.5d0*x23* # x56+x24*x56-0.5d0*x26*x35-x26*x45)+gh57+gh58* # (0.5d0*x36-x56) hb78i= s1*gh46*(2.d0*x56)+s2*gh45*(2.d0)+s3*gh46* # (-2.d0*x45)+s5*gh46*(4.d0*x56)+s10*gh46*(-2.d0* # x23+4.d0*x26)+s10*gh53*(4.d0)+s14*gh46*(-2.d0* # x13)+s14*gh55*(-4.d0)+s15*gh46*(2.d0) hb7r= vel*hb78r hb7i= vel*hb78i hb8r= ver*hb78r hb8i= -vel*hb78i * *-----complete diagrams: * alpha1= 1.d0/256.d0/cth4*tbeta*salpha/cbeta*cbma alpha2= 1.d0/256.d0/cth4*tbeta*calpha/cbeta*sbma alpha21= alpha2/alpha1 hcf= rbqm2*s/wm2*tm2/wm2/vv*alpha1*alpha1/dsz propp= (sp-rbhm2/vv)*(sp-rbhm2/vv)+(sp*sbhg)**2 addpr= 1.d0+alpha21/propp*((sp-rshm2/vv)*(sp-rbhm2/vv)+ # sp*sp*sbhg*sshg) addpi= alpha21/propp*sp*((sp-rshm2/vv)*sbhg-(sp-rbhm2/vv)* # sshg) chb1r= addpr*hb1r chb1re= -addpi*hb1i chb1ie= addpr*hb1i chb1i= addpi*hb1r chb2r= addpr*hb2r chb2re= -addpi*hb2i chb2ie= addpr*hb2i chb2i= addpi*hb2r chb3r= addpr*hb3r chb3re= -addpi*hb3i chb3ie= addpr*hb3i chb3i= addpi*hb3r chb4r= addpr*hb4r chb4re= -addpi*hb4i chb4ie= addpr*hb4i chb4i= addpi*hb4r chb5r= addpr*hb5r chb5re= -addpi*hb5i chb5ie= addpr*hb5i chb5i= addpi*hb5r chb6r= addpr*hb6r chb6re= -addpi*hb6i chb6ie= addpr*hb6i chb6i= addpi*hb6r chb7r= addpr*hb7r chb7re= -addpi*hb7i chb7ie= addpr*hb7i chb7i= addpi*hb7r chb8r= addpr*hb8r chb8re= -addpi*hb8i chb8ie= addpr*hb8i chb8i= addpi*hb8r * *-----Total * dthr= chb1r*chb1r+chb2r*chb2r+chb3r*chb3r+chb4r*chb4r+ # chb5r*chb5r+chb6r*chb6r+chb7r*chb7r+chb8r*chb8r dthre= chb1re*chb1re+chb2re*chb2re+chb3re*chb3re+chb4re*chb4re+ # chb5re*chb5re+chb6re*chb6re+chb7re*chb7re+chb8re*chb8re dthie= chb1ie*chb1ie+chb2ie*chb2ie+chb3ie*chb3ie+chb4ie*chb4ie+ # chb5ie*chb5ie+chb6ie*chb6ie+chb7ie*chb7ie+chb8ie*chb8ie dthi= chb1i*chb1i+chb2i*chb2i+chb3i*chb3i+chb4i*chb4i+ # chb5i*chb5i+chb6i*chb6i+chb7i*chb7i+chb8i*chb8i dth= hcf*(dthr+dthre+dthie+dthi) * 4 if(iz.eq.0) then dpxs(ix,it)= 0.d0 iz= 1 else tjac= ujc*vjc*smjc*spjc*sujc*sdjc* # sfjc*twjc*t1jc*vv dpxs(ix,it)= tjac*stf*dth/s endif * *-----end of ix loop * enddo * cpxs(it)= dpxs(1,it)+dpxs(2,it) * 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 * if(oqcd.eq.'y') then nf= 5 alssh= wtoralphas(wm,shm,als,nf) alsa= wtoralphas(wm,am,als,nf) fqcd= 1.d0+17.d0/3.d0*(alssh+alsa)/pi else fqcd= 1.d0 endif * wtoxsh26= tfact*resf*bfact*fqcd * if(om.eq.'g') then if(osm.eq.'n') then jp= iwtopos(ndim,x) if(wtoxsh26.gt.xshmx(jp)) then xshmx(jp)= wtoxsh26 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 * *-----WTOXSH19------------------------------------------------------------ * real*8 function wtoxsh19(ndim,x) implicit real*8 (a-h,o-z) character*1 oud,om,osm,oqcd,omssm * parameter(ninv=10,npos=512) * common/wtmod/om common/wtmp/zrm common/wtud/oud common/wtqcd/als common/wthiggs/hm common/wtsmod/osm common/wtdis/dist common/wtkount/ik common/wtaqcd/oqcd common/wtbme/bfact common/wtistrf/isf common/wtsf/ix0,it0 common/wtchi/hch(36) common/wtipt/ifz(44) common/wtmssmo/omssm common/wticuts/iac(4) common/wtisa/isaa,isab common/wthx/xshmx(npos) common/wtparh/xaph(ninv) common/wttc/itc,itcc,itcn common/wtpmxh/xmxh(npos,9) 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/wthapar/rhm,rhm2,rhg,rhmg,shg,shgs,opshgs 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 tgn(31) 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),cpxs(2),bpxs(2) dimension rr1(2),rr2(2),rs1(2),rs2(2),rtp(2),rtm(2) * 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 dpxs(ix,it)= 0.d0 enddo enddo do it=1,2 cpxs(it)= 0.d0 bpxs(it)= 0.d0 enddo * if(ndim.eq.6) then spx= x(1) sux= x(2) sdx= x(3) sfx= x(4) twx= x(5) t1x= x(6) else if(ndim.eq.8) then uvx= x(1) vvx= x(2) spx= x(3) sux= x(4) sdx= x(5) sfx= x(6) twx= x(7) t1x= x(8) 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(oud.eq.'l') then fkill= 1.d0 else if(oud.eq.'n') then fkill= 0.d0 endif * *-----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 * if(uvx.gt.1.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif 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.lt.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else if(vkf.eq.0.d0) then if(vvx.gt.1.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else if(vvx.eq.1.d0) then veps= 0.d0 else veps= uvl*(1.d0-vvx)**hbeti endif avkf= 1.d0 else veps= uvl*(1.d0-(1.d0-vkf**hbet)*vvx)**hbeti avkf= 1.d0-vkf**hbet endif vv= uv-veps vjc0= 1.d0-vvll/uv if(vjc0.le.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else vjc= vjc0**hbet*avkf endif endif * if(vv.lt.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif svv= sqrt(vv) vzmg= rzmg*vv vhmg= rhmg*vv vshmg= rshmg*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 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 * *-----test on sm * if(zmb.le.zma) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif * if(itc.eq.4) then bdistl= dist*dist/s-zma bdistu= zmb-dist*dist/s if(bdistl.le.0.d0.or.bdistu.le.0.d0) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif endif * if(omssm.eq.'n') then xrhm2= rhm2 xshg= shg xshgs= shgs xrhmg= rhmg xvhmg= vhmg xopshgs= opshgs else if(omssm.eq.'y') then xrhm2= rshm2 xshg= sshg xshgs= sshgs xrhmg= rshmg xvhmg= vshmg xopshgs= opsshgs endif * if(itc.eq.4) then sm= (dist/rs/svv)**2 smjc= 2.d0*dist/s/((vv*sm-xrhm2)**2+ # (vv*sm*xshg)**2) else * zmas= zma-xrhm2 zmbs= zmb-xrhm2 atma= (zmas+xshgs*zma)/xrhmg atmb= (zmbs+xshgs*zmb)/xrhmg if(atma.gt.1.d0.and.atmb.gt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/xvhmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/xvhmg smjc0= (-atmb+atma)/xvhmg else if(atma.gt.1.d0.and.atmb.lt.-1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/xvhmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/xvhmg smjc0= (-pi+atmb+atma)/xvhmg else if(atma.gt.1.d0.and.abs(atmb).lt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/xvhmg atmb= atan(atmb) zmbt= atmb/xvhmg smjc0= (-pih+atmb+atma)/xvhmg else if(atma.lt.-1.d0.and.atmb.gt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/xvhmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/xvhmg smjc0= (pi-atmb-atma)/xvhmg else if(atma.lt.-1.d0.and.atmb.lt.-1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/xvhmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/xvhmg smjc0= (atmb-atma)/xvhmg else if(atma.lt.-1.d0.and.abs(atmb).lt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/xvhmg atmb= atan(atmb) zmbt= atmb/xvhmg smjc0= (pih+atmb-atma)/xvhmg else if(abs(atma).lt.1.d0.and.atmb.gt.1.d0) then atma= atan(atma) zmat= atma/xvhmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/xvhmg smjc0= (pih-atmb-atma)/xvhmg else if(abs(atma).lt.1.d0.and.atmb.lt.-1.d0) then atma= atan(atma) zmat= atma/xvhmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/xvhmg smjc0= (-pih+atmb-atma)/xvhmg else if(abs(atma).lt.1.d0.and.abs(atmb).lt.1.d0) then atma= atan(atma) zmat= atma/xvhmg atmb= atan(atmb) zmbt= atmb/xvhmg smjc0= (atmb-atma)/xvhmg endif * zmv= smjc0*smx+zmat iftn= 1 atnm= xvhmg*zmv sm= xrhm2/xopshgs/vv*(1.d0+xshg*s07aaf(atnm,iftn)) if(iftn.ne.0) print 300 smjc= vv*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) * *-----test on sp * if(zpb.le.zpa) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif * 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 if(sp.lt.0.d0) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif ssp= sqrt(sp) spjc= vv*spjc0 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 * smtp= sm*sp 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) * *-----test on su * if(suu.le.sul) then iz= 0 ifz(8)= ifz(8)+1 go to 1 endif * sujc= suu-sul su= sujc*sux+sul 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 * 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) * *-----test on sd * if(sdu.le.sdl) then iz= 0 ifz(9)= ifz(9)+1 go to 1 endif * sdjc= sdu-sdl sd= sdjc*sdx+sdl 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 * *-----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 * *-----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(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 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= 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 * tgn(1)= x14/x25/x36 tgn(2)= x14*x25*x36 tgn(3)= x24/x15/x36 tgn(4)= x15*x24*x36 tgn(5)= x14/x24/x34/x45*x46 tgn(6)= x14/x24/x34*x45/x46 tgn(7)= x14/x24*x34/x45*x46 tgn(8)= x14/x24*x34*x45/x46 tgn(9)= x14*x24/x34/x45*x46 tgn(10)= x14*x24/x34*x45/x46 tgn(11)= x45*x46/x15/x25/x34 tgn(12)= x45/x15/x25/x34/x46 tgn(13)= x34*x45/x15/x25/x46 tgn(14)= x25*x46/x15/x34/x45 tgn(15)= x25*x45/x15/x34/x46 tgn(16)= x15/x25/x34*x45/x46 tgn(17)= x25/x15/x34*x45*x46 tgn(18)= x25*x34*x45/x46/x15 tgn(19)= x15/x25/x34*x45*x46 tgn(20)= x15/x25*x34*x45/x46 tgn(21)= x15*x25*x34/x45*x46 tgn(22)= x34/x15/x25/x45/x46 tgn(23)= x15/x25*x34/x45*x46 tgn(24)= x34/x14/x24*x45/x46 tgn(25)= x14/x24*x34/x45/x46 tgn(26)= x24/x14*x34*x45/x46 tgn(27)= x14*x24*x34/x45/x46 tgn(28)= x34/x14/x24*x45*x46 tgn(29)= x15/x24/x36 tgn(30)= 1.d0/x14/x25/x36 tgn(31)= x14/x25*x36 * itgn= 0 do l=1,31 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 * gh1= sqrt(tgn(1)) gh2= sqrt(tgn(2)) gh3= sqrt(tgn(3)) gh4= sqrt(tgn(4)) gh5= sqrt(tgn(5)) gh6= sqrt(tgn(6)) gh7= sqrt(tgn(7)) gh8= sqrt(tgn(8)) gh9= sqrt(tgn(9)) gh10= sqrt(tgn(10)) gh11= sqrt(tgn(11)) gh12= sqrt(tgn(12)) gh13= sqrt(tgn(13)) gh14= sqrt(tgn(14)) gh15= sqrt(tgn(15)) gh16= sqrt(tgn(16)) gh17= sqrt(tgn(17)) gh18= sqrt(tgn(18)) gh19= sqrt(tgn(19)) gh20= sqrt(tgn(20)) gh21= sqrt(tgn(21)) gh22= sqrt(tgn(22)) gh23= sqrt(tgn(23)) gh24= sqrt(tgn(24)) gh25= sqrt(tgn(25)) gh26= sqrt(tgn(26)) gh27= sqrt(tgn(27)) gh28= sqrt(tgn(28)) gh29= sqrt(tgn(29)) gh30= sqrt(tgn(30)) gh31= sqrt(tgn(31)) * *-----Helicity he1-2) * *-----Higgs Bremsstrahlung diagram: * hb12r= 4.d0*(gh7*x25+gh26*x16-gh27*x56- # gh28) hb12i= 16.d0*(-s5*gh24+s14*gh25) hb1r= 4.d0*hch(7)*hb12r hb1i= 4.d0*hch(7)*hb12i hb2r= 4.d0*hch(8)*hb12r hb2i= -4.d0*hch(8)*hb12i * *-----Higgs Fusion diagram: * hf2r= 4.d0*(-gh7*x25-gh26*x16+gh27*x56+gh28) hf2i= 16.d0*(-s5*gh24+s14*gh25) * *-----Helicity he3-4) * *-----Higgs Bremsstrahlung diagram: * hb34r= 4.d0*(-gh4+gh29*(x23*x46-x26*x34)) hb34i= -16.d0*s12*gh29 hb3r= 4.d0*hch(7)*hb34r hb3i= 4.d0*hch(7)*hb34i hb4r= 4.d0*hch(8)*hb34r hb4i= -4.d0*hch(8)*hb34i * *-----Higgs Fusion diagram: * hf4r= 4.d0*(gh4+gh29*(-x23*x46+x26*x34)) hf4i= -16.d0*s12*gh29 * *-----Helicity he5-6) * *-----Higgs Bremsstrahlung diagram: * hb56r= 4.d0*(-gh13*x16*x25+gh22*x14*x25*x56- # gh23*x25) hb56i= 16.d0*s10*gh22*x25 hb5r= 4.d0*hch(5)*hb56r hb5i= 4.d0*hch(5)*hb56i hb6r= 4.d0*hch(6)*hb56r hb6i= -4.d0*hch(6)*hb56i * *-----Helicity he7-8) * *-----Higgs Bremsstrahlung diagram: * hb78r= 4.d0*(gh30*(x13*x25*x46-x16*x25*x34)- # gh31*x25) hb78i= 16.d0*s8*gh30*x25 hb7r= 4.d0*hch(5)*hb78r hb7i= 4.d0*hch(5)*hb78i hb8r= 4.d0*hch(6)*hb78r hb8i= -4.d0*hch(6)*hb78i * *-----compensating single Z propagator * wpcfr= sp-rzm2/vv wpcfi= sp*szg * *-----extra propagators * vrwm2= rwm2/vv x25w= x25+vrwm2 x16w= x16+vrwm2 * *-----complete diagrams: * if(omssm.eq.'y') then alpha1= -sbma*salpha/cbeta alpha2= cbma*calpha/cbeta alpha21= alpha2/alpha1 propm= (sm-rbhm2/vv)*(sm-rbhm2/vv)+(sm*sbhg)**2 addmr= 1.d0+alpha21/propm*((sm-rshm2/vv)*(sm-rbhm2/vv)+ # sm*sm*sbhg*sshg) addmi= alpha21/propm*sm*((sm-rshm2/vv)*sbhg-(sm-rbhm2/vv)* # sshg) else if(omssm.eq.'n') then alpha1= 1.d0 addmr= 1.d0 addmi= 0.d0 endif hbcf= sqrt(rbqm2/vv)/8.d0/cth4*alpha1 hfcf= fkill*sqrt(rbqm2/vv)/16.d0/x16w/x25w*alpha1 * chb1r= hbcf*rsz*hb1r chb1re= -hbcf*aisz*hb1i chb1ie= hbcf*rsz*hb1i chb1i= hbcf*aisz*hb1r * chb2r= hbcf*rsz*hb2r chb2re= -hbcf*aisz*hb2i chb2ie= hbcf*rsz*hb2i chb2i= hbcf*aisz*hb2r * chb3r= hbcf*rsz*hb3r chb3re= -hbcf*aisz*hb3i chb3ie= hbcf*rsz*hb3i chb3i= hbcf*aisz*hb3r * chb4r= hbcf*rsz*hb4r chb4re= -hbcf*aisz*hb4i chb4ie= hbcf*rsz*hb4i chb4i= hbcf*aisz*hb4r * chb5r= hbcf*rsz*hb5r chb5re= -hbcf*aisz*hb5i chb5ie= hbcf*rsz*hb5i chb5i= hbcf*aisz*hb5r * chb6r= hbcf*rsz*hb6r chb6re= -hbcf*aisz*hb6i chb6ie= hbcf*rsz*hb6i chb6i= hbcf*aisz*hb6r * chb7r= hbcf*rsz*hb7r chb7re= -hbcf*aisz*hb7i chb7ie= hbcf*rsz*hb7i chb7i= hbcf*aisz*hb7r * chb8r= hbcf*rsz*hb8r chb8re= -hbcf*aisz*hb8i chb8ie= hbcf*rsz*hb8i chb8i= hbcf*aisz*hb8r * chf2r= hfcf*wpcfr*hf2r chf2re= -hfcf*wpcfi*hf2i chf2ie= hfcf*wpcfr*hf2i chf2i= hfcf*wpcfi*hf2r * chf4r= hfcf*wpcfr*hf4r chf4re= -hfcf*wpcfi*hf4i chf4ie= hfcf*wpcfr*hf4i chf4i= hfcf*wpcfi*hf4r * cchb1r= addmr*chb1r-addmi*chb1i cchb1re= addmr*chb1re-addmi*chb1ie cchb1ie= addmr*chb1ie+addmi*chb1re cchb1i= addmr*chb1i+addmi*chb1r cchb2r= addmr*chb2r-addmi*chb2i cchb2re= addmr*chb2re-addmi*chb2ie cchb2ie= addmr*chb2ie+addmi*chb2re cchb2i= addmr*chb2i+addmi*chb2r cchb3r= addmr*chb3r-addmi*chb3i cchb3re= addmr*chb3re-addmi*chb3ie cchb3ie= addmr*chb3ie+addmi*chb3re cchb3i= addmr*chb3i+addmi*chb3r cchb4r= addmr*chb4r-addmi*chb4i cchb4re= addmr*chb4re-addmi*chb4ie cchb4ie= addmr*chb4ie+addmi*chb4re cchb4i= addmr*chb4i+addmi*chb4r cchb5r= addmr*chb5r-addmi*chb5i cchb5re= addmr*chb5re-addmi*chb5ie cchb5ie= addmr*chb5ie+addmi*chb5re cchb5i= addmr*chb5i+addmi*chb5r cchb6r= addmr*chb6r-addmi*chb6i cchb6re= addmr*chb6re-addmi*chb6ie cchb6ie= addmr*chb6ie+addmi*chb6re cchb6i= addmr*chb6i+addmi*chb6r cchb7r= addmr*chb7r-addmi*chb7i cchb7re= addmr*chb7re-addmi*chb7ie cchb7ie= addmr*chb7ie+addmi*chb7re cchb7i= addmr*chb7i+addmi*chb7r cchb8r= addmr*chb8r-addmi*chb8i cchb8re= addmr*chb8re-addmi*chb8ie cchb8ie= addmr*chb8ie+addmi*chb8re cchb8i= addmr*chb8i+addmi*chb8r cchf2r= addmr*chf2r-addmi*chf2i cchf2re= addmr*chf2re-addmi*chf2ie cchf2ie= addmr*chf2ie+addmi*chf2re cchf2i= addmr*chf2i+addmi*chf2r cchf4r= addmr*chf4r-addmi*chf4i cchf4re= addmr*chf4re-addmi*chf4ie cchf4ie= addmr*chf4ie+addmi*chf4re cchf4i= addmr*chf4i+addmi*chf4r * *-----Total * dthr= cchb1r*cchb1r+(cchb2r-cchf2r)*(cchb2r-cchf2r)+ # cchb3r*cchb3r+(cchb4r-cchf4r)*(cchb4r-cchf4r)+ # cchb5r*cchb5r+cchb6r*cchb6r+cchb7r*cchb7r+cchb8r*cchb8r dthie= cchb1ie*cchb1ie+(cchb2ie-cchf2ie)*(cchb2ie-cchf2ie)+ # cchb3ie*cchb3ie+(cchb4ie-cchf4ie)*(cchb4ie-cchf4ie)+ # cchb5ie*cchb5ie+cchb6ie*cchb6ie+cchb7ie*cchb7ie+ # cchb8ie*cchb8ie dthre= cchb1re*cchb1re+(cchb2re-cchf2re)*(cchb2re-cchf2re)+ # cchb3re*cchb3re+(cchb4re-cchf4re)*(cchb4re-cchf4re)+ # cchb5re*cchb5re+cchb6re*cchb6re+cchb7re*cchb7re+ # cchb8re*cchb8re dthi= cchb1i*cchb1i+(cchb2i-cchf2i)*(cchb2i-cchf2i)+ # cchb3i*cchb3i+(cchb4i-cchf4i)*(cchb4i-cchf4i)+ # cchb5i*cchb5i+cchb6i*cchb6i+cchb7i*cchb7i+cchb8i*cchb8i dth= dthr+dthie+dthre+dthi dth= dthr+dthie+dthre+dthi * 4 if(iz.eq.0) then dpxs(ix,it)= 0.d0 iz= 1 else tjac= ujc*vjc*smjc*spjc*sujc*sdjc* # sfjc*twjc*t1jc*vv dpxs(ix,it)= tjac*stf*dth/s endif * *-----end of ix loop * enddo * cpxs(it)= dpxs(1,it)+dpxs(2,it) * 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 * if(oqcd.eq.'y') then nf= 5 if(omssm.eq.'n') then xhm= hm else if(omssm.eq.'y') then xhm= shm endif alsh= wtoralphas(wm,xhm,als,nf) if(omssm.eq.'n') then fqcd= 1.d0+alsh/pi*(17.d0/3.d0+(35.94d0-1.36d0*nf)* # alsh/pi) else if(omssm.eq.'y') then fqcd= 1.d0+17.d0/3.d0*alsh/pi endif else fqcd= 1.d0 endif * wtoxsh19= tfact*resf*bfact*fqcd * if(om.eq.'g') then if(osm.eq.'n') then jp= iwtopos(ndim,x) if(wtoxsh19.gt.xshmx(jp)) then xshmx(jp)= wtoxsh19 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 * *-----WTOXSH49----------------------------------------------------------- * real*8 function wtoxsh49(ndim,x) implicit real*8 (a-h,o-z) character*1 om,osm,oqcd,omssm * parameter(ninv=10,npos=512) * common/wtmod/om common/wtmp/zrm common/wtqcd/als common/wthiggs/hm common/wtsmod/osm common/wtdis/dist common/wtkount/ik common/wtaqcd/oqcd common/wtbme/bfact common/wtistrf/isf common/wtsf/ix0,it0 common/wtchi/hch(36) common/wtipt/ifz(44) common/wtmssmo/omssm common/wticuts/iac(4) common/wtisa/isaa,isab common/wthx/xshmx(npos) common/wtparh/xaph(ninv) common/wttc/itc,itcc,itcn common/wtpmxh/xmxh(npos,9) 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/wthapar/rhm,rhm2,rhg,rhmg,shg,shgs,opshgs 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 tgn(45) 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),cpxs(2),bpxs(2) dimension rr1(2),rr2(2),rs1(2),rs2(2),rtp(2),rtm(2) * 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 dpxs(ix,it)= 0.d0 enddo enddo do it=1,2 cpxs(it)= 0.d0 bpxs(it)= 0.d0 enddo * if(ndim.eq.6) then spx= x(1) sux= x(2) sdx= x(3) sfx= x(4) twx= x(5) t1x= x(6) else if(ndim.eq.8) then uvx= x(1) vvx= x(2) spx= x(3) sux= x(4) sdx= x(5) sfx= x(6) twx= x(7) t1x= x(8) 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 * if(uvx.gt.1.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif 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.lt.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else if(vkf.eq.0.d0) then if(vvx.gt.1.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else if(vvx.eq.1.d0) then veps= 0.d0 else veps= uvl*(1.d0-vvx)**hbeti endif avkf= 1.d0 else veps= uvl*(1.d0-(1.d0-vkf**hbet)*vvx)**hbeti avkf= 1.d0-vkf**hbet endif vv= uv-veps vjc0= 1.d0-vvll/uv if(vjc0.le.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 else vjc= vjc0**hbet*avkf endif endif * if(vv.lt.0.d0) then iz= 0 ifz(1)= ifz(1)+1 go to 1 endif svv= sqrt(vv) vzmg= rzmg*vv vhmg= rhmg*vv vshmg= rshmg*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 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 * *-----test on sm * if(zmb.le.zma) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif * if(itc.eq.4) then bdistl= dist*dist/s-zma bdistu= zmb-dist*dist/s if(bdistl.le.0.d0.or.bdistu.le.0.d0) then iz= 0 ifz(4)= ifz(4)+1 go to 1 endif endif * if(omssm.eq.'n') then xrhm2= rhm2 xshg= shg xshgs= shgs xrhmg= rhmg xvhmg= vhmg xopshgs= opshgs else if(omssm.eq.'y') then xrhm2= rshm2 xshg= sshg xshgs= sshgs xrhmg= rshmg xvhmg= vshmg xopshgs= opsshgs endif if(itc.eq.4) then sm= (dist/rs/svv)**2 smjc= 2.d0*dist/s/((vv*sm-xrhm2)**2+ # (vv*sm*xshg)**2) else * zmas= zma-xrhm2 zmbs= zmb-xrhm2 atma= (zmas+xshgs*zma)/xrhmg atmb= (zmbs+xshgs*zmb)/xrhmg if(atma.gt.1.d0.and.atmb.gt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/xvhmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/xvhmg smjc0= (-atmb+atma)/xvhmg else if(atma.gt.1.d0.and.atmb.lt.-1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/xvhmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/xvhmg smjc0= (-pi+atmb+atma)/xvhmg else if(atma.gt.1.d0.and.abs(atmb).lt.1.d0) then atma= 1.d0/atma atma= atan(atma) zmat= (pih-atma)/xvhmg atmb= atan(atmb) zmbt= atmb/xvhmg smjc0= (-pih+atmb+atma)/xvhmg else if(atma.lt.-1.d0.and.atmb.gt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/xvhmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/xvhmg smjc0= (pi-atmb-atma)/xvhmg else if(atma.lt.-1.d0.and.atmb.lt.-1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/xvhmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/xvhmg smjc0= (atmb-atma)/xvhmg else if(atma.lt.-1.d0.and.abs(atmb).lt.1.d0) then atma= -1.d0/atma atma= atan(atma) zmat= (-pih+atma)/xvhmg atmb= atan(atmb) zmbt= atmb/xvhmg smjc0= (pih+atmb-atma)/xvhmg else if(abs(atma).lt.1.d0.and.atmb.gt.1.d0) then atma= atan(atma) zmat= atma/xvhmg atmb= 1.d0/atmb atmb= atan(atmb) zmbt= (pih-atmb)/xvhmg smjc0= (pih-atmb-atma)/xvhmg else if(abs(atma).lt.1.d0.and.atmb.lt.-1.d0) then atma= atan(atma) zmat= atma/xvhmg atmb= -1.d0/atmb atmb= atan(atmb) zmbt= (-pih+atmb)/xvhmg smjc0= (-pih+atmb-atma)/xvhmg else if(abs(atma).lt.1.d0.and.abs(atmb).lt.1.d0) then atma= atan(atma) zmat= atma/xvhmg atmb= atan(atmb) zmbt= atmb/xvhmg smjc0= (atmb-atma)/xvhmg endif * zmv= smjc0*smx+zmat iftn= 1 atnm= xvhmg*zmv sm= xrhm2/xopshgs/vv*(1.d0+xshg*s07aaf(atnm,iftn)) if(iftn.ne.0) print 300 smjc= vv*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) * *-----test on sp * if(zpb.le.zpa) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif * 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 if(sp.lt.0.d0) then iz= 0 ifz(5)= ifz(5)+1 go to 1 endif ssp= sqrt(sp) spjc= vv*spjc0 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 * smtp= sm*sp 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) * *-----test on su * if(suu.le.sul) then iz= 0 ifz(8)= ifz(8)+1 go to 1 endif * sujc= suu-sul su= sujc*sux+sul 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 * 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) * *-----test on sd * if(sdu.le.sdl) then iz= 0 ifz(9)= ifz(9)+1 go to 1 endif * sdjc= sdu-sdl sd= sdjc*sdx+sdl 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 * *-----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 * *-----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(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_wu * *-----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 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= 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 * tgn(1)= x14/x25/x36 tgn(2)= x14*x25*x36 tgn(3)= x24/x15/x36 tgn(4)= x15*x24*x36 tgn(5)= x14/x24/x34/x45*x46 tgn(6)= x14/x24/x34*x45/x46 tgn(7)= x14/x24*x34/x45*x46 tgn(8)= x14/x24*x34*x45/x46 tgn(9)= x14*x24/x34/x45*x46 tgn(10)= x14*x24/x34*x45/x46 tgn(11)= x45*x46/x15/x25/x34 tgn(12)= x45/x15/x25/x34/x46 tgn(13)= x34*x45/x15/x25/x46 tgn(14)= x25*x46/x15/x34/x45 tgn(15)= x25*x45/x15/x34/x46 tgn(16)= x15/x25/x34*x45/x46 tgn(17)= x25/x15/x34*x45*x46 tgn(18)= x25*x34*x45/x46/x15 tgn(19)= x15/x25/x34*x45*x46 tgn(20)= x15/x25*x34*x45/x46 tgn(21)= x15*x25*x34/x45*x46 tgn(22)= x34/x15/x25/x45/x46 tgn(23)= x15/x25*x34/x45*x46 tgn(24)= x34/x14/x24*x45/x46 tgn(25)= x14/x24*x34/x45/x46 tgn(26)= x24/x14*x34*x45/x46 tgn(27)= x14*x24*x34/x45/x46 tgn(28)= x34/x14/x24*x45*x46 tgn(29)= x15/x24/x36 tgn(30)= 1.d0/x14/x25/x36 tgn(31)= x14/x25*x36 tgn(32)= 1.d0/x15/x24/x36 tgn(33)= 1.d0/x14/x15/x24/x25 tgn(34)= 1.d0/x14*x25/x36 tgn(35)= x15*x24/x36 tgn(36)= x14*x25/x36 tgn(37)= 1.d0/x14*x15*x24/x25 tgn(38)= x14/x15/x24*x25 tgn(39)= 1.d0/x24/x25*x34/x36/x45/x46 tgn(40)= x24/x25*x34/x36/x45/x46 tgn(41)= 1.d0/x24*x25*x34/x36/x45*x46 tgn(42)= 1.d0/x14/x24*x34/x45*x46 tgn(43)= 1.d0/x14*x24*x34/x45*x46 tgn(44)= 1.d0/x24/x25*x34/x36*x45/x46 tgn(45)= x36/x15/x24 * itgn= 0 do l=1,45 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 * gh1= sqrt(tgn(1)) gh2= sqrt(tgn(2)) gh3= sqrt(tgn(3)) gh4= sqrt(tgn(4)) gh5= sqrt(tgn(5)) gh6= sqrt(tgn(6)) gh7= sqrt(tgn(7)) gh8= sqrt(tgn(8)) gh9= sqrt(tgn(9)) gh10= sqrt(tgn(10)) gh11= sqrt(tgn(11)) gh12= sqrt(tgn(12)) gh13= sqrt(tgn(13)) gh14= sqrt(tgn(14)) gh15= sqrt(tgn(15)) gh16= sqrt(tgn(16)) gh17= sqrt(tgn(17)) gh18= sqrt(tgn(18)) gh19= sqrt(tgn(19)) gh20= sqrt(tgn(20)) gh21= sqrt(tgn(21)) gh22= sqrt(tgn(22)) gh23= sqrt(tgn(23)) gh24= sqrt(tgn(24)) gh25= sqrt(tgn(25)) gh26= sqrt(tgn(26)) gh27= sqrt(tgn(27)) gh28= sqrt(tgn(28)) gh29= sqrt(tgn(29)) gh30= sqrt(tgn(30)) gh31= sqrt(tgn(31)) gh32= sqrt(tgn(32)) gh33= sqrt(tgn(33)) gh34= sqrt(tgn(34)) gh35= sqrt(tgn(35)) gh36= sqrt(tgn(36)) gh37= sqrt(tgn(37)) gh38= sqrt(tgn(38)) gh39= sqrt(tgn(39)) gh40= sqrt(tgn(40)) gh41= sqrt(tgn(41)) gh42= sqrt(tgn(42)) gh43= sqrt(tgn(43)) gh44= sqrt(tgn(44)) gh45= sqrt(tgn(45)) * x45i= 1.d0/x45 * *-----Helicity he1-2) * *-----Higgs Bremsstrahlung diagram: * hb12r= 4.d0*(gh7*x25+gh26*x16-gh27*x56- # gh28) hb12i= 16.d0*(-s5*gh24+s14*gh25) hb1r= 4.d0*hch(7)*hb12r hb1i= 4.d0*hch(7)*hb12i hb2r= 4.d0*hch(8)*hb12r hb2i= -4.d0*hch(8)*hb12i * *-----Higgs Fusion diagram: * hf12cr= 4.d0*(-gh7*x25-gh26*x16+gh27*x56+gh28) hf12ci= 16.d0*(s5*gh24-s14*gh25) hf1r= 0.25d0*ver*ver*hf12cr hf1i= 0.25d0*ver*ver*hf12ci hf2r= 0.25d0*vel*vel*hf12cr hf2i= -0.25d0*vel*vel*hf12ci * *-----Helicity he3-4) * *-----Higgs Bremsstrahlung diagram: * hb34r= 4.d0*(-gh4+gh29*(x23*x46-x26*x34)) hb34i= -16.d0*s12*gh29 hb3r= 4.d0*hch(7)*hb34r hb3i= 4.d0*hch(7)*hb34i hb4r= 4.d0*hch(8)*hb34r hb4i= -4.d0*hch(8)*hb34i * *-----Higgs Fusion diagram: * hf34r= 4.d0*(gh4+gh29*(-x23*x46+x26*x34)) hf34i= 16.d0*s12*gh29 hf3r= 0.25d0*ver*ver*hf34r hf3i= 0.25d0*ver*ver*hf34i hf4r= 0.25d0*vel*vel*hf34r hf4i= -0.25d0*vel*vel*hf34i * *-----Helicity he5-6) * *-----Higgs Bremsstrahlung diagram: * hb56r= 4.d0*(-gh13*x16*x25+gh22*x14*x25*x56- # gh23*x25) hb56i= 16.d0*s10*gh22*x25 hb5r= 4.d0*hch(5)*hb56r hb5i= 4.d0*hch(5)*hb56i hb6r= 4.d0*hch(6)*hb56r hb6i= -4.d0*hch(6)*hb56i * *-----Helicity he7-8) * *-----Higgs Bremsstrahlung diagram: * hb78r= 4.d0*(gh30*(x13*x25*x46-x16*x25*x34)- # gh31*x25) hb78i= 16.d0*s8*gh30*x25 hb7r= 4.d0*hch(5)*hb78r hb7i= 4.d0*hch(5)*hb78i hb8r= 4.d0*hch(6)*hb78r hb8i= -4.d0*hch(6)*hb78i * *-----Helicity he9-10) * *-----Higgs Fusion diagram: * hf910r= 2.d0*(gh3*(x13*x56-x16*x35)-gh4+gh29*(-x23*x46+x26*x34)+ # 2.d0*gh32*x45i*x14*x25*(x34*x56-x35*x46)+gh32*(x13*x25*x46- # x13*x26*x45-x14*x23*x56+x14*x26*x35+x16*x23*x45-x16*x25*x34- # x34*x56+x35*x46)+2.d0*gh35*x45i*(-x34*x56+x35*x46)+gh45*(x14* # x25-x45)) hf910i= 8.d0*(s2*gh32*x46+2.d0*s4*gh32*x45i*(x34*x56-x35*x46)+ # s4*gh45+s6*gh32*x34+s8*gh32*x25-s12*gh29-s15*gh32) hf9r= 0.25d0*ver*vel*hf910r hf9i= 0.25d0*ver*vel*hf910i hf10r= 0.25d0*ver*vel*hf910r hf10i= -0.25d0*ver*vel*hf910i * *-----Helicity he11-12) * *-----Higgs Fusion diagram: * hf1112r= 4.d0*(gh7*x25-gh8*x26+gh26*x16-gh43*x15) hf1112i= 16.d0*(s4*gh42-s5*gh24) hf11r= 0.25*ver*vel*hf1112r hf11i= 0.25*ver*vel*hf1112i hf12r= 0.25*ver*vel*hf1112r hf12i= -0.25*ver*vel*hf1112i * *-----compensating single Z propagator * wpcfr= sp-rzm2/vv wpcfi= sp*szg * *-----extra propagators *s vrzm2= rzm2/vv x25z= x25+vrzm2 x16z= x16+vrzm2 * *-----complete diagrams: * hbcf= sqrt(rbqm2/vv)/8.d0/cth4 hfcf= sqrt(rbqm2/vv)/cth4/8.d0/x16z/x25z if(omssm.eq.'y') then hbcf= -hbcf*sbma*salpha/cbeta hfcf= -hfcf*sbma*salpha/cbeta alpha1= -salpha/cbeta*sbma alpha2= calpha/cbeta*cbma alpha21= alpha2/alpha1 propm= (sm-rbhm2/vv)*(sm-rbhm2/vv)+(sm*sbhg)**2 addmr= 1.d0+alpha21/propm*((sm-rshm2/vv)*(sm-rbhm2/vv)+ # sm*sm*sbhg*sshg) addmi= alpha21/propm*sm*((sm-rshm2/vv)*sbhg-(sm-rbhm2/vv)*sshg) else if(omssm.eq.'n') then addmr= 1.d0 addmi= 0.d0 endif * chb1r= hbcf*rsz*hb1r chb1re= -hbcf*aisz*hb1i chb1ie= hbcf*rsz*hb1i chb1i= hbcf*aisz*hb1r * chb2r= hbcf*rsz*hb2r chb2re= -hbcf*aisz*hb2i chb2ie= hbcf*rsz*hb2i chb2i= hbcf*aisz*hb2r * chb3r= hbcf*rsz*hb3r chb3re= -hbcf*aisz*hb3i chb3ie= hbcf*rsz*hb3i chb3i= hbcf*aisz*hb3r * chb4r= hbcf*rsz*hb4r chb4re= -hbcf*aisz*hb4i chb4ie= hbcf*rsz*hb4i chb4i= hbcf*aisz*hb4r * chb5r= hbcf*rsz*hb5r chb5re= -hbcf*aisz*hb5i chb5ie= hbcf*rsz*hb5i chb5i= hbcf*aisz*hb5r * chb6r= hbcf*rsz*hb6r chb6re= -hbcf*aisz*hb6i chb6ie= hbcf*rsz*hb6i chb6i= hbcf*aisz*hb6r * chb7r= hbcf*rsz*hb7r chb7re= -hbcf*aisz*hb7i chb7ie= hbcf*rsz*hb7i chb7i= hbcf*aisz*hb7r * chb8r= hbcf*rsz*hb8r chb8re= -hbcf*aisz*hb8i chb8ie= hbcf*rsz*hb8i chb8i= hbcf*aisz*hb8r * chf1r= hfcf*wpcfr*hf1r chf1re= -hfcf*wpcfi*hf1i chf1ie= hfcf*wpcfr*hf1i chf1i= hfcf*wpcfi*hf1r * chf2r= hfcf*wpcfr*hf2r chf2re= -hfcf*wpcfi*hf2i chf2ie= hfcf*wpcfr*hf2i chf2i= hfcf*wpcfi*hf2r * chf3r= hfcf*wpcfr*hf3r chf3re= -hfcf*wpcfi*hf3i chf3ie= hfcf*wpcfr*hf3i chf3i= hfcf*wpcfi*hf3r * chf4r= hfcf*wpcfr*hf4r chf4re= -hfcf*wpcfi*hf4i chf4ie= hfcf*wpcfr*hf4i chf4i= hfcf*wpcfi*hf4r * chf9r= hfcf*wpcfr*hf9r chf9re= -hfcf*wpcfi*hf9i chf9ie= hfcf*wpcfr*hf9i chf9i= hfcf*wpcfi*hf9r * chf10r= hfcf*wpcfr*hf10r chf10re= -hfcf*wpcfi*hf10i chf10ie= hfcf*wpcfr*hf10i chf10i= hfcf*wpcfi*hf10r * chf11r= hfcf*wpcfr*hf11r chf11re= -hfcf*wpcfi*hf11i chf11ie= hfcf*wpcfr*hf11i chf11i= hfcf*wpcfi*hf11r * chf12r= hfcf*wpcfr*hf12r chf12re= -hfcf*wpcfi*hf12i chf12ie= hfcf*wpcfr*hf12i chf12i= hfcf*wpcfi*hf12r * dhb1r= addmr*chb1r-addmi*chb1i dhb1re= addmr*chb1re-addmi*chb1ie dhb1ie= addmr*chb1ie+addmi*chb1re dhb1i= addmr*chb1i+addmi*chb1r dhb2r= addmr*chb2r-addmi*chb2i dhb2re= addmr*chb2re-addmi*chb2ie dhb2ie= addmr*chb2ie+addmi*chb2re dhb2i= addmr*chb2i+addmi*chb2r dhb3r= addmr*chb3r-addmi*chb3i dhb3re= addmr*chb3re-addmi*chb3ie dhb3ie= addmr*chb3ie+addmi*chb3re dhb3i= addmr*chb3i+addmi*chb3r dhb4r= addmr*chb4r-addmi*chb4i dhb4re= addmr*chb4re-addmi*chb4ie dhb4ie= addmr*chb4ie+addmi*chb4re dhb4i= addmr*chb4i+addmi*chb4r dhb5r= addmr*chb5r-addmi*chb5i dhb5re= addmr*chb5re-addmi*chb5ie dhb5ie= addmr*chb5ie+addmi*chb5re dhb5i= addmr*chb5i+addmi*chb5r dhb6r= addmr*chb6r-addmi*chb6i dhb6re= addmr*chb6re-addmi*chb6ie dhb6ie= addmr*chb6ie+addmi*chb6re dhb6i= addmr*chb6i+addmi*chb6r dhb7r= addmr*chb7r-addmi*chb7i dhb7re= addmr*chb7re-addmi*chb7ie dhb7ie= addmr*chb7ie+addmi*chb7re dhb7i= addmr*chb7i+addmi*chb7r dhb8r= addmr*chb8r-addmi*chb8i dhb8re= addmr*chb8re-addmi*chb8ie dhb8ie= addmr*chb8ie+addmi*chb8re dhb8i= addmr*chb8i+addmi*chb8r dhf1r= addmr*chf1r-addmi*chf1i dhf1re= addmr*chf1re-addmi*chf1ie dhf1ie= addmr*chf1ie+addmi*chf1re dhf1i= addmr*chf1i+addmi*chf1r dhf2r= addmr*chf2r-addmi*chf2i dhf2re= addmr*chf2re-addmi*chf2ie dhf2ie= addmr*chf2ie+addmi*chf2re dhf2i= addmr*chf2i+addmi*chf2r dhf3r= addmr*chf3r-addmi*chf3i dhf3re= addmr*chf3re-addmi*chf3ie dhf3ie= addmr*chf3ie+addmi*chf3re dhf3i= addmr*chf3i+addmi*chf3r dhf4r= addmr*chf4r-addmi*chf4i dhf4re= addmr*chf4re-addmi*chf4ie dhf4ie= addmr*chf4ie+addmi*chf4re dhf4i= addmr*chf4i+addmi*chf4r dhf9r= addmr*chf9r-addmi*chf9i dhf9re= addmr*chf9re-addmi*chf9ie dhf9ie= addmr*chf9ie+addmi*chf9re dhf9i= addmr*chf9i+addmi*chf9r dhf10r= addmr*chf10r-addmi*chf10i dhf10re= addmr*chf10re-addmi*chf10ie dhf10ie= addmr*chf10ie+addmi*chf10re dhf10i= addmr*chf10i+addmi*chf10r dhf11r= addmr*chf11r-addmi*chf11i dhf11re= addmr*chf11re-addmi*chf11ie dhf11ie= addmr*chf11ie+addmi*chf11re dhf11i= addmr*chf11i+addmi*chf11r dhf12r= addmr*chf12r-addmi*chf12i dhf12re= addmr*chf12re-addmi*chf12ie dhf12ie= addmr*chf12ie+addmi*chf12re dhf12i= addmr*chf12i+addmi*chf12r * *-----Total * dthr= (dhb1r-dhf1r)*(dhb1r-dhf1r)+ # (dhb2r-dhf2r)*(dhb2r-dhf2r)+ # (dhb3r-dhf3r)*(dhb3r-dhf3r)+ # (dhb4r-dhf4r)*(dhb4r-dhf4r)+ # dhb5r*dhb5r+dhb6r*dhb6r+dhb7r*dhb7r+dhb8r*dhb8r+ # dhf9r*dhf9r+dhf10r*dhf10r+ # dhf11r*dhf11r+dhf12r*dhf12r * dthie= (dhb1ie-dhf1ie)*(dhb1ie-dhf1ie)+ # (dhb2ie-dhf2ie)*(dhb2ie-dhf2ie)+ # (dhb3ie-dhf3ie)*(dhb3ie-dhf3ie)+ # (dhb4ie-dhf4ie)*(dhb4ie-dhf4ie)+ # dhb5ie*dhb5ie+dhb6ie*dhb6ie+ # dhb7ie*dhb7ie+dhb8ie*dhb8ie+ # dhf9ie*dhf9ie+dhf10ie*dhf10ie+ # dhf11ie*dhf11ie+dhf12ie*dhf12ie * dthre= (dhb1re-dhf1re)*(dhb1re-dhf1re)+ # (dhb2re-dhf2re)*(dhb2re-dhf2re)+ # (dhb3re-dhf3re)*(dhb3re-dhf3re)+ # (dhb4re-dhf4re)*(dhb4re-dhf4re)+ # dhb5re*dhb5re+dhb6re*dhb6re+ # dhb7re*dhb7re+dhb8re*dhb8re+ # dhf9re*dhf9re+dhf10re*dhf10re+ # dhf11re*dhf11re+dhf12re*dhf12re * dthi= (dhb1i-dhf1i)*(dhb1i-dhf1i)+ # (dhb2i-dhf2i)*(dhb2i-dhf2i)+ # (dhb3i-dhf3i)*(dhb3i-dhf3i)+ # (dhb4i-dhf4i)*(dhb4i-dhf4i)+ # dhb5i*dhb5i+dhb6i*dhb6i+dhb7i*dhb7i+dhb8i*dhb8i+ # dhf9i*dhf9i+dhf10i*dhf10i+ # dhf11i*dhf11i+dhf12i*dhf12i * dth= dthr+dthie+dthre+dthi * 4 if(iz.eq.0) then dpxs(ix,it)= 0.d0 iz= 1 else tjac= ujc*vjc*smjc*spjc*sujc*sdjc* # sfjc*twjc*t1jc*vv dpxs(ix,it)= tjac*stf*dth/s endif * *-----end of ix loop * enddo * cpxs(it)= dpxs(1,it)+dpxs(2,it) * 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 * if(oqcd.eq.'y') then nf= 5 if(omssm.eq.'n') then xhm= hm else if(omssm.eq.'y') then xhm= shm endif alsh= wtoralphas(wm,xhm,als,nf) if(omssm.eq.'n') then fqcd= 1.d0+alsh/pi*(5.67d0+(35.94d0-1.36d0*nf)*alsh/pi) else if(omssm.eq.'y') then fqcd= 1.d0+17.d0/3.d0*alsh/pi endif else fqcd= 1.d0 endif * wtoxsh49= tfact*resf*bfact*fqcd * if(om.eq.'g') then if(osm.eq.'n') then jp= iwtopos(ndim,x) if(wtoxsh49.gt.xshmx(jp)) then xshmx(jp)= wtoxsh49 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