File indexing completed on 2024-04-06 12:14:05
0001
0002 function ffsigiut(xx1,xx2,jpp,je1,je2)
0003
0004
0005
0006
0007
0008 common /ar3/ x1(7),a1(7)
0009 include 'epos.incsem'
0010 include 'epos.inc'
0011 double precision tmin,tmax,t,sh2,sqrtq2s
0012
0013 ig=3
0014 s=engy**2
0015 sh=s*xx1*xx2
0016 ffsigiut=0.
0017 if(sh.le.4.*q2min)return
0018 sh2=dble(sh/2.)
0019
0020 sqrtq2s=sqrt(dble(q2min*sh))
0021 tmin=sh2-sqrt((sh2-sqrtq2s)*(sh2+sqrtq2s))
0022 tmax=sh2
0023 do i=1,ig
0024 do m=1,2
0025 t=2d0*tmin/(1d0+tmin/tmax-dble(tgss(ig,i)*(2*m-3))
0026 & *(1d0-tmin/tmax))
0027 qq=sngl(t*(1d0-t/dble(sh)))
0028 ft=ffsigj(sngl(t),qq,xx1,xx2,jpp,je1,je2)/sh**3
0029 * * (2*pi*pssalf(qq/qcdlam))**2
0030 ffsigiut=ffsigiut+wgss(ig,i)*ft*sngl(t)**2
0031 enddo
0032 enddo
0033 ffsigiut=ffsigiut
0034 * *0.5*sngl(1d0/tmin-1d0/tmax)
0035 * *2*pi*s
0036 * /2 !CS for parton pair
0037 return
0038 end
0039
0040
0041 function ffsigj(t,qt,x1,x2,jpp,je1,je2)
0042
0043
0044
0045
0046
0047
0048
0049
0050
0051
0052
0053
0054
0055
0056
0057
0058
0059
0060
0061
0062
0063
0064
0065
0066
0067 include 'epos.incsem'
0068 include 'epos.inc'
0069
0070 s=engy**2*x1*x2
0071
0072 if(jpp.ne.5)then
0073 ji1=mod(jpp+1,2)+1
0074 ji2=(jpp+1)/2
0075 sea1=pifpartone(x1,qt,-1,je1,ji1)
0076 g1= pifpartone(x1,qt, 0,je1,ji1)
0077 uv1= pifpartone(x1,qt, 1,je1,ji1)
0078 dv1= pifpartone(x1,qt, 2,je1,ji1)
0079 sea2=pifpartone(x2,qt,-1,je2,ji2)
0080 g2= pifpartone(x2,qt, 0,je2,ji2)
0081 uv2= pifpartone(x2,qt, 1,je2,ji2)
0082 dv2= pifpartone(x2,qt, 2,je2,ji2)
0083 else
0084 sea1=pifpartone(x1,qt,-1,je1,1)+pifpartone(x1,qt,-1,je1,2)
0085 g1= pifpartone(x1,qt, 0,je1,1)+pifpartone(x1,qt, 0,je1,2)
0086 uv1= pifpartone(x1,qt, 1,je1,1)+pifpartone(x1,qt, 1,je1,2)
0087 dv1= pifpartone(x1,qt, 2,je1,1)+pifpartone(x1,qt, 2,je1,2)
0088 sea2=pifpartone(x2,qt,-1,je2,1)+pifpartone(x2,qt,-1,je2,2)
0089 g2= pifpartone(x2,qt, 0,je2,1)+pifpartone(x2,qt, 0,je2,2)
0090 uv2= pifpartone(x2,qt, 1,je2,1)+pifpartone(x2,qt, 1,je2,2)
0091 dv2= pifpartone(x2,qt, 2,je2,1)+pifpartone(x2,qt, 2,je2,2)
0092 endif
0093
0094 ffsigj= ffborn(s,t, g1*g2 !gg
0095
0096 * ,(uv1+dv1+2.*naflav*sea1)*g2+g1*(uv2+dv2+2.*naflav*sea2) !gq
0097
0098 * ,(uv1+sea1)*(uv2+sea2) !qq
0099 * +(dv1+sea1)*(dv2+sea2)+sea1*sea2*(naflav-1)*2.
0100
0101 * ,(uv1+sea1)*sea2+(uv2+sea2)*sea1 !qa
0102 * +(dv1+sea1)*sea2+(dv2+sea2)*sea1+sea1*sea2*(naflav-2)*2.
0103
0104 * ,dv1*uv2+dv2*uv1+(uv2+dv2)*sea1*(naflav-1)*2. !qqp
0105 * +(uv1+dv1)*sea2*(naflav-1)*2.
0106 * +sea1*sea2*naflav*(naflav-1)*4.
0107
0108 *)
0109 end
0110
0111
0112 function ffsig(t,qt,x1,x2) !former psjy
0113
0114 include 'epos.incsem'
0115 include 'epos.inc'
0116
0117 s=engy**2*x1*x2
0118
0119 g1= pifpartone(x1,qt, 0,2,1)+pifpartone(x1,qt, 0,2,2)
0120 uv1= pifpartone(x1,qt, 1,2,1)+pifpartone(x1,qt, 1,2,2)
0121 dv1= pifpartone(x1,qt, 2,2,1)+pifpartone(x1,qt, 2,2,2)
0122 sea1=pifpartone(x1,qt,-1,2,1)+pifpartone(x1,qt,-1,2,2)
0123 g2= pifpartone(x2,qt, 0,2,1)+pifpartone(x2,qt, 0,2,2)
0124 uv2= pifpartone(x2,qt, 1,2,1)+pifpartone(x2,qt, 1,2,2)
0125 dv2= pifpartone(x2,qt, 2,2,1)+pifpartone(x2,qt, 2,2,2)
0126 sea2=pifpartone(x2,qt,-1,2,1)+pifpartone(x2,qt,-1,2,2)
0127
0128 ffsig= ffborn(s,t, g1*g2 !gg
0129
0130 * ,(uv1+dv1+2.*naflav*sea1)*g2+g1*(uv2+dv2+2.*naflav*sea2) !gq
0131
0132 * ,(uv1+sea1)*(uv2+sea2) !qq
0133 * +(dv1+sea1)*(dv2+sea2)+sea1*sea2*(naflav-1)*2.
0134
0135 * ,(uv1+sea1)*sea2+(uv2+sea2)*sea1 !qa
0136 * +(dv1+sea1)*sea2+(dv2+sea2)*sea1+sea1*sea2*(naflav-2)*2.
0137
0138 * ,dv1*uv2+dv2*uv1+(uv2+dv2)*sea1*(naflav-1)*2. !qqp
0139 * +(uv1+dv1)*sea2*(naflav-1)*2.
0140 * +sea1*sea2*naflav*(naflav-1)*4.
0141
0142 *)
0143 end
0144
0145
0146 function ffborn(s,t,gg,gq,qq,qa,qqp)
0147
0148
0149 ffborn=
0150 *( psbori(s,t,0,0,1)+psbori(s,s-t,0,0,1)
0151 * +psbori(s,t,0,0,2)+psbori(s,s-t,0,0,2)) /2. *gg !gg
0152
0153 *+(psbori(s,t,0,1,1)+psbori(s,s-t,0,1,1)) *gq !gq
0154
0155 *+(psbori(s,t,1,1,1)+psbori(s,s-t,1,1,1))/2. *qq !qq
0156
0157 *+(psbori(s,t,1,-1,1)+psbori(s,s-t,1,-1,1)+psbori(s,t,1,-1,2)+
0158 * psbori(s,s-t,1,-1,2)+psbori(s,t,1,-1,3)+psbori(s,s-t,1,-1,3)) !qa
0159 * *qa
0160
0161 *+(psbori(s,t,1,2,1)+psbori(s,s-t,1,2,1)) *qqp !qq'
0162
0163 end
0164
0165 c-----------------------------------------------------------------------
0166 function pifpartone(xx,qq,j,je,ji) ! pol interpolation of partone
0167 c-----------------------------------------------------------------------
0168 include 'epos.incsem'
0169 include 'epos.inc'
0170 common/tabfptn/kxxmax,kqqmax,fptn(20,20,-1:2,0:2,2)
0171 real wi(3),wj(3)
0172 common /cpifpartone/npifpartone
0173 data npifpartone /0/
0174 npifpartone=npifpartone+1
0175 if(npifpartone.eq.1)call MakeFpartonTable
0176
0177 qqmax=engy**2/4.
0178 xxmin=0.01/engy
0179 xxmax=1
0180
0181 xxk=1.+log(xx/xxmin)/log(xxmax/xxmin)*(kxxmax-1)
0182 qqk=1.+log(qq/q2min)/log(qqmax/q2min)*(kqqmax-1)
0183 kxx=int(xxk)
0184 kqq=int(qqk)
0185 if(kxx.lt.1)kxx=1
0186 if(kqq.lt.1)kqq=1
0187 if(kxx.gt.(kxxmax-2))kxx=kxxmax-2
0188 if(kqq.gt.(kqqmax-2))kqq=kqqmax-2
0189
0190 wi(2)=xxk-kxx
0191 wi(3)=wi(2)*(wi(2)-1.)*.5
0192 wi(1)=1.-wi(2)+wi(3)
0193 wi(2)=wi(2)-2.*wi(3)
0194
0195 wj(2)=qqk-kqq
0196 wj(3)=wj(2)*(wj(2)-1.)*.5
0197 wj(1)=1.-wj(2)+wj(3)
0198 wj(2)=wj(2)-2.*wj(3)
0199 pifpartone=0
0200 do kx=1,3
0201 do kq=1,3
0202 pifpartone=pifpartone+fptn(kxx+kx-1,kqq+kq-1,j,je,ji)
0203 * *wi(kx)*wj(kq)
0204 enddo
0205 enddo
0206 end
0207
0208 c-----------------------------------------------------------------------
0209 subroutine MakeFpartonTable
0210 c-----------------------------------------------------------------------
0211 include 'epos.incsem'
0212 include 'epos.inc'
0213 common/tabfptn/kxxmax,kqqmax,fptn(20,20,-1:2,0:2,2)
0214 write (*,'(a,$)')'(Fparton table'
0215 kxxmax=10
0216 kqqmax=10
0217 qqmax=engy**2/4.
0218 xxmin=0.01/engy
0219 xxmax=1
0220 do ji=1,2
0221 do je=0,2
0222 write(*,'(a,$)')'.'
0223 do j=-1,2
0224 do kxx=1,kxxmax
0225 xx=xxmin*(xxmax/xxmin)**((kxx-1.)/(kxxmax-1.))
0226 do kqq=1,kqqmax
0227 qq=q2min*(qqmax/q2min)**((kqq-1.)/(kqqmax-1.))
0228 fptn(kxx,kqq,j,je,ji)= fpartone(xx,qq,j,je,ji)
0229 enddo
0230 enddo
0231 enddo
0232 enddo
0233 enddo
0234 write (*,'(a,$)')'done)'
0235 end
0236
0237 c------------------------------------------------------------------------
0238 function fpartone(xx,qq,j,je,ji) !former pspdf0 (sha)
0239 c-----------------------------------------------------------------------
0240 c
0241 c parton distribution function for proton ( actually x*f(x) !!!!!!! )
0242 c
0243 c xx = light cone momentum fraction
0244 c qq = virtuality scale
0245 c j = parton type
0246 c -1 ... sea (distribution function per flavor)
0247 c 0 ... g
0248 c 1 ... u
0249 c 2 ... d
0250 c je = emission type
0251 c 0 ... no emissions
0252 c 1 ... emissions
0253 c 2 ... all
0254 c ji = initial parton type
0255 c 1 ... sea (q et g)
0256 c 2 ... val
0257 c-----------------------------------------------------------------------
0258 double precision z,xmin,xm,zx,psuds
0259 common/ar3/ x1(7),a1(7)
0260 include 'epos.inc'
0261 include 'epos.incsem'
0262
0263 fpartone=0
0264 if(je.eq.1)goto888
0265
0266 c ...... f_0 * sudakov.........
0267
0268 if(j.eq.0.and.ji.eq.1)then
0269 fpartone=fzeroGlu(xx,2,1) !hadron class 2, projectile side
0270 elseif((j.eq.1.or.j.eq.2).and.ji.eq.2)then
0271 fpartone=psdfh4(xx,q2min,0.,2,j)
0272 elseif(j.eq.-1.and.ji.eq.1)then
0273 fpartone=fzeroSea(xx,2,1)
0274 endif
0275 fpartone=fpartone*sngl(psuds(qq,j)/psuds(q2min,j))
0276 if(je.eq.0)goto999
0277
0278 c......... integral f_0 E_qcd............
0279
0280 888 continue
0281 xmin=dble(xx)/(1.d0-dble(q2ini/qq))
0282 if(xmin.lt.1.d0)then
0283 dpd1=0.
0284 dpd2=0.
0285 xm=max(xmin,0.3d0)
0286
0287 !numerical integration xm -> 1
0288
0289 do i=1,7
0290 do m=1,2
0291 zx=1.d0-(1.d0-xm)*(.5d0+(dble(m)-1.5d0)*dble(x1(i)))**.25d0
0292 z=xx/zx
0293
0294 gl=fzeroGlu(sngl(zx),2,1)
0295 uv=psdfh4(sngl(zx),q2min,0.,2,1)
0296 dv=psdfh4(sngl(zx),q2min,0.,2,2)
0297 sea=fzeroSea(sngl(zx),2,1)
0298
0299 fz=0
0300 if(j.eq.0)then
0301 if(ji.eq.1)
0302 * fz=gl *psevi(q2min,qq,z,1,1)
0303 * +sea*psevi(q2min,qq,z,2,1) !ccccc
0304 if(ji.eq.2)
0305 * fz=(uv+dv)*psevi(q2min,qq,z,2,1)
0306 elseif(j.eq.1.and.ji.eq.2)then
0307 fz=psevi(q2min,qq,z,3,2)*uv
0308 elseif(j.eq.2.and.ji.eq.2)then
0309 fz=psevi(q2min,qq,z,3,2)*dv
0310 elseif(j.eq.-1)then
0311 akns=psevi(q2min,qq,z,3,2) !nonsinglet contribution
0312 aks=(psevi(q2min,qq,z,2,2)-akns) !singlet contribution
0313 if(ji.eq.1)
0314 * fz=psevi(q2min,qq,z,1,2)*gl
0315 * +sea*aks+sea*akns !ccccc
0316 if(ji.eq.2)
0317 * fz=(uv+dv)*aks
0318 endif
0319 dpd1=dpd1+a1(i)*fz/sngl(zx)**2/sngl(1.d0-zx)**3
0320 enddo
0321 enddo
0322 dpd1=dpd1*sngl(1.d0-xm)**4/8.*xx
0323
0324 !numerical integration xmin -> xm
0325
0326 if(xm.gt.xmin)then
0327 do i=1,7
0328 do m=1,2
0329 zx=xx+(xm-xx)
0330 & *((xmin-xx)/(xm-xx))**(.5d0-(dble(m)-1.5d0)*dble(x1(i)))
0331 z=xx/zx
0332
0333 gl=fzeroGlu(sngl(zx),2,1)
0334 uv=psdfh4(sngl(zx),q2min,0.,2,1)
0335 dv=psdfh4(sngl(zx),q2min,0.,2,2)
0336 sea=fzeroSea(sngl(zx),2,1)
0337
0338 fz=0
0339 if(j.eq.0)then
0340 if(ji.eq.1)
0341 * fz=gl *psevi(q2min,qq,z,1,1)
0342 * +sea*psevi(q2min,qq,z,2,1) !ccccc
0343 if(ji.eq.2)
0344 * fz=(uv+dv)*psevi(q2min,qq,z,2,1)
0345 elseif(j.eq.1.and.ji.eq.2)then
0346 fz=psevi(q2min,qq,z,3,2)*uv
0347 elseif(j.eq.2.and.ji.eq.2)then
0348 fz=psevi(q2min,qq,z,3,2)*dv
0349 elseif(j.eq.-1)then
0350 akns=psevi(q2min,qq,z,3,2) !nonsinglet contribution
0351 aks=(psevi(q2min,qq,z,2,2)-akns) !singlet contribution
0352 if(ji.eq.1)
0353 * fz=psevi(q2min,qq,z,1,2)*gl
0354 * +sea*aks+sea*akns !ccccc
0355 if(ji.eq.2)
0356 * fz=(uv+dv)*aks
0357 endif
0358 dpd2=dpd2+a1(i)*fz*sngl((1.d0-xx/zx)/zx)
0359 enddo
0360 enddo
0361 dpd2=dpd2*sngl(log((xm-xx)/(xmin-xx))*.5d0*xx)
0362 endif
0363 fpartone=fpartone+dpd2+dpd1
0364 endif
0365
0366 999 continue
0367 if(j.lt.0)fpartone=fpartone/naflav/2.
0368 return
0369 end
0370
0371 c------------------------------------------------------------------------
0372 function fparton(xx,qq,j) !former pspdf0 (sha)
0373 c-----------------------------------------------------------------------
0374 c
0375 c parton distribution function for proton ( actually x*f(x) !!!!!!! )
0376 c
0377 c xx = light cone momentum fraction
0378 c qq = virtuality scale
0379 c j = parton type
0380 c -1 ... sea (dsistribution fuction per flavor)
0381 c 0 ... g
0382 c 1 ... u
0383 c 2 ... d
0384 c
0385 c-----------------------------------------------------------------------
0386 c (see pages 105 - 107 of our report)
0387 c
0388 c fparton(xx) = xx * f(xx) !!!!!
0389 c
0390 c f_j(xx,qq) = \sum_k \int(xx<x<1) dx/x f0_k(x) Eqcd_k_j(xx/x,qq)
0391 c
0392 c f0_k = fzeroGlu or fzeroSea
0393 c
0394 c Eqcd=E~qcd+delta*sudakov, E~qcd: at least one emission
0395 c
0396 c-----------------------------------------------------------------------
0397 double precision z,xmin,xm,zx,psuds
0398 common/ar3/ x1(7),a1(7)
0399 include 'epos.inc'
0400 include 'epos.incsem'
0401
0402 c ...... f_0 * sudakov.........
0403
0404 if(j.eq.0)then
0405 fparton=fzeroGlu(xx,2,1)
0406 elseif(j.eq.1.or.j.eq.2)then
0407 fparton=psdfh4(xx,q2min,0.,2,j)
0408 else
0409 fparton=fzeroSea(xx,2,1)
0410 endif
0411 fparton=fparton*sngl(psuds(qq,j)/psuds(q2min,j))
0412
0413 c......... integral f_0 E_qcd............
0414
0415 xmin=xx/(1.d0-dble(q2ini/qq))
0416 if(xmin.lt.1.d0)then
0417 dpd1=0.
0418 dpd2=0.
0419 xm=max(xmin,.3d0)
0420
0421 !numerical integration xm -> 1
0422
0423 do i=1,7
0424 do m=1,2
0425 zx=1.d0-(1.d0-xm)*(.5d0+(dble(m)-1.5d0)*dble(x1(i)))**.25d0
0426 z=xx/zx
0427
0428 gl=fzeroGlu(sngl(zx),2,1)
0429 uv=psdfh4(sngl(zx),q2min,0.,2,1)
0430 dv=psdfh4(sngl(zx),q2min,0.,2,2)
0431 sea=fzeroSea(sngl(zx),2,1)
0432
0433 if(j.eq.0)then
0434 fz=psevi(q2min,qq,z,1,1)*gl
0435 * +(uv+dv+sea)*psevi(q2min,qq,z,2,1)
0436 elseif(j.eq.1)then
0437 fz=psevi(q2min,qq,z,3,2)*uv
0438 elseif(j.eq.2)then
0439 fz=psevi(q2min,qq,z,3,2)*dv
0440 else
0441 akns=psevi(q2min,qq,z,3,2) !nonsinglet contribution
0442 aks=(psevi(q2min,qq,z,2,2)-akns) !singlet contribution
0443 fz=(psevi(q2min,qq,z,1,2)*gl+(uv+dv+sea)*aks+sea*akns)
0444 endif
0445 dpd1=dpd1+a1(i)*fz/sngl(zx)**2/sngl(1.d0-zx)**3
0446 enddo
0447 enddo
0448 dpd1=dpd1*sngl((1.d0-xm)**4/8.*xx)
0449
0450 !numerical integration xmin -> xm
0451
0452 if(xm.gt.xmin)then
0453 do i=1,7
0454 do m=1,2
0455 zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))
0456 * **(.5d0-(dble(m)-1.5)*dble(x1(i)))
0457 z=xx/zx
0458
0459 gl=fzeroGlu(sngl(zx),2,1)
0460 uv=psdfh4(sngl(zx),q2min,0.,2,1)
0461 dv=psdfh4(sngl(zx),q2min,0.,2,2)
0462 sea=fzeroSea(sngl(zx),2,1)
0463
0464 if(j.eq.0)then
0465 fz=psevi(q2min,qq,z,1,1)*gl+(uv+dv+sea)*
0466 * psevi(q2min,qq,z,2,1)
0467 elseif(j.eq.1)then
0468 fz=psevi(q2min,qq,z,3,2)*uv
0469 elseif(j.eq.2)then
0470 fz=psevi(q2min,qq,z,3,2)*dv
0471 else
0472 akns=psevi(q2min,qq,z,3,2) !nonsinglet contribution
0473 aks=(psevi(q2min,qq,z,2,2)-akns) !singlet contribution
0474 fz=(psevi(q2min,qq,z,1,2)*gl+(uv+dv+sea)*aks+sea*akns)
0475 endif
0476 dpd2=dpd2+a1(i)*fz*sngl((1.d0-xx/zx)/zx)
0477 enddo
0478 enddo
0479 dpd2=dpd2*sngl(log((xm-xx)/(xmin-xx))*.5d0*xx)
0480 endif
0481 fparton=fparton+dpd2+dpd1
0482 endif
0483 if(j.lt.0)fparton=fparton/naflav/2.
0484 return
0485 end
0486
0487 c------------------------------------------------------------------------
0488 function fzeroGlu(z,k,ipt)
0489 c-----------------------------------------------------------------------
0490 c
0491 c x*f(x)
0492 c
0493 c f = F & EsoftGluon &=convolution
0494 c
0495 c F(x) = alpff(k)*x**betff(ipt)*(1-x)**alplea(k)
0496 c
0497 c EsoftGluon(x) = x**(-1-dels) * EsoftGluonTil(x)
0498 c
0499 c z - light cone x
0500 c k - hadron class
0501 c ipt - 1=proj 2=targ
0502 c-----------------------------------------------------------------------
0503 double precision xpmin,xp
0504 include 'epos.inc'
0505 common /ar3/ x1(7),a1(7)
0506 include 'epos.incsem'
0507
0508 fzeroGlu=0.
0509 xpmin=z
0510 xpmin=xpmin**(1+betff(ipt)+dels)
0511 do i=1,7
0512 do m=1,2
0513 xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
0514 * (1+betff(ipt)+dels))
0515 zz=z/xp
0516 fzeroGlu=fzeroGlu+a1(i)*(1.-xp)**alplea(k)*EsoftGluonTil(zz)
0517 enddo
0518 enddo
0519 fzeroGlu=fzeroGlu*.5*(1.-xpmin)/(1+betff(ipt)+dels)
0520
0521 fzeroGlu=fzeroGlu *alpff(k) *z**(-dels)
0522
0523 end
0524
0525 c------------------------------------------------------------------------
0526 function fzeroSea(z,k,ipt)
0527 c-----------------------------------------------------------------------
0528 c
0529 c x*f(x)
0530 c
0531 c f = F & EsoftQuark &=convolution
0532 c
0533 c F(x) = alpff(k)*x**betff(ipt)*(1-x)**alplea(k)
0534 c
0535 c EsoftQuark(x) = x**(-1-dels) * EsoftQuarkTil(x)
0536 c
0537 c z - light cone x of the quark,
0538 c k - hadron class
0539 c-----------------------------------------------------------------------
0540 double precision xpmin,xp
0541 common /ar3/ x1(7),a1(7)
0542 include 'epos.inc'
0543 include 'epos.incsem'
0544
0545 fzeroSea=0.
0546 xpmin=z
0547 xpmin=xpmin**(1+betff(ipt)+dels)
0548 do i=1,7
0549 do m=1,2
0550 xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
0551 * (1+betff(ipt)+dels))
0552 zz=z/xp
0553 fzeroSea=fzeroSea+a1(i)*(1.-xp)**alplea(k)*EsoftQuarkTil(zz)
0554 enddo
0555 enddo
0556 fzeroSea=fzeroSea*.5*(1.-xpmin)/(1+betff(ipt)+dels)
0557
0558 fzeroSea=fzeroSea *alpff(k) *z**(-dels)
0559
0560 end
0561
0562 c------------------------------------------------------------------------
0563 function EsoftGluonTil(zz)
0564 c-----------------------------------------------------------------------
0565 c EsoftGluon = zz^(-1-dels) * EsoftGluonTil
0566 c-----------------------------------------------------------------------
0567 include 'epos.inc'
0568 include 'epos.incsem'
0569 EsoftGluonTil=gamsoft*(1-glusea)*(1.-zz)**betpom
0570 end
0571
0572 c------------------------------------------------------------------------
0573 function EsoftQuarkTil(zz)
0574 c-----------------------------------------------------------------------
0575 c EsoftQuark = zz^(-1-dels) * EsoftQuarkTil
0576 c-----------------------------------------------------------------------
0577 double precision zmin,z
0578 common /ar3/ x1(7),a1(7)
0579 include 'epos.inc'
0580 include 'epos.incsem'
0581
0582 EsoftQuarkTil=0.
0583 zmin=zz
0584 zmin=zmin**(1.+dels)
0585 do i=1,7
0586 do m=1,2
0587 z=(.5d0*(1.+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))
0588 * **(1.d0/(1.d0+dels))
0589 EsoftQuarkTil=EsoftQuarkTil+a1(i)*max(1.d-5,(1.d0-zz/z))**betpom
0590 * *(z**2+(1.-z)**2)
0591 enddo
0592 enddo
0593 EsoftQuarkTil=EsoftQuarkTil*1.5*(1.d0-zmin)/(1.+dels)
0594 !1.5=naflav/2 at Q0
0595 EsoftQuarkTil=gamsoft*glusea*EsoftQuarkTil
0596
0597 end
0598
0599 c------------------------------------------------------------------------
0600 function EsoftQZero(zz) ! former psftilf
0601 c-----------------------------------------------------------------------
0602 c
0603 c EsoftQuark = EsoftQZero * wsplit * z^(-1-dels) * gamsoft
0604 c
0605 c zz - ratio of the quark and pomeron light cone x (zz=x_G/x_P)
0606 c integration over quark to gluon light cone momentum ratio (z=x/x_G):
0607 c
0608 c EsoftQZero = int(dz) z^dels * (1-zz/z)^betpom * P_qG(z)
0609 c
0610 c-----------------------------------------------------------------------
0611 double precision zmin,z
0612 common /ar3/ x1(7),a1(7)
0613 include 'epos.incsem'
0614
0615 EsoftQZero=0.
0616 zmin=zz
0617 zmin=zmin**(1.+dels)
0618 do i=1,7
0619 do m=1,2
0620 z=(.5d0*(1.+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))
0621 * **(1.d0/(1.d0+dels))
0622 EsoftQZero=EsoftQZero+a1(i)*max(1.d-5,(1.d0-zz/z))**betpom
0623 * *(z**2+(1.-z)**2)
0624 enddo
0625 enddo
0626 EsoftQZero=EsoftQZero*1.5*(1.d0-zmin)/(1.+dels) !1.5=naflav/2 at Q0
0627 return
0628 end
0629
0630 c------------------------------------------------------------------------
0631 function ffsigi(qq,y0) !former psjx1 (sto)
0632 c------------------------------------------------------------------------
0633 c
0634 c dsigma/dpt_jet = \int dy \int dx1 ffsig(x1,x2(x1))
0635 c
0636 c x1=xplus, x2=xminus
0637 c x2=x2(x1) due to u+t+s=0
0638 c ( s=x1*x2*spp, t/spp=-x1*xt*exp(-y)/2, u/spp=-x2*xt*exp(y)/2 )
0639 c
0640 c qq = pt**2, xt=2.*sqrt(qq/s)
0641 c rapidity range: 0 to y0
0642 c
0643 c ffsig = function ffsig(t,qq,x1,x2)
0644 c
0645 c-----------------------------------------------------------------------
0646 include 'epos.incsem'
0647 include 'epos.inc'
0648 double precision xx1,xx2,xt,ymax,ymin,y,xmin,xmax
0649 ig=3
0650 ig1=3
0651 s=engy**2
0652 ffsigi=0.
0653 if(s.le.4.*qq)return
0654 if(qq.lt.q2min)return
0655 xt=2d0*sqrt(dble(qq)/dble(s))
0656 ymax=min(dble(y0),log(1d0/xt+sqrt((1d0/xt-1d0)*(1d0/xt+1d0))))
0657 ymin=-ymax !final result must be divided by 2
0658 do i=1,ig
0659 do m=1,2
0660 y=.5d0*(ymax+ymin+(ymin-ymax)*dble((2*m-3)*tgss(ig,i)))
0661 !for xx1-integration, use variable x=xx1-xt*exp(y)/2.,with xmin<x<xmax
0662 xmin=xt**2/2.d0/(2.d0-xt*exp(-y)) !condition x2<1
0663 xmax=1.d0-xt*exp(y)/2.d0 !condition x1<1
0664 fx=0.
0665 do i1=1,ig1
0666 do m1=1,2
0667 xx1=xt*exp(y)/2.d0+xmin*(xmax/xmin)**dble(.5
0668 & +tgss(ig1,i1)*(m1-1.5))
0669 xx2=xt*exp(-y)*xx1/(2.d0*xx1-xt*exp(y))
0670 z=sngl(xx1*xx2)
0671 sh=z*s
0672 aa=1.-4.*qq/sh
0673 aa=max(1e-10,aa)
0674 t=sh/2.*(1.-sqrt(aa)) !formula in parton-parton cms
0675 ft=ffsig(t,qq,sngl(xx1),sngl(xx2))
0676 fx=fx+wgss(ig1,i1)*ft/sh**2
0677 enddo
0678 enddo
0679 fx=fx*0.5*sngl(log(xmax/xmin)) !dx/x=0.5*log(xmax/xmin)dt (gauss)
0680 ffsigi=ffsigi+wgss(ig,i)*fx
0681 enddo
0682 enddo
0683 ffsigi=ffsigi*0.5*sngl(ymax-ymin) !dy=0.5*(ymax-ymin)dt (gauss)
0684 * *2*pi*(2*pi*pssalf(qq/qcdlam))**2 !alpha = 2*pi*pssalf
0685 * *2*sqrt(qq) !d2pt=2*pi*pt*dpt
0686 * /2 ! y interval 2 * Delta_y
0687 * /2 ! condition t < sqrt(s)/2,
0688 ! since t > sqrt(s)/2 is automatically included,
0689 ! see psbori
0690 return
0691 end
0692
0693 c------------------------------------------------------------------------
0694 function psbori(s,t,j,l,n)
0695 c-----------------------------------------------------------------------
0696 c contribution to the born cross-section:
0697 c
0698 c dsigmaBorn/d2pt/dy = s/pi * delta(s+t+u) * 2*pi*alpha**2 /s**2 *psbori
0699 c
0700 c s - c.m. energy squared for the born scattering,
0701 c t - invariant variable for the born scattering |(p1-p3)**2|,
0702 c j - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
0703 c l - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
0704 c n - subprocess number
0705 c-----------------------------------------------------------------------
0706 include 'epos.incsem'
0707
0708 psbori=0.
0709 u=s-t
0710 if(u.le.0.d0)return
0711
0712 if(iabs(j).ne.4)then !light quarks and gluons
0713 if(n.eq.1)then
0714 if(j.eq.0.and.l.eq.0)then !gg->gg
0715 psbori=(3.-t*u/s**2+s*u/t**2+s*t/u**2)*4.5
0716 elseif(j*l.eq.0)then !gq->gq
0717 psbori=(s**2+u**2)/t**2+(s/u+u/s)/2.25
0718 elseif(j.eq.l)then !qq->qq
0719 psbori=((s**2+u**2)/t**2+(s**2+t**2)/u**2)/2.25
0720 * -s**2/t/u/3.375
0721 elseif(j.eq.-l)then !qq~->qq~
0722 psbori=((s**2+u**2)/t**2+(u**2+t**2)/s**2)/2.25
0723 * +u**2/t/s/3.375
0724 else !qq'->qq'
0725 psbori=(s**2+u**2)/t**2/2.25
0726 endif
0727 elseif(n.eq.2)then
0728 if(j.eq.0.and.l.eq.0)then !gg->qq~
0729 psbori=.5*(t/u+u/t)-1.125*(t*t+u*u)/s**2
0730 elseif(j.eq.-l)then !qq~->q'q'~
0731 psbori=(t*t+u*u)/s**2/1.125
0732 else
0733 psbori=0.
0734 endif
0735 elseif(n.eq.3)then
0736 if(j.ne.0.and.j.eq.-l)then !qq~->gg
0737 psbori=32./27.*(t/u+u/t)-(t*t+u*u)/s**2/.375
0738 else
0739 psbori=0.
0740 endif
0741
0742 c............ n=4 for photon product processes, make e_q**2 =2/9.,
0743 c the average value of charge squared for all types of quarks.
0744 elseif(n.eq.4) then
0745 if(j.ne.0.and.j.eq.-l)then !qq~->g+gamma
0746 psbori=16*factgam*(u/t+t/u)/81.
0747 elseif (j*l.eq.0.and.j+l.ne.0) then !q(q~)g->q(q~)+gamma
0748 psbori=2*factgam*(u/s+s/u)/27.
0749 else
0750 psbori=0.
0751 endif
0752 ctp090305 temporary to avoid hard gamma which produce fragmentation problem in psahot
0753 psbori=0. !????????????
0754 elseif(n.eq.5) then
0755 if(j.ne.0.and.j.eq.-l)then !qq~->gamma+gamma
0756 psbori=4*factgam*(t/u+u/t)/81.
0757 else
0758 psbori=0.
0759 endif
0760 ctp090305 temporary to avoid hard gamma which produce fragmentation problem in psahot
0761 psbori=0. !????????????
0762 endif
0763
0764 elseif(n.eq.1)then !c-quark
0765
0766 if(l.eq.0)then !cg->cg
0767 xm=qcmass**2/s/u
0768 psbori=(s**2+u**2)/t**2+(s/u+u/s)/2.25
0769 * -4.*qcmass**2/t+xm*(xm*t**2-t)/.5625+4.*qcmass**2*xm
0770 else !cq->cq
0771 psbori=(s**2+u**2)/t**2/2.25-qcmass**2/t/1.125
0772 endif
0773
0774 else
0775
0776 psbori=0.
0777
0778 endif
0779 return
0780 end
0781
0782 c-----------------------------------------------------------------------
0783 double precision function om51p(sy,xh,yp,b,iqq)
0784 c-----------------------------------------------------------------------
0785 c om5p - chi~(x,y)
0786 c xh - fraction of the energy squared s for the pomeron;
0787 c yp - rapidity for the pomeron;
0788 c b - impact parameter between the pomeron ends;
0789 c iqq =-1 - 0+1+2+3+4,
0790 c iqq = 0 - soft pomeron,
0791 c iqq = 1 - gg,
0792 c iqq = 2 - qg,
0793 c iqq = 3 - gq,
0794 c iqq = 4 - qq,
0795 c iqq = 5 - soft(int)|b,
0796 c iqq = 6 - gg(int)|b,
0797 c iqq = 7 - soft(proj)|b,
0798 c iqq = 8 - gg(proj)|b,
0799 c iqq = 9 - qg(proj)|b,
0800 c iqq = 10 - total fro-uncut integrated,
0801 c iqq = 11 - total uncut integrated,
0802 c iqq = 12 - soft(int),
0803 c iqq = 13 - gg(int),
0804 c iqq = 14 - <b^2*soft(int)>,
0805 c iqq = 15 - <b^2*gg(int)>,
0806 c iqq = 16 - soft(proj-int),
0807 c iqq = 17 - gg(proj-int),
0808 c iqq = 18 - qg(proj-int),
0809 c iqq = 19 - <b^2*soft(proj)>,
0810 c iqq = 20 - <b^2*gg(proj)>,
0811 c iqq = 21 - <b^2*qg(proj)>
0812 c-----------------------------------------------------------------------
0813 double precision xh,yp!,coefom1,coefom2
0814 common /psar7/ delx,alam3p,gam3p
0815 common /psar37/ coefom1,coefom2
0816 include 'epos.inc'
0817 include 'epos.incsem'
0818
0819 xp=dsqrt(xh)*exp(yp)
0820 if(xh.ne.0.d0)then
0821 xm=xh/xp
0822 else
0823 xm=0.
0824 endif
0825 rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
0826 zb=exp(-b**2/(4.*.0389*rp))
0827 rh=r2had(iclpro)+r2had(icltar)
0828
0829 if(iqq.eq.0)then !soft
0830 c rp=r2hads(iclpro)+r2hads(icltar)+slopoms*log(max(1.,sy))
0831 zb=exp(-b**2/(4.*.0389*rp))
0832 om51p=chad(iclpro)*chad(icltar)*gamhads(iclpro)
0833 * *gamhads(icltar)*sy**dels*(xp*xm)**(-alppar)*zb/rp
0834 elseif(iqq.le.4)then !gg,qg,gq,qq
0835 om51p=psvin(sy,xp,xm,zb,iqq)
0836 elseif(iqq.eq.5)then !soft(int)|b
0837 c rh=alam3p+slopoms*log(max(1.,sy))
0838 om51p=sy**dels*zb**(rp/rh)/rh
0839 elseif(iqq.eq.6)then !gg(int)|b
0840 om51p=psvin(sy,xp,xm,zb,14)
0841 elseif(iqq.eq.7)then !soft(proj)b
0842 c rh=r2hads(iclpro)+.5*alam3p+slopoms*log(max(1.,sy))
0843 om51p=chad(iclpro)*gamhads(iclpro)*sy**dels
0844 * *xp**(-alppar)*zb**(rp/rh)/rh
0845 elseif(iqq.eq.8)then !gg(proj)b
0846 om51p=psvin(sy,xp,xm,zb,16)
0847 elseif(iqq.eq.9)then !qg(proj)b
0848 om51p=psvin(sy,xp,xm,zb,18)
0849 elseif(iqq.eq.10)then !total fro-uncut integrated
0850 om51p=0.d0
0851 return
0852 elseif(iqq.eq.11)then !total uncut integrated
0853 om51p=psvin(sy,xp,xm,zb,9)
0854 c om51p=om51p+dble(coefom1)/2.d0*om51p**2+dble(coefom2)/6.d0*om51p**3 !!!!!!!!!!
0855 c if(om51p.gt.100.d0)om51p=100.d0
0856 elseif(iqq.eq.12)then !soft(int)
0857 om51p=sy**dels*4.*.0389
0858 elseif(iqq.eq.13)then !gg(int)
0859 om51p=psvin(sy,xp,xm,zb,5)
0860 elseif(iqq.eq.14)then !<b^2*soft(int)>
0861 c rh=alam3p+slopoms*log(max(1.,sy))
0862 om51p=sy**dels*rh*(4.*.0389)**2
0863 elseif(iqq.eq.15)then !<b^2*gg(int)>
0864 om51p=psvin(sy,xp,xm,zb,15)
0865 elseif(iqq.eq.16)then !soft(proj-int)
0866 om51p=chad(iclpro)*gamhads(iclpro)*sy**dels
0867 * *xp**(-alppar)*4.*.0389
0868 elseif(iqq.eq.17)then !gg(proj-int)
0869 om51p=psvin(sy,xp,xm,zb,6)
0870 elseif(iqq.eq.18)then !qg(proj-int)
0871 om51p=psvin(sy,xp,xm,zb,7)
0872 elseif(iqq.eq.19)then !<b^2*soft(proj)>
0873 c rh=r2hads(iclpro)+.5*alam3p+slopoms*log(max(1.,sy))
0874 om51p=chad(iclpro)*gamhads(iclpro)*sy**dels
0875 * *xp**(-alppar)*rh*(4.*.0389)**2
0876 elseif(iqq.eq.20)then !<b^2*gg(proj)>
0877 om51p=psvin(sy,xp,xm,zb,17)
0878 elseif(iqq.eq.21)then !<b^2*qg(proj)>
0879 om51p=psvin(sy,xp,xm,zb,19)
0880 else
0881 om51p=0.
0882 call utstop("Unknown iqq in om51p !&")
0883 endif
0884
0885 return
0886 end
0887
0888 cc-----------------------------------------------------------------------
0889 c double precision function om2p(xh,yp,xprem0,xmrem0,b,iqq)
0890 cc-----------------------------------------------------------------------
0891 cc om2p - chi~(x,y) for cut pomeron
0892 cc xh - fraction of the energy squared s for the pomeron;
0893 cc yp - rapidity for the pomeron;
0894 cc xprem - x+ for the projectile remnant;
0895 cc xmrem - x- for the target remnant;
0896 cc b - impact parameter between the pomeron ends;
0897 cc iqq = 0 - total,
0898 cc iqq = 1 - 1-cut,
0899 cc iqq = 2 - Y+,
0900 cc iqq = -2 - Y-,
0901 cc iqq = 3 - 1-cut(soft),
0902 cc iqq = 4 - 1+(gg),
0903 cc iqq = 5 - 1+(qg),
0904 cc iqq = 6 - 1+(gq),
0905 cc iqq = 7 - 1+(difr)
0906 cc iqq = -7 - 1-(difr)
0907 cc-----------------------------------------------------------------------
0908 c double precision xh,yp,xprem0,xmrem0
0909 c include 'epos.inc'
0910 c include 'epos.incsem'
0911 c
0912 c om2p=0.d0
0913 c sy=xh*engy**2
0914 c xprem=sngl(xprem0)
0915 c xmrem=sngl(xmrem0)
0916 c xp=dsqrt(xh)*dexp(yp)
0917 c if(xh.ne.0.d0)then
0918 c xm=xh/xp
0919 c else
0920 c xm=0.
0921 c endif
0922 c rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
0923 c zb=exp(-b**2/(4.*.0389*rp))
0924 c
0925 c if(iqq.eq.0)then
0926 c om2p=psvy(xp,xprem,xm,xmrem,b,2)
0927 c * +psvy(xp,xprem,xm,xmrem,b,-2)
0928 c * +psvy(xp,xprem,xm,xmrem,b,3)
0929 c * +psvy(xp,xprem,xm,xmrem,b,-3)
0930 c * +psvy(xp,xprem,xm,xmrem,b,9)
0931 c * +psvy(xp,xprem,xm,xmrem,b,-9)
0932 c * +psvx(xp,xprem,xm,xmrem,b,1)
0933 c * +psvx(xp,xprem,xm,xmrem,b,2)
0934 c * +psvx(xp,xprem,xm,xmrem,b,-2)
0935 c * +psvx(xp,xprem,xm,xmrem,b,6)
0936 c * +psvx(xp,xprem,xm,xmrem,b,-6)
0937 c om2p=om2p+(chad(iclpro)*chad(icltar)*gamhad(iclpro)
0938 c * *gamhad(icltar)*sy**dels*(xp*xm)**(-alppar)*zb/rp
0939 c * +psvin(sy,xp,xm,zb,1)+psvin(sy,xp,xm,zb,2)
0940 c * +psvin(sy,xp,xm,zb,3)+psvin(sy,xp,xm,zb,4))
0941 c elseif(iqq.eq.1)then
0942 c om2p=psvy(xp,xprem,xm,xmrem,b,2)+psvy(xp,xprem,xm,xmrem,b,-2)
0943 c * +psvx(xp,xprem,xm,xmrem,b,1)
0944 c elseif(iqq.eq.2)then
0945 c om2p=psvy(xp,xprem,xm,xmrem,b,3)
0946 c * +psvx(xp,xprem,xm,xmrem,b,2)
0947 c elseif(iqq.eq.-2)then
0948 c om2p=psvy(xp,xprem,xm,xmrem,b,-3)
0949 c * +psvx(xp,xprem,xm,xmrem,b,-2)
0950 c elseif(iqq.eq.3)then
0951 c om2p=psvy(xp,xprem,xm,xmrem,b,4)+psvy(xp,xprem,xm,xmrem,b,-4)
0952 c * +psvx(xp,xprem,xm,xmrem,b,3)
0953 c elseif(iqq.eq.4)then
0954 c om2p=psvy(xp,xprem,xm,xmrem,b,5)+psvy(xp,xprem,xm,xmrem,b,7)
0955 c * +psvy(xp,xprem,xm,xmrem,b,-5)+psvy(xp,xprem,xm,xmrem,b,-7)
0956 c * +psvx(xp,xprem,xm,xmrem,b,4)+psvx(xp,xprem,xm,xmrem,b,-4)
0957 c elseif(iqq.eq.5)then
0958 c om2p=psvy(xp,xprem,xm,xmrem,b,6)+psvy(xp,xprem,xm,xmrem,b,-8)
0959 c * +psvx(xp,xprem,xm,xmrem,b,5)
0960 c elseif(iqq.eq.6)then
0961 c om2p=psvy(xp,xprem,xm,xmrem,b,-6)+psvy(xp,xprem,xm,xmrem,b,8)
0962 c * +psvx(xp,xprem,xm,xmrem,b,-5)
0963 c elseif(iqq.eq.7)then
0964 c om2p=psvy(xp,xprem,xm,xmrem,b,9)
0965 c * +psvx(xp,xprem,xm,xmrem,b,6)
0966 c elseif(iqq.eq.-7)then
0967 c om2p=psvy(xp,xprem,xm,xmrem,b,-9)
0968 c * +psvx(xp,xprem,xm,xmrem,b,-6)
0969 c else
0970 c stop'om2p-wrong iqq!!!'
0971 c endif
0972 c return
0973 c end
0974 c
0975 cc-----------------------------------------------------------------------
0976 c double precision function om3p(xh,yp,xleg,xprem,xmrem,xlrem
0977 c *,b1,b2,b12,iqq)
0978 cc-----------------------------------------------------------------------
0979 cc om3p - chi~(x,y) for cut pomeron (nuclear effects)
0980 cc xh - fraction of the energy squared s for the pomeron;
0981 cc yp - rapidity for the pomeron;
0982 cc xleg - x for the pomeron leg;
0983 cc xprem - x+ for the projectile remnant;
0984 cc xmrem - x- for the target remnant;
0985 cc xlrem - x for the leg remnant;
0986 cc b1 - impact parameter between the pomeron ends;
0987 cc b2 - impact parameter for the second pomeron end;
0988 cc iqq = 1 - uncut+,
0989 cc iqq = 2 - cut+,
0990 cc iqq = 3 - scr+,
0991 cc iqq = 4 - diffr+,
0992 cc iqq = 5 - uncut-,
0993 cc iqq = 6 - cut-,
0994 cc iqq = 7 - scr-,
0995 cc iqq = 8 - diff-
0996 cc iqq = 9 - uncut-h+,
0997 cc iqq = 10 - uncut-h-,
0998 cc iqq = 11 - uncut-YY+,
0999 cc iqq = 12 - uncut-YY-,
1000 cc-----------------------------------------------------------------------
1001 c double precision xh,yp,xleg,xprem,xmrem,xlrem
1002 c
1003 c om3p=0.d0
1004 c return !!!!!!!!!!!!!!!
1005 cc if(iqq.ne.1.and.iqq.ne.5.and.iqq.ne.9.and.iqq.ne.10
1006 cc *.and.iqq.ne.11.and.iqq.ne.12)return
1007 c
1008 cc$$$ xp=dsqrt(xh)*exp(yp)
1009 cc$$$ if(xh.ne.0.d0)then
1010 cc$$$ xm=xh/xp
1011 cc$$$ else
1012 cc$$$ xm=0.d0
1013 cc$$$ endif
1014 cc$$$
1015 cc$$$ return
1016 c end
1017 c
1018 cc-----------------------------------------------------------------------
1019 c double precision function om4p(xx1,xx2,xx3,xx4
1020 c *,b12,b13,b14,b23,b24,b34,iqq)
1021 cc-----------------------------------------------------------------------
1022 cc om4p - chi for 2-leg contributions
1023 cc xx_i - x+- for pomeron ends;
1024 cc b_ij - impact parameter diff. between pomeron ends;
1025 cc iqq = 1 - uncut-H,
1026 cc iqq = 2 - uncut-YY+,
1027 cc iqq = 3 - uncut-YY-
1028 cc-----------------------------------------------------------------------
1029 c double precision xx1,xx2xx3,xx4
1030 c om4p=0.d0
1031 c return
1032 c end
1033 c
1034 cc------------------------------------------------------------------------
1035 c function omi5pp(sy,xpp,xpm,z,iqq) !former psfsh1
1036 cc-----------------------------------------------------------------------
1037 cc omi5pp - integrated semihard interaction eikonal
1038 cc sy - energy squared for the hard interaction,
1039 cc z - impact parameter factor, z=exp(-b**2/rp),
1040 cc iqq - type of the hard interaction:
1041 cc 0 - soft, 1 - gg, 2 - qg, 3 - gq
1042 cc-----------------------------------------------------------------------
1043 c common /ar3/ x1(7),a1(7)
1044 c common /ar9/ x9(3),a9(3)
1045 c include 'epos.inc'
1046 c include 'epos.incsem'
1047 c fsy(zsy)=zsy**dels !*(1.-1./zsy)**betpom
1048 c
1049 c omi5pp=0.
1050 c if(iclpro.eq.4.and.iqq.eq.2.or.icltar.eq.4.and.iqq.eq.3)then
1051 c spmin=4.*q2min+2.*qcmass**2
1052 c elseif(iqq.ne.0)then
1053 c spmin=4.*q2min
1054 c else
1055 c spmin=0.
1056 c endif
1057 c if(sy.le.spmin)return
1058 c
1059 c rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
1060 c alpq=(alppar+1.)/2.
1061 c if(iqq.eq.3)then
1062 c iclt=iclpro
1063 c iclp=icltar
1064 c else
1065 c iclp=iclpro
1066 c iclt=icltar
1067 c endif
1068 c
1069 c if(iqq.eq.0)then
1070 c xpmax=(1.-spmin/sy)**(1.+alplea(iclp))
1071 c do i=1,3
1072 c do m=1,2
1073 c xp=1.-(xpmax*(.5+x9(i)*(m-1.5)))**(1./(1.+alplea(iclp)))
1074 c xmmax=(1.-spmin/sy/xp)**(1.+alplea(iclt))
1075 c do i1=1,3
1076 c do m1=1,2
1077 c xm=1.-(xmmax*(.5+x9(i1)*(m1-1.5)))**(1./(1.+alplea(iclt)))
1078 c
1079 c sy1=sy*xp*xm
1080 c rh=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy1))
1081 c omi5pp=omi5pp+a9(i)*a9(i1)*fsy(sy1)*xmmax*z**(rp/rh)/rh
1082 c * *(xp*xm)**(-alppar)
1083 c enddo
1084 c enddo
1085 c enddo
1086 c enddo
1087 c omi5pp=omi5pp*xpmax/(1.+alplea(iclp))/(1.+alplea(iclt))
1088 c * *chad(iclpro)*chad(icltar)*gamhad(iclpro)*gamhad(icltar)
1089 c * *(xpp*xpm)**(1.-alppar)/4.
1090 c return
1091 c else
1092 c
1093 c xmin=(spmin/sy)**(delh-dels)
1094 c do i=1,3
1095 c do m=1,2
1096 c zh=(.5*(1.+xmin-(2*m-3)*x9(i)*(1.-xmin)))**(1./(delh-dels))
1097 c if(iclpro.eq.4.and.iqq.eq.2.or.icltar.eq.4.and.iqq.eq.3)then
1098 c call psjti0(zh*sy,sgq,sgqb,4,0)
1099 c call psjti0(zh*sy,sqq,sqqb,4,1)
1100 c else
1101 c call psjti0(zh*sy,sgg,sggb,0,0)
1102 c call psjti0(zh*sy,sgq,sgqb,0,1)
1103 c call psjti0(zh*sy,sqq,sqqb,1,1)
1104 c call psjti0(zh*sy,sqaq,sqaqb,-1,1)
1105 c call psjti0(zh*sy,sqqp,sqqpb,1,2)
1106 c sqq=(sqq+sqaq+2.*(naflav-1)*sqqp)/naflav/2.
1107 c endif
1108 c
1109 c if(iqq.eq.1)then
1110 c stg=0.
1111 c do i1=1,3
1112 c do m1=1,2
1113 c xx=.5+x9(i1)*(m1-1.5)
1114 c xp=zh**xx
1115 c xm=zh/xp
1116 c
1117 c xp1max=(1.-xp)**(1.+alplea(iclp))
1118 c xm1max=(1.-xm)**(1.+alplea(iclt))
1119 c do i2=1,3
1120 c do m2=1,2
1121 c xp1=1.-(xp1max*(.5+x9(i2)*(m2-1.5)))
1122 c * **(1./(1.+alplea(iclp)))
1123 c do i3=1,3
1124 c do m3=1,2
1125 c xm1=1.-(xm1max*(.5+x9(i3)*(m3-1.5)))
1126 c * **(1./(1.+alplea(iclt)))
1127 c if(xp1.lt.xp.or.xm1.lt.xm)write (*,*)'xp1,xm1,xp,xm'
1128 c * ,xp1,xm1,xp,xm
1129 c
1130 c rh=r2had(iclpro)+r2had(icltar)+slopom
1131 c * *log(xp1*xm1/xp/xm)
1132 c glu1=(1.-xp/xp1)**betpom*(1.-glusea)
1133 c sea1=EsoftQZero(xp/xp1)*glusea
1134 c glu2=(1.-xm/xm1)**betpom*(1.-glusea)
1135 c sea2=EsoftQZero(xm/xm1)*glusea
1136 c stg=stg+a9(i1)*a9(i2)*a9(i3)*(glu1*glu2*sgg
1137 c * +(glu1*sea2+sea1*glu2)*sgq+sea1*sea2*sqq)
1138 c * *xp1max*xm1max*(xp1*xm1)**(dels-alppar)
1139 c * *z**(rp/rh)/rh
1140 c enddo
1141 c enddo
1142 c enddo
1143 c enddo
1144 c enddo
1145 c enddo
1146 c omi5pp=omi5pp-a9(i)*log(zh)*stg/zh**delh
1147 c
1148 c else
1149 c stq=0.
1150 c xpmin=zh**(dels+.5)
1151 c do i1=1,3
1152 c do m1=1,2
1153 c xp=(.5*(1.+xpmin-(2*m1-3)*x9(i1)*(1.-xpmin)))
1154 c * **(1./(dels+.5))
1155 c xm=zh/xp
1156 c if(xp*xpp.lt..99999)then
1157 c uv1=psdfh4(xp*xpp,q2min,0.,iclp,1)
1158 c dv1=psdfh4(xp*xpp,q2min,0.,iclp,2)
1159 c xm1max=(1.-xm)**(1.+alplea(iclt))
1160 c do i2=1,3
1161 c do m2=1,2
1162 c xm1=1.-(xm1max*(.5+x9(i2)*(m2-1.5)))
1163 c * **(1./(1.+alplea(iclt)))
1164 c
1165 c rh=r2had(iclpro)+r2had(icltar)+slopom*log(xm1/xm)
1166 c glu2=(1.-xm/xm1)**betpom*(1.-glusea)
1167 c sea2=EsoftQZero(xm/xm1)*glusea
1168 c stq=stq+a9(i1)*a9(i2)*(glu2*sgq+sea2*sqq)*(uv1+dv1)
1169 c * *z**(rp/rh)/rh*xm1max*xm1**(dels-alppar)/sqrt(xp)
1170 c * *((1.-xp)/(1.-xp*xpp))**(1.-alpq+alplea(iclp))
1171 c enddo
1172 c enddo
1173 c endif
1174 c enddo
1175 c enddo
1176 c stq=stq*(1.-xpmin)
1177 c omi5pp=omi5pp+a9(i)*stq/zh**delh
1178 c endif
1179 c enddo
1180 c enddo
1181 c endif
1182 c
1183 c omi5pp=omi5pp*(1.-xmin)/(delh-dels)
1184 c if(iqq.eq.1)then
1185 c omi5pp=omi5pp*chad(iclp)*chad(iclt)*gamhad(iclp)
1186 c * *gamhad(iclt)*ffrr**2*(xpp*xpm)**(1.-alppar)
1187 c * /(1.+alplea(iclp))/(1.+alplea(iclt))*pi/8.*factk
1188 c else
1189 c omi5pp=omi5pp*chad(iclp)*chad(iclt)*ffrr*gamhad(iclt)
1190 c * *xpp**(1.-alpq)*xpm**(1.-alppar)/(.5+dels)
1191 c * /(1.+alplea(iclt))/16.*factk
1192 c endif
1193 c return
1194 c end
1195 c
1196 c------------------------------------------------------------------------
1197 function om52pi(sy,xpp,xpm,iqq,je1,je2) !modified om51pp
1198 c-----------------------------------------------------------------------
1199 c sy - energy squared for the hard interaction
1200 c
1201 c iqq = 0 - sea-sea,
1202 c iqq = 1 - val-sea,
1203 c iqq = 2 - sea-val,
1204 c iqq = 3 - val-val,
1205 c
1206 c je = emission type
1207 c 0 ... no emissions
1208 c 1 ... emissions
1209 c else ... all
1210 c
1211 c already b-averaged (\int d2b /sigine*10)
1212 c-----------------------------------------------------------------------
1213 common /ar3/ x1(7),a1(7)
1214 common /psar7/ delx,alam3p,gam3p
1215 include 'epos.inc'
1216 include 'epos.incsem'
1217 if(iqq.lt.0.or.iqq.gt.3)stop'om52pi: unvalid iqq'
1218
1219 om52pi=0.
1220
1221 ef1=0
1222 ef2=0
1223 ef3=0
1224 ef4=0
1225 if( je1.ge.1 .and. je2.ge.1) ef1=1
1226 if( je1.ge.1 .and.(je2.eq.0.or.je2.eq.2))ef2=1
1227 if((je1.eq.0.or.je1.eq.2).and. je2.ge.1) ef3=1
1228 if((je1.eq.0.or.je1.eq.2).and.(je2.eq.0.or.je2.eq.2))ef4=1
1229
1230 spmin=4.*q2min
1231 if(sy.le.spmin)goto999
1232
1233 if(iqq.eq.1)then
1234 iclv=iclpro
1235 ctp060829 icls=icltar
1236 elseif(iqq.eq.2)then
1237 ctp060829 icls=iclpro
1238 iclv=icltar
1239 endif
1240
1241 delss=dels
1242 if(iqq.eq.3)delss=-0.5
1243 xmin=spmin/sy
1244 xmin=xmin**(delh-delss)
1245 alpq=(alppar+1.)/2.
1246
1247 c numerical integration over zh
1248 do i=1,7
1249 do m=1,2
1250 zh=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./(delh-delss))
1251 sgg= ef1 *pijet(2,q2min,q2min,zh*sy,0,0)
1252 * + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,0,0)
1253 * + ef4 *pijet(0,q2min,q2min,zh*sy,0,0)
1254 sgq= ef1 *pijet(2,q2min,q2min,zh*sy,0,1)
1255 * + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,0,1)
1256 * + ef4 *pijet(0,q2min,q2min,zh*sy,0,1)
1257 sqq= ef1 *pijet(2,q2min,q2min,zh*sy,1,1)
1258 * + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,1,1)
1259 * + ef4 *pijet(0,q2min,q2min,zh*sy,1,1)
1260 sqaq= ef1 *pijet(2,q2min,q2min,zh*sy,-1,1)
1261 * + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,-1,1)
1262 * + ef4 *pijet(0,q2min,q2min,zh*sy,-1,1)
1263 sqqp= ef1 *pijet(2,q2min,q2min,zh*sy,1,2)
1264 * + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,1,2)
1265 * + ef4 *pijet(0,q2min,q2min,zh*sy,1,2)
1266 sqqi=sqq
1267 sqq=(sqq+sqaq+2.*(naflav-1)*sqqp)/naflav/2.
1268 if(iqq.eq.0)then
1269 stg=0.
1270 do i1=1,7
1271 do m1=1,2
1272 xx=.5+x1(i1)*(m1-1.5)
1273 xp=zh**xx
1274 xm=zh/xp
1275 glu1=EsoftGluonTil(xp)
1276 sea1=EsoftQuarkTil(xp)
1277 glu2=EsoftGluonTil(xm)
1278 sea2=EsoftQuarkTil(xm)
1279 dstg= glu1*glu2*sgg
1280 * +(glu1*sea2+sea1*glu2)*sgq !ccccc
1281 * +sea1*sea2*sqq !ccccc
1282 stg=stg+a1(i1)*dstg
1283 enddo
1284 enddo
1285 om52pi=om52pi-a1(i)*log(zh)*stg/zh**delh
1286 elseif(iqq.eq.3)then
1287 stq=0. !int^1_(sqrt(z)) dx_p / x_p / sqrt(1-x_p) =int^(tmax)_(0) dt
1288 tmax=sqrt(1.-sqrt(zh)) !t=ln((1+sqrt(1-x_p))/(1-sqrt(1-x_p)))
1289 tmax=log((1.+tmax)/(1.-tmax))
1290 if(tmax.gt.1.e-20)then
1291 do i1=1,7
1292 do m1=1,2
1293 t=tmax*(.5+x1(i1)*(m1-1.5))
1294 z01=((1.d0-exp(-1.d0*t))/(1.d0+exp(-1.d0*t)))**2
1295 xp=1.-z01
1296 xm=zh/xp
1297 if(xp*xpp.le..9999.and.xm*xpm.le..9999
1298 * .or.xm*xpp.le..9999.and.xp*xpm.le..9999)then
1299 stq=stq+a1(i1)
1300 * *(psharg(xp*xpp,xm*xpm,sqqi,sqqp,sqaq)
1301 * +psharg(xm*xpp,xp*xpm,sqqi,sqqp,sqaq))
1302 * *max(1e-20,1.-xp)**(.5-alpq)
1303 * *max(1e-20,1.-xm)**(-alpq)
1304 * *xp**delss*xm**delss
1305 * *xpp**alppar/gamhad(iclpro) ! Eval
1306 * *xpm**alppar/gamhad(icltar) ! Eval
1307 endif
1308 enddo
1309 enddo
1310 stq=stq*tmax
1311 endif
1312 om52pi=om52pi+a1(i)*stq/zh**delh
1313 elseif(iqq.eq.1.or.iqq.eq.2)then
1314 stq=0.
1315 tmax=acos(sqrt(zh))
1316 do i1=1,7
1317 do m1=1,2
1318 t=tmax*(.5+x1(i1)*(m1-1.5))
1319 xp=cos(t)**2
1320 xm=zh/xp
1321 if(xp*xpp.lt..99999)then
1322 uv1=psdfh4(xp*xpp,q2min,0.,iclv,1) ! Eval
1323 dv1=psdfh4(xp*xpp,q2min,0.,iclv,2) ! Eval
1324 glu2=EsoftGluonTil(xm)
1325 sea2=EsoftQuarkTil(xm)
1326 dstq=0
1327 if(xp.ne.1.)
1328 * dstq=(glu2*sgq+sea2*sqq)*(uv1+dv1)
1329 * *(1.-xp*xpp)**(-1.+alpq-alplea(iclv)) ! Eval
1330 * *xp**(delss-.5)*(1.-xp)**(-alpq+.5) ! Eval *sqrt(1-x)/sqrt(x)
1331 * *xpp**alppar/gamhad(iclv) ! Eval
1332 stq=stq+a1(i1)*dstq
1333 endif
1334 enddo
1335 enddo
1336 stq=stq*tmax
1337 om52pi=om52pi+a1(i)*stq/zh**delh
1338 else
1339 stop'om52pi: unvalid iqq (2). '
1340 endif
1341 enddo
1342 enddo
1343
1344 om52pi=om52pi*(1.-xmin)/(delh-delss)
1345
1346 if(iqq.eq.0)then
1347 om52pi=om52pi/4
1348 elseif(iqq.eq.3)then
1349 om52pi=om52pi/4
1350 * * utgam1(2.+alplea(iclpro)-alpq) ! Eval
1351 * /utgam1(1.+alplea(iclpro))/utgam1(1.-alpq) ! Eval
1352 * * utgam1(2.+alplea(icltar)-alpq) ! Eval
1353 * /utgam1(1.+alplea(icltar))/utgam1(1.-alpq) ! Eval
1354 * /xpp**alpq/xpm**alpq ! Eval
1355 elseif(iqq.le.2)then
1356 om52pi=om52pi/2
1357 * *utgam1(2.+alplea(iclv)-alpq)/utgam1(1.+alplea(iclv)) ! Eval
1358 * /utgam1(1.-alpq) ! Eval
1359 * /xpp**alpq ! Eval
1360 endif
1361
1362 999 continue
1363 om52pi=om52pi*factk * .0390 /sigine*10 /2.
1364 end
1365
1366 c------------------------------------------------------------------------
1367 function psharg(zh1,zh2,sqq,sqqp,sqaq)
1368 c-----------------------------------------------------------------------
1369 include 'epos.incsem'
1370 include 'epos.inc'
1371
1372 alpq=(alppar+1.)/2.
1373 if(zh1.le..9999.and.zh2.le..9999)then
1374 uv1=psdfh4(zh1,q2min,0.,iclpro,1)
1375 dv1=psdfh4(zh1,q2min,0.,iclpro,2)
1376 uv2=psdfh4(zh2,q2min,0.,icltar,1)
1377 dv2=psdfh4(zh2,q2min,0.,icltar,2)
1378 if(iclpro.eq.2.and.icltar.eq.2)then !proton
1379 fff=sqq*(uv1*uv2+dv1*dv2)+sqqp*(uv1*dv2+dv1*uv2)
1380 elseif(iclpro.eq.1.or.icltar.eq.1)then !pion
1381 fff=sqq*uv1*uv2+sqaq*dv1*dv2+sqqp*(uv1*dv2+dv1*uv2)
1382 elseif(iclpro.eq.3.or.icltar.eq.3)then !kaon
1383 fff=sqq*uv1*uv2+sqqp*(uv1*dv2+dv1*uv2+dv1*dv2)
1384 elseif(iclpro.eq.4.or.icltar.eq.4)then !J/psi
1385 fff=sqq*uv1*(uv2+dv2)
1386 else
1387 fff=0.
1388 call utstop("Projectile not know in psharg !&")
1389 endif
1390 psharg=fff
1391 * *(1.-zh1)**(-1.+alpq-alplea(iclpro))
1392 * *(1.-zh2)**(-1.+alpq-alplea(icltar))
1393 else
1394 psharg=0.
1395 endif
1396 return
1397 end
1398
1399 c------------------------------------------------------------------------
1400 function om51pp(sy,xpp,z,iqq) !former psfsh
1401 c-----------------------------------------------------------------------
1402 c om51pp - semihard interaction eikonal
1403 c sy - energy squared for the hard interaction,
1404 c z - impact parameter factor, z=exp(-b**2/rp),
1405 c iqq - type of the hard interaction:
1406 c 0 - gg, 1 - qg, 2 - gq, 3 - gg(int), 4 - gg(proj), 5 - qg(proj),
1407 c 6 - gg(int)|b=0, 7 - <b^2*gg(int)>, 8 - gg(proj)|b=0,
1408 c 9 - <b^2*gg(proj)>, 10 - qg(proj)|b=0, 11 - <b^2*qg(proj)>
1409 c-----------------------------------------------------------------------
1410 common /ar3/ x1(7),a1(7)
1411 common /psar7/ delx,alam3p,gam3p
1412 include 'epos.inc'
1413 include 'epos.incsem'
1414
1415 om51pp=0.
1416 if(iqq.eq.0.or.iqq.eq.3.or.iqq.eq.4
1417 *.or.iqq.eq.6.or.iqq.eq.7.or.iqq.eq.8.or.iqq.eq.9
1418 *.or.iclpro.ne.4.and.(iqq.eq.1.or.iqq.eq.5
1419 *.or.iqq.eq.10.or.iqq.eq.11)
1420 *.or.icltar.ne.4.and.iqq.eq.2)then
1421 spmin=4.*q2min
1422 else
1423 spmin=4.*q2min+2.*qcmass**2
1424 endif
1425 if(sy.le.spmin)goto999
1426
1427 icls=iclpro
1428 if(iqq.eq.1.or.iqq.eq.5.or.iqq.eq.10.or.iqq.eq.11)then
1429 iclv=iclpro
1430 icls=icltar
1431 elseif(iqq.eq.2)then
1432 icls=iclpro
1433 iclv=icltar
1434 endif
1435
1436 xmin=spmin/sy
1437 xmin=xmin**(delh-dels)
1438 rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
1439 alpq=(alppar+1.)/2.
1440
1441 c numerical integration over zh
1442 do i=1,7
1443 do m=1,2
1444 zh=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./
1445 * (delh-dels))
1446 if(iqq.eq.0.or.iqq.eq.3.or.iqq.eq.4
1447 * .or.iqq.eq.6.or.iqq.eq.7.or.iqq.eq.8.or.iqq.eq.9
1448 * .or.iclpro.ne.4.and.(iqq.eq.1.or.iqq.eq.5
1449 * .or.iqq.eq.10.or.iqq.eq.11)
1450 * .or.icltar.ne.4.and.iqq.eq.2)then
1451 call psjti0(zh*sy,sgg,sggb,0,0) !inclusive (sj) and born (sjb)
1452 call psjti0(zh*sy,sgq,sgqb,0,1)
1453 call psjti0(zh*sy,sqq,sqqb,1,1)
1454 call psjti0(zh*sy,sqaq,sqaqb,-1,1)
1455 call psjti0(zh*sy,sqqp,sqqpb,1,2)
1456 sqq=(sqq+sqaq+2.*(naflav-1)*sqqp)/naflav/2.
1457 c...........test.......
1458 c tgg= psjet(q2min,q2min,q2min,zh*sy,0,0,0)
1459 c * +2*psjet1(q2min,q2min,q2min,zh*sy,0,0,0)
1460 c * + psborn(q2min,q2min,q2min,zh*sy,0,0,0,1)
1461 c tgq= psjet(q2min,q2min,q2min,zh*sy,0,1,0)
1462 c * +2*psjet1(q2min,q2min,q2min,zh*sy,0,1,0)
1463 c * + psborn(q2min,q2min,q2min,zh*sy,0,1,0,1)
1464 c tqq= psjet(q2min,q2min,q2min,zh*sy,1,1,0)
1465 c * +2*psjet1(q2min,q2min,q2min,zh*sy,1,1,0)
1466 c * + psborn(q2min,q2min,q2min,zh*sy,1,1,0,1)
1467 c tqa= psjet(q2min,q2min,q2min,zh*sy,-1,1,0)
1468 c * +2*psjet1(q2min,q2min,q2min,zh*sy,-1,1,0)
1469 c * + psborn(q2min,q2min,q2min,zh*sy,-1,1,0,1)
1470 c tqqp= psjet(q2min,q2min,q2min,zh*sy,1,2,0)
1471 c * +2*psjet1(q2min,q2min,q2min,zh*sy,1,2,0)
1472 c * + psborn(q2min,q2min,q2min,zh*sy,1,2,0,1)
1473 c write(6,'(f12.2,3x,2f7.3,2(3x,2f7.3))')
1474 c * zh*sy,tgg,sgg, tgq,sgq, tqqp,sqqp
1475 c.......................
1476 else
1477 call psjti0(zh*sy,sgq,sgqb,4,0)
1478 call psjti0(zh*sy,sqq,sqqb,4,1)
1479 endif
1480
1481 if(iqq.eq.0.or.iqq.eq.3.or.iqq.eq.4
1482 * .or.iqq.eq.6.or.iqq.eq.7.or.iqq.eq.8.or.iqq.eq.9)then
1483 stg=0.
1484 do i1=1,7
1485 do m1=1,2
1486 xx=.5+x1(i1)*(m1-1.5)
1487 xp=zh**xx
1488 xm=zh/xp
1489 glu1=(1.-xp)**betpom*(1.-glusea)
1490 sea1=EsoftQZero(xp)*glusea
1491 glu2=(1.-xm)**betpom*(1.-glusea)
1492 sea2=EsoftQZero(xm)*glusea
1493 rh=0.
1494 if(iqq.eq.0)then
1495 rh=r2had(iclpro)+r2had(icltar)-slopom*log(zh)
1496 elseif(iqq.eq.3.or.iqq.eq.4)then
1497 rh=1.
1498 elseif(iqq.eq.6.or.iqq.eq.7)then
1499 rh=alam3p-slopom*log(zh)
1500 elseif(iqq.eq.8.or.iqq.eq.9)then
1501 rh=r2had(iclpro)+.5*alam3p-slopom*log(zh)
1502 endif
1503 dstg=(glu1*glu2*sgg+
1504 * (glu1*sea2+sea1*glu2)*sgq+sea1*sea2*sqq)
1505 * *z**(rp/rh)/rh
1506 if(iqq.eq.7.or.iqq.eq.9)dstg=dstg*rh**2
1507 stg=stg+a1(i1)*dstg
1508 enddo
1509 enddo
1510 om51pp=om51pp-a1(i)*log(zh)*stg/zh**delh
1511 else
1512 stq=0.
1513 tmax=acos(sqrt(zh))
1514 do i1=1,7
1515 do m1=1,2
1516 t=tmax*(.5+x1(i1)*(m1-1.5))
1517 xp=cos(t)**2
1518 xm=zh/xp
1519 if(xp*xpp.lt..99999)then
1520 uv1=psdfh4(xp*xpp,q2min,0.,iclv,1)
1521 dv1=psdfh4(xp*xpp,q2min,0.,iclv,2)
1522 glu2=(1.-xm)**betpom*(1.-glusea)
1523 sea2=EsoftQZero(xm)*glusea
1524 rh=0.
1525 if(iqq.le.2)then
1526 rh=r2had(iclpro)+r2had(icltar)-slopom*log(xm)
1527 elseif(iqq.eq.5)then
1528 rh=1.
1529 elseif(iqq.le.10.or.iqq.le.11)then
1530 rh=r2had(iclpro)+.5*alam3p-slopom*log(xm)
1531 endif
1532 dstq=0
1533 if(xp.ne.1.)
1534 * dstq=(glu2*sgq+sea2*sqq)*(uv1+dv1)
1535 * *z**(rp/rh)/rh
1536 * *(1.-xp*xpp)**(-1.+alpq-alplea(iclv))
1537 * *xp**(dels-.5)*(1.-xp)**(-alpq+.5)
1538 if(iqq.eq.11)dstq=dstq*rh**2
1539 stq=stq+a1(i1)*dstq
1540 endif
1541 enddo
1542 enddo
1543 stq=stq*tmax
1544 om51pp=om51pp+a1(i)*stq/zh**delh
1545 endif
1546 enddo
1547 enddo
1548
1549 om51pp=om51pp*(1.-xmin)/(delh-dels)/sy**delh/2.
1550 if(iqq.eq.0)then
1551 om51pp=om51pp*chad(iclpro)*chad(icltar)*gamhad(iclpro)
1552 * *gamhad(icltar)*ffrr**2*pi
1553 elseif(iqq.eq.3)then
1554 om51pp=om51pp*ffrr**2*pi*4.*.0389
1555 elseif(iqq.eq.6)then
1556 om51pp=om51pp*ffrr**2*pi
1557 elseif(iqq.eq.7)then
1558 om51pp=om51pp*ffrr**2*pi*(4.*.0389)**2
1559 elseif(iqq.eq.4.or.iqq.eq.8.or.iqq.eq.9)then
1560 om51pp=om51pp*ffrr**2*pi*chad(iclpro)*gamhad(iclpro)
1561 if(iqq.eq.4)om51pp=om51pp*4.*.0389
1562 if(iqq.eq.9)om51pp=om51pp*(4.*.0389)**2
1563 elseif(iqq.le.2)then
1564 om51pp=om51pp*chad(iclpro)*chad(icltar)*ffrr*gamhad(icls)
1565 * *utgam1(2.+alplea(iclv)-alpq)/utgam1(1.+alplea(iclv))
1566 * /utgam1(1.-alpq)/2./xpp**alpq
1567 elseif(iqq.eq.5.or.iqq.eq.10.or.iqq.eq.11)then
1568 om51pp=om51pp*chad(iclv)*ffrr
1569 * *utgam1(2.+alplea(iclv)-alpq)/utgam1(1.+alplea(iclv))
1570 * /utgam1(1.-alpq)/2./xpp**alpq
1571 if(iqq.eq.5)om51pp=om51pp*4.*.0389
1572 if(iqq.eq.11)om51pp=om51pp*(4.*.0389)**2
1573 endif
1574 999 continue
1575 end
1576
1577 c-------------------------------------------------------------------------------
1578 subroutine epocrossc(niter,gtot,gprod,gabs,gcoh,gqel,gdd)
1579 c-------------------------------------------------------------------------------
1580 c epocrossc - nucleus-nucleus (nucleus-hydrogen) interaction cross sections
1581 c by calculation will real nuclear profiles and eikonal (simplified simulations)
1582 c gtot - total cross section
1583 c gprod - production cross section (all diffraction included)
1584 c gabs - cut Pomerons cross section (no diffraction at all)
1585 c gdd - proj (ionudi=2) or proj or targ (ionudi=0/3) excited diffraction
1586 c cross section
1587 c gcoh - coherent (elastic with respect to the projectile) cross section
1588 c (non excited diff proj if ionudi=2, non excited proj+targ if ionudi=0/3)
1589 c
1590 c Be careful : this function is not symmetric for gdd and gqel (only projectile
1591 c diffraction) in case of ionudi=2.
1592 c (target diffraction is not treated explicitely and contributes to
1593 c gprod, gdd, gcoh and gtot).
1594 c
1595 c WARNING : results are sure only in case of ionudi=1 (no substraction from
1596 c diffractive part) in particular for AA with A > 10 (nuclear diff
1597 c not well described). For pA seems to be OK with ionudi 2 and 3.
1598 c
1599 c code from QGSJET programs by S.Ostapchenko
1600 c-------------------------------------------------------------------------------
1601 include 'epos.inc'
1602 include 'epos.incems'
1603 common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
1604 * ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
1605 common/geom/rmproj,rmtarg,bmax,bkmx
1606 dimension wabs(28),wdd(28),wcoh(28),wprod(28),wqel(28)
1607 & ,b0(28),ai(28)
1608 common /ar3/ x1(7),a1(7)
1609 double precision xgabs,xgdd,xgprod,xgcoh,xgqel
1610
1611 call utpri('epocrs',ish,ishini,2)
1612 if(ish.ge.2)write(ifch,201)niter,bmax
1613 kollini=koll !koll modified
1614 do i=1,7
1615 b0(15-i)=bmax*sqrt((1.+x1(i))/2.)
1616 b0(i)=bmax*sqrt((1.-x1(i))/2.)
1617 ai(i)=a1(i)*bmax**2*pi*5.05 !factor change cs
1618 ai(15-i)=ai(i)
1619 enddo
1620 if(maproj.gt.1.or.matarg.gt.1)then
1621 difn=max(difnuc(maproj),difnuc(matarg))
1622 else
1623 difn=1.
1624 endif
1625 do i=1,7
1626 tp=(1.+x1(i))/2.
1627 tm=(1.-x1(i))/2.
1628 b0(14+i)=bmax-log(tp)*difn
1629 b0(29-i)=bmax-log(tm)*difn
1630 ai(14+i)=a1(i)*b0(14+i)/tp*10.*difn*pi
1631 ai(29-i)=a1(i)*b0(29-i)/tm*10.*difn*pi
1632 enddo
1633 do i=1,28
1634 wabs(i)=0.
1635 wdd(i)=0.
1636 wprod(i)=0.
1637 wcoh(i)=0.
1638 wqel(i)=0.
1639 enddo
1640 do nc=1,niter
1641 if(maproj.eq.1)then
1642 xproj(1)=0.
1643 yproj(1)=0.
1644 zproj(1)=0.
1645 else
1646 call conxyz('p',mamx,xproj,yproj,zproj,ypjtl-yhaha)
1647 endif
1648 if(matarg.eq.1)then
1649 xtarg(1)=0.
1650 ytarg(1)=0.
1651 ztarg(1)=0.
1652 else
1653 call conxyz('t',mamx,xtarg,ytarg,ztarg,yhaha)
1654 endif
1655
1656 do i=1,28
1657 call epogcr(b0(i),xgabs,xgdd,xgprod,xgcoh,xgqel)
1658 wabs(i)=wabs(i)+sngl(xgabs)
1659 wdd(i)=wdd(i)+sngl(xgdd)
1660 wprod(i)=wprod(i)+sngl(xgprod)
1661 wcoh(i)=wcoh(i)+sngl(xgcoh)
1662 wqel(i)=wqel(i)+sngl(xgqel)
1663 enddo
1664 enddo
1665
1666 gabs=0.
1667 gdd=0.
1668 gcoh=0.
1669 gprod=0.
1670 gqel=0.
1671 do i=1,28
1672 wabs(i)=wabs(i)/niter
1673 wdd(i)=wdd(i)/niter
1674 wcoh(i)=wcoh(i)/niter
1675 wprod(i)=wprod(i)/niter
1676 wqel(i)=wqel(i)/niter
1677 gabs=gabs+ai(i)*wabs(i)
1678 gdd=gdd+ai(i)*wdd(i)
1679 gcoh=gcoh+ai(i)*wcoh(i)
1680 gqel=gqel+ai(i)*wqel(i)
1681 gprod=gprod+ai(i)*wprod(i)
1682 enddo
1683
1684
1685 gtot=gprod+gcoh !total=all cut (with diff) + all uncut
1686 if(ish.ge.2)write (ifch,202)gtot,gprod,gabs,gdd,gcoh,gqel
1687
1688 201 format(2x,'epocrossc - A-B interaction cross sections,'
1689 *,' N of iter.:',i5,' bmax:',f5.2)
1690 202 format(2x,'epocrossc: gtot=',e10.3,2x,'gprod=',e10.3,2x
1691 *,'gabs=',e10.3/4x,'gdd=',e10.3,2x,'gcoh=',e10.3,'gqel=',e10.3)
1692
1693
1694 koll=kollini
1695 call utprix('epocrs',ish,ishini,2)
1696
1697 return
1698 end
1699
1700 c-------------------------------------------------------------------------------
1701 subroutine epogcr(b,gabs,gdd,gprod,gcoh,gqel)
1702 c-------------------------------------------------------------------------------
1703 c epogcr - integrands (b-profiles) for nucleus-nucleus cross sections
1704 c b - impact parameter
1705 c code from QGSJET programs by S.Ostapchenko
1706 c-------------------------------------------------------------------------------
1707 include 'epos.inc'
1708 include 'epos.incems'
1709 include 'epos.incpar'
1710 common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
1711 * ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
1712 common/geom/rmproj,rmtarg,bmax,bkmx
1713 common/scrangle/ phik3(kollmx),thetak3(kollmx)
1714 double precision vin,gabs,gdd,gprod,gcoh,fdd,gqel,fdt,vdt,vcu
1715
1716 if(ish.ge.9)write (ifch,201)b
1717 gprod=1d0
1718 gabs=1d0
1719 gdd=1d0
1720 fdd=1d0
1721 fdt=1d0
1722 bx=0
1723 by=0
1724
1725 if(maproj.eq.1.and.matarg.eq.1)then
1726 if(b.gt.bkmx)then
1727 koll=0
1728 else
1729 koll=1
1730 bk(1)=b
1731 iproj(1)=1
1732 itarg(1)=1
1733 lproj(1)=1
1734 ltarg(1)=1
1735 lproj3(1)=1
1736 ltarg3(1)=1
1737 kproj3(1,1)=1
1738 ktarg3(1,1)=1
1739 kproj(1,1)=1
1740 ktarg(1,1)=1
1741 endif
1742 else
1743 bx=b
1744 by=0.
1745 koll=0
1746 do i=1,maproj
1747 lproj(i)=0
1748 lproj3(i)=0
1749 enddo
1750 do j=1,matarg
1751 ltarg(j)=0
1752 ltarg3(j)=0
1753 enddo
1754 do 12 i=1,maproj
1755 do 11 j=1,matarg
1756 bij=sqrt((xproj(i)+bx-xtarg(j))**2+(yproj(i)+by-ytarg(j))**2)
1757 if(bij.gt.bkmx)goto 11
1758
1759 koll=koll+1
1760 if(koll.gt.kollmx)call utstop('epogcr: kollmx too small&')
1761 bk(koll)=bij
1762 bkx(koll)=xproj(i)+bx-xtarg(j)
1763 bky(koll)=yproj(i)+by-ytarg(j)
1764 iproj(koll)=i
1765 itarg(koll)=j
1766 lproj(i)=lproj(i)+1
1767 ltarg(j)=ltarg(j)+1
1768 kproj(i,lproj(i))=koll
1769 ktarg(j,ltarg(j))=koll
1770 if(iscreen.ne.0.and.bij.le.bkmxndif)then
1771 if(zbrmax.gt.0..and.bij.gt.zbcut+zbrmax*rangen())goto 11
1772 lproj3(i)=lproj3(i)+1
1773 ltarg3(j)=ltarg3(j)+1
1774 kproj3(i,lproj3(i))=koll
1775 ktarg3(j,ltarg3(j))=koll
1776 c define angle for anti-shadowing
1777 if(abs(bky(koll)).gt.1.e-6)then
1778 if(abs(bkx(koll)).gt.1.e-6)then
1779 phik3(koll)=atan(bky(koll)/bkx(koll))
1780 else
1781 phik3(koll)=sign(0.5*pi,bky(koll))
1782 endif
1783 elseif(bkx(koll).lt.0.)then
1784 phik3(koll)=pi
1785 endif
1786 if(bk(koll).gt.0.)then
1787 thetak3(koll)=atan(bglaubx/bk(koll))
1788 else
1789 thetak3(koll)=0.5*pi
1790 endif
1791 endif
1792
1793 11 continue
1794 12 continue
1795 endif
1796 if(koll.eq.0)then
1797 gabs=0d0
1798 gdd=0d0
1799 gprod=0d0
1800 gcoh=0d0
1801 gqel=0d0
1802 goto 1000
1803 endif
1804 if(iscreen.ne.0)call CalcScrPair(b)
1805
1806 irea=-1
1807 call GfunParK(irea)
1808 if(ionudi.eq.0
1809 & .and.(maproj.ne.1.or.matarg.ne.1).and.nglevt.eq.0)then
1810 gabs=0d0
1811 gdd=0d0
1812 gprod=0d0
1813 gcoh=0d0
1814 gqel=0d0
1815 goto 1000
1816 endif
1817 call integom1(irea)
1818
1819 do n=1,maproj
1820 call epov(n,vin,vcu,vdt)
1821 gprod=gprod*vin
1822 gabs=gabs*vcu
1823 fdd=fdd*(1.-rexdif(iclpro))
1824 & **(1.+rexres(iclpro)*float(lproj(n)-1))
1825 fdt=fdt*vdt
1826 enddo
1827 gprod=min(gprod,1.d0)
1828 gcoh=1d0-2d0*sqrt(gprod)+gprod
1829 gprod=1d0-gprod
1830 gabs=max(0d0,1d0-gabs) !cut (no diffraction)
1831 gdd=max(0d0,gprod-gabs) !diffractive part
1832 gqel=0d0
1833 if(ionudi.eq.2.and.maproj+matarg.gt.2)then
1834 gqel=fdd*gdd !quasielastic = diffractive without excited proj.
1835 if(iLHC.eq.1)gqel=gqel-fdd*fdt*gdd !DPE counted as inelastic
1836 gdd=gdd-gqel !only excited projectile diffraction
1837 elseif(iLHC.ne.1)then
1838 gqel=fdd*fdt*gdd !quasielastic = diffractive without excited proj. or targ
1839 gdd=gdd-gqel !inelastic part due to excited diffraction
1840 endif
1841 1000 continue
1842 if(ish.ge.9)write (ifch,202)gabs,gdd,gprod,gcoh,gqel,fdd,fdt
1843
1844 201 format(2x,'epogcr-integrands for nucleus-nucleus cross sections,'
1845 *,' b=',e10.3)
1846 202 format(2x,'epogcr: gabs=',e10.3,2x,'gdd=',e10.3,2x,'gprod=',e10.3
1847 *,2x,'gcoh=',e10.3,2x,'gqel=',e10.3,2x,'fdd=',e10.3,' fdt=',e10.3)
1848 return
1849 end
1850
1851 c=============================================================================
1852 subroutine epov(n,vin,vcu,vdt)
1853 c epov - eikonal factors for nucleus-nucleus interaction
1854 c (used for cross-section calculation)
1855 c n - projectile nucleon indice
1856 c vin - all uncut pomerons
1857 c vcu - all uncut non diff pomerons
1858 c vdt - non diffractive excitation factor for target
1859 c code from QGSJET programs by S.Ostapchenko
1860 c----------------------------------------------------------------------------
1861 include 'epos.inc'
1862 include 'epos.incems'
1863 common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
1864 * ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
1865 double precision vvv2,vvv1,dv,vin,vcu,vdt,PhiExpoK,PhiExpoK2
1866
1867 if(ish.ge.9)write (ifch,201)xproj(n),yproj(n)
1868
1869 vin=0.d0
1870 vcu=0.d0
1871 vvv1=1.d0
1872 vvv2=1.d0
1873 dv=1.d0
1874 do m=1,lproj(n)
1875 k=kproj(n,m)
1876 vvv2=vvv2*max(0.d0,PhiExpoK2(k,1.d0,1.d0))
1877 vvv1=vvv1*max(0.d0,PhiExpoK(k,1.d0,1.d0))
1878 dv=dv*(1.-rexdif(icltar))
1879 & **(1.+rexres(icltar)*float(ltarg(m)-1))
1880 enddo
1881 vcu=vvv2
1882 vin=vvv1 !exp(-2 * chi)
1883 vdt=dv
1884
1885 if(ish.ge.9)write (ifch,202)vin,vcu,vdt
1886 if(ish.ge.9)write (ifch,203)
1887
1888 201 format(2x,'epov - eikonal factor: nucleon coordinates x=',
1889 *e10.3,2x,'y=',e10.3)
1890 202 format(2x,'vin=',e10.3,2x,'vcu=',e10.3,2x,'vdt=',e10.3)
1891 203 format(2x,'epov - end')
1892 return
1893 end
1894
1895 c------------------------------------------------------------------------
1896 subroutine psfz(iqq,gz2,b)
1897 c-----------------------------------------------------------------------
1898 c hadron-nucleus cross sections calculation
1899 c b - impact parameter squared
1900 C iqq - 1 = elastic cross section
1901 C 2 = inelastic cross section
1902 c-----------------------------------------------------------------------
1903 double precision PhiExpo
1904 include 'epos.inc'
1905 include 'epos.incems'
1906 include 'epos.incpar'
1907 common /ar3/ x1(7),a1(7)
1908 external pttcs,pprcs
1909
1910 gz2=0.
1911 e1=exp(-1.)
1912 if(iomega.eq.2)then !no dif
1913 rs=r2had(iclpro)+r2had(icltar)+slopom*log(engy**2)
1914 else
1915 rs=r2had(iclpro)+r2had(icltar)+max(slopom,slopoms)*log(engy**2)
1916 & +gwidth*(r2had(iclpro)+r2had(icltar))
1917 & +bmxdif(iclpro,icltar)/4./0.0389
1918 endif
1919 rpom=4.*.0389*rs
1920 kollini=koll !koll modified in zzfz
1921 koll=1
1922 if(iscreen.ne.0.and.(maproj.gt.1.or.matarg.gt.1))then
1923 call zzfz(zzp,zzt,kollth,b)
1924 koll=kollth
1925 else
1926 zzp=0.
1927 zzt=0.
1928 endif
1929
1930 do i1=1,7
1931 do m=1,2
1932 z=.5+x1(i1)*(m-1.5)
1933 zv1=exp(-z)
1934 zv2=(e1*z)
1935 b1=sqrt(-rpom*log(zv1))
1936 b2=sqrt(-rpom*log(zv2))
1937
1938 if(maproj.eq.1.and.matarg.eq.1)then
1939 cg1=1.
1940 cg2=1.
1941 elseif(matarg.eq.1)then
1942 cg1=ptrot(pprcs,b,b1)
1943 cg2=ptrot(pprcs,b,b2)
1944 else
1945 cg1=ptrot(pttcs,b,b1)
1946 cg2=ptrot(pttcs,b,b2)
1947 endif
1948
1949 vv21=sngl(Phiexpo(zzp,zzt,1.,1.d0,1.d0,engy**2,b1))
1950 vv22=sngl(Phiexpo(zzp,zzt,1.,1.d0,1.d0,engy**2,b2))
1951 if(iqq.ne.1)then
1952 gz2=gz2+a1(i1)*(cg1*(1.-vv21)+cg2*(1.-vv22)/z)
1953 else
1954 vv11=sngl(Phiexpo(zzp,zzt,0.5,1.d0,1.d0,engy**2,b1))
1955 vv12=sngl(Phiexpo(zzp,zzt,0.5,1.d0,1.d0,engy**2,b2))
1956 gz2=gz2+a1(i1)*(cg1*(vv21-2.*vv11+1.)
1957 & +cg2*(vv22-2.*vv12+1.)/z)
1958 endif
1959 enddo
1960 enddo
1961 gz2=gz2*rpom*0.5
1962
1963 koll=kollini
1964
1965 return
1966 end
1967
1968 c------------------------------------------------------------------------
1969 subroutine zzfz(zzp,zzt,kollth,b)
1970 c-----------------------------------------------------------------------
1971 c hadron-nucleus cross sections calculation
1972 c b - impact parameter squared
1973 C xsfct - 0.5 = total cross section
1974 C 1.0 = inelastic cross section
1975 c-----------------------------------------------------------------------
1976 common /psar50/ zznuc,b2xnuc
1977 include 'epos.inc'
1978 include 'epos.incems'
1979 include 'epos.incpar'
1980 common /ar3/ x1(7),a1(7)
1981 external pttcs,pprcs,pttzz,pprzz
1982
1983 zzp=0.
1984 zzt=0.
1985 kollth=1
1986 if(iscreen.eq.0.or.(maproj.eq.1.and.matarg.eq.1))return
1987
1988 rs=r2had(iclpro)+r2had(icltar)+slopom*log(engy**2)
1989 rpom=4.*.0389*rs
1990 bgl2=2.*rpom*epscrp
1991 zzpp=epscrw*fscra(engy/egyscr)
1992 c caculate the radius where Z is saturated at epscrx to define the bases
1993 c of nuclear shadowing
1994 satrad=0.
1995 if(zzpp.gt.0.)satrad=-bgl2*log(epscrx/zzpp)
1996 bglx=zbrads*sqrt(max(0.1,satrad))
1997 fzbrmax=1.
1998 if(zbrmax.gt.0)fzbrmax=zbrmax
1999 fzbcut=1.
2000 if(zbcut.gt.0)fzbcut=zbcut*bglx
2001 fzbrads=1.
2002 if(bglx.gt.0)fzbrads=bglx
2003 fnuc=1.2*fzbcut/fzbrads
2004 b2xnuc=bgl2+4.*fzbrmax*sqrt(float(maproj*matarg))*fnuc
2005
2006
2007 e1=exp(-1.)
2008
2009 colp=0.
2010 colt=0.
2011 do i1=1,7
2012 do m=1,2
2013 z=.5+x1(i1)*(m-1.5)
2014 zv1=exp(-z)
2015 zv2=(e1*z)
2016 b1=sqrt(-rpom*log(zv1))
2017 b2=sqrt(-rpom*log(zv2))
2018
2019
2020 if(maproj.gt.1)then
2021 cg1=ptrot(pprcs,b,b1)
2022 cg2=ptrot(pprcs,b,b2)
2023 colnuc=a1(i1)*(cg1+cg2/z)
2024 colp=colp+colnuc
2025 rho=0.05
2026 zznuc=epscrw*fscro(engy/egyscr,rho)
2027 zp1=ptrot(pprzz,b,b1)
2028 zp2=ptrot(pprzz,b,b2)
2029 zzp=zzp+a1(i1)*(zp1+zp2/z)
2030 endif
2031 if(matarg.gt.1)then
2032 cg1=ptrot(pttcs,b,b1)
2033 cg2=ptrot(pttcs,b,b2)
2034 colnuc=a1(i1)*(cg1+cg2/z)
2035 colt=colt+colnuc
2036 rho=0.05
2037 zznuc=epscrw*fscro(engy/egyscr,rho)
2038 zt1=ptrot(pttzz,b,b1)
2039 zt2=ptrot(pttzz,b,b2)
2040 zzt=zzt+a1(i1)*(zt1+zt2/z)
2041 endif
2042
2043 enddo
2044 enddo
2045 colp=sqrt(colp)
2046 colt=sqrt(colt)
2047 if(colp.gt.1.)then
2048 kollth=nint(max(1.,colp))
2049 colp=fnuc*log(colp)
2050 zzp=sqrt(zzp)
2051 zzp=0.01*zzp*colp*bgl2
2052 c saturation
2053 zzp=min(zzp,colp*epscrx)
2054 else
2055 zzp=0.
2056 endif
2057 if(colt.gt.1.)then
2058 kollth=nint(max(1.,kollth+colt))
2059 colt=fnuc*log(colt)
2060 zzt=sqrt(zzt)
2061 zzt=0.01*zzt*colt*bgl2
2062 c saturation
2063 zzt=min(zzt,colt*epscrx)
2064 else
2065 zzt=0.
2066 endif
2067 c zzp=zzp*2. !correction to have formula=MC
2068 c zzt=zzt*2.
2069
2070 c print *,'ici',b,zzp,zzt,kollth,b2xnuc
2071
2072 return
2073 end
2074
2075
2076 c------------------------------------------------------------------------
2077 function ptgau(func,bm,ipt,iqq)
2078 c-----------------------------------------------------------------------
2079 c impact parameter integration for impact parameters <bm -
2080 c for nucleus-nucleus and hadron-nucleus cross-sections calculation
2081 c ipt=1 : projectile, ipt=2 : target
2082 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2083 c-----------------------------------------------------------------------
2084 include 'epos.inc'
2085 common /ar3/ x1(7),a1(7)
2086 external func
2087
2088 ptgau=0.
2089 do i=1,7
2090 do m=1,2
2091 b=bm*sqrt(.5+x1(i)*(m-1.5))
2092 ptgau=ptgau+func(b,ipt,iqq)*a1(i)
2093 enddo
2094 enddo
2095 ptgau=ptgau*bm**2*pi*.5
2096 return
2097 end
2098
2099 c------------------------------------------------------------------------
2100 function ptgau1(bm,ipt,iqq)
2101 c-----------------------------------------------------------------------
2102 c impact parameter integration for impact parameters >bm -
2103 c for hadron-nucleus cross-sections calculation
2104 c ipt=1 : projectile, ipt=2 : target
2105 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2106 c-----------------------------------------------------------------------
2107 include 'epos.inc'
2108 common /ar5/ x5(2),a5(2)
2109
2110 ptgau1=0.
2111 if(ipt.eq.1)then
2112 difn=difnuc(maproj)
2113 else
2114 difn=difnuc(matarg)
2115 endif
2116 do i=1,2
2117 b=bm+x5(i)*difn
2118 ptgau1=ptgau1+ptfau(b,ipt,iqq)*a5(i)*exp(x5(i))*b*2.*pi*difn
2119 enddo
2120 return
2121 end
2122 c------------------------------------------------------------------------
2123 function ptgau2(bm,iqq)
2124 c-----------------------------------------------------------------------
2125 c impact parameter integration for impact parameters >bm -
2126 c for nucleus-nucleus cross-sections calculation
2127 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2128 c-----------------------------------------------------------------------
2129 include 'epos.inc'
2130 common /ar5/ x5(2),a5(2)
2131
2132 ptgau2=0.
2133 difn=difnuc(maproj)+difnuc(matarg)
2134 do i=1,2
2135 b=bm+x5(i)*difn
2136 ptgau2=ptgau2+ptfauAA(b,iqq)*a5(i)*exp(x5(i))*b*2.*pi*difn
2137 enddo
2138 return
2139 end
2140
2141
2142 c------------------------------------------------------------------------
2143 function ptfau(b,ipt,iqq)
2144 c-----------------------------------------------------------------------
2145 c ptfau - integrands for hadron-nucleus cross-sections calculation
2146 c ipt=1 : projectile, ipt=2 : target
2147 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2148 c-----------------------------------------------------------------------
2149 include 'epos.inc'
2150 common /psar35/ anorm,anormp
2151
2152 call psfz(iqq,gz2,b)
2153
2154 if(ipt.eq.1)then
2155 ptfau=1.-max(0.,(1.-anormp*gz2))**maproj
2156 else
2157 ptfau=1.-max(0.,(1.-anorm*gz2))**matarg
2158 endif
2159
2160 return
2161 end
2162
2163 c------------------------------------------------------------------------
2164 function ptfauAA(b,iqq)
2165 c-----------------------------------------------------------------------
2166 c ptfau - integrands for hadron-nucleus cross-sections calculation
2167 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2168 c-----------------------------------------------------------------------
2169 include 'epos.inc'
2170 common /ar3/ x1(7),a1(7)
2171 common /psar35/ anorm,anormp
2172 external pprcs
2173
2174 ptfauAA=0.
2175 e1=exp(-1.)
2176 rs=r2had(iclpro)+r2had(icltar)+max(slopom,slopoms)*log(engy**2)
2177 & +gwidth*(r2had(iclpro)+r2had(icltar))
2178 & +bmxdif(iclpro,icltar)/4./0.0389
2179 rpom=4.*.0389*rs
2180 do i1=1,7
2181 do m=1,2
2182 z=.5+x1(i1)*(m-1.5)
2183 zv1=exp(-z)
2184 zv2=(e1*z)
2185 b1=sqrt(-rpom*log(zv1))
2186 b2=sqrt(-rpom*log(zv2))
2187 call psfz(iqq,gz21,b1)
2188 call psfz(iqq,gz22,b2)
2189 ptfau1=max(0.,(1.-anorm*gz21))**matarg
2190 ptfau2=max(0.,(1.-anorm*gz22))**matarg
2191 cg1=ptrot(pprcs,b,b1)
2192 cg2=ptrot(pprcs,b,b2)
2193 ptfauAA=ptfauAA+a1(i1)*(cg1*(1.-ptfau1)+cg2*(1.-ptfau2)/z)
2194 enddo
2195 enddo
2196 ptfauAA=ptfauAA*rpom/2.
2197 ptfauAA=1.-max(0.,(1.-anormp*ptfauAA))**maproj
2198
2199 return
2200 end
2201
2202 c------------------------------------------------------------------------
2203 function ptrot(func,s,b)
2204 c-----------------------------------------------------------------------
2205 c convolution of nuclear profile functions (axial angle integration)
2206 c-----------------------------------------------------------------------
2207 common /ar8/ x2(4),a2
2208 external func
2209
2210 ptrot=0.
2211 do i=1,4
2212 sb1=b**2+s**2-2.*b*s*(2.*x2(i)-1.)
2213 sb2=b**2+s**2-2.*b*s*(1.-2.*x2(i))
2214 ptrot=ptrot+(func(sb1)+func(sb2))
2215 enddo
2216 ptrot=ptrot*a2
2217 return
2218 end
2219
2220 c------------------------------------------------------------------------
2221 function pttcs(b0)
2222 c-----------------------------------------------------------------------
2223 c ptt - nuclear profile function value at imp param squared b*difnuc**2
2224 c-----------------------------------------------------------------------
2225 include 'epos.inc'
2226 common /psar34/ rrr,rrrm
2227 common /ar5/ x5(2),a5(2)
2228 common /ar9/ x9(3),a9(3)
2229
2230 b=b0/difnuc(matarg)**2
2231 pttcs=0.
2232 zm=rrrm**2-b
2233 if(zm.gt.4.*b)then
2234 zm=sqrt(zm)
2235 else
2236 zm=2.*sqrt(b)
2237 endif
2238
2239 do i=1,3
2240 z1=zm*(1.+x9(i))*0.5
2241 z2=zm*(1.-x9(i))*0.5
2242 quq=sqrt(b+z1**2)-rrr
2243 if (quq.lt.85.)pttcs=pttcs+a9(i)/(1.+exp(quq))
2244 quq=sqrt(b+z2**2)-rrr
2245 if (quq.lt.85.)pttcs=pttcs+a9(i)/(1.+exp(quq))
2246 enddo
2247 pttcs=pttcs*zm*0.5
2248
2249 dt=0.
2250 do i=1,2
2251 z1=x5(i)+zm
2252 quq=sqrt(b+z1**2)-rrr-x5(i)
2253 if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
2254 enddo
2255
2256 pttcs=pttcs+dt
2257 return
2258 end
2259
2260
2261 c------------------------------------------------------------------------
2262 function pttzz(b0)
2263 c-----------------------------------------------------------------------
2264 c ptt - nuclear Z function value at imp param squared b*difnuc**2
2265 c-----------------------------------------------------------------------
2266 include 'epos.inc'
2267 include 'epos.incpar'
2268 common /psar34/ rrr,rrrm
2269 common /psar50/ zznuc,b2xnuc
2270 common /ar5/ x5(2),a5(2)
2271 common /ar9/ x9(3),a9(3)
2272
2273 pttzz=0.
2274 b=b0/difnuc(matarg)**2
2275 c absb=max(1.e-9,sqrt(b0)-zbcut)
2276 absb=max(1.e-9,sqrt(b0))
2277 bsq=absb*absb
2278 zm=rrrm**2-b
2279 if(zm.gt.4.*b)then
2280 zm=sqrt(zm)
2281 else
2282 zm=2.*sqrt(b)
2283 endif
2284
2285 do i=1,3
2286 z1=zm*(1.+x9(i))*0.5
2287 z2=zm*(1.-x9(i))*0.5
2288 quq=sqrt(b+z1**2)-rrr
2289 if (quq.lt.85.)pttzz=pttzz+a9(i)/(1.+exp(quq))
2290 quq=sqrt(b+z2**2)-rrr
2291 if (quq.lt.85.)pttzz=pttzz+a9(i)/(1.+exp(quq))
2292 enddo
2293 pttzz=pttzz*zm*0.5
2294
2295 dt=0.
2296 do i=1,2
2297 z1=x5(i)+zm
2298 quq=sqrt(b+z1**2)-rrr-x5(i)
2299 if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
2300 enddo
2301
2302 pttzz=max(0.,(pttzz+dt)-1.)*zznuc*exp(-bsq/2./b2xnuc)
2303
2304 return
2305 end
2306
2307 c------------------------------------------------------------------------
2308 function pprcs(b0)
2309 c-----------------------------------------------------------------------
2310 c ppr - nuclear profile function value at imp param squared b*difnuc**2
2311 c-----------------------------------------------------------------------
2312 include 'epos.inc'
2313 common /psar41/ rrrp,rrrmp
2314 common /ar5/ x5(2),a5(2)
2315 common /ar9/ x9(3),a9(3)
2316
2317 b=b0/difnuc(maproj)**2
2318 pprcs=0.
2319 zm=rrrmp**2-b
2320 if(zm.gt.4.*b)then
2321 zm=sqrt(zm)
2322 else
2323 zm=2.*sqrt(b)
2324 endif
2325
2326 do i=1,3
2327 z1=zm*(1.+x9(i))*0.5
2328 z2=zm*(1.-x9(i))*0.5
2329 quq=sqrt(b+z1**2)-rrrp
2330 if (quq.lt.85.)pprcs=pprcs+a9(i)/(1.+exp(quq))
2331 quq=sqrt(b+z2**2)-rrrp
2332 if (quq.lt.85.)pprcs=pprcs+a9(i)/(1.+exp(quq))
2333 enddo
2334 pprcs=pprcs*zm*0.5
2335
2336 dt=0.
2337 do i=1,2
2338 z1=x5(i)+zm
2339 quq=sqrt(b+z1**2)-rrrp-x5(i)
2340 if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
2341 enddo
2342
2343 pprcs=pprcs+dt
2344 return
2345 end
2346
2347 c------------------------------------------------------------------------
2348 function pprzz(b0)
2349 c-----------------------------------------------------------------------
2350 c ppr - Z nuclear function value at imp param squared b*difnuc**2
2351 c-----------------------------------------------------------------------
2352 include 'epos.inc'
2353 include 'epos.incpar'
2354 common /psar41/ rrrp,rrrmp
2355 common /psar50/ zznuc,b2xnuc
2356 common /ar5/ x5(2),a5(2)
2357 common /ar9/ x9(3),a9(3)
2358
2359 pprzz=0.
2360 b=b0/difnuc(maproj)**2
2361 c absb=max(1.e-9,sqrt(b0)-zbcut)
2362 absb=max(1.e-9,sqrt(b0))
2363 bsq=absb*absb
2364 zm=rrrmp**2-b
2365 if(zm.gt.4.*b)then
2366 zm=sqrt(zm)
2367 else
2368 zm=2.*sqrt(b)
2369 endif
2370
2371 do i=1,3
2372 z1=zm*(1.+x9(i))*0.5
2373 z2=zm*(1.-x9(i))*0.5
2374 quq=sqrt(b+z1**2)-rrrp
2375 if (quq.lt.85.)pprzz=pprzz+a9(i)/(1.+exp(quq))
2376 quq=sqrt(b+z2**2)-rrrp
2377 if (quq.lt.85.)pprzz=pprzz+a9(i)/(1.+exp(quq))
2378 enddo
2379 pprzz=pprzz*zm*0.5
2380
2381 dt=0.
2382 do i=1,2
2383 z1=x5(i)+zm
2384 quq=sqrt(b+z1**2)-rrrp-x5(i)
2385 if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
2386 enddo
2387
2388 pprzz=max(0.,(pprzz+dt)-1.)*zznuc*exp(-bsq/2./b2xnuc)
2389
2390 return
2391 end
2392
2393 c------------------------------------------------------------------------------
2394 function pscrse(ek,mapr,matg,iqq)
2395 c------------------------------------------------------------------------------
2396 c hadron-nucleus (hadron-proton) and nucl-nucl particle production cross section
2397 c ek - lab kinetic energy for the interaction
2398 c maproj - projec mass number
2399 c matarg - target mass number
2400 c iqq=1 - ela cross section
2401 c >2 - ine cross section (2 used for cut (changing iomega), 3 uses table,
2402 c 4 used for ine without table)
2403 c------------------------------------------------------------------------------
2404 dimension wk(3),wa(3),wb(3)
2405 include 'epos.inc'
2406 common /psar33/ asect(7,4,7),asectn(7,7,7)
2407 common /psar34/ rrr,rrrm
2408 common /psar35/ anorm,anormp
2409 common /psar41/ rrrp,rrrmp
2410 external ptfau,ptfauAA
2411
2412 pscrse=0.
2413 call idmass(1120,amt1)
2414 call idmass(1220,amt2)
2415 amtar=0.5*(amt1+amt2)
2416 if(matg.eq.1)amtar=amt1
2417 if(mapr.eq.1)then
2418 call idmass(idproj,ampro)
2419 else
2420 ampro=amtar
2421 endif
2422 egy=ek+ampro
2423 c p=sqrt(max(0.,egy**2-ampro**2))
2424 egy=sqrt( 2*egy*amtar+amtar**2+ampro**2 )
2425
2426 if(isetcs.le.1.or.iqq.ne.3)then
2427 maprojsave=maproj
2428 matargsave=matarg
2429 engysave=engy
2430 maproj=mapr
2431 matarg=matg
2432 engy=egy
2433 if(matg.eq.1.and.mapr.eq.1)then
2434 if(iqq.eq.1)then !sig ela
2435 call psfz(1,gz2,0.)
2436 else !sig ine
2437 call psfz(2,gz2,0.)
2438 endif
2439 gin=gz2*pi*10.
2440 elseif(mapr.eq.1)then
2441 rad=radnuc(matg)
2442 bm=rad+2.
2443 rrr=rad/difnuc(matg)
2444 rrrm=rrr+log(9.)
2445 anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matg)**2
2446 if(iqq.ne.1)then
2447 gin=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig ine
2448 else
2449 gin=(ptgau(ptfau,bm,2,1)+ptgau1(bm,2,1))*10. !sig ela
2450 endif
2451 elseif(matg.eq.1)then
2452 rad=radnuc(mapr)
2453 bm=rad+2.
2454 rrrp=rad/difnuc(mapr)
2455 rrrmp=rrrp+log(9.)
2456 anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(mapr)**2
2457 if(iqq.ne.1)then
2458 gin=(ptgau(ptfau,bm,1,2)+ptgau1(bm,1,2))*10. !sig ine
2459 else
2460 gin=(ptgau(ptfau,bm,1,1)+ptgau1(bm,1,1))*10. !sig ela
2461 endif
2462 else
2463 rad=radnuc(matg)+1.
2464 radp=radnuc(mapr)+1.
2465 bm=rad+radp+2.
2466 rrr=rad/difnuc(matg)
2467 rrrm=rrr+log(9.)
2468 rrrp=radp/difnuc(mapr)
2469 rrrmp=rrrp+log(9.)
2470 anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matg)**2
2471 anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(mapr)**2
2472 if(iqq.ne.1)then
2473 gin=(ptgau(ptfauAA,bm,2,2)+ptgau2(bm,2))*10. !sig ine
2474 else
2475 gin=(ptgau(ptfauAA,bm,2,1)+ptgau2(bm,1))*10. !sig ela
2476 endif
2477 endif
2478 pscrse=gin
2479 maproj=maprojsave
2480 matarg=matargsave
2481 engy=engysave
2482 else
2483 ye=log10(max(1.,egy/1.5))+1.
2484 je=min(5,int(ye))
2485
2486 wk(2)=ye-je
2487 wk(3)=wk(2)*(wk(2)-1.)*.5
2488 wk(1)=1.-wk(2)+wk(3)
2489 wk(2)=wk(2)-2.*wk(3)
2490
2491 ya=matg
2492 ya=log(ya)/.69315+1.
2493 ja=min(int(ya),4)
2494 wa(2)=ya-ja
2495 wa(3)=wa(2)*(wa(2)-1.)*.5
2496 wa(1)=1.-wa(2)+wa(3)
2497 wa(2)=wa(2)-2.*wa(3)
2498
2499 if(mapr.eq.1)then
2500
2501 do i=1,3
2502 do m=1,3
2503 pscrse=pscrse+asect(je+i-1,iclpro,ja+m-1)*wk(i)*wa(m)
2504 enddo
2505 enddo
2506
2507 else
2508
2509 yb=mapr
2510 yb=log(yb)/.69315+1.
2511 jb=min(int(yb),4)
2512 wb(2)=yb-jb
2513 wb(3)=wb(2)*(wb(2)-1.)*.5
2514 wb(1)=1.-wb(2)+wb(3)
2515 wb(2)=wb(2)-2.*wb(3)
2516
2517 do i=1,3
2518 do m=1,3
2519 do n=1,3
2520 pscrse=pscrse+asectn(je+i-1,jb+n-1,ja+m-1)*wk(i)*wa(m)*wb(n)
2521 enddo
2522 enddo
2523 enddo
2524
2525 endif
2526
2527 pscrse=exp(pscrse)
2528 endif
2529 return
2530 end
2531
2532 c------------------------------------------------------------------------------
2533 function eposcrse(ek,mapro,matar,id)
2534 c------------------------------------------------------------------------------
2535 c inelastic cross section of epos
2536 c (id=0 corresponds to air)
2537 c ek - kinetic energy for the interaction
2538 c maproj - projec mass number (1<maproj<64)
2539 c matarg - target mass number (1<matarg<64)
2540 c------------------------------------------------------------------------------
2541 include 'epos.inc'
2542
2543 eposcrse=0.
2544 if(id.eq.0)then
2545 do k=1,3
2546 mt=int(airanxs(k))
2547 eposcrse=eposcrse+airwnxs(k)*pscrse(ek,mapro,mt,3)
2548 enddo
2549 else
2550 eposcrse=pscrse(ek,mapro,matar,3)
2551 endif
2552
2553 return
2554 end
2555
2556 c------------------------------------------------------------------------------
2557 function eposinecrse(ek,mapro,matar,id)
2558 c------------------------------------------------------------------------------
2559 c inelastic cross section of epos not using tabulated xs
2560 c (id=0 corresponds to air)
2561 c ek - kinetic energy for the interaction
2562 c maproj - projec mass number (1<maproj<64)
2563 c matarg - target mass number (1<matarg<64)
2564 c------------------------------------------------------------------------------
2565 include 'epos.inc'
2566
2567 eposinecrse=0.
2568 if(id.eq.0)then
2569 do k=1,3
2570 mt=int(airanxs(k))
2571 eposinecrse=eposinecrse+airwnxs(k)*pscrse(ek,mapro,mt,4)
2572 enddo
2573 else
2574 eposinecrse=pscrse(ek,mapro,matar,4)
2575 endif
2576
2577 return
2578 end
2579
2580 c------------------------------------------------------------------------------
2581 function eposelacrse(ek,mapro,matar,id)
2582 c------------------------------------------------------------------------------
2583 c elastic cross section of epos
2584 c (id=0 corresponds to air)
2585 c ek - kinetic energy for the interaction
2586 c maproj - projec mass number (1<maproj<64)
2587 c matarg - target mass number (1<matarg<64)
2588 c------------------------------------------------------------------------------
2589 include 'epos.inc'
2590
2591 eposelacrse=0.
2592 if(id.eq.0)then
2593 do k=1,3
2594 mt=int(airanxs(k))
2595 eposelacrse=eposelacrse+airwnxs(k)*pscrse(ek,mapro,mt,1)
2596 enddo
2597 else
2598 eposelacrse=pscrse(ek,mapro,matar,1)
2599 endif
2600
2601 return
2602 end
2603
2604
2605 c------------------------------------------------------------------------------
2606 function eposcutcrse(ek,mapro,matar,id)
2607 c------------------------------------------------------------------------------
2608 c total cross section of epos
2609 c (id=0 corresponds to air)
2610 c ek - kinetic energy for the interaction
2611 c maproj - projec mass number (1<maproj<64)
2612 c matarg - target mass number (1<matarg<64)
2613 c------------------------------------------------------------------------------
2614 include 'epos.inc'
2615
2616 eposcutcrse=0.
2617 iomegasave=iomega
2618 iomega=2
2619 if(id.eq.0)then
2620 do k=1,3
2621 mt=int(airanxs(k))
2622 eposcutcrse=eposcutcrse+airwnxs(k)*pscrse(ek,mapro,mt,2)
2623 enddo
2624 else
2625 eposcutcrse=pscrse(ek,mapro,matar,2)
2626 endif
2627 iomega=iomegasave
2628
2629 return
2630 end
2631
2632 c------------------------------------------------------------------------------
2633 subroutine crseaaEpos(sigt,sigi,sigc,sige)
2634 c------------------------------------------------------------------------------
2635 c nucleus-nucleus (hadron) cross section of epos from simplified (realistic)
2636 c simulations
2637 c (id=0 corresponds to air)
2638 c sigt = sig tot
2639 c sigi = sig inelastic (cut + projectile diffraction)
2640 c sigc = sig cut
2641 c sige = sig elastic (includes target diffraction)
2642 c------------------------------------------------------------------------------
2643 include 'epos.inc'
2644 niter=20000
2645 if(idtarg.eq.0)then
2646 sigt=0.
2647 sigc=0.
2648 sigi=0.
2649 sige=0.
2650 sigd=0.
2651 sigql=0.
2652 do k=1,3
2653 matarg=int(airanxs(k))
2654 call epocrossc(niter,xsigt,xsigi,xsigc,xsige,xsigql,xsigd)
2655 sigt=sigt+airwnxs(k)*xsigt
2656 sigi=sigi+airwnxs(k)*xsigi
2657 sigc=sigc+airwnxs(k)*xsigc
2658 sige=sige+airwnxs(k)*xsige
2659 sigd=sigd+airwnxs(k)*xsigd
2660 sigql=sigql+airwnxs(k)*xsigql
2661 enddo
2662 else
2663 call epocrossc(niter,sigt,sigi,sigc,sige,sigql,sigd)
2664 endif
2665 if(ionudi.ne.1)then
2666 sige=sige+sigql !add non-excited diffractive projectile to elastic
2667 sigi=sigi-sigql !do not count non-excited diffractive projectile in inelastic
2668 if(maproj+matarg.gt.2)then
2669 sigc=sigc+sigd*0.95 !for absorbtion cross section remove 5% of the
2670 !excited projectile diffractive cross section
2671 !which "looks like" non excited (approximation)
2672 endif
2673 endif
2674 end
2675
2676
2677 cc------------------------------------------------------------------------
2678 c function pshard1(sy,xpp,xpm,z)
2679 cc-----------------------------------------------------------------------
2680 cc pshard - qq-pomeron eikonal
2681 cc sy - energy squared for the pomeron,
2682 cc xpp - lc+ for the pomeron,
2683 cc xpm - lc- for the pomeron
2684 cc-----------------------------------------------------------------------
2685 c common /ar3/ x1(7),a1(7)
2686 c common /ar9/ x9(3),a9(3)
2687 c include 'epos.inc'
2688 c include 'epos.incsem'
2689 c
2690 c pshard1=0.
2691 c if(iclpro.ne.4.and.icltar.ne.4)then
2692 c spmin=4.*q2min
2693 c else
2694 c spmin=4.*q2min+2.*qcmass**2
2695 c endif
2696 c if(sy.le.spmin)return
2697 c
2698 c rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
2699 c alpq=(alppar+1.)/2.
2700 c xmin=spmin/sy !min hard pomeron mass share
2701 c xminl=xmin**(delh+.5)
2702 c
2703 c do i=1,3
2704 c do m=1,2
2705 c zh=(.5*(1.+xminl-(2*m-3)*x9(i)*(1.-xminl)))**(1./(delh+.5))
2706 c if(iclpro.ne.4.and.icltar.ne.4)then
2707 c call psjti0(zh*sy,sqq,sqqb,1,1)
2708 c call psjti0(zh*sy,sqqp,sqqpb,1,2)
2709 c call psjti0(zh*sy,sqaq,sqaqb,-1,1)
2710 c else
2711 c call psjti0(zh*sy,sqq,sqqb,4,1)
2712 c sqq=0.
2713 c sqaq=0.
2714 c endif
2715 c
2716 c stq=0.
2717 c do i1=1,3
2718 c do m1=1,2
2719 c xx=.5+x9(i1)*(m1-1.5)
2720 c xp=zh**xx
2721 c xm=zh/xp
2722 c if(xp*xpp.le..9999.and.xm*xpm.le..9999.or.
2723 c * xm*xpp.le..9999.and.xp*xpm.le..9999)then
2724 c stq=stq+a9(i1)*psharf(xp*xpp,xm*xpm,sqq,sqqp,sqaq)
2725 c * *(1.-xp)**(1.+alplea(iclpro)-alpq)
2726 c * *(1.-xm)**(1.+alplea(icltar)-alpq)
2727 c endif
2728 c enddo
2729 c enddo
2730 c pshard1=pshard1-a9(i)*stq/zh**(delh+0.5)*log(zh)
2731 c enddo
2732 c enddo
2733 c pshard1=pshard1*(1.-xminl)/(delh+.5)/4.*factk
2734 c **chad(iclpro)*chad(icltar)*(xpp*xpm)**(1.-alpq)
2735 c **z**(rp/(r2had(iclpro)+r2had(icltar)))
2736 c */(8.*pi*(r2had(iclpro)+r2had(icltar)))
2737 c return
2738 c end
2739 c
2740 c------------------------------------------------------------------------
2741 function pshard(sy,xpp,xpm)
2742 c-----------------------------------------------------------------------
2743 c pshard - qq-pomeron eikonal
2744 c sy - energy squared for the pomeron,
2745 c xpp - lc+ for the pomeron,
2746 c xpm - lc- for the pomeron
2747 c-----------------------------------------------------------------------
2748 double precision z01
2749 common /ar3/ x1(7),a1(7)
2750 include 'epos.inc'
2751 include 'epos.incsem'
2752
2753 pshard=0.
2754 if(iclpro.ne.4.and.icltar.ne.4)then
2755 spmin=4.*q2min
2756 else
2757 spmin=4.*q2min+2.*qcmass**2
2758 endif
2759 if(sy.le.spmin)return
2760
2761 alpq=(alppar+1.)/2.
2762 xmin=spmin/sy !min hard pomeron mass share
2763 xminl=xmin**(delh+.5)
2764
2765 do i=1,7
2766 do m=1,2
2767 zh=(.5*(1.+xminl-(2*m-3)*x1(i)*(1.-xminl)))**(1./(delh+.5))
2768 if(iclpro.ne.4.and.icltar.ne.4)then
2769 call psjti0(zh*sy,sqq,sqqb,1,1)
2770 call psjti0(zh*sy,sqqp,sqqpb,1,2)
2771 call psjti0(zh*sy,sqaq,sqaqb,-1,1)
2772 else
2773 call psjti0(zh*sy,sqq,sqqb,4,1)
2774 sqqp=0.
2775 sqaq=0.
2776 endif
2777
2778 stq=0. !int^1_(sqrt(z)) dx_p / x_p / sqrt(1-x_p) =int^(tmax)_(0) dt
2779 tmax=sqrt(1.-sqrt(zh)) !t=ln((1+sqrt(1-x_p))/(1-sqrt(1-x_p)))
2780 tmax=log((1.+tmax)/(1.-tmax))
2781 if(tmax.gt.1.e-20)then
2782 do i1=1,7
2783 do m1=1,2
2784 t=tmax*(.5+x1(i1)*(m1-1.5))
2785 z01=((1.d0-exp(-1.d0*t))/(1.d0+exp(-1.d0*t)))**2
2786 xp=1.-z01
2787 xm=zh/xp
2788 if(xp*xpp.le..9999.and.xm*xpm.le..9999.or.
2789 * xm*xpp.le..9999.and.xp*xpm.le..9999)then
2790 stq=stq+a1(i1)*(psharf(xp*xpp,xm*xpm,sqq,sqqp,sqaq)+
2791 * psharf(xm*xpp,xp*xpm,sqq,sqqp,sqaq))
2792 * *z01**(.5-alpq)/(1.-xm)**alpq
2793 endif
2794 enddo
2795 enddo
2796 stq=stq*tmax
2797 endif
2798 pshard=pshard+a1(i)*stq/zh**(delh+0.5)
2799 enddo
2800 enddo
2801 pshard=pshard*(1.-xminl)/(delh+.5)/4.*
2802 *utgam1(2.+alplea(iclpro)-alpq)/utgam1(1.+alplea(iclpro))/
2803 *utgam1(1.-alpq)*
2804 *utgam1(2.+alplea(icltar)-alpq)/utgam1(1.+alplea(icltar))/
2805 *utgam1(1.-alpq)*
2806 *chad(iclpro)*chad(icltar)/(8.*pi*(r2had(iclpro)+r2had(icltar)))*
2807 *(xpp*xpm)**(-alpq)/sy**delh
2808 return
2809 end
2810
2811 c------------------------------------------------------------------------
2812 function psharf(zh1,zh2,sqq,sqqp,sqaq)
2813 c-----------------------------------------------------------------------
2814 include 'epos.incsem'
2815 include 'epos.inc'
2816
2817 alpq=(alppar+1.)/2.
2818 if(zh1.le..9999.and.zh2.le..9999)then
2819 uv1=psdfh4(zh1,q2min,0.,iclpro,1)
2820 dv1=psdfh4(zh1,q2min,0.,iclpro,2)
2821 uv2=psdfh4(zh2,q2min,0.,icltar,1)
2822 dv2=psdfh4(zh2,q2min,0.,icltar,2)
2823 if(iclpro.eq.2.and.icltar.eq.2)then !proton
2824 fff=sqq*(uv1*uv2+dv1*dv2)+sqqp*(uv1*dv2+dv1*uv2)
2825 elseif(iclpro.eq.1.or.icltar.eq.1)then !pion
2826 fff=sqq*uv1*uv2+sqaq*dv1*dv2+sqqp*(uv1*dv2+dv1*uv2)
2827 elseif(iclpro.eq.3.or.icltar.eq.3)then !kaon
2828 fff=sqq*uv1*uv2+sqqp*(uv1*dv2+dv1*uv2+dv1*dv2)
2829 elseif(iclpro.eq.4.or.icltar.eq.4)then !J/psi
2830 fff=sqq*uv1*(uv2+dv2)
2831 else
2832 fff=0.
2833 call utstop("Projectile not know in psharg !&")
2834 endif
2835 psharf=fff*(1.-zh1)**(-1.+alpq-alplea(iclpro))*
2836 * (1.-zh2)**(-1.+alpq-alplea(icltar))
2837 else
2838 psharf=0.
2839 endif
2840 return
2841 end
2842
2843 c------------------------------------------------------------------------
2844 function psvin(sy,xpp,xpm,z,iqq)
2845 c-----------------------------------------------------------------------
2846 c psvin - contributions to the interaction eikonal
2847 c sy - energy squared for the hard interaction,
2848 c xpp - lc+ for the sh pomeron,
2849 c xpm - lc- for the sh pomeron,
2850 c z - impact parameter factor, z=exp(-b**2/4*rp),
2851 c iqq = 1 - gg,
2852 c iqq = 2 - qg,
2853 c iqq = 3 - gq,
2854 c iqq = 4 - qq,
2855 c iqq = 5 - gg(int),
2856 c iqq = 6 - gg(proj),
2857 c iqq = 7 - qg(proj),
2858 c iqq = 9 - total uncut-integrated,
2859 c iqq = 10 - total cut,
2860 c iqq = 14 - gg(int)|b=0,
2861 c iqq = 15 - <b^2*gg(int)>,
2862 c iqq = 16 - gg(proj)|b=0,
2863 c iqq = 17 - <b^2*gg(proj)>,
2864 c iqq = 18 - qg(proj)|b=0,
2865 c iqq = 19 - <b^2*qg(proj)>
2866 c-----------------------------------------------------------------------
2867 dimension wk(3),wi(3),wj(3),wz(3),fa(3)
2868 common /psar2/ edmax,epmax
2869 common /psar4/ fhgg(11,10,8),fhqg(11,10,80)
2870 *,fhgq(11,10,80),fhqq(11,10,80),fhgg0(11,10),fhgg1(11,10,4)
2871 *,fhqg1(11,10,40),fhgg01(11),fhgg02(11),fhgg11(11,4)
2872 *,fhgg12(11,4),fhqg11(11,10,4),fhqg12(11,10,4)
2873 *,ftoint(11,14,2,2,3)
2874 common /psar7/ delx,alam3p,gam3p
2875 include 'epos.inc'
2876 include 'epos.incsem'
2877
2878 if(iqq.eq.3)then
2879 xp=xpm
2880 xm=xpp
2881 iclp=icltar
2882 iclt=iclpro
2883 else
2884 xp=xpp
2885 xm=xpm
2886 iclp=iclpro
2887 iclt=icltar
2888 endif
2889 rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
2890
2891 psvin=0.
2892 if(iqq.eq.1.or.iqq.eq.5.or.iqq.eq.6.or.iqq.eq.14
2893 *.or.iqq.eq.15.or.iqq.eq.16.or.iqq.eq.17
2894 *.or.iclpro.ne.4.and.(iqq.eq.2.or.iqq.eq.7
2895 *.or.iqq.eq.18.or.iqq.eq.19)
2896 *.or.icltar.ne.4.and.iqq.eq.3
2897 *.or.iclpro.ne.4.and.icltar.ne.4)then
2898 spmin=4.*q2min
2899 else
2900 spmin=4.*q2min+2.*qcmass**2
2901 endif
2902 if(sy.le.spmin.and.(iqq.le.7.or.iqq.gt.13))return
2903
2904 if(iqq.le.7.or.iqq.gt.13)then
2905 yl=log(sy/spmin)/log(epmax/2./spmin)*10.+1
2906 k=int(yl)
2907 if(k.gt.9)k=9
2908 wk(2)=yl-k
2909 wk(3)=wk(2)*(wk(2)-1.)*.5
2910 wk(1)=1.-wk(2)+wk(3)
2911 wk(2)=wk(2)-2.*wk(3)
2912
2913 if(iqq.ne.4)then !---------------- not 4 ------------------
2914
2915 if(iqq.eq.5)then
2916 if(k.eq.1)then
2917 psvin=max(0.,exp(fhgg01(k+1))*wk(2)
2918 * +exp(fhgg01(k+2))*wk(3))
2919 else
2920 psvin=exp(fhgg01(k)*wk(1)+fhgg01(k+1)*wk(2)
2921 * +fhgg01(k+2)*wk(3))
2922 endif
2923 psvin=psvin*factk*sy**delh
2924 return
2925
2926 elseif(iqq.eq.15)then
2927 if(k.eq.1)then
2928 psvin=max(0.,exp(fhgg02(k+1))*wk(2)
2929 * +exp(fhgg02(k+2))*wk(3))
2930 else
2931 psvin=exp(fhgg02(k)*wk(1)+fhgg02(k+1)*wk(2)
2932 * +fhgg02(k+2)*wk(3))
2933 endif
2934 psvin=psvin*factk*sy**delh
2935 return
2936
2937 elseif(iqq.eq.6)then
2938 if(k.eq.1)then
2939 psvin=max(0.,exp(fhgg11(k+1,iclpro))*wk(2)
2940 * +exp(fhgg11(k+2,iclpro))*wk(3))
2941 else
2942 psvin=exp(fhgg11(k,iclpro)*wk(1)+fhgg11(k+1,iclpro)*wk(2)
2943 * +fhgg11(k+2,iclpro)*wk(3))
2944 endif
2945 psvin=psvin*factk*sy**delh*xp**(-alppar)
2946 return
2947
2948 elseif(iqq.eq.17)then
2949 if(k.eq.1)then
2950 psvin=max(0.,exp(fhgg12(k+1,iclpro))*wk(2)
2951 * +exp(fhgg12(k+2,iclpro))*wk(3))
2952 else
2953 psvin=exp(fhgg12(k,iclpro)*wk(1)+fhgg12(k+1,iclpro)*wk(2)
2954 * +fhgg12(k+2,iclpro)*wk(3))
2955 endif
2956 psvin=psvin*factk*sy**delh*xp**(-alppar)
2957 return
2958
2959 elseif(iqq.eq.7.or.iqq.eq.19)then
2960 if(xp.lt..2)then
2961 xl=log(10.*xp)/log(2.)+5.
2962 else
2963 xl=5.*xp+5.
2964 endif
2965 i=int(xl)
2966 if(i.lt.1)i=1
2967 if(i.eq.5)i=4
2968 if(i.gt.8)i=8
2969 wi(2)=xl-i
2970 wi(3)=wi(2)*(wi(2)-1.)*.5
2971 wi(1)=1.-wi(2)+wi(3)
2972 wi(2)=wi(2)-2.*wi(3)
2973 do k1=1,3
2974 fa(k1)=0.
2975 do i1=1,3
2976 k2=k+k1-1
2977 fhhh=0.
2978 if(iqq.eq.7)then
2979 fhhh=fhqg11(k2,i+i1-1,iclpro)
2980 elseif(iqq.eq.19)then
2981 fhhh=fhqg12(k2,i+i1-1,iclpro)
2982 endif
2983 fa(k1)=fa(k1)+fhhh*wi(i1)
2984 enddo
2985 enddo
2986 if(k.eq.1)then
2987 psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
2988 else
2989 psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
2990 endif
2991 psvin=psvin*factk*sy**delh
2992 return
2993 endif
2994
2995 jz=int(10.*z)
2996 if(jz.gt.8)jz=8
2997 if(jz.lt.1)jz=1
2998 wz(2)=10.*z-jz
2999 wz(3)=wz(2)*(wz(2)-1.)*.5
3000 wz(1)=1.-wz(2)+wz(3)
3001 wz(2)=wz(2)-2.*wz(3)
3002
3003 if(iqq.eq.14)then
3004 do k1=1,3
3005 k2=k+k1-1
3006 fa(k1)=fhgg0(k2,jz)*wz(1)+fhgg0(k2,jz+1)
3007 * *wz(2)+fhgg0(k2,jz+2)*wz(3)
3008 enddo
3009 if(k.eq.1)then
3010 psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3011 else
3012 psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3013 endif
3014 psvin=psvin*z*factk*sy**delh
3015
3016 elseif(iqq.eq.16)then
3017 do k1=1,3
3018 k2=k+k1-1
3019 fa(k1)=fhgg1(k2,jz,iclpro)*wz(1)+fhgg1(k2,jz+1,iclpro)
3020 * *wz(2)+fhgg1(k2,jz+2,iclpro)*wz(3)
3021 enddo
3022 if(k.eq.1)then
3023 psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3024 else
3025 psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3026 endif
3027 psvin=psvin*z*factk*sy**delh*xp**(-alppar)
3028
3029 elseif(iqq.eq.18)then
3030 if(xp.lt..2)then
3031 xl=log(10.*xp)/log(2.)+5.
3032 else
3033 xl=5.*xp+5.
3034 endif
3035 i=int(xl)
3036 if(i.lt.1)i=1
3037 if(i.eq.5)i=4
3038 if(i.gt.8)i=8
3039 wi(2)=xl-i
3040 wi(3)=wi(2)*(wi(2)-1.)*.5
3041 wi(1)=1.-wi(2)+wi(3)
3042 wi(2)=wi(2)-2.*wi(3)
3043 do k1=1,3
3044 fa(k1)=0.
3045 do i1=1,3
3046 do l1=1,3
3047 k2=k+k1-1
3048 l2=jz+l1-1+10*(iclpro-1)
3049 fhhh=fhqg1(k2,i+i1-1,l2)
3050 fa(k1)=fa(k1)+fhhh*wi(i1)*wz(l1)
3051 enddo
3052 enddo
3053 enddo
3054 if(k.eq.1)then
3055 psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3056 else
3057 psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3058 endif
3059 psvin=psvin*z*factk*sy**delh
3060
3061 elseif(iqq.eq.1)then !1111111111111111111111111111111111
3062
3063 do k1=1,3
3064 k2=k+k1-1
3065 iclpt=iclpro+4*(icltar-1)
3066 fa(k1)=fhgg(k2,jz,iclpt)*wz(1)+fhgg(k2,jz+1,iclpt)
3067 * *wz(2)+fhgg(k2,jz+2,iclpt)*wz(3)
3068 enddo
3069 if(k.eq.1)then
3070 psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3071 else
3072 psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3073 endif
3074 psvin=psvin*z*factk*sy**delh*(xp*xm)**(-alppar)
3075
3076 else ! 2222222222222222222222 3333333333333333333333 ....
3077
3078 if(xp.lt..2)then
3079 xl=log(10.*xp)/log(2.)+5.
3080 else
3081 xl=5.*xp+5.
3082 endif
3083 i=int(xl)
3084 if(i.lt.1)i=1
3085 if(i.eq.5)i=4
3086 if(i.gt.8)i=8
3087 wi(2)=xl-i
3088 wi(3)=wi(2)*(wi(2)-1.)*.5
3089 wi(1)=1.-wi(2)+wi(3)
3090 wi(2)=wi(2)-2.*wi(3)
3091 do k1=1,3
3092 fa(k1)=0.
3093 do i1=1,3
3094 do l1=1,3
3095 k2=k+k1-1
3096 fhhh=0.
3097 if(iqq.eq.2)then
3098 l2=jz+l1-1+10*(iclpro+4*(icltar-1)-1)
3099 fhhh=fhqg(k2,i+i1-1,l2)
3100 elseif(iqq.eq.3)then
3101 l2=jz+l1-1+10*(iclpro+4*(icltar-1)-1)
3102 fhhh=fhgq(k2,i+i1-1,l2)
3103 endif
3104 fa(k1)=fa(k1)+fhhh*wi(i1)*wz(l1)
3105 enddo
3106 enddo
3107 enddo
3108 if(k.eq.1)then
3109 psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3110 else
3111 psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3112 endif
3113 psvin=psvin*xm**(-alppar)*z*factk*sy**delh
3114 endif
3115
3116 else ! ------------- 4444444444444444444 -----------------------
3117
3118 if(xp.lt..2)then
3119 xl1=log(10.*xp)/log(2.)+5.
3120 else
3121 xl1=5.*xp+5.
3122 endif
3123 i=max(1,int(xl1))
3124 if(i.eq.5)i=4
3125 i=min(8,i)
3126 wi(2)=xl1-i
3127 wi(3)=wi(2)*(wi(2)-1.)*.5
3128 wi(1)=1.-wi(2)+wi(3)
3129 wi(2)=wi(2)-2.*wi(3)
3130
3131 if(xm.lt..2)then
3132 xl2=log(10.*xm)/log(2.)+5.
3133 else
3134 xl2=5.*xm+5.
3135 endif
3136 j=max(1,int(xl2))
3137 if(j.eq.5)j=4
3138 j=min(8,j)
3139 wj(2)=xl2-j
3140 wj(3)=wj(2)*(wj(2)-1.)*.5
3141 wj(1)=1.-wj(2)+wj(3)
3142 wj(2)=wj(2)-2.*wj(3)
3143
3144 do k1=1,3
3145 fa(k1)=0.
3146 do i1=1,3
3147 do j1=1,3
3148 k2=k+k1-1
3149 j2=j+j1-1+10*(iclp+4*(iclt-1)-1)
3150 fa(k1)=fa(k1)+fhqq(k2,i+i1-1,j2)*wi(i1)*wj(j1)
3151 enddo
3152 enddo
3153 enddo
3154 if(k.eq.1)then
3155 psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3156 else
3157 psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3158 endif
3159 psvin=psvin*z**(rp/(r2had(iclpro)+r2had(icltar)))*
3160 * factk*sy**delh
3161
3162 endif !--------------------------------------------
3163
3164 return
3165 endif
3166
3167 yl=log(sy)/log(1.e8)*10.+1
3168 k=max(1,int(yl))
3169 k=min(k,9) !?????????????9
3170 wk(2)=yl-k
3171 wk(3)=wk(2)*(wk(2)-1.)*.5
3172 wk(1)=1.-wk(2)+wk(3)
3173 wk(2)=wk(2)-2.*wk(3)
3174
3175 if(z.gt..1)then
3176 zz=10.*z+4
3177 else
3178 zz=50.*z
3179 endif
3180 jz=min(12,int(zz))
3181 if(jz.eq.0)jz=1
3182 if(jz.eq.4)jz=3
3183 wz(2)=zz-jz
3184 wz(3)=wz(2)*(wz(2)-1.)*.5
3185 wz(1)=1.-wz(2)+wz(3)
3186 wz(2)=wz(2)-2.*wz(3)
3187
3188 if(iqq.eq.9)then
3189 do k1=1,3
3190 do l1=1,3
3191 k2=k+k1-1
3192 l2=jz+l1-1
3193 psvin=psvin+ftoint(k2,l2,icdp,icdt,iclp)*wk(k1)*wz(l1)
3194 enddo
3195 enddo
3196 psvin=exp(psvin)*z
3197
3198 endif
3199 return
3200 end
3201
3202 c------------------------------------------------------------------------
3203 function psbint(q1,q2,qqcut,ss,m1,l1,jdis)
3204 c-----------------------------------------------------------------------
3205 c psbint - born cross-section interpolation
3206 c q1 - virtuality cutoff at current end of the ladder;
3207 c q2 - virtuality cutoff at opposite end of the ladder;
3208 c qqcut - p_t cutoff for the born process;
3209 c s - total c.m. energy squared for the scattering,
3210 c m1 - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
3211 c l1 - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
3212 c-----------------------------------------------------------------------
3213 dimension wi(3),wk(3)
3214 common /psar2/ edmax,epmax
3215 common /psar21/ csbor(20,160,2)
3216 include 'epos.incsem'
3217 double precision psuds
3218
3219 psbint=0.
3220 if(jdis.eq.0)then
3221 qq=max(q1,q2)
3222 else
3223 qq=max(q1/4.,q2)
3224 endif
3225 qq=max(qq,qqcut)
3226 if(iabs(m1).ne.4)then
3227 q2mass=0.
3228 if(m1.ne.0.and.m1.eq.l1)then
3229 m=2
3230 l=2
3231 elseif(m1.ne.0.and.m1.eq.-l1)then
3232 m=3
3233 l=1
3234 elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
3235 m=3
3236 l=2
3237 else
3238 m=min(1,iabs(m1))+1
3239 l=min(1,iabs(l1))+1
3240 endif
3241 else
3242 q2mass=qcmass**2
3243 m=4
3244 l=min(1,iabs(l1))+1
3245 endif
3246 s=ss-q2mass
3247 spmin=4.*q2min+q2mass
3248 s2min=4.*qq+q2mass
3249 if(s.le.s2min)return
3250
3251 p1=s/(1.+q2mass/s)
3252 if(p1.gt.4.*qq)then
3253 tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
3254 else
3255 tmin=2.*qq
3256 endif
3257 qmax=p1/4.
3258 tmax=p1/2.
3259
3260 ml=20*(m-1)+80*(l-1)
3261 qli=log(qq/q2min)/log(qmax/q2min)*19.+1.
3262 sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
3263 k=int(sl)
3264 i=int(qli)
3265 if(k.lt.1)k=1
3266 if(i.lt.1)i=1
3267 if(k.gt.18)k=18
3268 if(i.gt.18)i=18
3269
3270 wi(2)=qli-i
3271 wi(3)=wi(2)*(wi(2)-1.)*.5
3272 wi(1)=1.-wi(2)+wi(3)
3273 wi(2)=wi(2)-2.*wi(3)
3274
3275 wk(2)=sl-k
3276 wk(3)=wk(2)*(wk(2)-1.)*.5
3277 wk(1)=1.-wk(2)+wk(3)
3278 wk(2)=wk(2)-2.*wk(3)
3279
3280 do i1=1,3
3281 do k1=1,3
3282 psbint=psbint+csbor(i+i1-1,k+k1+ml-1,jdis+1)
3283 * *wi(i1)*wk(k1)
3284 enddo
3285 enddo
3286 psbint=exp(psbint)*(1./tmin-1./tmax)
3287 if(jdis.eq.0.and.qq.gt.q1)then
3288 psbint=psbint*sngl(psuds(qq,m1)/psuds(q1,m1))
3289 elseif(jdis.eq.1.and.4.*qq.gt.q1)then
3290 psbint=psbint*sngl(psuds(4.*qq,m1)/psuds(q1,m1))
3291 endif
3292 if(qq.gt.q2)psbint=psbint*sngl(psuds(qq,l1)/psuds(q2,l1))
3293 return
3294 end
3295
3296 c-----------------------------------------------------------------------
3297 function psborn(q1,q2,qqcut,s,j,l,jdis,md)
3298 c-----------------------------------------------------------------------
3299 c
3300 c hard 2->2 parton scattering born cross-section
3301 c including sudakov on both sides
3302 c
3303 c q1 - virtuality cutoff at current end of the ladder;
3304 c q2 - virtuality cutoff at opposite end of the ladder;
3305 c qqcut - p_t cutoff for the born process;
3306 c s - c.m. energy squared for the scattering;
3307 c j - parton type at current end of the ladder (0 - g, 1,2 etc. - q);
3308 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
3309 c-----------------------------------------------------------------------
3310 common /ar3/ x1(7),a1(7)
3311 double precision sud0,psbornd,psuds
3312 include 'epos.inc'
3313 include 'epos.incsem'
3314
3315 psborn=0
3316
3317 if(jdis.eq.0)then
3318 qq=max(q1,q2)
3319 else
3320 qq=max(q1/4.,q2)
3321 endif
3322 qq=max(qq,qqcut)
3323 c if(j.ne.3)then !kkkkkkkkkk charm is 3 ???
3324 if(j.ne.4)then
3325 j1=j
3326 q2mass=0.
3327 else
3328 j1=4
3329 q2mass=qcmass**2
3330 endif
3331 p1=s/(1.+q2mass/s)
3332 if(p1.gt.4.*qq)then
3333 tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
3334 else
3335 tmin=2.*qq
3336 ! return !tmin=2.*qq !kkkkkkk !????????????? tp why not ?
3337 endif
3338 tmax=p1/2.
3339 sud0=psuds(q1,j1)*psuds(q2,l)
3340
3341 psbornd=0.d0
3342 do i=1,7
3343 do m=1,2
3344 t=2.*tmin/(1.+tmin/tmax-x1(i)*(2*m-3)
3345 & *(1.-tmin/tmax))
3346 qt=t*(1.-t/p1)
3347 if(qt.lt..999*qq.and.ish.ge.1)write(ifch,*)'psborn:qt,qq,q1,q2'
3348 & ,qq,qt,q1,q2
3349
3350 if(jdis.eq.0)then
3351 scale=qt
3352 else
3353 scale=qt*4.
3354 endif
3355 if(j1.eq.0.and.l.eq.0)then
3356 fb=ffborn(s,t, 1. , 0. , 0. , 0. , 0. ) !gg
3357 elseif(j1*l.eq.0)then
3358 fb=ffborn(s,t, 0. , 1. , 0. , 0. , 0.) !qg
3359 elseif(j1.eq.l)then
3360 fb=ffborn(s,t, 0. , 0. , 1. , 0. , 0.) !qq
3361 elseif(j1.eq.-l)then
3362 fb=ffborn(s,t, 0. , 0. , 0. , 1. , 0.) !qq
3363 else
3364 fb=ffborn(s,t, 0. , 0. , 0. , 0. , 1.) !qq
3365 endif
3366 fb=fb*pssalf(qt/qcdlam)**2
3367 psbornd=psbornd+dble(a1(i)*fb)*dble(t)**2
3368 & *psuds(scale,j1)*psuds(qt,l)
3369 enddo
3370 enddo
3371 psbornd=psbornd*dble(2.*pi**3)/dble(s)**2/sud0*2
3372 * /2 !CS for parton pair
3373 if(md.eq.1)psbornd=psbornd*(1./tmin-1./tmax)
3374 psborn=sngl(psbornd)
3375 return
3376 end
3377
3378 c------------------------------------------------------------------------
3379 function psdgh(s,qq,long)
3380 c-----------------------------------------------------------------------
3381 c psdgh
3382 c s - energy squared for the interaction (hadron-hadron),
3383 c-----------------------------------------------------------------------
3384 common/ar3/ x1(7),a1(7)
3385 common /cnsta/ pi,pii,hquer,prom,piom,ainfin
3386 include 'epos.incsem'
3387 double precision psuds
3388
3389 xd=qq/s
3390 if(long.eq.0)then
3391 psdgh=(psdfh4(xd,q2min,0.,2,1)/2.25+psdfh4(xd,q2min,0.,2,2)/9.
3392 * +psdfh4(xd,q2min,0.,2,3)/9.+
3393 * 2.*(psdfh4(xd,q2min,0.,2,-1)+psdfh4(xd,q2min,0.,2,-2)+
3394 * psdfh4(xd,q2min,0.,2,-3))/4.5)
3395 * *sngl(psuds(qq,1)/psuds(q2min,1))*4.*pi**2*alfe/qq
3396 else
3397 psdgh=0.
3398 endif
3399
3400 dgh=0.
3401 if(long.eq.0)then
3402 s2min=qq/(1.-q2ini/qq)
3403 else
3404 s2min=4.*max(q2min,qcmass**2)+qq
3405 s2min=s2min/(1.-4.*q2ini/(s2min-qq))
3406 endif
3407 xmin=s2min/s
3408
3409 if(xmin.lt.1.)then
3410 do i=1,7 !numerical integration over z1
3411 do m=1,2
3412 if(long.eq.0)then
3413 z1=qq/s+(xmin-qq/s)*((1.-qq/s)/(xmin-qq/s))
3414 * **(.5+(m-1.5)*x1(i))
3415 else
3416 z1=.5*(1.+xmin+(2*m-3)*x1(i)*(1.-xmin))
3417 endif
3418 call psdint(z1*s,qq,sds,sdn,sdb,sdt,sdr,1,long)
3419 call psdint(z1*s,qq,sdsg,sdng,sdbg,sdtg,sdrg,0,long)
3420 tu=psdfh4(z1,q2min,0.,2,1)
3421 td=psdfh4(z1,q2min,0.,2,2)
3422 ts=psdfh4(z1,q2min,0.,2,3)
3423 tg=psdfh4(z1,q2min,0.,2,0)
3424 tsea=2.*(psdfh4(z1,q2min,0.,2,-1)+psdfh4(z1,q2min,0.,2,-2)
3425 * +psdfh4(z1,q2min,0.,2,-3))
3426 gy=sdn*(tu/2.25+td/9.+ts/9.+tsea/4.5)+sdtg*tg/4.5
3427 * +sdt*(tu+td+ts+tsea)/4.5
3428 dgh=dgh+a1(i)*gy*(1.-qq/s/z1)
3429 enddo
3430 enddo
3431 dgh=dgh*log((1.-qq/s)/(xmin-qq/s))*.5
3432 endif
3433 psdgh=psdgh+dgh
3434 return
3435 end
3436
3437 c------------------------------------------------------------------------
3438 function psdh(s,qq,iclpro0,long)
3439 c-----------------------------------------------------------------------
3440 c pshard - hard quark-quark interaction cross-section
3441 c s - energy squared for the interaction (hadron-hadron),
3442 c iclpro0 - type of the primary hadron (nucleon)
3443 c-----------------------------------------------------------------------
3444 common /ar3/ x1(7),a1(7)
3445 include 'epos.incsem'
3446 include 'epos.inc'
3447 double precision psuds
3448
3449 xd=qq/s
3450 qqs=q2min
3451 if(long.eq.0.and.(idisco.eq.0.or.idisco.eq.1))then
3452 psdh=(psdfh4(xd,qqs,0.,iclpro0,1)/2.25+
3453 * psdfh4(xd,qqs,0.,iclpro0,2)/9.)
3454 * *sngl(psuds(qq,1)/psuds(qqs,1))
3455 * *4.*pi**2*alfe/qq
3456 else
3457 psdh=0.
3458 endif
3459
3460 dh=0.
3461 if(long.eq.0)then
3462 s2min=qq/(1.-q2ini/qq)
3463 else
3464 s2min=4.*max(q2min,qcmass**2)+qq
3465 s2min=s2min/(1.-4.*q2ini/(s2min-qq))
3466 endif
3467 xmin=s2min/s
3468 if(xmin.lt.1.)then
3469 do i=1,7 !numerical integration over z1
3470 do m=1,2
3471 if(long.eq.0)then
3472 z1=qq/s+(xmin-qq/s)*((1.-qq/s)/(xmin-qq/s))
3473 * **(.5+(m-1.5)*x1(i))
3474 else
3475 z1=.5*(1.+xmin+(2*m-3)*x1(i)*(1.-xmin))
3476 endif
3477 call psdint(z1*s,qq,sds,sdn,sdb,sdt,sdr,1,long)
3478 tu=psdfh4(z1,qqs,0.,iclpro0,1)
3479 td=psdfh4(z1,qqs,0.,iclpro0,2)
3480 gy=sdt*(tu+td)/4.5+sdn*(tu/2.25+td/9.)
3481 if(long.eq.0)then
3482 gy=gy*(1.-qq/s/z1)
3483 else
3484 gy=gy/z1
3485 endif
3486 dh=dh+a1(i)*gy
3487 enddo
3488 enddo
3489 if(long.eq.0)then
3490 dh=dh*log((1.-qq/s)/(xmin-qq/s))*.5
3491 else
3492 dh=dh*(1.-xmin)*.5
3493 endif
3494 endif
3495 psdh=psdh+dh
3496 return
3497 end
3498
3499 c------------------------------------------------------------------------
3500 function psdsh(s,qq,iclpro0,dqsh,long)
3501 c-----------------------------------------------------------------------
3502 c psdsh - semihard interaction eikonal
3503 c s - energy squared for the interaction (hadron-hadron),
3504 c iclpro0 - hadron class,
3505 c z - impact parameter factor, z=exp(-b**2/rp),
3506 c iqq - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
3507 c-----------------------------------------------------------------------
3508 common /ar3/ x1(7),a1(7)
3509 include 'epos.inc'
3510 include 'epos.incsem'
3511 double precision psuds
3512
3513 xd=qq/s
3514 if(long.eq.0.and.(idisco.eq.0.or.idisco.eq.1))then
3515 dqsh=fzeroSeaZZ(xd,iclpro0)/xd**dels
3516 * *ffrr*4.*pi*gamhad(iclpro0)/
3517 * 4.5*sngl(psuds(qq,1)/psuds(q2min,1))
3518 * *4.*pi**2*alfe/qq
3519 else
3520 dqsh=0.
3521 endif
3522
3523 if(long.eq.0)then
3524 s2min=qq/(1.-q2ini/qq)
3525 else
3526 s2min=qq+4.*max(q2min,qcmass**2)
3527 endif
3528 xmin=s2min/s
3529 xmin=xmin**(delh-dels)
3530 dsh=0.
3531 if(xmin.lt.1.)then
3532 c numerical integration over z1
3533 do i=1,7
3534 do m=1,2
3535 z1=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./
3536 * (delh-dels))
3537 call psdint(z1*s,qq,sdsg,sdng,sdbg,sdtg,sdrg,0,long)
3538 call psdint(z1*s,qq,sdsq,sdnq,sdbq,sdtq,sdrq,1,long)
3539 dsh=dsh+a1(i)/z1**delh*(sdtg*fzeroGluZZ(z1,iclpro0)
3540 * +(sdtq+sdnq)*fzeroSeaZZ(z1,iclpro0))
3541 enddo
3542 enddo
3543 dsh=dsh*(1.-xmin)/(delh-dels)/2.
3544 endif
3545 psdsh=dqsh+dsh*ffrr*4.*pi*gamhad(iclpro0)/4.5 !*ccorr(1,1,iclpro0)
3546 return
3547 end
3548
3549 cc------------------------------------------------------------------------
3550 c function psdsh1(s,qq,iclpro0,dqsh,long)
3551 cc-----------------------------------------------------------------------
3552 cc psdsh - semihard interaction eikonal
3553 cc s - energy squared for the interaction (hadron-hadron),
3554 cc iclpro0 - hadron class,
3555 cc z - impact parameter factor, z=exp(-b**2/rp),
3556 cc iqq - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
3557 cc-----------------------------------------------------------------------
3558 c common /ar3/ x1(7),a1(7)
3559 c include 'epos.inc'
3560 c include 'epos.incsem'
3561 cc double precision psuds
3562 c
3563 c psdsh1=0. !only for plotting in psaevp : not use any more
3564 c
3565 cc$$$ xd=qq/s
3566 cc$$$ write(ifch,*)'Psdsh1 for xd,qq',xd,qq
3567 cc$$$ if(long.eq.0.and.(idisco.eq.0.or.idisco.eq.1))then
3568 cc$$$ dqsh=psftist(xd)/4.5*sngl(psuds(qq,1)/psuds(q2min,1))
3569 cc$$$ * *4.*pi**2*alfe/qq
3570 cc$$$ else
3571 cc$$$ dqsh=0.
3572 cc$$$ endif
3573 cc$$$
3574 cc$$$ if(long.eq.0)then
3575 cc$$$ s2min=qq/(1.-q2ini/qq)
3576 cc$$$ else
3577 cc$$$ s2min=qq+4.*max(q2min,qcmass**2)
3578 cc$$$ endif
3579 cc$$$ xmin=s2min/s
3580 cc$$$ xmin=xmin**(delh-dels)
3581 cc$$$ dsh=0.
3582 cc$$$ if(xmin.lt.1.)then
3583 cc$$$c numerical integration over z1
3584 cc$$$ do i=1,7
3585 cc$$$ do m=1,2
3586 cc$$$ z1=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./
3587 cc$$$ * (delh-dels))
3588 cc$$$ call psdint(z1*s,qq,sdsg,sdng,sdbg,sdtg,sdrg,0,long)
3589 cc$$$ call psdint(z1*s,qq,sdsq,sdnq,sdbq,sdtq,sdrq,1,long)
3590 cc$$$ dsh=dsh+a1(i)/z1**delh*(sdtg*psftigt(z1)
3591 cc$$$ * +(sdtq+sdnq)*psftist(z1))*z1**dels
3592 cc$$$ enddo
3593 cc$$$ enddo
3594 cc$$$ dsh=dsh*(1.-xmin)/(delh-dels)/2.
3595 cc$$$ endif
3596 cc$$$ psdsh1=dqsh+dsh/4.5
3597 c return
3598 c end
3599 c
3600
3601 c------------------------------------------------------------------------
3602 function psev0(q1,qq,xx,j)
3603 c-----------------------------------------------------------------------
3604 double precision xx,psuds,psev00
3605 common /ar3/ x1(7),a1(7)
3606 include 'epos.incsem'
3607
3608 psev0=0.
3609 psev00=0.d0
3610 do i=1,7
3611 do m=1,2
3612 if(j.eq.1)then !g->q
3613 qi=2.*q1/(1.+q1/qq+(1.-q1/qq)*(2.*m-3.)*x1(i))
3614 psev00=psev00+a1(i)*qi*psuds(qi,0)/psuds(qi,1)
3615 * /log(qi*(1.d0-xx)/qcdlam)
3616 else !q->g
3617 qi=(.5*(q1+qq+(q1-qq)*(2.*m-3.)*x1(i)))
3618 psev00=psev00+a1(i)/qi/psuds(qi,0)*psuds(qi,1)
3619 * /log(qi*(1.d0-xx)/qcdlam)
3620 endif
3621 enddo
3622 enddo
3623
3624 if(j.eq.1)then
3625 psev00=psev00*(1.d0/q1-1.d0/qq)*psuds(qq,1)/psuds(qq,0)/2.d0
3626 else
3627 psev00=psev00*(qq-q1)*psuds(qq,0)/psuds(qq,1)/2.d0
3628 endif
3629 psev00=psev00/log(log(qq*(1.d0-xx)/qcdlam)
3630 & /log(q1*(1.d0-xx)/qcdlam))
3631 psev0=sngl(psev00)
3632 return
3633 end
3634
3635 c------------------------------------------------------------------------
3636 function psev(q1,qq,xx,j,l,n)
3637 c------------------------------------------------------------------------
3638 double precision xx,zmax,zmax1,zmin,zmin1,z,psuds,fk,fq
3639 &,fz1,fz2
3640 common /ar3/ x1(7),a1(7)
3641 include 'epos.incsem'
3642
3643 zmax=1.d0-q2ini/qq
3644 zmin=xx/zmax
3645 qmax=qq
3646 fz1=0.d0
3647 fz2=0.d0
3648
3649 if(zmin.lt.zmax)then
3650 if(zmin.lt..1d0)then
3651 zmax1=min(.1d0,zmax)
3652 do i=1,7
3653 do m=1,2
3654 if(n.eq.2)then
3655 z=xx+(zmin-xx)*((zmax1-xx)/(zmin-xx))**(.5+(m-1.5)*x1(i))
3656 elseif(j.eq.1)then
3657 z=zmin*(zmax1/zmin)**(.5+(m-1.5)*x1(i))
3658 else
3659 z=(.5d0*(zmax1+zmin+(zmax1-zmin)*(2*m-3)*x1(i)))
3660 endif
3661 qmin=max(q2ini/(1.d0-xx/z),q2ini/(1.d0-z))
3662 qmin=max(qmin,q1)
3663
3664 do k=1,2
3665 fq=0.d0
3666 do i1=1,7
3667 do m1=1,2
3668 if(n.eq.2)then
3669 qi=qmin*(qmax/qmin)**(.5+x1(i1)*(m1-1.5))
3670 else
3671 qi=(.5*(qmax+qmin+(qmax-qmin)*(2.*m1-3.)*x1(i1)))
3672 endif
3673
3674 if(j.eq.3.and.k.eq.1)then
3675 fk=0.d0
3676 else
3677 if(n.eq.2)then
3678 fk=dble(psevi0(q1,qi,xx/z,min(2,j),k))
3679 else
3680 fk=dble(psevi(q1,qi,xx/z,j,k)/qi)
3681 endif
3682 endif
3683 qt=qi*(1.d0-z)
3684 fq=fq+a1(i1)*fk/psuds(qi,l-1)*pssalf(qt/qcdlam)
3685 enddo
3686 enddo
3687 if(n.eq.2)then
3688 fq=fq*log(qmax/qmin)*(1.d0-xx/z)
3689 elseif(j.eq.1)then
3690 fq=fq*(qmax-qmin)
3691 else
3692 fq=fq*(qmax-qmin)/z
3693 endif
3694 fz1=fz1+a1(i)*fq*psfap(z,k-1,l-1)
3695 enddo
3696 enddo
3697 enddo
3698 if(n.eq.2)then
3699 fz1=fz1*log((zmax1-xx)/(zmin-xx))/4.
3700 elseif(j.eq.1)then
3701 fz1=fz1*log(zmax1/zmin)/4.
3702 else
3703 fz1=fz1*(zmax1-zmin)/4.
3704 endif
3705 endif
3706
3707 if(zmax.gt..1d0)then
3708 zmin1=max(.1d0,zmin)
3709 do i=1,7
3710 do m=1,2
3711 z=1.d0-(1.d0-zmax)*((1.d0-zmin1)/(1.d0-zmax))**
3712 * (.5+x1(i)*(m-1.5))
3713 qmin=max(q2ini/(1.d0-z),q2ini/(1.d0-xx/z))
3714 qmin=max(qmin,q1)
3715
3716 do k=1,2
3717 fq=0.
3718 do i1=1,7
3719 do m1=1,2
3720 if(n.eq.2)then
3721 qi=qmin*(qmax/qmin)**(.5+x1(i1)*(m1-1.5))
3722 else
3723 qi=(.5*(qmax+qmin+(qmax-qmin)*(2.*m1-3.)*x1(i1)))
3724 endif
3725
3726 if(j.eq.3.and.k.eq.1)then
3727 fk=0.d0
3728 else
3729 if(n.eq.2)then
3730 fk=dble(psevi0(q1,qi,xx/z,min(2,j),k))
3731 else
3732 fk=dble(psevi(q1,qi,xx/z,j,k)/qi)
3733 endif
3734 endif
3735 qt=qi*(1.d0-z)
3736 fq=fq+a1(i1)*fk/psuds(qi,l-1)*pssalf(qt/qcdlam)
3737 enddo
3738 enddo
3739 if(n.eq.2)then
3740 fq=fq*log(qmax/qmin)
3741 else
3742 fq=fq*(qmax-qmin)
3743 endif
3744 fz2=fz2+a1(i)*fq*psfap(z,k-1,l-1)*(1.d0/z-1.d0)
3745 enddo
3746 enddo
3747 enddo
3748 fz2=fz2*log((1.d0-zmin1)/(1.d0-zmax))/4.
3749 endif
3750 endif
3751 psev=sngl((fz1+fz2)*psuds(qq,l-1))
3752 return
3753 end
3754
3755 c------------------------------------------------------------------------
3756 function psevi0(q1,qq,xx,m,l)
3757 c------------------------------------------------------------------------
3758 double precision xx,xmax,psuds
3759 dimension wi(3),wj(3),wk(3)
3760 common /psar2/ edmax,epmax
3761 common /psar31/ evk0(21,21,54)
3762 include 'epos.inc'
3763 include 'epos.incsem'
3764
3765 xmax=1.d0-2.d0*q2ini/epmax
3766 qmin=max(1.d0*q2min,q2ini/(1.d0-xx))
3767 qm1=max(q1,qmin)
3768 if(qq.gt..5001*epmax.and.ish.ge.1)then
3769 write(ifch,*)'0-extrap.:q1,qq,epmax,xx,m,l:',q1,qq,epmax,xx,m,l
3770 c stop
3771 endif
3772 if(xx.ge.xmax.or.qq.le.1.000*qm1)then
3773 psevi0=0.
3774 c write (*,*)'xx,xmax,qq,qm1,qmin,q1',xx,xmax,qq,qm1,qmin,q1
3775 return
3776 endif
3777
3778 if(m.eq.l)then
3779 psevi0=1.
3780 else
3781 if(xx.lt..1d0)then
3782 yx=log(10.d0*xx)+13.
3783 k=int(yx)
3784 if(k.gt.11)k=11
3785 if(k.lt.1)k=1
3786 elseif(xx.lt..9d0)then
3787 yx=10.*xx+12.
3788 k=int(yx)
3789 if(k.gt.19)k=19
3790 else
3791 yx=log(10.d0*(1.d0-xx))/log(10.d0*(1.d0-xmax))*6.+21
3792 k=int(yx)
3793 if(k.gt.25)k=25
3794 endif
3795 wk(2)=yx-k
3796 wk(3)=wk(2)*(wk(2)-1.)*.5
3797 wk(1)=1.-wk(2)+wk(3)
3798 wk(2)=wk(2)-2.*wk(3)
3799
3800 qli=log(qq/qmin)/log(.5*epmax/qmin)*20.+1.
3801 qlj=log(qm1/qmin)/log(qq/qmin)*20.+1.
3802 i=int(qli)
3803 if(i.gt.19)i=19
3804 if(i.lt.1)i=1
3805 wi(2)=qli-i
3806 wi(3)=wi(2)*(wi(2)-1.)*.5
3807 wi(1)=1.-wi(2)+wi(3)
3808 wi(2)=wi(2)-2.*wi(3)
3809
3810 j=int(qlj)
3811 if(j.lt.1)j=1
3812 if(j.gt.19)j=19
3813 wj(2)=qlj-j
3814 wj(3)=wj(2)*(wj(2)-1.)*.5
3815 wj(1)=1.-wj(2)+wj(3)
3816 wj(2)=wj(2)-2.*wj(3)
3817
3818 psevi0=0.
3819 do i1=1,3
3820 do j1=1,3
3821 do k1=1,3
3822 psevi0=psevi0+evk0(i+i1-1,j+j1-1,k+k1-1+27*(m-1))
3823 * *wi(i1)*wj(j1)*wk(k1)
3824 enddo
3825 enddo
3826 enddo
3827 psevi0=exp(psevi0)
3828 endif
3829 psevi0=psevi0*psfap(xx,m-1,l-1)*log(log(qq*(1.d0-xx)/qcdlam)
3830 */log(qm1*(1.d0-xx)/qcdlam))*sngl(psuds(qq,m-1)/psuds(q1,m-1))/4.5
3831 return
3832 end
3833
3834 c------------------------------------------------------------------------
3835 function psevi(q1,qq,xx,m,l)
3836 c------------------------------------------------------------------------
3837 c m l: 1 1 ... gluon -> gluon
3838 c 2 1 ... quark -> gluon
3839 c 1 2 ... gluon -> quark
3840 c 3 2 ... quark -> quark non singlet
3841 c 2 2 ... quark -> quark all
3842 c singlet = all - non singlet
3843 c-----------------------------------------------------------------------
3844 double precision xx,xmax,psuds
3845 dimension wi(3),wj(3),wk(3)
3846 common /psar2/ edmax,epmax
3847 common /psar32/ evk(21,21,135)
3848 include 'epos.inc'
3849 include 'epos.incsem'
3850
3851 psevi=0.
3852 xmax=1.d0-2.d0*q2ini/epmax
3853 if(qq.gt..5001*epmax.and.ish.ge.1)then
3854 write(ifch,*)'1-extrap.:q1,qq,epmax,xx,m,l:',q1,qq,epmax,xx,m,l
3855 c stop
3856 endif
3857 qmin=max(1.d0*q2min,q2ini/(1.d0-xx))
3858 qm1=max(q1,qmin)
3859 if(xx.ge.xmax.or.qq.le.1.0001*qm1)then
3860 return
3861 endif
3862 qmin1=max(1.d0*qmin,q2ini/(1.d0-dsqrt(xx)))
3863 if(qq.le.1.0001*qmin1)then
3864 psevi=psevi0(q1,qq,xx,min(m,2),l)
3865 return
3866 endif
3867
3868 if(xx.lt..1d0)then
3869 yx=log(10.d0*xx)+13.
3870 k=int(yx)
3871 if(k.gt.11)k=11
3872 if(k.lt.1)k=1
3873 elseif(xx.lt..9d0)then
3874 yx=10.*xx+12.
3875 k=int(yx)
3876 if(k.gt.19)k=19
3877 else
3878 yx=log(10.d0*(1.d0-xx))/log(10.d0*(1.d0-xmax))*6.+21
3879 k=int(yx)
3880 if(k.gt.25)k=25
3881 endif
3882 wk(2)=yx-k
3883 wk(3)=wk(2)*(wk(2)-1.)*.5
3884 wk(1)=1.-wk(2)+wk(3)
3885 wk(2)=wk(2)-2.*wk(3)
3886
3887 qli=log(qq/qmin)/log(.5*epmax/qmin)*20.+1.
3888 qlj=log(qm1/qmin)/log(qq/qmin)*20.+1.
3889 i=int(qli)
3890 if(i.lt.1)i=1
3891 if(i.gt.19)i=19
3892 wi(2)=qli-i
3893 wi(3)=wi(2)*(wi(2)-1.)*.5
3894 wi(1)=1.-wi(2)+wi(3)
3895 wi(2)=wi(2)-2.*wi(3)
3896
3897 j=int(qlj)
3898 if(j.lt.1)j=1
3899 if(j.gt.19)j=19
3900 wj(2)=qlj-j
3901 wj(3)=wj(2)*(wj(2)-1.)*.5
3902 wj(1)=1.-wj(2)+wj(3)
3903 wj(2)=wj(2)-2.*wj(3)
3904
3905 do i1=1,3
3906 do j1=1,3
3907 do k1=1,3
3908 if(m.eq.3)then
3909 k2=k+k1-1+108
3910 else
3911 k2=k+k1-1+27*(m-1)+54*(l-1)
3912 endif
3913 psevi=psevi+evk(i+i1-1,j+j1-1,k2)
3914 * *wi(i1)*wj(j1)*wk(k1)
3915 enddo
3916 enddo
3917 enddo
3918 psevi=exp(psevi)*psfap(xx,m-1,l-1)*log(log(qq*(1.d0-xx)/qcdlam)
3919 */log(qm1*(1.d0-xx)/qcdlam))/4.5
3920 if(q1.lt.qm1)psevi=psevi*sngl(psuds(qm1,m-1)/psuds(q1,m-1))
3921 return
3922 end
3923
3924 c------------------------------------------------------------------------
3925 function psjci(q1,s,l1)
3926 c-----------------------------------------------------------------------
3927 c psjci - inclusive ordered ladder cross-section interpolation for c-quark
3928 c q1 - virtuality cutoff at current end of the ladder
3929 c s - total c.m. energy squared for the ladder,
3930 c l1 - parton type at current end of the ladder (0-g, 1,2,etc.-q)
3931 c-----------------------------------------------------------------------
3932 dimension wi(3),wk(3)
3933 common /psar2/ edmax,epmax
3934 common /psar23/ cschar(20,20,2)
3935 include 'epos.incsem'
3936
3937 psjci=0.
3938 q2mass=qcmass**2
3939 spmin=4.*q2min+q2mass
3940 qq=q1
3941 s2min=4.*qq+q2mass
3942 if(s.le.s2min)return
3943
3944 smins=s2min/(1.-q2ini/q1)
3945 c if(s.le.smins)goto 1
3946 if(s.le.smins.or.qq.le.q2min)goto 1 !??????? ctp070618
3947
3948 p1=s/(1.+q2mass/s)
3949 if(p1.gt.4.*qq)then
3950 tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
3951 else
3952 tmin=2.*qq
3953 endif
3954 tmax=p1/2.
3955 qmax=p1/4.
3956
3957 l=min(1,iabs(l1))+1
3958 qli=log(qq/q2min)/log(qmax/q2min)*19.+1.
3959 sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
3960 k=int(sl)
3961 i=int(qli)
3962 if(i.lt.1)i=1
3963 if(k.gt.18)k=18
3964 if(i.gt.18)i=18
3965
3966 wi(2)=qli-i
3967 wi(3)=wi(2)*(wi(2)-1.)*.5
3968 wi(1)=1.-wi(2)+wi(3)
3969 wi(2)=wi(2)-2.*wi(3)
3970
3971 wk(2)=sl-k
3972 wk(3)=wk(2)*(wk(2)-1.)*.5
3973 wk(1)=1.-wk(2)+wk(3)
3974 wk(2)=wk(2)-2.*wk(3)
3975
3976 do i1=1,3
3977 do k1=1,3
3978 psjci=psjci+cschar(i+i1-1,k+k1-1,l)*wi(i1)*wk(k1)
3979 enddo
3980 enddo
3981 psjci=exp(psjci)*(1./tmin-1./tmax)
3982 return
3983 1 psjci=psbint(q2min,q1,0.,s,4,l1,0)
3984 return
3985 end
3986
3987 c-----------------------------------------------------------------------
3988 function psjct(s,l)
3989 c-----------------------------------------------------------------------
3990 c psjct - unordered ladder cross-section for c-quark
3991 c s - c.m. energy squared for the scattering;
3992 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
3993 c-----------------------------------------------------------------------
3994 double precision xx,zmax,qmax,qmin,qi,zmin,fsj,z,s2,sj
3995 common /ar3/ x1(7),a1(7)
3996 include 'epos.inc'
3997 include 'epos.incsem'
3998
3999 psjct=0.
4000 q2mass=qcmass**2
4001 zmax=dble(s)/(dble(s)+dble(5.*q2mass))
4002 qmax=zmax**2*dble(q2mass)/(1.d0-zmax)
4003 qmin=dble(q2min)
4004
4005 if(qmax.lt.qmin.and.ish.ge.1)write(ifch,*)'psjct:qmin,qmax'
4006 * ,qmin,qmax
4007 do i=1,7
4008 do m=1,2
4009 qi=2.d0*qmin/(1.d0+qmin/qmax+dble((2*m-3)*x1(i))
4010 * *(1.d0-qmin/qmax))
4011 zmax=(2.d0/(1.d0+dsqrt(1.d0+4.d0*dble(q2mass)/qi)))**delh
4012 zmin=(5.d0*qi/dble(s))**delh
4013
4014 fsj=0.d0
4015 if(zmax.lt.zmin.and.ish.ge.1)write(ifch,*)'psjct:zmin,zmax'
4016 * ,zmin,zmax
4017 do i1=1,7
4018 do m1=1,2
4019 z=(.5d0*(zmax+zmin+dble((2*m1-3)*x1(i1))
4020 * *(zmax-zmin)))**(1./delh)
4021 s2=z*dble(s)-qi
4022 xx=z
4023 sj=dble(psjti(sngl(qi),q2min,sngl(s2),0,l,0)*psfap(xx,1,0))*z
4024 fsj=fsj+dble(a1(i1))*sj*dble(pssalf(sngl(qi)/qcdlam))/z**delh
4025 enddo
4026 enddo
4027 fsj=fsj*(zmax-zmin)
4028 psjct=psjct+a1(i)*sngl(fsj*qi)
4029 enddo
4030 enddo
4031 psjct=psjct*sngl(1./qmin-1./qmax)/delh/4.
4032 return
4033 end
4034
4035 c------------------------------------------------------------------------
4036 function psjet1(q1,q2,qqcut,s,j,l,jdis)
4037 c-----------------------------------------------------------------------
4038 c psjet1 - ordered parton ladder cross-section
4039 c q1 - virtuality cutoff at current end of the ladder;
4040 c q2 - virtuality cutoff at opposite end of the ladder;
4041 c qqcut - p_t cutoff for the born process;
4042 c s - c.m. energy squared for the scattering;
4043 c j - parton type at current end of the ladder (0 - g, 1,2 etc. - q);
4044 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
4045 c-----------------------------------------------------------------------
4046 double precision xx,z,qq,xmax,xmin,s2min,smin,p1,q2ms,q2inis,xmin1
4047 *,sh,qtmin,t,xmax1,fx1,fx2,psuds
4048 common /ar3/ x1(7),a1(7)
4049 common /ar9/ x9(3),a9(3)
4050 include 'epos.inc'
4051 include 'epos.incsem'
4052
4053 psjet1=0.
4054 if(jdis.eq.0)then
4055 qq=dble(max(q1,q2))
4056 elseif(jdis.eq.1)then
4057 qq=dble(max(q1/4.,q2))
4058 else
4059 qq=dble(max(q1,q2/4.))
4060 endif
4061 qq=max(qq,dble(qqcut))
4062 if(l.ne.3)then
4063 q2mass=0.
4064 else
4065 q2mass=qcmass**2
4066 endif
4067 s2min=dble(q2mass)+4.d0*qq
4068 if(jdis.eq.0.or.jdis.eq.2)then
4069 smin=s2min/(1.d0-dble(q2ini)/qq)
4070 else
4071 smin=s2min/(1.d0-dble(q2ini)/qq/4.d0)
4072 endif
4073 if(dble(s).le.smin)return
4074
4075 q2ms=dble(q2mass)/dble(s)
4076 q2inis=dble(q2ini)/dble(s)
4077 p1=dble(s)/(1.d0+q2ms)
4078
4079
4080 if(jdis.eq.0.or.jdis.eq.2)then
4081 xmax=.5d0*(1.d0+q2ms)+dsqrt(.25d0*(1.d0-q2ms)**2-4.d0*q2inis)
4082 else
4083 xmax=.5d0*(1.+q2ms)+dsqrt(.25d0*(1.-q2ms)**2-q2inis)
4084 endif
4085 xmin=max(1.d0+q2ms-xmax,s2min/dble(s))
4086 if(xmin.ge.xmax.and.ish.ge.1)then
4087 write(ifch,*)'jti1,xmin,xmax',xmin,xmax
4088 c return
4089 endif
4090
4091 fx1=0.d0
4092 fx2=0.d0
4093 if(xmax.gt..8d0)then
4094 xmin1=max(xmin,.8d0)
4095 do i=1,3
4096 do m=1,2
4097 z=1.d0-(1.d0-xmax)*((1.d0-xmin1)/(1.d0-xmax))**
4098 * (.5d0+dble(x9(i)*(m-1.5)))
4099 sh=z*dble(s)
4100 xx=z
4101 p1=sh/(1.d0+dble(q2mass)/sh)
4102
4103 if(jdis.eq.0.or.jdis.eq.2)then
4104 qtmin=max(qq,dble(q2ini)/(1.d0-z))
4105 else
4106 qtmin=max(qq,dble(q2ini)/(1.d0-z)/4.d0)
4107 endif
4108 tmin=2.d0*dble(qtmin)/(1.d0+dsqrt(1.d0-4.d0*dble(qtmin)/p1))
4109 tmax=p1/2.d0
4110
4111 ft=0.
4112 if(tmin.ge.tmax.and.ish.ge.1)write(ifch,*)'psjet1:tmin,tmax'
4113 * ,tmin,tmax
4114 do i1=1,3
4115 do m1=1,2
4116 t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
4117 & *(1.d0-tmin/tmax))
4118 qt=sngl(t*(1.d0-t/p1))
4119 c if(qt.lt.qtmin)write (*,*)'psjet1:qt,qq',qt,qq
4120
4121 if(jdis.eq.0)then
4122 scale1=qt
4123 scale2=qt
4124 elseif(jdis.eq.1)then
4125 scale1=qt*4.
4126 scale2=qt
4127 elseif(jdis.eq.2)then
4128 scale1=qt
4129 scale2=qt*4.
4130 endif
4131 fb=0.
4132 do n=1,3
4133 fb=fb+psjetj(q1,scale1,sngl(t),xx,sngl(sh),j,l,n)
4134 enddo
4135 ft=ft+a9(i1)*fb*pssalf(qt/qcdlam)**2*sngl(t**2
4136 * *psuds(scale2,l))
4137 enddo
4138 enddo
4139 fx1=fx1+dble(a9(i)*ft)*(1.d0/tmin-1.d0/tmax)/sh**2*(1.d0-z)
4140 enddo
4141 enddo
4142 fx1=fx1*dlog((1.d0-xmin1)/(1.d0-xmax))
4143 endif
4144
4145 if(xmin.lt..8d0)then
4146 xmax1=min(xmax,.8d0)**(-delh)
4147 xmin1=xmin**(-delh)
4148 do i=1,3
4149 do m=1,2
4150 z=(.5d0*(xmax1+xmin1+(xmin1-xmax1)*dble((2*m-3)*x9(i))))
4151 * **(-1./delh)
4152 sh=z*dble(s)
4153 xx=z
4154 p1=sh/(1.d0+dble(q2mass)/sh)
4155
4156 if(jdis.eq.0.or.jdis.eq.2)then
4157 qtmin=max(qq,dble(q2ini)/(1.d0-z))
4158 else
4159 qtmin=max(qq,dble(q2ini)/(1.d0-z)/4.d0)
4160 endif
4161 tmin=2.d0*dble(qtmin)/(1.d0+dsqrt(1.d0-4.d0*dble(qtmin)/p1))
4162 tmax=p1/2.d0
4163
4164 ft=0.
4165 if(tmin.ge.tmax.and.ish.ge.1)write(ifch,*)'psjet1:tmin,tmax'
4166 & ,tmin,tmax
4167 do i1=1,3
4168 do m1=1,2
4169 t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
4170 & *(1.d0-tmin/tmax))
4171 qt=sngl(t*(1.d0-t/p1))
4172 if(qt.lt.sngl(qtmin).and.ish.ge.1)write(ifch,*)'psjet1:qt,qq'
4173 & ,qt,qq
4174
4175 if(jdis.eq.0)then
4176 scale1=qt
4177 scale2=qt
4178 elseif(jdis.eq.1)then
4179 scale1=qt*4.
4180 scale2=qt
4181 elseif(jdis.eq.2)then
4182 scale1=qt
4183 scale2=qt*4.
4184 endif
4185 fb=0.
4186 do n=1,3
4187 fb=fb+psjetj(q1,scale1,sngl(t),xx,sngl(sh),j,l,n)
4188 enddo
4189 ft=ft+a9(i1)*fb*pssalf(qt/qcdlam)**2*sngl(t**2
4190 * *psuds(scale2,l))
4191 enddo
4192 enddo
4193 fx2=fx2+dble(a9(i)*ft)*(1.d0/tmin-1.d0/tmax)/sh**2*z**(1.+delh)
4194 enddo
4195 enddo
4196 fx2=fx2*(xmin1-xmax1)/dble(delh)
4197 endif
4198 psjet1=sngl((fx1+fx2)/psuds(q2,l))*pi**3*2
4199 * /2 !CS for parton pair
4200 return
4201 end
4202
4203 c-----------------------------------------------------------------------
4204 function psjet(q1,q2,qqcut,s,j,l,jdis)
4205 c-----------------------------------------------------------------------
4206 c parton ladder cross-section
4207 c with at least one emission on each side
4208 c
4209 c q1 - virtuality cutoff at current end of the ladder;
4210 c q2 - virtuality cutoff at opposite end of the ladder;
4211 c qqcut - p_t cutoff for the born process;
4212 c s - c.m. energy squared for the scattering;
4213 c j - parton type at current end of the ladder (0 - g, 1,2 etc. - q);
4214 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
4215 c-----------------------------------------------------------------------
4216 double precision xx1,xx2,qq,s2min,xmin,xmax,xmin1,xmax1,t,tmin
4217 *,tmax,sh,z,qtmin,ft,fx1,fx2
4218 common /ar3/ x1(7),a1(7)
4219 common /ar9/ x9(3),a9(3)
4220 include 'epos.inc'
4221 include 'epos.incsem'
4222 common/ccctest/iiitest
4223 iiitest=0
4224
4225 psjet=0.
4226 if(jdis.eq.0)then
4227 qq=dble(max(q1,q2))
4228 else
4229 qq=dble(max(q1/4.,q2))
4230 endif
4231 qq=max(qq,dble(qqcut))
4232 s2min=4.d0*qq
4233 if(dble(s).le.s2min/(1.d0-dble(q2ini)/qq)**2)return !kkkkkkk
4234
4235 phi=acos(1.-54.*q2ini/s)/3.
4236 zmax=(1.+2.*cos(phi))**2/9. !kkkkkkk
4237 zmin=(1.-cos(phi)+sqrt(3.d0)*sin(phi))/3. !kkkkkkk
4238 zmin=max(zmin**2,sngl(s2min/dble(s)))
4239 if(zmin.gt.zmax.and.ish.ge.1)write(ifch,*)'psjet:zmin,zmax'
4240 * ,zmin,zmax
4241 zmin=zmin**(-delh)
4242 zmax=zmax**(-delh)
4243 do i=1,3
4244 do m=1,2
4245 z=dble(.5*(zmax+zmin+(zmin-zmax)*(2*m-3)*x9(i)))**(-1./delh)
4246 xmin=dsqrt(z)
4247 sh=z*dble(s)
4248
4249 qtmin=max(qq,dble(q2ini)/(1.d0-dsqrt(z)))
4250 tmin=max(0.d0,1.d0-4.d0*qtmin/sh)
4251 tmin=2.d0*qtmin/(1.d0+dsqrt(tmin)) !kkkkkkk
4252 tmax=sh/2.d0
4253
4254 ft=0.d0
4255 c if(tmin.gt.tmax)write (*,*)'psjet:tmin,tmax',tmin,tmax
4256 do i1=1,3
4257 do m1=1,2
4258 t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
4259 & *(1.d0-tmin/tmax))
4260 qt=t*(1.d0-t/sh)
4261 c if(qt.lt.qtmin)write (*,*)'psjet:qt,qq',qt,qq
4262 xmax=1.d0-q2ini/qt
4263 xmin=max(dsqrt(z),z/xmax) !xm>xp !!!
4264 if(xmin.gt.xmax.and.ish.ge.1)write(ifch,*)'psjet:xmin,xmax'
4265 * ,xmin,xmax
4266 fx1=0.d0
4267 fx2=0.d0
4268 if(xmax.gt..8d0)then
4269 xmin1=max(xmin,.8d0)
4270 do i2=1,3
4271 do m2=1,2
4272 xx1=1.d0-(1.d0-xmax)*((1.d0-xmin1)/(1.d0-xmax))**
4273 * dble(.5+x9(i2)*(m2-1.5))
4274 xx2=z/xx1
4275
4276 fb=0.
4277 fb=fb+psjeti(q1,q2,qt,sngl(t),xx1,xx2,sngl(sh)
4278 * ,j,l,jdis)
4279 * +psjeti(q1,q2,qt,sngl(t),xx2,xx1,sngl(sh)
4280 * ,j,l,jdis)
4281 fx1=fx1+dble(a9(i2)*fb)*(1.d0/xx1-1.d0)
4282 * *pssalf(qt/qcdlam)**2
4283 enddo
4284 enddo
4285 fx1=fx1*dlog((1.d0-xmin1)/(1.d0-xmax))
4286 endif
4287 if(xmin.lt..8d0)then
4288 xmax1=min(xmax,.8d0)
4289 do i2=1,3
4290 do m2=1,2
4291 xx1=xmin*(xmax1/xmin)**dble(.5+x9(i2)*(m2-1.5))
4292 xx2=z/xx1
4293
4294 fb=0.
4295 fb=fb+psjeti(q1,q2,qt,sngl(t),xx1,xx2,sngl(sh)
4296 * ,j,l,jdis)
4297 * +psjeti(q1,q2,qt,sngl(t),xx2,xx1,sngl(sh)
4298 * ,j,l,jdis)
4299 fx2=fx2+dble(a9(i2))*fb*pssalf(qt/qcdlam)**2
4300 enddo
4301 enddo
4302 fx2=fx2*dlog(xmax1/xmin)
4303 endif
4304 ft=ft+dble(a9(i1))*(fx1+fx2)*t**2
4305 enddo
4306 enddo
4307 ft=ft*(1.d0/tmin-1.d0/tmax)
4308 psjet=psjet+a9(i)*sngl(ft*z**(1.+delh)/sh**2)
4309 enddo
4310 enddo
4311 psjet=psjet*(zmin-zmax)/delh*pi**3
4312 * /2. !CS for parton pair
4313 return
4314 end
4315
4316 c-----------------------------------------------------------------------
4317 function pijet(ii,qi,qq,sk,m1,l1) !polynomial interpol of jet CS
4318 c-----------------------------------------------------------------------
4319 c ii ..... type of CS (2 = bothside, 1 = oneside, 0 = no emission, Born)
4320 c qi ..... virtuality cutoff at current end of the ladder
4321 c qq ..... virtuality cutoff of Born
4322 c sk ..... energy squared for the scattering
4323 c m1,l1 .. parton types
4324 c-----------------------------------------------------------------------
4325 include 'epos.incsem'
4326 common/psar2/edmax,epmax
4327 common/tabcsjet/ksmax,iqmax,jqmax,csjet(0:2,2,20,20,20,3,2)
4328 real wi(3),wj(3),wk(3)
4329 common/cpijet/npijet
4330 data npijet/0/
4331 npijet=npijet+1
4332 if(npijet.eq.1)call MakeCSTable
4333
4334 if(m1.ne.0.and.m1.eq.l1)then
4335 m=2
4336 l=2
4337 elseif(m1.ne.0.and.m1.eq.-l1)then
4338 m=3
4339 l=1
4340 elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4341 m=3
4342 l=2
4343 else
4344 m=min(1,iabs(m1))+1
4345 l=min(1,iabs(l1))+1
4346 endif
4347
4348 qqmin=min(qi,qq)
4349 qmax=sk/4.
4350 spmin=4.*q2min
4351 spmed=spmin*(epmax/2./spmin)**(1./(ksmax-1.))
4352 if(sk.le.spmed)then
4353 kk=2
4354 spmax=spmed
4355 else
4356 kk=1
4357 spmax=epmax/2.
4358 endif
4359
4360 qli=1.+log(qi/q2min)/log(qmax/q2min)*(iqmax-1)
4361 qlj=1.+log(qq/qqmin)/log(qmax/qqmin)*(jqmax-1)
4362 sl= 1.+log(sk/spmin)/log(spmax/spmin)*(ksmax-1)
4363 k=int(sl)
4364 i=int(qli)
4365 j=int(qlj)
4366 if(k.lt.1)k=1
4367 if(j.lt.1)j=1
4368 if(i.lt.1)i=1
4369 if(k.gt.(ksmax-2))k=ksmax-2
4370 if(i.gt.(iqmax-2))i=iqmax-2
4371 if(j.gt.(jqmax-2))j=jqmax-2
4372
4373 wi(2)=qli-i
4374 wi(3)=wi(2)*(wi(2)-1.)*.5
4375 wi(1)=1.-wi(2)+wi(3)
4376 wi(2)=wi(2)-2.*wi(3)
4377
4378 wj(2)=qlj-j
4379 wj(3)=wj(2)*(wj(2)-1.)*.5
4380 wj(1)=1.-wj(2)+wj(3)
4381 wj(2)=wj(2)-2.*wj(3)
4382
4383 wk(2)=sl-k
4384 wk(3)=wk(2)*(wk(2)-1.)*.5
4385 wk(1)=1.-wk(2)+wk(3)
4386 wk(2)=wk(2)-2.*wk(3)
4387
4388 pijet=0
4389 do i1=1,3
4390 do j1=1,3
4391 do k1=1,3
4392 pijet=pijet+csjet(ii,kk,k+k1-1,i+i1-1,j+j1-1,m,l)
4393 * *wi(i1)*wj(j1)*wk(k1)
4394 enddo
4395 enddo
4396 enddo
4397 ! if(ii.eq.2)print*,' '
4398 ! write(*,'(i2,f6.0,i2,3x,3(2f5.2,2x),f5.2)')
4399 !* ii,sk,k,(wk(kk1),csjet(ii,kk,k+kk1-1,1,1,m,l),kk1=1,3) ,pijet
4400 end
4401
4402 c-----------------------------------------------------------------------
4403 subroutine MakeCSTable !tabulates psjet
4404 c-----------------------------------------------------------------------
4405 c last two indices of table: parton types
4406 c 1 1 ... gg
4407 c 1 2 ... gq
4408 c 2 1 ... qg
4409 c 2 2 ... qq
4410 c 3 1 ... qa
4411 c 3 2 ... qq'
4412
4413 include 'epos.incsem'
4414 common/psar2/edmax,epmax
4415 common/tabcsjet/ksmax,iqmax,jqmax,csjet(0:2,2,20,20,20,3,2)
4416 write (*,'(a,$)')'(CS table'
4417 ksmax=10
4418 iqmax=3
4419 jqmax=3
4420 spmin=4.*q2min
4421 do kk=1,2
4422 if(kk.eq.1)then
4423 spmax=epmax/2.
4424 else !if(kk.eq.2)
4425 spmax=spmin*(epmax/2./spmin)**(1./(ksmax-1.))
4426 endif
4427 do m=1,3 !parton type at upper end of the ladder
4428 write (*,'(a,$)')'.'
4429 do l=1,2 !parton type at lower end of the ladder
4430 m1=m-1
4431 l1=l-1
4432 if(m.eq.3.and.l.eq.1)l1=-m1
4433 do k=1,ksmax
4434 sk=spmin*(spmax/spmin)**((k-1.)/(ksmax-1.))
4435 qmax=sk/4.
4436 do i=1,iqmax
4437 qi=q2min*(qmax/q2min)**((i-1.)/(iqmax-1.))
4438 do j=1,jqmax
4439 qq=qi*(qmax/qi)**((j-1.)/(jqmax-1.))
4440 !write(*,'(i3,4f8.3,2i4,$)')j, qi,q2min,qq,sk,m1,l1
4441 csjet(2,kk,k,i,j,m,l)= psjet(qi,q2min,qq,sk,m1,l1,0)
4442 csjet(1,kk,k,i,j,m,l)=psjet1(qi,q2min,qq,sk,m1,l1,0)
4443 csjet(0,kk,k,i,j,m,l)=psborn(qi,q2min,qq,sk,m1,l1,0,1)
4444 ! if(i.eq.1.and.j.eq.1.and.m.eq.1.and.l.eq.1)
4445 ! *write(*,'(2f8.2,f13.2,2i3,3x,i3,3f8.3)')
4446 ! * qi,qq,sk,m1,l1,k,csjet(2,kk,k,i,j,m,l)
4447 ! * ,csjet(1,kk,k,i,j,m,l),csjet(0,kk,k,i,j,m,l)
4448 enddo
4449 enddo
4450 enddo
4451 enddo
4452 enddo
4453 enddo
4454 write (*,'(a,$)')'done)'
4455 end
4456
4457
4458 function psjeti(q1,q2,qt,t,xx1,xx2,s,j,l,jdis)
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486 double precision xx1,xx2
4487 include 'epos.incsem'
4488 common/ccctest/iiitest
4489
4490 if(jdis.eq.0)then
4491 scale=qt
4492 else
4493 scale=qt*4.
4494 endif
4495 if(j.eq.0.and.l.eq.0)then ! gluon-gluon --->
4496 akg1=psevi(q1,scale,xx1,1,1) !gluon contribution
4497 akg2=psevi(q2,qt,xx2,1,1) !gluon contribution
4498 aks1=psevi(q1,scale,xx1,1,2)/naflav/2. !singlet contribution per quark
4499 aks2=psevi(q2,qt,xx2,1,2)/naflav/2. !singlet contribution per quark
4500 psjeti=ffborn(s,t,akg1*akg2
4501 * ,(akg1*aks2+aks1*akg2)*naflav*2. !ccccc
4502 * ,aks1*aks2*naflav*2.
4503 * ,aks1*aks2*naflav*2.
4504 * ,aks1*aks2*naflav*2.*(naflav-1)*2.
4505 *)
4506 elseif(j.eq.0)then ! gluon-quark --->
4507 akg1=psevi(q1,scale,xx1,1,1) !gluon contribution
4508 akg2=psevi(q2,qt,xx2,2,1) !gluon contribution
4509 aks1=psevi(q1,scale,xx1,1,2)/naflav/2. !singlet contribution
4510 akns2=psevi(q2,qt,xx2,3,2) !nonsinglet contribution
4511 aks2=(psevi(q2,qt,xx2,2,2)-akns2)/naflav/2. !singlet contribution
4512 psjeti=ffborn(s,t,akg1*akg2
4513 * ,(akg1*(akns2+aks2*naflav*2.)+aks1*akg2*naflav*2.)
4514 * ,aks1*(akns2+aks2*naflav*2.)
4515 * ,aks1*(akns2+aks2*naflav*2.)
4516 * ,aks1*(akns2+aks2*naflav*2.)*(naflav-1)*2.)
4517 elseif(l.eq.0)then ! quark-gluon --->
4518 akg1=psevi(q1,scale,xx1,2,1) !gluon contribution
4519 akg2=psevi(q2,qt,xx2,1,1) !gluon contribution
4520 akns1=psevi(q1,scale,xx1,3,2) !nonsinglet contribution
4521 aks1=(psevi(q1,scale,xx1,2,2)-akns1)/naflav/2. !singlet contribution
4522 aks2=psevi(q2,qt,xx2,1,2)/naflav/2. !singlet contribution
4523 psjeti=ffborn(s,t,akg1*akg2
4524 * ,(akg2*(akns1+aks1*naflav*2.)+aks2*akg1*naflav*2.)
4525 * ,aks2*(akns1+aks1*naflav*2.)
4526 * ,aks2*(akns1+aks1*naflav*2.)
4527 * ,aks2*(akns1+aks1*naflav*2.)*(naflav-1)*2.)
4528 else ! quark-quark --->
4529 akg1=psevi(q1,scale,xx1,2,1) !gluon contribution
4530 akg2=psevi(q2,qt,xx2,2,1) !gluon contribution
4531 akns1=psevi(q1,scale,xx1,3,2) !nonsinglet contribution
4532 aks1=(psevi(q1,scale,xx1,2,2)-akns1)/naflav/2.!singlet contribution
4533 akns2=psevi(q2,qt,xx2,3,2) !nonsinglet contribution
4534 aks2=(psevi(q2,qt,xx2,2,2)-akns2)/naflav/2.!singlet contribution
4535
4536 if(j.eq.l)then
4537 psjeti=ffborn(s,t,akg1*akg2
4538 * ,(akg2*(akns1+aks1*naflav*2.)+akg1*(akns2+aks2*naflav*2.))
4539 * ,((akns1+aks1)*(akns2+aks2)+aks1*aks2*(2.*naflav-1.))
4540 * ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
4541 * ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)*(naflav-1)*2.)
4542 elseif(j.eq.-l)then
4543 psjeti=ffborn(s,t,akg1*akg2
4544 * ,(akg2*(akns1+aks1*naflav*2.)+akg1*(akns2+aks2*naflav*2.))
4545 * ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
4546 * ,((akns1+aks1)*(akns2+aks2)+aks1*aks2*(2.*naflav-1.))
4547 * ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)*(naflav-1)*2.)
4548 else !j.ne.l,-l
4549 psjeti=ffborn(s,t,akg1*akg2
4550 * ,(akg2*(akns1+aks1*naflav*2.)+akg1*(akns2+aks2*naflav*2.))
4551 * ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
4552 * ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
4553 * ,(akns1*akns2+akns1*aks2*(naflav-1)*2.
4554 * +akns2*aks1*(naflav-1)*2.+aks1*aks2*naflav*2.*(naflav-1)*2.))
4555 endif
4556 endif
4557 return
4558 end
4559
4560
4561 function psjetj(q1,scale,t,xx,s,j,l,n)
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573 double precision xx
4574 include 'epos.incsem'
4575
4576 m=min(1,iabs(j))+1
4577 if(l.ne.3)then
4578 if(l.eq.0)then
4579 psjetj=psevi(q1,scale,xx,m,1)*(psbori(s,t,0,0,n)+ !gg
4580 * psbori(s,s-t,0,0,n))/2.
4581 * +psevi(q1,scale,xx,m,2)*(psbori(s,t,1,0,n)+ !qg
4582 * psbori(s,s-t,1,0,n))
4583 elseif(j.eq.0)then
4584 aks=psevi(q1,scale,xx,1,2)/naflav/2. !singlet contribution per quark
4585 psjetj=psevi(q1,scale,xx,1,1)*(psbori(s,t,0,1,n)+ !gq
4586 * psbori(s,s-t,0,1,n))
4587 * +aks*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2. !qq
4588 * +aks*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n)) !qq~
4589 * +aks*(psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))*(naflav-1)*2. !qq'
4590 else
4591 akg=psevi(q1,scale,xx,2,1) !gluon contribution
4592 akns=psevi(q1,scale,xx,3,2) !nonsinglet contribution
4593 aks=(psevi(q1,scale,xx,2,2)-akns)/naflav/2. !singlet contribution
4594 if(j.eq.l)then
4595 psjetj=akg*(psbori(s,t,0,1,n)+psbori(s,s-t,0,1,n)) !gq
4596 * +(akns+aks)*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2. !qq
4597 * +aks*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n)) !qq~
4598 * +aks*(psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))*(naflav-1)*2. !qq'
4599 elseif(j.eq.-l)then
4600 psjetj=akg*(psbori(s,t,0,1,n)+psbori(s,s-t,0,1,n)) !gq
4601 * +aks*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2. !qq
4602 * +(akns+aks)*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n)) !qq~
4603 * +aks*(psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))*(naflav-1)*2.!qq'
4604 else
4605 psjetj=akg*(psbori(s,t,0,1,n)+psbori(s,s-t,0,1,n)) !gq
4606 * +aks*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2. !qq
4607 * +aks*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n)) !qq~
4608 * +(akns+aks*(naflav-1)*2.)*
4609 * (psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n)) !qq'
4610 endif
4611 endif
4612 elseif(n.eq.1)then
4613 p1=s/(1.+qcmass**2/s)
4614 psjetj=psevi(q1,scale,xx,m,1)*(psbori(s,t,4,0,n)+ !cg
4615 * psbori(s,p1-t,4,0,n))
4616 * +psevi(q1,scale,xx,m,2)*(psbori(s,t,4,1,n)+ !cq
4617 * psbori(s,p1-t,4,1,n))
4618 else
4619 psjetj=0.
4620 endif
4621 return
4622 end
4623
4624
4625 function psjti(q1,qqcut,s,m1,l1,jdis)
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635 dimension wi(3),wj(3),wk(3)
4636 common /psar2/ edmax,epmax
4637 common /psar19/ cstot(20,20,240)
4638 include 'epos.incsem'
4639
4640 psjti=0.
4641
4642 if(jdis.eq.0)then
4643 qqmin=q1
4644 qmax=s/4.
4645 else
4646 qqmin=max(q2min,q1/4.)
4647 qmax=s
4648 endif
4649 qq=max(qqmin,qqcut)
4650 spmin=4.*q2min
4651 s2min=4.*qq
4652 if(s.le.s2min)return
4653
4654 if(jdis.eq.0)then
4655 smins=s2min/(1.-q2ini/qq)
4656 else
4657 smins=s2min/(1.-q2ini/qq/4.)
4658 endif
4659 if(s.le.smins)goto 1
4660
4661 if(s.gt.4.*qq)then
4662 tmin=2.*qq/(1.+sqrt(1.-4.*qq/s))
4663 else
4664 tmin=2.*qq
4665 endif
4666 tmax=s/2.
4667
4668 if(m1.ne.0.and.m1.eq.l1)then
4669 m=2
4670 l=2
4671 elseif(m1.ne.0.and.m1.eq.-l1)then
4672 m=3
4673 l=1
4674 elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4675 m=3
4676 l=2
4677 else
4678 m=min(1,iabs(m1))+1
4679 l=min(1,iabs(l1))+1
4680 endif
4681
4682 ml=20*(m-1)+60*(l-1)+120*jdis
4683 qli=log(q1/q2min)/log(qmax/q2min)*19.+1.
4684 qlj=log(qq/qqmin)/log(s/4./qqmin)*19.+1.
4685 sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
4686 k=int(sl)
4687 i=int(qli)
4688 j=int(qlj)
4689 if(j.lt.1)j=1
4690 if(i.lt.1)i=1
4691 if(k.gt.18)k=18
4692 if(i.gt.18)i=18
4693 if(j.gt.18)j=18
4694
4695 wi(2)=qli-i
4696 wi(3)=wi(2)*(wi(2)-1.)*.5
4697 wi(1)=1.-wi(2)+wi(3)
4698 wi(2)=wi(2)-2.*wi(3)
4699
4700 wj(2)=qlj-j
4701 wj(3)=wj(2)*(wj(2)-1.)*.5
4702 wj(1)=1.-wj(2)+wj(3)
4703 wj(2)=wj(2)-2.*wj(3)
4704
4705 wk(2)=sl-k
4706 wk(3)=wk(2)*(wk(2)-1.)*.5
4707 wk(1)=1.-wk(2)+wk(3)
4708 wk(2)=wk(2)-2.*wk(3)
4709
4710 do i1=1,3
4711 do j1=1,3
4712 do k1=1,3
4713 psjti=psjti+cstot(i+i1-1,j+j1-1,k+k1+ml-1)
4714 * *wi(i1)*wj(j1)*wk(k1)
4715 enddo
4716 enddo
4717 enddo
4718 psjti=exp(psjti)*(1./tmin-1./tmax)
4719 return
4720 1 continue
4721 psjti=psbint(q1,q2min,qqcut,s,m1,l1,jdis)
4722 return
4723 end
4724
4725
4726 subroutine psjti0(ss,sj,sjb,m1,l1)
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736 dimension wk(3)
4737 common /psar2/ edmax,epmax
4738 common /psar22/ cstotzero(20,4,2),csborzer(20,4,2)
4739 include 'epos.incsem'
4740
4741 sj=0.
4742 sjb=0.
4743 if(iabs(m1).ne.4)then
4744 q2mass=0.
4745 if(m1.ne.0.and.m1.eq.l1)then
4746 m=2
4747 l=2
4748 elseif(m1.ne.0.and.m1.eq.-l1)then
4749 m=3
4750 l=1
4751 elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4752 m=3
4753 l=2
4754 else
4755 m=min(1,iabs(m1))+1
4756 l=min(1,iabs(l1))+1
4757 endif
4758 else
4759 q2mass=qcmass**2
4760 m=4
4761 l=min(1,iabs(l1))+1
4762 endif
4763 s=ss-q2mass
4764 qq=q2min
4765 spmin=4.*qq+q2mass
4766 if(s.le.spmin)return
4767
4768 p1=s/(1.+q2mass/s)
4769 if(p1.gt.4.*qq)then
4770 tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
4771 else
4772 tmin=2.*qq
4773 endif
4774 tmax=.5*p1
4775
4776 sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
4777 k=int(sl)
4778 if(k.gt.18)k=18
4779 wk(2)=sl-k
4780 wk(3)=wk(2)*(wk(2)-1.)*.5
4781 wk(1)=1.-wk(2)+wk(3)
4782 wk(2)=wk(2)-2.*wk(3)
4783
4784 do k1=1,3
4785 sj=sj+cstotzero(k+k1-1,m,l)*wk(k1)
4786 sjb=sjb+csborzer(k+k1-1,m,l)*wk(k1)
4787 enddo
4788
4789 sjb=exp(sjb)*(1./tmin-1./tmax)
4790 sj=max(sjb,exp(sj)*(1./tmin-1./tmax))
4791 return
4792 end
4793
4794
4795 function psjti1(q1,q2,qqcut,s,m1,l1,jdis)
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806 dimension wi(3),wj(3),wk(3)
4807 common /psar2/ edmax,epmax
4808 common /psar20/ csord(20,20,240)
4809 include 'epos.incsem'
4810 double precision psuds
4811
4812 psjti1=0.
4813 if(jdis.eq.0)then
4814 qqmin=max(q1,q2)
4815 else
4816 qqmin=max(q1,q2/4.)
4817 endif
4818 qq=max(qqmin,qqcut)
4819 spmin=4.*q2min
4820 s2min=4.*qq
4821 if(s.le.s2min)return
4822
4823 smins=s2min/(1.-q2ini/qq)
4824 if(s.le.smins)goto 1
4825
4826 if(s.gt.4.*qq)then
4827 tmin=2.*qq/(1.+sqrt(1.-4.*qq/s))
4828 else
4829 tmin=2.*qq
4830 endif
4831 tmax=s/2.
4832
4833 if(m1.ne.0.and.m1.eq.l1)then
4834 m=2
4835 l=2
4836 elseif(m1.ne.0.and.m1.eq.-l1)then
4837 m=3
4838 l=1
4839 elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4840 m=3
4841 l=2
4842 else
4843 m=min(1,iabs(m1))+1
4844 l=min(1,iabs(l1))+1
4845 endif
4846
4847 ml=20*(m-1)+60*(l-1)+120*jdis
4848 qli=log(q1/q2min)/log(s/4./q2min)*19.+1.
4849 qlj=log(qq/qqmin)/log(s/4./qqmin)*19.+1.
4850 sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
4851 k=int(sl)
4852 i=int(qli)
4853 j=int(qlj)
4854 if(j.lt.1)j=1
4855 if(i.lt.1)i=1
4856 if(k.gt.18)k=18
4857 if(i.gt.18)i=18
4858 if(j.gt.18)j=18
4859
4860 wi(2)=qli-i
4861 wi(3)=wi(2)*(wi(2)-1.)*.5
4862 wi(1)=1.-wi(2)+wi(3)
4863 wi(2)=wi(2)-2.*wi(3)
4864
4865 wj(2)=qlj-j
4866 wj(3)=wj(2)*(wj(2)-1.)*.5
4867 wj(1)=1.-wj(2)+wj(3)
4868 wj(2)=wj(2)-2.*wj(3)
4869
4870 wk(2)=sl-k
4871 wk(3)=wk(2)*(wk(2)-1.)*.5
4872 wk(1)=1.-wk(2)+wk(3)
4873 wk(2)=wk(2)-2.*wk(3)
4874
4875 do i1=1,3
4876 do j1=1,3
4877 do k1=1,3
4878 k2=k+k1+ml-1
4879 psjti1=psjti1+csord(i+i1-1,j+j1-1,k2)
4880 * *wi(i1)*wj(j1)*wk(k1)
4881 enddo
4882 enddo
4883 enddo
4884 psjti1=exp(psjti1)*(1./tmin-1./tmax)
4885
4886 if(jdis.eq.0.and.qq.gt.q2)then
4887 psjti1=psjti1*sngl(psuds(qq,l1)/psuds(q2,l1))
4888 elseif(jdis.eq.1.and.4.*qq.gt.q2)then
4889 psjti1=psjti1*sngl(psuds(4.*qq,l1)/psuds(q2,l1))
4890 endif
4891 return
4892 1 continue
4893 if(jdis.eq.0)then
4894 psjti1=psbint(q1,q2,qqcut,s,m1,l1,0)
4895 else
4896 psjti1=psbint(q2,q1,qqcut,s,l1,m1,1)
4897 endif
4898 return
4899 end
4900
4901
4902 function pspdfg(xx,qqs,qq,iclpro0,j)
4903
4904
4905
4906
4907
4908
4909
4910 double precision z
4911 common/ar3/ x1(7),a1(7)
4912 include 'epos.incsem'
4913 double precision psuds
4914
4915 pspdfg=psdfh4(xx,qqs,0.,iclpro0,j)
4916 if(j.gt.0)pspdfg=pspdfg+psdfh4(xx,qqs,0.,iclpro0,-j) !+sea contr.
4917 pspdfg=pspdfg*sngl(psuds(qq,j)/psuds(qqs,j))
4918
4919 xmin=xx/(1.-q2ini/qq)
4920 if(xmin.ge.1.)return
4921
4922 dpd1=0.
4923 dpd2=0.
4924 xm=max(xmin,.3)
4925 do i=1,7 !numerical integration over zx
4926 do m=1,2
4927 zx=1.-(1.-xm)*(.5+(m-1.5)*x1(i))**.25
4928 z=xx/zx
4929
4930 if(j.eq.0)then
4931 aks=psevi(qqs,qq,z,2,1) !quark contribution
4932 akg=psevi(qqs,qq,z,1,1) !gluon contribution
4933 akns=0.
4934 else
4935 akg=psevi(qqs,qq,z,1,2)/naflav/2. !gluon contribution
4936 akns=psevi(qqs,qq,z,3,2) !nonsinglet contribution
4937 aks=(psevi(qqs,qq,z,2,2)-akns)/naflav/2. !quark contribution
4938 endif
4939
4940 fz=akg*psdfh4(zx,qqs,0.,iclpro0,0)
4941 * +akns*psdfh4(zx,qqs,0.,iclpro0,j)
4942 * +aks*(psdfh4(zx,qqs,0.,iclpro0,1)+
4943 * 2.*psdfh4(zx,qqs,0.,iclpro0,-1)
4944 * +psdfh4(zx,qqs,0.,iclpro0,2)+2.*psdfh4(zx,qqs,0.,iclpro0,-2)
4945 * +2.*psdfh4(zx,qqs,0.,iclpro0,-3))
4946 if(j.gt.0)fz=fz+akns*psdfh4(zx,qqs,0.,iclpro0,-j)
4947
4948 dpd1=dpd1+a1(i)*fz/zx**2/(1.-zx)**3
4949 enddo
4950 enddo
4951 dpd1=dpd1*(1.-xm)**4/8.*xx
4952
4953 if(xm.gt.xmin)then
4954 do i=1,7 !numerical integration
4955 do m=1,2
4956 zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))**(.5-(m-1.5)*x1(i))
4957 z=xx/zx
4958
4959 if(j.eq.0)then
4960 aks=psevi(qqs,qq,z,2,1) !quark contribution
4961 akg=psevi(qqs,qq,z,1,1) !gluon contribution
4962 akns=0.
4963 else
4964 akg=psevi(qqs,qq,z,1,2)/naflav/2. !gluon contribution
4965 akns=psevi(qqs,qq,z,3,2) !nonsinglet contribution
4966 aks=(psevi(qqs,qq,z,2,2)-akns)/naflav/2. !quark contribution
4967 endif
4968
4969 fz=akg*psdfh4(zx,qqs,0.,iclpro0,0)
4970 * +akns*psdfh4(zx,qqs,0.,iclpro0,j)
4971 * +aks*(psdfh4(zx,qqs,0.,iclpro0,1)
4972 * +2.*psdfh4(zx,qqs,0.,iclpro0,-1)
4973 * +psdfh4(zx,qqs,0.,iclpro0,2)+2.*psdfh4(zx,qqs,0.,iclpro0,-2)
4974 * +2.*psdfh4(zx,qqs,0.,iclpro0,-3))
4975 if(j.gt.0)fz=fz+akns*psdfh4(zx,qqs,0.,iclpro0,-j)
4976
4977 dpd2=dpd2+a1(i)*fz*(1.-xx/zx)/zx
4978 enddo
4979 enddo
4980 dpd2=dpd2*log((xm-xx)/(xmin-xx))*.5*xx
4981 endif
4982 pspdfg=pspdfg+dpd2+dpd1
4983 return
4984 end
4985
4986
4987 subroutine psaevp
4988
4989 include 'epos.inc'
4990 include 'epos.incsem'
4991 qq=xpar1
4992 jmod=nint(xpar2)
4993 iologb=1
4994
4995 if(jmod.eq.0)then !??????????????ttttttt
4996 write(*,*)"no more triple Pomeron, xpar2=0 in psaevp not accepted"
4997 write(*,*)"use xpar2=1 instead"
4998 jmod=1
4999 endif
5000
5001 do i=1,nrbins
5002 if(iologb.eq.0)then
5003 xx=xminim+(xmaxim-xminim)*(i-.5)/nrbins
5004 else
5005 xx=xminim*(xmaxim/xminim)**((i-.5)/nrbins)
5006 endif
5007 ar(i,1)=xx
5008 ar(i,2)=0.
5009 if(jmod.eq.0)then !evolution+matrix element +3P (ours)
5010 ww=qq/xx
5011 ar(i,3)=(psdh(ww,qq,2,0)+psdh(ww,qq,2,1)
5012
5013 * )/(4.*pi**2*alfe)*qq
5014 elseif(jmod.eq.1)then !evolution+matrix element (ours)
5015 ww=qq/xx
5016 ar(i,3)=(psdh(ww,qq,2,0)+psdh(ww,qq,2,1)+
5017 * psdsh(ww,qq,2,dqsh,0)+psdsh(ww,qq,2,dqsh,1)
5018 * )/(4.*pi**2*alfe)*qq
5019 elseif(jmod.eq.2)then !just evolution (grv)
5020 ar(i,3)=(pspdfg(xx,q2min,qq,2,1)/2.25+
5021 * pspdfg(xx,q2min,qq,2,2)/9.+
5022 * pspdfg(xx,q2min,qq,2,-1)*2./3.6+
5023 * pspdfg(xx,q2min,qq,2,-3)*2./9.)
5024 if(naflav.eq.4)ar(i,3)=ar(i,3)+pspdfg(xx,q2min,qq,2,-4)
5025 * *2./2.25
5026 elseif(jmod.eq.3)then !grv
5027 ar(i,3)=(psdfh4(xx,qq,0.,2,1)+2.*psdfh4(xx,qq,0.,2,-1))/2.25
5028 * +(psdfh4(xx,qq,0.,2,2)+2.*psdfh4(xx,qq,0.,2,-2))/9.
5029 * +2.*psdfh4(xx,qq,0.,2,-3)/9. !
5030 elseif(jmod.eq.4)then !just evolution (ours)
5031 ar(i,3)=(fparton(xx,qq,1)/2.25+fparton(xx,qq,2)/9.+
5032 * fparton(xx,qq,-1)*6./4.5) !uv+dv+6*sea
5033 if(naflav.eq.4)ar(i,3)=ar(i,3)+fparton(xx,qq,-4)*2./2.25
5034 elseif(jmod.eq.5)then !grv+res
5035 ww=qq/xx
5036 ar(i,3)=(psdgh(ww,qq,0)+psdgh(ww,qq,1)
5037 * )/(4.*pi**2*alfe)*qq
5038 endif
5039 ar(i,4)=0.
5040 enddo
5041 return
5042 end
5043
5044
5045 subroutine pscs(c,s)
5046
5047
5048
5049 1 s1=2.*rangen()-1.
5050 s2=2.*rangen()-1.
5051 s3=s1*s1+s2*s2
5052 if(s3.gt.1.)goto 1
5053 s3=sqrt(s3)
5054 c=s1/s3
5055 s=s2/s3
5056 return
5057 end
5058
5059
5060 subroutine psdefrot(ep,s0x,c0x,s0,c0)
5061
5062
5063
5064
5065
5066
5067 dimension ep(4)
5068
5069
5070 pt2=ep(3)**2+ep(4)**2
5071 if(pt2.ne.0.)then
5072 pt=sqrt(pt2)
5073
5074
5075 c0x=ep(3)/pt
5076 s0x=ep(4)/pt
5077
5078 pl=sqrt(pt2+ep(2)**2)
5079 s0=pt/pl
5080 c0=ep(2)/pl
5081 else
5082 c0x=1.
5083 s0x=0.
5084 pl=abs(ep(2))
5085 s0=0.
5086 c0=ep(2)/pl
5087 endif
5088
5089 ep(2)=pl
5090 ep(3)=0.
5091 ep(4)=0.
5092 return
5093 end
5094
5095
5096 subroutine psdeftr(s,ep,ey)
5097
5098
5099
5100
5101 dimension ey(3)
5102 double precision ep(4)
5103
5104 do i=1,3
5105 if(ep(i+1).eq.0.d0)then
5106 ey(i)=1.
5107 else
5108 wp=ep(1)+ep(i+1)
5109 wm=ep(1)-ep(i+1)
5110 if(wp.gt.1.e-8.and.wm/wp.lt.1.e-8)then
5111 ww=s
5112 do l=1,3
5113 if(l.ne.i)ww=ww+ep(l+1)**2
5114 enddo
5115 wm=ww/wp
5116 elseif(wm.gt.1.e-8.and.wp/wm.lt.1.e-8)then
5117 ww=s
5118 do l=1,3
5119 if(l.ne.i)ww=ww+ep(l+1)**2
5120 enddo
5121 wp=ww/wm
5122 endif
5123 ey(i)=sqrt(wm/wp)
5124 ep(1)=wp*ey(i)
5125 ep(i+1)=0.
5126 endif
5127 enddo
5128 ep(1)=dsqrt(dble(s))
5129 return
5130 end
5131
5132
5133 function psdfh4(xxx,qqs,qq,icq,iq)
5134
5135
5136
5137 common /psar8/ stmass ,amhadr(8),qcmass
5138 common /psar36/ alvc
5139
5140 psdfh4=0.
5141 ! if(x.gt..99999)return
5142 x=min(xxx,0.99999) !warning ! but necessary for idraflx
5143
5144 if(icq.eq.2)then
5145 if(qqs.le.0.232**2)return
5146 sq=log(log(qqs/.232**2)/log(.23/.232**2))
5147 if(sq.le.0.)return
5148 if(iq.eq.0)then !gluon
5149 alg=.524
5150 betg=1.088
5151 aag=1.742-.93*sq
5152 bbg=-.399*sq**2
5153 ag=7.486-2.185*sq
5154 bg=16.69-22.74*sq+5.779*sq*sq
5155 cg=-25.59+29.71*sq-7.296*sq*sq
5156 dg=2.792+2.215*sq+.422*sq*sq-.104*sq*sq*sq
5157 eg=.807+2.005*sq
5158 eeg=3.841+.361*sq
5159 psdfh4=(1.-x)**dg*(x**aag*(ag+bg*x+cg*x**2)*log(1./x)**bbg
5160 * +sq**alg*exp(-eg+sqrt(eeg*sq**betg*log(1./x))))
5161 elseif(iq.eq.1.or.iq.eq.2)then !u_v or d_v
5162 aau=.59-.024*sq
5163 bbu=.131+.063*sq
5164 auu=2.284+.802*sq+.055*sq*sq
5165 au=-.449-.138*sq-.076*sq*sq
5166 bu=.213+2.669*sq-.728*sq*sq
5167 cu=8.854-9.135*sq+1.979*sq*sq
5168 du=2.997+.753*sq-.076*sq*sq
5169 uv=auu*x**aau*(1.-x)**du*
5170 * (1.+au*x**bbu+bu*x+cu*x**1.5)
5171
5172 aad=.376
5173 bbd=.486+.062*sq
5174 add=.371+.083*sq+.039*sq*sq
5175 ad=-.509+3.31*sq-1.248*sq*sq
5176 bd=12.41-10.52*sq+2.267*sq*sq
5177 ccd=6.373-6.208*sq+1.418*sq*sq
5178 dd=3.691+.799*sq-.071*sq*sq
5179 dv=add*x**aad*(1.-x)**dd*
5180 * (1.+ad*x**bbd+bd*x+ccd*x**1.5)
5181
5182 if(iq.eq.1)then !u_v
5183 psdfh4=uv
5184 elseif(iq.eq.2)then !d_v
5185 psdfh4=dv
5186 endif
5187 elseif(iq.eq.-3)then !s_sea
5188 als=.914
5189 bets=.577
5190 aas=1.798-.596*sq
5191 as=-5.548+3.669*sqrt(sq)-.616*sq
5192 bs=18.92-16.73*sqrt(sq)+5.168*sq
5193 ds=6.379-.35*sq+.142*sq*sq
5194 es=3.981+1.638*sq
5195 ees=6.402
5196 psdfh4=(1.-x)**ds*sq**als/log(1./x)**aas*(1.+as*sqrt(x)
5197 * +bs*x)*exp(-es+sqrt(ees*sq**bets*log(1./x)))
5198 elseif(iabs(iq).lt.3)then !u_sea or d_sea
5199 aadel=.409-.005*sq
5200 bbdel=.799+.071*sq
5201 addel=.082+.014*sq+.008*sq*sq
5202 adel=-38.07+36.13*sq-.656*sq*sq
5203 bdel=90.31-74.15*sq+7.645*sq*sq
5204 ccdel=0.
5205 ddel=7.486+1.217*sq-.159*sq*sq
5206 delv=addel*x**aadel*(1.-x)**ddel*
5207 * (1.+adel*x**bbdel+bdel*x+ccdel*x**1.5)
5208
5209 alud=1.451
5210 betud=.271
5211 aaud=.41-.232*sq
5212 bbud=.534-.457*sq
5213 aud=.89-.14*sq
5214 bud=-.981
5215 cud=.32+.683*sq
5216 dud=4.752+1.164*sq+.286*sq*sq
5217 eud=4.119+1.713*sq
5218 eeud=.682+2.978*sq
5219 udsea=(1.-x)**dud*(x**aaud*(aud+bud*x+cud*x**2)
5220 * *log(1./x)**bbud+sq**alud*exp(-eud+sqrt(eeud*sq**betud*
5221 * log(1./x))))
5222
5223 if(iq.eq.-1)then !u_sea
5224 psdfh4=(udsea-delv)/2.
5225 elseif(iq.eq.-2)then !d_sea
5226 psdfh4=(udsea+delv)/2.
5227 endif
5228 else
5229 psdfh4=0.
5230 endif
5231 elseif(icq.eq.1.or.icq.eq.3)then
5232 if(qqs.le.0.204**2)return
5233 sq=log(log(qqs/.204**2)/log(.26/.204**2))
5234 if(sq.le.0.)return
5235 if(iq.eq.1.or.iq.eq.2)then
5236 aapi=.517-.02*sq
5237 api=-.037-.578*sq
5238 bpi=.241+.251*sq
5239 dpi=.383+.624*sq
5240 anorm=1.212+.498*sq+.009*sq**2
5241 psdfh4=.5*anorm*x**aapi*(1.-x)**dpi*
5242 * (1.+api*sqrt(x)+bpi*x)
5243 elseif(iq.eq.0)then
5244 alfpi=.504
5245 betpi=.226
5246 aapi=2.251-1.339*sqrt(sq)
5247 api=2.668-1.265*sq+.156*sq**2
5248 bbpi=0.
5249 bpi=-1.839+.386*sq
5250 cpi=-1.014+.92*sq-.101*sq**2
5251 dpi=-.077+1.466*sq
5252 epi=1.245+1.833*sq
5253 eppi=.51+3.844*sq
5254 psdfh4=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
5255 * log(1./x)**bbpi+sq**alfpi*
5256 * exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
5257 elseif(iq.eq.-3)then
5258 alfpi=.823
5259 betpi=.65
5260 aapi=1.036-.709*sq
5261 api=-1.245+.713*sq
5262 bpi=5.58-1.281*sq
5263 dpi=2.746-.191*sq
5264 epi=5.101+1.294*sq
5265 eppi=4.854-.437*sq
5266 psdfh4=sq**alfpi/log(1./x)**aapi*(1.-x)**dpi*
5267 * (1.+api*sqrt(x)+bpi*x)*
5268 * exp(-epi+sqrt(eppi*sq**betpi*log(1./x)))
5269 elseif(iabs(iq).lt.3)then
5270 alfpi=1.147
5271 betpi=1.241
5272 aapi=.309-.134*sqrt(sq)
5273 api=.219-.054*sq
5274 bbpi=.893-.264*sqrt(sq)
5275 bpi=-.593+.24*sq
5276 cpi=1.1-.452*sq
5277 dpi=3.526+.491*sq
5278 epi=4.521+1.583*sq
5279 eppi=3.102
5280 psdfh4=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
5281 * log(1./x)**bbpi+sq**alfpi*
5282 * exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
5283 else
5284 psdfh4=0.
5285 endif
5286 elseif(icq.eq.0)then
5287 if(qqs.le.0.204**2)return
5288 sq=log(log(qqs/.204**2)/log(.26/.204**2))
5289 if(sq.le.0.)return
5290 if(iq.eq.0)then
5291 alfpi=.504
5292 betpi=.226
5293 aapi=2.251-1.339*sqrt(sq)
5294 api=2.668-1.265*sq+.156*sq**2
5295 bbpi=0.
5296 bpi=-1.839+.386*sq
5297 cpi=-1.014+.92*sq-.101*sq**2
5298 dpi=-.077+1.466*sq
5299 epi=1.245+1.833*sq
5300 eppi=.51+3.844*sq
5301 psdfh4=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
5302 * log(1./x)**bbpi+sq**alfpi*
5303 * exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
5304 * *.543
5305 else
5306 alfpi=.823
5307 betpi=.65
5308 aapi=1.036-.709*sq
5309 api=-1.245+.713*sq
5310 bpi=5.58-1.281*sq
5311 dpi=2.746-.191*sq
5312 epi=5.101+1.294*sq
5313 eppi=4.854-.437*sq
5314 str=sq**alfpi/log(1./x)**aapi*(1.-x)**dpi*
5315 * (1.+api*sqrt(x)+bpi*x)*
5316 * exp(-epi+sqrt(eppi*sq**betpi*log(1./x)))
5317 if(iq.eq.3)then
5318 psdfh4=str*.543*2.
5319 else
5320 aapi=.517-.02*sq
5321 api=-.037-.578*sq
5322 bpi=.241+.251*sq
5323 dpi=.383+.624*sq
5324 anorm=1.212+.498*sq+.009*sq**2
5325 val=.5*anorm*x**aapi*(1.-x)**dpi*
5326 * (1.+api*sqrt(x)+bpi*x)
5327
5328 alfpi=1.147
5329 betpi=1.241
5330 aapi=.309-.134*sqrt(sq)
5331 api=.219-.054*sq
5332 bbpi=.893-.264*sqrt(sq)
5333 bpi=-.593+.24*sq
5334 cpi=1.1-.452*sq
5335 dpi=3.526+.491*sq
5336 epi=4.521+1.583*sq
5337 eppi=3.102
5338 sea=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
5339 * log(1./x)**bbpi+sq**alfpi*
5340 * exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
5341 if(iq.eq.1)then
5342 psdfh4=(.836*(val+2.*sea)-.587*str)
5343 elseif(iq.eq.2)then
5344 psdfh4=(.25*(val+2.*sea)+.587*str)
5345 else
5346 psdfh4=0.
5347 endif
5348 endif
5349 endif
5350 psdfh4=psdfh4/(1.+qq/.59)**2
5351
5352 elseif(icq.eq.4)then
5353 if(qqs.le.qcmass**2)return
5354 sq=log(log(qqs/qcmass**2)/log(.23/qcmass**2))
5355 if(sq.le.0.)return
5356 if(iq.eq.2)then
5357 psdfh4=x**3*(1.-x)**alvc*(alvc+3.)*(alvc+2.)*(alvc+1.)
5358 else
5359 aapi=.517-.02*sq
5360 api=-.037-.578*sq
5361 bpi=.241+.251*sq
5362 dpi=.383+.624*sq
5363 anorm=1.212+.498*sq+.009*sq**2
5364 psdfh4=.5*anorm*x**aapi*(1.-x)**dpi*
5365 * (1.+api*sqrt(x)+bpi*x)
5366 endif
5367 else
5368 psdfh4=0.
5369 endif
5370 return
5371 end
5372
5373
5374
5375 function psfap(x,j,l)
5376
5377
5378
5379
5380
5381
5382 double precision x
5383 include 'epos.incsem'
5384
5385 if(j.eq.0)then
5386 if(l.eq.0)then
5387 psfap=((1.d0-x)/x+x/(1.d0-x)+x*(1.d0-x))*6.d0
5388 else
5389 psfap=(x**2+(1.d0-x)**2)*naflav
5390 endif
5391 else
5392 if(l.eq.0)then
5393 psfap=(1.d0+(1.d0-x)**2)/x/.75d0
5394 else
5395 psfap=(x**2+1.d0)/(1.d0-x)/.75d0
5396 endif
5397 endif
5398 return
5399 end
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433 function psidd(icc)
5434
5435
5436
5437 if(icc.eq.0)then !g
5438 psidd=9
5439 elseif(iabs(icc).le.2)then !u,u~,d,d~
5440 psidd=icc
5441 elseif(iabs(icc).eq.4)then !s,s~
5442 psidd=icc/4*3
5443 elseif(iabs(icc).gt.10)then !c,c~ etc.
5444 psidd=icc/10
5445 elseif(icc.eq.3)then !ud
5446 psidd=1200
5447 elseif(icc.eq.-3)then !u~d~
5448 psidd=-1200
5449 elseif(icc.eq.6)then !uu
5450 psidd=1100
5451 elseif(icc.eq.-6)then !u~u~
5452 psidd=-1100
5453 elseif(icc.eq.7)then !dd
5454 psidd=2200
5455 elseif(icc.eq.-7)then !d~d~
5456 psidd=-2200
5457 else
5458 psidd=0.
5459 write (*,*)'psidd?????????',icc
5460 endif
5461 return
5462 end
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477 function psjvrg1(qt,s,y0)
5478
5479 common /ar3/ x1(7),a1(7)
5480 common /cnsta/ pi,pii,hquer,prom,piom,ainfin
5481 include 'epos.incsem'
5482 double precision xt,ymin,ymax,y,xmin,xmax,xx1,xx2
5483
5484 psjvrg1=0.
5485 if(s.le.4.*qt)return
5486
5487 xt=2.d0*sqrt(dble(qt)/dble(s))
5488 ymax=min(dble(y0),log(1d0/xt+sqrt((1d0/xt-1d0)*(1d0/xt+1d0))))
5489 ymin=-ymax
5490
5491 do i=1,7
5492 do m=1,2
5493 y=.5d0*(ymax+ymin+(ymin-ymax)*dble((2*m-3)*x1(i)))
5494 xmin=xt**2/2.d0/(2.d0-xt*exp(-y))
5495 xmax=1.d0-xt*exp(y)/2.d0
5496
5497 fx=0.
5498 do i1=1,7
5499 do m1=1,2
5500 xx1=xt*exp(y)/2d0+xmin*(xmax/xmin)**dble(.5+x1(i1)*(m1-1.5))
5501 xx2=xt*exp(-y)*xx1/(2.d0*xx1-xt*exp(y))
5502 z=sngl(xx1*xx2)
5503 sh=z*s
5504 t=sngl(dble(sh)/2d0*(1d0
5505 & -sqrt(max(0d0,1d0-4d0*dble(qt)/dble(sh)))))
5506 ft=psjvrx(t,qt,sngl(xx1),sngl(xx2),sh)
5507 fx=fx+a1(i1)*ft/sh**2
5508 enddo
5509 enddo
5510 fx=fx*sngl(log(xmax/xmin))
5511 psjvrg1=psjvrg1+a1(i)*fx
5512 enddo
5513 enddo
5514 psjvrg1=psjvrg1*sngl(ymax-ymin)*pi**3
5515 **pssalf(qt/qcdlam)**2*sqrt(qt)
5516 return
5517 end
5518
5519
5520 function psjvrx(t,qt,xx1,xx2,s)
5521
5522 include 'epos.incsem'
5523
5524 g1=psdfh4(xx1,qt,0.,2,0)
5525 ub1=psdfh4(xx1,qt,0.,2,-1)
5526 u1=psdfh4(xx1,qt,0.,2,1)+ub1
5527 db1=psdfh4(xx1,qt,0.,2,-2)
5528 d1=psdfh4(xx1,qt,0.,2,2)+db1
5529 sb1=psdfh4(xx1,qt,0.,2,-3)
5530 s1=sb1
5531 g2=psdfh4(xx2,qt,0.,2,0)
5532 ub2=psdfh4(xx2,qt,0.,2,-1)
5533 u2=psdfh4(xx2,qt,0.,2,1)+ub2
5534 db2=psdfh4(xx2,qt,0.,2,-2)
5535 d2=psdfh4(xx2,qt,0.,2,2)+db2
5536 sb2=psdfh4(xx2,qt,0.,2,-3)
5537 s2=sb2
5538
5539 psjvrx=g1*g2*(psbori(s,t,0,0,1)+psbori(s,s-t,0,0,1)
5540 *+psbori(s,t,0,0,2)+psbori(s,s-t,0,0,2))/2.
5541 *+(psbori(s,t,0,1,1)+psbori(s,s-t,0,1,1))*
5542 *(g2*(u1+ub1+d1+db1+s1+sb1)+g1*(u2+ub2+d2+db2+s2+sb2))
5543 *+(psbori(s,t,1,1,1)+psbori(s,s-t,1,1,1))/2.*
5544 *(u1*u2+ub1*ub2+d1*d2+db1*db2+s1*s2+sb1*sb2)
5545 *+(psbori(s,t,1,-1,1)+psbori(s,s-t,1,-1,1)+psbori(s,t,1,-1,2)+
5546 *psbori(s,s-t,1,-1,2)+psbori(s,t,1,-1,3)+psbori(s,s-t,1,-1,3))*
5547 *(u1*ub2+ub1*u2+d1*db2+db1*d2+s1*sb2+sb1*s2)
5548 *+(psbori(s,t,1,2,1)+psbori(s,s-t,1,2,1))*
5549 *((u1+ub1)*(d2+db2+s2+sb2)+(u2+ub2)*(d1+db1+s1+sb1)+
5550 *(d1+db1)*(u2+ub2+s2+sb2)+(d2+db2)*(u1+ub1+s1+sb1)+
5551 *(s1+sb1)*(u2+ub2+d2+db2)+(s2+sb2)*(u1+ub1+d1+db1))
5552 return
5553 end
5554
5555
5556 function psjwo1(qt,s,y0)
5557
5558 common /ar3/ x1(7),a1(7)
5559 common /cnsta/ pi,pii,hquer,prom,piom,ainfin
5560 double precision xt,ymax,ymin,y,xmin,xmax,xx1,xx2
5561 include 'epos.incsem'
5562
5563 psjwo1=0.
5564 if(s.le.4.*qt)return
5565
5566 xt=2.d0*sqrt(dble(qt)/dble(s))
5567 ymax=min(dble(y0),log(1d0/xt+sqrt((1d0/xt-1d0)*(1d0/xt+1d0))))
5568 ymin=-ymax
5569
5570 do i=1,7
5571 do m=1,2
5572 y=.5d0*(ymax+ymin+(ymin-ymax)*dble(2*m-3)*dble(x1(i)))
5573 xmin=xt**2/2.d0/(2.d0-xt*exp(-y))
5574 xmax=1.d0-xt*exp(y)/2.d0
5575
5576 fx=0.
5577 do i1=1,7
5578 do m1=1,2
5579 xx1=xt*exp(y)/2.d0+xmin*(xmax/xmin)**dble(.5+x1(i1)*(m1-1.5))
5580 xx2=xt*exp(-y)/(2.d0-xt*exp(y)/xx1)
5581 z=sngl(xx1*xx2)
5582 sh=z*s
5583 t=sngl(dble(sh)/2d0*(1d0-sqrt(1d0-4d0*dble(qt)/dble(sh))))
5584 ft=psjwox(t,qt,sngl(xx1),sngl(xx2),sh)
5585 fx=fx+a1(i1)*ft/sh**2
5586 enddo
5587 enddo
5588 fx=fx*log(xmax/xmin)
5589 psjwo1=psjwo1+a1(i)*fx
5590 enddo
5591 enddo
5592 psjwo1=psjwo1*sngl(ymax-ymin)*pi**3
5593 **pssalf(qt/qcdlam)**2*sqrt(qt)
5594 return
5595 end
5596
5597
5598 function psjwox(t,qt,xx1,xx2,s)
5599
5600 double precision x,scale,upv1,dnv1,sea1,str1,chm1,gl1,
5601 *upv2,dnv2,sea2,str2,chm2,gl2
5602 scale=sqrt(qt)
5603 x=xx1
5604 call strdo1(x,scale,upv1,dnv1,sea1,str1,chm1,gl1)
5605 x=xx2
5606 call strdo1(x,scale,upv2,dnv2,sea2,str2,chm2,gl2)
5607
5608 psjwox=gl1*gl2*(psbori(s,t,0,0,1)+psbori(s,s-t,0,0,1)
5609 *+psbori(s,t,0,0,2)+psbori(s,s-t,0,0,2)+psbori(s,t,0,0,3)
5610 *+psbori(s,s-t,0,0,3))/2.
5611 *+(psbori(s,t,0,1,1)+psbori(s,s-t,0,1,1)
5612 *+psbori(s,t,0,1,2)+psbori(s,s-t,0,1,2)+psbori(s,t,0,1,3)
5613 *+psbori(s,s-t,0,1,3))*(gl2*(upv1+dnv1+4.*sea1+2.*str1+2.*chm1)+
5614 *gl1*(upv2+dnv2+4.*sea2+2.*str2+2.*chm2))
5615 *+(psbori(s,t,1,1,1)+psbori(s,s-t,1,1,1)
5616 *+psbori(s,t,1,1,2)+psbori(s,s-t,1,1,2)+psbori(s,t,1,1,3)+
5617 *psbori(s,s-t,1,1,3))/2.*
5618 *((upv1+sea1)*(upv2+sea2)+(dnv1+sea1)*(dnv2+sea2)+2.*sea1*sea2
5619 *+2.*str1*str2+2.*chm1*chm2)
5620 *+(psbori(s,t,1,-1,1)+psbori(s,s-t,1,-1,1)+psbori(s,t,1,-1,2)+
5621 *psbori(s,s-t,1,-1,2)+psbori(s,t,1,-1,3)+psbori(s,s-t,1,-1,3))*
5622 *((upv1+sea1)*sea2+sea1*(upv2+sea2)+(dnv1+sea1)*sea2+
5623 *sea1*(dnv2+sea2)+2.*str1*str2+2.*chm1*chm2)
5624 *+(psbori(s,t,1,2,1)
5625 *+psbori(s,s-t,1,2,1)+psbori(s,t,1,2,2)+psbori(s,s-t,1,2,2)
5626 *+psbori(s,t,1,2,3)+psbori(s,s-t,1,2,3))*
5627 *(upv1*dnv2+upv2*dnv1+(upv1+dnv1)*(2.*sea2+2.*str2+2.*chm2)+
5628 *(upv2+dnv2)*(2.*sea1+2.*str1+2.*chm1)+
5629 *4.*sea1*(2.*sea2+2.*str2+2.*chm2)+2.*str1*(4.*sea2+2.*chm2)+
5630 *2.*chm1*(4.*sea2+2.*str2))
5631 return
5632 end
5633
5634
5635 subroutine pslcsh(wp1,wm1,wp2,wm2,samqt,amqpt)
5636
5637
5638
5639 double precision amqt(4),yqm(4),yqm1(4),xlp(4),xlm(4),am23,sx,y2
5640 *,wp1,wp2,wm1,wm2,s,sq,psutz,yqmax,y,amjp,amjm,y1,s12,s34,x34,amqpt
5641 dimension samqt(4)
5642 include 'epos.inc'
5643
5644 s=wp1*wm1
5645 sq=dsqrt(s)
5646 do i=1,4
5647 amqt(i)=dble(samqt(i))
5648 yqm(i)=dlog(sq/amqt(i)*psutz(s,amqt(i)**2,(amqpt-amqt(i))**2))
5649 enddo
5650 yqmax=max(yqm(1),yqm(2))
5651
5652 1 y=yqmax*dble(rangen())
5653 j=int(1.5+rangen())
5654 if(y.gt.yqm(j))goto 1
5655
5656 amjp=amqt(j)*dexp(y)
5657 amjm=amqt(j)*dexp(-y)
5658 do i=3,4
5659 am23=amqt(3-j)+amqt(7-i)
5660 sx=(am23+amjp)*(am23+amjm)
5661 yqm1(i)=dlog(sq/amqt(i)*psutz(s,amqt(i)**2,sx))
5662 enddo
5663 yqmax1=max(yqm1(3),yqm1(4))
5664 if(dble(rangen()).gt.yqmax1/max(yqm(3),yqm(4)))goto 1
5665
5666 y1=yqmax1*dble(rangen())
5667 j1=int(3.5+rangen())
5668 if(y1.gt.yqm1(j1))goto 1
5669
5670 amjp1=amqt(j1)*exp(y1)
5671 amjm1=amqt(j1)*exp(-y1)
5672 s12=(amqt(3-j)+amjp)*(amqt(3-j)+amjm)
5673 s34=(amqt(7-j1)+amjp1)*(amqt(7-j1)+amjm1)
5674 y2=dlog(sq/(amqt(3-j)+amjp)*psutz(s,s12,s34))
5675
5676 xlp(j)=amqt(j)/sq*dexp(y+y2)
5677 xlm(j)=amqt(j)/sq*dexp(-y-y2)
5678 xlp(3-j)=amqt(3-j)/sq*dexp(y2)
5679 xlm(3-j)=amqt(3-j)/sq*dexp(-y2)
5680 x34=1.-xlm(1)-xlm(2)
5681 xlm(7-j1)=x34/(1.+amjp1/amqt(7-j1))
5682 xlm(j1)=x34-xlm(7-j1)
5683
5684 if(dble(rangen()).gt.(xlp(1)*xlp(2)*xlm(3)*xlm(4))**(-alpqua)*
5685 *(xlp(j)*(1.d0-xlp(j))*xlm(j1)*(1.d0-xlm(j1))))goto 1
5686
5687 wp2=xlp(2)*wp1
5688 wp1=xlp(1)*wp1
5689 wm2=xlm(4)*wm1
5690 wm1=xlm(3)*wm1
5691
5692 return
5693 end
5694
5695
5696 function psnorm(ep)
5697
5698
5699
5700 double precision sm2,ep(4)
5701 sm2=ep(1)**2
5702 do i=1,3
5703 sm2=sm2-ep(i+1)**2
5704 enddo
5705 psnorm=sm2
5706 return
5707 end
5708
5709
5710 subroutine psrotat(ep,s0x,c0x,s0,c0)
5711
5712
5713
5714
5715
5716 dimension ep(4),ep1(3)
5717
5718 ep1(3)=ep(4)
5719 ep1(2)=ep(2)*s0+ep(3)*c0
5720 ep1(1)=ep(2)*c0-ep(3)*s0
5721
5722 ep(2)=ep1(1)
5723 ep(4)=ep1(2)*s0x+ep1(3)*c0x
5724 ep(3)=ep1(2)*c0x-ep1(3)*s0x
5725 return
5726 end
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748 function pssalf(qq)
5749
5750
5751
5752 include "epos.incsem"
5753 pssalf=2./(11.-naflav/1.5)/log(qq)
5754 return
5755 end
5756
5757
5758 subroutine pstrans(ep,ey,jj)
5759
5760
5761
5762
5763
5764
5765 dimension ey(3),ep(4)
5766
5767 if(jj.eq.1)then
5768
5769 do i=1,3
5770 if(ey(4-i).ne.1.)then
5771 wp=(ep(1)+ep(5-i))/ey(4-i)
5772 wm=(ep(1)-ep(5-i))*ey(4-i)
5773 ep(1)=.5*(wp+wm)
5774 ep(5-i)=.5*(wp-wm)
5775 endif
5776 enddo
5777 else
5778
5779 do i=1,3
5780 if(ey(i).ne.1.)then
5781 wp=(ep(1)+ep(i+1))*ey(i)
5782 wm=(ep(1)-ep(i+1))/ey(i)
5783 ep(1)=.5*(wp+wm)
5784 ep(i+1)=.5*(wp-wm)
5785 endif
5786 enddo
5787 endif
5788 return
5789 end
5790
5791
5792 double precision function psuds(q,m)
5793
5794
5795
5796
5797
5798 dimension wi(3)
5799 common /psar15/ sudx(40,2)
5800 include 'epos.incsem'
5801 double precision dps,qlm,ffacs,qlm0,qlmi
5802
5803 j=min(iabs(m),1)+1
5804
5805 if(q.gt.q2ini)then
5806 qli=log(q/q2min)*2.+1.
5807 i=int(qli)
5808 if(i.lt.1)i=1
5809 if(i.gt.38)i=38
5810 wi(2)=qli-i
5811 wi(3)=wi(2)*(wi(2)-1.)*.5
5812 wi(1)=1.-wi(2)+wi(3)
5813 wi(2)=wi(2)-2.*wi(3)
5814 dps=0.d0
5815 do i1=1,3
5816 dps=dps+dble(sudx(i+i1-1,j)*wi(i1))
5817 enddo
5818
5819 qlm0=dble(log(q2ini/qcdlam))
5820 qlm=dble(log(q/qcdlam))
5821 qlmi=qlm-qlm0 !=log(q/q2ini)
5822 psuds=(qlm*log(qlm/qlm0)-qlmi)
5823
5824 ffacs=(11.d0-dble(naflav)/1.5d0)/12.d0
5825 if(j.eq.1)then
5826 psuds=(psuds-ffacs*log(qlm/qlm0)
5827 * +dps*(1.d0-dble(q2ini/q)))/ffacs
5828 else
5829 psuds=(psuds-log(qlm/qlm0)*.75d0
5830 * +dps*(1.d0-dble(q2ini/q)))*4.d0/9.d0/ffacs
5831 endif
5832 psuds=exp(-psuds)
5833 else
5834 psuds=1.d0
5835 endif
5836 return
5837 end
5838
5839
5840 function psudx(q,j)
5841
5842
5843
5844
5845
5846 common /ar3/ x1(7),a1(7)
5847 include 'epos.incsem'
5848
5849 psudx=0.
5850
5851 do i=1,7
5852 do m=1,2
5853 qt=.5*(q2ini+q-x1(i)*(2.*m-3.)*(q2ini-q))
5854 if(j.eq.1)then
5855 zm=1.-qt/q
5856 dps=((11.-naflav/1.5)/12.-zm**2*(1.-naflav/12.)+
5857 * (zm**3/3.-zm**4/4.)*(1.-naflav/3.))*q/qt
5858 else
5859 dps=(1.-qt/q/4.)
5860 endif
5861 psudx=psudx+a1(i)*dps/log(qt/qcdlam)
5862 enddo
5863 enddo
5864 psudx=psudx*.5
5865 return
5866 end
5867
5868
5869 double precision function psutz(s,a,b)
5870
5871
5872
5873
5874
5875
5876 double precision a1,b1,s1,x,dx,s,a,b
5877 a1=dsqrt(a)
5878 b1=dsqrt(b)
5879 s1=dsqrt(s)
5880 x=(1.d0+(a1-b1)*(a1+b1)/s)/2.d0
5881 dx=(x-a1/s1)*(x+a1/s1)
5882
5883
5884 if(dx.gt.0.d0)then
5885 x=x+dsqrt(dx)
5886 else
5887 x=a1/s1
5888 endif
5889 psutz=min(0.999999999d0,x)
5890 return
5891 end
5892
5893
5894 block data ptdata
5895
5896
5897
5898 common /ar3/ x1(7),a1(7)
5899 common /ar4/ x4(2),a4(2)
5900 common /ar5/ x5(2),a5(2)
5901 common /ar8/ x2(4),a2
5902 common /ar9/ x9(3),a9(3)
5903
5904 data x1/.9862838,.9284349,.8272013,.6872929,.5152486,
5905 *.3191124,.1080549/
5906 data a1/.03511946,.08015809,.1215186,.1572032,
5907 *.1855384,.2051985,.2152639/
5908 data x2/.00960736,.0842652,.222215,.402455/
5909 data a2/.392699/
5910 data x4/ 0.339981,0.861136/
5911 data a4/ 0.652145,0.347855/
5912 data x5/.585786,3.41421/
5913 data a5/.853553,.146447/
5914 data x9/.93247,.661209,.238619/
5915 data a9/.171324,.360762,.467914/
5916 end
5917
5918
5919 subroutine strdo1(x,scale,upv,dnv,sea,str,chm,gl)
5920
5921
5922
5923 implicit double precision(a-h,o-z)
5924 double precision
5925 + f(5),a(6,5),b1(3,6,5)
5926 data q0,ql1/2.d0,.2d0/
5927 data b1/3.d0,0.d0,0.d0,.419d0,.004383d0,-.007412d0,
5928 &3.46d0,.72432d0,-.065998d0,4.4d0,-4.8644d0,1.3274d0,
5929 &6*0.d0,1.d0,
5930 &0.d0,0.d0,.763d0,-.23696d0,.025836d0,4.d0,.62664d0,-.019163d0,
5931 &0.d0,-.42068d0,.032809d0,6*0.d0,1.265d0,-1.1323d0,.29268d0,
5932 &0.d0,-.37162d0,-.028977d0,8.05d0,1.5877d0,-.15291d0,
5933 &0.d0,6.3059d0,-.27342d0,0.d0,-10.543d0,-3.1674d0,
5934 &0.d0,14.698d0,9.798d0,0.d0,.13479d0,-.074693d0,
5935 &-.0355d0,-.22237d0,-.057685d0,6.3494d0,3.2649d0,-.90945d0,
5936 &0.d0,-3.0331d0,1.5042d0,0.d0,17.431d0,-11.255d0,
5937 &0.d0,-17.861d0,15.571d0,1.564d0,-1.7112d0,.63751d0,
5938 &0.d0,-.94892d0,.32505d0,6.d0,1.4345d0,-1.0485d0,
5939 &9.d0,-7.1858d0,.25494d0,0.d0,-16.457d0,10.947d0,
5940 &0.d0,15.261d0,-10.085d0/
5941 wn=1.d0
5942 s= log( log( max(q0,scale)/ql1)/ log(q0/ql1))
5943 do 10 i=1,5
5944 do 10 j=1,6
5945 10 a(j,i)=b1(1,j,i)+s*(b1(2,j,i)+s*b1(3,j,i))
5946 do 40 i=1,5
5947 40 f(i)=a(1,i)*x**a(2,i)*(wn-x)**a(3,i)*(wn+x*
5948 & (a(4,i)+x*(a(5,i)+x*a(6,i))))
5949 do 50 i=1,2
5950 aa=wn+a(2,i)+a(3,i)
5951 50 f(i)=f(i)*utgam2(aa)/((wn+a(2,i)*a(4,i)/aa)
5952 &*utgam2(a(2,i))*utgam2(wn+a(3,i)))
5953 upv=f(1)-f(2)
5954 dnv=f(2)
5955 sea=f(3)/6.d0
5956 str=sea
5957 chm=f(4)
5958 gl =f(5)
5959 return
5960 end
5961
5962
5963
5964
5965 function fzeroGluZZ(z,k) ! former psftild
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979 double precision xpmin,xp
5980 include 'epos.inc'
5981 common /ar3/ x1(7),a1(7)
5982 include 'epos.incsem'
5983
5984 fzeroGluZZ=0.
5985 xpmin=z
5986 xpmin=xpmin**(1.-alppar+dels+epszero)
5987 do i=1,7
5988 do m=1,2
5989 xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
5990 * (1.-alppar+dels+epszero))
5991 fzeroGluZZ=fzeroGluZZ+a1(i)*(1.-xp)**alplea(k)*(1.-z/xp)**betpom
5992 enddo
5993 enddo
5994 fzeroGluZZ=
5995 * fzeroGluZZ*.5*(1.-xpmin)/(1.-alppar+dels+epszero)
5996 * *(1.-glusea) *engy**epszero
5997 return
5998 end
5999
6000
6001 function fzeroSeaZZ(z,k) ! former psftile
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015 double precision xpmin,xp
6016 common /ar3/ x1(7),a1(7)
6017 include 'epos.inc'
6018 include 'epos.incsem'
6019
6020 fzeroSeaZZ=0.
6021 xpmin=z
6022 xpmin=xpmin**(1.-alppar+dels+epszero)
6023 do i=1,7
6024 do m=1,2
6025 xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
6026 * (1.-alppar+dels+epszero))
6027 zz=z/xp
6028 fzeroSeaZZ=fzeroSeaZZ+a1(i)*(1.-xp)**alplea(k)*EsoftQZero(zz)
6029 enddo
6030 enddo
6031 fzeroSeaZZ=fzeroSeaZZ*.5*(1.-xpmin)/(1.-alppar+dels+epszero)
6032 * *glusea *engy**epszero
6033 return
6034 end
6035
6036
6037
6038
6039 subroutine psaini
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057 include 'epos.inc'
6058 include 'epos.incpar'
6059 include 'epos.incsem'
6060 include 'epos.incems'
6061 logical lcalc!,lcalc2
6062
6063 dimension gamhad0(nclha),r2had0(nclha),chad0(nclha)
6064 *,alplea0(nclha),asect11(7,4,7),asect13(7,4,7),asect21(7,4,7)
6065 *,asect23(7,4,7),asect31(7,7,7),asect33(7,7,7)
6066 *,asect41(7,7,7),asect43(7,7,7)!,cgam(idxD)
6067 common /psar2/ edmax,epmax
6068 common /psar4/ fhgg(11,10,8),fhqg(11,10,80)
6069 *,fhgq(11,10,80),fhqq(11,10,80),fhgg0(11,10),fhgg1(11,10,4)
6070 *,fhqg1(11,10,40),fhgg01(11),fhgg02(11),fhgg11(11,4)
6071 *,fhgg12(11,4),fhqg11(11,10,4),fhqg12(11,10,4)
6072 *,ftoint(11,14,2,2,3)
6073 common /psar7/ delx,alam3p,gam3p
6074 common /psar9/ alpr
6075 common /psar15/ sudx(40,2)
6076 common /psar19/ cstot(20,20,240)
6077 common /psar20/ csord(20,20,240)
6078 common /psar21/ csbor(20,160,2)
6079 common /psar22/ cstotzero(20,4,2),csborzer(20,4,2)
6080 common /psar23/ cschar(20,20,2)
6081 common /psar25/ csdsi(21,21,104)
6082 common /psar27/ csds(21,26,4),csdt(21,26,2),csdr(21,26,2)
6083 common /psar33/ asect(7,4,7),asectn(7,7,7)
6084 common /psar34/ rrr,rrrm
6085 common /psar35/ anorm,anormp
6086 common /psar41/ rrrp,rrrmp
6087 common /psar36/ alvc
6088 common /psar37/ coefom1,coefom2
6089 common /psar38/ vfro(11,14,3,2)
6090 common /psar39/ vnorm(11,14,3,2,2)
6091
6092
6093 common/producetab/ producetables !used to link with CRMC
6094 logical producetables
6095 common /ar3/ x1(7),a1(7)
6096 common /testj/ ajeth(4),ajete(5),ajet0(7)
6097 parameter(nbkbin=40)
6098 common /kfitd/ xkappafit(nclegy,nclha,nclha,nbkbin),xkappa,bkbin
6099 common/geom/rmproj,rmtarg,bmax,bkmx
6100 character textini*38
6101 external ptfau,ptfauAA
6102
6103
6104 call utpri('psaini',ish,ishini,4)
6105
6106
6107
6108
6109 nrflav=min(max(nrflav,naflav),nflavems)
6110 pmqu2=pmqu**2
6111 difud=pmqd**2-pmqu2
6112 difus=pmqs**2-pmqu2
6113 difuuu=(pmqq+pmqu+pmqu)**2-pmqu2
6114 difuud=(pudd*pmqq+pmqd+pmqu)**2-pmqu2
6115 difuus=(puds*pmqq+pmqs+pmqu)**2-pmqu2
6116 difudd=(pudd*pudd*pmqq+pmqd+pmqd)**2-pmqu2
6117 difuds=(pudd*puds*pmqq+pmqs+pmqd)**2-pmqu2
6118 difuss=(puds*puds*pmqq+pmqs+pmqs)**2-pmqu2
6119 if(nrflav.gt.3)then
6120 difuc=pmqc**2-pmqu2
6121 difuuc=(pudc*pmqq+pmqc+pmqu)**2-pmqu2
6122 difudc=(pudd*pudc*pmqq+pmqc+pmqd)**2-pmqu2
6123 difusc=(puds*pudc*pmqq+pmqc+pmqs)**2-pmqu2
6124 difucc=(pudc*pudc*pmqq+pmqc+pmqs)**2-pmqu2
6125 else
6126 difuc=0.
6127 difuuc=0.
6128 difudc=0.
6129 difusc=0.
6130 difucc=0.
6131 rstrac(1)=0.
6132 rstrac(2)=0.
6133 rstrac(3)=0.
6134 rstrac(4)=0.
6135 endif
6136
6137 if(iappl.ne.6)then
6138
6139 do i=1,4
6140 ajeth(i)=0.
6141 enddo
6142 do i=1,5
6143 ajete(i)=0.
6144 ajet0(i)=0.
6145 enddo
6146 ajet0(6)=0.
6147 ajet0(7)=0.
6148
6149
6150 if(isetcs.le.1)then !for Kfit
6151 bkbin=0.3
6152 else
6153 bkbin=0.1
6154 endif
6155 xkappa=1.
6156
6157 edmax=edmaxi !1.e12 defined in epos-bas
6158 epmax=epmaxi !1.e12 defined in epos-bas
6159
6160
6161 delx=1.5 !sqrt(egymin*egymin/exp(1.))
6162
6163 alam3p=0.5*(r2had(1)+r2had(2)+r2had(3)) !0.6
6164 gam3p=.1
6165
6166
6167
6168
6169
6170
6171 dels=alppom-1.
6172 alpqua=(alppar+1.)/2.
6173 if(abs(alpqua).lt.1.e-6)call utstop('alpar should not be -1 !&')
6174 alpr=-2.+alpqua !x-exponent for remnant mass
6175
6176
6177
6178
6179 coefom0=utgam1(1.+dels-alppar)*utgam1(1.+alplea(iclpro))
6180 */utgam1(2.+alplea(iclpro)+dels-alppar)
6181 **utgam1(1.+dels-alppar)*utgam1(1.+alplea(icltar))
6182 */utgam1(2.+alplea(icltar)+dels-alppar)
6183 coefom1=1.-utgam1(1.+dels-alppar)**2*utgam1(1.+alplea(iclpro))
6184 */utgam1(1.+alplea(iclpro)+2.*(1.+dels-alppar))
6185 **utgam1(1.+dels-alppar)**2*utgam1(1.+alplea(icltar))
6186 */utgam1(1.+alplea(icltar)+2.*(1.+dels-alppar))/coefom0**2
6187 coefom2=3.*coefom1-1.
6188 *+utgam1(1.+dels-alppar)**3*utgam1(1.+alplea(iclpro))
6189 */utgam1(1.+alplea(iclpro)+3.*(1.+dels-alppar))
6190 **utgam1(1.+dels-alppar)**3*utgam1(1.+alplea(icltar))
6191 */utgam1(1.+alplea(icltar)+3.*(1.+dels-alppar))/coefom0**3
6192 if(ish.ge.4)write(ifch,*)'coefom',coefom0,coefom1,coefom2,delx
6193
6194
6195
6196 if(iappl.eq.1.or.iappl.eq.8.or.iappl.eq.9)then
6197
6198
6199
6200
6201
6202 stmass=.05 !string mass cutoff
6203
6204
6205
6206 sq=log(log(q2min/.232**2)/log(.23/.232**2))
6207 du=2.997+.753*sq-.076*sq*sq
6208 qnorm=0.
6209 do i=1,7
6210 do m=1,2
6211 xx=.5+x1(i)*(m-1.5)
6212 xxq=1.-xx**(1./(1.+du))
6213 qnorm=qnorm+a1(i)*(psdfh4(xxq,q2min,0.,2,1)+
6214 * psdfh4(xxq,q2min,0.,2,2))/(1.-xxq)**du
6215 enddo
6216 enddo
6217 qnorm=qnorm*.5/(1.+du)
6218 qnormp=qnorm
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228 ffrr=gamtil
6229 * /utgam1(1.+alplea(2))/
6230 * utgam1(2.-alppar)*utgam1(3.+alplea(2)-alppar)
6231 gamsoft=ffrr*4.*pi
6232
6233 if(ish.ge.4)write (ifch,*)'rr,qnorm',ffrr,qnorm
6234
6235
6236 sq=log(log(q2min/.232**2)/log(.25/.232**2))
6237 dpi=.367+.563*sq
6238 qnorm=0.
6239 do i=1,7
6240 do m=1,2
6241 xx=.5+x1(i)*(m-1.5)
6242 xxq=1.-xx**(1./(1.+dpi))
6243 qnorm=qnorm+a1(i)*(psdfh4(xxq,q2min,0.,1,1)+
6244 * psdfh4(xxq,q2min,0.,1,2))/(1.-xxq)**dpi
6245 enddo
6246 enddo
6247 qnorm=qnorm*.5/(1.+dpi)
6248 cftmp=1./(1.-qnormp)*(1.-qnorm)
6249 * *utgam1(alplea(2)+1.)/utgam1(alplea(2)+3.-alppar)
6250 * /utgam1(alplea(1)+1.)*utgam1(alplea(1)+3.-alppar)
6251 gamhad(1)=gamhad(2)*cftmp
6252 if(gamhadsi(1).lt.0.)then
6253 gamhads(1)=gamhad(1)
6254 else
6255 gamhads(1)=gamhad(1)*gamhadsi(1)
6256 endif
6257 gamhad(1)=gamhads(1)
6258 if(ish.ge.4)
6259 * write (ifch,*)'gamhad(1),gamhads(1)',gamhad(1),gamhads(1)
6260
6261 if(gamhadsi(2).lt.0.)then
6262 gamhads(2)=gamhad(2)
6263 else
6264 gamhads(2)=gamhad(2)*gamhadsi(2)
6265 endif
6266 gamhad(2)=gamhads(2)
6267 if(ish.ge.4)
6268 * write (ifch,*)'gamhad(2),gamhads(2)',gamhad(2),gamhads(2)
6269
6270 qnorm=0.
6271 do i=1,7
6272 do m=1,2
6273 xx=.5+x1(i)*(m-1.5)
6274 xxq=1.-xx**(1./(1.+dpi))
6275 qnorm=qnorm+a1(i)*(psdfh4(xxq,q2min,0.,1,1)+
6276 * psdfh4(xxq,q2min,0.,1,2))/(1.-xxq)**dpi
6277 enddo
6278 enddo
6279 qnorm=qnorm*.5/(1.+dpi)
6280 cftmp=1./(1.-qnormp)*(1.-qnorm)
6281 * *utgam1(alplea(2)+1.)/utgam1(alplea(2)+3.-alppar)
6282 * /utgam1(alplea(3)+1.)*utgam1(alplea(3)+3.-alppar)
6283 gamhad(3)=gamhad(2)*cftmp
6284 if(gamhadsi(3).lt.0.)then
6285 gamhads(3)=gamhad(3)
6286 else
6287 gamhads(3)=gamhad(3)*gamhadsi(3)
6288 endif
6289 gamhad(3)=gamhads(3)
6290 if(ish.ge.4)
6291 * write (ifch,*)'gamhad(3),gamhads(3)',gamhad(3),gamhads(3)
6292
6293 quamas=.35
6294 gamhad(4)=gamhad(1)*(quamas/qcmass)**2
6295 if(gamhadsi(4).lt.0.)then
6296 gamhads(4)=gamhad(4)
6297 else
6298 gamhads(4)=gamhad(4)*gamhadsi(4)
6299 endif
6300 gamhad(4)=gamhads(4)
6301 if(ish.ge.4)
6302 * write (ifch,*)'gamhad(4),gamhads(4)',gamhad(4),gamhads(4)
6303 gnorm=0.
6304 do i=1,7
6305 do m=1,2
6306 xx=.5+x1(i)*(m-1.5)
6307 xxg=xx**(1./(1.-dels))
6308 gnorm=gnorm+a1(i)*(fzeroGluZZ(xxg,4)+fzeroSeaZZ(xxg,4))
6309 enddo
6310 enddo
6311 gnorm=gnorm/(1.-dels)*2.*pi*gamhad(4)*ffrr
6312 alvc=6./(1.-gnorm)-4.
6313 if(ish.ge.4) write (ifch,*)'rr,qnorm,gnorm,alvc',
6314 * ffrr,qnorm,gnorm,alvc
6315
6316
6317 endif
6318
6319
6320
6321
6322
6323 do i=1,40
6324 qi=q2min*exp(.5*(i-1))
6325 sudx(i,1)=psudx(qi,1)
6326 sudx(i,2)=psudx(qi,2)
6327 enddo
6328 if(ish.ge.4)write(ifch,*)'bare cross sections ...'
6329
6330 call psaevc
6331
6332
6333
6334 inquire(file=fnii(1:nfnii),exist=lcalc)
6335 if(lcalc)then
6336 if(inicnt.eq.1)then
6337 write(ifmt,'(3a)')'read from ',fnii(1:nfnii),' ...'
6338 open(1,file=fnii(1:nfnii),status='old')
6339 read (1,*)qcdlam0,q2min0,q2ini0,naflav0,epmax0,pt2cut0
6340 if(qcdlam0.ne.qcdlam)write(ifmt,'(a)')'initl: wrong qcdlam'
6341 if(q2min0 .ne.q2min )write(ifmt,'(a)')'initl: wrong q2min'
6342 if(q2ini0 .ne.q2ini )write(ifmt,'(a)')'initl: wrong q2ini'
6343 if(naflav0.ne.naflav)write(ifmt,'(a)')'initl: wrong naflav'
6344 if(epmax0 .ne.epmax )write(ifmt,'(a)')'initl: wrong epmax'
6345 if(pt2cut0 .ne.pt2cut )write(ifmt,'(a)')'initl: wrong pt2cut'
6346 if(qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min .or.q2ini0 .ne.q2ini
6347 * .or.naflav0.ne.naflav.or.epmax0 .ne.epmax.or. pt2cut.ne.pt2cut0)
6348 * then
6349 write(ifmt,'(//a//)')' initl has to be reinitialized!!!'
6350 stop
6351 endif
6352 read (1,*)csbor,csord,cstot,cstotzero,csborzer
6353 close(1)
6354 endif
6355
6356 goto 1
6357
6358 elseif(.not.producetables)then
6359 write(ifmt,*) "Missing epos.initl file !"
6360 write(ifmt,*) "Please correct the defined path ",
6361 &"or force production ..."
6362 stop
6363
6364 endif
6365
6366 write(ifmt,'(a)')'initl does not exist -> calculate tables ...'
6367
6368 write (*,*)'Born xsection csbor'
6369 spmin=4.*q2min
6370 spminc=4.*q2min+qcmass**2
6371 do m=1,4 !parton type at upper end of the ladder (1...4 - g,u,d,c)
6372 do k=1,20
6373 if(m.ne.4)then
6374 sk=spmin*(epmax/2./spmin)**((k-1)/19.)
6375 p1=sk
6376 else
6377 sk=spminc*(epmax/2./spminc)**((k-1)/19.)
6378 p1=sk/(1.+qcmass**2/sk)
6379 endif
6380 qmax=p1/4.
6381 do i=1,20
6382 qq=q2min*(qmax/q2min)**((i-1)/19.)
6383 do l=1,2 !parton type at lower end of the ladder
6384 k1=k+20*(m-1)+80*(l-1)
6385 m1=m-1
6386 if(m.eq.3.and.l.eq.1)then !dd~
6387 l1=-m1
6388 else !du
6389 l1=l-1
6390 endif !born cr.-sect.
6391 csbor(i,k1,1)=log(max(1.e-30,psborn(qq,qq,qq,sk,m1,l1,0,0)))
6392 if(m.ne.4)then
6393 csbor(i,k1,2)=log(max(1.e-30,psborn(4.*qq,qq,qq,sk,m1,l1,1,0)))
6394 endif
6395 enddo
6396 enddo
6397 enddo
6398 enddo
6399
6400 write (*,*)'ordered jet xsection csord'
6401 do m=1,4 !parton type at upper end of the ladder
6402 do k=1,20
6403 write (*,*)' m=',m,'/4 k=',k,'/20'
6404 if(m.ne.4)then
6405 sk=spmin*(epmax/2./spmin)**((k-1)/19.) !c.m. energy squared for the hard
6406 p1=sk
6407 else
6408 sk=spminc*(epmax/2./spminc)**((k-1)/19.)
6409 p1=sk/(1.+qcmass**2/sk)
6410 endif
6411 qmax=p1/4.
6412 tmax=p1/2.
6413 do i=1,20 !cross-sections initialization
6414 qi=q2min*(qmax/q2min)**((i-1)/19.)
6415 do j=1,20
6416 qq=qi*(qmax/qi)**((j-1)/19.)
6417 if(p1.gt.4.*qq)then
6418 tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
6419 else
6420 tmin=2.*qq
6421 endif
6422 do l=1,2 !parton type at lower end of the ladder
6423 m1=m-1
6424 if(m.eq.3.and.l.eq.1)then
6425 l1=-m1
6426 else
6427 l1=l-1
6428 endif
6429 if(m.ne.4)then
6430 k1=k+20*(m-1)+60*(l-1)
6431 if(k.eq.1.or.i.eq.20.or.j.eq.20)then
6432 csord(i,j,k1)=log(max(1.e-30,psborn(qi,qq,qq,sk,m1,l1,0,0)))
6433 csord(i,j,k1+120)=
6434 * log(max(1.e-30,psborn(4.*qq,qi,qq,sk,l1,m1,1,0)))
6435 else
6436 csord(i,j,k1)=log(psjet1(qi,qq,qq,sk,m1,l1,0)
6437 * /(1./tmin-1./tmax)+psborn(qi,qq,qq,sk,m1,l1,0,0))
6438 csord(i,j,k1+120)=log(psjet1(qi,4.*qq,qq,sk,m1,l1,2)
6439 * /(1./tmin-1./tmax)+psborn(4.*qq,qi,qq,sk,l1,m1,1,0))
6440
6441 endif
6442 elseif(j.eq.1)then
6443 if(k.eq.1.or.i.eq.20)then
6444 cschar(i,k,l)=log(max(1.e-30,psborn(q2min,qi,qq,sk,m1,l1,0,0)))
6445 else
6446 cschar(i,k,l)=log(psjet1(qi,q2min,qq,sk,l1,m1,0)
6447 * /(1./tmin-1./tmax)+psborn(q2min,qi,qq,sk,m1,l1,0,0))
6448 endif
6449 endif
6450 enddo
6451 enddo
6452 enddo
6453 enddo
6454 enddo
6455
6456 write (ifmt,*)'tests:'
6457 write (ifmt,'(a,a)')' n-1 sk qi qj qq '
6458 * ,' born born-i ord ord-i '
6459 do k=1,7
6460 sk=spmin*(epmax/2./spmin)**((k-1)/19.)
6461 if(k.ge.5)sk=spmin*1.5**(k-4)
6462 do n=1,2
6463 if(n.eq.1)then
6464 qmax1=sk/4.
6465 qmax2=sk/4.
6466 else !if(n.eq.2)then
6467 qmax1=sk/4.
6468 qmax2=sk
6469 endif
6470 do i=1,3
6471 qi=q2min*(qmax1/q2min)**((i-1)/3.)
6472 do j=1,3
6473 qj=q2min*(qmax2/q2min)**((j-1)/3.)
6474 qqmax=sk/4.
6475 if(n.eq.1)then
6476 qqmin=max(qi,qj)
6477 else
6478 qqmin=max(qi,qj/4.)
6479 endif
6480 do lq=1,3
6481 qq=qqmin*(qqmax/qqmin)**((lq-1)/3.)
6482 if(sk.gt.4.*qq)then
6483 tmin=2.*qq/(1.+sqrt(1.-4.*qq/sk))
6484 else
6485 tmin=2.*qq
6486 endif
6487 tmax=sk/2.
6488 do m=1,1 !parton type at upper end of the ladder (1
6489 do l=1,1 !parton type at lower end of the ladder (1
6490 m1=m-1
6491 if(m.eq.3.and.l.eq.1)then
6492 l1=-m1
6493 else
6494 l1=l-1
6495 endif
6496 a=psborn(qj,qi,qq,sk,l1,m1,n-1,0)*(1./tmin-1./tmax)
6497 b=psbint(qj,qi,qq,sk,l1,m1,n-1)
6498 c=psjet1(qi,qj,qq,sk,m1,l1,2*(n-1))
6499 * +psborn(qj,qi,qq,sk,l1,m1,n-1,0)*(1./tmin-1./tmax)
6500 d=psjti1(qi,qj,qq,sk,m1,l1,n-1)
6501 write (ifmt,'(i3,4f9.1,3x,4f9.4)')n-1,sk,qi,qj,qq,a,b,c,d
6502 enddo
6503 enddo
6504 enddo
6505 enddo
6506 enddo
6507 enddo
6508 enddo
6509
6510 write (*,*)'jet xsection cstot'
6511 do k=1,20
6512 write (*,*)'k=',k,'/20'
6513 sk=spmin*(epmax/2./spmin)**((k-1)/19.) !c.m. energy squared for the hard
6514 qmax=sk/4.
6515 tmax=sk/2.
6516 do i=1,20 !cross-sections initialization
6517 do n=1,2
6518 if(n.eq.1)then
6519 qi=q2min*(qmax/q2min)**((i-1)/19.)
6520 else
6521 qi=q2min*(4.*qmax/q2min)**((i-1)/19.)
6522 endif
6523 do j=1,20
6524 if(n.eq.1)then
6525 qq=qi*(qmax/qi)**((j-1)/19.)
6526 else
6527 qq=max(q2min,qi/4.)*(qmax/max(q2min,qi/4.))**
6528 * ((j-1)/19.)
6529 endif
6530 if(sk.gt.4.*qq)then
6531 tmin=2.*qq/(1.+sqrt(1.-4.*qq/sk))
6532 else
6533 tmin=2.*qq
6534 endif
6535 do m=1,3 !parton type at upper end of the ladder (1
6536 do l=1,2 !parton type at lower end of the ladder (1
6537 m1=m-1
6538 if(m.eq.3.and.l.eq.1)then
6539 l1=-m1
6540 else
6541 l1=l-1
6542 endif
6543 k1=k+20*(m-1)+60*(l-1)+120*(n-1)
6544 if(k.eq.1.or.i.eq.20.or.j.eq.20)then
6545 cstot(i,j,k1)=log(max(1.e-30,psborn(qi,q2min,qq,sk,m1,l1,n-1,0)))
6546 else
6547 if(n.eq.1)then
6548 cstot(i,j,k1)=log((psjet(qi,q2min,qq,sk,m1,l1,0)+
6549 * psjti1(qi,q2min,qq,sk,m1,l1,0)+
6550 * psjti1(q2min,qi,qq,sk,l1,m1,0)
6551 * -psbint(qi,q2min,qq,sk,m1,l1,0))/(1./tmin-1./tmax))
6552 else
6553 cstot(i,j,k1)=log((psjet(qi,q2min,qq,sk,m1,l1,1)+
6554 * psjet1(qi,q2min,qq,sk,m1,l1,1)+
6555 * psjti1(q2min,qi,qq,sk,l1,m1,1))/(1./tmin-1./tmax))
6556 endif
6557 endif
6558 enddo
6559 enddo
6560 enddo
6561 enddo
6562 enddo
6563 enddo
6564
6565
6566
6567 spmin=4.*q2min
6568 spminc=4.*q2min+qcmass**2
6569 do m=1,4
6570 do l=1,2
6571 m1=m-1
6572 if(m.eq.3.and.l.eq.1)then
6573 l1=-m1
6574 else
6575 l1=l-1
6576 endif
6577 do k=1,20
6578 if(m.ne.4)then
6579 sk=spmin*(epmax/2./spmin)**((k-1)/19.) !c.m. energy squared for the hard
6580 p1=sk
6581 qq=q2min
6582 else
6583 sk=spminc*(epmax/2./spminc)**((k-1)/19.)
6584 p1=sk/(1.+qcmass**2/sk)
6585 qq=q2min
6586 endif
6587 if(p1.gt.4.*qq)then
6588 tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
6589 else
6590 tmin=2.*qq
6591 endif
6592 tmax=p1/2.
6593
6594 k1=k+20*(m-1)+80*(l-1)
6595 csborzer(k,m,l)
6596 * =log(max(1.e-30,psborn(q2min,q2min,qq,sk,m1,l1,0,0)))
6597 if(k.eq.1)then
6598 cstotzero(k,m,l)=csborzer(k,m,l)
6599 elseif(m.ne.4)then
6600 cstotzero(k,m,l)=log(psjti(q2min,qq,sk,m1,l1,0)/
6601 * (1./tmin-1./tmax))
6602 else
6603 smins=2.5*q2min*(1.+sqrt(1.+4.*qcmass**2/q2min))
6604 if(sk.le.smins)then
6605 cstotzero(k,m,l)=log(psjci(q2min,sk,l1)/(1./tmin-1./tmax))
6606 else
6607 cstotzero(k,m,l)=log((psjci(q2min,sk,l1)+psjct(sk,l1))
6608 * /(1./tmin-1./tmax))
6609 endif
6610 endif
6611 enddo
6612 enddo
6613 enddo
6614
6615 write(ifmt,'(a)')'write to initl ...'
6616 open(1,file=fnii(1:nfnii),status='unknown')
6617 write (1,*)qcdlam,q2min,q2ini,naflav,epmax,pt2cut
6618 write (1,*)csbor,csord,cstot,cstotzero,csborzer,cschar
6619 close(1)
6620
6621 1 continue
6622
6623 if(iappl.ne.8)goto 3
6624 if(ish.ge.3)write(ifch,*)'dis cross sections ...'
6625 inquire(file=fnid(1:nfnid),exist=lcalc)
6626 if(lcalc)then
6627 if(inicnt.eq.1)then
6628 write(ifmt,'(3a)')'read from ',fnid(1:nfnid),' ...'
6629 open(1,file=fnid(1:nfnid),status='old')
6630 read (1,*)qcdlam0,q2min0,q2ini0,naflav0,epmax0,edmax0
6631 if(qcdlam0.ne.qcdlam)write(ifmt,'(a)')'inidi: wrong qcdlam'
6632 if(q2min0 .ne.q2min )write(ifmt,'(a)')'inidi: wrong q2min'
6633 if(q2ini0 .ne.q2ini )write(ifmt,'(a)')'inidi: wrong q2ini'
6634 if(naflav0.ne.naflav)write(ifmt,'(a)')'inidi: wrong naflav'
6635 if(epmax0 .ne.epmax )write(ifmt,'(a)')'inidi: wrong epmax'
6636 if(edmax0 .ne.edmax )write(ifmt,'(a)')'inidi: wrong edmax'
6637 if(qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min.or.q2ini0 .ne.q2ini
6638 * .or.naflav0.ne.naflav.or.epmax0 .ne.epmax
6639 * .or.edmax0 .ne.edmax)then
6640 write(ifmt,'(//a//)')' inidi has to be reinitialized!!!'
6641 stop
6642 endif
6643 read (1,*)csdsi,csds,csdt,csdr
6644 close(1)
6645 endif
6646 goto 3
6647
6648 elseif(.not.producetables)then
6649 write(ifmt,*) "Missing epos.inidi file !"
6650 write(ifmt,*) "Please correct the defined path ",
6651 &"or force production ..."
6652 stop
6653
6654 endif
6655
6656 write(ifmt,'(a)')'inidi does not exist -> calculate tables ...'
6657 do j=1,21
6658 qq=q2min*exp(.5*(j-1)) !photon virtuality
6659
6660 do m=1,2 !parton type at the end of the ladder
6661 q2mass=qcmass**2
6662 s2min=4.*max(q2mass,q2min)+qq
6663 if(m.eq.2)s2min=s2min/(1.-4.*q2ini/(s2min-qq))
6664 do k=1,26
6665 write (*,*)'sin,j,m,k',j,m,k
6666 sk=s2min*(edmax/s2min)**(.04*(k-1)) !c.m. energy squared
6667 if(k.eq.26)sk=1.01*sk
6668 qmin=q2min
6669 if(m.eq.1)then
6670 qmax=(sk-qq)/4.
6671 else
6672 qmax=(sk-qq+sqrt((sk-qq)**2-16.*sk*q2ini))/8.
6673 endif
6674
6675 do i=1,21 !cross-sections calculation
6676 qi=qmin*(qmax/qmin)**((i-1)/20.)
6677 tmax=.5*sk
6678 qtq=4.*max(q2mass,qi)/(sk-qq)
6679 if(qtq.lt.1.)then
6680 tmin=.5*sk*qtq/(1.+sqrt(1.-qtq))
6681 else
6682 tmin=.5*sk
6683 endif
6684
6685 do ilong=1,2
6686 k1=k+26*(m-1)+52*(ilong-1)
6687 if(m.eq.1)then
6688 if(tmax.gt.1.01*tmin)then
6689 sij=psds(qi,qq,sk,m-1,ilong-1)
6690 if(sij.lt.0.)write (*,*)'qi,qq,sk,m,long,sij',
6691 * qi,qq,sk,m,ilong,sij
6692 csdsi(i,j,k1)=log(max(0.,sij)/(1./tmin-1./tmax)
6693 * +psdbor(qi,qq,sk,ilong-1))
6694 else
6695 csdsi(i,j,k1)=
6696 * log(max(1.e-25,psdbor(qi,qq,sk,ilong-1)))
6697 endif
6698 else
6699 csdsi(i,j,k1)=psds(qi,qq,sk,m-1,ilong-1)
6700 endif
6701 enddo
6702 enddo
6703 enddo
6704 enddo
6705 enddo
6706
6707 do j=1,21
6708 qq=q2min*exp(.5*(j-1)) !photon virtuality
6709 s2min=max(4.*qq,16.*q2min) !pt2dis=qq
6710 do m=1,2
6711 do k=1,26
6712 do ilong=1,2
6713 k1=k+26*(m-1)+52*(ilong-1)
6714 csds(j,k,m+2*(ilong-1))=csdsi(1,j,k1)
6715 enddo
6716
6717 sk=(s2min+qq)*(edmax/(s2min+qq))**(.04*(k-1))
6718 csdt(j,k,m)=psdres(qq,sk,s2min,m-1)
6719 csdr(j,k,m)=psdrga(qq,sk-qq,s2min,m-1)
6720 enddo
6721 enddo
6722 enddo
6723
6724 write(ifmt,'(a)')'write to inidi ...'
6725
6726 write(ifmt,'(a)')'write to inidi ...'
6727 open(1,file=fnid(1:nfnid),status='unknown')
6728 write (1,*)qcdlam,q2min,q2ini,naflav,epmax,edmax
6729 write (1,*)csdsi,csds,csdt,csdr
6730 close(1)
6731 3 continue
6732
6733
6734
6735
6736
6737 !!!!!!!!! if(iappl.eq.1)then
6738
6739 if(ish.ge.4)write(ifch,*)'semihard eikonals ...'
6740 5 continue
6741 inquire(file=fnrj,exist=lcalc)
6742 if(lcalc)then
6743 if(inicnt.eq.1)then
6744 write(ifmt,'(3a)')'read from ',fnrj(1:nfnrj),' ...'
6745 open(1,file=fnrj(1:nfnrj),status='old')
6746 read (1,*)alpqua0,alplea0,alppom0,slopom0,
6747 * gamhad0,r2had0,chad0,
6748 * qcdlam0,q2min0,q2ini0,betpom0,glusea0,naflav0,
6749 * factk0,pt2cut0,gamtil0
6750 if(alpqua0.ne.alpqua)write(ifmt,'(a,2f8.4)')
6751 * 'inirj: wrong alpqua',alpqua0,alpqua
6752 if(alppom0.ne.alppom)write(ifmt,'(a,2f8.4)')
6753 * 'inirj: wrong alppom',alppom0,alppom
6754 if(slopom0.ne.slopom)write(ifmt,'(a,2f8.4)')
6755 * 'inirj: wrong slopom',slopom0,slopom
6756 iii=2
6757 if(gamhad0(iii).ne.gamhad(iii))write(ifmt,'(a,i1,a,2f8.4)')
6758 * 'inirj: wrong gamhad(',iii,')',gamhad0(iii),gamhad(iii)
6759 do iii=1,3
6760 if(r2had0(iii) .ne.r2had(iii) )write(ifmt,'(a,i1,a,2f8.4)')
6761 * 'inirj: wrong r2had(',iii,')',r2had0(iii),r2had(iii)
6762 if(chad0(iii) .ne.chad(iii) )write(ifmt,'(a,i1,a,2f8.4)')
6763 * 'inirj: wrong chad(',iii,')',chad0(iii),chad(iii)
6764 if(alplea0(iii).ne.alplea0(iii))write(ifmt,'(a,i1,a,2f8.4)')
6765 * 'inirj: wrong alplea(',iii,')',alplea0(iii),alplea(iii)
6766 enddo
6767 if(qcdlam0.ne.qcdlam)write(ifmt,'(a,2f8.4)')
6768 * 'inirj: wrong qcdlam',qcdlam0,qcdlam
6769 if(q2min0 .ne.q2min )write(ifmt,'(a,2f8.4)')
6770 * 'inirj: wrong q2min',q2min0,q2min
6771 if(q2ini0 .ne.q2ini )write(ifmt,'(a,2f8.4)')
6772 * 'inirj: wrong q2ini',q2ini0,q2ini
6773 if(betpom0.ne.betpom)write(ifmt,'(a,2f8.4)')
6774 * 'inirj: wrong betpom',betpom0,betpom
6775 if(glusea0.ne.glusea)write(ifmt,'(a,2f8.4)')
6776 * 'inirj: wrong glusea',glusea0,glusea
6777 if(naflav0.ne.naflav)write(ifmt,'(a,2f8.4)')
6778 * 'inirj: wrong naflav',naflav0,naflav
6779 if(factk0 .ne.factk )write(ifmt,'(a,2f8.4)')
6780 * 'inirj: wrong factk', factk0,factk
6781 if(pt2cut0 .ne.pt2cut )write(ifmt,'(a,2f8.4)')
6782 * 'inirj: wrong pt2cut', pt2cut0,pt2cut
6783 if(gamtil0 .ne.gamtil )write(ifmt,'(a,2f8.4)')
6784 * 'inirj: wrong gamtil', gamtil0,gamtil
6785 if(alpqua0.ne.alpqua.or.alppom0.ne.alppom
6786 * .or.slopom0.ne.slopom.or.gamhad0(2).ne.gamhad(2)
6787 * .or.r2had0(1).ne.r2had(1).or.r2had0(2).ne.r2had(2)
6788 * .or.r2had0(3).ne.r2had(3)
6789 * .or.chad0(1).ne.chad(1).or.chad0(2).ne.chad(2)
6790 * .or.chad0(3).ne.chad(3)
6791 * .or.alplea0(1).ne.alplea(1).or.alplea0(2).ne.alplea(2)
6792 * .or.alplea0(3).ne.alplea(3)
6793 * .or.qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min
6794 * .or.q2ini0 .ne.q2ini.or.gamtil0.ne.gamtil
6795 * .or.betpom0.ne.betpom.or.glusea0.ne.glusea.or.naflav0.ne.naflav
6796 * .or.factk0 .ne.factk .or.pt2cut0.ne.pt2cut)then
6797 write(ifmt,'(//a//)')' inirj has to be reinitialized!!!!'
6798 stop
6799 endif
6800
6801 read(1,*)fhgg,fhqg,fhgq,fhqq,fhgg0,fhgg1,fhqg1
6802 * ,fhgg01,fhgg02,fhgg11,fhgg12,fhqg11,fhqg12
6803 * ,ftoint,vfro,vnorm,coefxu1,coefxu2,coefxc2
6804 read(1,*)bkbin0,iclpro10,iclpro20,icltar10,icltar20,iclegy10
6805 * ,iclegy20,egylow0,egymax0,iomega0,egyscr0,epscrw0,epscrp0
6806 if(isetcs.gt.1)then
6807 textini=' '
6808 if(iclpro10.ne.iclpro1)write(textini,'(a,2i8)')
6809 * 'inirj: wrong iclpro1 ',iclpro10,iclpro1
6810 if(iclpro20.ne.iclpro2)write(textini,'(a,2i8)')
6811 * 'inirj: wrong iclpro2 ',iclpro20,iclpro2
6812 if(icltar10.ne.icltar1)write(textini,'(a,2i8)')
6813 * 'inirj: wrong icltar1 ',icltar10,icltar1
6814 if(icltar20.ne.icltar2)write(textini,'(a,2i8)')
6815 * 'inirj: wrong icltar2 ',icltar20,icltar2
6816 if(iclegy10.ne.iclegy1)write(textini,'(a,2i8)')
6817 * 'inirj: wrong iclegy1 ',iclegy10,iclegy1
6818 if(iclegy20.ne.iclegy2)write(textini,'(a,2i8)')
6819 * 'inirj: wrong iclegy2 ',iclegy20,iclegy2
6820 if(iomega0.ne.iomega)write(textini,'(a,2i8)')
6821 * 'inirj: wrong iomega ',iomega0,iomega
6822 if(egylow0.ne.egylow)write(textini,'(a,2f8.4)')
6823 * 'inirj: wrong egylow ',egylow0,egylow
6824 if(egymax0.ne.egymax)write(textini,'(a,2f8.4)')
6825 * 'inirj: wrong egymax ',egymax0,egymax
6826 if(epscrw0.ne.epscrw)write(textini,'(a,2f8.4)')
6827 * 'inirj: wrong epscrw ',epscrw0,epscrw
6828 if(epscrp0.ne.epscrp)write(textini,'(a,2f8.4)')
6829 * 'inirj: wrong epscrp ',epscrp0,epscrp
6830 if(bkbin0.ne.bkbin)write(textini,'(a,2f8.4)')
6831 * 'inirj: wrong bkbin',bkbin0,bkbin
6832 if(textini.ne.' ')then
6833 write(ifmt,'(//10x,a//10x,a//)')textini,
6834 * 'inirj has to be reinitialized!!!!'
6835 stop
6836 endif
6837 do iiipro=iclpro1,iclpro2
6838 do iiitar=icltar1,icltar2
6839 do iiiegy=iclegy1,iclegy2
6840 do iiib=1,nbkbin
6841 read(1,*)xkappafit(iiiegy,iiipro,iiitar,iiib)
6842 enddo
6843 xkappafit(iiiegy,iiipro,iiitar,nbkbin)=1.
6844 do iiib=2,nbkbin-1
6845 if(xkappafit(iiiegy,iiipro,iiitar,iiib).lt.1.)then
6846 xkappafit(iiiegy,iiipro,iiitar,iiib)=max(1.,0.5*
6847 * (xkappafit(iiiegy,iiipro,iiitar,iiib-1)
6848 * +xkappafit(iiiegy,iiipro,iiitar,iiib+1)))
6849 endif
6850 enddo
6851 do iiidf=idxD0,idxD
6852 read(1,*)alpDs(iiidf,iiiegy,iiipro,iiitar),
6853 * alpDps(iiidf,iiiegy,iiipro,iiitar),
6854 * alpDpps(iiidf,iiiegy,iiipro,iiitar),
6855 * betDs(iiidf,iiiegy,iiipro,iiitar),
6856 * betDps(iiidf,iiiegy,iiipro,iiitar),
6857 * betDpps(iiidf,iiiegy,iiipro,iiitar),
6858 * gamDs(iiidf,iiiegy,iiipro,iiitar),
6859 * delDs(iiidf,iiiegy,iiipro,iiitar)
6860 enddo
6861 enddo
6862 enddo
6863 enddo
6864 endif
6865
6866 close(1)
6867
6868 endif
6869
6870
6871 goto 4
6872
6873 elseif(.not.producetables)then
6874 write(ifmt,*) "Missing epos.inirj file !"
6875 write(ifmt,*) "Please correct the defined path ",
6876 &"or force production ..."
6877 stop
6878
6879 endif
6880
6881 write(ifmt,'(a)')'inirj does not exist -> calculate tables ...'
6882
6883 engysave=engy
6884 maprojsave=maproj
6885 matargsave=matarg
6886 iclpros=iclpro
6887 icltars=icltar
6888 spmin=4.*q2min
6889 spminc=4.*q2min+2.*qcmass**2
6890 icltar=2
6891
6892 write(ifmt,'(a)')' tabulate om5 ...'
6893
6894 do iy=1,11
6895 sy=spmin*(epmax/2./spmin)**((iy-1)/10.)
6896 syc=spminc*(epmax/2./spminc)**((iy-1)/10.)
6897 iclpro=2
6898 icltar=2
6899 if(iy.eq.1)then
6900 fhgg01(iy)=-80.
6901 fhgg02(iy)=-80.
6902 else
6903 fhgg01(iy)=log(om51pp(sy,1.,1.,3))
6904 fhgg02(iy)=log(om51pp(sy,1.,1.,7))
6905 endif
6906
6907 do iclpro=iclpro1,iclpro2
6908 if(iy.eq.1)then
6909 fhgg11(iy,iclpro)=-80.
6910 fhgg12(iy,iclpro)=-80.
6911 else
6912 fhgg11(iy,iclpro)=log(om51pp(sy,1.,1.,4))
6913 fhgg12(iy,iclpro)=log(om51pp(sy,1.,1.,9))
6914 endif
6915 do ix=1,10
6916 if(ix.le.5)then
6917 xp=.1*2.**(ix-5)
6918 else
6919 xp=.2*(ix-5)
6920 endif
6921 if(iy.eq.1)then
6922 fhqg11(iy,ix,iclpro)=-80.
6923 fhqg12(iy,ix,iclpro)=-80.
6924 elseif(iclpro.eq.4)then
6925 fhqg11(iy,ix,iclpro)=log(om51pp(syc,1.,1.,5))
6926 fhqg12(iy,ix,iclpro)=log(om51pp(syc,1.,1.,11))
6927 else
6928 fhqg11(iy,ix,iclpro)=log(om51pp(sy,xp,1.,5))
6929 fhqg12(iy,ix,iclpro)=log(om51pp(sy,xp,1.,11))
6930 endif
6931 enddo
6932 enddo
6933
6934 do iz=1,10
6935 z=.1*iz
6936
6937 iclpro=2
6938 icltar=2
6939 if(iy.eq.1)then
6940 fhgg0(iy,iz)=-80.
6941 else
6942 fhgg0(iy,iz)=log(om51pp(sy,1.,z,6)/z)
6943 endif
6944
6945 do iclpro=iclpro1,iclpro2
6946 if(iy.eq.1)then
6947 fhgg1(iy,iz,iclpro)=-80.
6948 else
6949 fhgg1(iy,iz,iclpro)=log(om51pp(sy,1.,z,8)/z)
6950 endif
6951
6952 do ix=1,10
6953 if(ix.le.5)then
6954 xp=.1*2.**(ix-5)
6955 else
6956 xp=.2*(ix-5)
6957 endif
6958 if(iy.eq.1)then
6959 fhqg1(iy,ix,iz+10*(iclpro-1))=-80.
6960 elseif(iclpro.eq.4)then
6961 fhqg1(iy,ix,iz+10*(iclpro-1))=log(om51pp(syc,xp,z,10)/z)
6962 else
6963 fhqg1(iy,ix,iz+10*(iclpro-1))=log(om51pp(sy,xp,z,10)/z)
6964 endif
6965 enddo
6966 enddo
6967 enddo
6968 enddo
6969
6970 do iclpro=iclpro1,iclpro2 !hadron type (1 - pion, 2 - nucleon, 3 - kaon, 4 - charm)
6971 do icltar=icltar1,icltar2 !hadron type (2 - nucleon)
6972 do iy=1,11
6973 sy=spmin*(epmax/2./spmin)**((iy-1)/10.)
6974 syc=spminc*(epmax/2./spminc)**((iy-1)/10.)
6975 do iz=1,10
6976 z=.1*iz
6977 if(iy.eq.1)then
6978 fhgg(iy,iz,iclpro+4*(icltar-1))=-80.
6979 else
6980 fhgg(iy,iz,iclpro+4*(icltar-1))=log(om51pp(sy,1.,z,0)/z)
6981 endif
6982
6983 do ix=1,10
6984 if(ix.le.5)then
6985 xp=.1*2.**(ix-5)
6986 else
6987 xp=.2*(ix-5)
6988 endif
6989 if(iy.eq.1)then
6990 fhqg(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=-80.
6991 fhgq(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=-80.
6992 else
6993 if(iclpro.ne.4)then
6994 syx=sy
6995 else
6996 syx=syc
6997 endif
6998 fhqg(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=
6999 * log(om51pp(syx,xp,z,1)/z)
7000 if(icltar.ne.4)then
7001 syx=sy
7002 else
7003 syx=syc
7004 endif
7005 fhgq(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=
7006 * log(om51pp(syx,xp,z,2)/z)
7007 endif
7008 enddo
7009 enddo
7010
7011 do ix1=1,10
7012 if(ix1.le.5)then
7013 xpph=.1*2.**(ix1-5)
7014 else
7015 xpph=.2*(ix1-5)
7016 endif
7017 do ix2=1,10
7018 if(ix2.le.5)then
7019 xmm=.1*2.**(ix2-5)
7020 else
7021 xmm=.2*(ix2-5)
7022 endif
7023
7024 if(iy.eq.1)then
7025 fhqq(iy,ix1,ix2+10*(iclpro+4*(icltar-1)-1))=-80.
7026 else
7027 if(iclpro.ne.4.and.icltar.ne.4)then
7028 syx=sy
7029 else
7030 syx=syc
7031 endif
7032 fhqq(iy,ix1,ix2+10*(iclpro+4*(icltar-1)-1))=
7033 * log(pshard(syx,xpph,xmm))
7034 endif
7035 enddo
7036 enddo
7037 enddo
7038 enddo
7039
7040 enddo
7041
7042 if(isetcs.gt.1)then
7043
7044
7045 write(ifmt,'(a)')' tabulate fit parameters ...'
7046
7047 engysave=engy
7048 do iclpro=iclpro1,iclpro2 !hadron type (1 - pion, 2 - nucleon, 3 - kaon, 4 - charm)
7049 do icltar=icltar1,icltar2 !hadron type (2 - nucleon)
7050 do iclegy=iclegy2,iclegy1,-1
7051 call param
7052 enddo
7053 do iiclegy=iclegy2,iclegy1,-1
7054 engy=egyfac**(iiclegy-1)*egylow
7055 call paramini(0)
7056 call Kfit(iiclegy)
7057 enddo
7058 enddo
7059 enddo
7060 engy=engysave
7061
7062 endif
7063
7064 write(ifmt,'(a)')' write to inirj ...'
7065 open(1,file=fnrj,status='unknown')
7066 write (1,*)alpqua,alplea,alppom,slopom,gamhad,r2had,chad,
7067 *qcdlam,q2min,q2ini,betpom,glusea,naflav,factk,pt2cut,gamtil
7068 write (1,*)fhgg,fhqg,fhgq,fhqq,fhgg0,fhgg1,fhqg1
7069 *,fhgg01,fhgg02,fhgg11,fhgg12,fhqg11,fhqg12
7070 *,ftoint,vfro,vnorm,coefxu1,coefxu2,coefxc2
7071 write(1,*)bkbin,iclpro1,iclpro2,icltar1,icltar2,iclegy1,iclegy2
7072 *,egylow,egymax,iomega,egyscr,epscrw,epscrp
7073 do iiipro=iclpro1,iclpro2
7074 do iiitar=icltar1,icltar2
7075 do iiiegy=iclegy1,iclegy2
7076 do iiib=1,nbkbin
7077 write(1,*)xkappafit(iiiegy,iiipro,iiitar,iiib)
7078 enddo
7079 do iiidf=idxD0,idxD
7080 write(1,*)alpDs(iiidf,iiiegy,iiipro,iiitar),
7081 * alpDps(iiidf,iiiegy,iiipro,iiitar),
7082 * alpDpps(iiidf,iiiegy,iiipro,iiitar),
7083 * betDs(iiidf,iiiegy,iiipro,iiitar),
7084 * betDps(iiidf,iiiegy,iiipro,iiitar),
7085 * betDpps(iiidf,iiiegy,iiipro,iiitar),
7086 * gamDs(iiidf,iiiegy,iiipro,iiitar),
7087 * delDs(iiidf,iiiegy,iiipro,iiitar)
7088 enddo
7089 enddo
7090 enddo
7091 enddo
7092
7093 close(1)
7094
7095 engy=engysave
7096 maproj=maprojsave
7097 matarg=matargsave
7098 iclpro=iclpros
7099 icltar=icltars
7100 inicnt=1
7101 goto 5
7102
7103 4 continue
7104
7105
7106
7107
7108
7109 if(isetcs.ge.2)then !--------------------
7110
7111 if(ish.ge.4)write(ifch,*)'cross sections ...'
7112 6 continue
7113 inquire(file=fncs,exist=lcalc)
7114 if(lcalc)then
7115 if(inicnt.eq.1)then
7116 write(ifmt,'(3a)')'read from ',fncs(1:nfncs),' ...'
7117 open(1,file=fncs(1:nfncs),status='old')
7118 read (1,*)alpqua0,alplea0,alppom0,slopom0,
7119 * gamhad0,r2had0,chad0,
7120 * qcdlam0,q2min0,q2ini0,betpom0,glusea0,naflav0,
7121 * factk0,pt2cut0
7122 if(alpqua0.ne.alpqua)write(ifmt,'(a,2f8.4)')
7123 * 'inics: wrong alpqua',alpqua0,alpqua
7124 if(alppom0.ne.alppom)write(ifmt,'(a,2f8.4)')
7125 * 'inics: wrong alppom',alppom0,alppom
7126 if(slopom0.ne.slopom)write(ifmt,'(a,2f8.4)')
7127 * 'inics: wrong slopom',slopom0,slopom
7128 iii=2
7129 if(gamhad0(iii).ne.gamhad(iii))write(ifmt,'(a,i1,a,2f8.4)')
7130 * 'inics: wrong gamhad(',iii,')',gamhad0(iii),gamhad(iii)
7131 do iii=1,3
7132 if(r2had0(iii) .ne.r2had(iii) )write(ifmt,'(a,i1,a,2f8.4)')
7133 * 'inics: wrong r2had(',iii,')',r2had0(iii),r2had(iii)
7134 if(chad0(iii) .ne.chad(iii) )write(ifmt,'(a,i1,a,2f8.4)')
7135 * 'inics: wrong chad(',iii,')',chad0(iii),chad(iii)
7136 if(alplea0(iii).ne.alplea0(iii))write(ifmt,'(a,i1,a,2f8.4)')
7137 * 'inics: wrong alplea(',iii,')',alplea0(iii),alplea(iii)
7138 enddo
7139 if(qcdlam0.ne.qcdlam)write(ifmt,'(a,2f8.4)')
7140 * 'inics: wrong qcdlam',qcdlam0,qcdlam
7141 if(q2min0 .ne.q2min )write(ifmt,'(a,2f8.4)')
7142 * 'inics: wrong q2min',q2min0,q2min
7143 if(q2ini0 .ne.q2ini )write(ifmt,'(a,2f8.4)')
7144 * 'inics: wrong q2ini',q2ini0,q2ini
7145 if(betpom0.ne.betpom)write(ifmt,'(a,2f8.4)')
7146 * 'inics: wrong betpom',betpom0,betpom
7147 if(glusea0.ne.glusea)write(ifmt,'(a,2f8.4)')
7148 * 'inics: wrong glusea',glusea0,glusea
7149 if(naflav0.ne.naflav)write(ifmt,'(a,2f8.4)')
7150 * 'inics: wrong naflav',naflav0,naflav
7151 if(factk0 .ne.factk )write(ifmt,'(a,2f8.4)')
7152 * 'inics: wrong factk', factk0,factk
7153 if(pt2cut0 .ne.pt2cut )write(ifmt,'(a,2f8.4)')
7154 * 'inics: wrong pt2cut', pt2cut0,pt2cut
7155 if(alpqua0.ne.alpqua.or.alppom0.ne.alppom
7156 * .or.slopom0.ne.slopom.or.gamhad0(2).ne.gamhad(2)
7157 * .or.r2had0(1).ne.r2had(1).or.r2had0(2).ne.r2had(2)
7158 * .or.r2had0(3).ne.r2had(3)
7159 * .or.chad0(1).ne.chad(1).or.chad0(2).ne.chad(2)
7160 * .or.chad0(3).ne.chad(3)
7161 * .or.alplea0(1).ne.alplea(1).or.alplea0(2).ne.alplea(2)
7162 * .or.alplea0(3).ne.alplea(3)
7163 * .or.qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min
7164 * .or.q2ini0 .ne.q2ini
7165 * .or.betpom0.ne.betpom.or.glusea0.ne.glusea.or.naflav0.ne.naflav
7166 * .or.factk0 .ne.factk .or.pt2cut0.ne.pt2cut)then
7167 write(ifmt,'(//a//)')' inics has to be reinitialized!!!!'
7168 stop
7169 endif
7170
7171 read(1,*)isetcs0,iclpro10,iclpro20,icltar10,icltar20,iclegy10
7172 * ,iclegy20,egylow0,egymax0,iomega0,egyscr0,epscrw0,epscrp0
7173
7174 if(iclpro10.ne.iclpro1)write(ifmt,'(a,2i2)')
7175 * 'inics: wrong iclpro1',iclpro10,iclpro1
7176 if(iclpro20.ne.iclpro2)write(ifmt,'(a,2i2)')
7177 * 'inics: wrong iclpro2',iclpro20,iclpro2
7178 if(icltar10.ne.icltar1)write(ifmt,'(a,2i2)')
7179 * 'inics: wrong icltar1',icltar10,icltar1
7180 if(icltar20.ne.icltar2)write(ifmt,'(a,2i2)')
7181 * 'inics: wrong icltar2',icltar20,icltar2
7182 if(iclegy10.ne.iclegy1)write(ifmt,'(a,2i4)')
7183 * 'inics: wrong iclegy1',iclegy10,iclegy1
7184 if(iclegy20.ne.iclegy2)write(ifmt,'(a,2i4)')
7185 * 'inics: wrong iclegy2',iclegy20,iclegy2
7186 if(iomega0.ne.iomega)write(textini,'(a,2i8)')
7187 * 'inics: wrong iomega ',iomega0,iomega
7188 if(egylow0.ne.egylow)write(ifmt,'(a,2f8.4)')
7189 * 'inics: wrong egylow',egylow0,egylow
7190 if(egymax0.ne.egymax)write(ifmt,'(a,2f12.4)')
7191 * 'inics: wrong egymax',egymax0,egymax
7192 if(egyscr0.ne.egyscr)write(ifmt,'(a,2f8.4)')
7193 * 'inics: wrong egyscr ',egyscr0,egyscr
7194 if(epscrw0.ne.epscrw)write(ifmt,'(a,2f8.4)')
7195 * 'inics: wrong epscrw',epscrw0,epscrw
7196 if(epscrp0.ne.epscrp)write(ifmt,'(a,2f8.4)')
7197 * 'inics: wrong epscrp',epscrp0,epscrp
7198 if(isetcs0.lt.isetcs)write(ifmt,'(a,2f8.4)')
7199 * 'inics: wrong isetcs',isetcs0,isetcs
7200 if(iclpro10.ne.iclpro1.or.iclpro20.ne.iclpro2
7201 * .or.icltar10.ne.icltar1.or.icltar20.ne.icltar2
7202 * .or.iclegy10.ne.iclegy1.or.iclegy20.ne.iclegy2
7203 * .or.egylow0.ne.egylow.or.egymax0.ne.egymax
7204 * .or.egyscr0.ne.egyscr.or.epscrw0.ne.epscrw.or.isetcs0.lt.isetcs
7205 * .or.epscrp0.ne.epscrp)then
7206 write(ifmt,'(//a//)')' inics has to be reinitialized!!!!'
7207 stop
7208 endif
7209 if(isetcs.eq.2)then
7210 if(ionudi.eq.1)then
7211 read (1,*)asect,asect13,asect21,asect23,asectn
7212 * ,asect33,asect41,asect43
7213 else !ionudi=3
7214 read (1,*)asect11,asect,asect21,asect23,asect31
7215 * ,asectn,asect41,asect43
7216 endif
7217 elseif(isetcs.eq.3)then
7218 if(ionudi.eq.1)then
7219 read (1,*)asect11,asect13,asect,asect23,asect31
7220 * ,asect33,asectn,asect43
7221 else !ionudi=3
7222 read (1,*)asect11,asect13,asect21,asect,asect31
7223 * ,asect33,asect41,asectn
7224 endif
7225 else
7226 write(ifmt,'(//a//)')' Wrong isetcs in psaini !!!!'
7227 endif
7228
7229 close(1)
7230
7231 endif
7232
7233
7234 goto 7
7235
7236
7237 elseif(.not.producetables)then
7238 write(ifmt,*) "Missing epos.inics file !"
7239 write(ifmt,*) "Please correct the defined path ",
7240 &"or force production ..."
7241 stop
7242
7243 endif
7244
7245 ifradesave=ifrade
7246 iremnsave=iremn
7247 idprojsave=idproj
7248 idprojinsave=idprojin
7249 idtargsave=idtarg
7250 idtarginsave=idtargin
7251 laprojsave=laproj
7252 latargsave=latarg
7253 maprojsave=maproj
7254 matargsave=matarg
7255 icltarsave=icltar
7256 iclprosave=iclpro
7257 engysave=engy
7258 pnllsave=pnll
7259 elabsave=elab
7260 ecmssave=ecms
7261 iclegysave=iclegy
7262 nrevtsave=nrevt
7263 neventsave=nevent
7264 ntevtsave=ntevt
7265 isetcssave=isetcs
7266 noebinsave=noebin
7267 isigmasave=isigma
7268 bminimsave=bminim
7269 bmaximsave=bmaxim
7270 bimevtsave=bimevt
7271 bkmxndifsave=bkmxndif
7272
7273 ionudisave=ionudi
7274
7275
7276 isetcs=2
7277 isigma=1
7278 noebin=1
7279 idtarg=1120
7280 idtargin=1120
7281 bminim=0.
7282 bmaxim=10000.
7283 ifrade=0 !to save time, no fragmentation
7284 iremn=0 !to save time, simple remnants
7285 ionudi=3 !to have both ionudi=1 and 3 in tables
7286
7287 write(ifmt,'(a)')'inics does not exist -> calculate tables ...'
7288
7289
7290 if(seedj.ne.0d0)then
7291 call ranfini(seedj,iseqsim,2)
7292 else
7293 stop 'seedi = 0 ... Please define it !'
7294 endif
7295 call aseed(2)
7296
7297 laproj=-1
7298 maproj=1
7299 icltar=2
7300 do iclpro=1,4
7301 if(iclpro.lt.iclpro1.or.iclpro.gt.iclpro2)then
7302 do ie=1,7
7303 do iia=1,7
7304 asect11(ie,iclpro,iia)=0.
7305 asect21(ie,iclpro,iia)=0.
7306 asect13(ie,iclpro,iia)=0.
7307 asect23(ie,iclpro,iia)=0.
7308 enddo
7309 enddo
7310 else
7311 do ie=1,7
7312 engy=1.5*10.**(ie-1)
7313 call paramini(0)
7314 bkmxndif=conbmxndif()
7315 if(ish.ge.1)
7316 & write(ifch,*)' calcul. ',ie,' (',iclpro,')',engy
7317 write(ifmt,*)' calcul. ',ie,' (',iclpro,')',engy
7318
7319 sigine=0.
7320 do iia=1,7
7321 matarg=2**(iia-1)
7322 if(matarg.eq.1)then !hadron-proton interaction
7323
7324 call psfz(2,gz2,0.)
7325 gin=gz2*pi*10.
7326
7327 iomegasave=iomega
7328 iomega=2
7329 call psfz(2,gz2,0.)
7330 iomega=iomegasave
7331 gcut=gz2*pi*10.
7332
7333 difpart=gin-gcut
7334
7335 gqela=(1.-rexdif(iclpro))*(1.-rexdif(icltar))*difpart
7336 gin3=max(1.,gin-gqela)
7337 else
7338 call conini
7339 rad=radnuc(matarg)
7340 bm=rad+2.
7341 rrr=rad/difnuc(matarg)
7342 rrrm=rrr+log(9.)
7343 anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matarg)**2
7344
7345
7346 gcut=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig_in
7347 gin=gcut
7348
7349 iomegasave=iomega
7350 iomega=2
7351 gcut=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig_cut
7352 iomega=iomegasave
7353
7354 difpart=gin-gcut
7355
7356 gqela=(1.-rexdif(iclpro))
7357 & **(1.+rexres(iclpro)*float(matarg-1)**0.3)
7358
7359 gqela=gqela*(1.-rexdif(icltar))
7360 gqela=gqela*difpart
7361 gin3=max(1.,gin-gqela)
7362 endif
7363 if(ish.ge.1)write (ifch,226)matarg,gin,gin3
7364 226 format(2x,'psaini: hadron-nucleus (',i3,') cross sections:'/
7365 * 4x,'gin,gin3=',2e10.3)
7366 write(ifmt,*)' matarg,gin,gin3:',matarg,gin,gin3
7367 asect11(ie,iclpro,iia)=log(gin)
7368 asect13(ie,iclpro,iia)=log(gin3)
7369 enddo
7370 enddo
7371
7372 if(isetcssave.ge.3)then
7373
7374 if(iclpro.eq.1)then
7375 idprojin=120
7376 elseif(iclpro.eq.2)then
7377 idprojin=1120
7378 elseif(iclpro.eq.3)then
7379 idprojin=130
7380 endif
7381 do ie=1,7
7382 engy=1.5*10.**(ie-1)
7383 if(engy.le.egymin)engy=egymin
7384 if(engy.ge.egymax)engy=egymax
7385 write(ifmt,*)' simul. ',ie,' (',iclpro,')',engy
7386 if(ish.ge.1)
7387 & write(ifch,*)' simul. ',ie,' (',iclpro,')',engy
7388 do iia=1,7
7389 matarg=2**(iia-1)
7390 latarg=min(1,matarg/2)
7391
7392 ntevt=0
7393 nrevt=0
7394 pnll=-1.
7395 elab=-1.
7396 ecms=-1.
7397 ekin=-1.
7398 call conini
7399 call ainit
7400 nevent=50000
7401 if(matarg.eq.1)nevent=1
7402 call epocrossc(nevent,sigt,sigi,sigc,sige,sigql,sigd)
7403
7404 sigi3=sigi-sigql
7405 if(ish.ge.1)write (ifch,228)matarg,sigi,sigi3
7406 228 format(2x,'simul.: hadron-nucleus (',i3,') cross sections:'/
7407 * 4x,'gin,gin3=',2e10.3)
7408 write(ifmt,*)' matarg,sigi,sigi3 :',matarg,sigi,sigi3
7409 asect21(ie,iclpro,iia)=log(sigi)
7410 asect23(ie,iclpro,iia)=log(sigi3)
7411
7412
7413
7414
7415
7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
7438 enddo
7439 enddo
7440 else
7441 do ie=1,7
7442 do iia=1,7
7443 asect21(ie,iclpro,iia)=0.
7444 asect23(ie,iclpro,iia)=0.
7445 enddo
7446 enddo
7447 endif
7448 endif
7449 enddo
7450
7451 idprojin=1120
7452 iclpro=2
7453 icltar=2
7454 do ie=1,7
7455 engy=1.5*10.**(ie-1)
7456 call paramini(0)
7457 bkmxndif=conbmxndif()
7458 if(ish.ge.1)
7459 & write(ifch,*)' calcul. AB ',ie,engy
7460 write(ifmt,*)' calcul. AB ',ie,engy
7461
7462 do iia=1,7
7463 maproj=2**(iia-1)
7464 laproj=max(1,maproj/2)
7465 do iib=1,7
7466 matarg=2**(iib-1)
7467 latarg=max(1,matarg/2)
7468 sigine=0.
7469 if(matarg.eq.1.and.maproj.eq.1)then !proton-proton interaction
7470
7471 call psfz(2,gz2,0.)
7472 gin=gz2*pi*10.
7473
7474 iomegasave=iomega
7475 iomega=2
7476 call psfz(2,gz2,0.)
7477 iomega=iomegasave
7478 gcut=gz2*pi*10.
7479
7480 difpart=gin-gcut
7481
7482 gqela=(1.-rexdif(iclpro))*(1.-rexdif(icltar))*difpart
7483 gin3=max(1.,gin-gqela)
7484 else
7485 call conini
7486 if(maproj.eq.1)then
7487 rad=radnuc(matarg)
7488 bm=rad+2.
7489 rrr=rad/difnuc(matarg)
7490 rrrm=rrr+log(9.)
7491 anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matarg)**2
7492
7493
7494 gcut=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig_in
7495 gin=gcut
7496
7497 iomegasave=iomega
7498 iomega=2
7499 gcut=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig_cut
7500 iomega=iomegasave
7501
7502 difpart=gin-gcut
7503
7504 gqela=(1.-rexdif(iclpro))
7505 & **(1.+rexres(iclpro)*float(matarg-1)**0.3)
7506
7507 gqela=gqela*(1.-rexdif(icltar))**(1.+float(matarg)**0.3)
7508 gqela=gqela*difpart
7509 gin3=max(1.,gin-gqela)
7510 elseif(matarg.eq.1)then
7511 radp=radnuc(maproj)
7512 bm=radp+2.
7513 rrrp=radp/difnuc(maproj)
7514 rrrmp=rrrp+log(9.)
7515 anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(maproj)**2
7516
7517
7518 gcut=(ptgau(ptfau,bm,1,2)+ptgau1(bm,1,2))*10. !sig_in
7519 gin=gcut !in=cut+diff
7520
7521 iomegasave=iomega
7522 iomega=2
7523 gcut=(ptgau(ptfau,bm,1,2)+ptgau1(bm,1,2))*10. !sig_cut
7524 iomega=iomegasave
7525
7526 difpart=gin-gcut
7527
7528 gqela=(1.-rexdif(iclpro))**(1.+float(maproj)**0.3)
7529
7530 gqela=gqela*(1.-rexdif(icltar))
7531 & **(1.+rexres(icltar)*float(maproj-1)**0.3)
7532 gqela=gqela*difpart
7533 gin3=max(1.,gin-gqela)
7534 else
7535 rad=radnuc(matarg)+1.
7536 radp=radnuc(maproj)+1.
7537 bm=rad+radp+2.
7538 rrr=rad/difnuc(matarg)
7539 rrrm=rrr+log(9.)
7540 rrrp=radp/difnuc(maproj)
7541 rrrmp=rrrp+log(9.)
7542 anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matarg)**2
7543 anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(maproj)**2
7544
7545
7546 gcut=(ptgau(ptfauAA,bm,2,2)+ptgau2(bm,2))*10.
7547
7548 gin=gcut
7549
7550 iomegasave=iomega
7551 iomega=2
7552 gcut=(ptgau(ptfauAA,bm,2,2)+ptgau2(bm,2))*10. !sig_cut
7553 iomega=iomegasave
7554
7555 difpart=gin-gcut
7556
7557 gqelap=(1.-rexdif(iclpro))
7558 & **(1.+rexres(iclpro)*float(matarg-1)**0.3)
7559 gqelap=gqelap**(1.+float(maproj)**0.3)
7560
7561 gqelat=(1.-rexdif(icltar))
7562 & **(1.+rexres(icltar)*float(maproj-1)**0.3)
7563 gqelat=gqelat**(1.+float(maproj)**0.3)
7564 gqela=gqelap*gqelat*difpart
7565 gin3=gin-gqela
7566 endif
7567 endif
7568 if(ish.ge.1)write (ifch,227)maproj,matarg,gin,gin3
7569 227 format(2x,'psaini: nucleus-nucleus (',i3,'-',i3
7570 * ,') cross sections:',/,4x,'gin,gin3=',2e10.3)
7571 write(ifmt,*)' maproj,matarg,gin,gin3 :'
7572 * ,maproj,matarg,gin,gin3
7573 asect31(ie,iia,iib)=log(gin)
7574 asect33(ie,iia,iib)=log(gin3)
7575
7576 enddo
7577 enddo
7578 enddo
7579
7580 if(isetcssave.ge.3)then
7581
7582 do ie=1,7
7583 engy=1.5*10.**(ie-1)
7584 if(engy.le.egymin)engy=egymin
7585 if(engy.ge.egymax)engy=egymax
7586 write(ifmt,*)' AB xs ',ie,engy
7587 if(ish.ge.1)
7588 & write(ifch,*)' AB xs ',ie,engy
7589 do iia=1,7
7590 maproj=2**(iia-1)
7591 laproj=max(1,maproj/2)
7592 do iib=1,7
7593 matarg=2**(iib-1)
7594 latarg=max(1,matarg/2)
7595
7596 ntevt=0
7597 nrevt=0
7598 pnll=-1.
7599 elab=-1.
7600 ecms=-1.
7601 ekin=-1.
7602 call conini
7603 call ainit
7604 nevent=10000
7605 if(maproj+matarg.eq.2)nevent=1
7606 call epocrossc(nevent,sigt,sigi,sigc,sige,sigql,sigd)
7607
7608 sigi3=sigi-sigql
7609 if(ish.ge.1)write (ifch,229)maproj,matarg,sigi,sigi3
7610 229 format(2x,'simul.: nucleus-nucleus (',i3,'-',i3
7611 * ,') cross sections:',/,4x,'gin,gin3=',2e10.3)
7612 write(ifmt,*)' maproj,matarg,sigi,sigi3 :',maproj,matarg
7613 & ,sigi,sigi3
7614 asect41(ie,iia,iib)=log(sigi)
7615 asect43(ie,iia,iib)=log(sigi3)
7616
7617
7618
7619
7620
7621
7622
7623
7624
7625
7626
7627
7628
7629
7630
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
7642 enddo
7643 enddo
7644 enddo
7645 else
7646 do ie=1,7
7647 do iia=1,7
7648 do iib=1,7
7649 asect41(ie,iia,iib)=0.
7650 asect43(ie,iia,iib)=0.
7651 enddo
7652 enddo
7653 enddo
7654 endif
7655
7656 ifrade=ifradesave
7657 iremn=iremnsave
7658 idproj=idprojsave
7659 idprojin=idprojinsave
7660 idtarg=idtargsave
7661 idtargin=idtarginsave
7662 laproj=laprojsave
7663 latarg=latargsave
7664 maproj=maprojsave
7665 matarg=matargsave
7666 icltar=icltarsave
7667 iclpro=iclprosave
7668 engy=engysave
7669 pnll=pnllsave
7670 elab=elabsave
7671 ecms=ecmssave
7672 iclegy=iclegysave
7673 nrevt=nrevtsave
7674 nevent=neventsave
7675 ntevt=ntevtsave
7676 isetcs=isetcssave
7677 noebin=noebinsave
7678 isigma=isigmasave
7679 bminim=bminimsave
7680 bmaxim=bmaximsave
7681 bimevt=bimevtsave
7682 bkmxndif=bkmxndifsave
7683 ionudi=ionudisave
7684
7685 inicnt=1
7686
7687 write(ifmt,'(a)')'write to inics ...'
7688 open(1,file=fncs,status='unknown')
7689 write (1,*)alpqua,alplea,alppom,slopom,gamhad,r2had,chad,
7690 *qcdlam,q2min,q2ini,betpom,glusea,naflav,factk,pt2cut
7691 write(1,*)isetcs,iclpro1,iclpro2,icltar1,icltar2,iclegy1,iclegy2
7692 *,egylow,egymax,iomega,egyscr,epscrw,epscrp
7693 write (1,*)asect11,asect13,asect21,asect23
7694 * ,asect31,asect33,asect41,asect43
7695
7696 close(1)
7697
7698
7699 goto 6
7700
7701 7 continue
7702
7703 endif !----------isetcs.ge.2-----------
7704
7705 endif
7706
7707 call utprix('psaini',ish,ishini,4)
7708
7709 return
7710 end
7711
7712
7713
7714
7715
7716
7717
7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
7728
7729
7730
7731
7732
7733
7734
7735
7736
7737
7738
7739
7740
7741
7742
7743
7744
7745
7746
7747
7748
7749
7750
7751
7752
7753
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765
7766
7767
7768
7769
7770
7771
7772
7773
7774
7775
7776
7777
7778
7779
7780
7781
7782
7783
7784
7785
7786
7787
7788
7789
7790
7791
7792
7793
7794
7795
7796
7797
7798
7799
7800
7801
