EPOS/epos167/epos-sem-165.f

   1 c------------------------------------------------------------------------
   2       function ffsigiut(xx1,xx2,jpp,je1,je2)
   3 c------------------------------------------------------------------------
   4 c
   5 c   \int(dt) \int(du)  ffsig *s/sh**3 *2*pi*alpha**2 *delta(uh+th+sh)
   6 c
   7 c-----------------------------------------------------------------------
   8       common /ar3/   x1(7),a1(7)
   9       include 'epos.incsem'
  10       include 'epos.inc'
  11       double precision tmin,tmax,t,sh2,sqrtq2s
  12
  13       ig=3
  14       s=engy**2
  15       sh=s*xx1*xx2
  16       ffsigiut=0.
  17       if(sh.le.4.*q2min)return
  18       sh2=dble(sh/2.)
  19 c      tmin=sh/2-sqrt(sh*sh/4-q2min*sh)
  20       sqrtq2s=sqrt(dble(q2min*sh))
  21       tmin=sh2-sqrt((sh2-sqrtq2s)*(sh2+sqrtq2s))
  22       tmax=sh2
  23       do i=1,ig
  24       do m=1,2
  25         t=2d0*tmin/(1d0+tmin/tmax-dble(tgss(ig,i)*(2*m-3))
  26      &       *(1d0-tmin/tmax))
  27         qq=sngl(t*(1d0-t/dble(sh)))
  28         ft=ffsigj(sngl(t),qq,xx1,xx2,jpp,je1,je2)/sh**3
  29      *         * (2*pi*pssalf(qq/qcdlam))**2
  30         ffsigiut=ffsigiut+wgss(ig,i)*ft*sngl(t)**2
  31       enddo
  32       enddo
  33       ffsigiut=ffsigiut
  34      *    *0.5*sngl(1d0/tmin-1d0/tmax)
  35      *    *2*pi*s
  36      *   /2      !CS for parton pair
  37       return
  38       end
  39
  40 c-----------------------------------------------------------------------
  41       function ffsigj(t,qt,x1,x2,jpp,je1,je2)
  42 c-----------------------------------------------------------------------
  43 c
  44 c      \sum  x1*f_i(x1,qt) * x2*f_k(x2,qt) * B_ik
  45 c
  46 c        B_ik = psbori = contribution to Born xsection:
  47 c                         dsigmaBorn/d2pt/dy
  48 c                          = s/pi * delta(s+t+u) * 2*pi*alpha**2 /s**2 * B_ik
  49 c
  50 c  qt = virtuality scale
  51 c  x1, x2 = light cone momentum fractions
  52 c
  53 c  x*f_j(x,qt) = function fparton(x,qt,j)
  54 c
  55 c-----------------------------------------------------------------------
  56 c jpp: type of Pomeron
  57 c          1 ... sea-sea
  58 c          2 ... val-sea
  59 c          3 ... sea-val
  60 c          4 ... val-val
  61 c          5 ... all
  62 c je = emission type
  63 c          0 ... no emissions
  64 c          1 ... emissions
  65 c          2 ... all
  66 c-----------------------------------------------------------------------
  67       include 'epos.incsem'
  68       include 'epos.inc'
  69
  70       s=engy**2*x1*x2
  71
  72       if(jpp.ne.5)then
  73       ji1=mod(jpp+1,2)+1
  74       ji2=(jpp+1)/2
  75       sea1=pifpartone(x1,qt,-1,je1,ji1)
  76       g1=  pifpartone(x1,qt, 0,je1,ji1)
  77       uv1= pifpartone(x1,qt, 1,je1,ji1)
  78       dv1= pifpartone(x1,qt, 2,je1,ji1)
  79       sea2=pifpartone(x2,qt,-1,je2,ji2)
  80       g2=  pifpartone(x2,qt, 0,je2,ji2)
  81       uv2= pifpartone(x2,qt, 1,je2,ji2)
  82       dv2= pifpartone(x2,qt, 2,je2,ji2)
  83       else
  84       sea1=pifpartone(x1,qt,-1,je1,1)+pifpartone(x1,qt,-1,je1,2)
  85       g1=  pifpartone(x1,qt, 0,je1,1)+pifpartone(x1,qt, 0,je1,2)
  86       uv1= pifpartone(x1,qt, 1,je1,1)+pifpartone(x1,qt, 1,je1,2)
  87       dv1= pifpartone(x1,qt, 2,je1,1)+pifpartone(x1,qt, 2,je1,2)
  88       sea2=pifpartone(x2,qt,-1,je2,1)+pifpartone(x2,qt,-1,je2,2)
  89       g2=  pifpartone(x2,qt, 0,je2,1)+pifpartone(x2,qt, 0,je2,2)
  90       uv2= pifpartone(x2,qt, 1,je2,1)+pifpartone(x2,qt, 1,je2,2)
  91       dv2= pifpartone(x2,qt, 2,je2,1)+pifpartone(x2,qt, 2,je2,2)
  92       endif
  93
  94       ffsigj= ffborn(s,t,  g1*g2                                  !gg
  95
  96      *  ,(uv1+dv1+2.*naflav*sea1)*g2+g1*(uv2+dv2+2.*naflav*sea2)    !gq
  97
  98      *  ,(uv1+sea1)*(uv2+sea2)                                      !qq
  99      *      +(dv1+sea1)*(dv2+sea2)+sea1*sea2*(naflav-1)*2.
 100
 101      *  ,(uv1+sea1)*sea2+(uv2+sea2)*sea1                            !qa
 102      *    +(dv1+sea1)*sea2+(dv2+sea2)*sea1+sea1*sea2*(naflav-2)*2.
 103
 104      *  ,dv1*uv2+dv2*uv1+(uv2+dv2)*sea1*(naflav-1)*2.                    !qqp
 105      *    +(uv1+dv1)*sea2*(naflav-1)*2.
 106      *    +sea1*sea2*naflav*(naflav-1)*4.
 107
 108      *)
 109       end
 110
 111 c-----------------------------------------------------------------------
 112       function ffsig(t,qt,x1,x2)    !former psjy
 113 c-----------------------------------------------------------------------
 114       include 'epos.incsem'
 115       include 'epos.inc'
 116
 117       s=engy**2*x1*x2
 118
 119       g1=  pifpartone(x1,qt, 0,2,1)+pifpartone(x1,qt, 0,2,2)
 120       uv1= pifpartone(x1,qt, 1,2,1)+pifpartone(x1,qt, 1,2,2)
 121       dv1= pifpartone(x1,qt, 2,2,1)+pifpartone(x1,qt, 2,2,2)
 122       sea1=pifpartone(x1,qt,-1,2,1)+pifpartone(x1,qt,-1,2,2)
 123       g2=  pifpartone(x2,qt, 0,2,1)+pifpartone(x2,qt, 0,2,2)
 124       uv2= pifpartone(x2,qt, 1,2,1)+pifpartone(x2,qt, 1,2,2)
 125       dv2= pifpartone(x2,qt, 2,2,1)+pifpartone(x2,qt, 2,2,2)
 126       sea2=pifpartone(x2,qt,-1,2,1)+pifpartone(x2,qt,-1,2,2)
 127
 128       ffsig= ffborn(s,t,  g1*g2                                  !gg
 129
 130      *  ,(uv1+dv1+2.*naflav*sea1)*g2+g1*(uv2+dv2+2.*naflav*sea2)   !gq
 131
 132      *  ,(uv1+sea1)*(uv2+sea2)                                     !qq
 133      *      +(dv1+sea1)*(dv2+sea2)+sea1*sea2*(naflav-1)*2.
 134
 135      *  ,(uv1+sea1)*sea2+(uv2+sea2)*sea1                           !qa
 136      *    +(dv1+sea1)*sea2+(dv2+sea2)*sea1+sea1*sea2*(naflav-2)*2.
 137
 138      *  ,dv1*uv2+dv2*uv1+(uv2+dv2)*sea1*(naflav-1)*2.             !qqp
 139      *    +(uv1+dv1)*sea2*(naflav-1)*2.
 140      *    +sea1*sea2*naflav*(naflav-1)*4.
 141
 142      *)
 143       end
 144
 145 c------------------------------------------------------------------------
 146       function ffborn(s,t,gg,gq,qq,qa,qqp)
 147 c------------------------------------------------------------------------
 148
 149       ffborn=
 150      *( psbori(s,t,0,0,1)+psbori(s,s-t,0,0,1)
 151      * +psbori(s,t,0,0,2)+psbori(s,s-t,0,0,2)) /2.   *gg             !gg
 152
 153      *+(psbori(s,t,0,1,1)+psbori(s,s-t,0,1,1))       *gq             !gq
 154
 155      *+(psbori(s,t,1,1,1)+psbori(s,s-t,1,1,1))/2.    *qq             !qq
 156
 157      *+(psbori(s,t,1,-1,1)+psbori(s,s-t,1,-1,1)+psbori(s,t,1,-1,2)+
 158      * psbori(s,s-t,1,-1,2)+psbori(s,t,1,-1,3)+psbori(s,s-t,1,-1,3)) !qa
 159      *                                               *qa
 160
 161      *+(psbori(s,t,1,2,1)+psbori(s,s-t,1,2,1))       *qqp            !qq'
 162
 163       end
 164
 165 c-----------------------------------------------------------------------
 166       function pifpartone(xx,qq,j,je,ji)  ! pol interpolation of partone
 167 c-----------------------------------------------------------------------
 168       include 'epos.incsem'
 169       include 'epos.inc'
 170       common/tabfptn/kxxmax,kqqmax,fptn(20,20,-1:2,0:2,2)
 171       real wi(3),wj(3)
 172       common /cpifpartone/npifpartone
 173       data npifpartone /0/
 174       npifpartone=npifpartone+1
 175       if(npifpartone.eq.1)call MakeFpartonTable
 176
 177       qqmax=engy**2/4.
 178       xxmin=0.01/engy
 179       xxmax=1
 180
 181       xxk=1.+log(xx/xxmin)/log(xxmax/xxmin)*(kxxmax-1)
 182       qqk=1.+log(qq/q2min)/log(qqmax/q2min)*(kqqmax-1)
 183       kxx=int(xxk)
 184       kqq=int(qqk)
 185       if(kxx.lt.1)kxx=1
 186       if(kqq.lt.1)kqq=1
 187       if(kxx.gt.(kxxmax-2))kxx=kxxmax-2
 188       if(kqq.gt.(kqqmax-2))kqq=kqqmax-2
 189
 190       wi(2)=xxk-kxx
 191       wi(3)=wi(2)*(wi(2)-1.)*.5
 192       wi(1)=1.-wi(2)+wi(3)
 193       wi(2)=wi(2)-2.*wi(3)
 194
 195       wj(2)=qqk-kqq
 196       wj(3)=wj(2)*(wj(2)-1.)*.5
 197       wj(1)=1.-wj(2)+wj(3)
 198       wj(2)=wj(2)-2.*wj(3)
 199       pifpartone=0
 200       do kx=1,3
 201       do kq=1,3
 202         pifpartone=pifpartone+fptn(kxx+kx-1,kqq+kq-1,j,je,ji)
 203      *              *wi(kx)*wj(kq)
 204       enddo
 205       enddo
 206       end
 207
 208 c-----------------------------------------------------------------------
 209       subroutine MakeFpartonTable
 210 c-----------------------------------------------------------------------
 211       include 'epos.incsem'
 212       include 'epos.inc'
 213       common/tabfptn/kxxmax,kqqmax,fptn(20,20,-1:2,0:2,2)
 214       write (*,'(a,$)')'(Fparton table'
 215       kxxmax=10
 216       kqqmax=10
 217       qqmax=engy**2/4.
 218       xxmin=0.01/engy
 219       xxmax=1
 220       do ji=1,2
 221        do je=0,2
 222         write(*,'(a,$)')'.'
 223         do j=-1,2
 224          do kxx=1,kxxmax
 225           xx=xxmin*(xxmax/xxmin)**((kxx-1.)/(kxxmax-1.))
 226           do kqq=1,kqqmax
 227            qq=q2min*(qqmax/q2min)**((kqq-1.)/(kqqmax-1.))
 228            fptn(kxx,kqq,j,je,ji)= fpartone(xx,qq,j,je,ji)
 229           enddo
 230          enddo
 231         enddo
 232        enddo
 233       enddo
 234       write (*,'(a,$)')'done)'
 235       end
 236
 237 c------------------------------------------------------------------------
 238       function fpartone(xx,qq,j,je,ji)                 !former pspdf0 (sha)
 239 c-----------------------------------------------------------------------
 240 c
 241 c  parton distribution function for proton  ( actually x*f(x) !!!!!!! )
 242 c
 243 c xx = light cone momentum fraction
 244 c qq = virtuality scale
 245 c j = parton type
 246 c         -1 ... sea  (distribution function per flavor)
 247 c          0 ... g
 248 c          1 ... u
 249 c          2 ... d
 250 c je = emission type
 251 c          0 ... no emissions
 252 c          1 ... emissions
 253 c          2 ... all
 254 c ji = initial parton type
 255 c          1 ... sea (q et g)
 256 c          2 ... val
 257 c-----------------------------------------------------------------------
 258       double precision z,xmin,xm,zx,psuds
 259       common/ar3/    x1(7),a1(7)
 260       include 'epos.inc'
 261       include 'epos.incsem'
 262
 263       fpartone=0
 264       if(je.eq.1)goto888
 265
 266 c ...... f_0 * sudakov.........
 267
 268       if(j.eq.0.and.ji.eq.1)then
 269         fpartone=fzeroGlu(xx,2,1)         !hadron class 2, projectile side
 270       elseif((j.eq.1.or.j.eq.2).and.ji.eq.2)then
 271         fpartone=psdfh4(xx,q2min,0.,2,j)
 272       elseif(j.eq.-1.and.ji.eq.1)then
 273         fpartone=fzeroSea(xx,2,1)
 274       endif
 275       fpartone=fpartone*sngl(psuds(qq,j)/psuds(q2min,j))
 276       if(je.eq.0)goto999
 277
 278 c......... integral f_0 E_qcd............
 279
 280  888  continue
 281       xmin=dble(xx)/(1.d0-dble(q2ini/qq))
 282       if(xmin.lt.1.d0)then
 283         dpd1=0.
 284         dpd2=0.
 285         xm=max(xmin,0.3d0)
 286
 287  !numerical integration xm -> 1
 288
 289         do i=1,7
 290         do m=1,2
 291           zx=1.d0-(1.d0-xm)*(.5d0+(dble(m)-1.5d0)*dble(x1(i)))**.25d0
 292           z=xx/zx
 293
 294           gl=fzeroGlu(sngl(zx),2,1)
 295           uv=psdfh4(sngl(zx),q2min,0.,2,1)
 296           dv=psdfh4(sngl(zx),q2min,0.,2,2)
 297           sea=fzeroSea(sngl(zx),2,1)
 298
 299           fz=0
 300           if(j.eq.0)then
 301             if(ji.eq.1)
 302      *        fz=gl *psevi(q2min,qq,z,1,1)
 303      *          +sea*psevi(q2min,qq,z,2,1)  !ccccc
 304             if(ji.eq.2)
 305      *           fz=(uv+dv)*psevi(q2min,qq,z,2,1)
 306           elseif(j.eq.1.and.ji.eq.2)then
 307             fz=psevi(q2min,qq,z,3,2)*uv
 308           elseif(j.eq.2.and.ji.eq.2)then
 309             fz=psevi(q2min,qq,z,3,2)*dv
 310           elseif(j.eq.-1)then
 311             akns=psevi(q2min,qq,z,3,2)            !nonsinglet contribution
 312             aks=(psevi(q2min,qq,z,2,2)-akns)      !singlet contribution
 313             if(ji.eq.1)
 314      *        fz=psevi(q2min,qq,z,1,2)*gl
 315      *          +sea*aks+sea*akns !ccccc
 316             if(ji.eq.2)
 317      *        fz=(uv+dv)*aks
 318           endif
 319           dpd1=dpd1+a1(i)*fz/sngl(zx)**2/sngl(1.d0-zx)**3
 320         enddo
 321         enddo
 322         dpd1=dpd1*sngl(1.d0-xm)**4/8.*xx
 323
 324  !numerical integration  xmin -> xm
 325
 326         if(xm.gt.xmin)then
 327           do i=1,7
 328           do m=1,2
 329             zx=xx+(xm-xx)
 330      &         *((xmin-xx)/(xm-xx))**(.5d0-(dble(m)-1.5d0)*dble(x1(i)))
 331             z=xx/zx
 332
 333             gl=fzeroGlu(sngl(zx),2,1)
 334             uv=psdfh4(sngl(zx),q2min,0.,2,1)
 335             dv=psdfh4(sngl(zx),q2min,0.,2,2)
 336             sea=fzeroSea(sngl(zx),2,1)
 337
 338             fz=0
 339             if(j.eq.0)then
 340               if(ji.eq.1)
 341      *        fz=gl *psevi(q2min,qq,z,1,1)
 342      *          +sea*psevi(q2min,qq,z,2,1)     !ccccc
 343               if(ji.eq.2)
 344      *                fz=(uv+dv)*psevi(q2min,qq,z,2,1)
 345             elseif(j.eq.1.and.ji.eq.2)then
 346               fz=psevi(q2min,qq,z,3,2)*uv
 347             elseif(j.eq.2.and.ji.eq.2)then
 348               fz=psevi(q2min,qq,z,3,2)*dv
 349             elseif(j.eq.-1)then
 350               akns=psevi(q2min,qq,z,3,2)            !nonsinglet contribution
 351               aks=(psevi(q2min,qq,z,2,2)-akns)      !singlet contribution
 352               if(ji.eq.1)
 353      *          fz=psevi(q2min,qq,z,1,2)*gl
 354      *              +sea*aks+sea*akns     !ccccc
 355               if(ji.eq.2)
 356      *          fz=(uv+dv)*aks
 357             endif
 358             dpd2=dpd2+a1(i)*fz*sngl((1.d0-xx/zx)/zx)
 359           enddo
 360           enddo
 361           dpd2=dpd2*sngl(log((xm-xx)/(xmin-xx))*.5d0*xx)
 362         endif
 363         fpartone=fpartone+dpd2+dpd1
 364       endif
 365
 366   999 continue
 367       if(j.lt.0)fpartone=fpartone/naflav/2.
 368       return
 369       end
 370
 371 c------------------------------------------------------------------------
 372       function fparton(xx,qq,j)                 !former pspdf0 (sha)
 373 c-----------------------------------------------------------------------
 374 c
 375 c  parton distribution function for proton  ( actually x*f(x) !!!!!!! )
 376 c
 377 c xx = light cone momentum fraction
 378 c qq = virtuality scale
 379 c j = parton type
 380 c         -1 ... sea  (dsistribution fuction per flavor)
 381 c          0 ... g
 382 c          1 ... u
 383 c          2 ... d
 384 c
 385 c-----------------------------------------------------------------------
 386 c (see pages 105 - 107 of our report)
 387 c
 388 c  fparton(xx) = xx * f(xx)   !!!!!
 389 c
 390 c     f_j(xx,qq) = \sum_k \int(xx<x<1) dx/x f0_k(x) Eqcd_k_j(xx/x,qq)
 391 c
 392 c      f0_k = fzeroGlu or fzeroSea
 393 c
 394 c      Eqcd=E~qcd+delta*sudakov,  E~qcd: at least one emission
 395 c
 396 c-----------------------------------------------------------------------
 397       double precision z,xmin,xm,zx,psuds
 398       common/ar3/    x1(7),a1(7)
 399       include 'epos.inc'
 400       include 'epos.incsem'
 401
 402 c ...... f_0 * sudakov.........
 403
 404       if(j.eq.0)then
 405         fparton=fzeroGlu(xx,2,1)
 406       elseif(j.eq.1.or.j.eq.2)then
 407         fparton=psdfh4(xx,q2min,0.,2,j)
 408       else
 409         fparton=fzeroSea(xx,2,1)
 410       endif
 411       fparton=fparton*sngl(psuds(qq,j)/psuds(q2min,j))
 412
 413 c......... integral f_0 E_qcd............
 414
 415       xmin=xx/(1.d0-dble(q2ini/qq))
 416       if(xmin.lt.1.d0)then
 417         dpd1=0.
 418         dpd2=0.
 419         xm=max(xmin,.3d0)
 420
 421  !numerical integration xm -> 1
 422
 423         do i=1,7
 424         do m=1,2
 425           zx=1.d0-(1.d0-xm)*(.5d0+(dble(m)-1.5d0)*dble(x1(i)))**.25d0
 426           z=xx/zx
 427
 428           gl=fzeroGlu(sngl(zx),2,1)
 429           uv=psdfh4(sngl(zx),q2min,0.,2,1)
 430           dv=psdfh4(sngl(zx),q2min,0.,2,2)
 431           sea=fzeroSea(sngl(zx),2,1)
 432
 433           if(j.eq.0)then
 434             fz=psevi(q2min,qq,z,1,1)*gl
 435      *            +(uv+dv+sea)*psevi(q2min,qq,z,2,1)
 436           elseif(j.eq.1)then
 437             fz=psevi(q2min,qq,z,3,2)*uv
 438           elseif(j.eq.2)then
 439             fz=psevi(q2min,qq,z,3,2)*dv
 440           else
 441             akns=psevi(q2min,qq,z,3,2)            !nonsinglet contribution
 442             aks=(psevi(q2min,qq,z,2,2)-akns)      !singlet contribution
 443             fz=(psevi(q2min,qq,z,1,2)*gl+(uv+dv+sea)*aks+sea*akns)
 444           endif
 445           dpd1=dpd1+a1(i)*fz/sngl(zx)**2/sngl(1.d0-zx)**3
 446         enddo
 447         enddo
 448         dpd1=dpd1*sngl((1.d0-xm)**4/8.*xx)
 449
 450  !numerical integration  xmin -> xm
 451
 452         if(xm.gt.xmin)then
 453           do i=1,7
 454           do m=1,2
 455             zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))
 456      *             **(.5d0-(dble(m)-1.5)*dble(x1(i)))
 457             z=xx/zx
 458
 459             gl=fzeroGlu(sngl(zx),2,1)
 460             uv=psdfh4(sngl(zx),q2min,0.,2,1)
 461             dv=psdfh4(sngl(zx),q2min,0.,2,2)
 462             sea=fzeroSea(sngl(zx),2,1)
 463
 464             if(j.eq.0)then
 465               fz=psevi(q2min,qq,z,1,1)*gl+(uv+dv+sea)*
 466      *        psevi(q2min,qq,z,2,1)
 467             elseif(j.eq.1)then
 468               fz=psevi(q2min,qq,z,3,2)*uv
 469             elseif(j.eq.2)then
 470               fz=psevi(q2min,qq,z,3,2)*dv
 471             else
 472               akns=psevi(q2min,qq,z,3,2)            !nonsinglet contribution
 473               aks=(psevi(q2min,qq,z,2,2)-akns)      !singlet contribution
 474               fz=(psevi(q2min,qq,z,1,2)*gl+(uv+dv+sea)*aks+sea*akns)
 475             endif
 476             dpd2=dpd2+a1(i)*fz*sngl((1.d0-xx/zx)/zx)
 477           enddo
 478           enddo
 479           dpd2=dpd2*sngl(log((xm-xx)/(xmin-xx))*.5d0*xx)
 480         endif
 481         fparton=fparton+dpd2+dpd1
 482       endif
 483       if(j.lt.0)fparton=fparton/naflav/2.
 484       return
 485       end
 486
 487 c------------------------------------------------------------------------
 488       function fzeroGlu(z,k,ipt)
 489 c-----------------------------------------------------------------------
 490 c
 491 c        x*f(x)
 492 c
 493 c   f = F & EsoftGluon         &=convolution
 494 c
 495 c   F(x) = alpff(k)*x**betff(ipt)*(1-x)**alplea(k)
 496 c
 497 c   EsoftGluon(x) = x**(-1-dels) * EsoftGluonTil(x)
 498 c
 499 c z - light cone x
 500 c k - hadron class
 501 c ipt - 1=proj 2=targ
 502 c-----------------------------------------------------------------------
 503       double precision xpmin,xp
 504       include 'epos.inc'
 505       common /ar3/   x1(7),a1(7)
 506       include 'epos.incsem'
 507
 508       fzeroGlu=0.
 509       xpmin=z
 510       xpmin=xpmin**(1+betff(ipt)+dels)
 511       do i=1,7
 512       do m=1,2
 513         xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
 514      *            (1+betff(ipt)+dels))
 515         zz=z/xp
 516         fzeroGlu=fzeroGlu+a1(i)*(1.-xp)**alplea(k)*EsoftGluonTil(zz)
 517       enddo
 518       enddo
 519       fzeroGlu=fzeroGlu*.5*(1.-xpmin)/(1+betff(ipt)+dels)
 520
 521       fzeroGlu=fzeroGlu *alpff(k) *z**(-dels)
 522
 523       end
 524
 525 c------------------------------------------------------------------------
 526       function fzeroSea(z,k,ipt)
 527 c-----------------------------------------------------------------------
 528 c
 529 c        x*f(x)
 530 c
 531 c   f = F & EsoftQuark         &=convolution
 532 c
 533 c   F(x) = alpff(k)*x**betff(ipt)*(1-x)**alplea(k)
 534 c
 535 c   EsoftQuark(x) = x**(-1-dels) * EsoftQuarkTil(x)
 536 c
 537 c z - light cone x of the quark,
 538 c k - hadron class
 539 c-----------------------------------------------------------------------
 540       double precision xpmin,xp
 541       common /ar3/   x1(7),a1(7)
 542       include 'epos.inc'
 543       include 'epos.incsem'
 544
 545       fzeroSea=0.
 546       xpmin=z
 547       xpmin=xpmin**(1+betff(ipt)+dels)
 548       do i=1,7
 549       do m=1,2
 550         xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
 551      *            (1+betff(ipt)+dels))
 552         zz=z/xp
 553         fzeroSea=fzeroSea+a1(i)*(1.-xp)**alplea(k)*EsoftQuarkTil(zz)
 554       enddo
 555       enddo
 556       fzeroSea=fzeroSea*.5*(1.-xpmin)/(1+betff(ipt)+dels)
 557
 558       fzeroSea=fzeroSea *alpff(k) *z**(-dels)
 559
 560       end
 561
 562 c------------------------------------------------------------------------
 563       function EsoftGluonTil(zz)
 564 c-----------------------------------------------------------------------
 565 c   EsoftGluon = zz^(-1-dels) * EsoftGluonTil
 566 c-----------------------------------------------------------------------
 567       include 'epos.inc'
 568       include 'epos.incsem'
 569       EsoftGluonTil=gamsoft*(1-glusea)*(1.-zz)**betpom
 570       end
 571
 572 c------------------------------------------------------------------------
 573       function EsoftQuarkTil(zz)
 574 c-----------------------------------------------------------------------
 575 c   EsoftQuark = zz^(-1-dels) * EsoftQuarkTil
 576 c-----------------------------------------------------------------------
 577       double precision zmin,z
 578       common /ar3/   x1(7),a1(7)
 579       include 'epos.inc'
 580       include 'epos.incsem'
 581
 582       EsoftQuarkTil=0.
 583       zmin=zz
 584       zmin=zmin**(1.+dels)
 585       do i=1,7
 586       do m=1,2
 587         z=(.5d0*(1.+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))
 588      *  **(1.d0/(1.d0+dels))
 589         EsoftQuarkTil=EsoftQuarkTil+a1(i)*max(1.d-5,(1.d0-zz/z))**betpom
 590      *  *(z**2+(1.-z)**2)
 591       enddo
 592       enddo
 593       EsoftQuarkTil=EsoftQuarkTil*1.5*(1.d0-zmin)/(1.+dels)
 594                                                 !1.5=naflav/2 at Q0
 595       EsoftQuarkTil=gamsoft*glusea*EsoftQuarkTil
 596
 597       end
 598
 599 c------------------------------------------------------------------------
 600       function EsoftQZero(zz)    ! former psftilf
 601 c-----------------------------------------------------------------------
 602 c
 603 c   EsoftQuark = EsoftQZero * wsplit * z^(-1-dels) * gamsoft
 604 c
 605 c zz - ratio of the quark and pomeron light cone x (zz=x_G/x_P)
 606 c integration over quark to gluon light cone momentum ratio (z=x/x_G):
 607 c
 608 c   EsoftQZero = int(dz) z^dels * (1-zz/z)^betpom * P_qG(z)
 609 c
 610 c-----------------------------------------------------------------------
 611       double precision zmin,z
 612       common /ar3/   x1(7),a1(7)
 613       include 'epos.incsem'
 614
 615       EsoftQZero=0.
 616       zmin=zz
 617       zmin=zmin**(1.+dels)
 618       do i=1,7
 619       do m=1,2
 620         z=(.5d0*(1.+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))
 621      *  **(1.d0/(1.d0+dels))
 622         EsoftQZero=EsoftQZero+a1(i)*max(1.d-5,(1.d0-zz/z))**betpom
 623      *  *(z**2+(1.-z)**2)
 624       enddo
 625       enddo
 626       EsoftQZero=EsoftQZero*1.5*(1.d0-zmin)/(1.+dels)   !1.5=naflav/2 at Q0
 627       return
 628       end
 629
 630 c------------------------------------------------------------------------
 631       function ffsigi(qq,y0)                   !former psjx1  (sto)
 632 c------------------------------------------------------------------------
 633 c
 634 c    dsigma/dpt_jet =  \int dy \int dx1  ffsig(x1,x2(x1))
 635 c
 636 c x1=xplus, x2=xminus
 637 c x2=x2(x1) due to u+t+s=0
 638 c ( s=x1*x2*spp, t/spp=-x1*xt*exp(-y)/2, u/spp=-x2*xt*exp(y)/2 )
 639 c
 640 c qq = pt**2,  xt=2.*sqrt(qq/s)
 641 c rapidity range: 0 to y0
 642 c
 643 c    ffsig = function ffsig(t,qq,x1,x2)
 644 c
 645 c-----------------------------------------------------------------------
 646       include 'epos.incsem'
 647       include 'epos.inc'
 648       double precision xx1,xx2,xt,ymax,ymin,y,xmin,xmax
 649       ig=3
 650       ig1=3
 651       s=engy**2
 652       ffsigi=0.
 653       if(s.le.4.*qq)return
 654       if(qq.lt.q2min)return
 655       xt=2d0*sqrt(dble(qq)/dble(s))
 656       ymax=min(dble(y0),log(1d0/xt+sqrt((1d0/xt-1d0)*(1d0/xt+1d0))))
 657       ymin=-ymax                          !final result must be divided by 2
 658       do i=1,ig
 659       do m=1,2
 660         y=.5d0*(ymax+ymin+(ymin-ymax)*dble((2*m-3)*tgss(ig,i)))
 661        !for xx1-integration, use variable x=xx1-xt*exp(y)/2.,with xmin<x<xmax
 662         xmin=xt**2/2.d0/(2.d0-xt*exp(-y))                    !condition x2<1
 663         xmax=1.d0-xt*exp(y)/2.d0                             !condition x1<1
 664         fx=0.
 665         do i1=1,ig1
 666         do m1=1,2
 667           xx1=xt*exp(y)/2.d0+xmin*(xmax/xmin)**dble(.5
 668      &                                           +tgss(ig1,i1)*(m1-1.5))
 669           xx2=xt*exp(-y)*xx1/(2.d0*xx1-xt*exp(y))
 670           z=sngl(xx1*xx2)
 671           sh=z*s
 672           aa=1.-4.*qq/sh
 673           aa=max(1e-10,aa)
 674           t=sh/2.*(1.-sqrt(aa))               !formula in parton-parton cms
 675           ft=ffsig(t,qq,sngl(xx1),sngl(xx2))
 676           fx=fx+wgss(ig1,i1)*ft/sh**2
 677         enddo
 678         enddo
 679         fx=fx*0.5*sngl(log(xmax/xmin))       !dx/x=0.5*log(xmax/xmin)dt (gauss)
 680         ffsigi=ffsigi+wgss(ig,i)*fx
 681       enddo
 682       enddo
 683       ffsigi=ffsigi*0.5*sngl(ymax-ymin)    !dy=0.5*(ymax-ymin)dt (gauss)
 684      *  *2*pi*(2*pi*pssalf(qq/qcdlam))**2      !alpha = 2*pi*pssalf
 685      *   *2*sqrt(qq)                 !d2pt=2*pi*pt*dpt
 686      *   /2   ! y interval  2 * Delta_y
 687      *   /2   ! condition t < sqrt(s)/2,
 688               !     since t > sqrt(s)/2 is automatically included,
 689               !      see psbori
 690       return
 691       end
 692
 693 c------------------------------------------------------------------------
 694       function psbori(s,t,j,l,n)
 695 c-----------------------------------------------------------------------
 696 c contribution to the born cross-section:
 697 c
 698 c   dsigmaBorn/d2pt/dy = s/pi * delta(s+t+u) * 2*pi*alpha**2 /s**2 *psbori
 699 c
 700 c s - c.m. energy squared for the born scattering,
 701 c t - invariant variable for the born scattering |(p1-p3)**2|,
 702 c j - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
 703 c l - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
 704 c n - subprocess number
 705 c-----------------------------------------------------------------------
 706       include 'epos.incsem'
 707
 708       psbori=0.
 709       u=s-t
 710       if(u.le.0.d0)return
 711
 712       if(iabs(j).ne.4)then           !light quarks and gluons
 713         if(n.eq.1)then
 714           if(j.eq.0.and.l.eq.0)then                   !gg->gg
 715             psbori=(3.-t*u/s**2+s*u/t**2+s*t/u**2)*4.5
 716           elseif(j*l.eq.0)then                        !gq->gq
 717             psbori=(s**2+u**2)/t**2+(s/u+u/s)/2.25
 718           elseif(j.eq.l)then                          !qq->qq
 719             psbori=((s**2+u**2)/t**2+(s**2+t**2)/u**2)/2.25
 720      *      -s**2/t/u/3.375
 721           elseif(j.eq.-l)then                         !qq~->qq~
 722             psbori=((s**2+u**2)/t**2+(u**2+t**2)/s**2)/2.25
 723      *      +u**2/t/s/3.375
 724           else                                        !qq'->qq'
 725             psbori=(s**2+u**2)/t**2/2.25
 726           endif
 727         elseif(n.eq.2)then
 728           if(j.eq.0.and.l.eq.0)then                   !gg->qq~
 729             psbori=.5*(t/u+u/t)-1.125*(t*t+u*u)/s**2
 730           elseif(j.eq.-l)then                         !qq~->q'q'~
 731             psbori=(t*t+u*u)/s**2/1.125
 732           else
 733             psbori=0.
 734           endif
 735         elseif(n.eq.3)then
 736           if(j.ne.0.and.j.eq.-l)then                  !qq~->gg
 737             psbori=32./27.*(t/u+u/t)-(t*t+u*u)/s**2/.375
 738           else
 739             psbori=0.
 740           endif
 741
 742 c............ n=4 for photon product processes, make e_q**2 =2/9.,
 743 c                 the average value of charge squared for all types of quarks.
 744         elseif(n.eq.4) then
 745           if(j.ne.0.and.j.eq.-l)then                   !qq~->g+gamma
 746             psbori=16*factgam*(u/t+t/u)/81.
 747           elseif (j*l.eq.0.and.j+l.ne.0) then          !q(q~)g->q(q~)+gamma
 748             psbori=2*factgam*(u/s+s/u)/27.
 749           else
 750             psbori=0.
 751           endif
 752         elseif(n.eq.5) then
 753           if(j.ne.0.and.j.eq.-l)then                   !qq~->gamma+gamma
 754             psbori=4*factgam*(t/u+u/t)/81.
 755           else
 756             psbori=0.
 757           endif
 758         endif
 759
 760       elseif(n.eq.1)then                                            !c-quark
 761
 762         if(l.eq.0)then                                !cg->cg
 763           xm=qcmass**2/s/u
 764           psbori=(s**2+u**2)/t**2+(s/u+u/s)/2.25
 765      *    -4.*qcmass**2/t+xm*(xm*t**2-t)/.5625+4.*qcmass**2*xm
 766         else                                          !cq->cq
 767           psbori=(s**2+u**2)/t**2/2.25-qcmass**2/t/1.125
 768         endif
 769
 770       else
 771
 772         psbori=0.
 773
 774       endif
 775       return
 776       end
 777
 778 c-----------------------------------------------------------------------
 779       double precision function om51p(sy,xh,yp,b,iqq)
 780 c-----------------------------------------------------------------------
 781 c om5p - chi~(x,y)
 782 c xh - fraction of the energy squared s for the pomeron;
 783 c yp - rapidity for the pomeron;
 784 c b - impact parameter between the pomeron ends;
 785 c iqq =-1  - 0+1+2+3+4,
 786 c iqq = 0  - soft pomeron,
 787 c iqq = 1  - gg,
 788 c iqq = 2  - qg,
 789 c iqq = 3  - gq,
 790 c iqq = 4  - qq,
 791 c iqq = 5  - soft(int)|b,
 792 c iqq = 6  - gg(int)|b,
 793 c iqq = 7  - soft(proj)|b,
 794 c iqq = 8  - gg(proj)|b,
 795 c iqq = 9  - qg(proj)|b,
 796 c iqq = 10 - total fro-uncut integrated,
 797 c iqq = 11 - total uncut integrated,
 798 c iqq = 12 - soft(int),
 799 c iqq = 13 - gg(int),
 800 c iqq = 14 - <b^2*soft(int)>,
 801 c iqq = 15 - <b^2*gg(int)>,
 802 c iqq = 16 - soft(proj-int),
 803 c iqq = 17 - gg(proj-int),
 804 c iqq = 18 - qg(proj-int),
 805 c iqq = 19 - <b^2*soft(proj)>,
 806 c iqq = 20 - <b^2*gg(proj)>,
 807 c iqq = 21 - <b^2*qg(proj)>
 808 c-----------------------------------------------------------------------
 809       double precision xh,yp!,coefom1,coefom2
 810       common /psar7/  delx,alam3p,gam3p
 811       common /psar37/ coefom1,coefom2
 812       include 'epos.inc'
 813       include 'epos.incsem'
 814
 815       xp=dsqrt(xh)*exp(yp)
 816       if(xh.ne.0.d0)then
 817         xm=xh/xp
 818       else
 819         xm=0.
 820       endif
 821       rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
 822       zb=exp(-b**2/(4.*.0389*rp))
 823       rh=r2had(iclpro)+r2had(icltar)
 824
 825       if(iqq.eq.0)then          !soft
 826 c      rp=r2hads(iclpro)+r2hads(icltar)+slopoms*log(max(1.,sy))
 827       zb=exp(-b**2/(4.*.0389*rp))
 828         om51p=chad(iclpro)*chad(icltar)*gamhads(iclpro)
 829      *  *gamhads(icltar)*sy**dels*(xp*xm)**(-alppar)*zb/rp
 830       elseif(iqq.le.4)then      !gg,qg,gq,qq
 831         om51p=psvin(sy,xp,xm,zb,iqq)
 832       elseif(iqq.eq.5)then      !soft(int)|b
 833 c        rh=alam3p+slopoms*log(max(1.,sy))
 834         om51p=sy**dels*zb**(rp/rh)/rh
 835       elseif(iqq.eq.6)then      !gg(int)|b
 836         om51p=psvin(sy,xp,xm,zb,14)
 837       elseif(iqq.eq.7)then      !soft(proj)b
 838 c        rh=r2hads(iclpro)+.5*alam3p+slopoms*log(max(1.,sy))
 839         om51p=chad(iclpro)*gamhads(iclpro)*sy**dels
 840      *  *xp**(-alppar)*zb**(rp/rh)/rh
 841        elseif(iqq.eq.8)then     !gg(proj)b
 842         om51p=psvin(sy,xp,xm,zb,16)
 843        elseif(iqq.eq.9)then     !qg(proj)b
 844         om51p=psvin(sy,xp,xm,zb,18)
 845        elseif(iqq.eq.10)then    !total fro-uncut integrated
 846          om51p=0.d0
 847          return
 848        elseif(iqq.eq.11)then    !total uncut integrated
 849         om51p=psvin(sy,xp,xm,zb,9)
 850 c        om51p=om51p+dble(coefom1)/2.d0*om51p**2+dble(coefom2)/6.d0*om51p**3 !!!!!!!!!!
 851 c        if(om51p.gt.100.d0)om51p=100.d0
 852       elseif(iqq.eq.12)then      !soft(int)
 853         om51p=sy**dels*4.*.0389
 854       elseif(iqq.eq.13)then      !gg(int)
 855         om51p=psvin(sy,xp,xm,zb,5)
 856       elseif(iqq.eq.14)then      !<b^2*soft(int)>
 857 c        rh=alam3p+slopoms*log(max(1.,sy))
 858         om51p=sy**dels*rh*(4.*.0389)**2
 859       elseif(iqq.eq.15)then      !<b^2*gg(int)>
 860         om51p=psvin(sy,xp,xm,zb,15)
 861       elseif(iqq.eq.16)then      !soft(proj-int)
 862         om51p=chad(iclpro)*gamhads(iclpro)*sy**dels
 863      *  *xp**(-alppar)*4.*.0389
 864        elseif(iqq.eq.17)then     !gg(proj-int)
 865         om51p=psvin(sy,xp,xm,zb,6)
 866        elseif(iqq.eq.18)then     !qg(proj-int)
 867         om51p=psvin(sy,xp,xm,zb,7)
 868       elseif(iqq.eq.19)then      !<b^2*soft(proj)>
 869 c        rh=r2hads(iclpro)+.5*alam3p+slopoms*log(max(1.,sy))
 870         om51p=chad(iclpro)*gamhads(iclpro)*sy**dels
 871      *  *xp**(-alppar)*rh*(4.*.0389)**2
 872        elseif(iqq.eq.20)then     !<b^2*gg(proj)>
 873         om51p=psvin(sy,xp,xm,zb,17)
 874        elseif(iqq.eq.21)then     !<b^2*qg(proj)>
 875         om51p=psvin(sy,xp,xm,zb,19)
 876       endif
 877
 878       return
 879       end
 880
 881 cc-----------------------------------------------------------------------
 882 c      double precision function om2p(xh,yp,xprem0,xmrem0,b,iqq)
 883 cc-----------------------------------------------------------------------
 884 cc om2p - chi~(x,y) for cut pomeron
 885 cc xh - fraction of the energy squared s for the pomeron;
 886 cc yp - rapidity for the pomeron;
 887 cc xprem - x+ for the projectile remnant;
 888 cc xmrem - x- for the target remnant;
 889 cc b - impact parameter between the pomeron ends;
 890 cc iqq = 0  - total,
 891 cc iqq = 1  - 1-cut,
 892 cc iqq = 2  - Y+,
 893 cc iqq = -2 - Y-,
 894 cc iqq = 3  - 1-cut(soft),
 895 cc iqq = 4  - 1+(gg),
 896 cc iqq = 5  - 1+(qg),
 897 cc iqq = 6  - 1+(gq),
 898 cc iqq = 7  - 1+(difr)
 899 cc iqq = -7 - 1-(difr)
 900 cc-----------------------------------------------------------------------
 901 c      double precision xh,yp,xprem0,xmrem0
 902 c      include 'epos.inc'
 903 c      include 'epos.incsem'
 904 c
 905 c      om2p=0.d0
 906 c      sy=xh*engy**2
 907 c      xprem=sngl(xprem0)
 908 c      xmrem=sngl(xmrem0)
 909 c      xp=dsqrt(xh)*dexp(yp)
 910 c      if(xh.ne.0.d0)then
 911 c        xm=xh/xp
 912 c      else
 913 c        xm=0.
 914 c      endif
 915 c      rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
 916 c      zb=exp(-b**2/(4.*.0389*rp))
 917 c
 918 c      if(iqq.eq.0)then
 919 c        om2p=psvy(xp,xprem,xm,xmrem,b,2)
 920 c     *  +psvy(xp,xprem,xm,xmrem,b,-2)
 921 c     *  +psvy(xp,xprem,xm,xmrem,b,3)
 922 c     *  +psvy(xp,xprem,xm,xmrem,b,-3)
 923 c     *  +psvy(xp,xprem,xm,xmrem,b,9)
 924 c     *  +psvy(xp,xprem,xm,xmrem,b,-9)
 925 c     *  +psvx(xp,xprem,xm,xmrem,b,1)
 926 c     *  +psvx(xp,xprem,xm,xmrem,b,2)
 927 c     *  +psvx(xp,xprem,xm,xmrem,b,-2)
 928 c     *  +psvx(xp,xprem,xm,xmrem,b,6)
 929 c     *  +psvx(xp,xprem,xm,xmrem,b,-6)
 930 c        om2p=om2p+(chad(iclpro)*chad(icltar)*gamhad(iclpro)
 931 c     *  *gamhad(icltar)*sy**dels*(xp*xm)**(-alppar)*zb/rp
 932 c     *  +psvin(sy,xp,xm,zb,1)+psvin(sy,xp,xm,zb,2)
 933 c     *  +psvin(sy,xp,xm,zb,3)+psvin(sy,xp,xm,zb,4))
 934 c      elseif(iqq.eq.1)then
 935 c        om2p=psvy(xp,xprem,xm,xmrem,b,2)+psvy(xp,xprem,xm,xmrem,b,-2)
 936 c     *  +psvx(xp,xprem,xm,xmrem,b,1)
 937 c      elseif(iqq.eq.2)then
 938 c        om2p=psvy(xp,xprem,xm,xmrem,b,3)
 939 c     *  +psvx(xp,xprem,xm,xmrem,b,2)
 940 c      elseif(iqq.eq.-2)then
 941 c        om2p=psvy(xp,xprem,xm,xmrem,b,-3)
 942 c     *  +psvx(xp,xprem,xm,xmrem,b,-2)
 943 c      elseif(iqq.eq.3)then
 944 c        om2p=psvy(xp,xprem,xm,xmrem,b,4)+psvy(xp,xprem,xm,xmrem,b,-4)
 945 c     *  +psvx(xp,xprem,xm,xmrem,b,3)
 946 c      elseif(iqq.eq.4)then
 947 c        om2p=psvy(xp,xprem,xm,xmrem,b,5)+psvy(xp,xprem,xm,xmrem,b,7)
 948 c     *  +psvy(xp,xprem,xm,xmrem,b,-5)+psvy(xp,xprem,xm,xmrem,b,-7)
 949 c     *  +psvx(xp,xprem,xm,xmrem,b,4)+psvx(xp,xprem,xm,xmrem,b,-4)
 950 c      elseif(iqq.eq.5)then
 951 c        om2p=psvy(xp,xprem,xm,xmrem,b,6)+psvy(xp,xprem,xm,xmrem,b,-8)
 952 c     *  +psvx(xp,xprem,xm,xmrem,b,5)
 953 c      elseif(iqq.eq.6)then
 954 c        om2p=psvy(xp,xprem,xm,xmrem,b,-6)+psvy(xp,xprem,xm,xmrem,b,8)
 955 c     *  +psvx(xp,xprem,xm,xmrem,b,-5)
 956 c      elseif(iqq.eq.7)then
 957 c        om2p=psvy(xp,xprem,xm,xmrem,b,9)
 958 c     *  +psvx(xp,xprem,xm,xmrem,b,6)
 959 c      elseif(iqq.eq.-7)then
 960 c        om2p=psvy(xp,xprem,xm,xmrem,b,-9)
 961 c     *  +psvx(xp,xprem,xm,xmrem,b,-6)
 962 c      else
 963 c        stop'om2p-wrong iqq!!!'
 964 c      endif
 965 c      return
 966 c      end
 967 c
 968 cc-----------------------------------------------------------------------
 969 c      double precision function om3p(xh,yp,xleg,xprem,xmrem,xlrem
 970 c     *,b1,b2,b12,iqq)
 971 cc-----------------------------------------------------------------------
 972 cc om3p - chi~(x,y) for cut pomeron (nuclear effects)
 973 cc xh     - fraction of the energy squared s for the pomeron;
 974 cc yp     - rapidity for the pomeron;
 975 cc xleg   - x for the pomeron leg;
 976 cc xprem  - x+ for the projectile remnant;
 977 cc xmrem  - x- for the target remnant;
 978 cc xlrem  - x for the leg remnant;
 979 cc b1     - impact parameter between the pomeron ends;
 980 cc b2     - impact parameter for the second pomeron end;
 981 cc iqq = 1  - uncut+,
 982 cc iqq = 2  - cut+,
 983 cc iqq = 3  - scr+,
 984 cc iqq = 4  - diffr+,
 985 cc iqq = 5  - uncut-,
 986 cc iqq = 6  - cut-,
 987 cc iqq = 7  - scr-,
 988 cc iqq = 8  - diff-
 989 cc iqq = 9  - uncut-h+,
 990 cc iqq = 10 - uncut-h-,
 991 cc iqq = 11 - uncut-YY+,
 992 cc iqq = 12 - uncut-YY-,
 993 cc-----------------------------------------------------------------------
 994 c      double precision xh,yp,xleg,xprem,xmrem,xlrem
 995 c
 996 c      om3p=0.d0
 997 c      return !!!!!!!!!!!!!!!
 998 cc      if(iqq.ne.1.and.iqq.ne.5.and.iqq.ne.9.and.iqq.ne.10
 999 cc     *.and.iqq.ne.11.and.iqq.ne.12)return
1000 c
1001 cc$$$      xp=dsqrt(xh)*exp(yp)
1002 cc$$$      if(xh.ne.0.d0)then
1003 cc$$$        xm=xh/xp
1004 cc$$$      else
1005 cc$$$        xm=0.d0
1006 cc$$$      endif
1007 cc$$$
1008 cc$$$      return
1009 c      end
1010 c
1011 cc-----------------------------------------------------------------------
1012 c      double precision function om4p(xx1,xx2,xx3,xx4
1013 c     *,b12,b13,b14,b23,b24,b34,iqq)
1014 cc-----------------------------------------------------------------------
1015 cc om4p - chi for 2-leg contributions
1016 cc xx_i - x+- for pomeron ends;
1017 cc b_ij - impact parameter diff. between pomeron ends;
1018 cc iqq = 1   - uncut-H,
1019 cc iqq = 2   - uncut-YY+,
1020 cc iqq = 3   - uncut-YY-
1021 cc-----------------------------------------------------------------------
1022 c      double precision xx1,xx2xx3,xx4
1023 c      om4p=0.d0
1024 c      return
1025 c      end
1026 c
1027 cc------------------------------------------------------------------------
1028 c      function omi5pp(sy,xpp,xpm,z,iqq)   !former psfsh1
1029 cc-----------------------------------------------------------------------
1030 cc omi5pp - integrated semihard interaction eikonal
1031 cc sy - energy squared for the hard interaction,
1032 cc z - impact parameter factor, z=exp(-b**2/rp),
1033 cc iqq - type of the hard interaction:
1034 cc 0  - soft, 1 - gg, 2 - qg, 3 - gq
1035 cc-----------------------------------------------------------------------
1036 c      common /ar3/    x1(7),a1(7)
1037 c      common /ar9/    x9(3),a9(3)
1038 c      include 'epos.inc'
1039 c      include 'epos.incsem'
1040 c      fsy(zsy)=zsy**dels   !*(1.-1./zsy)**betpom
1041 c
1042 c      omi5pp=0.
1043 c      if(iclpro.eq.4.and.iqq.eq.2.or.icltar.eq.4.and.iqq.eq.3)then
1044 c        spmin=4.*q2min+2.*qcmass**2
1045 c      elseif(iqq.ne.0)then
1046 c        spmin=4.*q2min
1047 c      else
1048 c        spmin=0.
1049 c      endif
1050 c      if(sy.le.spmin)return
1051 c
1052 c      rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
1053 c      alpq=(alppar+1.)/2.
1054 c      if(iqq.eq.3)then
1055 c        iclt=iclpro
1056 c        iclp=icltar
1057 c      else
1058 c        iclp=iclpro
1059 c        iclt=icltar
1060 c      endif
1061 c
1062 c      if(iqq.eq.0)then
1063 c        xpmax=(1.-spmin/sy)**(1.+alplea(iclp))
1064 c        do i=1,3
1065 c        do m=1,2
1066 c          xp=1.-(xpmax*(.5+x9(i)*(m-1.5)))**(1./(1.+alplea(iclp)))
1067 c          xmmax=(1.-spmin/sy/xp)**(1.+alplea(iclt))
1068 c          do i1=1,3
1069 c          do m1=1,2
1070 c            xm=1.-(xmmax*(.5+x9(i1)*(m1-1.5)))**(1./(1.+alplea(iclt)))
1071 c
1072 c            sy1=sy*xp*xm
1073 c            rh=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy1))
1074 c            omi5pp=omi5pp+a9(i)*a9(i1)*fsy(sy1)*xmmax*z**(rp/rh)/rh
1075 c     *      *(xp*xm)**(-alppar)
1076 c          enddo
1077 c          enddo
1078 c        enddo
1079 c        enddo
1080 c        omi5pp=omi5pp*xpmax/(1.+alplea(iclp))/(1.+alplea(iclt))
1081 c     *  *chad(iclpro)*chad(icltar)*gamhad(iclpro)*gamhad(icltar)
1082 c     *  *(xpp*xpm)**(1.-alppar)/4.
1083 c        return
1084 c      else
1085 c
1086 c        xmin=(spmin/sy)**(delh-dels)
1087 c        do i=1,3
1088 c        do m=1,2
1089 c          zh=(.5*(1.+xmin-(2*m-3)*x9(i)*(1.-xmin)))**(1./(delh-dels))
1090 c          if(iclpro.eq.4.and.iqq.eq.2.or.icltar.eq.4.and.iqq.eq.3)then
1091 c            call psjti0(zh*sy,sgq,sgqb,4,0)
1092 c            call psjti0(zh*sy,sqq,sqqb,4,1)
1093 c          else
1094 c            call psjti0(zh*sy,sgg,sggb,0,0)
1095 c            call psjti0(zh*sy,sgq,sgqb,0,1)
1096 c            call psjti0(zh*sy,sqq,sqqb,1,1)
1097 c            call psjti0(zh*sy,sqaq,sqaqb,-1,1)
1098 c            call psjti0(zh*sy,sqqp,sqqpb,1,2)
1099 c            sqq=(sqq+sqaq+2.*(naflav-1)*sqqp)/naflav/2.
1100 c          endif
1101 c
1102 c          if(iqq.eq.1)then
1103 c            stg=0.
1104 c            do i1=1,3
1105 c            do m1=1,2
1106 c              xx=.5+x9(i1)*(m1-1.5)
1107 c              xp=zh**xx
1108 c              xm=zh/xp
1109 c
1110 c              xp1max=(1.-xp)**(1.+alplea(iclp))
1111 c              xm1max=(1.-xm)**(1.+alplea(iclt))
1112 c              do i2=1,3
1113 c              do m2=1,2
1114 c                xp1=1.-(xp1max*(.5+x9(i2)*(m2-1.5)))
1115 c     *          **(1./(1.+alplea(iclp)))
1116 c                do i3=1,3
1117 c                do m3=1,2
1118 c                  xm1=1.-(xm1max*(.5+x9(i3)*(m3-1.5)))
1119 c     *            **(1./(1.+alplea(iclt)))
1120 c                  if(xp1.lt.xp.or.xm1.lt.xm)write (*,*)'xp1,xm1,xp,xm'
1121 c     *            ,xp1,xm1,xp,xm
1122 c
1123 c                  rh=r2had(iclpro)+r2had(icltar)+slopom
1124 c     *            *log(xp1*xm1/xp/xm)
1125 c                  glu1=(1.-xp/xp1)**betpom*(1.-glusea)
1126 c                  sea1=EsoftQZero(xp/xp1)*glusea
1127 c                  glu2=(1.-xm/xm1)**betpom*(1.-glusea)
1128 c                  sea2=EsoftQZero(xm/xm1)*glusea
1129 c                  stg=stg+a9(i1)*a9(i2)*a9(i3)*(glu1*glu2*sgg
1130 c     *            +(glu1*sea2+sea1*glu2)*sgq+sea1*sea2*sqq)
1131 c     *            *xp1max*xm1max*(xp1*xm1)**(dels-alppar)
1132 c     *            *z**(rp/rh)/rh
1133 c                enddo
1134 c                enddo
1135 c              enddo
1136 c              enddo
1137 c            enddo
1138 c            enddo
1139 c            omi5pp=omi5pp-a9(i)*log(zh)*stg/zh**delh
1140 c
1141 c          else
1142 c            stq=0.
1143 c            xpmin=zh**(dels+.5)
1144 c            do i1=1,3
1145 c            do m1=1,2
1146 c              xp=(.5*(1.+xpmin-(2*m1-3)*x9(i1)*(1.-xpmin)))
1147 c     *        **(1./(dels+.5))
1148 c              xm=zh/xp
1149 c              if(xp*xpp.lt..99999)then
1150 c                uv1=psdfh4(xp*xpp,q2min,0.,iclp,1)
1151 c                dv1=psdfh4(xp*xpp,q2min,0.,iclp,2)
1152 c                xm1max=(1.-xm)**(1.+alplea(iclt))
1153 c                do i2=1,3
1154 c                do m2=1,2
1155 c                  xm1=1.-(xm1max*(.5+x9(i2)*(m2-1.5)))
1156 c     *            **(1./(1.+alplea(iclt)))
1157 c
1158 c                  rh=r2had(iclpro)+r2had(icltar)+slopom*log(xm1/xm)
1159 c                  glu2=(1.-xm/xm1)**betpom*(1.-glusea)
1160 c                  sea2=EsoftQZero(xm/xm1)*glusea
1161 c                  stq=stq+a9(i1)*a9(i2)*(glu2*sgq+sea2*sqq)*(uv1+dv1)
1162 c     *            *z**(rp/rh)/rh*xm1max*xm1**(dels-alppar)/sqrt(xp)
1163 c     *            *((1.-xp)/(1.-xp*xpp))**(1.-alpq+alplea(iclp))
1164 c                enddo
1165 c                enddo
1166 c              endif
1167 c            enddo
1168 c            enddo
1169 c            stq=stq*(1.-xpmin)
1170 c            omi5pp=omi5pp+a9(i)*stq/zh**delh
1171 c          endif
1172 c        enddo
1173 c        enddo
1174 c      endif
1175 c
1176 c      omi5pp=omi5pp*(1.-xmin)/(delh-dels)
1177 c      if(iqq.eq.1)then
1178 c        omi5pp=omi5pp*chad(iclp)*chad(iclt)*gamhad(iclp)
1179 c     *  *gamhad(iclt)*rr**2*(xpp*xpm)**(1.-alppar)
1180 c     *  /(1.+alplea(iclp))/(1.+alplea(iclt))*pi/8.*factk
1181 c      else
1182 c        omi5pp=omi5pp*chad(iclp)*chad(iclt)*rr*gamhad(iclt)
1183 c     *  *xpp**(1.-alpq)*xpm**(1.-alppar)/(.5+dels)
1184 c     *  /(1.+alplea(iclt))/16.*factk
1185 c      endif
1186 c      return
1187 c      end
1188 c
1189 c------------------------------------------------------------------------
1190       function om52pi(sy,xpp,xpm,iqq,je1,je2)   !modified om51pp
1191 c-----------------------------------------------------------------------
1192 c      sy  - energy squared for the hard interaction
1193 c
1194 c      iqq = 0  - sea-sea,
1195 c      iqq = 1  - val-sea,
1196 c      iqq = 2  - sea-val,
1197 c      iqq = 3  - val-val,
1198 c
1199 c      je = emission type
1200 c               0 ... no emissions
1201 c               1 ... emissions
1202 c            else ... all
1203 c
1204 c       already b-averaged  (\int d2b /sigine*10)
1205 c-----------------------------------------------------------------------
1206       common /ar3/    x1(7),a1(7)
1207       common /psar7/  delx,alam3p,gam3p
1208       include 'epos.inc'
1209       include 'epos.incsem'
1210       if(iqq.lt.0.or.iqq.gt.3)stop'om52pi: unvalid  iqq'
1211
1212       om52pi=0.
1213
1214       ef1=0
1215       ef2=0
1216       ef3=0
1217       ef4=0
1218       if( je1.ge.1             .and. je2.ge.1)             ef1=1
1219       if( je1.ge.1             .and.(je2.eq.0.or.je2.eq.2))ef2=1
1220       if((je1.eq.0.or.je1.eq.2).and. je2.ge.1)             ef3=1
1221       if((je1.eq.0.or.je1.eq.2).and.(je2.eq.0.or.je2.eq.2))ef4=1
1222
1223       spmin=4.*q2min
1224       if(sy.le.spmin)goto999
1225
1226       if(iqq.eq.1)then
1227         iclv=iclpro
1228 ctp060829        icls=icltar
1229       elseif(iqq.eq.2)then
1230 ctp060829        icls=iclpro
1231         iclv=icltar
1232       endif
1233
1234       delss=dels
1235       if(iqq.eq.3)delss=-0.5
1236       xmin=spmin/sy
1237       xmin=xmin**(delh-delss)
1238       alpq=(alppar+1.)/2.
1239
1240 c numerical integration over zh
1241       do i=1,7
1242       do m=1,2
1243         zh=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./(delh-delss))
1244          sgg=  ef1  *pijet(2,q2min,q2min,zh*sy,0,0)
1245      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,0,0)
1246      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,0,0)
1247          sgq=  ef1  *pijet(2,q2min,q2min,zh*sy,0,1)
1248      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,0,1)
1249      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,0,1)
1250          sqq=  ef1  *pijet(2,q2min,q2min,zh*sy,1,1)
1251      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,1,1)
1252      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,1,1)
1253         sqaq=  ef1  *pijet(2,q2min,q2min,zh*sy,-1,1)
1254      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,-1,1)
1255      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,-1,1)
1256         sqqp=  ef1  *pijet(2,q2min,q2min,zh*sy,1,2)
1257      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,1,2)
1258      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,1,2)
1259         sqqi=sqq
1260         sqq=(sqq+sqaq+2.*(naflav-1)*sqqp)/naflav/2.
1261         if(iqq.eq.0)then
1262           stg=0.
1263           do i1=1,7
1264           do m1=1,2
1265             xx=.5+x1(i1)*(m1-1.5)
1266             xp=zh**xx
1267             xm=zh/xp
1268             glu1=EsoftGluonTil(xp)
1269             sea1=EsoftQuarkTil(xp)
1270             glu2=EsoftGluonTil(xm)
1271             sea2=EsoftQuarkTil(xm)
1272             dstg= glu1*glu2*sgg
1273      *            +(glu1*sea2+sea1*glu2)*sgq   !ccccc
1274      *              +sea1*sea2*sqq   !ccccc
1275             stg=stg+a1(i1)*dstg
1276           enddo
1277           enddo
1278           om52pi=om52pi-a1(i)*log(zh)*stg/zh**delh
1279         elseif(iqq.eq.3)then
1280           stq=0.  !int^1_(sqrt(z)) dx_p / x_p / sqrt(1-x_p) =int^(tmax)_(0) dt
1281           tmax=sqrt(1.-sqrt(zh))        !t=ln((1+sqrt(1-x_p))/(1-sqrt(1-x_p)))
1282           tmax=log((1.+tmax)/(1.-tmax))
1283           if(tmax.gt.1.e-20)then
1284           do i1=1,7
1285           do m1=1,2
1286             t=tmax*(.5+x1(i1)*(m1-1.5))
1287             z01=((1.d0-exp(-1.d0*t))/(1.d0+exp(-1.d0*t)))**2
1288             xp=1.-z01
1289             xm=zh/xp
1290             if(xp*xpp.le..9999.and.xm*xpm.le..9999
1291      *      .or.xm*xpp.le..9999.and.xp*xpm.le..9999)then
1292               stq=stq+a1(i1)
1293      *               *(psharg(xp*xpp,xm*xpm,sqqi,sqqp,sqaq)
1294      *                 +psharg(xm*xpp,xp*xpm,sqqi,sqqp,sqaq))
1295      *            *max(1e-20,1.-xp)**(.5-alpq)
1296      *            *max(1e-20,1.-xm)**(-alpq)
1297      *               *xp**delss*xm**delss
1298      *        *xpp**alppar/gamhad(iclpro)             ! Eval
1299      *        *xpm**alppar/gamhad(icltar)             ! Eval
1300             endif
1301           enddo
1302           enddo
1303           stq=stq*tmax
1304           endif
1305           om52pi=om52pi+a1(i)*stq/zh**delh
1306         elseif(iqq.eq.1.or.iqq.eq.2)then
1307           stq=0.
1308           tmax=acos(sqrt(zh))
1309           do i1=1,7
1310           do m1=1,2
1311             t=tmax*(.5+x1(i1)*(m1-1.5))
1312             xp=cos(t)**2
1313             xm=zh/xp
1314             if(xp*xpp.lt..99999)then
1315               uv1=psdfh4(xp*xpp,q2min,0.,iclv,1)      ! Eval
1316               dv1=psdfh4(xp*xpp,q2min,0.,iclv,2)      ! Eval
1317               glu2=EsoftGluonTil(xm)
1318               sea2=EsoftQuarkTil(xm)
1319               dstq=0
1320               if(xp.ne.1.)
1321      *        dstq=(glu2*sgq+sea2*sqq)*(uv1+dv1)
1322      *        *(1.-xp*xpp)**(-1.+alpq-alplea(iclv)) ! Eval
1323      *        *xp**(delss-.5)*(1.-xp)**(-alpq+.5)    ! Eval *sqrt(1-x)/sqrt(x)
1324      *        *xpp**alppar/gamhad(iclv)             ! Eval
1325               stq=stq+a1(i1)*dstq
1326             endif
1327           enddo
1328           enddo
1329           stq=stq*tmax
1330           om52pi=om52pi+a1(i)*stq/zh**delh
1331         else
1332           stop'om52pi: unvalid  iqq (2).            '
1333         endif
1334       enddo
1335       enddo
1336
1337       om52pi=om52pi*(1.-xmin)/(delh-delss)
1338
1339       if(iqq.eq.0)then
1340         om52pi=om52pi/4
1341       elseif(iqq.eq.3)then
1342         om52pi=om52pi/4
1343      *  * utgam1(2.+alplea(iclpro)-alpq)                           ! Eval
1344      *     /utgam1(1.+alplea(iclpro))/utgam1(1.-alpq)           ! Eval
1345      *  * utgam1(2.+alplea(icltar)-alpq)                           ! Eval
1346      *     /utgam1(1.+alplea(icltar))/utgam1(1.-alpq)           ! Eval
1347      *  /xpp**alpq/xpm**alpq                                       ! Eval
1348       elseif(iqq.le.2)then
1349         om52pi=om52pi/2
1350      *  *utgam1(2.+alplea(iclv)-alpq)/utgam1(1.+alplea(iclv)) ! Eval
1351      *  /utgam1(1.-alpq)                                      ! Eval
1352      *  /xpp**alpq                                            ! Eval
1353       endif
1354
1355  999  continue
1356       om52pi=om52pi*factk * .0390   /sigine*10  /2.
1357        end
1358
1359 c------------------------------------------------------------------------
1360       function psharg(zh1,zh2,sqq,sqqp,sqaq)
1361 c-----------------------------------------------------------------------
1362       include 'epos.incsem'
1363       include 'epos.inc'
1364
1365       alpq=(alppar+1.)/2.
1366       if(zh1.le..9999.and.zh2.le..9999)then
1367         uv1=psdfh4(zh1,q2min,0.,iclpro,1)
1368         dv1=psdfh4(zh1,q2min,0.,iclpro,2)
1369         uv2=psdfh4(zh2,q2min,0.,icltar,1)
1370         dv2=psdfh4(zh2,q2min,0.,icltar,2)
1371         if(iclpro.eq.2.and.icltar.eq.2)then       !proton
1372           fff=sqq*(uv1*uv2+dv1*dv2)+sqqp*(uv1*dv2+dv1*uv2)
1373         elseif(iclpro.eq.1.or.icltar.eq.1)then   !pion
1374           fff=sqq*uv1*uv2+sqaq*dv1*dv2+sqqp*(uv1*dv2+dv1*uv2)
1375         elseif(iclpro.eq.3.or.icltar.eq.3)then   !kaon
1376           fff=sqq*uv1*uv2+sqqp*(uv1*dv2+dv1*uv2+dv1*dv2)
1377         elseif(iclpro.eq.4.or.icltar.eq.4)then   !J/psi
1378           fff=sqq*uv1*(uv2+dv2)
1379         endif
1380         psharg=fff
1381      *               *(1.-zh1)**(-1.+alpq-alplea(iclpro))
1382      *               *(1.-zh2)**(-1.+alpq-alplea(icltar))
1383       else
1384         psharg=0.
1385       endif
1386       return
1387       end
1388
1389 c------------------------------------------------------------------------
1390       function om51pp(sy,xpp,z,iqq)   !former psfsh
1391 c-----------------------------------------------------------------------
1392 c om51pp - semihard interaction eikonal
1393 c sy  - energy squared for the hard interaction,
1394 c z   - impact parameter factor, z=exp(-b**2/rp),
1395 c iqq - type of the hard interaction:
1396 c   0 - gg, 1 - qg, 2 - gq, 3 - gg(int), 4 - gg(proj), 5 - qg(proj),
1397 c   6 - gg(int)|b=0, 7 - <b^2*gg(int)>, 8 - gg(proj)|b=0,
1398 c   9 - <b^2*gg(proj)>, 10 - qg(proj)|b=0, 11 - <b^2*qg(proj)>
1399 c-----------------------------------------------------------------------
1400       common /ar3/    x1(7),a1(7)
1401       common /psar7/  delx,alam3p,gam3p
1402       include 'epos.inc'
1403       include 'epos.incsem'
1404
1405       om51pp=0.
1406       if(iqq.eq.0.or.iqq.eq.3.or.iqq.eq.4
1407      *.or.iqq.eq.6.or.iqq.eq.7.or.iqq.eq.8.or.iqq.eq.9
1408      *.or.iclpro.ne.4.and.(iqq.eq.1.or.iqq.eq.5
1409      *.or.iqq.eq.10.or.iqq.eq.11)
1410      *.or.icltar.ne.4.and.iqq.eq.2)then
1411         spmin=4.*q2min
1412       else
1413         spmin=4.*q2min+2.*qcmass**2
1414       endif
1415       if(sy.le.spmin)goto999
1416
1417       if(iqq.eq.1.or.iqq.eq.5.or.iqq.eq.10.or.iqq.eq.11)then
1418         iclv=iclpro
1419         icls=icltar
1420       elseif(iqq.eq.2)then
1421         icls=iclpro
1422         iclv=icltar
1423       endif
1424
1425       xmin=spmin/sy
1426       xmin=xmin**(delh-dels)
1427       rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
1428       alpq=(alppar+1.)/2.
1429
1430 c numerical integration over zh
1431       do i=1,7
1432       do m=1,2
1433         zh=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./
1434      *  (delh-dels))
1435         if(iqq.eq.0.or.iqq.eq.3.or.iqq.eq.4
1436      *  .or.iqq.eq.6.or.iqq.eq.7.or.iqq.eq.8.or.iqq.eq.9
1437      *  .or.iclpro.ne.4.and.(iqq.eq.1.or.iqq.eq.5
1438      *  .or.iqq.eq.10.or.iqq.eq.11)
1439      *  .or.icltar.ne.4.and.iqq.eq.2)then
1440           call psjti0(zh*sy,sgg,sggb,0,0)  !inclusive (sj) and born (sjb)
1441           call psjti0(zh*sy,sgq,sgqb,0,1)
1442           call psjti0(zh*sy,sqq,sqqb,1,1)
1443           call psjti0(zh*sy,sqaq,sqaqb,-1,1)
1444           call psjti0(zh*sy,sqqp,sqqpb,1,2)
1445           sqq=(sqq+sqaq+2.*(naflav-1)*sqqp)/naflav/2.
1446 c...........test.......
1447 c      tgg=   psjet(q2min,q2min,q2min,zh*sy,0,0,0)
1448 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,0,0,0)
1449 c     *   +  psborn(q2min,q2min,q2min,zh*sy,0,0,0,1)
1450 c      tgq=   psjet(q2min,q2min,q2min,zh*sy,0,1,0)
1451 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,0,1,0)
1452 c     *   +  psborn(q2min,q2min,q2min,zh*sy,0,1,0,1)
1453 c      tqq=   psjet(q2min,q2min,q2min,zh*sy,1,1,0)
1454 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,1,1,0)
1455 c     *   +  psborn(q2min,q2min,q2min,zh*sy,1,1,0,1)
1456 c      tqa=   psjet(q2min,q2min,q2min,zh*sy,-1,1,0)
1457 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,-1,1,0)
1458 c     *   +  psborn(q2min,q2min,q2min,zh*sy,-1,1,0,1)
1459 c      tqqp=  psjet(q2min,q2min,q2min,zh*sy,1,2,0)
1460 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,1,2,0)
1461 c     *   +  psborn(q2min,q2min,q2min,zh*sy,1,2,0,1)
1462 c      write(6,'(f12.2,3x,2f7.3,2(3x,2f7.3))')
1463 c     * zh*sy,tgg,sgg, tgq,sgq, tqqp,sqqp
1464 c.......................
1465         else
1466           call psjti0(zh*sy,sgq,sgqb,4,0)
1467           call psjti0(zh*sy,sqq,sqqb,4,1)
1468         endif
1469
1470         if(iqq.eq.0.or.iqq.eq.3.or.iqq.eq.4
1471      *  .or.iqq.eq.6.or.iqq.eq.7.or.iqq.eq.8.or.iqq.eq.9)then
1472           stg=0.
1473           do i1=1,7
1474           do m1=1,2
1475             xx=.5+x1(i1)*(m1-1.5)
1476             xp=zh**xx
1477             xm=zh/xp
1478             glu1=(1.-xp)**betpom*(1.-glusea)
1479             sea1=EsoftQZero(xp)*glusea
1480             glu2=(1.-xm)**betpom*(1.-glusea)
1481             sea2=EsoftQZero(xm)*glusea
1482             if(iqq.eq.0)then
1483               rh=r2had(iclpro)+r2had(icltar)-slopom*log(zh)
1484             elseif(iqq.eq.3.or.iqq.eq.4)then
1485               rh=1.
1486             elseif(iqq.eq.6.or.iqq.eq.7)then
1487               rh=alam3p-slopom*log(zh)
1488             elseif(iqq.eq.8.or.iqq.eq.9)then
1489               rh=r2had(iclpro)+.5*alam3p-slopom*log(zh)
1490             endif
1491             dstg=(glu1*glu2*sgg+
1492      *      (glu1*sea2+sea1*glu2)*sgq+sea1*sea2*sqq)
1493      *      *z**(rp/rh)/rh
1494             if(iqq.eq.7.or.iqq.eq.9)dstg=dstg*rh**2
1495             stg=stg+a1(i1)*dstg
1496           enddo
1497           enddo
1498           om51pp=om51pp-a1(i)*log(zh)*stg/zh**delh
1499         else
1500           stq=0.
1501           tmax=acos(sqrt(zh))
1502           do i1=1,7
1503           do m1=1,2
1504             t=tmax*(.5+x1(i1)*(m1-1.5))
1505             xp=cos(t)**2
1506             xm=zh/xp
1507             if(xp*xpp.lt..99999)then
1508               uv1=psdfh4(xp*xpp,q2min,0.,iclv,1)
1509               dv1=psdfh4(xp*xpp,q2min,0.,iclv,2)
1510               glu2=(1.-xm)**betpom*(1.-glusea)
1511               sea2=EsoftQZero(xm)*glusea
1512               if(iqq.le.2)then
1513                 rh=r2had(iclpro)+r2had(icltar)-slopom*log(xm)
1514               elseif(iqq.eq.5)then
1515                 rh=1.
1516               elseif(iqq.le.10.or.iqq.le.11)then
1517                 rh=r2had(iclpro)+.5*alam3p-slopom*log(xm)
1518               endif
1519               dstq=0
1520               if(xp.ne.1.)
1521      *        dstq=(glu2*sgq+sea2*sqq)*(uv1+dv1)
1522      *        *z**(rp/rh)/rh
1523      *        *(1.-xp*xpp)**(-1.+alpq-alplea(iclv))
1524      *        *xp**(dels-.5)*(1.-xp)**(-alpq+.5)
1525               if(iqq.eq.11)dstq=dstq*rh**2
1526               stq=stq+a1(i1)*dstq
1527             endif
1528           enddo
1529           enddo
1530           stq=stq*tmax
1531           om51pp=om51pp+a1(i)*stq/zh**delh
1532         endif
1533       enddo
1534       enddo
1535
1536       om51pp=om51pp*(1.-xmin)/(delh-dels)/sy**delh/2.
1537       if(iqq.eq.0)then
1538         om51pp=om51pp*chad(iclpro)*chad(icltar)*gamhad(iclpro)
1539      *  *gamhad(icltar)*rr**2*pi
1540       elseif(iqq.eq.3)then
1541         om51pp=om51pp*rr**2*pi*4.*.0389
1542       elseif(iqq.eq.6)then
1543         om51pp=om51pp*rr**2*pi
1544       elseif(iqq.eq.7)then
1545         om51pp=om51pp*rr**2*pi*(4.*.0389)**2
1546       elseif(iqq.eq.4.or.iqq.eq.8.or.iqq.eq.9)then
1547         om51pp=om51pp*rr**2*pi*chad(iclpro)*gamhad(iclpro)
1548         if(iqq.eq.4)om51pp=om51pp*4.*.0389
1549         if(iqq.eq.9)om51pp=om51pp*(4.*.0389)**2
1550       elseif(iqq.le.2)then
1551         om51pp=om51pp*chad(iclpro)*chad(icltar)*rr*gamhad(icls)
1552      *  *utgam1(2.+alplea(iclv)-alpq)/utgam1(1.+alplea(iclv))
1553      *  /utgam1(1.-alpq)/2./xpp**alpq
1554       elseif(iqq.eq.5.or.iqq.eq.10.or.iqq.eq.11)then
1555         om51pp=om51pp*chad(iclv)*rr
1556      *  *utgam1(2.+alplea(iclv)-alpq)/utgam1(1.+alplea(iclv))
1557      *  /utgam1(1.-alpq)/2./xpp**alpq
1558         if(iqq.eq.5)om51pp=om51pp*4.*.0389
1559         if(iqq.eq.11)om51pp=om51pp*(4.*.0389)**2
1560       endif
1561  999  continue
1562       end
1563
1564 c------------------------------------------------------------------------
1565       subroutine psfz(gz2,b)
1566 c-----------------------------------------------------------------------
1567 c hadron-nucleus cross sections calculation
1568 c b - impact parameter squared
1569 c-----------------------------------------------------------------------
1570       double precision PhiExpo
1571       include 'epos.inc'
1572       common /ar3/ x1(7),a1(7)
1573       external pttcs,pprcs
1574
1575       gz2=0.
1576       e1=exp(-1.)
1577       rs=r2had(iclpro)+r2had(icltar)+max(slopom,slopoms)*log(engy**2)
1578      &     +gwidth*(r2had(iclpro)+r2had(icltar))
1579      &     +bmxdif(iclpro,icltar)/4./0.0389
1580       rpom=4.*.0389*rs
1581
1582
1583       do i1=1,7
1584       do m=1,2
1585         z=.5+x1(i1)*(m-1.5)
1586         zv1=exp(-z)
1587         zv2=(e1*z)
1588         b1=sqrt(-rpom*log(zv1))
1589         b2=sqrt(-rpom*log(zv2))
1590
1591         vv21=sngl(PhiExpo(1.,1.d0,1.d0,engy**2,b1))
1592         vv22=sngl(PhiExpo(1.,1.d0,1.d0,engy**2,b2))
1593
1594         if(maproj.eq.1.and.matarg.eq.1)then
1595           cg1=1.
1596           cg2=1.
1597         elseif(matarg.eq.1)then
1598           cg1=ptrot(pprcs,b,b1)
1599           cg2=ptrot(pprcs,b,b2)
1600         else
1601           cg1=ptrot(pttcs,b,b1)
1602           cg2=ptrot(pttcs,b,b2)
1603         endif
1604
1605         gz2=gz2+a1(i1)*(cg1*(1.-vv21)+cg2*(1.-vv22)/z)
1606       enddo
1607       enddo
1608       gz2=gz2*rpom/2.
1609
1610       return
1611       end
1612
1613
1614 c------------------------------------------------------------------------
1615       function ptgau(func,bm,iqq)
1616 c-----------------------------------------------------------------------
1617 c impact parameter integration for impact parameters <bm -
1618 c for nucleus-nucleus and hadron-nucleus cross-sections calculation
1619 c iqq=1 : projectile, iqq=2 : target
1620 c-----------------------------------------------------------------------
1621       include 'epos.inc'
1622       common /ar3/ x1(7),a1(7)
1623       external func
1624
1625       ptgau=0.
1626       do i=1,7
1627       do m=1,2
1628         b=bm*sqrt(.5+x1(i)*(m-1.5))
1629         ptgau=ptgau+func(b,iqq)*a1(i)
1630       enddo
1631       enddo
1632       ptgau=ptgau*bm**2*pi*.5
1633       return
1634       end
1635
1636 c------------------------------------------------------------------------
1637       function ptgau1(bm,iqq)
1638 c-----------------------------------------------------------------------
1639 c impact parameter integration for impact parameters >bm -
1640 c for hadron-nucleus cross-sections calculation
1641 c iqq=1 : projectile, iqq=2 : target
1642 c-----------------------------------------------------------------------
1643       include 'epos.inc'
1644       common /ar5/    x5(2),a5(2)
1645
1646       ptgau1=0.
1647       if(iqq.eq.1)then
1648         difn=difnuc(maproj)
1649       else
1650         difn=difnuc(matarg)
1651       endif
1652       do i=1,2
1653         b=bm+x5(i)*difn
1654         ptgau1=ptgau1+ptfau(b,iqq)*a5(i)*exp(x5(i))*b*2.*pi*difn
1655       enddo
1656       return
1657       end
1658 c------------------------------------------------------------------------
1659       function ptgau2(bm)
1660 c-----------------------------------------------------------------------
1661 c impact parameter integration for impact parameters >bm -
1662 c for nucleus-nucleus cross-sections calculation
1663 c-----------------------------------------------------------------------
1664       include 'epos.inc'
1665       common /ar5/    x5(2),a5(2)
1666
1667       ptgau2=0.
1668       difn=difnuc(maproj)+difnuc(matarg)
1669       do i=1,2
1670         b=bm+x5(i)*difn
1671         ptgau2=ptgau2+ptfauAA(b)*a5(i)*exp(x5(i))*b*2.*pi*difn
1672       enddo
1673       return
1674       end
1675
1676
1677 c------------------------------------------------------------------------
1678       function ptfau(b,iqq)
1679 c-----------------------------------------------------------------------
1680 c ptfau - integrands for hadron-nucleus cross-sections calculation
1681 c iqq=1 : projectile, iqq=2 : target
1682 c-----------------------------------------------------------------------
1683       include 'epos.inc'
1684       common /psar35/ anorm,anormp
1685
1686       call psfz(gz2,b)
1687
1688       if(iqq.eq.1)then
1689         ptfau=1.-max(0.,(1.-anormp*gz2))**maproj
1690       else
1691         ptfau=1.-max(0.,(1.-anorm*gz2))**matarg
1692       endif
1693
1694       return
1695       end
1696
1697 c------------------------------------------------------------------------
1698       function ptfauAA(b)
1699 c-----------------------------------------------------------------------
1700 c ptfau - integrands for hadron-nucleus cross-sections calculation
1701 c-----------------------------------------------------------------------
1702       include 'epos.inc'
1703       common /ar3/    x1(7),a1(7)
1704       common /psar35/ anorm,anormp
1705       external pprcs
1706
1707       ptfauAA=0.
1708       e1=exp(-1.)
1709       rs=r2had(iclpro)+r2had(icltar)+max(slopom,slopoms)*log(engy**2)
1710      &     +gwidth*(r2had(iclpro)+r2had(icltar))
1711      &     +bmxdif(iclpro,icltar)/4./0.0389
1712       rpom=4.*.0389*rs
1713       do i1=1,7
1714       do m=1,2
1715         z=.5+x1(i1)*(m-1.5)
1716         zv1=exp(-z)
1717         zv2=(e1*z)
1718         b1=sqrt(-rpom*log(zv1))
1719         b2=sqrt(-rpom*log(zv2))
1720         call psfz(gz21,b1)
1721         call psfz(gz22,b2)
1722         ptfau1=max(0.,(1.-anorm*gz21))**matarg
1723         ptfau2=max(0.,(1.-anorm*gz22))**matarg
1724         cg1=ptrot(pprcs,b,b1)
1725         cg2=ptrot(pprcs,b,b2)
1726         ptfauAA=ptfauAA+a1(i1)*(cg1*(1.-ptfau1)+cg2*(1.-ptfau2)/z)
1727       enddo
1728       enddo
1729       ptfauAA=ptfauAA*rpom/2.
1730       ptfauAA=1.-max(0.,(1.-anormp*ptfauAA))**maproj
1731
1732       return
1733       end
1734
1735 c------------------------------------------------------------------------
1736       function ptrot(func,s,b)
1737 c-----------------------------------------------------------------------
1738 c convolution of nuclear profile functions (axial angle integration)
1739 c-----------------------------------------------------------------------
1740       common /ar8/ x2(4),a2
1741       external func
1742
1743       ptrot=0.
1744       do i=1,4
1745         sb1=b**2+s**2-2.*b*s*(2.*x2(i)-1.)
1746         sb2=b**2+s**2-2.*b*s*(1.-2.*x2(i))
1747        ptrot=ptrot+(func(sb1)+func(sb2))
1748       enddo
1749       ptrot=ptrot*a2
1750       return
1751       end
1752
1753 c------------------------------------------------------------------------
1754       function pttcs(b0)
1755 c-----------------------------------------------------------------------
1756 c ptt - nuclear profile function value at imp param squared b*difnuc**2
1757 c-----------------------------------------------------------------------
1758       include 'epos.inc'
1759       common /psar34/ rrr,rrrm
1760       common /ar5/    x5(2),a5(2)
1761       common /ar9/    x9(3),a9(3)
1762
1763       b=b0/difnuc(matarg)**2
1764       pttcs=0.
1765       zm=rrrm**2-b
1766       if(zm.gt.4.*b)then
1767         zm=sqrt(zm)
1768       else
1769         zm=2.*sqrt(b)
1770       endif
1771
1772       do i=1,3
1773         z1=zm*(1.+x9(i))*0.5
1774         z2=zm*(1.-x9(i))*0.5
1775         quq=sqrt(b+z1**2)-rrr
1776         if (quq.lt.85.)pttcs=pttcs+a9(i)/(1.+exp(quq))
1777         quq=sqrt(b+z2**2)-rrr
1778         if (quq.lt.85.)pttcs=pttcs+a9(i)/(1.+exp(quq))
1779       enddo
1780       pttcs=pttcs*zm*0.5
1781
1782       dt=0.
1783       do i=1,2
1784         z1=x5(i)+zm
1785         quq=sqrt(b+z1**2)-rrr-x5(i)
1786         if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
1787       enddo
1788
1789       pttcs=pttcs+dt
1790       return
1791       end
1792
1793 c------------------------------------------------------------------------
1794       function pprcs(b0)
1795 c-----------------------------------------------------------------------
1796 c ptt - nuclear profile function value at imp param squared b*difnuc**2
1797 c-----------------------------------------------------------------------
1798       include 'epos.inc'
1799       common /psar41/ rrrp,rrrmp
1800       common /ar5/    x5(2),a5(2)
1801       common /ar9/    x9(3),a9(3)
1802
1803       b=b0/difnuc(maproj)**2
1804       pprcs=0.
1805       zm=rrrmp**2-b
1806       if(zm.gt.4.*b)then
1807         zm=sqrt(zm)
1808       else
1809         zm=2.*sqrt(b)
1810       endif
1811
1812       do i=1,3
1813         z1=zm*(1.+x9(i))*0.5
1814         z2=zm*(1.-x9(i))*0.5
1815         quq=sqrt(b+z1**2)-rrrp
1816         if (quq.lt.85.)pprcs=pprcs+a9(i)/(1.+exp(quq))
1817         quq=sqrt(b+z2**2)-rrrp
1818         if (quq.lt.85.)pprcs=pprcs+a9(i)/(1.+exp(quq))
1819       enddo
1820       pprcs=pprcs*zm*0.5
1821
1822       dt=0.
1823       do i=1,2
1824         z1=x5(i)+zm
1825         quq=sqrt(b+z1**2)-rrrp-x5(i)
1826         if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
1827       enddo
1828
1829       pprcs=pprcs+dt
1830       return
1831       end
1832
1833 c------------------------------------------------------------------------------
1834       function pscrse(ek,mapr,matg)
1835 c------------------------------------------------------------------------------
1836 c hadron-nucleus (hadron-proton) and nucl-nucl particle production cross section
1837 c ek     - lab kinetic energy for the interaction
1838 c maproj - projec mass number     (1<maproj<64)
1839 c matarg - target mass number     (1<matarg<64)
1840 c------------------------------------------------------------------------------
1841       dimension wk(3),wa(3),wb(3)
1842       include 'epos.inc'
1843       common /psar33/ asect(7,4,7),asectn(7,7,7)
1844       common /psar34/ rrr,rrrm
1845       common /psar35/ anorm,anormp
1846       common /psar41/ rrrp,rrrmp
1847       external ptfau,ptfauAA
1848
1849       pscrse=0.
1850       call idmass(1120,amt1)
1851       call idmass(1220,amt2)
1852       amtar=0.5*(amt1+amt2)
1853       if(matg.eq.1)amtar=amt1
1854       if(mapr.eq.1)then
1855         call idmass(idproj,ampro)
1856       else
1857         ampro=amtar
1858       endif
1859       egy=ek+ampro
1860 c      p=sqrt(max(0.,egy**2-ampro**2))
1861       egy=sqrt( 2*egy*amtar+amtar**2+ampro**2 )
1862
1863       if(isetcs.le.1)then
1864         maprojsave=maproj
1865         matargsave=matarg
1866         engysave=engy
1867         maproj=mapr
1868         matarg=matg
1869         engy=egy
1870         if(matg.eq.1.and.mapr.eq.1)then
1871           call psfz(gz2,0.)
1872           gin=gz2*pi*10.
1873         elseif(mapr.eq.1)then
1874           rad=radnuc(matg)
1875           bm=rad+2.
1876           rrr=rad/difnuc(matg)
1877           rrrm=rrr+log(9.)
1878           anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matg)**2
1879           gin=(ptgau(ptfau,bm,2)+ptgau1(bm,2))*10. !sig_in
1880         elseif(matg.eq.1)then
1881           rad=radnuc(mapr)
1882           bm=rad+2.
1883           rrrp=rad/difnuc(mapr)
1884           rrrmp=rrrp+log(9.)
1885           anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(mapr)**2
1886           gin=(ptgau(ptfau,bm,1)+ptgau1(bm,1))*10. !sig_in
1887         else
1888           rad=radnuc(matg)+1.
1889           radp=radnuc(mapr)+1.
1890           bm=rad+radp+2.
1891           rrr=rad/difnuc(matg)
1892           rrrm=rrr+log(9.)
1893           rrrp=radp/difnuc(mapr)
1894           rrrmp=rrrp+log(9.)
1895           anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matg)**2
1896           anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(mapr)**2
1897           gin=(ptgau(ptfauAA,bm,2)+ptgau2(bm))*10.
1898         endif
1899         pscrse=gin
1900         maproj=maprojsave
1901         matarg=matargsave
1902         engy=engysave
1903       else
1904         ye=log10(max(1.,egy/1.5))+1.
1905         je=min(5,int(ye))
1906
1907         wk(2)=ye-je
1908         wk(3)=wk(2)*(wk(2)-1.)*.5
1909         wk(1)=1.-wk(2)+wk(3)
1910         wk(2)=wk(2)-2.*wk(3)
1911
1912         ya=matg
1913         ya=log(ya)/.69315+1.
1914         ja=min(int(ya),4)
1915         wa(2)=ya-ja
1916         wa(3)=wa(2)*(wa(2)-1.)*.5
1917         wa(1)=1.-wa(2)+wa(3)
1918         wa(2)=wa(2)-2.*wa(3)
1919
1920         if(mapr.eq.1)then
1921
1922           do i=1,3
1923             do m=1,3
1924               pscrse=pscrse+asect(je+i-1,iclpro,ja+m-1)*wk(i)*wa(m)
1925             enddo
1926           enddo
1927
1928         else
1929
1930           yb=mapr
1931           yb=log(yb)/.69315+1.
1932           jb=min(int(yb),4)
1933           wb(2)=yb-jb
1934           wb(3)=wb(2)*(wb(2)-1.)*.5
1935           wb(1)=1.-wb(2)+wb(3)
1936           wb(2)=wb(2)-2.*wb(3)
1937
1938           do i=1,3
1939             do m=1,3
1940               do n=1,3
1941             pscrse=pscrse+asectn(je+i-1,jb+n-1,ja+m-1)*wk(i)*wa(m)*wb(n)
1942               enddo
1943             enddo
1944           enddo
1945
1946         endif
1947
1948         pscrse=exp(pscrse)
1949       endif
1950       return
1951       end
1952
1953 c------------------------------------------------------------------------------
1954       function eposcrse(ek,mapro,matar,id)
1955 c------------------------------------------------------------------------------
1956 c inelastic cross section of epos
1957 c (id=0 corresponds to air)
1958 c ek     - kinetic energy for the interaction
1959 c maproj - projec mass number     (1<maproj<64)
1960 c matarg - target mass number     (1<matarg<64)
1961 c------------------------------------------------------------------------------
1962       include 'epos.inc'
1963
1964       eposcrse=0.
1965       if(id.eq.0)then
1966         do k=1,3
1967           mt=int(airanxs(k))
1968           eposcrse=eposcrse+airwnxs(k)*pscrse(ek,mapro,mt)
1969         enddo
1970       else
1971         eposcrse=pscrse(ek,mapro,matar)
1972       endif
1973
1974       return
1975       end
1976
1977
1978 cc------------------------------------------------------------------------
1979 c      function pshard1(sy,xpp,xpm,z)
1980 cc-----------------------------------------------------------------------
1981 cc pshard - qq-pomeron eikonal
1982 cc sy - energy squared for the pomeron,
1983 cc xpp - lc+ for the pomeron,
1984 cc xpm - lc- for the pomeron
1985 cc-----------------------------------------------------------------------
1986 c      common /ar3/   x1(7),a1(7)
1987 c      common /ar9/   x9(3),a9(3)
1988 c      include 'epos.inc'
1989 c      include 'epos.incsem'
1990 c
1991 c      pshard1=0.
1992 c      if(iclpro.ne.4.and.icltar.ne.4)then
1993 c        spmin=4.*q2min
1994 c      else
1995 c        spmin=4.*q2min+2.*qcmass**2
1996 c      endif
1997 c      if(sy.le.spmin)return
1998 c
1999 c      rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
2000 c      alpq=(alppar+1.)/2.
2001 c      xmin=spmin/sy             !min hard pomeron mass share
2002 c      xminl=xmin**(delh+.5)
2003 c
2004 c      do i=1,3
2005 c      do m=1,2
2006 c        zh=(.5*(1.+xminl-(2*m-3)*x9(i)*(1.-xminl)))**(1./(delh+.5))
2007 c        if(iclpro.ne.4.and.icltar.ne.4)then
2008 c          call psjti0(zh*sy,sqq,sqqb,1,1)
2009 c          call psjti0(zh*sy,sqqp,sqqpb,1,2)
2010 c          call psjti0(zh*sy,sqaq,sqaqb,-1,1)
2011 c        else
2012 c          call psjti0(zh*sy,sqq,sqqb,4,1)
2013 c          sqq=0.
2014 c          sqaq=0.
2015 c        endif
2016 c
2017 c        stq=0.
2018 c        do i1=1,3
2019 c        do m1=1,2
2020 c          xx=.5+x9(i1)*(m1-1.5)
2021 c          xp=zh**xx
2022 c          xm=zh/xp
2023 c          if(xp*xpp.le..9999.and.xm*xpm.le..9999.or.
2024 c     *    xm*xpp.le..9999.and.xp*xpm.le..9999)then
2025 c          stq=stq+a9(i1)*psharf(xp*xpp,xm*xpm,sqq,sqqp,sqaq)
2026 c     *    *(1.-xp)**(1.+alplea(iclpro)-alpq)
2027 c     *    *(1.-xm)**(1.+alplea(icltar)-alpq)
2028 c          endif
2029 c        enddo
2030 c        enddo
2031 c        pshard1=pshard1-a9(i)*stq/zh**(delh+0.5)*log(zh)
2032 c      enddo
2033 c      enddo
2034 c      pshard1=pshard1*(1.-xminl)/(delh+.5)/4.*factk
2035 c     **chad(iclpro)*chad(icltar)*(xpp*xpm)**(1.-alpq)
2036 c     **z**(rp/(r2had(iclpro)+r2had(icltar)))
2037 c     */(8.*pi*(r2had(iclpro)+r2had(icltar)))
2038 c      return
2039 c      end
2040 c
2041 c------------------------------------------------------------------------
2042       function pshard(sy,xpp,xpm)
2043 c-----------------------------------------------------------------------
2044 c pshard - qq-pomeron eikonal
2045 c sy - energy squared for the pomeron,
2046 c xpp - lc+ for the pomeron,
2047 c xpm - lc- for the pomeron
2048 c-----------------------------------------------------------------------
2049       double precision z01
2050       common /ar3/   x1(7),a1(7)
2051       include 'epos.inc'
2052       include 'epos.incsem'
2053
2054       pshard=0.
2055       if(iclpro.ne.4.and.icltar.ne.4)then
2056         spmin=4.*q2min
2057       else
2058         spmin=4.*q2min+2.*qcmass**2
2059       endif
2060       if(sy.le.spmin)return
2061
2062       alpq=(alppar+1.)/2.
2063       xmin=spmin/sy             !min hard pomeron mass share
2064       xminl=xmin**(delh+.5)
2065
2066       do i=1,7
2067       do m=1,2
2068         zh=(.5*(1.+xminl-(2*m-3)*x1(i)*(1.-xminl)))**(1./(delh+.5))
2069         if(iclpro.ne.4.and.icltar.ne.4)then
2070           call psjti0(zh*sy,sqq,sqqb,1,1)
2071           call psjti0(zh*sy,sqqp,sqqpb,1,2)
2072           call psjti0(zh*sy,sqaq,sqaqb,-1,1)
2073         else
2074           call psjti0(zh*sy,sqq,sqqb,4,1)
2075           sqqp=0.
2076           sqaq=0.
2077         endif
2078
2079         stq=0.  !int^1_(sqrt(z)) dx_p / x_p / sqrt(1-x_p) =int^(tmax)_(0) dt
2080         tmax=sqrt(1.-sqrt(zh))        !t=ln((1+sqrt(1-x_p))/(1-sqrt(1-x_p)))
2081         tmax=log((1.+tmax)/(1.-tmax))
2082         if(tmax.gt.1.e-20)then
2083         do i1=1,7
2084         do m1=1,2
2085           t=tmax*(.5+x1(i1)*(m1-1.5))
2086           z01=((1.d0-exp(-1.d0*t))/(1.d0+exp(-1.d0*t)))**2
2087           xp=1.-z01
2088           xm=zh/xp
2089           if(xp*xpp.le..9999.and.xm*xpm.le..9999.or.
2090      *    xm*xpp.le..9999.and.xp*xpm.le..9999)then
2091           stq=stq+a1(i1)*(psharf(xp*xpp,xm*xpm,sqq,sqqp,sqaq)+
2092      *    psharf(xm*xpp,xp*xpm,sqq,sqqp,sqaq))
2093      *    *z01**(.5-alpq)/(1.-xm)**alpq
2094           endif
2095         enddo
2096         enddo
2097         stq=stq*tmax
2098         endif
2099         pshard=pshard+a1(i)*stq/zh**(delh+0.5)
2100       enddo
2101       enddo
2102       pshard=pshard*(1.-xminl)/(delh+.5)/4.*
2103      *utgam1(2.+alplea(iclpro)-alpq)/utgam1(1.+alplea(iclpro))/
2104      *utgam1(1.-alpq)*
2105      *utgam1(2.+alplea(icltar)-alpq)/utgam1(1.+alplea(icltar))/
2106      *utgam1(1.-alpq)*
2107      *chad(iclpro)*chad(icltar)/(8.*pi*(r2had(iclpro)+r2had(icltar)))*
2108      *(xpp*xpm)**(-alpq)/sy**delh
2109       return
2110       end
2111
2112 c------------------------------------------------------------------------
2113       function psharf(zh1,zh2,sqq,sqqp,sqaq)
2114 c-----------------------------------------------------------------------
2115       include 'epos.incsem'
2116       include 'epos.inc'
2117
2118       alpq=(alppar+1.)/2.
2119       if(zh1.le..9999.and.zh2.le..9999)then
2120         uv1=psdfh4(zh1,q2min,0.,iclpro,1)
2121         dv1=psdfh4(zh1,q2min,0.,iclpro,2)
2122         uv2=psdfh4(zh2,q2min,0.,icltar,1)
2123         dv2=psdfh4(zh2,q2min,0.,icltar,2)
2124         if(iclpro.eq.2.and.icltar.eq.2)then       !proton
2125           fff=sqq*(uv1*uv2+dv1*dv2)+sqqp*(uv1*dv2+dv1*uv2)
2126         elseif(iclpro.eq.1.or.icltar.eq.1)then   !pion
2127           fff=sqq*uv1*uv2+sqaq*dv1*dv2+sqqp*(uv1*dv2+dv1*uv2)
2128         elseif(iclpro.eq.3.or.icltar.eq.3)then   !kaon
2129           fff=sqq*uv1*uv2+sqqp*(uv1*dv2+dv1*uv2+dv1*dv2)
2130         elseif(iclpro.eq.4.or.icltar.eq.4)then   !J/psi
2131           fff=sqq*uv1*(uv2+dv2)
2132         endif
2133         psharf=fff*(1.-zh1)**(-1.+alpq-alplea(iclpro))*
2134      *  (1.-zh2)**(-1.+alpq-alplea(icltar))
2135       else
2136         psharf=0.
2137       endif
2138       return
2139       end
2140
2141 c------------------------------------------------------------------------
2142       function psvin(sy,xpp,xpm,z,iqq)
2143 c-----------------------------------------------------------------------
2144 c psvin - contributions to the interaction eikonal
2145 c sy  - energy squared for the hard interaction,
2146 c xpp - lc+ for the sh pomeron,
2147 c xpm - lc- for the sh pomeron,
2148 c z   - impact parameter factor, z=exp(-b**2/4*rp),
2149 c iqq = 1  - gg,
2150 c iqq = 2  - qg,
2151 c iqq = 3  - gq,
2152 c iqq = 4  - qq,
2153 c iqq = 5  - gg(int),
2154 c iqq = 6  - gg(proj),
2155 c iqq = 7  - qg(proj),
2156 c iqq = 9  - total uncut-integrated,
2157 c iqq = 10 - total cut,
2158 c iqq = 14  - gg(int)|b=0,
2159 c iqq = 15  - <b^2*gg(int)>,
2160 c iqq = 16  - gg(proj)|b=0,
2161 c iqq = 17  - <b^2*gg(proj)>,
2162 c iqq = 18  - qg(proj)|b=0,
2163 c iqq = 19  - <b^2*qg(proj)>
2164 c-----------------------------------------------------------------------
2165       dimension wk(3),wi(3),wj(3),wz(3),fa(3)
2166       common /psar2/  edmax,epmax
2167       common /psar4/  fhgg(11,10,8),fhqg(11,10,80)
2168      *,fhgq(11,10,80),fhqq(11,10,80),fhgg0(11,10),fhgg1(11,10,4)
2169      *,fhqg1(11,10,40),fhgg01(11),fhgg02(11),fhgg11(11,4)
2170      *,fhgg12(11,4),fhqg11(11,10,4),fhqg12(11,10,4)
2171      *,ftoint(11,14,2,2,3)
2172       common /psar7/  delx,alam3p,gam3p
2173       include 'epos.inc'
2174       include 'epos.incsem'
2175
2176       if(iqq.eq.3)then
2177         xp=xpm
2178         xm=xpp
2179         iclp=icltar
2180         iclt=iclpro
2181       else
2182         xp=xpp
2183         xm=xpm
2184         iclp=iclpro
2185         iclt=icltar
2186       endif
2187       rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
2188
2189       psvin=0.
2190       if(iqq.eq.1.or.iqq.eq.5.or.iqq.eq.6.or.iqq.eq.14
2191      *.or.iqq.eq.15.or.iqq.eq.16.or.iqq.eq.17
2192      *.or.iclpro.ne.4.and.(iqq.eq.2.or.iqq.eq.7
2193      *.or.iqq.eq.18.or.iqq.eq.19)
2194      *.or.icltar.ne.4.and.iqq.eq.3
2195      *.or.iclpro.ne.4.and.icltar.ne.4)then
2196         spmin=4.*q2min
2197       else
2198         spmin=4.*q2min+2.*qcmass**2
2199       endif
2200       if(sy.le.spmin.and.(iqq.le.7.or.iqq.gt.13))return
2201
2202       if(iqq.le.7.or.iqq.gt.13)then
2203         yl=log(sy/spmin)/log(epmax/2./spmin)*10.+1
2204         k=int(yl)
2205         if(k.gt.9)k=9
2206         wk(2)=yl-k
2207         wk(3)=wk(2)*(wk(2)-1.)*.5
2208         wk(1)=1.-wk(2)+wk(3)
2209         wk(2)=wk(2)-2.*wk(3)
2210
2211         if(iqq.ne.4)then  !---------------- not 4 ------------------
2212
2213           if(iqq.eq.5)then
2214             if(k.eq.1)then
2215               psvin=max(0.,exp(fhgg01(k+1))*wk(2)
2216      *        +exp(fhgg01(k+2))*wk(3))
2217             else
2218               psvin=exp(fhgg01(k)*wk(1)+fhgg01(k+1)*wk(2)
2219      *        +fhgg01(k+2)*wk(3))
2220             endif
2221             psvin=psvin*factk*sy**delh
2222             return
2223
2224           elseif(iqq.eq.15)then
2225             if(k.eq.1)then
2226               psvin=max(0.,exp(fhgg02(k+1))*wk(2)
2227      *        +exp(fhgg02(k+2))*wk(3))
2228             else
2229               psvin=exp(fhgg02(k)*wk(1)+fhgg02(k+1)*wk(2)
2230      *        +fhgg02(k+2)*wk(3))
2231             endif
2232             psvin=psvin*factk*sy**delh
2233             return
2234
2235           elseif(iqq.eq.6)then
2236             if(k.eq.1)then
2237               psvin=max(0.,exp(fhgg11(k+1,iclpro))*wk(2)
2238      *        +exp(fhgg11(k+2,iclpro))*wk(3))
2239             else
2240               psvin=exp(fhgg11(k,iclpro)*wk(1)+fhgg11(k+1,iclpro)*wk(2)
2241      *        +fhgg11(k+2,iclpro)*wk(3))
2242             endif
2243             psvin=psvin*factk*sy**delh*xp**(-alppar)
2244             return
2245
2246           elseif(iqq.eq.17)then
2247             if(k.eq.1)then
2248               psvin=max(0.,exp(fhgg12(k+1,iclpro))*wk(2)
2249      *        +exp(fhgg12(k+2,iclpro))*wk(3))
2250             else
2251               psvin=exp(fhgg12(k,iclpro)*wk(1)+fhgg12(k+1,iclpro)*wk(2)
2252      *        +fhgg12(k+2,iclpro)*wk(3))
2253             endif
2254             psvin=psvin*factk*sy**delh*xp**(-alppar)
2255             return
2256
2257           elseif(iqq.eq.7.or.iqq.eq.19)then
2258             if(xp.lt..2)then
2259               xl=log(10.*xp)/log(2.)+5.
2260             else
2261               xl=5.*xp+5.
2262             endif
2263             i=int(xl)
2264             if(i.lt.1)i=1
2265             if(i.eq.5)i=4
2266             if(i.gt.8)i=8
2267             wi(2)=xl-i
2268             wi(3)=wi(2)*(wi(2)-1.)*.5
2269             wi(1)=1.-wi(2)+wi(3)
2270             wi(2)=wi(2)-2.*wi(3)
2271             do k1=1,3
2272               fa(k1)=0.
2273             do i1=1,3
2274               k2=k+k1-1
2275               if(iqq.eq.7)then
2276                 fhhh=fhqg11(k2,i+i1-1,iclpro)
2277               elseif(iqq.eq.19)then
2278                 fhhh=fhqg12(k2,i+i1-1,iclpro)
2279               endif
2280               fa(k1)=fa(k1)+fhhh*wi(i1)
2281             enddo
2282             enddo
2283             if(k.eq.1)then
2284               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
2285             else
2286               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
2287             endif
2288             psvin=psvin*factk*sy**delh
2289             return
2290           endif
2291
2292           jz=int(10.*z)
2293           if(jz.gt.8)jz=8
2294           if(jz.lt.1)jz=1
2295           wz(2)=10.*z-jz
2296           wz(3)=wz(2)*(wz(2)-1.)*.5
2297           wz(1)=1.-wz(2)+wz(3)
2298           wz(2)=wz(2)-2.*wz(3)
2299
2300           if(iqq.eq.14)then
2301             do k1=1,3
2302               k2=k+k1-1
2303               fa(k1)=fhgg0(k2,jz)*wz(1)+fhgg0(k2,jz+1)
2304      *        *wz(2)+fhgg0(k2,jz+2)*wz(3)
2305             enddo
2306             if(k.eq.1)then
2307               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
2308             else
2309               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
2310             endif
2311             psvin=psvin*z*factk*sy**delh
2312
2313           elseif(iqq.eq.16)then
2314             do k1=1,3
2315               k2=k+k1-1
2316               fa(k1)=fhgg1(k2,jz,iclpro)*wz(1)+fhgg1(k2,jz+1,iclpro)
2317      *        *wz(2)+fhgg1(k2,jz+2,iclpro)*wz(3)
2318             enddo
2319             if(k.eq.1)then
2320               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
2321             else
2322               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
2323             endif
2324             psvin=psvin*z*factk*sy**delh*xp**(-alppar)
2325
2326           elseif(iqq.eq.18)then
2327             if(xp.lt..2)then
2328               xl=log(10.*xp)/log(2.)+5.
2329             else
2330               xl=5.*xp+5.
2331             endif
2332             i=int(xl)
2333             if(i.lt.1)i=1
2334             if(i.eq.5)i=4
2335             if(i.gt.8)i=8
2336             wi(2)=xl-i
2337             wi(3)=wi(2)*(wi(2)-1.)*.5
2338             wi(1)=1.-wi(2)+wi(3)
2339             wi(2)=wi(2)-2.*wi(3)
2340             do k1=1,3
2341               fa(k1)=0.
2342             do i1=1,3
2343             do l1=1,3
2344               k2=k+k1-1
2345               l2=jz+l1-1+10*(iclpro-1)
2346               fhhh=fhqg1(k2,i+i1-1,l2)
2347               fa(k1)=fa(k1)+fhhh*wi(i1)*wz(l1)
2348             enddo
2349             enddo
2350             enddo
2351             if(k.eq.1)then
2352               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
2353             else
2354               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
2355             endif
2356             psvin=psvin*z*factk*sy**delh
2357
2358           elseif(iqq.eq.1)then   !1111111111111111111111111111111111
2359
2360             do k1=1,3
2361               k2=k+k1-1
2362               iclpt=iclpro+4*(icltar-1)
2363               fa(k1)=fhgg(k2,jz,iclpt)*wz(1)+fhgg(k2,jz+1,iclpt)
2364      *        *wz(2)+fhgg(k2,jz+2,iclpt)*wz(3)
2365             enddo
2366             if(k.eq.1)then
2367               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
2368             else
2369               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
2370             endif
2371             psvin=psvin*z*factk*sy**delh*(xp*xm)**(-alppar)
2372
2373           else  ! 2222222222222222222222 3333333333333333333333 ....
2374
2375             if(xp.lt..2)then
2376               xl=log(10.*xp)/log(2.)+5.
2377             else
2378               xl=5.*xp+5.
2379             endif
2380             i=int(xl)
2381             if(i.lt.1)i=1
2382             if(i.eq.5)i=4
2383             if(i.gt.8)i=8
2384             wi(2)=xl-i
2385             wi(3)=wi(2)*(wi(2)-1.)*.5
2386             wi(1)=1.-wi(2)+wi(3)
2387             wi(2)=wi(2)-2.*wi(3)
2388             do k1=1,3
2389               fa(k1)=0.
2390             do i1=1,3
2391             do l1=1,3
2392               k2=k+k1-1
2393               if(iqq.eq.2)then
2394                 l2=jz+l1-1+10*(iclpro+4*(icltar-1)-1)
2395                 fhhh=fhqg(k2,i+i1-1,l2)
2396               elseif(iqq.eq.3)then
2397                 l2=jz+l1-1+10*(iclpro+4*(icltar-1)-1)
2398                 fhhh=fhgq(k2,i+i1-1,l2)
2399               endif
2400               fa(k1)=fa(k1)+fhhh*wi(i1)*wz(l1)
2401             enddo
2402             enddo
2403             enddo
2404             if(k.eq.1)then
2405               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
2406             else
2407               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
2408             endif
2409             psvin=psvin*xm**(-alppar)*z*factk*sy**delh
2410           endif
2411
2412         else ! ------------- 4444444444444444444 -----------------------
2413
2414           if(xp.lt..2)then
2415             xl1=log(10.*xp)/log(2.)+5.
2416           else
2417             xl1=5.*xp+5.
2418           endif
2419           i=max(1,int(xl1))
2420           if(i.eq.5)i=4
2421           i=min(8,i)
2422           wi(2)=xl1-i
2423           wi(3)=wi(2)*(wi(2)-1.)*.5
2424           wi(1)=1.-wi(2)+wi(3)
2425           wi(2)=wi(2)-2.*wi(3)
2426
2427           if(xm.lt..2)then
2428             xl2=log(10.*xm)/log(2.)+5.
2429           else
2430             xl2=5.*xm+5.
2431           endif
2432           j=max(1,int(xl2))
2433           if(j.eq.5)j=4
2434           j=min(8,j)
2435           wj(2)=xl2-j
2436           wj(3)=wj(2)*(wj(2)-1.)*.5
2437           wj(1)=1.-wj(2)+wj(3)
2438           wj(2)=wj(2)-2.*wj(3)
2439
2440           do k1=1,3
2441             fa(k1)=0.
2442           do i1=1,3
2443           do j1=1,3
2444             k2=k+k1-1
2445             j2=j+j1-1+10*(iclp+4*(iclt-1)-1)
2446             fa(k1)=fa(k1)+fhqq(k2,i+i1-1,j2)*wi(i1)*wj(j1)
2447           enddo
2448           enddo
2449           enddo
2450           if(k.eq.1)then
2451             psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
2452           else
2453             psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
2454           endif
2455           psvin=psvin*z**(rp/(r2had(iclpro)+r2had(icltar)))*
2456      *    factk*sy**delh
2457
2458         endif !--------------------------------------------
2459
2460         return
2461       endif
2462
2463       yl=log(sy)/log(1.e8)*10.+1
2464       k=max(1,int(yl))
2465       k=min(k,9)     !?????????????9
2466       wk(2)=yl-k
2467       wk(3)=wk(2)*(wk(2)-1.)*.5
2468       wk(1)=1.-wk(2)+wk(3)
2469       wk(2)=wk(2)-2.*wk(3)
2470
2471       if(z.gt..1)then
2472         zz=10.*z+4
2473       else
2474         zz=50.*z
2475       endif
2476       jz=min(12,int(zz))
2477       if(jz.eq.0)jz=1
2478       if(jz.eq.4)jz=3
2479       wz(2)=zz-jz
2480       wz(3)=wz(2)*(wz(2)-1.)*.5
2481       wz(1)=1.-wz(2)+wz(3)
2482       wz(2)=wz(2)-2.*wz(3)
2483
2484       if(iqq.eq.9)then
2485         do k1=1,3
2486         do l1=1,3
2487           k2=k+k1-1
2488           l2=jz+l1-1
2489           psvin=psvin+ftoint(k2,l2,icdp,icdt,iclp)*wk(k1)*wz(l1)
2490         enddo
2491         enddo
2492         psvin=exp(psvin)*z
2493
2494       endif
2495       return
2496       end
2497
2498 c------------------------------------------------------------------------
2499       function psbint(q1,q2,qqcut,ss,m1,l1,jdis)
2500 c-----------------------------------------------------------------------
2501 c psbint - born cross-section interpolation
2502 c q1 - virtuality cutoff at current end of the ladder;
2503 c q2 - virtuality cutoff at opposite end of the ladder;
2504 c qqcut - p_t cutoff for the born process;
2505 c s  - total c.m. energy squared for the scattering,
2506 c m1 - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
2507 c l1 - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
2508 c-----------------------------------------------------------------------
2509       dimension wi(3),wk(3)
2510       common /psar2/  edmax,epmax
2511       common /psar21/ csbor(20,160,2)
2512       include 'epos.incsem'
2513       double precision psuds
2514
2515       psbint=0.
2516       if(jdis.eq.0)then
2517         qq=max(q1,q2)
2518       else
2519         qq=max(q1/4.,q2)
2520       endif
2521       qq=max(qq,qqcut)
2522       if(iabs(m1).ne.4)then
2523         q2mass=0.
2524         if(m1.ne.0.and.m1.eq.l1)then
2525           m=2
2526           l=2
2527         elseif(m1.ne.0.and.m1.eq.-l1)then
2528           m=3
2529           l=1
2530         elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
2531           m=3
2532           l=2
2533         else
2534           m=min(1,iabs(m1))+1
2535           l=min(1,iabs(l1))+1
2536         endif
2537       else
2538         q2mass=qcmass**2
2539         m=4
2540         l=min(1,iabs(l1))+1
2541       endif
2542       s=ss-q2mass
2543       spmin=4.*q2min+q2mass
2544       s2min=4.*qq+q2mass
2545       if(s.le.s2min)return
2546
2547       p1=s/(1.+q2mass/s)
2548       if(p1.gt.4.*qq)then
2549         tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
2550       else
2551         tmin=2.*qq
2552       endif
2553       qmax=p1/4.
2554       tmax=p1/2.
2555
2556       ml=20*(m-1)+80*(l-1)
2557       qli=log(qq/q2min)/log(qmax/q2min)*19.+1.
2558       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
2559       k=int(sl)
2560       i=int(qli)
2561       if(k.lt.1)k=1
2562       if(i.lt.1)i=1
2563       if(k.gt.18)k=18
2564       if(i.gt.18)i=18
2565
2566       wi(2)=qli-i
2567       wi(3)=wi(2)*(wi(2)-1.)*.5
2568       wi(1)=1.-wi(2)+wi(3)
2569       wi(2)=wi(2)-2.*wi(3)
2570
2571       wk(2)=sl-k
2572       wk(3)=wk(2)*(wk(2)-1.)*.5
2573       wk(1)=1.-wk(2)+wk(3)
2574       wk(2)=wk(2)-2.*wk(3)
2575
2576       do i1=1,3
2577       do k1=1,3
2578         psbint=psbint+csbor(i+i1-1,k+k1+ml-1,jdis+1)
2579      *  *wi(i1)*wk(k1)
2580       enddo
2581       enddo
2582       psbint=exp(psbint)*(1./tmin-1./tmax)
2583       if(jdis.eq.0.and.qq.gt.q1)then
2584         psbint=psbint*sngl(psuds(qq,m1)/psuds(q1,m1))
2585       elseif(jdis.eq.1.and.4.*qq.gt.q1)then
2586         psbint=psbint*sngl(psuds(4.*qq,m1)/psuds(q1,m1))
2587       endif
2588       if(qq.gt.q2)psbint=psbint*sngl(psuds(qq,l1)/psuds(q2,l1))
2589       return
2590       end
2591
2592 c-----------------------------------------------------------------------
2593       function psborn(q1,q2,qqcut,s,j,l,jdis,md)
2594 c-----------------------------------------------------------------------
2595 c
2596 c    hard 2->2 parton scattering born cross-section
2597 c       including sudakov on both sides
2598 c
2599 c q1 - virtuality cutoff at current end of the ladder;
2600 c q2 - virtuality cutoff at opposite end of the ladder;
2601 c qqcut - p_t cutoff for the born process;
2602 c s - c.m. energy squared for the scattering;
2603 c j - parton type at current end of the ladder (0 - g, 1,2 etc. - q);
2604 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
2605 c-----------------------------------------------------------------------
2606       common /ar3/   x1(7),a1(7)
2607       double precision sud0,psbornd,psuds
2608       include 'epos.inc'
2609       include 'epos.incsem'
2610
2611       psborn=0
2612
2613       if(jdis.eq.0)then
2614         qq=max(q1,q2)
2615       else
2616         qq=max(q1/4.,q2)
2617       endif
2618       qq=max(qq,qqcut)
2619 c      if(j.ne.3)then  !kkkkkkkkkk  charm is 3 ???
2620       if(j.ne.4)then
2621         j1=j
2622         q2mass=0.
2623       else
2624         j1=4
2625         q2mass=qcmass**2
2626       endif
2627       p1=s/(1.+q2mass/s)
2628       if(p1.gt.4.*qq)then
2629         tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
2630       else
2631         tmin=2.*qq
2632 !        return !tmin=2.*qq   !kkkkkkk !?????????????  tp  why not ?
2633       endif
2634       tmax=p1/2.
2635       sud0=psuds(q1,j1)*psuds(q2,l)
2636
2637       psbornd=0.d0
2638       do i=1,7
2639       do m=1,2
2640         t=2.*tmin/(1.+tmin/tmax-x1(i)*(2*m-3)
2641      &  *(1.-tmin/tmax))
2642         qt=t*(1.-t/p1)
2643         if(qt.lt..999*qq.and.ish.ge.1)write(ifch,*)'psborn:qt,qq,q1,q2'
2644      &                                             ,qq,qt,q1,q2
2645
2646         if(jdis.eq.0)then
2647           scale=qt
2648         else
2649           scale=qt*4.
2650         endif
2651         if(j1.eq.0.and.l.eq.0)then
2652           fb=ffborn(s,t, 1. , 0. , 0. , 0. , 0. )    !gg
2653         elseif(j1*l.eq.0)then
2654           fb=ffborn(s,t, 0. , 1. , 0. , 0. , 0.)     !qg
2655         elseif(j1.eq.l)then
2656           fb=ffborn(s,t, 0. , 0. , 1. , 0. , 0.)     !qq
2657         elseif(j1.eq.-l)then
2658           fb=ffborn(s,t, 0. , 0. , 0. , 1. , 0.)     !qq
2659         else
2660           fb=ffborn(s,t, 0. , 0. , 0. , 0. , 1.)     !qq
2661         endif
2662         fb=fb*pssalf(qt/qcdlam)**2
2663         psbornd=psbornd+dble(a1(i)*fb)*dble(t)**2
2664      &  *psuds(scale,j1)*psuds(qt,l)
2665       enddo
2666       enddo
2667       psbornd=psbornd*dble(2.*pi**3)/dble(s)**2/sud0*2
2668      *    /2   !CS for parton pair
2669       if(md.eq.1)psbornd=psbornd*(1./tmin-1./tmax)
2670       psborn=sngl(psbornd)
2671       return
2672       end
2673
2674 c------------------------------------------------------------------------
2675       function psdgh(s,qq,long)
2676 c-----------------------------------------------------------------------
2677 c psdgh
2678 c s - energy squared for the interaction (hadron-hadron),
2679 c-----------------------------------------------------------------------
2680       common/ar3/    x1(7),a1(7)
2681       common /cnsta/ pi,pii,hquer,prom,piom,ainfin
2682       include 'epos.incsem'
2683       double precision psuds
2684
2685       xd=qq/s
2686       if(long.eq.0)then
2687         psdgh=(psdfh4(xd,q2min,0.,2,1)/2.25+psdfh4(xd,q2min,0.,2,2)/9.
2688      *  +psdfh4(xd,q2min,0.,2,3)/9.+
2689      *  2.*(psdfh4(xd,q2min,0.,2,-1)+psdfh4(xd,q2min,0.,2,-2)+
2690      *  psdfh4(xd,q2min,0.,2,-3))/4.5)
2691      *  *sngl(psuds(qq,1)/psuds(q2min,1))*4.*pi**2*alfe/qq
2692       else
2693         psdgh=0.
2694       endif
2695
2696       dgh=0.
2697       if(long.eq.0)then
2698         s2min=qq/(1.-q2ini/qq)
2699       else
2700         s2min=4.*max(q2min,qcmass**2)+qq
2701         s2min=s2min/(1.-4.*q2ini/(s2min-qq))
2702       endif
2703       xmin=s2min/s
2704
2705       if(xmin.lt.1.)then
2706         do i=1,7          !numerical integration over z1
2707         do m=1,2
2708           if(long.eq.0)then
2709             z1=qq/s+(xmin-qq/s)*((1.-qq/s)/(xmin-qq/s))
2710      *      **(.5+(m-1.5)*x1(i))
2711           else
2712             z1=.5*(1.+xmin+(2*m-3)*x1(i)*(1.-xmin))
2713           endif
2714           call psdint(z1*s,qq,sds,sdn,sdb,sdt,sdr,1,long)
2715           call psdint(z1*s,qq,sdsg,sdng,sdbg,sdtg,sdrg,0,long)
2716           tu=psdfh4(z1,q2min,0.,2,1)
2717           td=psdfh4(z1,q2min,0.,2,2)
2718           ts=psdfh4(z1,q2min,0.,2,3)
2719           tg=psdfh4(z1,q2min,0.,2,0)
2720           tsea=2.*(psdfh4(z1,q2min,0.,2,-1)+psdfh4(z1,q2min,0.,2,-2)
2721      *    +psdfh4(z1,q2min,0.,2,-3))
2722           gy=sdn*(tu/2.25+td/9.+ts/9.+tsea/4.5)+sdtg*tg/4.5
2723      *    +sdt*(tu+td+ts+tsea)/4.5
2724           dgh=dgh+a1(i)*gy*(1.-qq/s/z1)
2725         enddo
2726         enddo
2727         dgh=dgh*log((1.-qq/s)/(xmin-qq/s))*.5
2728       endif
2729       psdgh=psdgh+dgh
2730       return
2731       end
2732
2733 c------------------------------------------------------------------------
2734       function psdh(s,qq,iclpro0,long)
2735 c-----------------------------------------------------------------------
2736 c pshard - hard quark-quark interaction cross-section
2737 c s - energy squared for the interaction (hadron-hadron),
2738 c iclpro0 - type of the primary hadron (nucleon)
2739 c-----------------------------------------------------------------------
2740       common /ar3/   x1(7),a1(7)
2741       include 'epos.incsem'
2742       include 'epos.inc'
2743       double precision psuds
2744
2745       xd=qq/s
2746       qqs=q2min
2747       if(long.eq.0.and.(idisco.eq.0.or.idisco.eq.1))then
2748         psdh=(psdfh4(xd,qqs,0.,iclpro0,1)/2.25+
2749      *  psdfh4(xd,qqs,0.,iclpro0,2)/9.)
2750      *  *sngl(psuds(qq,1)/psuds(qqs,1))
2751      *  *4.*pi**2*alfe/qq
2752       else
2753         psdh=0.
2754       endif
2755
2756       dh=0.
2757       if(long.eq.0)then
2758         s2min=qq/(1.-q2ini/qq)
2759       else
2760         s2min=4.*max(q2min,qcmass**2)+qq
2761         s2min=s2min/(1.-4.*q2ini/(s2min-qq))
2762       endif
2763       xmin=s2min/s
2764       if(xmin.lt.1.)then
2765         do i=1,7          !numerical integration over z1
2766         do m=1,2
2767           if(long.eq.0)then
2768             z1=qq/s+(xmin-qq/s)*((1.-qq/s)/(xmin-qq/s))
2769      *      **(.5+(m-1.5)*x1(i))
2770           else
2771             z1=.5*(1.+xmin+(2*m-3)*x1(i)*(1.-xmin))
2772           endif
2773           call psdint(z1*s,qq,sds,sdn,sdb,sdt,sdr,1,long)
2774           tu=psdfh4(z1,qqs,0.,iclpro0,1)
2775           td=psdfh4(z1,qqs,0.,iclpro0,2)
2776           gy=sdt*(tu+td)/4.5+sdn*(tu/2.25+td/9.)
2777           if(long.eq.0)then
2778             gy=gy*(1.-qq/s/z1)
2779           else
2780             gy=gy/z1
2781           endif
2782           dh=dh+a1(i)*gy
2783         enddo
2784         enddo
2785         if(long.eq.0)then
2786           dh=dh*log((1.-qq/s)/(xmin-qq/s))*.5
2787         else
2788           dh=dh*(1.-xmin)*.5
2789         endif
2790       endif
2791       psdh=psdh+dh
2792       return
2793       end
2794
2795 c------------------------------------------------------------------------
2796       function psdsh(s,qq,iclpro0,dqsh,long)
2797 c-----------------------------------------------------------------------
2798 c psdsh - semihard interaction eikonal
2799 c s - energy squared for the interaction (hadron-hadron),
2800 c iclpro0 - hadron class,
2801 c z - impact parameter factor, z=exp(-b**2/rp),
2802 c iqq - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
2803 c-----------------------------------------------------------------------
2804       common /ar3/    x1(7),a1(7)
2805       include 'epos.inc'
2806       include 'epos.incsem'
2807       double precision psuds
2808
2809       xd=qq/s
2810       if(long.eq.0.and.(idisco.eq.0.or.idisco.eq.1))then
2811         dqsh=fzeroSeaZZ(xd,iclpro0)/xd**dels
2812      *  *rr*4.*pi*gamhad(iclpro0)/
2813      *  4.5*sngl(psuds(qq,1)/psuds(q2min,1))
2814      *  *4.*pi**2*alfe/qq
2815       else
2816         dqsh=0.
2817       endif
2818
2819       if(long.eq.0)then
2820         s2min=qq/(1.-q2ini/qq)
2821       else
2822         s2min=qq+4.*max(q2min,qcmass**2)
2823       endif
2824       xmin=s2min/s
2825       xmin=xmin**(delh-dels)
2826       dsh=0.
2827       if(xmin.lt.1.)then
2828 c numerical integration over z1
2829         do i=1,7
2830         do m=1,2
2831           z1=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./
2832      *    (delh-dels))
2833           call psdint(z1*s,qq,sdsg,sdng,sdbg,sdtg,sdrg,0,long)
2834           call psdint(z1*s,qq,sdsq,sdnq,sdbq,sdtq,sdrq,1,long)
2835           dsh=dsh+a1(i)/z1**delh*(sdtg*fzeroGluZZ(z1,iclpro0)
2836      *    +(sdtq+sdnq)*fzeroSeaZZ(z1,iclpro0))
2837         enddo
2838         enddo
2839         dsh=dsh*(1.-xmin)/(delh-dels)/2.
2840       endif
2841       psdsh=dqsh+dsh*rr*4.*pi*gamhad(iclpro0)/4.5  !*ccorr(1,1,iclpro0)
2842       return
2843       end
2844
2845 c------------------------------------------------------------------------
2846       function psdsh1(s,qq,iclpro0,dqsh,long)
2847 c-----------------------------------------------------------------------
2848 c psdsh - semihard interaction eikonal
2849 c s - energy squared for the interaction (hadron-hadron),
2850 c iclpro0 - hadron class,
2851 c z - impact parameter factor, z=exp(-b**2/rp),
2852 c iqq - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
2853 c-----------------------------------------------------------------------
2854       common /ar3/    x1(7),a1(7)
2855       include 'epos.inc'
2856       include 'epos.incsem'
2857 c      double precision psuds
2858
2859       psdsh1=0.       !only for plotting in psaevp : not use any more
2860
2861 c$$$      xd=qq/s
2862 c$$$      write(ifch,*)'Psdsh1 for xd,qq',xd,qq
2863 c$$$      if(long.eq.0.and.(idisco.eq.0.or.idisco.eq.1))then
2864 c$$$        dqsh=psftist(xd)/4.5*sngl(psuds(qq,1)/psuds(q2min,1))
2865 c$$$     *  *4.*pi**2*alfe/qq
2866 c$$$      else
2867 c$$$        dqsh=0.
2868 c$$$      endif
2869 c$$$
2870 c$$$      if(long.eq.0)then
2871 c$$$        s2min=qq/(1.-q2ini/qq)
2872 c$$$      else
2873 c$$$        s2min=qq+4.*max(q2min,qcmass**2)
2874 c$$$      endif
2875 c$$$      xmin=s2min/s
2876 c$$$      xmin=xmin**(delh-dels)
2877 c$$$      dsh=0.
2878 c$$$      if(xmin.lt.1.)then
2879 c$$$c numerical integration over z1
2880 c$$$        do i=1,7
2881 c$$$        do m=1,2
2882 c$$$          z1=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./
2883 c$$$     *    (delh-dels))
2884 c$$$          call psdint(z1*s,qq,sdsg,sdng,sdbg,sdtg,sdrg,0,long)
2885 c$$$          call psdint(z1*s,qq,sdsq,sdnq,sdbq,sdtq,sdrq,1,long)
2886 c$$$          dsh=dsh+a1(i)/z1**delh*(sdtg*psftigt(z1)
2887 c$$$     *    +(sdtq+sdnq)*psftist(z1))*z1**dels
2888 c$$$        enddo
2889 c$$$        enddo
2890 c$$$        dsh=dsh*(1.-xmin)/(delh-dels)/2.
2891 c$$$      endif
2892 c$$$      psdsh1=dqsh+dsh/4.5
2893       return
2894       end
2895
2896
2897 c------------------------------------------------------------------------
2898       function psev0(q1,qq,xx,j)
2899 c-----------------------------------------------------------------------
2900       double precision xx,psuds,psev00
2901       common /ar3/   x1(7),a1(7)
2902       include 'epos.incsem'
2903
2904       psev0=0.
2905       psev00=0.d0
2906       do i=1,7
2907       do m=1,2
2908         if(j.eq.1)then           !g->q
2909           qi=2.*q1/(1.+q1/qq+(1.-q1/qq)*(2.*m-3.)*x1(i))
2910           psev00=psev00+a1(i)*qi*psuds(qi,0)/psuds(qi,1)
2911      *    /log(qi*(1.d0-xx)/qcdlam)
2912         else                     !q->g
2913           qi=(.5*(q1+qq+(q1-qq)*(2.*m-3.)*x1(i)))
2914           psev00=psev00+a1(i)/qi/psuds(qi,0)*psuds(qi,1)
2915      *    /log(qi*(1.d0-xx)/qcdlam)
2916         endif
2917       enddo
2918       enddo
2919
2920       if(j.eq.1)then
2921         psev00=psev00*(1.d0/q1-1.d0/qq)*psuds(qq,1)/psuds(qq,0)/2.d0
2922       else
2923         psev00=psev00*(qq-q1)*psuds(qq,0)/psuds(qq,1)/2.d0
2924       endif
2925       psev00=psev00/log(log(qq*(1.d0-xx)/qcdlam)
2926      &             /log(q1*(1.d0-xx)/qcdlam))
2927       psev0=sngl(psev00)
2928       return
2929       end
2930
2931 c------------------------------------------------------------------------
2932       function psev(q1,qq,xx,j,l,n)
2933 c------------------------------------------------------------------------
2934       double precision xx,zmax,zmax1,zmin,zmin1,z,psuds,fk,fq
2935      &,fz1,fz2
2936       common /ar3/   x1(7),a1(7)
2937       include 'epos.incsem'
2938
2939       zmax=1.d0-q2ini/qq
2940       zmin=xx/zmax
2941       qmax=qq
2942       fz1=0.d0
2943       fz2=0.d0
2944
2945       if(zmin.lt.zmax)then
2946       if(zmin.lt..1d0)then
2947         zmax1=min(.1d0,zmax)
2948         do i=1,7
2949         do m=1,2
2950           if(n.eq.2)then
2951             z=xx+(zmin-xx)*((zmax1-xx)/(zmin-xx))**(.5+(m-1.5)*x1(i))
2952           elseif(j.eq.1)then
2953             z=zmin*(zmax1/zmin)**(.5+(m-1.5)*x1(i))
2954           else
2955             z=(.5d0*(zmax1+zmin+(zmax1-zmin)*(2*m-3)*x1(i)))
2956           endif
2957           qmin=max(q2ini/(1.d0-xx/z),q2ini/(1.d0-z))
2958           qmin=max(qmin,q1)
2959
2960           do k=1,2
2961             fq=0.d0
2962             do i1=1,7
2963             do m1=1,2
2964               if(n.eq.2)then
2965                 qi=qmin*(qmax/qmin)**(.5+x1(i1)*(m1-1.5))
2966               else
2967                 qi=(.5*(qmax+qmin+(qmax-qmin)*(2.*m1-3.)*x1(i1)))
2968               endif
2969
2970               if(j.eq.3.and.k.eq.1)then
2971                 fk=0.d0
2972               else
2973                 if(n.eq.2)then
2974                   fk=dble(psevi0(q1,qi,xx/z,min(2,j),k))
2975                 else
2976                   fk=dble(psevi(q1,qi,xx/z,j,k)/qi)
2977                 endif
2978               endif
2979               qt=qi*(1.d0-z)
2980               fq=fq+a1(i1)*fk/psuds(qi,l-1)*pssalf(qt/qcdlam)
2981             enddo
2982             enddo
2983             if(n.eq.2)then
2984               fq=fq*log(qmax/qmin)*(1.d0-xx/z)
2985             elseif(j.eq.1)then
2986               fq=fq*(qmax-qmin)
2987             else
2988               fq=fq*(qmax-qmin)/z
2989             endif
2990             fz1=fz1+a1(i)*fq*psfap(z,k-1,l-1)
2991           enddo
2992         enddo
2993         enddo
2994         if(n.eq.2)then
2995           fz1=fz1*log((zmax1-xx)/(zmin-xx))/4.
2996         elseif(j.eq.1)then
2997           fz1=fz1*log(zmax1/zmin)/4.
2998         else
2999           fz1=fz1*(zmax1-zmin)/4.
3000         endif
3001       endif
3002
3003       if(zmax.gt..1d0)then
3004         zmin1=max(.1d0,zmin)
3005         do i=1,7
3006         do m=1,2
3007           z=1.d0-(1.d0-zmax)*((1.d0-zmin1)/(1.d0-zmax))**
3008      *    (.5+x1(i)*(m-1.5))
3009           qmin=max(q2ini/(1.d0-z),q2ini/(1.d0-xx/z))
3010           qmin=max(qmin,q1)
3011
3012           do k=1,2
3013             fq=0.
3014             do i1=1,7
3015             do m1=1,2
3016               if(n.eq.2)then
3017                 qi=qmin*(qmax/qmin)**(.5+x1(i1)*(m1-1.5))
3018               else
3019                 qi=(.5*(qmax+qmin+(qmax-qmin)*(2.*m1-3.)*x1(i1)))
3020               endif
3021
3022               if(j.eq.3.and.k.eq.1)then
3023                 fk=0.d0
3024               else
3025                 if(n.eq.2)then
3026                   fk=dble(psevi0(q1,qi,xx/z,min(2,j),k))
3027                 else
3028                   fk=dble(psevi(q1,qi,xx/z,j,k)/qi)
3029                 endif
3030               endif
3031               qt=qi*(1.d0-z)
3032               fq=fq+a1(i1)*fk/psuds(qi,l-1)*pssalf(qt/qcdlam)
3033             enddo
3034             enddo
3035             if(n.eq.2)then
3036               fq=fq*log(qmax/qmin)
3037             else
3038               fq=fq*(qmax-qmin)
3039             endif
3040             fz2=fz2+a1(i)*fq*psfap(z,k-1,l-1)*(1.d0/z-1.d0)
3041           enddo
3042         enddo
3043         enddo
3044         fz2=fz2*log((1.d0-zmin1)/(1.d0-zmax))/4.
3045       endif
3046       endif
3047       psev=sngl((fz1+fz2)*psuds(qq,l-1))
3048       return
3049       end
3050
3051 c------------------------------------------------------------------------
3052       function psevi0(q1,qq,xx,m,l)
3053 c------------------------------------------------------------------------
3054       double precision xx,xmax,psuds
3055       dimension wi(3),wj(3),wk(3)
3056       common /psar2/  edmax,epmax
3057       common /psar31/ evk0(21,21,54)
3058       include 'epos.inc'
3059       include 'epos.incsem'
3060
3061       xmax=1.d0-2.d0*q2ini/epmax
3062       qmin=max(1.d0*q2min,q2ini/(1.d0-xx))
3063       qm1=max(q1,qmin)
3064       if(qq.gt..5001*epmax.and.ish.ge.1)then
3065         write(ifch,*)'0-extrap.:q1,qq,epmax,xx,m,l:',q1,qq,epmax,xx,m,l
3066 c        stop
3067       endif
3068       if(xx.ge.xmax.or.qq.le.1.000*qm1)then
3069         psevi0=0.
3070 c        write (*,*)'xx,xmax,qq,qm1,qmin,q1',xx,xmax,qq,qm1,qmin,q1
3071         return
3072       endif
3073
3074       if(m.eq.l)then
3075         psevi0=1.
3076       else
3077         if(xx.lt..1d0)then
3078           yx=log(10.d0*xx)+13.
3079           k=int(yx)
3080           if(k.gt.11)k=11
3081           if(k.lt.1)k=1
3082         elseif(xx.lt..9d0)then
3083           yx=10.*xx+12.
3084           k=int(yx)
3085           if(k.gt.19)k=19
3086         else
3087           yx=log(10.d0*(1.d0-xx))/log(10.d0*(1.d0-xmax))*6.+21
3088           k=int(yx)
3089           if(k.gt.25)k=25
3090         endif
3091         wk(2)=yx-k
3092         wk(3)=wk(2)*(wk(2)-1.)*.5
3093         wk(1)=1.-wk(2)+wk(3)
3094         wk(2)=wk(2)-2.*wk(3)
3095
3096         qli=log(qq/qmin)/log(.5*epmax/qmin)*20.+1.
3097         qlj=log(qm1/qmin)/log(qq/qmin)*20.+1.
3098         i=int(qli)
3099         if(i.gt.19)i=19
3100         if(i.lt.1)i=1
3101         wi(2)=qli-i
3102         wi(3)=wi(2)*(wi(2)-1.)*.5
3103         wi(1)=1.-wi(2)+wi(3)
3104         wi(2)=wi(2)-2.*wi(3)
3105
3106         j=int(qlj)
3107         if(j.lt.1)j=1
3108         if(j.gt.19)j=19
3109         wj(2)=qlj-j
3110         wj(3)=wj(2)*(wj(2)-1.)*.5
3111         wj(1)=1.-wj(2)+wj(3)
3112         wj(2)=wj(2)-2.*wj(3)
3113
3114         psevi0=0.
3115         do i1=1,3
3116         do j1=1,3
3117         do k1=1,3
3118           psevi0=psevi0+evk0(i+i1-1,j+j1-1,k+k1-1+27*(m-1))
3119      *    *wi(i1)*wj(j1)*wk(k1)
3120         enddo
3121         enddo
3122         enddo
3123         psevi0=exp(psevi0)
3124       endif
3125       psevi0=psevi0*psfap(xx,m-1,l-1)*log(log(qq*(1.d0-xx)/qcdlam)
3126      */log(qm1*(1.d0-xx)/qcdlam))*sngl(psuds(qq,m-1)/psuds(q1,m-1))/4.5
3127       return
3128       end
3129
3130 c------------------------------------------------------------------------
3131       function psevi(q1,qq,xx,m,l)
3132 c------------------------------------------------------------------------
3133 c       m l: 1 1 ... gluon -> gluon
3134 c            2 1 ... quark -> gluon
3135 c            1 2 ... gluon -> quark
3136 c            3 2 ... quark -> quark non singlet
3137 c            2 2 ... quark -> quark all
3138 c                             singlet = all - non singlet
3139 c-----------------------------------------------------------------------
3140       double precision xx,xmax,psuds
3141       dimension wi(3),wj(3),wk(3)
3142       common /psar2/  edmax,epmax
3143       common /psar32/ evk(21,21,135)
3144       include 'epos.inc'
3145       include 'epos.incsem'
3146
3147       psevi=0.
3148       xmax=1.d0-2.d0*q2ini/epmax
3149       if(qq.gt..5001*epmax.and.ish.ge.1)then
3150         write(ifch,*)'1-extrap.:q1,qq,epmax,xx,m,l:',q1,qq,epmax,xx,m,l
3151 c        stop
3152       endif
3153       qmin=max(1.d0*q2min,q2ini/(1.d0-xx))
3154       qm1=max(q1,qmin)
3155       if(xx.ge.xmax.or.qq.le.1.0001*qm1)then
3156         return
3157       endif
3158       qmin1=max(1.d0*qmin,q2ini/(1.d0-dsqrt(xx)))
3159       if(qq.le.1.0001*qmin1)then
3160         psevi=psevi0(q1,qq,xx,min(m,2),l)
3161         return
3162       endif
3163
3164       if(xx.lt..1d0)then
3165         yx=log(10.d0*xx)+13.
3166         k=int(yx)
3167         if(k.gt.11)k=11
3168         if(k.lt.1)k=1
3169       elseif(xx.lt..9d0)then
3170         yx=10.*xx+12.
3171         k=int(yx)
3172         if(k.gt.19)k=19
3173       else
3174         yx=log(10.d0*(1.d0-xx))/log(10.d0*(1.d0-xmax))*6.+21
3175         k=int(yx)
3176         if(k.gt.25)k=25
3177       endif
3178       wk(2)=yx-k
3179       wk(3)=wk(2)*(wk(2)-1.)*.5
3180       wk(1)=1.-wk(2)+wk(3)
3181       wk(2)=wk(2)-2.*wk(3)
3182
3183       qli=log(qq/qmin)/log(.5*epmax/qmin)*20.+1.
3184       qlj=log(qm1/qmin)/log(qq/qmin)*20.+1.
3185       i=int(qli)
3186       if(i.lt.1)i=1
3187       if(i.gt.19)i=19
3188       wi(2)=qli-i
3189       wi(3)=wi(2)*(wi(2)-1.)*.5
3190       wi(1)=1.-wi(2)+wi(3)
3191       wi(2)=wi(2)-2.*wi(3)
3192
3193       j=int(qlj)
3194       if(j.lt.1)j=1
3195       if(j.gt.19)j=19
3196       wj(2)=qlj-j
3197       wj(3)=wj(2)*(wj(2)-1.)*.5
3198       wj(1)=1.-wj(2)+wj(3)
3199       wj(2)=wj(2)-2.*wj(3)
3200
3201       do i1=1,3
3202       do j1=1,3
3203       do k1=1,3
3204         if(m.eq.3)then
3205           k2=k+k1-1+108
3206         else
3207           k2=k+k1-1+27*(m-1)+54*(l-1)
3208         endif
3209         psevi=psevi+evk(i+i1-1,j+j1-1,k2)
3210      *  *wi(i1)*wj(j1)*wk(k1)
3211       enddo
3212       enddo
3213       enddo
3214       psevi=exp(psevi)*psfap(xx,m-1,l-1)*log(log(qq*(1.d0-xx)/qcdlam)
3215      */log(qm1*(1.d0-xx)/qcdlam))/4.5
3216       if(q1.lt.qm1)psevi=psevi*sngl(psuds(qm1,m-1)/psuds(q1,m-1))
3217       return
3218       end
3219
3220 c------------------------------------------------------------------------
3221       function psjci(q1,s,l1)
3222 c-----------------------------------------------------------------------
3223 c psjci - inclusive ordered ladder cross-section interpolation for c-quark
3224 c q1 - virtuality cutoff at current end of the ladder
3225 c s - total c.m. energy squared for the ladder,
3226 c l1 - parton type at current end of the ladder (0-g, 1,2,etc.-q)
3227 c-----------------------------------------------------------------------
3228       dimension wi(3),wk(3)
3229       common /psar2/  edmax,epmax
3230       common /psar23/ cschar(20,20,2)
3231       include 'epos.incsem'
3232
3233       psjci=0.
3234       q2mass=qcmass**2
3235       spmin=4.*q2min+q2mass
3236       qq=q1
3237       s2min=4.*qq+q2mass
3238       if(s.le.s2min)return
3239
3240       smins=s2min/(1.-q2ini/q1)
3241 c      if(s.le.smins)goto 1
3242       if(s.le.smins.or.qq.le.q2min)goto 1        !??????? ctp070618
3243
3244       p1=s/(1.+q2mass/s)
3245       if(p1.gt.4.*qq)then
3246         tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
3247       else
3248         tmin=2.*qq
3249       endif
3250       tmax=p1/2.
3251       qmax=p1/4.
3252
3253       l=min(1,iabs(l1))+1
3254       qli=log(qq/q2min)/log(qmax/q2min)*19.+1.
3255       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
3256       k=int(sl)
3257       i=int(qli)
3258       if(i.lt.1)i=1
3259       if(k.gt.18)k=18
3260       if(i.gt.18)i=18
3261
3262       wi(2)=qli-i
3263       wi(3)=wi(2)*(wi(2)-1.)*.5
3264       wi(1)=1.-wi(2)+wi(3)
3265       wi(2)=wi(2)-2.*wi(3)
3266
3267       wk(2)=sl-k
3268       wk(3)=wk(2)*(wk(2)-1.)*.5
3269       wk(1)=1.-wk(2)+wk(3)
3270       wk(2)=wk(2)-2.*wk(3)
3271
3272       do i1=1,3
3273       do k1=1,3
3274         psjci=psjci+cschar(i+i1-1,k+k1-1,l)*wi(i1)*wk(k1)
3275       enddo
3276       enddo
3277       psjci=exp(psjci)*(1./tmin-1./tmax)
3278       return
3279 1     psjci=psbint(q2min,q1,0.,s,4,l1,0)
3280       return
3281       end
3282
3283 c-----------------------------------------------------------------------
3284       function psjct(s,l)
3285 c-----------------------------------------------------------------------
3286 c psjct - unordered ladder cross-section for c-quark
3287 c s - c.m. energy squared for the scattering;
3288 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
3289 c-----------------------------------------------------------------------
3290       double precision xx,zmax,qmax,qmin,qi,zmin,fsj,z,s2,sj
3291       common /ar3/   x1(7),a1(7)
3292       include 'epos.inc'
3293       include 'epos.incsem'
3294
3295       psjct=0.
3296       q2mass=qcmass**2
3297       zmax=dble(s)/(dble(s)+dble(5.*q2mass))
3298       qmax=zmax**2*dble(q2mass)/(1.d0-zmax)
3299       qmin=dble(q2min)
3300
3301       if(qmax.lt.qmin.and.ish.ge.1)write(ifch,*)'psjct:qmin,qmax'
3302      *                                          ,qmin,qmax
3303       do i=1,7
3304       do m=1,2
3305         qi=2.d0*qmin/(1.d0+qmin/qmax+dble((2*m-3)*x1(i))
3306      *              *(1.d0-qmin/qmax))
3307         zmax=(2.d0/(1.d0+dsqrt(1.d0+4.d0*dble(q2mass)/qi)))**delh
3308         zmin=(5.d0*qi/dble(s))**delh
3309
3310         fsj=0.d0
3311         if(zmax.lt.zmin.and.ish.ge.1)write(ifch,*)'psjct:zmin,zmax'
3312      *                                            ,zmin,zmax
3313         do i1=1,7
3314         do m1=1,2
3315           z=(.5d0*(zmax+zmin+dble((2*m1-3)*x1(i1))
3316      *      *(zmax-zmin)))**(1./delh)
3317           s2=z*dble(s)-qi
3318           xx=z
3319           sj=dble(psjti(sngl(qi),q2min,sngl(s2),0,l,0)*psfap(xx,1,0))*z
3320           fsj=fsj+dble(a1(i1))*sj*dble(pssalf(sngl(qi)/qcdlam))/z**delh
3321         enddo
3322         enddo
3323         fsj=fsj*(zmax-zmin)
3324         psjct=psjct+a1(i)*sngl(fsj*qi)
3325       enddo
3326       enddo
3327       psjct=psjct*sngl(1./qmin-1./qmax)/delh/4.
3328       return
3329       end
3330
3331 c------------------------------------------------------------------------
3332       function psjet1(q1,q2,qqcut,s,j,l,jdis)
3333 c-----------------------------------------------------------------------
3334 c psjet1 - ordered parton ladder cross-section
3335 c q1 - virtuality cutoff at current end of the ladder;
3336 c q2 - virtuality cutoff at opposite end of the ladder;
3337 c qqcut - p_t cutoff for the born process;
3338 c s - c.m. energy squared for the scattering;
3339 c j - parton type at current end of the ladder (0 - g, 1,2 etc. - q);
3340 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
3341 c-----------------------------------------------------------------------
3342       double precision xx,z,qq,xmax,xmin,s2min,smin,p1,q2ms,q2inis,xmin1
3343      *,sh,qtmin,t,xmax1,fx1,fx2,psuds
3344       common /ar3/   x1(7),a1(7)
3345       common /ar9/ x9(3),a9(3)
3346       include 'epos.inc'
3347       include 'epos.incsem'
3348
3349       psjet1=0.
3350       if(jdis.eq.0)then
3351         qq=dble(max(q1,q2))
3352       elseif(jdis.eq.1)then
3353         qq=dble(max(q1/4.,q2))
3354       else
3355         qq=dble(max(q1,q2/4.))
3356       endif
3357       qq=max(qq,dble(qqcut))
3358       if(l.ne.3)then
3359         q2mass=0.
3360       else
3361         q2mass=qcmass**2
3362       endif
3363       s2min=dble(q2mass)+4.d0*qq
3364       if(jdis.eq.0.or.jdis.eq.2)then
3365         smin=s2min/(1.d0-dble(q2ini)/qq)
3366       else
3367         smin=s2min/(1.d0-dble(q2ini)/qq/4.d0)
3368       endif
3369       if(dble(s).le.smin)return
3370
3371       q2ms=dble(q2mass)/dble(s)
3372       q2inis=dble(q2ini)/dble(s)
3373       p1=dble(s)/(1.d0+q2ms)
3374
3375
3376       if(jdis.eq.0.or.jdis.eq.2)then
3377         xmax=.5d0*(1.d0+q2ms)+dsqrt(.25d0*(1.d0-q2ms)**2-4.d0*q2inis)
3378       else
3379         xmax=.5d0*(1.+q2ms)+dsqrt(.25d0*(1.-q2ms)**2-q2inis)
3380       endif
3381       xmin=max(1.d0+q2ms-xmax,s2min/dble(s))
3382       if(xmin.ge.xmax.and.ish.ge.1)then
3383         write(ifch,*)'jti1,xmin,xmax',xmin,xmax
3384 c        return
3385       endif
3386
3387       fx1=0.d0
3388       fx2=0.d0
3389       if(xmax.gt..8d0)then
3390         xmin1=max(xmin,.8d0)
3391         do i=1,3
3392         do m=1,2
3393           z=1.d0-(1.d0-xmax)*((1.d0-xmin1)/(1.d0-xmax))**
3394      *    (.5d0+dble(x9(i)*(m-1.5)))
3395           sh=z*dble(s)
3396           xx=z
3397           p1=sh/(1.d0+dble(q2mass)/sh)
3398
3399           if(jdis.eq.0.or.jdis.eq.2)then
3400             qtmin=max(qq,dble(q2ini)/(1.d0-z))
3401           else
3402             qtmin=max(qq,dble(q2ini)/(1.d0-z)/4.d0)
3403           endif
3404           tmin=2.d0*dble(qtmin)/(1.d0+dsqrt(1.d0-4.d0*dble(qtmin)/p1))
3405           tmax=p1/2.d0
3406
3407           ft=0.
3408           if(tmin.ge.tmax.and.ish.ge.1)write(ifch,*)'psjet1:tmin,tmax'
3409      *                                              ,tmin,tmax
3410           do i1=1,3
3411           do m1=1,2
3412             t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
3413      &      *(1.d0-tmin/tmax))
3414             qt=sngl(t*(1.d0-t/p1))
3415 c            if(qt.lt.qtmin)write (*,*)'psjet1:qt,qq',qt,qq
3416
3417             if(jdis.eq.0)then
3418               scale1=qt
3419               scale2=qt
3420             elseif(jdis.eq.1)then
3421               scale1=qt*4.
3422               scale2=qt
3423             elseif(jdis.eq.2)then
3424               scale1=qt
3425               scale2=qt*4.
3426             endif
3427             fb=0.
3428             do n=1,3
3429               fb=fb+psjetj(q1,scale1,sngl(t),xx,sngl(sh),j,l,n)
3430             enddo
3431             ft=ft+a9(i1)*fb*pssalf(qt/qcdlam)**2*sngl(t**2
3432      *      *psuds(scale2,l))
3433           enddo
3434           enddo
3435           fx1=fx1+dble(a9(i)*ft)*(1.d0/tmin-1.d0/tmax)/sh**2*(1.d0-z)
3436         enddo
3437         enddo
3438         fx1=fx1*dlog((1.d0-xmin1)/(1.d0-xmax))
3439       endif
3440
3441       if(xmin.lt..8d0)then
3442         xmax1=min(xmax,.8d0)**(-delh)
3443         xmin1=xmin**(-delh)
3444         do i=1,3
3445         do m=1,2
3446           z=(.5d0*(xmax1+xmin1+(xmin1-xmax1)*dble((2*m-3)*x9(i))))
3447      *    **(-1./delh)
3448           sh=z*dble(s)
3449           xx=z
3450           p1=sh/(1.d0+dble(q2mass)/sh)
3451
3452           if(jdis.eq.0.or.jdis.eq.2)then
3453             qtmin=max(qq,dble(q2ini)/(1.d0-z))
3454           else
3455             qtmin=max(qq,dble(q2ini)/(1.d0-z)/4.d0)
3456           endif
3457           tmin=2.d0*dble(qtmin)/(1.d0+dsqrt(1.d0-4.d0*dble(qtmin)/p1))
3458           tmax=p1/2.d0
3459
3460           ft=0.
3461           if(tmin.ge.tmax.and.ish.ge.1)write(ifch,*)'psjet1:tmin,tmax'
3462      &                                              ,tmin,tmax
3463           do i1=1,3
3464           do m1=1,2
3465             t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
3466      &      *(1.d0-tmin/tmax))
3467             qt=sngl(t*(1.d0-t/p1))
3468           if(qt.lt.sngl(qtmin).and.ish.ge.1)write(ifch,*)'psjet1:qt,qq'
3469      &                                               ,qt,qq
3470
3471             if(jdis.eq.0)then
3472               scale1=qt
3473               scale2=qt
3474             elseif(jdis.eq.1)then
3475               scale1=qt*4.
3476               scale2=qt
3477             elseif(jdis.eq.2)then
3478               scale1=qt
3479               scale2=qt*4.
3480             endif
3481             fb=0.
3482             do n=1,3
3483               fb=fb+psjetj(q1,scale1,sngl(t),xx,sngl(sh),j,l,n)
3484             enddo
3485             ft=ft+a9(i1)*fb*pssalf(qt/qcdlam)**2*sngl(t**2
3486      *      *psuds(scale2,l))
3487           enddo
3488           enddo
3489         fx2=fx2+dble(a9(i)*ft)*(1.d0/tmin-1.d0/tmax)/sh**2*z**(1.+delh)
3490         enddo
3491         enddo
3492         fx2=fx2*(xmin1-xmax1)/dble(delh)
3493       endif
3494       psjet1=sngl((fx1+fx2)/psuds(q2,l))*pi**3*2
3495      *    /2    !CS for parton pair
3496       return
3497       end
3498
3499 c-----------------------------------------------------------------------
3500       function psjet(q1,q2,qqcut,s,j,l,jdis)
3501 c-----------------------------------------------------------------------
3502 c     parton ladder cross-section
3503 c     with at least one emission on each side
3504 c
3505 c q1 - virtuality cutoff at current end of the ladder;
3506 c q2 - virtuality cutoff at opposite end of the ladder;
3507 c qqcut - p_t cutoff for the born process;
3508 c s - c.m. energy squared for the scattering;
3509 c j - parton type at current end of the ladder (0 - g, 1,2 etc. - q);
3510 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
3511 c-----------------------------------------------------------------------
3512       double precision xx1,xx2,qq,s2min,xmin,xmax,xmin1,xmax1,t,tmin
3513      *,tmax,sh,z,qtmin,ft,fx1,fx2
3514       common /ar3/   x1(7),a1(7)
3515       common /ar9/ x9(3),a9(3)
3516       include 'epos.inc'
3517       include 'epos.incsem'
3518       common/ccctest/iiitest
3519       iiitest=0
3520
3521       psjet=0.
3522       if(jdis.eq.0)then
3523         qq=dble(max(q1,q2))
3524       else
3525         qq=dble(max(q1/4.,q2))
3526       endif
3527       qq=max(qq,dble(qqcut))
3528       s2min=4.d0*qq
3529       if(dble(s).le.s2min/(1.d0-dble(q2ini)/qq)**2)return   !kkkkkkk
3530
3531       phi=acos(1.-54.*q2ini/s)/3.
3532       zmax=(1.+2.*cos(phi))**2/9.                 !kkkkkkk
3533       zmin=(1.-cos(phi)+sqrt(3.d0)*sin(phi))/3.   !kkkkkkk
3534       zmin=max(zmin**2,sngl(s2min/dble(s)))
3535       if(zmin.gt.zmax.and.ish.ge.1)write(ifch,*)'psjet:zmin,zmax'
3536      *                                           ,zmin,zmax
3537       zmin=zmin**(-delh)
3538       zmax=zmax**(-delh)
3539       do i=1,3
3540       do m=1,2
3541         z=dble(.5*(zmax+zmin+(zmin-zmax)*(2*m-3)*x9(i)))**(-1./delh)
3542         xmin=dsqrt(z)
3543         sh=z*dble(s)
3544
3545         qtmin=max(qq,dble(q2ini)/(1.d0-dsqrt(z)))
3546         tmin=max(0.d0,1.d0-4.d0*qtmin/sh)
3547         tmin=2.d0*qtmin/(1.d0+dsqrt(tmin))         !kkkkkkk
3548         tmax=sh/2.d0
3549
3550         ft=0.d0
3551 c        if(tmin.gt.tmax)write (*,*)'psjet:tmin,tmax',tmin,tmax
3552         do i1=1,3
3553         do m1=1,2
3554           t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
3555      &    *(1.d0-tmin/tmax))
3556           qt=t*(1.d0-t/sh)
3557 c          if(qt.lt.qtmin)write (*,*)'psjet:qt,qq',qt,qq
3558           xmax=1.d0-q2ini/qt
3559           xmin=max(dsqrt(z),z/xmax)   !xm>xp !!!
3560           if(xmin.gt.xmax.and.ish.ge.1)write(ifch,*)'psjet:xmin,xmax'
3561      *                                              ,xmin,xmax
3562           fx1=0.d0
3563           fx2=0.d0
3564           if(xmax.gt..8d0)then
3565             xmin1=max(xmin,.8d0)
3566             do i2=1,3
3567             do m2=1,2
3568               xx1=1.d0-(1.d0-xmax)*((1.d0-xmin1)/(1.d0-xmax))**
3569      *        dble(.5+x9(i2)*(m2-1.5))
3570               xx2=z/xx1
3571
3572               fb=0.
3573                 fb=fb+psjeti(q1,q2,qt,sngl(t),xx1,xx2,sngl(sh)
3574      *                       ,j,l,jdis)
3575      *          +psjeti(q1,q2,qt,sngl(t),xx2,xx1,sngl(sh)
3576      *                       ,j,l,jdis)
3577               fx1=fx1+dble(a9(i2)*fb)*(1.d0/xx1-1.d0)
3578      *                               *pssalf(qt/qcdlam)**2
3579             enddo
3580             enddo
3581             fx1=fx1*dlog((1.d0-xmin1)/(1.d0-xmax))
3582           endif
3583           if(xmin.lt..8d0)then
3584             xmax1=min(xmax,.8d0)
3585             do i2=1,3
3586             do m2=1,2
3587               xx1=xmin*(xmax1/xmin)**dble(.5+x9(i2)*(m2-1.5))
3588               xx2=z/xx1
3589
3590               fb=0.
3591                 fb=fb+psjeti(q1,q2,qt,sngl(t),xx1,xx2,sngl(sh)
3592      *                       ,j,l,jdis)
3593      *          +psjeti(q1,q2,qt,sngl(t),xx2,xx1,sngl(sh)
3594      *                       ,j,l,jdis)
3595               fx2=fx2+dble(a9(i2))*fb*pssalf(qt/qcdlam)**2
3596             enddo
3597             enddo
3598             fx2=fx2*dlog(xmax1/xmin)
3599           endif
3600           ft=ft+dble(a9(i1))*(fx1+fx2)*t**2
3601         enddo
3602         enddo
3603         ft=ft*(1.d0/tmin-1.d0/tmax)
3604         psjet=psjet+a9(i)*sngl(ft*z**(1.+delh)/sh**2)
3605       enddo
3606       enddo
3607       psjet=psjet*(zmin-zmax)/delh*pi**3
3608      *         /2.    !CS for parton pair
3609       return
3610       end
3611
3612 c-----------------------------------------------------------------------
3613       function pijet(ii,qi,qq,sk,m1,l1) !polynomial interpol of jet CS
3614 c-----------------------------------------------------------------------
3615 c  ii ..... type of CS (2 = bothside, 1 = oneside, 0 = no emission, Born)
3616 c  qi ..... virtuality cutoff at current end of the ladder
3617 c  qq ..... virtuality cutoff of Born
3618 c  sk ..... energy squared for the scattering
3619 c  m1,l1 .. parton types
3620 c-----------------------------------------------------------------------
3621       include 'epos.incsem'
3622       common/psar2/edmax,epmax
3623       common/tabcsjet/ksmax,iqmax,jqmax,csjet(0:2,2,20,20,20,3,2)
3624       real wi(3),wj(3),wk(3)
3625       common/cpijet/npijet
3626       data npijet/0/
3627       npijet=npijet+1
3628       if(npijet.eq.1)call MakeCSTable
3629
3630       if(m1.ne.0.and.m1.eq.l1)then
3631         m=2
3632         l=2
3633       elseif(m1.ne.0.and.m1.eq.-l1)then
3634         m=3
3635         l=1
3636       elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
3637         m=3
3638         l=2
3639       else
3640         m=min(1,iabs(m1))+1
3641         l=min(1,iabs(l1))+1
3642       endif
3643
3644       qqmin=min(qi,qq)
3645       qmax=sk/4.
3646       spmin=4.*q2min
3647       spmed=spmin*(epmax/2./spmin)**(1./(ksmax-1.))
3648       if(sk.le.spmed)then
3649         kk=2
3650         spmax=spmed
3651       else
3652         kk=1
3653         spmax=epmax/2.
3654       endif
3655
3656       qli=1.+log(qi/q2min)/log(qmax/q2min)*(iqmax-1)
3657       qlj=1.+log(qq/qqmin)/log(qmax/qqmin)*(jqmax-1)
3658       sl= 1.+log(sk/spmin)/log(spmax/spmin)*(ksmax-1)
3659       k=int(sl)
3660       i=int(qli)
3661       j=int(qlj)
3662       if(k.lt.1)k=1
3663       if(j.lt.1)j=1
3664       if(i.lt.1)i=1
3665       if(k.gt.(ksmax-2))k=ksmax-2
3666       if(i.gt.(iqmax-2))i=iqmax-2
3667       if(j.gt.(jqmax-2))j=jqmax-2
3668
3669       wi(2)=qli-i
3670       wi(3)=wi(2)*(wi(2)-1.)*.5
3671       wi(1)=1.-wi(2)+wi(3)
3672       wi(2)=wi(2)-2.*wi(3)
3673
3674       wj(2)=qlj-j
3675       wj(3)=wj(2)*(wj(2)-1.)*.5
3676       wj(1)=1.-wj(2)+wj(3)
3677       wj(2)=wj(2)-2.*wj(3)
3678
3679       wk(2)=sl-k
3680       wk(3)=wk(2)*(wk(2)-1.)*.5
3681       wk(1)=1.-wk(2)+wk(3)
3682       wk(2)=wk(2)-2.*wk(3)
3683
3684       pijet=0
3685       do i1=1,3
3686       do j1=1,3
3687       do k1=1,3
3688         pijet=pijet+csjet(ii,kk,k+k1-1,i+i1-1,j+j1-1,m,l)
3689      *  *wi(i1)*wj(j1)*wk(k1)
3690       enddo
3691       enddo
3692       enddo
3693           ! if(ii.eq.2)print*,' '
3694           ! write(*,'(i2,f6.0,i2,3x,3(2f5.2,2x),f5.2)')
3695           !*  ii,sk,k,(wk(kk1),csjet(ii,kk,k+kk1-1,1,1,m,l),kk1=1,3) ,pijet
3696       end
3697
3698 c-----------------------------------------------------------------------
3699       subroutine MakeCSTable     !tabulates psjet
3700 c-----------------------------------------------------------------------
3701 c   last two indices of table: parton types
3702 c        1 1 ... gg
3703 c        1 2 ... gq
3704 c        2 1 ... qg
3705 c        2 2 ... qq
3706 c        3 1 ... qa
3707 c        3 2 ... qq'
3708 c-----------------------------------------------------------------------
3709       include 'epos.incsem'
3710       common/psar2/edmax,epmax
3711       common/tabcsjet/ksmax,iqmax,jqmax,csjet(0:2,2,20,20,20,3,2)
3712       write (*,'(a,$)')'(CS table'
3713       ksmax=10
3714       iqmax=3
3715       jqmax=3
3716       spmin=4.*q2min
3717       do kk=1,2
3718        if(kk.eq.1)spmax=epmax/2.
3719        if(kk.eq.2)spmax=spmin*(epmax/2./spmin)**(1./(ksmax-1.))
3720        do m=1,3              !parton type at upper end of the ladder
3721         write (*,'(a,$)')'.'
3722          do l=1,2              !parton type at lower end of the ladder
3723          m1=m-1
3724          l1=l-1
3725          if(m.eq.3.and.l.eq.1)l1=-m1
3726         do k=1,ksmax
3727           sk=spmin*(spmax/spmin)**((k-1.)/(ksmax-1.))
3728           qmax=sk/4.
3729           do i=1,iqmax
3730            qi=q2min*(qmax/q2min)**((i-1.)/(iqmax-1.))
3731            do j=1,jqmax
3732             qq=qi*(qmax/qi)**((j-1.)/(jqmax-1.))
3733                 !write(*,'(i3,4f8.3,2i4,$)')j, qi,q2min,qq,sk,m1,l1
3734             csjet(2,kk,k,i,j,m,l)= psjet(qi,q2min,qq,sk,m1,l1,0)
3735             csjet(1,kk,k,i,j,m,l)=psjet1(qi,q2min,qq,sk,m1,l1,0)
3736             csjet(0,kk,k,i,j,m,l)=psborn(qi,q2min,qq,sk,m1,l1,0,1)
3737        !   if(i.eq.1.and.j.eq.1.and.m.eq.1.and.l.eq.1)
3738        ! *write(*,'(2f8.2,f13.2,2i3,3x,i3,3f8.3)')
3739        ! * qi,qq,sk,m1,l1,k,csjet(2,kk,k,i,j,m,l)
3740        ! *             ,csjet(1,kk,k,i,j,m,l),csjet(0,kk,k,i,j,m,l)
3741            enddo
3742           enddo
3743          enddo
3744         enddo
3745        enddo
3746       enddo
3747       write (*,'(a,$)')'done)'
3748       end
3749
3750 c-----------------------------------------------------------------------
3751       function psjeti(q1,q2,qt,t,xx1,xx2,s,j,l,jdis)
3752 c-----------------------------------------------------------------------
3753 c
3754 c      E~qcd_ji * E~qcd_lk * B_ik
3755 c
3756 c        B_ik = psbori = contribution to Born xsection:
3757 c                         dsigmaBorn/d2pt/dy
3758 c                         = s/pi * delta(s+t+u) * 2*pi*alpha**2 /s**2 * B_ik
3759 c
3760 c        E~qcd: at least one emission
3761 c
3762 c q1  - virtuality cutoff at current end of the ladder
3763 c q2  - virtuality cutoff at opposite end of the ladder
3764 c xx1 - feinman x for the first parton for the born process
3765 c xx2 - feinman x for the second parton for the born process
3766 c s   - c.m. energy squared for the born scattering
3767 c t   - invariant variable for the scattering |(p1-p3)**2|,
3768 c j   - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
3769 c l   - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
3770 c-----------------------------------------------------------------------
3771 c reminder
3772 c     psevi: 1 1 ... gluon -> gluon
3773 c            2 1 ... quark -> gluon
3774 c            1 2 ... gluon -> quark
3775 c            3 2 ... quark -> quark non singlet
3776 c            2 2 ... quark -> quark all
3777 c                          singlet = all - non singlet
3778 c-----------------------------------------------------------------------
3779       double precision xx1,xx2
3780       include 'epos.incsem'
3781       common/ccctest/iiitest
3782
3783       if(jdis.eq.0)then
3784         scale=qt
3785       else
3786         scale=qt*4.
3787       endif
3788       if(j.eq.0.and.l.eq.0)then  ! gluon-gluon --->
3789         akg1=psevi(q1,scale,xx1,1,1)                  !gluon contribution
3790         akg2=psevi(q2,qt,xx2,1,1)                  !gluon contribution
3791         aks1=psevi(q1,scale,xx1,1,2)/naflav/2.  !singlet contribution per quark
3792         aks2=psevi(q2,qt,xx2,1,2)/naflav/2.  !singlet contribution per quark
3793         psjeti=ffborn(s,t,akg1*akg2
3794      *              ,(akg1*aks2+aks1*akg2)*naflav*2.    !ccccc
3795      *               ,aks1*aks2*naflav*2.
3796      *               ,aks1*aks2*naflav*2.
3797      *               ,aks1*aks2*naflav*2.*(naflav-1)*2.
3798      *)
3799       elseif(j.eq.0)then     !  gluon-quark --->
3800         akg1=psevi(q1,scale,xx1,1,1)                  !gluon contribution
3801         akg2=psevi(q2,qt,xx2,2,1)                  !gluon contribution
3802         aks1=psevi(q1,scale,xx1,1,2)/naflav/2.         !singlet contribution
3803         akns2=psevi(q2,qt,xx2,3,2)                 !nonsinglet contribution
3804         aks2=(psevi(q2,qt,xx2,2,2)-akns2)/naflav/2. !singlet contribution
3805         psjeti=ffborn(s,t,akg1*akg2
3806      *              ,(akg1*(akns2+aks2*naflav*2.)+aks1*akg2*naflav*2.)
3807      *              ,aks1*(akns2+aks2*naflav*2.)
3808      *              ,aks1*(akns2+aks2*naflav*2.)
3809      *              ,aks1*(akns2+aks2*naflav*2.)*(naflav-1)*2.)
3810       elseif(l.eq.0)then   ! quark-gluon --->
3811         akg1=psevi(q1,scale,xx1,2,1)                  !gluon contribution
3812         akg2=psevi(q2,qt,xx2,1,1)                  !gluon contribution
3813         akns1=psevi(q1,scale,xx1,3,2)                 !nonsinglet contribution
3814         aks1=(psevi(q1,scale,xx1,2,2)-akns1)/naflav/2. !singlet contribution
3815         aks2=psevi(q2,qt,xx2,1,2)/naflav/2.         !singlet contribution
3816         psjeti=ffborn(s,t,akg1*akg2
3817      *             ,(akg2*(akns1+aks1*naflav*2.)+aks2*akg1*naflav*2.)
3818      *             ,aks2*(akns1+aks1*naflav*2.)
3819      *             ,aks2*(akns1+aks1*naflav*2.)
3820      *             ,aks2*(akns1+aks1*naflav*2.)*(naflav-1)*2.)
3821       else     !  quark-quark --->
3822         akg1=psevi(q1,scale,xx1,2,1)                  !gluon contribution
3823         akg2=psevi(q2,qt,xx2,2,1)                  !gluon contribution
3824         akns1=psevi(q1,scale,xx1,3,2)                 !nonsinglet contribution
3825         aks1=(psevi(q1,scale,xx1,2,2)-akns1)/naflav/2.!singlet contribution
3826         akns2=psevi(q2,qt,xx2,3,2)                 !nonsinglet contribution
3827         aks2=(psevi(q2,qt,xx2,2,2)-akns2)/naflav/2.!singlet contribution
3828
3829         if(j.eq.l)then
3830          psjeti=ffborn(s,t,akg1*akg2
3831      *     ,(akg2*(akns1+aks1*naflav*2.)+akg1*(akns2+aks2*naflav*2.))
3832      *     ,((akns1+aks1)*(akns2+aks2)+aks1*aks2*(2.*naflav-1.))
3833      *     ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
3834      *     ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)*(naflav-1)*2.)
3835         elseif(j.eq.-l)then
3836          psjeti=ffborn(s,t,akg1*akg2
3837      *     ,(akg2*(akns1+aks1*naflav*2.)+akg1*(akns2+aks2*naflav*2.))
3838      *     ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
3839      *     ,((akns1+aks1)*(akns2+aks2)+aks1*aks2*(2.*naflav-1.))
3840      *     ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)*(naflav-1)*2.)
3841         else                           !j.ne.l,-l
3842          psjeti=ffborn(s,t,akg1*akg2
3843      *    ,(akg2*(akns1+aks1*naflav*2.)+akg1*(akns2+aks2*naflav*2.))
3844      *    ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
3845      *    ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
3846      *    ,(akns1*akns2+akns1*aks2*(naflav-1)*2.
3847      *    +akns2*aks1*(naflav-1)*2.+aks1*aks2*naflav*2.*(naflav-1)*2.))
3848         endif
3849       endif
3850       return
3851       end
3852
3853 c-----------------------------------------------------------------------
3854       function psjetj(q1,scale,t,xx,s,j,l,n)
3855 c-----------------------------------------------------------------------
3856 c psjetj - integrand for the ordered ladder cross-section
3857 c q1 - virtuality cutoff at current end of the ladder,
3858 c scale - born process scale,
3859 c t  - invariant variable for the scattering |(p1-p3)**2|,
3860 c xx - feinman x for the first parton for the born process
3861 c s  - c.m. energy squared for the born scattering,
3862 c j  - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
3863 c l  - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
3864 c n  - subprocess number
3865 c-----------------------------------------------------------------------
3866       double precision xx
3867       include 'epos.incsem'
3868
3869       m=min(1,iabs(j))+1
3870       if(l.ne.3)then
3871         if(l.eq.0)then
3872           psjetj=psevi(q1,scale,xx,m,1)*(psbori(s,t,0,0,n)+               !gg
3873      *    psbori(s,s-t,0,0,n))/2.
3874      *    +psevi(q1,scale,xx,m,2)*(psbori(s,t,1,0,n)+                     !qg
3875      *    psbori(s,s-t,1,0,n))
3876         elseif(j.eq.0)then
3877           aks=psevi(q1,scale,xx,1,2)/naflav/2.  !singlet contribution per quark
3878           psjetj=psevi(q1,scale,xx,1,1)*(psbori(s,t,0,1,n)+               !gq
3879      *    psbori(s,s-t,0,1,n))
3880      *    +aks*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2.             !qq
3881      *    +aks*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n))              !qq~
3882      *    +aks*(psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))*(naflav-1)*2.   !qq'
3883         else
3884           akg=psevi(q1,scale,xx,2,1)                  !gluon contribution
3885           akns=psevi(q1,scale,xx,3,2)                 !nonsinglet contribution
3886           aks=(psevi(q1,scale,xx,2,2)-akns)/naflav/2.  !singlet contribution
3887           if(j.eq.l)then
3888             psjetj=akg*(psbori(s,t,0,1,n)+psbori(s,s-t,0,1,n))        !gq
3889      *      +(akns+aks)*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2.    !qq
3890      *      +aks*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n))            !qq~
3891      *      +aks*(psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))*(naflav-1)*2. !qq'
3892           elseif(j.eq.-l)then
3893             psjetj=akg*(psbori(s,t,0,1,n)+psbori(s,s-t,0,1,n))        !gq
3894      *      +aks*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2.           !qq
3895      *      +(akns+aks)*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n))     !qq~
3896      *      +aks*(psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))*(naflav-1)*2.!qq'
3897           else
3898             psjetj=akg*(psbori(s,t,0,1,n)+psbori(s,s-t,0,1,n))        !gq
3899      *      +aks*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2.           !qq
3900      *      +aks*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n))            !qq~
3901      *      +(akns+aks*(naflav-1)*2.)*
3902      *      (psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))                   !qq'
3903           endif
3904         endif
3905       elseif(n.eq.1)then
3906         p1=s/(1.+qcmass**2/s)
3907         psjetj=psevi(q1,scale,xx,m,1)*(psbori(s,t,4,0,n)+                 !cg
3908      *  psbori(s,p1-t,4,0,n))
3909      *  +psevi(q1,scale,xx,m,2)*(psbori(s,t,4,1,n)+                       !cq
3910      *  psbori(s,p1-t,4,1,n))
3911       else
3912         psjetj=0.
3913       endif
3914       return
3915       end
3916
3917 c------------------------------------------------------------------------
3918       function psjti(q1,qqcut,s,m1,l1,jdis)
3919 c-----------------------------------------------------------------------
3920 c psjti - inclusive hard cross-section interpolation - for any ordering
3921 c in the ladder
3922 c q1 - virtuality cutoff at current end of the ladder
3923 c qqcut - p_t cutoff for the born process;
3924 c s  - total c.m. energy squared for the ladder
3925 c m1 - parton type at current end of the ladder (0-g, 1,2,etc.-q)
3926 c l1 - parton type at opposite end of the ladder (0-g, 1,2,etc.-q)
3927 c-----------------------------------------------------------------------
3928       dimension wi(3),wj(3),wk(3)
3929       common /psar2/  edmax,epmax
3930       common /psar19/ cstot(20,20,240)
3931       include 'epos.incsem'
3932
3933       psjti=0.
3934 c      jdis1=jdis
3935       if(jdis.eq.0)then
3936         qqmin=q1
3937         qmax=s/4.
3938       else
3939         qqmin=max(q2min,q1/4.)
3940         qmax=s
3941       endif
3942       qq=max(qqmin,qqcut)
3943       spmin=4.*q2min
3944       s2min=4.*qq
3945       if(s.le.s2min)return
3946
3947       if(jdis.eq.0)then
3948         smins=s2min/(1.-q2ini/qq)
3949       else
3950         smins=s2min/(1.-q2ini/qq/4.)
3951       endif
3952       if(s.le.smins)goto 1
3953
3954       if(s.gt.4.*qq)then
3955         tmin=2.*qq/(1.+sqrt(1.-4.*qq/s))
3956       else
3957         tmin=2.*qq
3958       endif
3959       tmax=s/2.
3960
3961       if(m1.ne.0.and.m1.eq.l1)then
3962         m=2
3963         l=2
3964       elseif(m1.ne.0.and.m1.eq.-l1)then
3965         m=3
3966         l=1
3967       elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
3968         m=3
3969         l=2
3970       else
3971         m=min(1,iabs(m1))+1
3972         l=min(1,iabs(l1))+1
3973       endif
3974
3975       ml=20*(m-1)+60*(l-1)+120*jdis
3976       qli=log(q1/q2min)/log(qmax/q2min)*19.+1.
3977       qlj=log(qq/qqmin)/log(s/4./qqmin)*19.+1.
3978       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
3979       k=int(sl)
3980       i=int(qli)
3981       j=int(qlj)
3982       if(j.lt.1)j=1
3983       if(i.lt.1)i=1
3984       if(k.gt.18)k=18
3985       if(i.gt.18)i=18
3986       if(j.gt.18)j=18
3987
3988       wi(2)=qli-i
3989       wi(3)=wi(2)*(wi(2)-1.)*.5
3990       wi(1)=1.-wi(2)+wi(3)
3991       wi(2)=wi(2)-2.*wi(3)
3992
3993       wj(2)=qlj-j
3994       wj(3)=wj(2)*(wj(2)-1.)*.5
3995       wj(1)=1.-wj(2)+wj(3)
3996       wj(2)=wj(2)-2.*wj(3)
3997
3998       wk(2)=sl-k
3999       wk(3)=wk(2)*(wk(2)-1.)*.5
4000       wk(1)=1.-wk(2)+wk(3)
4001       wk(2)=wk(2)-2.*wk(3)
4002
4003       do i1=1,3
4004       do j1=1,3
4005       do k1=1,3
4006         psjti=psjti+cstot(i+i1-1,j+j1-1,k+k1+ml-1)
4007      *  *wi(i1)*wj(j1)*wk(k1)
4008       enddo
4009       enddo
4010       enddo
4011       psjti=exp(psjti)*(1./tmin-1./tmax)
4012       return
4013 1     continue
4014       psjti=psbint(q1,q2min,qqcut,s,m1,l1,jdis)
4015       return
4016       end
4017
4018 c------------------------------------------------------------------------
4019       subroutine psjti0(ss,sj,sjb,m1,l1)
4020 c-----------------------------------------------------------------------
4021 c psjti0 - inclusive hard cross-section interpolation -
4022 c for minimal virtuality cutoff in the ladder
4023 c s - total c.m. energy squared for the ladder,
4024 c sj - inclusive jet cross-section,
4025 c sjb - born cross-section,
4026 c m1 - parton type at current end of the ladder (0-g, 1,2,etc.-q)
4027 c l1 - parton type at opposite end of the ladder (0-g, 1,2,etc.-q)
4028 c-----------------------------------------------------------------------
4029       dimension wk(3)
4030       common /psar2/  edmax,epmax
4031       common /psar22/ cstotzero(20,4,2),csborzer(20,4,2)
4032       include 'epos.incsem'
4033
4034       sj=0.
4035       sjb=0.
4036       if(iabs(m1).ne.4)then
4037         q2mass=0.
4038         if(m1.ne.0.and.m1.eq.l1)then
4039           m=2
4040           l=2
4041         elseif(m1.ne.0.and.m1.eq.-l1)then
4042           m=3
4043           l=1
4044         elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4045           m=3
4046           l=2
4047         else
4048           m=min(1,iabs(m1))+1
4049           l=min(1,iabs(l1))+1
4050         endif
4051       else
4052         q2mass=qcmass**2
4053         m=4
4054         l=min(1,iabs(l1))+1
4055       endif
4056       s=ss-q2mass
4057       qq=q2min
4058       spmin=4.*qq+q2mass
4059       if(s.le.spmin)return
4060
4061       p1=s/(1.+q2mass/s)
4062       if(p1.gt.4.*qq)then
4063         tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
4064       else
4065         tmin=2.*qq
4066       endif
4067       tmax=.5*p1
4068
4069       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
4070       k=int(sl)
4071       if(k.gt.18)k=18
4072       wk(2)=sl-k
4073       wk(3)=wk(2)*(wk(2)-1.)*.5
4074       wk(1)=1.-wk(2)+wk(3)
4075       wk(2)=wk(2)-2.*wk(3)
4076
4077       do k1=1,3
4078         sj=sj+cstotzero(k+k1-1,m,l)*wk(k1)
4079         sjb=sjb+csborzer(k+k1-1,m,l)*wk(k1)
4080       enddo
4081
4082       sjb=exp(sjb)*(1./tmin-1./tmax)
4083       sj=max(sjb,exp(sj)*(1./tmin-1./tmax))
4084       return
4085       end
4086
4087 c------------------------------------------------------------------------
4088       function psjti1(q1,q2,qqcut,s,m1,l1,jdis)
4089 c-----------------------------------------------------------------------
4090 c psjti1 - inclusive hard cross-section interpolation - for strict order
4091 c in the ladder
4092 c q1 - virtuality cutoff at current end of the ladder
4093 c q2 - virtuality cutoff at opposite end of the ladder
4094 c qqcut - p_t cutoff for the born process;
4095 c s - total c.m. energy squared for the ladder,
4096 c m1 - parton type at current end of the ladder (0-g, 1,2,etc.-q)
4097 c l1 - parton type at opposite end of the ladder (0-g, 1,2,etc.-q)
4098 c-----------------------------------------------------------------------
4099       dimension wi(3),wj(3),wk(3)
4100       common /psar2/  edmax,epmax
4101       common /psar20/ csord(20,20,240)
4102       include 'epos.incsem'
4103       double precision psuds
4104
4105       psjti1=0.
4106       if(jdis.eq.0)then
4107         qqmin=max(q1,q2)
4108       else
4109         qqmin=max(q1,q2/4.)
4110       endif
4111       qq=max(qqmin,qqcut)
4112       spmin=4.*q2min
4113       s2min=4.*qq
4114       if(s.le.s2min)return
4115
4116       smins=s2min/(1.-q2ini/qq)
4117       if(s.le.smins)goto 1
4118
4119       if(s.gt.4.*qq)then
4120         tmin=2.*qq/(1.+sqrt(1.-4.*qq/s))
4121       else
4122         tmin=2.*qq
4123       endif
4124       tmax=s/2.
4125
4126       if(m1.ne.0.and.m1.eq.l1)then
4127         m=2
4128         l=2
4129       elseif(m1.ne.0.and.m1.eq.-l1)then
4130         m=3
4131         l=1
4132       elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4133         m=3
4134         l=2
4135       else
4136         m=min(1,iabs(m1))+1
4137         l=min(1,iabs(l1))+1
4138       endif
4139
4140       ml=20*(m-1)+60*(l-1)+120*jdis
4141       qli=log(q1/q2min)/log(s/4./q2min)*19.+1.
4142       qlj=log(qq/qqmin)/log(s/4./qqmin)*19.+1.
4143       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
4144       k=int(sl)
4145       i=int(qli)
4146       j=int(qlj)
4147       if(j.lt.1)j=1
4148       if(i.lt.1)i=1
4149       if(k.gt.18)k=18
4150       if(i.gt.18)i=18
4151       if(j.gt.18)j=18
4152
4153       wi(2)=qli-i
4154       wi(3)=wi(2)*(wi(2)-1.)*.5
4155       wi(1)=1.-wi(2)+wi(3)
4156       wi(2)=wi(2)-2.*wi(3)
4157
4158       wj(2)=qlj-j
4159       wj(3)=wj(2)*(wj(2)-1.)*.5
4160       wj(1)=1.-wj(2)+wj(3)
4161       wj(2)=wj(2)-2.*wj(3)
4162
4163       wk(2)=sl-k
4164       wk(3)=wk(2)*(wk(2)-1.)*.5
4165       wk(1)=1.-wk(2)+wk(3)
4166       wk(2)=wk(2)-2.*wk(3)
4167
4168       do i1=1,3
4169       do j1=1,3
4170       do k1=1,3
4171         k2=k+k1+ml-1
4172         psjti1=psjti1+csord(i+i1-1,j+j1-1,k2)
4173      *  *wi(i1)*wj(j1)*wk(k1)
4174       enddo
4175       enddo
4176       enddo
4177       psjti1=exp(psjti1)*(1./tmin-1./tmax)
4178
4179       if(jdis.eq.0.and.qq.gt.q2)then
4180         psjti1=psjti1*sngl(psuds(qq,l1)/psuds(q2,l1))
4181       elseif(jdis.eq.1.and.4.*qq.gt.q2)then
4182         psjti1=psjti1*sngl(psuds(4.*qq,l1)/psuds(q2,l1))
4183       endif
4184       return
4185 1     continue
4186       if(jdis.eq.0)then
4187         psjti1=psbint(q1,q2,qqcut,s,m1,l1,0)
4188       else
4189         psjti1=psbint(q2,q1,qqcut,s,l1,m1,1)
4190       endif
4191       return
4192       end
4193
4194 c------------------------------------------------------------------------
4195       function pspdfg(xx,qqs,qq,iclpro0,j)
4196 c-----------------------------------------------------------------------
4197 c pspdf - parton distribution function
4198 c qq  - virtuality scale
4199 c qqs - initial virtuality for the input distributions
4200 c iclpro0 - hadron class
4201 c j   - parton type
4202 c-----------------------------------------------------------------------
4203       double precision z
4204       common/ar3/    x1(7),a1(7)
4205       include 'epos.incsem'
4206       double precision psuds
4207
4208       pspdfg=psdfh4(xx,qqs,0.,iclpro0,j)
4209       if(j.gt.0)pspdfg=pspdfg+psdfh4(xx,qqs,0.,iclpro0,-j)  !+sea contr.
4210       pspdfg=pspdfg*sngl(psuds(qq,j)/psuds(qqs,j))
4211
4212       xmin=xx/(1.-q2ini/qq)
4213       if(xmin.ge.1.)return
4214
4215       dpd1=0.
4216       dpd2=0.
4217       xm=max(xmin,.3)
4218       do i=1,7         !numerical integration over zx
4219       do m=1,2
4220         zx=1.-(1.-xm)*(.5+(m-1.5)*x1(i))**.25
4221         z=xx/zx
4222
4223         if(j.eq.0)then
4224           aks=psevi(qqs,qq,z,2,1)                  !quark contribution
4225           akg=psevi(qqs,qq,z,1,1)                  !gluon contribution
4226           akns=0.
4227         else
4228           akg=psevi(qqs,qq,z,1,2)/naflav/2.         !gluon contribution
4229           akns=psevi(qqs,qq,z,3,2)            !nonsinglet contribution
4230           aks=(psevi(qqs,qq,z,2,2)-akns)/naflav/2.  !quark contribution
4231         endif
4232
4233         fz=akg*psdfh4(zx,qqs,0.,iclpro0,0)
4234      *  +akns*psdfh4(zx,qqs,0.,iclpro0,j)
4235      *  +aks*(psdfh4(zx,qqs,0.,iclpro0,1)+
4236      *  2.*psdfh4(zx,qqs,0.,iclpro0,-1)
4237      *  +psdfh4(zx,qqs,0.,iclpro0,2)+2.*psdfh4(zx,qqs,0.,iclpro0,-2)
4238      *  +2.*psdfh4(zx,qqs,0.,iclpro0,-3))
4239         if(j.gt.0)fz=fz+akns*psdfh4(zx,qqs,0.,iclpro0,-j)
4240
4241         dpd1=dpd1+a1(i)*fz/zx**2/(1.-zx)**3
4242       enddo
4243       enddo
4244       dpd1=dpd1*(1.-xm)**4/8.*xx
4245
4246       if(xm.gt.xmin)then
4247         do i=1,7         !numerical integration
4248         do m=1,2
4249           zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))**(.5-(m-1.5)*x1(i))
4250           z=xx/zx
4251
4252           if(j.eq.0)then
4253             aks=psevi(qqs,qq,z,2,1)                  !quark contribution
4254             akg=psevi(qqs,qq,z,1,1)                  !gluon contribution
4255             akns=0.
4256           else
4257             akg=psevi(qqs,qq,z,1,2)/naflav/2.         !gluon contribution
4258             akns=psevi(qqs,qq,z,3,2)            !nonsinglet contribution
4259             aks=(psevi(qqs,qq,z,2,2)-akns)/naflav/2.  !quark contribution
4260           endif
4261
4262           fz=akg*psdfh4(zx,qqs,0.,iclpro0,0)
4263      *    +akns*psdfh4(zx,qqs,0.,iclpro0,j)
4264      *    +aks*(psdfh4(zx,qqs,0.,iclpro0,1)
4265      *    +2.*psdfh4(zx,qqs,0.,iclpro0,-1)
4266      *    +psdfh4(zx,qqs,0.,iclpro0,2)+2.*psdfh4(zx,qqs,0.,iclpro0,-2)
4267      *    +2.*psdfh4(zx,qqs,0.,iclpro0,-3))
4268           if(j.gt.0)fz=fz+akns*psdfh4(zx,qqs,0.,iclpro0,-j)
4269
4270           dpd2=dpd2+a1(i)*fz*(1.-xx/zx)/zx
4271         enddo
4272         enddo
4273         dpd2=dpd2*log((xm-xx)/(xmin-xx))*.5*xx
4274       endif
4275       pspdfg=pspdfg+dpd2+dpd1
4276       return
4277       end
4278
4279 c-----------------------------------------------------------------------
4280       subroutine psaevp
4281 c-----------------------------------------------------------------------
4282       include 'epos.inc'
4283       include 'epos.incsem'
4284       qq=xpar1
4285       jmod=nint(xpar2)
4286       iologb=1
4287
4288       if(jmod.eq.0)then            !??????????????ttttttt
4289       write(*,*)"no more triple Pomeron, xpar2=0 in psaevp not accepted"
4290       write(*,*)"use xpar2=1 instead"
4291       jmod=1
4292       endif
4293
4294       do i=1,nrbins
4295         if(iologb.eq.0)then
4296           xx=xminim+(xmaxim-xminim)*(i-.5)/nrbins
4297         else
4298           xx=xminim*(xmaxim/xminim)**((i-.5)/nrbins)
4299         endif
4300         ar(i,1)=xx
4301         ar(i,2)=0.
4302         if(jmod.eq.0)then            !evolution+matrix element +3P (ours)
4303           ww=qq/xx
4304           ar(i,3)=(psdh(ww,qq,2,0)+psdh(ww,qq,2,1)+
4305      *    psdsh1(ww,qq,2,dqsh,0)+psdsh1(ww,qq,2,dqsh,1)
4306      *    )/(4.*pi**2*alfe)*qq
4307         elseif(jmod.eq.1)then        !evolution+matrix element (ours)
4308           ww=qq/xx
4309           ar(i,3)=(psdh(ww,qq,2,0)+psdh(ww,qq,2,1)+
4310      *    psdsh(ww,qq,2,dqsh,0)+psdsh(ww,qq,2,dqsh,1)
4311      *    )/(4.*pi**2*alfe)*qq
4312         elseif(jmod.eq.2)then    !just evolution (grv)
4313           ar(i,3)=(pspdfg(xx,q2min,qq,2,1)/2.25+
4314      *    pspdfg(xx,q2min,qq,2,2)/9.+
4315      *    pspdfg(xx,q2min,qq,2,-1)*2./3.6+
4316      *    pspdfg(xx,q2min,qq,2,-3)*2./9.)
4317           if(naflav.eq.4)ar(i,3)=ar(i,3)+pspdfg(xx,q2min,qq,2,-4)
4318      *    *2./2.25
4319         elseif(jmod.eq.3)then    !grv
4320           ar(i,3)=(psdfh4(xx,qq,0.,2,1)+2.*psdfh4(xx,qq,0.,2,-1))/2.25
4321      *    +(psdfh4(xx,qq,0.,2,2)+2.*psdfh4(xx,qq,0.,2,-2))/9.
4322      *    +2.*psdfh4(xx,qq,0.,2,-3)/9.  !
4323         elseif(jmod.eq.4)then         !just evolution (ours)
4324           ar(i,3)=(fparton(xx,qq,1)/2.25+fparton(xx,qq,2)/9.+
4325      *    fparton(xx,qq,-1)*6./4.5)                     !uv+dv+6*sea
4326           if(naflav.eq.4)ar(i,3)=ar(i,3)+fparton(xx,qq,-4)*2./2.25
4327         elseif(jmod.eq.5)then         !grv+res
4328           ww=qq/xx
4329           ar(i,3)=(psdgh(ww,qq,0)+psdgh(ww,qq,1)
4330      *    )/(4.*pi**2*alfe)*qq
4331         endif
4332         ar(i,4)=0.
4333       enddo
4334       return
4335       end
4336
4337 c------------------------------------------------------------------------
4338       subroutine pscs(c,s)
4339 c-----------------------------------------------------------------------
4340 c pscs - cos (c) and sin (s) generation for uniformly distributed angle
4341 c-----------------------------------------------------------------------
4342 1     s1=2.*rangen()-1.
4343       s2=2.*rangen()-1.
4344       s3=s1*s1+s2*s2
4345       if(s3.gt.1.)goto 1
4346       s3=sqrt(s3)
4347       c=s1/s3
4348       s=s2/s3
4349       return
4350       end
4351
4352 c------------------------------------------------------------------------
4353       subroutine psdefrot(ep,s0x,c0x,s0,c0)
4354 c-----------------------------------------------------------------------
4355 c psdefrot - determination of the parameters the spacial rotation to the
4356 c system for 4-vector ep
4357 c s0, c0 - sin and cos for the zx-rotation;
4358 c s0x, c0x - sin and cos for the xy-rotation
4359 c-----------------------------------------------------------------------
4360       dimension ep(4)
4361
4362 c transverse momentum square for the current parton (ep)
4363       pt2=ep(3)**2+ep(4)**2
4364       if(pt2.ne.0.)then
4365         pt=sqrt(pt2)
4366 c system rotation to get pt=0 - euler angles are determined (c0x = cos t
4367 c s0x = sin theta, c0 = cos phi, s0 = sin phi)
4368         c0x=ep(3)/pt
4369         s0x=ep(4)/pt
4370 c total momentum for the gluon
4371         pl=sqrt(pt2+ep(2)**2)
4372         s0=pt/pl
4373         c0=ep(2)/pl
4374       else
4375         c0x=1.
4376         s0x=0.
4377         pl=abs(ep(2))
4378         s0=0.
4379         c0=ep(2)/pl
4380       endif
4381
4382       ep(2)=pl
4383       ep(3)=0.
4384       ep(4)=0.
4385       return
4386       end
4387
4388 c------------------------------------------------------------------------
4389       subroutine psdeftr(s,ep,ey)
4390 c-----------------------------------------------------------------------
4391 c psdeftr - determination of the parameters for the lorentz transform to
4392 c rest frame system for 4-vector ep of mass squared s
4393 c-----------------------------------------------------------------------
4394       dimension ey(3)
4395       double precision ep(4)
4396
4397       do i=1,3
4398         if(ep(i+1).eq.0.d0)then
4399           ey(i)=1.
4400         else
4401           wp=ep(1)+ep(i+1)
4402           wm=ep(1)-ep(i+1)
4403           if(wp.gt.1.e-8.and.wm/wp.lt.1.e-8)then
4404             ww=s
4405             do l=1,3
4406               if(l.ne.i)ww=ww+ep(l+1)**2
4407             enddo
4408             wm=ww/wp
4409           elseif(wm.gt.1.e-8.and.wp/wm.lt.1.e-8)then
4410             ww=s
4411             do l=1,3
4412               if(l.ne.i)ww=ww+ep(l+1)**2
4413             enddo
4414             wp=ww/wm
4415           endif
4416           ey(i)=sqrt(wm/wp)
4417           ep(1)=wp*ey(i)
4418           ep(i+1)=0.
4419         endif
4420       enddo
4421       ep(1)=dsqrt(dble(s))
4422       return
4423       end
4424
4425 c------------------------------------------------------------------------
4426       function psdfh4(x,qqs,qq,icq,iq)
4427 c------------------------------------------------------------------------
4428 c psdfh4 - GRV structure functions
4429 c------------------------------------------------------------------------
4430       common /psar36/ alvc
4431
4432       if(x.gt..99999)then
4433         psdfh4=0.
4434         return
4435       endif
4436       if(icq.eq.2)then
4437         sq=log(log(qqs/.232**2)/log(.23/.232**2))
4438         if(iq.eq.0)then                                 !gluon
4439           alg=.524
4440           betg=1.088
4441           aag=1.742-.93*sq
4442           bbg=-.399*sq**2
4443           ag=7.486-2.185*sq
4444           bg=16.69-22.74*sq+5.779*sq*sq
4445           cg=-25.59+29.71*sq-7.296*sq*sq
4446           dg=2.792+2.215*sq+.422*sq*sq-.104*sq*sq*sq
4447           eg=.807+2.005*sq
4448           eeg=3.841+.361*sq
4449           psdfh4=(1.-x)**dg*(x**aag*(ag+bg*x+cg*x**2)*log(1./x)**bbg
4450      *    +sq**alg*exp(-eg+sqrt(eeg*sq**betg*log(1./x))))
4451         elseif(iq.eq.1.or.iq.eq.2)then                  !u_v or d_v
4452           aau=.59-.024*sq
4453           bbu=.131+.063*sq
4454           auu=2.284+.802*sq+.055*sq*sq
4455           au=-.449-.138*sq-.076*sq*sq
4456           bu=.213+2.669*sq-.728*sq*sq
4457           cu=8.854-9.135*sq+1.979*sq*sq
4458           du=2.997+.753*sq-.076*sq*sq
4459           uv=auu*x**aau*(1.-x)**du*
4460      *    (1.+au*x**bbu+bu*x+cu*x**1.5)
4461
4462           aad=.376
4463           bbd=.486+.062*sq
4464           add=.371+.083*sq+.039*sq*sq
4465           ad=-.509+3.31*sq-1.248*sq*sq
4466           bd=12.41-10.52*sq+2.267*sq*sq
4467           ccd=6.373-6.208*sq+1.418*sq*sq
4468           dd=3.691+.799*sq-.071*sq*sq
4469           dv=add*x**aad*(1.-x)**dd*
4470      *    (1.+ad*x**bbd+bd*x+ccd*x**1.5)
4471
4472           if(iq.eq.1)then                              !u_v
4473             psdfh4=uv
4474           elseif(iq.eq.2)then                          !d_v
4475             psdfh4=dv
4476           endif
4477         elseif(iq.eq.-3)then                           !s_sea
4478           als=.914
4479           bets=.577
4480           aas=1.798-.596*sq
4481           as=-5.548+3.669*sqrt(sq)-.616*sq
4482           bs=18.92-16.73*sqrt(sq)+5.168*sq
4483           ds=6.379-.35*sq+.142*sq*sq
4484           es=3.981+1.638*sq
4485           ees=6.402
4486           psdfh4=(1.-x)**ds*sq**als/log(1./x)**aas*(1.+as*sqrt(x)
4487      *    +bs*x)*exp(-es+sqrt(ees*sq**bets*log(1./x)))
4488         elseif(iabs(iq).lt.3)then                      !u_sea or d_sea
4489           aadel=.409-.005*sq
4490           bbdel=.799+.071*sq
4491           addel=.082+.014*sq+.008*sq*sq
4492           adel=-38.07+36.13*sq-.656*sq*sq
4493           bdel=90.31-74.15*sq+7.645*sq*sq
4494           ccdel=0.
4495           ddel=7.486+1.217*sq-.159*sq*sq
4496           delv=addel*x**aadel*(1.-x)**ddel*
4497      *    (1.+adel*x**bbdel+bdel*x+ccdel*x**1.5)
4498
4499           alud=1.451
4500           betud=.271
4501           aaud=.41-.232*sq
4502           bbud=.534-.457*sq
4503           aud=.89-.14*sq
4504           bud=-.981
4505           cud=.32+.683*sq
4506           dud=4.752+1.164*sq+.286*sq*sq
4507           eud=4.119+1.713*sq
4508           eeud=.682+2.978*sq
4509           udsea=(1.-x)**dud*(x**aaud*(aud+bud*x+cud*x**2)
4510      *    *log(1./x)**bbud+sq**alud*exp(-eud+sqrt(eeud*sq**betud*
4511      *    log(1./x))))
4512
4513           if(iq.eq.-1)then                           !u_sea
4514             psdfh4=(udsea-delv)/2.
4515           elseif(iq.eq.-2)then                       !d_sea
4516             psdfh4=(udsea+delv)/2.
4517           endif
4518         else
4519           psdfh4=0.
4520         endif
4521       elseif(icq.eq.1.or.icq.eq.3)then
4522         sq=log(log(qqs/.204**2)/log(.26/.204**2))
4523         if(iq.eq.1.or.iq.eq.2)then
4524           aapi=.517-.02*sq
4525           api=-.037-.578*sq
4526           bpi=.241+.251*sq
4527           dpi=.383+.624*sq
4528           anorm=1.212+.498*sq+.009*sq**2
4529           psdfh4=.5*anorm*x**aapi*(1.-x)**dpi*
4530      *    (1.+api*sqrt(x)+bpi*x)
4531         elseif(iq.eq.0)then
4532           alfpi=.504
4533           betpi=.226
4534           aapi=2.251-1.339*sqrt(sq)
4535           api=2.668-1.265*sq+.156*sq**2
4536           bbpi=0.
4537           bpi=-1.839+.386*sq
4538           cpi=-1.014+.92*sq-.101*sq**2
4539           dpi=-.077+1.466*sq
4540           epi=1.245+1.833*sq
4541           eppi=.51+3.844*sq
4542           psdfh4=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
4543      *    log(1./x)**bbpi+sq**alfpi*
4544      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
4545         elseif(iq.eq.-3)then
4546           alfpi=.823
4547           betpi=.65
4548           aapi=1.036-.709*sq
4549           api=-1.245+.713*sq
4550           bpi=5.58-1.281*sq
4551           dpi=2.746-.191*sq
4552           epi=5.101+1.294*sq
4553           eppi=4.854-.437*sq
4554           psdfh4=sq**alfpi/log(1./x)**aapi*(1.-x)**dpi*
4555      *    (1.+api*sqrt(x)+bpi*x)*
4556      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x)))
4557         elseif(iabs(iq).lt.3)then
4558           alfpi=1.147
4559           betpi=1.241
4560           aapi=.309-.134*sqrt(sq)
4561           api=.219-.054*sq
4562           bbpi=.893-.264*sqrt(sq)
4563           bpi=-.593+.24*sq
4564           cpi=1.1-.452*sq
4565           dpi=3.526+.491*sq
4566           epi=4.521+1.583*sq
4567           eppi=3.102
4568           psdfh4=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
4569      *    log(1./x)**bbpi+sq**alfpi*
4570      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
4571         else
4572           psdfh4=0.
4573         endif
4574       elseif(icq.eq.0)then
4575         sq=log(log(qqs/.204**2)/log(.26/.204**2))
4576         if(iq.eq.0)then
4577           alfpi=.504
4578           betpi=.226
4579           aapi=2.251-1.339*sqrt(sq)
4580           api=2.668-1.265*sq+.156*sq**2
4581           bbpi=0.
4582           bpi=-1.839+.386*sq
4583           cpi=-1.014+.92*sq-.101*sq**2
4584           dpi=-.077+1.466*sq
4585           epi=1.245+1.833*sq
4586           eppi=.51+3.844*sq
4587           psdfh4=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
4588      *    log(1./x)**bbpi+sq**alfpi*
4589      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
4590      *    *.543
4591         else
4592           alfpi=.823
4593           betpi=.65
4594           aapi=1.036-.709*sq
4595           api=-1.245+.713*sq
4596           bpi=5.58-1.281*sq
4597           dpi=2.746-.191*sq
4598           epi=5.101+1.294*sq
4599           eppi=4.854-.437*sq
4600           str=sq**alfpi/log(1./x)**aapi*(1.-x)**dpi*
4601      *    (1.+api*sqrt(x)+bpi*x)*
4602      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x)))
4603           if(iq.eq.3)then
4604             psdfh4=str*.543*2.
4605           else
4606             aapi=.517-.02*sq
4607             api=-.037-.578*sq
4608             bpi=.241+.251*sq
4609             dpi=.383+.624*sq
4610             anorm=1.212+.498*sq+.009*sq**2
4611             val=.5*anorm*x**aapi*(1.-x)**dpi*
4612      *      (1.+api*sqrt(x)+bpi*x)
4613
4614             alfpi=1.147
4615             betpi=1.241
4616             aapi=.309-.134*sqrt(sq)
4617             api=.219-.054*sq
4618             bbpi=.893-.264*sqrt(sq)
4619             bpi=-.593+.24*sq
4620             cpi=1.1-.452*sq
4621             dpi=3.526+.491*sq
4622             epi=4.521+1.583*sq
4623             eppi=3.102
4624             sea=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
4625      *      log(1./x)**bbpi+sq**alfpi*
4626      *      exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
4627             if(iq.eq.1)then
4628               psdfh4=(.836*(val+2.*sea)-.587*str)
4629             elseif(iq.eq.2)then
4630               psdfh4=(.25*(val+2.*sea)+.587*str)
4631             else
4632               psdfh4=0.
4633             endif
4634           endif
4635         endif
4636         psdfh4=psdfh4/(1.+qq/.59)**2
4637
4638       elseif(icq.eq.4.and.iq.eq.1)then
4639         psdfh4=x**3*(1.-x)**alvc*(alvc+3.)*(alvc+2.)*(alvc+1.)
4640       else
4641         psdfh4=0.
4642       endif
4643       return
4644       end
4645
4646
4647 c------------------------------------------------------------------------
4648       function psfap(x,j,l)
4649 c-----------------------------------------------------------------------
4650 c psfap - altarelli-parisi function (multiplied by x)
4651 c x - light cone momentum share value,
4652 c j - type of the parent parton (0-g;1,2,etc.-q)
4653 c l - type of the daughter parton (0-g;1,2,etc.-q)
4654 c-----------------------------------------------------------------------
4655       double precision x
4656       include 'epos.incsem'
4657
4658       if(j.eq.0)then
4659         if(l.eq.0)then
4660           psfap=((1.d0-x)/x+x/(1.d0-x)+x*(1.d0-x))*6.d0
4661         else
4662           psfap=(x**2+(1.d0-x)**2)*naflav
4663         endif
4664       else
4665         if(l.eq.0)then
4666           psfap=(1.d0+(1.d0-x)**2)/x/.75d0
4667         else
4668           psfap=(x**2+1.d0)/(1.d0-x)/.75d0
4669         endif
4670       endif
4671       return
4672       end
4673
4674 cc------------------------------------------------------------------------
4675 c      function psgen(a1,a2)
4676 cc-----------------------------------------------------------------------
4677 cc psgen - x-values generation according to distribution
4678 cc x1^(-a1) x2^(-0.5)
4679 cc-----------------------------------------------------------------------
4680 c      common/lept1/engy,elepti,elepto,angmue,icinpu
4681 c
4682 c      aa=max(a1,a2)
4683 c1     continue
4684 c      if(aa.lt.1.)then
4685 c        x1=.5*rangen()**(1./(1.-aa))
4686 c      elseif(aa.eq.1.)then
4687 c        x1=.5/engy**rangen()
4688 c      else
4689 c        x1=.5*(1.+rangen()*(engy**(aa-1.)-1.))**(1./(1.-aa))
4690 c      endif
4691 c      if(x1.lt.1.e-7.or.x1.gt..999999)then
4692 c        goto 1
4693 c      endif
4694 c      if(rangen().lt..5)then
4695 c        gb=x1**(aa-a1)*.5**aa/(1.-x1)**a2
4696 c      else
4697 c        x1=1.-x1
4698 c        gb=(1.-x1)**(aa-a2)*.5**aa/x1**a1
4699 c      endif
4700 c      if(rangen().gt.gb)goto 1
4701 c      psgen=x1
4702 c      return
4703 c      end
4704 c
4705 c------------------------------------------------------------------------
4706       function psidd(icc)
4707 c-----------------------------------------------------------------------
4708 c psidd - kink type decoder
4709 c-----------------------------------------------------------------------
4710       if(icc.eq.0)then                    !g
4711         psidd=9
4712       elseif(iabs(icc).le.2)then          !u,u~,d,d~
4713         psidd=icc
4714       elseif(iabs(icc).eq.4)then          !s,s~
4715         psidd=icc/4*3
4716       elseif(iabs(icc).gt.10)then         !c,c~ etc.
4717         psidd=icc/10
4718       elseif(icc.eq.3)then                !ud
4719         psidd=1200
4720       elseif(icc.eq.-3)then               !u~d~
4721         psidd=-1200
4722       elseif(icc.eq.6)then                !uu
4723         psidd=1100
4724       elseif(icc.eq.-6)then               !u~u~
4725         psidd=-1100
4726       elseif(icc.eq.7)then                !dd
4727         psidd=2200
4728       elseif(icc.eq.-7)then               !d~d~
4729         psidd=-2200
4730       else
4731         write (*,*)'psidd?????????',icc
4732       endif
4733       return
4734       end
4735
4736 cc------------------------------------------------------------------------
4737 c       function pslam(s,a,b)
4738 cc-----------------------------------------------------------------------
4739 cc kinematical function for two particle decay - maximal pt-value
4740 cc a - first particle mass squared,
4741 cc b - second particle mass squared,
4742 cc s - two particle invariant mass squared
4743 cc-----------------------------------------------------------------------
4744 c       pslam=.25/s*(s+a-b)**2-a
4745 c       return
4746 c       end
4747 c
4748 c------------------------------------------------------------------------
4749       function psjvrg1(qt,s,y0)
4750 c-----------------------------------------------------------------------
4751       common /ar3/   x1(7),a1(7)
4752       common /cnsta/ pi,pii,hquer,prom,piom,ainfin
4753       include 'epos.incsem'
4754       double precision xt,ymin,ymax,y,xmin,xmax,xx1,xx2
4755
4756       psjvrg1=0.
4757       if(s.le.4.*qt)return
4758
4759       xt=2.d0*sqrt(dble(qt)/dble(s))
4760       ymax=min(dble(y0),log(1d0/xt+sqrt((1d0/xt-1d0)*(1d0/xt+1d0))))
4761       ymin=-ymax
4762
4763       do i=1,7
4764       do m=1,2
4765         y=.5d0*(ymax+ymin+(ymin-ymax)*dble((2*m-3)*x1(i)))
4766         xmin=xt**2/2.d0/(2.d0-xt*exp(-y))
4767         xmax=1.d0-xt*exp(y)/2.d0
4768
4769         fx=0.
4770         do i1=1,7
4771         do m1=1,2
4772           xx1=xt*exp(y)/2d0+xmin*(xmax/xmin)**dble(.5+x1(i1)*(m1-1.5))
4773           xx2=xt*exp(-y)*xx1/(2.d0*xx1-xt*exp(y))
4774           z=sngl(xx1*xx2)
4775           sh=z*s
4776           t=sngl(dble(sh)/2d0*(1d0
4777      &                      -sqrt(max(0d0,1d0-4d0*dble(qt)/dble(sh)))))
4778           ft=psjvrx(t,qt,sngl(xx1),sngl(xx2),sh)
4779           fx=fx+a1(i1)*ft/sh**2
4780         enddo
4781         enddo
4782         fx=fx*sngl(log(xmax/xmin))
4783         psjvrg1=psjvrg1+a1(i)*fx
4784       enddo
4785       enddo
4786       psjvrg1=psjvrg1*sngl(ymax-ymin)*pi**3
4787      **pssalf(qt/qcdlam)**2*sqrt(qt)
4788       return
4789       end
4790
4791 c-----------------------------------------------------------------------
4792       function psjvrx(t,qt,xx1,xx2,s)
4793 c-----------------------------------------------------------------------
4794       include 'epos.incsem'
4795
4796       g1=psdfh4(xx1,qt,0.,2,0)
4797       ub1=psdfh4(xx1,qt,0.,2,-1)
4798       u1=psdfh4(xx1,qt,0.,2,1)+ub1
4799       db1=psdfh4(xx1,qt,0.,2,-2)
4800       d1=psdfh4(xx1,qt,0.,2,2)+db1
4801       sb1=psdfh4(xx1,qt,0.,2,-3)
4802       s1=sb1
4803       g2=psdfh4(xx2,qt,0.,2,0)
4804       ub2=psdfh4(xx2,qt,0.,2,-1)
4805       u2=psdfh4(xx2,qt,0.,2,1)+ub2
4806       db2=psdfh4(xx2,qt,0.,2,-2)
4807       d2=psdfh4(xx2,qt,0.,2,2)+db2
4808       sb2=psdfh4(xx2,qt,0.,2,-3)
4809       s2=sb2
4810
4811       psjvrx=g1*g2*(psbori(s,t,0,0,1)+psbori(s,s-t,0,0,1)
4812      *+psbori(s,t,0,0,2)+psbori(s,s-t,0,0,2))/2.
4813      *+(psbori(s,t,0,1,1)+psbori(s,s-t,0,1,1))*
4814      *(g2*(u1+ub1+d1+db1+s1+sb1)+g1*(u2+ub2+d2+db2+s2+sb2))
4815      *+(psbori(s,t,1,1,1)+psbori(s,s-t,1,1,1))/2.*
4816      *(u1*u2+ub1*ub2+d1*d2+db1*db2+s1*s2+sb1*sb2)
4817      *+(psbori(s,t,1,-1,1)+psbori(s,s-t,1,-1,1)+psbori(s,t,1,-1,2)+
4818      *psbori(s,s-t,1,-1,2)+psbori(s,t,1,-1,3)+psbori(s,s-t,1,-1,3))*
4819      *(u1*ub2+ub1*u2+d1*db2+db1*d2+s1*sb2+sb1*s2)
4820      *+(psbori(s,t,1,2,1)+psbori(s,s-t,1,2,1))*
4821      *((u1+ub1)*(d2+db2+s2+sb2)+(u2+ub2)*(d1+db1+s1+sb1)+
4822      *(d1+db1)*(u2+ub2+s2+sb2)+(d2+db2)*(u1+ub1+s1+sb1)+
4823      *(s1+sb1)*(u2+ub2+d2+db2)+(s2+sb2)*(u1+ub1+d1+db1))
4824       return
4825       end
4826
4827 c------------------------------------------------------------------------
4828       function psjwo1(qt,s,y0)
4829 c-----------------------------------------------------------------------
4830       common /ar3/   x1(7),a1(7)
4831       common /cnsta/ pi,pii,hquer,prom,piom,ainfin
4832       double precision xt,ymax,ymin,y,xmin,xmax,xx1,xx2
4833       include 'epos.incsem'
4834
4835       psjwo1=0.
4836       if(s.le.4.*qt)return
4837
4838       xt=2.d0*sqrt(dble(qt)/dble(s))
4839       ymax=min(dble(y0),log(1d0/xt+sqrt((1d0/xt-1d0)*(1d0/xt+1d0))))
4840       ymin=-ymax
4841
4842       do i=1,7
4843       do m=1,2
4844         y=.5d0*(ymax+ymin+(ymin-ymax)*dble(2*m-3)*dble(x1(i)))
4845         xmin=xt**2/2.d0/(2.d0-xt*exp(-y))
4846         xmax=1.d0-xt*exp(y)/2.d0
4847
4848         fx=0.
4849         do i1=1,7
4850         do m1=1,2
4851           xx1=xt*exp(y)/2.d0+xmin*(xmax/xmin)**dble(.5+x1(i1)*(m1-1.5))
4852           xx2=xt*exp(-y)/(2.d0-xt*exp(y)/xx1)
4853           z=sngl(xx1*xx2)
4854           sh=z*s
4855           t=sngl(dble(sh)/2d0*(1d0-sqrt(1d0-4d0*dble(qt)/dble(sh))))
4856           ft=psjwox(t,qt,sngl(xx1),sngl(xx2),sh)
4857           fx=fx+a1(i1)*ft/sh**2
4858         enddo
4859         enddo
4860         fx=fx*log(xmax/xmin)
4861         psjwo1=psjwo1+a1(i)*fx
4862       enddo
4863       enddo
4864       psjwo1=psjwo1*sngl(ymax-ymin)*pi**3
4865      **pssalf(qt/qcdlam)**2*sqrt(qt)
4866       return
4867       end
4868
4869 c-----------------------------------------------------------------------
4870       function psjwox(t,qt,xx1,xx2,s)
4871 c-----------------------------------------------------------------------
4872       double precision x,scale,upv1,dnv1,sea1,str1,chm1,gl1,
4873      *upv2,dnv2,sea2,str2,chm2,gl2
4874       scale=sqrt(qt)
4875       x=xx1
4876       call strdo1(x,scale,upv1,dnv1,sea1,str1,chm1,gl1)
4877       x=xx2
4878       call strdo1(x,scale,upv2,dnv2,sea2,str2,chm2,gl2)
4879
4880       psjwox=gl1*gl2*(psbori(s,t,0,0,1)+psbori(s,s-t,0,0,1)
4881      *+psbori(s,t,0,0,2)+psbori(s,s-t,0,0,2)+psbori(s,t,0,0,3)
4882      *+psbori(s,s-t,0,0,3))/2.
4883      *+(psbori(s,t,0,1,1)+psbori(s,s-t,0,1,1)
4884      *+psbori(s,t,0,1,2)+psbori(s,s-t,0,1,2)+psbori(s,t,0,1,3)
4885      *+psbori(s,s-t,0,1,3))*(gl2*(upv1+dnv1+4.*sea1+2.*str1+2.*chm1)+
4886      *gl1*(upv2+dnv2+4.*sea2+2.*str2+2.*chm2))
4887      *+(psbori(s,t,1,1,1)+psbori(s,s-t,1,1,1)
4888      *+psbori(s,t,1,1,2)+psbori(s,s-t,1,1,2)+psbori(s,t,1,1,3)+
4889      *psbori(s,s-t,1,1,3))/2.*
4890      *((upv1+sea1)*(upv2+sea2)+(dnv1+sea1)*(dnv2+sea2)+2.*sea1*sea2
4891      *+2.*str1*str2+2.*chm1*chm2)
4892      *+(psbori(s,t,1,-1,1)+psbori(s,s-t,1,-1,1)+psbori(s,t,1,-1,2)+
4893      *psbori(s,s-t,1,-1,2)+psbori(s,t,1,-1,3)+psbori(s,s-t,1,-1,3))*
4894      *((upv1+sea1)*sea2+sea1*(upv2+sea2)+(dnv1+sea1)*sea2+
4895      *sea1*(dnv2+sea2)+2.*str1*str2+2.*chm1*chm2)
4896      *+(psbori(s,t,1,2,1)
4897      *+psbori(s,s-t,1,2,1)+psbori(s,t,1,2,2)+psbori(s,s-t,1,2,2)
4898      *+psbori(s,t,1,2,3)+psbori(s,s-t,1,2,3))*
4899      *(upv1*dnv2+upv2*dnv1+(upv1+dnv1)*(2.*sea2+2.*str2+2.*chm2)+
4900      *(upv2+dnv2)*(2.*sea1+2.*str1+2.*chm1)+
4901      *4.*sea1*(2.*sea2+2.*str2+2.*chm2)+2.*str1*(4.*sea2+2.*chm2)+
4902      *2.*chm1*(4.*sea2+2.*str2))
4903       return
4904       end
4905
4906 c------------------------------------------------------------------------
4907       subroutine pslcsh(wp1,wm1,wp2,wm2,samqt,amqpt)
4908 c-----------------------------------------------------------------------
4909 c pslcsh - sh pomeron lc momentum sharing between two strings
4910 c------------------------------------------------------------------------
4911       double precision amqt(4),yqm(4),yqm1(4),xlp(4),xlm(4),am23,sx,y2
4912      *,wp1,wp2,wm1,wm2,s,sq,psutz,yqmax,y,amjp,amjm,y1,s12,s34,x34,amqpt
4913       dimension samqt(4)
4914       include 'epos.inc'
4915
4916       s=wp1*wm1
4917       sq=dsqrt(s)
4918       do i=1,4
4919         amqt(i)=dble(samqt(i))
4920         yqm(i)=dlog(sq/amqt(i)*psutz(s,amqt(i)**2,(amqpt-amqt(i))**2))
4921       enddo
4922       yqmax=max(yqm(1),yqm(2))
4923
4924 1     y=yqmax*dble(rangen())
4925       j=int(1.5+rangen())
4926       if(y.gt.yqm(j))goto 1
4927
4928       amjp=amqt(j)*dexp(y)
4929       amjm=amqt(j)*dexp(-y)
4930       do i=3,4
4931         am23=amqt(3-j)+amqt(7-i)
4932         sx=(am23+amjp)*(am23+amjm)
4933         yqm1(i)=dlog(sq/amqt(i)*psutz(s,amqt(i)**2,sx))
4934       enddo
4935       yqmax1=max(yqm1(3),yqm1(4))
4936       if(dble(rangen()).gt.yqmax1/max(yqm(3),yqm(4)))goto 1
4937
4938       y1=yqmax1*dble(rangen())
4939       j1=int(3.5+rangen())
4940       if(y1.gt.yqm1(j1))goto 1
4941
4942       amjp1=amqt(j1)*exp(y1)
4943       amjm1=amqt(j1)*exp(-y1)
4944       s12=(amqt(3-j)+amjp)*(amqt(3-j)+amjm)
4945       s34=(amqt(7-j1)+amjp1)*(amqt(7-j1)+amjm1)
4946       y2=dlog(sq/(amqt(3-j)+amjp)*psutz(s,s12,s34))
4947
4948       xlp(j)=amqt(j)/sq*dexp(y+y2)
4949       xlm(j)=amqt(j)/sq*dexp(-y-y2)
4950       xlp(3-j)=amqt(3-j)/sq*dexp(y2)
4951       xlm(3-j)=amqt(3-j)/sq*dexp(-y2)
4952       x34=1.-xlm(1)-xlm(2)
4953       xlm(7-j1)=x34/(1.+amjp1/amqt(7-j1))
4954       xlm(j1)=x34-xlm(7-j1)
4955 c      write (*,*)'xlc',xlp(1),xlp(2),xlm(3),xlm(4)
4956       if(dble(rangen()).gt.(xlp(1)*xlp(2)*xlm(3)*xlm(4))**(-alpqua)*
4957      *(xlp(j)*(1.d0-xlp(j))*xlm(j1)*(1.d0-xlm(j1))))goto 1
4958
4959       wp2=xlp(2)*wp1
4960       wp1=xlp(1)*wp1
4961       wm2=xlm(4)*wm1
4962       wm1=xlm(3)*wm1
4963 c      write (*,*)'wp1,wm1,wp2,wm2',wp1,wm1,wp2,wm2
4964       return
4965       end
4966
4967 c------------------------------------------------------------------------
4968       function psnorm(ep)
4969 c-----------------------------------------------------------------------
4970 c 4-vector squared calculation
4971 c-----------------------------------------------------------------------
4972       double precision sm2,ep(4)
4973       sm2=ep(1)**2
4974       do i=1,3
4975         sm2=sm2-ep(i+1)**2
4976       enddo
4977       psnorm=sm2
4978       return
4979       end
4980
4981 c------------------------------------------------------------------------
4982       subroutine psrotat(ep,s0x,c0x,s0,c0)
4983 c-----------------------------------------------------------------------
4984 c psrotat - spacial rotation to the lab. system for 4-vector ep
4985 c s0, c0 - sin and cos for the zx-rotation;
4986 c s0x, c0x - sin and cos for the xy-rotation
4987 c-----------------------------------------------------------------------
4988       dimension ep(4),ep1(3)
4989
4990       ep1(3)=ep(4)
4991       ep1(2)=ep(2)*s0+ep(3)*c0
4992       ep1(1)=ep(2)*c0-ep(3)*s0
4993
4994       ep(2)=ep1(1)
4995       ep(4)=ep1(2)*s0x+ep1(3)*c0x
4996       ep(3)=ep1(2)*c0x-ep1(3)*s0x
4997       return
4998       end
4999
5000 cc------------------------------------------------------------------------
5001 c      subroutine psrotat1(ep,s0x,c0x,s0,c0)
5002 cc-----------------------------------------------------------------------
5003 cc psrotat - spacial rotation to the lab. system for 4-vector ep
5004 cc s0, c0 - sin and cos for the zx-rotation;
5005 cc s0x, c0x - sin and cos for the xy-rotation
5006 cc-----------------------------------------------------------------------
5007 c      dimension ep(4),ep1(3)
5008 c
5009 c      ep1(1)=ep(2)
5010 c      ep1(3)=-ep(3)*s0x+ep(4)*c0x
5011 c      ep1(2)=ep(3)*c0x+ep(4)*s0x
5012 c
5013 c      ep(4)=ep1(3)
5014 c      ep(3)=-ep1(1)*s0+ep1(2)*c0
5015 c      ep(2)=ep1(1)*c0+ep1(2)*s0
5016 c      return
5017 c      end
5018 c
5019 c-----------------------------------------------------------------------
5020       function pssalf(qq)
5021 c-----------------------------------------------------------------------
5022 c pssalf - effective qcd coupling (alpha_s/2/pi)
5023 c-----------------------------------------------------------------------
5024       include "epos.incsem"
5025       pssalf=2./(11.-naflav/1.5)/log(qq)
5026       return
5027       end
5028
5029 c------------------------------------------------------------------------
5030       subroutine pstrans(ep,ey,jj)
5031 c-----------------------------------------------------------------------
5032 c pstrans - lorentz boosts according to the parameters ey ( determining
5033 c shift along the z,x,y-axis respectively (ey(1),ey(2),ey(3)))
5034 c jj=1 - inverse transformation to the lab. system;
5035 c jj=-1 - direct transformation
5036 c-----------------------------------------------------------------------
5037       dimension ey(3),ep(4)
5038
5039       if(jj.eq.1)then
5040 c lorentz transform to lab. system according to 1/ey(i) parameters
5041         do i=1,3
5042           if(ey(4-i).ne.1.)then
5043             wp=(ep(1)+ep(5-i))/ey(4-i)
5044             wm=(ep(1)-ep(5-i))*ey(4-i)
5045             ep(1)=.5*(wp+wm)
5046             ep(5-i)=.5*(wp-wm)
5047           endif
5048         enddo
5049       else
5050 c lorentz transform to lab. system according to ey(i) parameters
5051         do i=1,3
5052           if(ey(i).ne.1.)then
5053             wp=(ep(1)+ep(i+1))*ey(i)
5054             wm=(ep(1)-ep(i+1))/ey(i)
5055             ep(1)=.5*(wp+wm)
5056             ep(i+1)=.5*(wp-wm)
5057           endif
5058         enddo
5059       endif
5060       return
5061       end
5062
5063 c------------------------------------------------------------------------
5064       double precision function psuds(q,m)
5065 c-----------------------------------------------------------------------
5066 c psuds - spacelike sudakov formfactor
5067 c q - maximal value of the effective momentum,
5068 c m - type of parton (0 - g, 1,2, etc. - q)
5069 c-----------------------------------------------------------------------
5070       dimension wi(3)
5071       common /psar15/ sudx(40,2)
5072       include 'epos.incsem'
5073       double precision dps,qlm,ffacs,qlm0,qlmi
5074
5075       j=min(iabs(m),1)+1
5076
5077       if(q.gt.q2ini)then
5078         qli=log(q/q2min)*2.+1.
5079         i=int(qli)
5080         if(i.lt.1)i=1
5081         if(i.gt.38)i=38
5082         wi(2)=qli-i
5083         wi(3)=wi(2)*(wi(2)-1.)*.5
5084         wi(1)=1.-wi(2)+wi(3)
5085         wi(2)=wi(2)-2.*wi(3)
5086         dps=0.d0
5087         do i1=1,3
5088           dps=dps+dble(sudx(i+i1-1,j)*wi(i1))
5089         enddo
5090
5091         qlm0=dble(log(q2ini/qcdlam))
5092         qlm=dble(log(q/qcdlam))
5093         qlmi=qlm-qlm0         !=log(q/q2ini)
5094         psuds=(qlm*log(qlm/qlm0)-qlmi)
5095
5096         ffacs=(11.d0-dble(naflav)/1.5d0)/12.d0
5097         if(j.eq.1)then
5098           psuds=(psuds-ffacs*log(qlm/qlm0)
5099      *    +dps*(1.d0-dble(q2ini/q)))/ffacs
5100         else
5101           psuds=(psuds-log(qlm/qlm0)*.75d0
5102      *    +dps*(1.d0-dble(q2ini/q)))*4.d0/9.d0/ffacs
5103         endif
5104         psuds=exp(-psuds)
5105       else
5106         psuds=1.d0
5107       endif
5108       return
5109       end
5110
5111 c------------------------------------------------------------------------
5112       function psudx(q,j)
5113 c-----------------------------------------------------------------------
5114 c psudx - part of the bspacelike sudakov formfactor
5115 c q - maximal value of the effective momentum,
5116 c j - type of parton (1 - g, 2 - q)
5117 c-----------------------------------------------------------------------
5118       common /ar3/    x1(7),a1(7)
5119       include 'epos.incsem'
5120
5121       psudx=0.
5122
5123       do i=1,7
5124       do m=1,2
5125         qt=.5*(q2ini+q-x1(i)*(2.*m-3.)*(q2ini-q))
5126         if(j.eq.1)then
5127           zm=1.-qt/q
5128           dps=((11.-naflav/1.5)/12.-zm**2*(1.-naflav/12.)+
5129      *    (zm**3/3.-zm**4/4.)*(1.-naflav/3.))*q/qt
5130         else
5131           dps=(1.-qt/q/4.)
5132         endif
5133         psudx=psudx+a1(i)*dps/log(qt/qcdlam)
5134       enddo
5135       enddo
5136       psudx=psudx*.5
5137       return
5138       end
5139
5140 c------------------------------------------------------------------------
5141       double precision function psutz(s,a,b)
5142 c-----------------------------------------------------------------------
5143 c psutz - kinematical function for two particle decay - light cone momen
5144 c share for the particle of mass squared a,
5145 c b - partner's mass squared,
5146 c s - two particle invariant mass
5147 c-----------------------------------------------------------------------
5148       double precision a1,b1,s1,x,dx,s,a,b
5149       a1=dsqrt(a)
5150       b1=dsqrt(b)
5151       s1=dsqrt(s)
5152       x=(1.d0+(a1-b1)*(a1+b1)/s)/2.d0
5153       dx=(x-a1/s1)*(x+a1/s1)
5154 c      x=.5*(1.+(a-b)/s)
5155 c      dx=(x*x-a/s)
5156       if(dx.gt.0.d0)then
5157         x=x+dsqrt(dx)
5158       else
5159         x=a1/s1
5160       endif
5161       psutz=min(0.999999999d0,x)
5162       return
5163       end
5164
5165 c------------------------------------------------------------------------
5166       block data ptdata
5167 c-----------------------------------------------------------------------
5168 c constants for numerical integration (gaussian weights)
5169 c-----------------------------------------------------------------------
5170       common /ar3/ x1(7),a1(7)
5171       common /ar4/ x4(2),a4(2)
5172       common /ar5/ x5(2),a5(2)
5173       common /ar8/ x2(4),a2
5174       common /ar9/ x9(3),a9(3)
5175
5176       data x1/.9862838,.9284349,.8272013,.6872929,.5152486,
5177      *.3191124,.1080549/
5178       data a1/.03511946,.08015809,.1215186,.1572032,
5179      *.1855384,.2051985,.2152639/
5180       data x2/.00960736,.0842652,.222215,.402455/
5181       data a2/.392699/
5182       data x4/ 0.339981,0.861136/
5183       data a4/ 0.652145,0.347855/
5184       data x5/.585786,3.41421/
5185       data a5/.853553,.146447/
5186       data x9/.93247,.661209,.238619/
5187       data a9/.171324,.360762,.467914/
5188       end
5189
5190 c------------------------------------------------------------------------
5191       subroutine strdo1(x,scale,upv,dnv,sea,str,chm,gl)
5192 c------------------------------------------------------------------------
5193 c :::::::::::: duke owens set 1 ::::::::::::::::::::::::::::
5194 c------------------------------------------------------------------------
5195       implicit double precision(a-h,o-z)
5196       double precision
5197      +       f(5),a(6,5),b1(3,6,5)
5198       data q0,ql1/2.d0,.2d0/
5199       data b1/3.d0,0.d0,0.d0,.419d0,.004383d0,-.007412d0,
5200      &3.46d0,.72432d0,-.065998d0,4.4d0,-4.8644d0,1.3274d0,
5201      &6*0.d0,1.d0,
5202      &0.d0,0.d0,.763d0,-.23696d0,.025836d0,4.d0,.62664d0,-.019163d0,
5203      &0.d0,-.42068d0,.032809d0,6*0.d0,1.265d0,-1.1323d0,.29268d0,
5204      &0.d0,-.37162d0,-.028977d0,8.05d0,1.5877d0,-.15291d0,
5205      &0.d0,6.3059d0,-.27342d0,0.d0,-10.543d0,-3.1674d0,
5206      &0.d0,14.698d0,9.798d0,0.d0,.13479d0,-.074693d0,
5207      &-.0355d0,-.22237d0,-.057685d0,6.3494d0,3.2649d0,-.90945d0,
5208      &0.d0,-3.0331d0,1.5042d0,0.d0,17.431d0,-11.255d0,
5209      &0.d0,-17.861d0,15.571d0,1.564d0,-1.7112d0,.63751d0,
5210      &0.d0,-.94892d0,.32505d0,6.d0,1.4345d0,-1.0485d0,
5211      &9.d0,-7.1858d0,.25494d0,0.d0,-16.457d0,10.947d0,
5212      &0.d0,15.261d0,-10.085d0/
5213       wn=1.d0
5214       s= log( log( max(q0,scale)/ql1)/ log(q0/ql1))
5215       do 10 i=1,5
5216       do 10 j=1,6
5217    10 a(j,i)=b1(1,j,i)+s*(b1(2,j,i)+s*b1(3,j,i))
5218       do 40 i=1,5
5219    40 f(i)=a(1,i)*x**a(2,i)*(wn-x)**a(3,i)*(wn+x*
5220      &    (a(4,i)+x*(a(5,i)+x*a(6,i))))
5221       do 50 i=1,2
5222       aa=wn+a(2,i)+a(3,i)
5223    50 f(i)=f(i)*utgam2(aa)/((wn+a(2,i)*a(4,i)/aa)
5224      &*utgam2(a(2,i))*utgam2(wn+a(3,i)))
5225       upv=f(1)-f(2)
5226       dnv=f(2)
5227       sea=f(3)/6.d0
5228       str=sea
5229       chm=f(4)
5230       gl =f(5)
5231       return
5232       end
5233
5234
5235
5236 c------------------------------------------------------------------------
5237       function fzeroGluZZ(z,k)   ! former psftild
5238 c-----------------------------------------------------------------------
5239 c
5240 c    fzeroGluZZComplete = fzeroGluZZ * z^(-1-dels) * gamsoft * gamhad
5241 c
5242 c  A = 8*pi*s0*gampar*gamtilde
5243 c integration over semihard pomeron light cone momentum share xp==u
5244 c
5245 c fzeroGluZZ = (1-glusea) * engy^epszero
5246 c  * int(du) u^(epszero-alppar+dels) (1-u)^alplea * (1-z/u)**betpom
5247 c
5248 c z - light cone x of the gluon,
5249 c k - hadron class
5250 c-----------------------------------------------------------------------
5251       double precision xpmin,xp
5252       include 'epos.inc'
5253       common /ar3/   x1(7),a1(7)
5254       include 'epos.incsem'
5255
5256       fzeroGluZZ=0.
5257       xpmin=z
5258       xpmin=xpmin**(1.-alppar+dels+epszero)
5259       do i=1,7
5260       do m=1,2
5261         xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
5262      *  (1.-alppar+dels+epszero))
5263         fzeroGluZZ=fzeroGluZZ+a1(i)*(1.-xp)**alplea(k)*(1.-z/xp)**betpom
5264       enddo
5265       enddo
5266       fzeroGluZZ=
5267      *  fzeroGluZZ*.5*(1.-xpmin)/(1.-alppar+dels+epszero)
5268      *     *(1.-glusea)  *engy**epszero
5269       return
5270       end
5271
5272 c------------------------------------------------------------------------
5273       function fzeroSeaZZ(z,k)     ! former psftile
5274 c-----------------------------------------------------------------------
5275 c
5276 c    fzeroSeaZZComplete = fzeroSeaZZ * z^(-1-dels) * gamsoft * gamhad
5277 c
5278 c  gamsoft = 8*pi*s0*gampar*gamtilde
5279 c integration over semihard pomeron light cone momentum share xp==u
5280 c
5281 c fzeroSeaZZ = glusea * engy^epszero
5282 c   * int(du) u^(epszero-alppar+dels) (1-u)^alplea * EsoftQZero(z/u)
5283 c
5284 c z - light cone x of the quark,
5285 c k - hadron class
5286 c-----------------------------------------------------------------------
5287       double precision xpmin,xp
5288       common /ar3/   x1(7),a1(7)
5289       include 'epos.inc'
5290       include 'epos.incsem'
5291
5292       fzeroSeaZZ=0.
5293       xpmin=z
5294       xpmin=xpmin**(1.-alppar+dels+epszero)
5295       do i=1,7
5296       do m=1,2
5297         xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
5298      *  (1.-alppar+dels+epszero))
5299         zz=z/xp
5300         fzeroSeaZZ=fzeroSeaZZ+a1(i)*(1.-xp)**alplea(k)*EsoftQZero(zz)
5301       enddo
5302       enddo
5303       fzeroSeaZZ=fzeroSeaZZ*.5*(1.-xpmin)/(1.-alppar+dels+epszero)
5304      *     *glusea  *engy**epszero
5305       return
5306       end
5307
5308
5309 c########################################################################
5310 c########################################################################
5311       subroutine psaini
5312 c########################################################################
5313 c########################################################################
5314
5315 c-----------------------------------------------------------------------
5316 c common initialization procedure
5317 c if isetcs = 0, alpD, betD, etc ... in inirj are not used and xkappa=1
5318 c if isetcs = 1, alpD, betD, etc ... in inirj are not used but xkappa.ne.1
5319 c if isetcs = 2, alpD, betD, xkappa, etc ... in inirj are used and
5320 c                cross section from calculation in inics are read.
5321 c    if epos.inics doesn't exist, it produces only the calculated part of it.
5322 c if isetcs = 3, alpD, betD, xkappa, etc ... in inirj are used and
5323 c                cross section from simulation in inics are read.
5324 c    if epos.inics doesn't exist, it produces the calculated AND the
5325 c    simulated part of it.
5326 c-----------------------------------------------------------------------
5327       include 'epos.inc'
5328       include 'epos.incpar'
5329       include 'epos.incsem'
5330       logical lcalc!,lcalc2
5331 c      double precision om5p,xh,yh,v3pom(4),om2p
5332       dimension gamhad0(nclha),r2had0(nclha),chad0(nclha)
5333      *,alplea0(nclha),asect1(7,4,7),asect2(7,4,7),asect3(7,7,7)
5334      *,asect4(7,7,7)!,cgam(idxD)
5335       common /psar2/  edmax,epmax
5336       common /psar4/  fhgg(11,10,8),fhqg(11,10,80)
5337      *,fhgq(11,10,80),fhqq(11,10,80),fhgg0(11,10),fhgg1(11,10,4)
5338      *,fhqg1(11,10,40),fhgg01(11),fhgg02(11),fhgg11(11,4)
5339      *,fhgg12(11,4),fhqg11(11,10,4),fhqg12(11,10,4)
5340      *,ftoint(11,14,2,2,3)
5341       common /psar7/  delx,alam3p,gam3p
5342       common /psar9/  alpr
5343       common /psar15/ sudx(40,2)
5344       common /psar19/ cstot(20,20,240)
5345       common /psar20/ csord(20,20,240)
5346       common /psar21/ csbor(20,160,2)
5347       common /psar22/ cstotzero(20,4,2),csborzer(20,4,2)
5348       common /psar23/ cschar(20,20,2)
5349       common /psar25/ csdsi(21,21,104)
5350       common /psar27/ csds(21,26,4),csdt(21,26,2),csdr(21,26,2)
5351       common /psar33/ asect(7,4,7),asectn(7,7,7)
5352       common /psar34/ rrr,rrrm
5353       common /psar35/ anorm,anormp
5354       common /psar41/ rrrp,rrrmp
5355       common /psar36/ alvc
5356       common /psar37/ coefom1,coefom2
5357       common /psar38/ vfro(11,14,3,2)
5358       common /psar39/ vnorm(11,14,3,2,2)
5359 c$$$      common /psar40/ coefxu1(idxD,nclha,10)
5360 c$$$     *,coefxu2(idxD,idxD,nclha,10),coefxc2(idxD,idxD,nclha,10)
5361       common /ar3/    x1(7),a1(7)
5362       common /testj/  ajeth(4),ajete(5),ajet0(7)
5363       parameter(nbkbin=40)
5364       common /kfitd/ xkappafit(nclegy,nclha,nclha,nbkbin),xkappa,bkbin
5365       common/geom/rmproj,rmtarg,bmax,bkmx
5366       character textini*38
5367       external ptfau,ptfauAA
5368
5369
5370       call utpri('psaini',ish,ishini,4)
5371
5372       do i=1,4
5373       ajeth(i)=0.
5374       enddo
5375       do i=1,5
5376       ajete(i)=0.
5377       ajet0(i)=0.
5378       enddo
5379       ajet0(6)=0.
5380       ajet0(7)=0.
5381
5382
5383       if(isetcs.le.1)then              !for Kfit
5384         bkbin=0.3
5385       else
5386         bkbin=0.1
5387       endif
5388       xkappa=1.
5389
5390       edmax=edmaxi  !1.e12     defined in epos-bas
5391       epmax=epmaxi  !1.e12     defined in epos-bas
5392
5393 c fix enhanced diagrams at minimum energy = 2.5
5394       delx=1.5 !sqrt(egymin*egymin/exp(1.))
5395       alam3p=.6
5396       gam3p=.1
5397
5398
5399
5400 c   interface to 'bas'
5401 c    ----------------
5402
5403       dels=alppom-1.
5404       alpqua=(alppar+1.)/2.
5405       if(abs(alpqua).lt.1.e-6)call utstop('alpar should not be -1 !&')
5406       alpr=-2.+alpqua      !x-exponent for remnant mass
5407
5408 c   omega coeffs
5409 c    ----------------
5410       coefom0=utgam1(1.+dels-alppar)*utgam1(1.+alplea(iclpro))
5411      */utgam1(2.+alplea(iclpro)+dels-alppar)
5412      **utgam1(1.+dels-alppar)*utgam1(1.+alplea(icltar))
5413      */utgam1(2.+alplea(icltar)+dels-alppar)
5414       coefom1=1.-utgam1(1.+dels-alppar)**2*utgam1(1.+alplea(iclpro))
5415      */utgam1(1.+alplea(iclpro)+2.*(1.+dels-alppar))
5416      **utgam1(1.+dels-alppar)**2*utgam1(1.+alplea(icltar))
5417      */utgam1(1.+alplea(icltar)+2.*(1.+dels-alppar))/coefom0**2
5418       coefom2=3.*coefom1-1.
5419      *+utgam1(1.+dels-alppar)**3*utgam1(1.+alplea(iclpro))
5420      */utgam1(1.+alplea(iclpro)+3.*(1.+dels-alppar))
5421      **utgam1(1.+dels-alppar)**3*utgam1(1.+alplea(icltar))
5422      */utgam1(1.+alplea(icltar)+3.*(1.+dels-alppar))/coefom0**3
5423       if(ish.ge.4)write(ifch,*)'coefom',coefom0,coefom1,coefom2,delx
5424
5425 c soft pomeron: abbreviations
5426 c---------------------------------------
5427       if(iappl.eq.1.or.iappl.eq.8.or.iappl.eq.9)then
5428
5429
5430 c---------------------------------------
5431 c auxiliary constants:
5432 c---------------------------------------
5433         stmass=.05               !string mass cutoff
5434
5435 c---------------------------------------
5436 c parton density normalization
5437         sq=log(log(q2min/.232**2)/log(.23/.232**2))
5438         du=2.997+.753*sq-.076*sq*sq
5439         qnorm=0.
5440         do i=1,7
5441         do m=1,2
5442           xx=.5+x1(i)*(m-1.5)
5443           xxq=1.-xx**(1./(1.+du))
5444           qnorm=qnorm+a1(i)*(psdfh4(xxq,q2min,0.,2,1)+
5445      *    psdfh4(xxq,q2min,0.,2,2))/(1.-xxq)**du
5446         enddo
5447         enddo
5448         qnorm=qnorm*.5/(1.+du)
5449         qnormp=qnorm
5450 ckkkkk-----------------------------
5451 c        rr=(1.-qnorm)/4./pi/gamhad(2)
5452 c     *  *utgam1(2.+betpom-dels)/utgam1(1.-dels)
5453 c     *  /utgam1(1.+betpom)/utgam1(1.+alplea(2))/
5454 c     *  utgam1(2.-alppar)*utgam1(3.+alplea(2)-alppar)
5455 c      ffrr=(1.-qnorm)/4./pi/gamhad(2)
5456 c     *  *utgam1(2.+betpom-dels)/utgam1(1.-dels)
5457 c     *  /utgam1(1.+betpom)
5458 c      write(6,*)'===========',ffrr
5459       ffrr=gamtil
5460         rr=ffrr
5461      *  /utgam1(1.+alplea(2))/
5462      *  utgam1(2.-alppar)*utgam1(3.+alplea(2)-alppar)
5463       gamsoft=rr*4.*pi
5464 ckkkkkkk-------------------------------
5465         if(ish.ge.4)write (ifch,*)'rr,qnorm',rr,qnorm
5466
5467
5468         sq=log(log(q2min/.232**2)/log(.25/.232**2))
5469         dpi=.367+.563*sq
5470         qnorm=0.
5471         do i=1,7
5472         do m=1,2
5473           xx=.5+x1(i)*(m-1.5)
5474           xxq=1.-xx**(1./(1.+dpi))
5475           qnorm=qnorm+a1(i)*(psdfh4(xxq,q2min,0.,1,1)+
5476      *    psdfh4(xxq,q2min,0.,1,2))/(1.-xxq)**dpi
5477         enddo
5478         enddo
5479         qnorm=qnorm*.5/(1.+dpi)
5480         cftmp=1./(1.-qnormp)*(1.-qnorm)
5481      *  *utgam1(alplea(2)+1.)/utgam1(alplea(2)+3.-alppar)
5482      *  /utgam1(alplea(1)+1.)*utgam1(alplea(1)+3.-alppar)
5483         gamhad(1)=gamhad(2)*cftmp
5484         if(gamhadsi(1).lt.0.)then
5485           gamhads(1)=gamhad(1)
5486         else
5487           gamhads(1)=gamhadsi(1)
5488         endif
5489         if(ish.ge.4)
5490      *  write (ifch,*)'gamhad(1),gamhads(1)',gamhad(1),gamhads(1)
5491
5492         if(gamhadsi(2).lt.0.)then
5493           gamhads(2)=gamhad(2)
5494         else
5495           gamhads(2)=gamhadsi(2)
5496         endif
5497         if(ish.ge.4)
5498      *  write (ifch,*)'gamhad(2),gamhads(2)',gamhad(2),gamhads(2)
5499
5500         qnorm=0.
5501         do i=1,7
5502         do m=1,2
5503           xx=.5+x1(i)*(m-1.5)
5504           xxq=1.-xx**(1./(1.+dpi))
5505           qnorm=qnorm+a1(i)*(psdfh4(xxq,q2min,0.,1,1)+
5506      *    psdfh4(xxq,q2min,0.,1,2))/(1.-xxq)**dpi
5507         enddo
5508         enddo
5509         qnorm=qnorm*.5/(1.+dpi)
5510         cftmp=1./(1.-qnormp)*(1.-qnorm)
5511      *  *utgam1(alplea(2)+1.)/utgam1(alplea(2)+3.-alppar)
5512      *  /utgam1(alplea(3)+1.)*utgam1(alplea(3)+3.-alppar)
5513         gamhad(3)=gamhad(2)*cftmp
5514         if(gamhadsi(3).lt.0.)then
5515           gamhads(3)=gamhad(3)
5516         else
5517           gamhads(3)=gamhadsi(3)
5518         endif
5519         if(ish.ge.4)
5520      *  write (ifch,*)'gamhad(3),gamhads(3)',gamhad(3),gamhads(3)
5521
5522         quamas=.35
5523         gamhad(4)=gamhad(1)*(quamas/qcmass)**2
5524         if(gamhadsi(4).lt.0.)then
5525           gamhads(4)=gamhad(4)
5526         else
5527           gamhads(4)=gamhadsi(4)
5528         endif
5529         if(ish.ge.4)
5530      *  write (ifch,*)'gamhad(4),gamhads(4)',gamhad(4),gamhads(4)
5531         gnorm=0.
5532         do i=1,7
5533         do m=1,2
5534           xx=.5+x1(i)*(m-1.5)
5535           xxg=xx**(1./(1.-dels))
5536           gnorm=gnorm+a1(i)*(fzeroGluZZ(xxg,4)+fzeroSeaZZ(xxg,4))
5537         enddo
5538         enddo
5539         gnorm=gnorm/(1.-dels)*2.*pi*gamhad(4)*rr
5540         alvc=6./(1.-gnorm)-4.
5541         if(ish.ge.4) write (ifch,*)'rr,qnorm,gnorm,alvc',
5542      *  rr,qnorm,gnorm,alvc
5543
5544 c        write (*,*)'rr-c,qnorm,gnorm,alvc',rr,qnorm,gnorm,alvc
5545       endif
5546
5547 c-----------------------------------------------
5548 c tabulation of inclusive jet cross sections
5549 c--------------------------------------------------
5550
5551       do i=1,40
5552         qi=q2min*exp(.5*(i-1))
5553         sudx(i,1)=psudx(qi,1)
5554         sudx(i,2)=psudx(qi,2)
5555       enddo
5556       if(ish.ge.4)write(ifch,*)'bare cross sections ...'
5557
5558       call psaevc
5559
5560 ccc      call MakeCSTable
5561
5562       inquire(file=fnii(1:nfnii),exist=lcalc)
5563       if(lcalc)then
5564        if(inicnt.eq.1)then
5565         write(ifmt,'(3a)')'read from ',fnii(1:nfnii),' ...'
5566         open(1,file=fnii(1:nfnii),status='old')
5567         read (1,*)qcdlam0,q2min0,q2ini0,naflav0,epmax0,pt2cut0
5568         if(qcdlam0.ne.qcdlam)write(ifmt,'(a)')'initl: wrong qcdlam'
5569         if(q2min0 .ne.q2min )write(ifmt,'(a)')'initl: wrong q2min'
5570         if(q2ini0 .ne.q2ini )write(ifmt,'(a)')'initl: wrong q2ini'
5571         if(naflav0.ne.naflav)write(ifmt,'(a)')'initl: wrong naflav'
5572         if(epmax0 .ne.epmax )write(ifmt,'(a)')'initl: wrong epmax'
5573         if(pt2cut0 .ne.pt2cut )write(ifmt,'(a)')'initl: wrong pt2cut'
5574         if(qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min .or.q2ini0 .ne.q2ini
5575      *  .or.naflav0.ne.naflav.or.epmax0 .ne.epmax.or. pt2cut.ne.pt2cut0)
5576      *  then
5577           write(ifmt,'(//a//)')'   initl has to be reinitialized!!!'
5578           stop
5579         endif
5580         read (1,*)csbor,csord,cstot,cstotzero,csborzer
5581         close(1)
5582        endif
5583
5584        goto 1
5585       endif
5586
5587       write(ifmt,'(a)')'initl does not exist -> calculate tables  ...'
5588
5589       write (*,*)'Born xsection csbor'
5590       spmin=4.*q2min
5591       spminc=4.*q2min+qcmass**2
5592       do m=1,4   !parton type at upper end of the ladder (1...4 - g,u,d,c)
5593       do k=1,20
5594         if(m.ne.4)then
5595           sk=spmin*(epmax/2./spmin)**((k-1)/19.)
5596           p1=sk
5597         else
5598           sk=spminc*(epmax/2./spminc)**((k-1)/19.)
5599           p1=sk/(1.+qcmass**2/sk)
5600         endif
5601         qmax=p1/4.
5602       do i=1,20
5603         qq=q2min*(qmax/q2min)**((i-1)/19.)
5604       do l=1,2    !parton type at lower end of the ladder
5605         k1=k+20*(m-1)+80*(l-1)
5606         m1=m-1
5607         if(m.eq.3.and.l.eq.1)then  !dd~
5608           l1=-m1
5609         else                       !du
5610           l1=l-1
5611         endif                                       !born cr.-sect.
5612         csbor(i,k1,1)=log(max(1.e-30,psborn(qq,qq,qq,sk,m1,l1,0,0)))
5613         if(m.ne.4)then
5614         csbor(i,k1,2)=log(max(1.e-30,psborn(4.*qq,qq,qq,sk,m1,l1,1,0)))
5615         endif
5616       enddo
5617       enddo
5618       enddo
5619       enddo
5620
5621       write (*,*)'ordered jet xsection csord'
5622       do m=1,4            !parton type at upper end of the ladder
5623       do k=1,20
5624         write (*,*)'   m=',m,'/4  k=',k,'/20'
5625         if(m.ne.4)then
5626           sk=spmin*(epmax/2./spmin)**((k-1)/19.)  !c.m. energy squared for the hard
5627           p1=sk
5628         else
5629           sk=spminc*(epmax/2./spminc)**((k-1)/19.)
5630           p1=sk/(1.+qcmass**2/sk)
5631         endif
5632         qmax=p1/4.
5633         tmax=p1/2.
5634       do i=1,20             !cross-sections initialization
5635         qi=q2min*(qmax/q2min)**((i-1)/19.)
5636       do j=1,20
5637         qq=qi*(qmax/qi)**((j-1)/19.)
5638         if(p1.gt.4.*qq)then
5639           tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
5640         else
5641           tmin=2.*qq
5642         endif
5643       do l=1,2              !parton type at lower end of the ladder
5644         m1=m-1
5645         if(m.eq.3.and.l.eq.1)then
5646           l1=-m1
5647         else
5648           l1=l-1
5649         endif
5650         if(m.ne.4)then
5651           k1=k+20*(m-1)+60*(l-1)
5652           if(k.eq.1.or.i.eq.20.or.j.eq.20)then
5653             csord(i,j,k1)=log(max(1.e-30,psborn(qi,qq,qq,sk,m1,l1,0,0)))
5654             csord(i,j,k1+120)=
5655      *                 log(max(1.e-30,psborn(4.*qq,qi,qq,sk,l1,m1,1,0)))
5656           else
5657             csord(i,j,k1)=log(psjet1(qi,qq,qq,sk,m1,l1,0)
5658      *      /(1./tmin-1./tmax)+psborn(qi,qq,qq,sk,m1,l1,0,0))
5659             csord(i,j,k1+120)=log(psjet1(qi,4.*qq,qq,sk,m1,l1,2)
5660      *      /(1./tmin-1./tmax)+psborn(4.*qq,qi,qq,sk,l1,m1,1,0))
5661
5662           endif
5663         elseif(j.eq.1)then
5664           if(k.eq.1.or.i.eq.20)then
5665          cschar(i,k,l)=log(max(1.e-30,psborn(q2min,qi,qq,sk,m1,l1,0,0)))
5666           else
5667             cschar(i,k,l)=log(psjet1(qi,q2min,qq,sk,l1,m1,0)
5668      *      /(1./tmin-1./tmax)+psborn(q2min,qi,qq,sk,m1,l1,0,0))
5669           endif
5670         endif
5671       enddo
5672       enddo
5673       enddo
5674       enddo
5675       enddo
5676
5677       write (ifmt,*)'tests:'
5678       write (ifmt,'(a,a)')' n-1      sk       qi       qj       qq  '
5679      * ,'      born   born-i      ord    ord-i  '
5680       do k=1,7
5681           sk=spmin*(epmax/2./spmin)**((k-1)/19.)
5682           if(k.ge.5)sk=spmin*1.5**(k-4)
5683       do n=1,2
5684         if(n.eq.1)then
5685           qmax1=sk/4.
5686           qmax2=sk/4.
5687         elseif(n.eq.2)then
5688           qmax1=sk/4.
5689           qmax2=sk
5690         endif
5691       do i=1,3
5692         qi=q2min*(qmax1/q2min)**((i-1)/3.)
5693       do j=1,3
5694         qj=q2min*(qmax2/q2min)**((j-1)/3.)
5695         qqmax=sk/4.
5696         if(n.eq.1)then
5697           qqmin=max(qi,qj)
5698         else
5699           qqmin=max(qi,qj/4.)
5700         endif
5701       do lq=1,3
5702         qq=qqmin*(qqmax/qqmin)**((lq-1)/3.)
5703         if(sk.gt.4.*qq)then
5704           tmin=2.*qq/(1.+sqrt(1.-4.*qq/sk))
5705         else
5706           tmin=2.*qq
5707         endif
5708         tmax=sk/2.
5709       do m=1,1             !parton type at upper end of the ladder (1
5710       do l=1,1              !parton type at lower end of the ladder (1
5711         m1=m-1
5712         if(m.eq.3.and.l.eq.1)then
5713           l1=-m1
5714         else
5715           l1=l-1
5716         endif
5717        a=psborn(qj,qi,qq,sk,l1,m1,n-1,0)*(1./tmin-1./tmax)
5718        b=psbint(qj,qi,qq,sk,l1,m1,n-1)
5719        c=psjet1(qi,qj,qq,sk,m1,l1,2*(n-1))
5720      *    +psborn(qj,qi,qq,sk,l1,m1,n-1,0)*(1./tmin-1./tmax)
5721        d=psjti1(qi,qj,qq,sk,m1,l1,n-1)
5722        write (ifmt,'(i3,4f9.1,3x,4f9.4)')n-1,sk,qi,qj,qq,a,b,c,d
5723       enddo
5724       enddo
5725       enddo
5726       enddo
5727       enddo
5728       enddo
5729       enddo
5730
5731       write (*,*)'jet xsection cstot'
5732       do k=1,20
5733         write (*,*)'k=',k,'/20'
5734         sk=spmin*(epmax/2./spmin)**((k-1)/19.)  !c.m. energy squared for the hard
5735         qmax=sk/4.
5736         tmax=sk/2.
5737       do i=1,20             !cross-sections initialization
5738       do n=1,2
5739         if(n.eq.1)then
5740           qi=q2min*(qmax/q2min)**((i-1)/19.)
5741         else
5742           qi=q2min*(4.*qmax/q2min)**((i-1)/19.)
5743         endif
5744       do j=1,20
5745         if(n.eq.1)then
5746           qq=qi*(qmax/qi)**((j-1)/19.)
5747         else
5748           qq=max(q2min,qi/4.)*(qmax/max(q2min,qi/4.))**
5749      *    ((j-1)/19.)
5750         endif
5751         if(sk.gt.4.*qq)then
5752           tmin=2.*qq/(1.+sqrt(1.-4.*qq/sk))
5753         else
5754           tmin=2.*qq
5755         endif
5756       do m=1,3              !parton type at upper end of the ladder (1
5757       do l=1,2              !parton type at lower end of the ladder (1
5758         m1=m-1
5759         if(m.eq.3.and.l.eq.1)then
5760           l1=-m1
5761         else
5762           l1=l-1
5763         endif
5764         k1=k+20*(m-1)+60*(l-1)+120*(n-1)
5765         if(k.eq.1.or.i.eq.20.or.j.eq.20)then
5766        cstot(i,j,k1)=log(max(1.e-30,psborn(qi,q2min,qq,sk,m1,l1,n-1,0)))
5767         else
5768           if(n.eq.1)then
5769             cstot(i,j,k1)=log((psjet(qi,q2min,qq,sk,m1,l1,0)+
5770      *      psjti1(qi,q2min,qq,sk,m1,l1,0)+
5771      *      psjti1(q2min,qi,qq,sk,l1,m1,0)
5772      *      -psbint(qi,q2min,qq,sk,m1,l1,0))/(1./tmin-1./tmax))
5773           else
5774             cstot(i,j,k1)=log((psjet(qi,q2min,qq,sk,m1,l1,1)+
5775      *      psjet1(qi,q2min,qq,sk,m1,l1,1)+
5776      *      psjti1(q2min,qi,qq,sk,l1,m1,1))/(1./tmin-1./tmax))
5777           endif
5778         endif
5779       enddo
5780       enddo
5781       enddo
5782       enddo
5783       enddo
5784       enddo
5785
5786 c total and born hard cross-sections logarithms for minimal cutoff
5787 c (q2min), interpolated in the psjti0 procedure
5788 2     spmin=4.*q2min
5789       spminc=4.*q2min+qcmass**2
5790       do m=1,4
5791       do l=1,2
5792         m1=m-1
5793         if(m.eq.3.and.l.eq.1)then
5794           l1=-m1
5795         else
5796           l1=l-1
5797         endif
5798       do k=1,20
5799         if(m.ne.4)then
5800           sk=spmin*(epmax/2./spmin)**((k-1)/19.)  !c.m. energy squared for the hard
5801           p1=sk
5802           qq=q2min
5803         else
5804           sk=spminc*(epmax/2./spminc)**((k-1)/19.)
5805           p1=sk/(1.+qcmass**2/sk)
5806           qq=q2min
5807         endif
5808         if(p1.gt.4.*qq)then
5809           tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
5810         else
5811           tmin=2.*qq
5812         endif
5813         tmax=p1/2.
5814
5815         k1=k+20*(m-1)+80*(l-1)
5816         csborzer(k,m,l)
5817      *      =log(max(1.e-30,psborn(q2min,q2min,qq,sk,m1,l1,0,0)))
5818         if(k.eq.1)then
5819           cstotzero(k,m,l)=csborzer(k,m,l)
5820         elseif(m.ne.4)then
5821           cstotzero(k,m,l)=log(psjti(q2min,qq,sk,m1,l1,0)/
5822      *    (1./tmin-1./tmax))
5823         else
5824           smins=2.5*q2min*(1.+sqrt(1.+4.*qcmass**2/q2min))
5825           if(sk.le.smins)then
5826             cstotzero(k,m,l)=log(psjci(q2min,sk,l1)/(1./tmin-1./tmax))
5827           else
5828             cstotzero(k,m,l)=log((psjci(q2min,sk,l1)+psjct(sk,l1))
5829      *      /(1./tmin-1./tmax))
5830           endif
5831         endif
5832       enddo
5833       enddo
5834       enddo
5835
5836       write(ifmt,'(a)')'write to initl ...'
5837       open(1,file=fnii(1:nfnii),status='unknown')
5838       write (1,*)qcdlam,q2min,q2ini,naflav,epmax,pt2cut
5839       write (1,*)csbor,csord,cstot,cstotzero,csborzer,cschar
5840       close(1)
5841
5842 1     continue
5843
5844       if(iappl.ne.8)goto 3
5845       if(ish.ge.3)write(ifch,*)'dis cross sections ...'
5846       inquire(file=fnid(1:nfnid),exist=lcalc)
5847       if(lcalc)then
5848        if(inicnt.eq.1)then
5849         write(ifmt,'(3a)')'read from ',fnid(1:nfnid),' ...'
5850         open(1,file=fnid(1:nfnid),status='old')
5851         read (1,*)qcdlam0,q2min0,q2ini0,naflav0,epmax0,edmax0
5852         if(qcdlam0.ne.qcdlam)write(ifmt,'(a)')'inidi: wrong qcdlam'
5853         if(q2min0 .ne.q2min )write(ifmt,'(a)')'inidi: wrong q2min'
5854         if(q2ini0 .ne.q2ini )write(ifmt,'(a)')'inidi: wrong q2ini'
5855         if(naflav0.ne.naflav)write(ifmt,'(a)')'inidi: wrong naflav'
5856         if(epmax0 .ne.epmax )write(ifmt,'(a)')'inidi: wrong epmax'
5857         if(edmax0 .ne.edmax )write(ifmt,'(a)')'inidi: wrong edmax'
5858         if(qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min.or.q2ini0 .ne.q2ini
5859      *  .or.naflav0.ne.naflav.or.epmax0 .ne.epmax
5860      *  .or.edmax0 .ne.edmax)then
5861            write(ifmt,'(//a//)')'   inidi has to be reinitialized!!!'
5862            stop
5863         endif
5864         read (1,*)csdsi,csds,csdt,csdr
5865         close(1)
5866        endif
5867        goto 3
5868       endif
5869
5870       write(ifmt,'(a)')'inidi does not exist -> calculate tables  ...'
5871       do j=1,21
5872         qq=q2min*exp(.5*(j-1))                !photon virtuality
5873
5874         do m=1,2               !parton type at the end of the ladder
5875           q2mass=qcmass**2
5876           s2min=4.*max(q2mass,q2min)+qq
5877           if(m.eq.2)s2min=s2min/(1.-4.*q2ini/(s2min-qq))
5878         do k=1,26
5879           write (*,*)'sin,j,m,k',j,m,k
5880           sk=s2min*(edmax/s2min)**(.04*(k-1))      !c.m. energy squared
5881           if(k.eq.26)sk=1.01*sk
5882           qmin=q2min
5883           if(m.eq.1)then
5884             qmax=(sk-qq)/4.
5885           else
5886             qmax=(sk-qq+sqrt((sk-qq)**2-16.*sk*q2ini))/8.
5887           endif
5888
5889           do i=1,21               !cross-sections calculation
5890             qi=qmin*(qmax/qmin)**((i-1)/20.)
5891             tmax=.5*sk
5892             qtq=4.*max(q2mass,qi)/(sk-qq)
5893             if(qtq.lt.1.)then
5894               tmin=.5*sk*qtq/(1.+sqrt(1.-qtq))
5895             else
5896               tmin=.5*sk
5897             endif
5898
5899             do ilong=1,2
5900               k1=k+26*(m-1)+52*(ilong-1)
5901               if(m.eq.1)then
5902                 if(tmax.gt.1.01*tmin)then
5903                   sij=psds(qi,qq,sk,m-1,ilong-1)
5904                   if(sij.lt.0.)write (*,*)'qi,qq,sk,m,long,sij',
5905      *            qi,qq,sk,m,ilong,sij
5906                   csdsi(i,j,k1)=log(max(0.,sij)/(1./tmin-1./tmax)
5907      *            +psdbor(qi,qq,sk,ilong-1))
5908                 else
5909                   csdsi(i,j,k1)=
5910      *            log(max(1.e-25,psdbor(qi,qq,sk,ilong-1)))
5911                 endif
5912               else
5913                 csdsi(i,j,k1)=psds(qi,qq,sk,m-1,ilong-1)
5914               endif
5915             enddo
5916           enddo
5917         enddo
5918         enddo
5919       enddo
5920
5921 800     continue
5922       do j=1,21
5923         qq=q2min*exp(.5*(j-1))                       !photon virtuality
5924         s2min=max(4.*qq,16.*q2min)    !pt2dis=qq
5925       do m=1,2
5926       do k=1,26
5927         do ilong=1,2
5928           k1=k+26*(m-1)+52*(ilong-1)
5929           csds(j,k,m+2*(ilong-1))=csdsi(1,j,k1)
5930         enddo
5931
5932         sk=(s2min+qq)*(edmax/(s2min+qq))**(.04*(k-1))
5933         csdt(j,k,m)=psdres(qq,sk,s2min,m-1)
5934         csdr(j,k,m)=psdrga(qq,sk-qq,s2min,m-1)
5935       enddo
5936       enddo
5937       enddo
5938
5939       write(ifmt,'(a)')'write to inidi ...'
5940
5941       write(ifmt,'(a)')'write to inidi ...'
5942       open(1,file=fnid(1:nfnid),status='unknown')
5943       write (1,*)qcdlam,q2min,q2ini,naflav,epmax,edmax
5944       write (1,*)csdsi,csds,csdt,csdr
5945       close(1)
5946 3     continue
5947
5948 c---------------------------------------
5949 c tabulation of semihard eikonals
5950 c---------------------------------------
5951
5952 !!!!!!!!!      if(iappl.eq.1)then
5953
5954       if(ish.ge.4)write(ifch,*)'semihard eikonals ...'
5955 5     continue
5956       inquire(file=fnrj,exist=lcalc)
5957       if(lcalc)then
5958        if(inicnt.eq.1)then
5959         write(ifmt,'(3a)')'read from ',fnrj(1:nfnrj),' ...'
5960         open(1,file=fnrj(1:nfnrj),status='old')
5961         read (1,*)alpqua0,alplea0,alppom0,slopom0,
5962      *  gamhad0,r2had0,chad0,
5963      *  qcdlam0,q2min0,q2ini0,betpom0,glusea0,naflav0,
5964      *  factk0,pt2cut0,gamtil0
5965         if(alpqua0.ne.alpqua)write(ifmt,'(a,2f8.4)')
5966      *  'inirj: wrong alpqua',alpqua0,alpqua
5967         if(alppom0.ne.alppom)write(ifmt,'(a,2f8.4)')
5968      *  'inirj: wrong alppom',alppom0,alppom
5969         if(slopom0.ne.slopom)write(ifmt,'(a,2f8.4)')
5970      *  'inirj: wrong slopom',slopom0,slopom
5971         iii=2
5972         if(gamhad0(iii).ne.gamhad(iii))write(ifmt,'(a,i1,a,2f8.4)')
5973      *  'inirj: wrong gamhad(',iii,')',gamhad0(iii),gamhad(iii)
5974         do iii=1,3
5975         if(r2had0(iii) .ne.r2had(iii) )write(ifmt,'(a,i1,a,2f8.4)')
5976      *  'inirj: wrong r2had(',iii,')',r2had0(iii),r2had(iii)
5977         if(chad0(iii)  .ne.chad(iii)  )write(ifmt,'(a,i1,a,2f8.4)')
5978      *  'inirj: wrong chad(',iii,')',chad0(iii),chad(iii)
5979         if(alplea0(iii).ne.alplea0(iii))write(ifmt,'(a,i1,a,2f8.4)')
5980      *  'inirj: wrong alplea(',iii,')',alplea0(iii),alplea(iii)
5981         enddo
5982         if(qcdlam0.ne.qcdlam)write(ifmt,'(a,2f8.4)')
5983      *  'inirj: wrong qcdlam',qcdlam0,qcdlam
5984         if(q2min0 .ne.q2min )write(ifmt,'(a,2f8.4)')
5985      *  'inirj: wrong q2min',q2min0,q2min
5986         if(q2ini0 .ne.q2ini )write(ifmt,'(a,2f8.4)')
5987      *  'inirj: wrong q2ini',q2ini0,q2ini
5988         if(betpom0.ne.betpom)write(ifmt,'(a,2f8.4)')
5989      *  'inirj: wrong betpom',betpom0,betpom
5990         if(glusea0.ne.glusea)write(ifmt,'(a,2f8.4)')
5991      *  'inirj: wrong glusea',glusea0,glusea
5992         if(naflav0.ne.naflav)write(ifmt,'(a,2f8.4)')
5993      *  'inirj: wrong naflav',naflav0,naflav
5994         if(factk0 .ne.factk )write(ifmt,'(a,2f8.4)')
5995      *  'inirj: wrong factk', factk0,factk
5996         if(pt2cut0 .ne.pt2cut )write(ifmt,'(a,2f8.4)')
5997      *  'inirj: wrong pt2cut', pt2cut0,pt2cut
5998         if(gamtil0 .ne.gamtil )write(ifmt,'(a,2f8.4)')
5999      *  'inirj: wrong gamtil', gamtil0,gamtil
6000         if(alpqua0.ne.alpqua.or.alppom0.ne.alppom
6001      *  .or.slopom0.ne.slopom.or.gamhad0(2).ne.gamhad(2)
6002      *  .or.r2had0(1).ne.r2had(1).or.r2had0(2).ne.r2had(2)
6003      *  .or.r2had0(3).ne.r2had(3)
6004      *  .or.chad0(1).ne.chad(1).or.chad0(2).ne.chad(2)
6005      *  .or.chad0(3).ne.chad(3)
6006      *  .or.alplea0(1).ne.alplea(1).or.alplea0(2).ne.alplea(2)
6007      *  .or.alplea0(3).ne.alplea(3)
6008      *  .or.qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min
6009      *  .or.q2ini0 .ne.q2ini.or.gamtil0.ne.gamtil
6010      *  .or.betpom0.ne.betpom.or.glusea0.ne.glusea.or.naflav0.ne.naflav
6011      *  .or.factk0 .ne.factk .or.pt2cut0.ne.pt2cut)then
6012            write(ifmt,'(//a//)')'   inirj has to be reinitialized!!!!'
6013            stop
6014         endif
6015
6016         read(1,*)fhgg,fhqg,fhgq,fhqq,fhgg0,fhgg1,fhqg1
6017      *  ,fhgg01,fhgg02,fhgg11,fhgg12,fhqg11,fhqg12
6018      *  ,ftoint,vfro,vnorm,coefxu1,coefxu2,coefxc2
6019         read(1,*)bkbin0,iclpro10,iclpro20,icltar10,icltar20,iclegy10
6020      *   ,iclegy20,egylow0,egymax0,iomega0,egyscr0,epscrw0,epscrp0
6021         if(isetcs.gt.1)then
6022         textini='                                      '
6023         if(iclpro10.ne.iclpro1)write(textini,'(a,2i8)')
6024      *  'inirj: wrong iclpro1  ',iclpro10,iclpro1
6025         if(iclpro20.ne.iclpro2)write(textini,'(a,2i8)')
6026      *  'inirj: wrong iclpro2  ',iclpro20,iclpro2
6027         if(icltar10.ne.icltar1)write(textini,'(a,2i8)')
6028      *  'inirj: wrong icltar1  ',icltar10,icltar1
6029         if(icltar20.ne.icltar2)write(textini,'(a,2i8)')
6030      *  'inirj: wrong icltar2  ',icltar20,icltar2
6031         if(iclegy10.ne.iclegy1)write(textini,'(a,2i8)')
6032      *  'inirj: wrong iclegy1  ',iclegy10,iclegy1
6033         if(iclegy20.ne.iclegy2)write(textini,'(a,2i8)')
6034      *  'inirj: wrong iclegy2  ',iclegy20,iclegy2
6035         if(egylow0.ne.egylow)write(textini,'(a,2f8.4)')
6036      *  'inirj: wrong egylow   ',egylow0,egylow
6037         if(egymax0.ne.egymax)write(textini,'(a,2f8.4)')
6038      *  'inirj: wrong egymax   ',egymax0,egymax
6039         if(epscrw0.ne.epscrw)write(textini,'(a,2f8.4)')
6040      *  'inirj: wrong epscrw    ',epscrw0,epscrw
6041         if(epscrp0.ne.epscrp)write(textini,'(a,2f8.4)')
6042      *  'inirj: wrong epscrp   ',epscrp0,epscrp
6043         if(bkbin0.ne.bkbin)write(textini,'(a,2f8.4)')
6044      *  'inirj: wrong bkbin',bkbin0,bkbin
6045         if(textini.ne.'                                      ')then
6046            write(ifmt,'(//10x,a//10x,a//)')textini,
6047      *     'inirj has to be reinitialized!!!!'
6048            stop
6049         endif
6050         do iiipro=iclpro1,iclpro2
6051         do iiitar=icltar1,icltar2
6052         do iiiegy=iclegy1,iclegy2
6053         do iiib=1,nbkbin
6054           read(1,*)xkappafit(iiiegy,iiipro,iiitar,iiib)
6055         enddo
6056         xkappafit(iiiegy,iiipro,iiitar,nbkbin)=1.
6057         do iiib=2,nbkbin-1
6058           if(xkappafit(iiiegy,iiipro,iiitar,iiib).lt.1.)then
6059             xkappafit(iiiegy,iiipro,iiitar,iiib)=max(1.,0.5*
6060      *        (xkappafit(iiiegy,iiipro,iiitar,iiib-1)
6061      *        +xkappafit(iiiegy,iiipro,iiitar,iiib+1)))
6062           endif
6063         enddo
6064         do iiidf=idxD0,idxD
6065          read(1,*)alpDs(iiidf,iiiegy,iiipro,iiitar),
6066      *   alpDps(iiidf,iiiegy,iiipro,iiitar),
6067      *   alpDpps(iiidf,iiiegy,iiipro,iiitar),
6068      *   betDs(iiidf,iiiegy,iiipro,iiitar),
6069      *   betDps(iiidf,iiiegy,iiipro,iiitar),
6070      *   betDpps(iiidf,iiiegy,iiipro,iiitar),
6071      *   gamDs(iiidf,iiiegy,iiipro,iiitar),
6072      *   delDs(iiidf,iiiegy,iiipro,iiitar)
6073         enddo
6074         enddo
6075         enddo
6076         enddo
6077       endif
6078
6079         close(1)
6080
6081       endif
6082
6083
6084         goto 4
6085       endif
6086
6087       write(ifmt,'(a)')'inirj does not exist -> calculate tables  ...'
6088
6089       engysave=engy
6090       maprojsave=maproj
6091       matargsave=matarg
6092       iclpros=iclpro
6093       icltars=icltar
6094       spmin=4.*q2min
6095       spminc=4.*q2min+2.*qcmass**2
6096       icltar=2
6097
6098       write(ifmt,'(a)')'  tabulate om5 ...'
6099
6100       do iy=1,11
6101         sy=spmin*(epmax/2./spmin)**((iy-1)/10.)
6102         syc=spminc*(epmax/2./spminc)**((iy-1)/10.)
6103         iclpro=2
6104         icltar=2
6105         if(iy.eq.1)then
6106           fhgg01(iy)=-80.
6107           fhgg02(iy)=-80.
6108         else
6109           fhgg01(iy)=log(om51pp(sy,1.,1.,3))
6110           fhgg02(iy)=log(om51pp(sy,1.,1.,7))
6111         endif
6112
6113         do iclpro=iclpro1,iclpro2
6114           if(iy.eq.1)then
6115             fhgg11(iy,iclpro)=-80.
6116             fhgg12(iy,iclpro)=-80.
6117           else
6118             fhgg11(iy,iclpro)=log(om51pp(sy,1.,1.,4))
6119             fhgg12(iy,iclpro)=log(om51pp(sy,1.,1.,9))
6120           endif
6121           do ix=1,10
6122             if(ix.le.5)then
6123               xp=.1*2.**(ix-5)
6124             else
6125               xp=.2*(ix-5)
6126             endif
6127             if(iy.eq.1)then
6128               fhqg11(iy,ix,iclpro)=-80.
6129               fhqg12(iy,ix,iclpro)=-80.
6130             elseif(iclpro.eq.4)then
6131               fhqg11(iy,ix,iclpro)=log(om51pp(syc,1.,1.,5))
6132               fhqg12(iy,ix,iclpro)=log(om51pp(syc,1.,1.,11))
6133             else
6134               fhqg11(iy,ix,iclpro)=log(om51pp(sy,xp,1.,5))
6135               fhqg12(iy,ix,iclpro)=log(om51pp(sy,xp,1.,11))
6136             endif
6137           enddo
6138         enddo
6139
6140       do iz=1,10
6141         z=.1*iz
6142
6143         iclpro=2
6144         icltar=2
6145         if(iy.eq.1)then
6146           fhgg0(iy,iz)=-80.
6147         else
6148           fhgg0(iy,iz)=log(om51pp(sy,1.,z,6)/z)
6149         endif
6150
6151         do iclpro=iclpro1,iclpro2
6152           if(iy.eq.1)then
6153             fhgg1(iy,iz,iclpro)=-80.
6154           else
6155             fhgg1(iy,iz,iclpro)=log(om51pp(sy,1.,z,8)/z)
6156           endif
6157
6158           do ix=1,10
6159             if(ix.le.5)then
6160               xp=.1*2.**(ix-5)
6161             else
6162               xp=.2*(ix-5)
6163             endif
6164             if(iy.eq.1)then
6165               fhqg1(iy,ix,iz+10*(iclpro-1))=-80.
6166             elseif(iclpro.eq.4)then
6167               fhqg1(iy,ix,iz+10*(iclpro-1))=log(om51pp(syc,xp,z,10)/z)
6168             else
6169               fhqg1(iy,ix,iz+10*(iclpro-1))=log(om51pp(sy,xp,z,10)/z)
6170             endif
6171           enddo
6172         enddo
6173       enddo
6174       enddo
6175
6176       do iclpro=iclpro1,iclpro2 !hadron type (1 - pion, 2 - nucleon, 3 - kaon, 4 - charm)
6177       do icltar=icltar1,icltar2 !hadron type (2 - nucleon)
6178         do iy=1,11
6179           sy=spmin*(epmax/2./spmin)**((iy-1)/10.)
6180           syc=spminc*(epmax/2./spminc)**((iy-1)/10.)
6181           do iz=1,10
6182             z=.1*iz
6183             if(iy.eq.1)then
6184               fhgg(iy,iz,iclpro+4*(icltar-1))=-80.
6185             else
6186               fhgg(iy,iz,iclpro+4*(icltar-1))=log(om51pp(sy,1.,z,0)/z)
6187             endif
6188
6189           do ix=1,10
6190             if(ix.le.5)then
6191               xp=.1*2.**(ix-5)
6192             else
6193               xp=.2*(ix-5)
6194             endif
6195             if(iy.eq.1)then
6196               fhqg(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=-80.
6197               fhgq(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=-80.
6198             else
6199               if(iclpro.ne.4)then
6200                 syx=sy
6201               else
6202                 syx=syc
6203               endif
6204               fhqg(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=
6205      *        log(om51pp(syx,xp,z,1)/z)
6206               if(icltar.ne.4)then
6207                 syx=sy
6208               else
6209                 syx=syc
6210               endif
6211               fhgq(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=
6212      *        log(om51pp(syx,xp,z,2)/z)
6213             endif
6214           enddo
6215           enddo
6216
6217           do ix1=1,10
6218             if(ix1.le.5)then
6219               xpp=.1*2.**(ix1-5)
6220             else
6221               xpp=.2*(ix1-5)
6222             endif
6223           do ix2=1,10
6224             if(ix2.le.5)then
6225               xmm=.1*2.**(ix2-5)
6226             else
6227               xmm=.2*(ix2-5)
6228             endif
6229
6230             if(iy.eq.1)then
6231               fhqq(iy,ix1,ix2+10*(iclpro+4*(icltar-1)-1))=-80.
6232             else
6233               if(iclpro.ne.4.and.icltar.ne.4)then
6234                 syx=sy
6235               else
6236                 syx=syc
6237               endif
6238               fhqq(iy,ix1,ix2+10*(iclpro+4*(icltar-1)-1))=
6239      *        log(pshard(syx,xpp,xmm))
6240             endif
6241           enddo
6242           enddo
6243         enddo
6244       enddo
6245
6246       enddo
6247
6248       if(isetcs.gt.1)then
6249
6250
6251         write(ifmt,'(a)')'  tabulate fit parameters ...'
6252
6253       engysave=engy
6254       do iclpro=iclpro1,iclpro2 !hadron type (1 - pion, 2 - nucleon, 3 - kaon, 4 - charm)
6255       do icltar=icltar1,icltar2 !hadron type (2 - nucleon)
6256       do iclegy=iclegy2,iclegy1,-1
6257         call param
6258       enddo
6259       do iiclegy=iclegy2,iclegy1,-1
6260         engy=egyfac**(iiclegy-1)*egylow
6261         call paramini(0)
6262         call Kfit(iiclegy)
6263       enddo
6264       enddo
6265       enddo
6266       engy=engysave
6267
6268       endif
6269
6270       write(ifmt,'(a)')'  write to inirj ...'
6271       open(1,file=fnrj,status='unknown')
6272       write (1,*)alpqua,alplea,alppom,slopom,gamhad,r2had,chad,
6273      *qcdlam,q2min,q2ini,betpom,glusea,naflav,factk,pt2cut,gamtil
6274       write (1,*)fhgg,fhqg,fhgq,fhqq,fhgg0,fhgg1,fhqg1
6275      *,fhgg01,fhgg02,fhgg11,fhgg12,fhqg11,fhqg12
6276      *,ftoint,vfro,vnorm,coefxu1,coefxu2,coefxc2
6277       write(1,*)bkbin,iclpro1,iclpro2,icltar1,icltar2,iclegy1,iclegy2
6278      *,egylow,egymax,iomega,egyscr,epscrw,epscrp
6279       do iiipro=iclpro1,iclpro2
6280        do iiitar=icltar1,icltar2
6281         do iiiegy=iclegy1,iclegy2
6282         do iiib=1,nbkbin
6283           write(1,*)xkappafit(iiiegy,iiipro,iiitar,iiib)
6284         enddo
6285         do iiidf=idxD0,idxD
6286          write(1,*)alpDs(iiidf,iiiegy,iiipro,iiitar),
6287      *   alpDps(iiidf,iiiegy,iiipro,iiitar),
6288      *   alpDpps(iiidf,iiiegy,iiipro,iiitar),
6289      *   betDs(iiidf,iiiegy,iiipro,iiitar),
6290      *   betDps(iiidf,iiiegy,iiipro,iiitar),
6291      *   betDpps(iiidf,iiiegy,iiipro,iiitar),
6292      *   gamDs(iiidf,iiiegy,iiipro,iiitar),
6293      *   delDs(iiidf,iiiegy,iiipro,iiitar)
6294         enddo
6295         enddo
6296        enddo
6297       enddo
6298
6299       close(1)
6300
6301       engy=engysave
6302       maproj=maprojsave
6303       matarg=matargsave
6304       iclpro=iclpros
6305       icltar=icltars
6306       inicnt=1
6307       goto 5
6308
6309 4     continue
6310
6311 c--------------------------------------
6312 c inelastic cross sections
6313 c---------------------------------------
6314
6315       if(isetcs.ge.2)then !--------------------
6316
6317       if(ish.ge.4)write(ifch,*)'cross sections ...'
6318  6    continue
6319       inquire(file=fncs,exist=lcalc)
6320       if(lcalc)then
6321        if(inicnt.eq.1)then
6322         write(ifmt,'(3a)')'read from ',fncs(1:nfncs),' ...'
6323         open(1,file=fncs(1:nfncs),status='old')
6324         read (1,*)alpqua0,alplea0,alppom0,slopom0,
6325      *  gamhad0,r2had0,chad0,
6326      *  qcdlam0,q2min0,q2ini0,betpom0,glusea0,naflav0,
6327      *  factk0,pt2cut0
6328         if(alpqua0.ne.alpqua)write(ifmt,'(a,2f8.4)')
6329      *  'inics: wrong alpqua',alpqua0,alpqua
6330         if(alppom0.ne.alppom)write(ifmt,'(a,2f8.4)')
6331      *  'inics: wrong alppom',alppom0,alppom
6332         if(slopom0.ne.slopom)write(ifmt,'(a,2f8.4)')
6333      *  'inics: wrong slopom',slopom0,slopom
6334         iii=2
6335         if(gamhad0(iii).ne.gamhad(iii))write(ifmt,'(a,i1,a,2f8.4)')
6336      *  'inics: wrong gamhad(',iii,')',gamhad0(iii),gamhad(iii)
6337         do iii=1,3
6338         if(r2had0(iii) .ne.r2had(iii) )write(ifmt,'(a,i1,a,2f8.4)')
6339      *  'inics: wrong r2had(',iii,')',r2had0(iii),r2had(iii)
6340         if(chad0(iii)  .ne.chad(iii)  )write(ifmt,'(a,i1,a,2f8.4)')
6341      *  'inics: wrong chad(',iii,')',chad0(iii),chad(iii)
6342         if(alplea0(iii).ne.alplea0(iii))write(ifmt,'(a,i1,a,2f8.4)')
6343      *  'inics: wrong alplea(',iii,')',alplea0(iii),alplea(iii)
6344         enddo
6345         if(qcdlam0.ne.qcdlam)write(ifmt,'(a,2f8.4)')
6346      *  'inics: wrong qcdlam',qcdlam0,qcdlam
6347         if(q2min0 .ne.q2min )write(ifmt,'(a,2f8.4)')
6348      *  'inics: wrong q2min',q2min0,q2min
6349         if(q2ini0 .ne.q2ini )write(ifmt,'(a,2f8.4)')
6350      *  'inics: wrong q2ini',q2ini0,q2ini
6351         if(betpom0.ne.betpom)write(ifmt,'(a,2f8.4)')
6352      *  'inics: wrong betpom',betpom0,betpom
6353         if(glusea0.ne.glusea)write(ifmt,'(a,2f8.4)')
6354      *  'inics: wrong glusea',glusea0,glusea
6355         if(naflav0.ne.naflav)write(ifmt,'(a,2f8.4)')
6356      *  'inics: wrong naflav',naflav0,naflav
6357         if(factk0 .ne.factk )write(ifmt,'(a,2f8.4)')
6358      *  'inics: wrong factk', factk0,factk
6359         if(pt2cut0 .ne.pt2cut )write(ifmt,'(a,2f8.4)')
6360      *  'inics: wrong pt2cut', pt2cut0,pt2cut
6361         if(alpqua0.ne.alpqua.or.alppom0.ne.alppom
6362      *  .or.slopom0.ne.slopom.or.gamhad0(2).ne.gamhad(2)
6363      *  .or.r2had0(1).ne.r2had(1).or.r2had0(2).ne.r2had(2)
6364      *  .or.r2had0(3).ne.r2had(3)
6365      *  .or.chad0(1).ne.chad(1).or.chad0(2).ne.chad(2)
6366      *  .or.chad0(3).ne.chad(3)
6367      *  .or.alplea0(1).ne.alplea(1).or.alplea0(2).ne.alplea(2)
6368      *  .or.alplea0(3).ne.alplea(3)
6369      *  .or.qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min
6370      *  .or.q2ini0 .ne.q2ini
6371      *  .or.betpom0.ne.betpom.or.glusea0.ne.glusea.or.naflav0.ne.naflav
6372      *  .or.factk0 .ne.factk .or.pt2cut0.ne.pt2cut)then
6373            write(ifmt,'(//a//)')'   inics has to be reinitialized!!!!'
6374            stop
6375         endif
6376
6377         read(1,*)isetcs0,iclpro10,iclpro20,icltar10,icltar20,iclegy10
6378      *   ,iclegy20,egylow0,egymax0,iomega0,egyscr0,epscrw0,epscrp0
6379
6380         if(iclpro10.ne.iclpro1)write(ifmt,'(a,2i2)')
6381      *  'inics: wrong iclpro1',iclpro10,iclpro1
6382         if(iclpro20.ne.iclpro2)write(ifmt,'(a,2i2)')
6383      *  'inics: wrong iclpro2',iclpro20,iclpro2
6384         if(icltar10.ne.icltar1)write(ifmt,'(a,2i2)')
6385      *  'inics: wrong icltar1',icltar10,icltar1
6386         if(icltar20.ne.icltar2)write(ifmt,'(a,2i2)')
6387      *  'inics: wrong icltar2',icltar20,icltar2
6388         if(iclegy10.ne.iclegy1)write(ifmt,'(a,2i4)')
6389      *  'inics: wrong iclegy1',iclegy10,iclegy1
6390         if(iclegy20.ne.iclegy2)write(ifmt,'(a,2i4)')
6391      *  'inics: wrong iclegy2',iclegy20,iclegy2
6392         if(egylow0.ne.egylow)write(ifmt,'(a,2f8.4)')
6393      *  'inics: wrong egylow',egylow0,egylow
6394         if(egymax0.ne.egymax)write(ifmt,'(a,2f12.4)')
6395      *  'inics: wrong egymax',egymax0,egymax
6396         if(egyscr0.ne.egyscr)write(ifmt,'(a,2f8.4)')
6397      *  'inics: wrong egyscr ',egyscr0,egyscr
6398         if(epscrw0.ne.epscrw)write(ifmt,'(a,2f8.4)')
6399      *  'inics: wrong epscrw',epscrw0,epscrw
6400         if(epscrp0.ne.epscrp)write(ifmt,'(a,2f8.4)')
6401      *  'inics: wrong epscrp',epscrp0,epscrp
6402         if(isetcs0.lt.isetcs)write(ifmt,'(a,2f8.4)')
6403      *  'inics: wrong isetcs',isetcs0,isetcs
6404         if(iclpro10.ne.iclpro1.or.iclpro20.ne.iclpro2
6405      *   .or.icltar10.ne.icltar1.or.icltar20.ne.icltar2
6406      *   .or.iclegy10.ne.iclegy1.or.iclegy20.ne.iclegy2
6407      *   .or.egylow0.ne.egylow.or.egymax0.ne.egymax
6408      *   .or.egyscr0.ne.egyscr.or.epscrw0.ne.epscrw.or.isetcs0.lt.isetcs
6409      *   .or.epscrp0.ne.epscrp)then
6410            write(ifmt,'(//a//)')'   inics has to be reinitialized!!!!'
6411            stop
6412         endif
6413         if(isetcs.eq.2)then
6414           read (1,*)asect,asect2,asectn,asect4
6415         elseif(isetcs.eq.3)then
6416           read (1,*)asect1,asect,asect3,asectn
6417         else
6418            write(ifmt,'(//a//)')' Wrong isetcs in psaini !!!!'
6419         endif
6420
6421         close(1)
6422
6423       endif
6424
6425
6426         goto 7
6427
6428       endif
6429
6430       ifradesave=ifrade
6431       idprojsave=idproj
6432       idprojinsave=idprojin
6433       idtargsave=idtarg
6434       idtarginsave=idtargin
6435       laprojsave=laproj
6436       latargsave=latarg
6437       maprojsave=maproj
6438       matargsave=matarg
6439       icltarsave=icltar
6440       iclprosave=iclpro
6441       engysave=engy
6442       pnllsave=pnll
6443       elabsave=elab
6444       ecmssave=ecms
6445       iclegysave=iclegy
6446       nrevtsave=nrevt
6447       neventsave=nevent
6448       ntevtsave=ntevt
6449       isetcssave=isetcs
6450       noebinsave=noebin
6451       isigmasave=isigma
6452       bminimsave=bminim
6453       bmaximsave=bmaxim
6454       bimevtsave=bimevt
6455       fctrmxsave=fctrmx
6456
6457
6458       isetcs=2
6459       isigma=1
6460       noebin=1
6461       nevent=100
6462       idtarg=1120
6463       idtargin=1120
6464       bminim=0.
6465       bmaxim=10000.
6466       fctrmx=100.         !to get stable pA and AA cross section, this number has to be large
6467       ifrade=0            !to save time, no fragmentation
6468
6469       write(ifmt,'(a)')'inics does not exist -> calculate tables  ...'
6470
6471       laproj=-1
6472       maproj=1
6473       icltar=2
6474       do iclpro=1,4
6475        if(iclpro.lt.iclpro1.or.iclpro.gt.iclpro2)then
6476          do ie=1,7
6477            do iia=1,7
6478              asect1(ie,iclpro,iia)=0.
6479              asect2(ie,iclpro,iia)=0.
6480            enddo
6481          enddo
6482        else
6483          do ie=1,7
6484            engy=1.5*10.**(ie-1)
6485            call paramini(0)
6486            write(ifmt,*)'  calcul.   ',ie,'  (',iclpro,')',engy
6487
6488            do iia=1,7
6489             matarg=2**(iia-1)
6490             sigine=0.
6491             if(matarg.eq.1)then  !hadron-proton interaction
6492              call psfz(gz2,0.)
6493              gin=gz2*pi*10.
6494             else
6495              call conini
6496              rad=radnuc(matarg)
6497              bm=rad+2.
6498              rrr=rad/difnuc(matarg)
6499              rrrm=rrr+log(9.)
6500              anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matarg)**2
6501              gin=(ptgau(ptfau,bm,2)+ptgau1(bm,2))*10.  !sig_in
6502             endif
6503             if(ish.ge.3)write (ifch,226)gin
6504 226         format(2x,'psaini: hadron-nucleus cross sections:'/
6505      *       4x,'gin=',e10.3)
6506             asect1(ie,iclpro,iia)=log(gin)
6507             asect(ie,iclpro,iia)=asect1(ie,iclpro,iia)
6508             write(ifmt,*)'  matarg,gin :'
6509      *       ,matarg,gin
6510            enddo
6511          enddo
6512
6513          if(isetcssave.ge.3)then
6514
6515          if(iclpro.eq.1)then
6516           idprojin=120
6517          elseif(iclpro.eq.2)then
6518           idprojin=1120
6519          elseif(iclpro.eq.3)then
6520           idprojin=130
6521          endif
6522          do ie=1,7
6523           engy=1.5*10.**(ie-1)
6524            if(engy.le.egymin)engy=egymin
6525            if(engy.ge.egymax)engy=egymax
6526            write(ifmt,*)'  simul.   ',ie,'  (',iclpro,')',engy
6527            write(ifch,*)'  simul.   ',ie,'  (',iclpro,')',engy
6528            do iia=1,7
6529             matarg=2**(iia-1)
6530             latarg=min(1,matarg/2)
6531             ntevt=0
6532             nrevt=0
6533             pnll=-1.
6534             elab=-1.
6535             ecms=-1.
6536             ekin=-1.
6537             call conini
6538             call ainit
6539             do  n=1,nevent
6540               ntry=0
6541  222          ntevt=ntevt+1
6542               iret=0
6543               ntry=ntry+1
6544               bimevt=-1.
6545               if(ntry.lt.10000)then
6546 c if random sign for projectile, set it here
6547                 idproj=idprojin*(1-2*int(rangen()+0.5d0))
6548                 call emsaaa(iret)
6549                 if(iret.gt.0)goto 222
6550               else
6551                 ntevt=ntry
6552               endif
6553             enddo
6554             a=pi*bmax**2
6555             if(a.gt.0..and.ntevt.gt.0.)then
6556              xs=float(nevent)/float(ntevt)*a*10.
6557              write(ifmt,*)'  matarg,nevent,ntevt,bmax,xs :'
6558      .       ,matarg,nevent,ntevt,bmax,xs
6559              write(ifch,*)'  matarg,nevent,ntevt,bmax,xs :'
6560      .       ,matarg,nevent,ntevt,bmax,xs
6561              asect2(ie,iclpro,iia)=log(xs)
6562             else
6563              write(ifmt,*)' Problem ? ',iclpro,matarg,bmax,ntevt
6564              asect2(ie,iclpro,iia)=0.
6565             endif
6566            enddo
6567          enddo
6568         else
6569           do ie=1,7
6570             do iia=1,7
6571               asect2(ie,iclpro,iia)=0.
6572             enddo
6573           enddo
6574         endif
6575        endif
6576       enddo
6577
6578       idprojin=1120
6579       iclpro=2
6580       icltar=2
6581       do ie=1,7
6582         engy=1.5*10.**(ie-1)
6583         call paramini(0)
6584         write(ifmt,*)'  calcul. AB  ',ie,engy
6585
6586         do iia=1,7
6587           maproj=2**(iia-1)
6588           laproj=max(1,maproj/2)
6589         do iib=1,7
6590           matarg=2**(iib-1)
6591           latarg=max(1,matarg/2)
6592           sigine=0.
6593           if(matarg.eq.1.and.maproj.eq.1)then !proton-proton interaction
6594             call psfz(gz2,0.)
6595             gin=gz2*pi*10.
6596           else
6597             call conini
6598             if(maproj.eq.1)then
6599               rad=radnuc(matarg)
6600               bm=rad+2.
6601               rrr=rad/difnuc(matarg)
6602               rrrm=rrr+log(9.)
6603               anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matarg)**2
6604               gin=(ptgau(ptfau,bm,2)+ptgau1(bm,2))*10. !sig_in
6605             elseif(matarg.eq.1)then
6606               radp=radnuc(maproj)
6607               bm=radp+2.
6608               rrrp=radp/difnuc(maproj)
6609               rrrmp=rrrp+log(9.)
6610               anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(maproj)**2
6611               gin=(ptgau(ptfau,bm,1)+ptgau1(bm,1))*10. !sig_in
6612             else
6613               rad=radnuc(matarg)+1.
6614               radp=radnuc(maproj)+1.
6615               bm=rad+radp+2.
6616               rrr=rad/difnuc(matarg)
6617               rrrm=rrr+log(9.)
6618               rrrp=radp/difnuc(maproj)
6619               rrrmp=rrrp+log(9.)
6620               anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matarg)**2
6621               anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(maproj)**2
6622               gin=(ptgau(ptfauAA,bm,2)+ptgau2(bm))*10.
6623             endif
6624           endif
6625           if(ish.ge.3)write (ifch,227)gin
6626  227      format(2x,'psaini: nucleus-nucleus cross sections:'/
6627      *       4x,'gin=',e10.3)
6628             asect3(ie,iia,iib)=log(gin)
6629             asectn(ie,iia,iib)=asect3(ie,iia,iib)
6630             write(ifmt,*)'  maproj,matarg,gin :'
6631      *       ,maproj,matarg,gin
6632
6633           enddo
6634         enddo
6635       enddo
6636
6637       if(isetcssave.ge.3)then
6638
6639       do ie=1,7
6640         engy=1.5*10.**(ie-1)
6641         if(engy.le.egymin)engy=egymin
6642         if(engy.ge.egymax)engy=egymax
6643         write(ifmt,*)'  AB xs   ',ie,engy
6644         write(ifch,*)'  AB xs   ',ie,engy
6645         do iia=1,7
6646           maproj=2**(iia-1)
6647           laproj=max(1,maproj/2)
6648         do iib=1,7
6649           matarg=2**(iib-1)
6650           latarg=max(1,matarg/2)
6651           ntevt=0
6652           nrevt=0
6653           pnll=-1.
6654           elab=-1.
6655           ecms=-1.
6656           ekin=-1.
6657           call conini
6658           call ainit
6659
6660           do  n=1,nevent
6661             ntry=0
6662  223        ntevt=ntevt+1
6663             iret=0
6664             ntry=ntry+1
6665             bimevt=-1.
6666             if(ntry.lt.10000)then
6667               call emsaaa(iret)
6668               if(iret.gt.0)goto 223
6669             else
6670               ntevt=ntry
6671             endif
6672           enddo
6673           a=pi*bmax**2
6674           if(a.gt.0..and.ntevt.gt.0.)then
6675             xs=float(nevent)/float(ntevt)*a*10.
6676           write(ifmt,*)'  maproj,matarg,nevent,ntevt,bmax,xs :'
6677      &                         ,maproj,matarg,nevent,ntevt,bmax,xs
6678           write(ifch,*)'  maproj,matarg,nevent,ntevt,bmax,xs :'
6679      &                         ,maproj,matarg,nevent,ntevt,bmax,xs
6680             asect4(ie,iia,iib)=log(xs)
6681           else
6682             write(ifmt,*)' Problem ? ',maproj,matarg,bmax,ntevt
6683             asect4(ie,iia,iib)=0.
6684           endif
6685         enddo
6686       enddo
6687       enddo
6688       else
6689         do ie=1,7
6690           do iia=1,7
6691             do iib=1,7
6692               asect4(ie,iia,iib)=0.
6693             enddo
6694           enddo
6695         enddo
6696       endif
6697
6698       ifrade=ifradesave
6699       idproj=idprojsave
6700       idprojin=idprojinsave
6701       idtarg=idtargsave
6702       idtargin=idtarginsave
6703       laproj=laprojsave
6704       latarg=latargsave
6705       maproj=maprojsave
6706       matarg=matargsave
6707       icltar=icltarsave
6708       iclpro=iclprosave
6709       engy=engysave
6710       pnll=pnllsave
6711       elab=elabsave
6712       ecms=ecmssave
6713       iclegy=iclegysave
6714       nrevt=nrevtsave
6715       nevent=neventsave
6716       ntevt=ntevtsave
6717       isetcs=isetcssave
6718       noebin=noebinsave
6719       isigma=isigmasave
6720       bminim=bminimsave
6721       bmaxim=bmaximsave
6722       bimevt=bimevtsave
6723       fctrmx=fctrmxsave
6724       inicnt=1
6725
6726       write(ifmt,'(a)')'write to inics ...'
6727       open(1,file=fncs,status='unknown')
6728       write (1,*)alpqua,alplea,alppom,slopom,gamhad,r2had,chad,
6729      *qcdlam,q2min,q2ini,betpom,glusea,naflav,factk,pt2cut
6730       write(1,*)isetcs,iclpro1,iclpro2,icltar1,icltar2,iclegy1,iclegy2
6731      *,egylow,egymax,iomega,egyscr,epscrw,epscrp
6732       write (1,*)asect1,asect2,asect3,asect4
6733
6734       close(1)
6735
6736
6737       goto 6
6738
6739  7    continue
6740
6741       endif !----------isetcs.ge.2-----------
6742
6743       call utprix('psaini',ish,ishini,4)
6744
6745       return
6746       end
6747
6748 cc-----------------------------------------------------------------------
6749 c      function fjetxx(jpp,je1,je2)
6750 cc-----------------------------------------------------------------------
6751 cc   almost exactly psjet, just with Eqcd replaced by fparton
6752 cc    for testing
6753 cc   gives indeed the same result as jetx
6754 cc   so the integration seems correct
6755 cc-----------------------------------------------------------------------
6756 c      double precision xx1,xx2,s2min,xmin,xmax,xmin1,xmax1,t,tmin
6757 c     *,tmax,sh,z,qtmin,ft,fx1,fx2
6758 c      common /ar3/   x1(7),a1(7)
6759 c      common /ar9/ x9(3),a9(3)
6760 c      include 'epos.inc'
6761 c      include 'epos.incsem'
6762 c
6763 c      fjetxx=0.
6764 c      s=engy*engy
6765 c      s2min=4.d0*q2min
6766 c
6767 c      zmin=s2min/dble(s)
6768 c      zmax=1
6769 c
6770 c      zmin=zmin**(-delh)
6771 c      zmax=zmax**(-delh)
6772 c      do i=1,3
6773 c      do m=1,2
6774 c        z=dble(.5*(zmax+zmin+(zmin-zmax)*(2*m-3)*x9(i)))**(-1./delh)
6775 c        xmin=dsqrt(z)
6776 c        sh=z*dble(s)
6777 c        qtmin=max(dble(q2min),dble(q2ini)/(1.d0-dsqrt(z)))
6778 c        tmin=max(0.d0,1.d0-4.d0*qtmin/sh)
6779 c        tmin=2.d0*qtmin/(1.d0+dsqrt(tmin))
6780 c        tmax=sh/2.d0
6781 c        ft=0.d0
6782 c        do i1=1,3
6783 c        do m1=1,2
6784 c          t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
6785 c     &    *(1.d0-tmin/tmax))
6786 c          qt=t*(1.d0-t/sh)
6787 c          xmax=1.d0-q2ini/qt
6788 c          xmin=max(dsqrt(z),z/xmax)   !xm<xp !!!
6789 c          if(xmin.gt.xmax.and.ish.ge.1)write(ifmt,*)'fjetxx:xmin,xmax'
6790 c     *                                              ,xmin,xmax
6791 c          fx1=0.d0
6792 c          fx2=0.d0
6793 c          if(xmax.gt..8d0)then
6794 c            xmin1=max(xmin,.8d0)
6795 c            do i2=1,3
6796 c            do m2=1,2
6797 c              xx1=1.d0-(1.d0-xmax)*((1.d0-xmin1)/(1.d0-xmax))**
6798 c     *        dble(.5+x9(i2)*(m2-1.5))
6799 c              xx2=z/xx1
6800 c                fb=ffsigj(sngl(t),qt,sngl(xx1),sngl(xx2),jpp,je1,je2)
6801 c     *       +ffsigj(sngl(t),qt,sngl(xx2),sngl(xx1),jpp,je1,je2)
6802 c              fx1=fx1+dble(a9(i2)*fb)*(1.d0/xx1-1.d0)
6803 c     *                               *pssalf(qt/qcdlam)**2
6804 c            enddo
6805 c            enddo
6806 c            fx1=fx1*dlog((1.d0-xmin1)/(1.d0-xmax))
6807 c          endif
6808 c          if(xmin.lt..8d0)then
6809 c            xmax1=min(xmax,.8d0)
6810 c            do i2=1,3
6811 c            do m2=1,2
6812 c              xx1=xmin*(xmax1/xmin)**dble(.5+x9(i2)*(m2-1.5))
6813 c              xx2=z/xx1
6814 c
6815 c              fb=0.
6816 c              fb=fb
6817 c     *             +ffsigj(sngl(t),qt,sngl(xx1),sngl(xx2),jpp,je1,je2)
6818 c     *       +ffsigj(sngl(t),qt,sngl(xx2),sngl(xx1),jpp,je1,je2)
6819 c              fx2=fx2+dble(a9(i2))*fb*pssalf(qt/qcdlam)**2
6820 c            enddo
6821 c            enddo
6822 c            fx2=fx2*dlog(xmax1/xmin)
6823 c          endif
6824 c          ft=ft+dble(a9(i1))*(fx1+fx2)*t**2
6825 c        enddo
6826 c        enddo
6827 c        ft=ft*(1.d0/tmin-1.d0/tmax)
6828 c        fjetxx=fjetxx+a9(i)*sngl(ft*z**(1.+delh)/sh**2)
6829 c     *          /z  ! ffsig = xp f xm f sigma
6830 c      enddo
6831 c      enddo
6832 c      fjetxx=fjetxx*(zmin-zmax)/delh*pi**3
6833 c  !   *         /2.   !???????????????  kkkkkkkkk
6834 c      return
6835 c      end
6836 c
6837 c