Back to home page

Project CMSSW displayed by LXR

 
 

    


File indexing completed on 2021-02-14 13:07:29

0001 c------------------------------------------------------------------------
0002       function ffsigiut(xx1,xx2,jpp,je1,je2)
0003 c------------------------------------------------------------------------
0004 c
0005 c   \int(dt) \int(du)  ffsig *s/sh**3 *2*pi*alpha**2 *delta(uh+th+sh)
0006 c
0007 c-----------------------------------------------------------------------
0008       common /ar3/   x1(7),a1(7)
0009       include 'epos.incsem'
0010       include 'epos.inc'
0011       double precision tmin,tmax,t,sh2,sqrtq2s
0012 
0013       ig=3
0014       s=engy**2
0015       sh=s*xx1*xx2
0016       ffsigiut=0.
0017       if(sh.le.4.*q2min)return
0018       sh2=dble(sh/2.)
0019 c      tmin=sh/2-sqrt(sh*sh/4-q2min*sh)
0020       sqrtq2s=sqrt(dble(q2min*sh))
0021       tmin=sh2-sqrt((sh2-sqrtq2s)*(sh2+sqrtq2s))
0022       tmax=sh2
0023       do i=1,ig
0024       do m=1,2
0025         t=2d0*tmin/(1d0+tmin/tmax-dble(tgss(ig,i)*(2*m-3))
0026      &       *(1d0-tmin/tmax))
0027         qq=sngl(t*(1d0-t/dble(sh)))
0028         ft=ffsigj(sngl(t),qq,xx1,xx2,jpp,je1,je2)/sh**3
0029      *         * (2*pi*pssalf(qq/qcdlam))**2
0030         ffsigiut=ffsigiut+wgss(ig,i)*ft*sngl(t)**2
0031       enddo
0032       enddo
0033       ffsigiut=ffsigiut
0034      *    *0.5*sngl(1d0/tmin-1d0/tmax)
0035      *    *2*pi*s
0036      *   /2      !CS for parton pair
0037       return
0038       end
0039 
0040 c-----------------------------------------------------------------------
0041       function ffsigj(t,qt,x1,x2,jpp,je1,je2)
0042 c-----------------------------------------------------------------------
0043 c
0044 c      \sum  x1*f_i(x1,qt) * x2*f_k(x2,qt) * B_ik
0045 c
0046 c        B_ik = psbori = contribution to Born xsection:
0047 c                         dsigmaBorn/d2pt/dy
0048 c                          = s/pi * delta(s+t+u) * 2*pi*alpha**2 /s**2 * B_ik
0049 c
0050 c  qt = virtuality scale
0051 c  x1, x2 = light cone momentum fractions
0052 c
0053 c  x*f_j(x,qt) = function fparton(x,qt,j)
0054 c
0055 c-----------------------------------------------------------------------
0056 c jpp: type of Pomeron
0057 c          1 ... sea-sea
0058 c          2 ... val-sea
0059 c          3 ... sea-val
0060 c          4 ... val-val
0061 c          5 ... all
0062 c je = emission type
0063 c          0 ... no emissions
0064 c          1 ... emissions
0065 c          2 ... all
0066 c-----------------------------------------------------------------------
0067       include 'epos.incsem'
0068       include 'epos.inc'
0069 
0070       s=engy**2*x1*x2
0071 
0072       if(jpp.ne.5)then
0073       ji1=mod(jpp+1,2)+1
0074       ji2=(jpp+1)/2
0075       sea1=pifpartone(x1,qt,-1,je1,ji1)
0076       g1=  pifpartone(x1,qt, 0,je1,ji1)
0077       uv1= pifpartone(x1,qt, 1,je1,ji1)
0078       dv1= pifpartone(x1,qt, 2,je1,ji1)
0079       sea2=pifpartone(x2,qt,-1,je2,ji2)
0080       g2=  pifpartone(x2,qt, 0,je2,ji2)
0081       uv2= pifpartone(x2,qt, 1,je2,ji2)
0082       dv2= pifpartone(x2,qt, 2,je2,ji2)
0083       else
0084       sea1=pifpartone(x1,qt,-1,je1,1)+pifpartone(x1,qt,-1,je1,2)
0085       g1=  pifpartone(x1,qt, 0,je1,1)+pifpartone(x1,qt, 0,je1,2)
0086       uv1= pifpartone(x1,qt, 1,je1,1)+pifpartone(x1,qt, 1,je1,2)
0087       dv1= pifpartone(x1,qt, 2,je1,1)+pifpartone(x1,qt, 2,je1,2)
0088       sea2=pifpartone(x2,qt,-1,je2,1)+pifpartone(x2,qt,-1,je2,2)
0089       g2=  pifpartone(x2,qt, 0,je2,1)+pifpartone(x2,qt, 0,je2,2)
0090       uv2= pifpartone(x2,qt, 1,je2,1)+pifpartone(x2,qt, 1,je2,2)
0091       dv2= pifpartone(x2,qt, 2,je2,1)+pifpartone(x2,qt, 2,je2,2)
0092       endif
0093 
0094       ffsigj= ffborn(s,t,  g1*g2                                  !gg
0095 
0096      *  ,(uv1+dv1+2.*naflav*sea1)*g2+g1*(uv2+dv2+2.*naflav*sea2)    !gq
0097 
0098      *  ,(uv1+sea1)*(uv2+sea2)                                      !qq
0099      *      +(dv1+sea1)*(dv2+sea2)+sea1*sea2*(naflav-1)*2.
0100 
0101      *  ,(uv1+sea1)*sea2+(uv2+sea2)*sea1                            !qa
0102      *    +(dv1+sea1)*sea2+(dv2+sea2)*sea1+sea1*sea2*(naflav-2)*2.
0103 
0104      *  ,dv1*uv2+dv2*uv1+(uv2+dv2)*sea1*(naflav-1)*2.                    !qqp
0105      *    +(uv1+dv1)*sea2*(naflav-1)*2.
0106      *    +sea1*sea2*naflav*(naflav-1)*4.
0107 
0108      *)
0109       end
0110 
0111 c-----------------------------------------------------------------------
0112       function ffsig(t,qt,x1,x2)    !former psjy
0113 c-----------------------------------------------------------------------
0114       include 'epos.incsem'
0115       include 'epos.inc'
0116 
0117       s=engy**2*x1*x2
0118 
0119       g1=  pifpartone(x1,qt, 0,2,1)+pifpartone(x1,qt, 0,2,2)
0120       uv1= pifpartone(x1,qt, 1,2,1)+pifpartone(x1,qt, 1,2,2)
0121       dv1= pifpartone(x1,qt, 2,2,1)+pifpartone(x1,qt, 2,2,2)
0122       sea1=pifpartone(x1,qt,-1,2,1)+pifpartone(x1,qt,-1,2,2)
0123       g2=  pifpartone(x2,qt, 0,2,1)+pifpartone(x2,qt, 0,2,2)
0124       uv2= pifpartone(x2,qt, 1,2,1)+pifpartone(x2,qt, 1,2,2)
0125       dv2= pifpartone(x2,qt, 2,2,1)+pifpartone(x2,qt, 2,2,2)
0126       sea2=pifpartone(x2,qt,-1,2,1)+pifpartone(x2,qt,-1,2,2)
0127 
0128       ffsig= ffborn(s,t,  g1*g2                                  !gg
0129 
0130      *  ,(uv1+dv1+2.*naflav*sea1)*g2+g1*(uv2+dv2+2.*naflav*sea2)   !gq
0131 
0132      *  ,(uv1+sea1)*(uv2+sea2)                                     !qq
0133      *      +(dv1+sea1)*(dv2+sea2)+sea1*sea2*(naflav-1)*2.
0134 
0135      *  ,(uv1+sea1)*sea2+(uv2+sea2)*sea1                           !qa
0136      *    +(dv1+sea1)*sea2+(dv2+sea2)*sea1+sea1*sea2*(naflav-2)*2.
0137 
0138      *  ,dv1*uv2+dv2*uv1+(uv2+dv2)*sea1*(naflav-1)*2.             !qqp
0139      *    +(uv1+dv1)*sea2*(naflav-1)*2.
0140      *    +sea1*sea2*naflav*(naflav-1)*4.
0141 
0142      *)
0143       end
0144 
0145 c------------------------------------------------------------------------
0146       function ffborn(s,t,gg,gq,qq,qa,qqp)
0147 c------------------------------------------------------------------------
0148 
0149       ffborn=
0150      *( psbori(s,t,0,0,1)+psbori(s,s-t,0,0,1)
0151      * +psbori(s,t,0,0,2)+psbori(s,s-t,0,0,2)) /2.   *gg             !gg
0152 
0153      *+(psbori(s,t,0,1,1)+psbori(s,s-t,0,1,1))       *gq             !gq
0154 
0155      *+(psbori(s,t,1,1,1)+psbori(s,s-t,1,1,1))/2.    *qq             !qq
0156 
0157      *+(psbori(s,t,1,-1,1)+psbori(s,s-t,1,-1,1)+psbori(s,t,1,-1,2)+
0158      * psbori(s,s-t,1,-1,2)+psbori(s,t,1,-1,3)+psbori(s,s-t,1,-1,3)) !qa
0159      *                                               *qa
0160 
0161      *+(psbori(s,t,1,2,1)+psbori(s,s-t,1,2,1))       *qqp            !qq'
0162 
0163       end
0164 
0165 c-----------------------------------------------------------------------
0166       function pifpartone(xx,qq,j,je,ji)  ! pol interpolation of partone
0167 c-----------------------------------------------------------------------
0168       include 'epos.incsem'
0169       include 'epos.inc'
0170       common/tabfptn/kxxmax,kqqmax,fptn(20,20,-1:2,0:2,2)
0171       real wi(3),wj(3)
0172       common /cpifpartone/npifpartone
0173       data npifpartone /0/
0174       npifpartone=npifpartone+1
0175       if(npifpartone.eq.1)call MakeFpartonTable
0176 
0177       qqmax=engy**2/4.
0178       xxmin=0.01/engy
0179       xxmax=1
0180 
0181       xxk=1.+log(xx/xxmin)/log(xxmax/xxmin)*(kxxmax-1)
0182       qqk=1.+log(qq/q2min)/log(qqmax/q2min)*(kqqmax-1)
0183       kxx=int(xxk)
0184       kqq=int(qqk)
0185       if(kxx.lt.1)kxx=1
0186       if(kqq.lt.1)kqq=1
0187       if(kxx.gt.(kxxmax-2))kxx=kxxmax-2
0188       if(kqq.gt.(kqqmax-2))kqq=kqqmax-2
0189 
0190       wi(2)=xxk-kxx
0191       wi(3)=wi(2)*(wi(2)-1.)*.5
0192       wi(1)=1.-wi(2)+wi(3)
0193       wi(2)=wi(2)-2.*wi(3)
0194 
0195       wj(2)=qqk-kqq
0196       wj(3)=wj(2)*(wj(2)-1.)*.5
0197       wj(1)=1.-wj(2)+wj(3)
0198       wj(2)=wj(2)-2.*wj(3)
0199       pifpartone=0
0200       do kx=1,3
0201       do kq=1,3
0202         pifpartone=pifpartone+fptn(kxx+kx-1,kqq+kq-1,j,je,ji)
0203      *              *wi(kx)*wj(kq)
0204       enddo
0205       enddo
0206       end
0207 
0208 c-----------------------------------------------------------------------
0209       subroutine MakeFpartonTable
0210 c-----------------------------------------------------------------------
0211       include 'epos.incsem'
0212       include 'epos.inc'
0213       common/tabfptn/kxxmax,kqqmax,fptn(20,20,-1:2,0:2,2)
0214       write (*,'(a,$)')'(Fparton table'
0215       kxxmax=10
0216       kqqmax=10
0217       qqmax=engy**2/4.
0218       xxmin=0.01/engy
0219       xxmax=1
0220       do ji=1,2
0221        do je=0,2
0222         write(*,'(a,$)')'.'
0223         do j=-1,2
0224          do kxx=1,kxxmax
0225           xx=xxmin*(xxmax/xxmin)**((kxx-1.)/(kxxmax-1.))
0226           do kqq=1,kqqmax
0227            qq=q2min*(qqmax/q2min)**((kqq-1.)/(kqqmax-1.))
0228            fptn(kxx,kqq,j,je,ji)= fpartone(xx,qq,j,je,ji)
0229           enddo
0230          enddo
0231         enddo
0232        enddo
0233       enddo
0234       write (*,'(a,$)')'done)'
0235       end
0236 
0237 c------------------------------------------------------------------------
0238       function fpartone(xx,qq,j,je,ji)                 !former pspdf0 (sha)
0239 c-----------------------------------------------------------------------
0240 c
0241 c  parton distribution function for proton  ( actually x*f(x) !!!!!!! )
0242 c
0243 c xx = light cone momentum fraction
0244 c qq = virtuality scale
0245 c j = parton type
0246 c         -1 ... sea  (distribution function per flavor)
0247 c          0 ... g
0248 c          1 ... u
0249 c          2 ... d
0250 c je = emission type
0251 c          0 ... no emissions
0252 c          1 ... emissions
0253 c          2 ... all
0254 c ji = initial parton type
0255 c          1 ... sea (q et g)
0256 c          2 ... val
0257 c-----------------------------------------------------------------------
0258       double precision z,xmin,xm,zx,psuds
0259       common/ar3/    x1(7),a1(7)
0260       include 'epos.inc'
0261       include 'epos.incsem'
0262 
0263       fpartone=0
0264       if(je.eq.1)goto888
0265 
0266 c ...... f_0 * sudakov.........
0267 
0268       if(j.eq.0.and.ji.eq.1)then
0269         fpartone=fzeroGlu(xx,2,1)         !hadron class 2, projectile side
0270       elseif((j.eq.1.or.j.eq.2).and.ji.eq.2)then
0271         fpartone=psdfh4(xx,q2min,0.,2,j)
0272       elseif(j.eq.-1.and.ji.eq.1)then
0273         fpartone=fzeroSea(xx,2,1)
0274       endif
0275       fpartone=fpartone*sngl(psuds(qq,j)/psuds(q2min,j))
0276       if(je.eq.0)goto999
0277 
0278 c......... integral f_0 E_qcd............
0279 
0280  888  continue
0281       xmin=dble(xx)/(1.d0-dble(q2ini/qq))
0282       if(xmin.lt.1.d0)then
0283         dpd1=0.
0284         dpd2=0.
0285         xm=max(xmin,0.3d0)
0286 
0287  !numerical integration xm -> 1
0288 
0289         do i=1,7
0290         do m=1,2
0291           zx=1.d0-(1.d0-xm)*(.5d0+(dble(m)-1.5d0)*dble(x1(i)))**.25d0
0292           z=xx/zx
0293 
0294           gl=fzeroGlu(sngl(zx),2,1)
0295           uv=psdfh4(sngl(zx),q2min,0.,2,1)
0296           dv=psdfh4(sngl(zx),q2min,0.,2,2)
0297           sea=fzeroSea(sngl(zx),2,1)
0298 
0299           fz=0
0300           if(j.eq.0)then
0301             if(ji.eq.1)
0302      *        fz=gl *psevi(q2min,qq,z,1,1)
0303      *          +sea*psevi(q2min,qq,z,2,1)  !ccccc
0304             if(ji.eq.2)
0305      *           fz=(uv+dv)*psevi(q2min,qq,z,2,1)
0306           elseif(j.eq.1.and.ji.eq.2)then
0307             fz=psevi(q2min,qq,z,3,2)*uv
0308           elseif(j.eq.2.and.ji.eq.2)then
0309             fz=psevi(q2min,qq,z,3,2)*dv
0310           elseif(j.eq.-1)then
0311             akns=psevi(q2min,qq,z,3,2)            !nonsinglet contribution
0312             aks=(psevi(q2min,qq,z,2,2)-akns)      !singlet contribution
0313             if(ji.eq.1)
0314      *        fz=psevi(q2min,qq,z,1,2)*gl
0315      *          +sea*aks+sea*akns !ccccc
0316             if(ji.eq.2)
0317      *        fz=(uv+dv)*aks
0318           endif
0319           dpd1=dpd1+a1(i)*fz/sngl(zx)**2/sngl(1.d0-zx)**3
0320         enddo
0321         enddo
0322         dpd1=dpd1*sngl(1.d0-xm)**4/8.*xx
0323 
0324  !numerical integration  xmin -> xm
0325 
0326         if(xm.gt.xmin)then
0327           do i=1,7
0328           do m=1,2
0329             zx=xx+(xm-xx)
0330      &         *((xmin-xx)/(xm-xx))**(.5d0-(dble(m)-1.5d0)*dble(x1(i)))
0331             z=xx/zx
0332 
0333             gl=fzeroGlu(sngl(zx),2,1)
0334             uv=psdfh4(sngl(zx),q2min,0.,2,1)
0335             dv=psdfh4(sngl(zx),q2min,0.,2,2)
0336             sea=fzeroSea(sngl(zx),2,1)
0337 
0338             fz=0
0339             if(j.eq.0)then
0340               if(ji.eq.1)
0341      *        fz=gl *psevi(q2min,qq,z,1,1)
0342      *          +sea*psevi(q2min,qq,z,2,1)     !ccccc
0343               if(ji.eq.2)
0344      *                fz=(uv+dv)*psevi(q2min,qq,z,2,1)
0345             elseif(j.eq.1.and.ji.eq.2)then
0346               fz=psevi(q2min,qq,z,3,2)*uv
0347             elseif(j.eq.2.and.ji.eq.2)then
0348               fz=psevi(q2min,qq,z,3,2)*dv
0349             elseif(j.eq.-1)then
0350               akns=psevi(q2min,qq,z,3,2)            !nonsinglet contribution
0351               aks=(psevi(q2min,qq,z,2,2)-akns)      !singlet contribution
0352               if(ji.eq.1)
0353      *          fz=psevi(q2min,qq,z,1,2)*gl
0354      *              +sea*aks+sea*akns     !ccccc
0355               if(ji.eq.2)
0356      *          fz=(uv+dv)*aks
0357             endif
0358             dpd2=dpd2+a1(i)*fz*sngl((1.d0-xx/zx)/zx)
0359           enddo
0360           enddo
0361           dpd2=dpd2*sngl(log((xm-xx)/(xmin-xx))*.5d0*xx)
0362         endif
0363         fpartone=fpartone+dpd2+dpd1
0364       endif
0365 
0366   999 continue
0367       if(j.lt.0)fpartone=fpartone/naflav/2.
0368       return
0369       end
0370 
0371 c------------------------------------------------------------------------
0372       function fparton(xx,qq,j)                 !former pspdf0 (sha)
0373 c-----------------------------------------------------------------------
0374 c
0375 c  parton distribution function for proton  ( actually x*f(x) !!!!!!! )
0376 c
0377 c xx = light cone momentum fraction
0378 c qq = virtuality scale
0379 c j = parton type
0380 c         -1 ... sea  (dsistribution fuction per flavor)
0381 c          0 ... g
0382 c          1 ... u
0383 c          2 ... d
0384 c
0385 c-----------------------------------------------------------------------
0386 c (see pages 105 - 107 of our report)
0387 c
0388 c  fparton(xx) = xx * f(xx)   !!!!!
0389 c
0390 c     f_j(xx,qq) = \sum_k \int(xx<x<1) dx/x f0_k(x) Eqcd_k_j(xx/x,qq)
0391 c
0392 c      f0_k = fzeroGlu or fzeroSea
0393 c
0394 c      Eqcd=E~qcd+delta*sudakov,  E~qcd: at least one emission
0395 c
0396 c-----------------------------------------------------------------------
0397       double precision z,xmin,xm,zx,psuds
0398       common/ar3/    x1(7),a1(7)
0399       include 'epos.inc'
0400       include 'epos.incsem'
0401 
0402 c ...... f_0 * sudakov.........
0403 
0404       if(j.eq.0)then
0405         fparton=fzeroGlu(xx,2,1)
0406       elseif(j.eq.1.or.j.eq.2)then
0407         fparton=psdfh4(xx,q2min,0.,2,j)
0408       else
0409         fparton=fzeroSea(xx,2,1)
0410       endif
0411       fparton=fparton*sngl(psuds(qq,j)/psuds(q2min,j))
0412 
0413 c......... integral f_0 E_qcd............
0414 
0415       xmin=xx/(1.d0-dble(q2ini/qq))
0416       if(xmin.lt.1.d0)then
0417         dpd1=0.
0418         dpd2=0.
0419         xm=max(xmin,.3d0)
0420 
0421  !numerical integration xm -> 1
0422 
0423         do i=1,7
0424         do m=1,2
0425           zx=1.d0-(1.d0-xm)*(.5d0+(dble(m)-1.5d0)*dble(x1(i)))**.25d0
0426           z=xx/zx
0427 
0428           gl=fzeroGlu(sngl(zx),2,1)
0429           uv=psdfh4(sngl(zx),q2min,0.,2,1)
0430           dv=psdfh4(sngl(zx),q2min,0.,2,2)
0431           sea=fzeroSea(sngl(zx),2,1)
0432 
0433           if(j.eq.0)then
0434             fz=psevi(q2min,qq,z,1,1)*gl
0435      *            +(uv+dv+sea)*psevi(q2min,qq,z,2,1)
0436           elseif(j.eq.1)then
0437             fz=psevi(q2min,qq,z,3,2)*uv
0438           elseif(j.eq.2)then
0439             fz=psevi(q2min,qq,z,3,2)*dv
0440           else
0441             akns=psevi(q2min,qq,z,3,2)            !nonsinglet contribution
0442             aks=(psevi(q2min,qq,z,2,2)-akns)      !singlet contribution
0443             fz=(psevi(q2min,qq,z,1,2)*gl+(uv+dv+sea)*aks+sea*akns)
0444           endif
0445           dpd1=dpd1+a1(i)*fz/sngl(zx)**2/sngl(1.d0-zx)**3
0446         enddo
0447         enddo
0448         dpd1=dpd1*sngl((1.d0-xm)**4/8.*xx)
0449 
0450  !numerical integration  xmin -> xm
0451 
0452         if(xm.gt.xmin)then
0453           do i=1,7
0454           do m=1,2
0455             zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))
0456      *             **(.5d0-(dble(m)-1.5)*dble(x1(i)))
0457             z=xx/zx
0458 
0459             gl=fzeroGlu(sngl(zx),2,1)
0460             uv=psdfh4(sngl(zx),q2min,0.,2,1)
0461             dv=psdfh4(sngl(zx),q2min,0.,2,2)
0462             sea=fzeroSea(sngl(zx),2,1)
0463 
0464             if(j.eq.0)then
0465               fz=psevi(q2min,qq,z,1,1)*gl+(uv+dv+sea)*
0466      *        psevi(q2min,qq,z,2,1)
0467             elseif(j.eq.1)then
0468               fz=psevi(q2min,qq,z,3,2)*uv
0469             elseif(j.eq.2)then
0470               fz=psevi(q2min,qq,z,3,2)*dv
0471             else
0472               akns=psevi(q2min,qq,z,3,2)            !nonsinglet contribution
0473               aks=(psevi(q2min,qq,z,2,2)-akns)      !singlet contribution
0474               fz=(psevi(q2min,qq,z,1,2)*gl+(uv+dv+sea)*aks+sea*akns)
0475             endif
0476             dpd2=dpd2+a1(i)*fz*sngl((1.d0-xx/zx)/zx)
0477           enddo
0478           enddo
0479           dpd2=dpd2*sngl(log((xm-xx)/(xmin-xx))*.5d0*xx)
0480         endif
0481         fparton=fparton+dpd2+dpd1
0482       endif
0483       if(j.lt.0)fparton=fparton/naflav/2.
0484       return
0485       end
0486 
0487 c------------------------------------------------------------------------
0488       function fzeroGlu(z,k,ipt)
0489 c-----------------------------------------------------------------------
0490 c
0491 c        x*f(x)
0492 c
0493 c   f = F & EsoftGluon         &=convolution
0494 c
0495 c   F(x) = alpff(k)*x**betff(ipt)*(1-x)**alplea(k)
0496 c
0497 c   EsoftGluon(x) = x**(-1-dels) * EsoftGluonTil(x)
0498 c
0499 c z - light cone x
0500 c k - hadron class
0501 c ipt - 1=proj 2=targ
0502 c-----------------------------------------------------------------------
0503       double precision xpmin,xp
0504       include 'epos.inc'
0505       common /ar3/   x1(7),a1(7)
0506       include 'epos.incsem'
0507 
0508       fzeroGlu=0.
0509       xpmin=z
0510       xpmin=xpmin**(1+betff(ipt)+dels)
0511       do i=1,7
0512       do m=1,2
0513         xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
0514      *            (1+betff(ipt)+dels))
0515         zz=z/xp
0516         fzeroGlu=fzeroGlu+a1(i)*(1.-xp)**alplea(k)*EsoftGluonTil(zz)
0517       enddo
0518       enddo
0519       fzeroGlu=fzeroGlu*.5*(1.-xpmin)/(1+betff(ipt)+dels)
0520 
0521       fzeroGlu=fzeroGlu *alpff(k) *z**(-dels)
0522 
0523       end
0524 
0525 c------------------------------------------------------------------------
0526       function fzeroSea(z,k,ipt)
0527 c-----------------------------------------------------------------------
0528 c
0529 c        x*f(x)
0530 c
0531 c   f = F & EsoftQuark         &=convolution
0532 c
0533 c   F(x) = alpff(k)*x**betff(ipt)*(1-x)**alplea(k)
0534 c
0535 c   EsoftQuark(x) = x**(-1-dels) * EsoftQuarkTil(x)
0536 c
0537 c z - light cone x of the quark,
0538 c k - hadron class
0539 c-----------------------------------------------------------------------
0540       double precision xpmin,xp
0541       common /ar3/   x1(7),a1(7)
0542       include 'epos.inc'
0543       include 'epos.incsem'
0544 
0545       fzeroSea=0.
0546       xpmin=z
0547       xpmin=xpmin**(1+betff(ipt)+dels)
0548       do i=1,7
0549       do m=1,2
0550         xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
0551      *            (1+betff(ipt)+dels))
0552         zz=z/xp
0553         fzeroSea=fzeroSea+a1(i)*(1.-xp)**alplea(k)*EsoftQuarkTil(zz)
0554       enddo
0555       enddo
0556       fzeroSea=fzeroSea*.5*(1.-xpmin)/(1+betff(ipt)+dels)
0557 
0558       fzeroSea=fzeroSea *alpff(k) *z**(-dels)
0559 
0560       end
0561 
0562 c------------------------------------------------------------------------
0563       function EsoftGluonTil(zz)
0564 c-----------------------------------------------------------------------
0565 c   EsoftGluon = zz^(-1-dels) * EsoftGluonTil
0566 c-----------------------------------------------------------------------
0567       include 'epos.inc'
0568       include 'epos.incsem'
0569       EsoftGluonTil=gamsoft*(1-glusea)*(1.-zz)**betpom
0570       end
0571 
0572 c------------------------------------------------------------------------
0573       function EsoftQuarkTil(zz)
0574 c-----------------------------------------------------------------------
0575 c   EsoftQuark = zz^(-1-dels) * EsoftQuarkTil
0576 c-----------------------------------------------------------------------
0577       double precision zmin,z
0578       common /ar3/   x1(7),a1(7)
0579       include 'epos.inc'
0580       include 'epos.incsem'
0581 
0582       EsoftQuarkTil=0.
0583       zmin=zz
0584       zmin=zmin**(1.+dels)
0585       do i=1,7
0586       do m=1,2
0587         z=(.5d0*(1.+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))
0588      *  **(1.d0/(1.d0+dels))
0589         EsoftQuarkTil=EsoftQuarkTil+a1(i)*max(1.d-5,(1.d0-zz/z))**betpom
0590      *  *(z**2+(1.-z)**2)
0591       enddo
0592       enddo
0593       EsoftQuarkTil=EsoftQuarkTil*1.5*(1.d0-zmin)/(1.+dels)
0594                                                 !1.5=naflav/2 at Q0
0595       EsoftQuarkTil=gamsoft*glusea*EsoftQuarkTil
0596 
0597       end
0598 
0599 c------------------------------------------------------------------------
0600       function EsoftQZero(zz)    ! former psftilf
0601 c-----------------------------------------------------------------------
0602 c
0603 c   EsoftQuark = EsoftQZero * wsplit * z^(-1-dels) * gamsoft
0604 c
0605 c zz - ratio of the quark and pomeron light cone x (zz=x_G/x_P)
0606 c integration over quark to gluon light cone momentum ratio (z=x/x_G):
0607 c
0608 c   EsoftQZero = int(dz) z^dels * (1-zz/z)^betpom * P_qG(z)
0609 c
0610 c-----------------------------------------------------------------------
0611       double precision zmin,z
0612       common /ar3/   x1(7),a1(7)
0613       include 'epos.incsem'
0614 
0615       EsoftQZero=0.
0616       zmin=zz
0617       zmin=zmin**(1.+dels)
0618       do i=1,7
0619       do m=1,2
0620         z=(.5d0*(1.+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))
0621      *  **(1.d0/(1.d0+dels))
0622         EsoftQZero=EsoftQZero+a1(i)*max(1.d-5,(1.d0-zz/z))**betpom
0623      *  *(z**2+(1.-z)**2)
0624       enddo
0625       enddo
0626       EsoftQZero=EsoftQZero*1.5*(1.d0-zmin)/(1.+dels)   !1.5=naflav/2 at Q0
0627       return
0628       end
0629 
0630 c------------------------------------------------------------------------
0631       function ffsigi(qq,y0)                   !former psjx1  (sto)
0632 c------------------------------------------------------------------------
0633 c
0634 c    dsigma/dpt_jet =  \int dy \int dx1  ffsig(x1,x2(x1))
0635 c
0636 c x1=xplus, x2=xminus
0637 c x2=x2(x1) due to u+t+s=0
0638 c ( s=x1*x2*spp, t/spp=-x1*xt*exp(-y)/2, u/spp=-x2*xt*exp(y)/2 )
0639 c
0640 c qq = pt**2,  xt=2.*sqrt(qq/s)
0641 c rapidity range: 0 to y0
0642 c
0643 c    ffsig = function ffsig(t,qq,x1,x2)
0644 c
0645 c-----------------------------------------------------------------------
0646       include 'epos.incsem'
0647       include 'epos.inc'
0648       double precision xx1,xx2,xt,ymax,ymin,y,xmin,xmax
0649       ig=3
0650       ig1=3
0651       s=engy**2
0652       ffsigi=0.
0653       if(s.le.4.*qq)return
0654       if(qq.lt.q2min)return
0655       xt=2d0*sqrt(dble(qq)/dble(s))
0656       ymax=min(dble(y0),log(1d0/xt+sqrt((1d0/xt-1d0)*(1d0/xt+1d0))))
0657       ymin=-ymax                          !final result must be divided by 2
0658       do i=1,ig
0659       do m=1,2
0660         y=.5d0*(ymax+ymin+(ymin-ymax)*dble((2*m-3)*tgss(ig,i)))
0661        !for xx1-integration, use variable x=xx1-xt*exp(y)/2.,with xmin<x<xmax
0662         xmin=xt**2/2.d0/(2.d0-xt*exp(-y))                    !condition x2<1
0663         xmax=1.d0-xt*exp(y)/2.d0                             !condition x1<1
0664         fx=0.
0665         do i1=1,ig1
0666         do m1=1,2
0667           xx1=xt*exp(y)/2.d0+xmin*(xmax/xmin)**dble(.5
0668      &                                           +tgss(ig1,i1)*(m1-1.5))
0669           xx2=xt*exp(-y)*xx1/(2.d0*xx1-xt*exp(y))
0670           z=sngl(xx1*xx2)
0671           sh=z*s
0672           aa=1.-4.*qq/sh
0673           aa=max(1e-10,aa)
0674           t=sh/2.*(1.-sqrt(aa))               !formula in parton-parton cms
0675           ft=ffsig(t,qq,sngl(xx1),sngl(xx2))
0676           fx=fx+wgss(ig1,i1)*ft/sh**2
0677         enddo
0678         enddo
0679         fx=fx*0.5*sngl(log(xmax/xmin))       !dx/x=0.5*log(xmax/xmin)dt (gauss)
0680         ffsigi=ffsigi+wgss(ig,i)*fx
0681       enddo
0682       enddo
0683       ffsigi=ffsigi*0.5*sngl(ymax-ymin)    !dy=0.5*(ymax-ymin)dt (gauss)
0684      *  *2*pi*(2*pi*pssalf(qq/qcdlam))**2      !alpha = 2*pi*pssalf
0685      *   *2*sqrt(qq)                 !d2pt=2*pi*pt*dpt
0686      *   /2   ! y interval  2 * Delta_y
0687      *   /2   ! condition t < sqrt(s)/2,
0688               !     since t > sqrt(s)/2 is automatically included,
0689               !      see psbori
0690       return
0691       end
0692 
0693 c------------------------------------------------------------------------
0694       function psbori(s,t,j,l,n)
0695 c-----------------------------------------------------------------------
0696 c contribution to the born cross-section:
0697 c
0698 c   dsigmaBorn/d2pt/dy = s/pi * delta(s+t+u) * 2*pi*alpha**2 /s**2 *psbori
0699 c
0700 c s - c.m. energy squared for the born scattering,
0701 c t - invariant variable for the born scattering |(p1-p3)**2|,
0702 c j - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
0703 c l - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
0704 c n - subprocess number
0705 c-----------------------------------------------------------------------
0706       include 'epos.incsem'
0707 
0708       psbori=0.
0709       u=s-t
0710       if(u.le.0.d0)return
0711 
0712       if(iabs(j).ne.4)then           !light quarks and gluons
0713         if(n.eq.1)then
0714           if(j.eq.0.and.l.eq.0)then                   !gg->gg
0715             psbori=(3.-t*u/s**2+s*u/t**2+s*t/u**2)*4.5
0716           elseif(j*l.eq.0)then                        !gq->gq
0717             psbori=(s**2+u**2)/t**2+(s/u+u/s)/2.25
0718           elseif(j.eq.l)then                          !qq->qq
0719             psbori=((s**2+u**2)/t**2+(s**2+t**2)/u**2)/2.25
0720      *      -s**2/t/u/3.375
0721           elseif(j.eq.-l)then                         !qq~->qq~
0722             psbori=((s**2+u**2)/t**2+(u**2+t**2)/s**2)/2.25
0723      *      +u**2/t/s/3.375
0724           else                                        !qq'->qq'
0725             psbori=(s**2+u**2)/t**2/2.25
0726           endif
0727         elseif(n.eq.2)then
0728           if(j.eq.0.and.l.eq.0)then                   !gg->qq~
0729             psbori=.5*(t/u+u/t)-1.125*(t*t+u*u)/s**2
0730           elseif(j.eq.-l)then                         !qq~->q'q'~
0731             psbori=(t*t+u*u)/s**2/1.125
0732           else
0733             psbori=0.
0734           endif
0735         elseif(n.eq.3)then
0736           if(j.ne.0.and.j.eq.-l)then                  !qq~->gg
0737             psbori=32./27.*(t/u+u/t)-(t*t+u*u)/s**2/.375
0738           else
0739             psbori=0.
0740           endif
0741 
0742 c............ n=4 for photon product processes, make e_q**2 =2/9.,
0743 c                 the average value of charge squared for all types of quarks.
0744         elseif(n.eq.4) then
0745           if(j.ne.0.and.j.eq.-l)then                   !qq~->g+gamma
0746             psbori=16*factgam*(u/t+t/u)/81.
0747           elseif (j*l.eq.0.and.j+l.ne.0) then          !q(q~)g->q(q~)+gamma
0748             psbori=2*factgam*(u/s+s/u)/27.
0749           else
0750             psbori=0.
0751           endif
0752 ctp090305 temporary to avoid hard gamma which produce fragmentation problem in psahot
0753           psbori=0.     !????????????
0754         elseif(n.eq.5) then
0755           if(j.ne.0.and.j.eq.-l)then                   !qq~->gamma+gamma
0756             psbori=4*factgam*(t/u+u/t)/81.
0757           else
0758             psbori=0.
0759           endif
0760 ctp090305 temporary to avoid hard gamma which produce fragmentation problem in psahot
0761           psbori=0.     !????????????
0762         endif
0763 
0764       elseif(n.eq.1)then                                            !c-quark
0765 
0766         if(l.eq.0)then                                !cg->cg
0767           xm=qcmass**2/s/u
0768           psbori=(s**2+u**2)/t**2+(s/u+u/s)/2.25
0769      *    -4.*qcmass**2/t+xm*(xm*t**2-t)/.5625+4.*qcmass**2*xm
0770         else                                          !cq->cq
0771           psbori=(s**2+u**2)/t**2/2.25-qcmass**2/t/1.125
0772         endif
0773 
0774       else
0775 
0776         psbori=0.
0777 
0778       endif
0779       return
0780       end
0781 
0782 c-----------------------------------------------------------------------
0783       double precision function om51p(sy,xh,yp,b,iqq)
0784 c-----------------------------------------------------------------------
0785 c om5p - chi~(x,y)
0786 c xh - fraction of the energy squared s for the pomeron;
0787 c yp - rapidity for the pomeron;
0788 c b - impact parameter between the pomeron ends;
0789 c iqq =-1  - 0+1+2+3+4,
0790 c iqq = 0  - soft pomeron,
0791 c iqq = 1  - gg,
0792 c iqq = 2  - qg,
0793 c iqq = 3  - gq,
0794 c iqq = 4  - qq,
0795 c iqq = 5  - soft(int)|b,
0796 c iqq = 6  - gg(int)|b,
0797 c iqq = 7  - soft(proj)|b,
0798 c iqq = 8  - gg(proj)|b,
0799 c iqq = 9  - qg(proj)|b,
0800 c iqq = 10 - total fro-uncut integrated,
0801 c iqq = 11 - total uncut integrated,
0802 c iqq = 12 - soft(int),
0803 c iqq = 13 - gg(int),
0804 c iqq = 14 - <b^2*soft(int)>,
0805 c iqq = 15 - <b^2*gg(int)>,
0806 c iqq = 16 - soft(proj-int),
0807 c iqq = 17 - gg(proj-int),
0808 c iqq = 18 - qg(proj-int),
0809 c iqq = 19 - <b^2*soft(proj)>,
0810 c iqq = 20 - <b^2*gg(proj)>,
0811 c iqq = 21 - <b^2*qg(proj)>
0812 c-----------------------------------------------------------------------
0813       double precision xh,yp!,coefom1,coefom2
0814       common /psar7/  delx,alam3p,gam3p
0815       common /psar37/ coefom1,coefom2
0816       include 'epos.inc'
0817       include 'epos.incsem'
0818 
0819       xp=dsqrt(xh)*exp(yp)
0820       if(xh.ne.0.d0)then
0821         xm=xh/xp
0822       else
0823         xm=0.
0824       endif
0825       rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
0826       zb=exp(-b**2/(4.*.0389*rp))
0827       rh=r2had(iclpro)+r2had(icltar)
0828 
0829       if(iqq.eq.0)then          !soft
0830 c      rp=r2hads(iclpro)+r2hads(icltar)+slopoms*log(max(1.,sy))
0831       zb=exp(-b**2/(4.*.0389*rp))
0832         om51p=chad(iclpro)*chad(icltar)*gamhads(iclpro)
0833      *  *gamhads(icltar)*sy**dels*(xp*xm)**(-alppar)*zb/rp
0834       elseif(iqq.le.4)then      !gg,qg,gq,qq
0835         om51p=psvin(sy,xp,xm,zb,iqq)
0836       elseif(iqq.eq.5)then      !soft(int)|b
0837 c        rh=alam3p+slopoms*log(max(1.,sy))
0838         om51p=sy**dels*zb**(rp/rh)/rh
0839       elseif(iqq.eq.6)then      !gg(int)|b
0840         om51p=psvin(sy,xp,xm,zb,14)
0841       elseif(iqq.eq.7)then      !soft(proj)b
0842 c        rh=r2hads(iclpro)+.5*alam3p+slopoms*log(max(1.,sy))
0843         om51p=chad(iclpro)*gamhads(iclpro)*sy**dels
0844      *  *xp**(-alppar)*zb**(rp/rh)/rh
0845        elseif(iqq.eq.8)then     !gg(proj)b
0846         om51p=psvin(sy,xp,xm,zb,16)
0847        elseif(iqq.eq.9)then     !qg(proj)b
0848         om51p=psvin(sy,xp,xm,zb,18)
0849        elseif(iqq.eq.10)then    !total fro-uncut integrated
0850          om51p=0.d0
0851          return
0852        elseif(iqq.eq.11)then    !total uncut integrated
0853         om51p=psvin(sy,xp,xm,zb,9)
0854 c        om51p=om51p+dble(coefom1)/2.d0*om51p**2+dble(coefom2)/6.d0*om51p**3 !!!!!!!!!!
0855 c        if(om51p.gt.100.d0)om51p=100.d0
0856       elseif(iqq.eq.12)then      !soft(int)
0857         om51p=sy**dels*4.*.0389
0858       elseif(iqq.eq.13)then      !gg(int)
0859         om51p=psvin(sy,xp,xm,zb,5)
0860       elseif(iqq.eq.14)then      !<b^2*soft(int)>
0861 c        rh=alam3p+slopoms*log(max(1.,sy))
0862         om51p=sy**dels*rh*(4.*.0389)**2
0863       elseif(iqq.eq.15)then      !<b^2*gg(int)>
0864         om51p=psvin(sy,xp,xm,zb,15)
0865       elseif(iqq.eq.16)then      !soft(proj-int)
0866         om51p=chad(iclpro)*gamhads(iclpro)*sy**dels
0867      *  *xp**(-alppar)*4.*.0389
0868        elseif(iqq.eq.17)then     !gg(proj-int)
0869         om51p=psvin(sy,xp,xm,zb,6)
0870        elseif(iqq.eq.18)then     !qg(proj-int)
0871         om51p=psvin(sy,xp,xm,zb,7)
0872       elseif(iqq.eq.19)then      !<b^2*soft(proj)>
0873 c        rh=r2hads(iclpro)+.5*alam3p+slopoms*log(max(1.,sy))
0874         om51p=chad(iclpro)*gamhads(iclpro)*sy**dels
0875      *  *xp**(-alppar)*rh*(4.*.0389)**2
0876        elseif(iqq.eq.20)then     !<b^2*gg(proj)>
0877         om51p=psvin(sy,xp,xm,zb,17)
0878        elseif(iqq.eq.21)then     !<b^2*qg(proj)>
0879         om51p=psvin(sy,xp,xm,zb,19)  
0880       else
0881         om51p=0.
0882         call utstop("Unknown iqq in om51p !&")
0883       endif
0884 
0885       return
0886       end
0887 
0888 cc-----------------------------------------------------------------------
0889 c      double precision function om2p(xh,yp,xprem0,xmrem0,b,iqq)
0890 cc-----------------------------------------------------------------------
0891 cc om2p - chi~(x,y) for cut pomeron
0892 cc xh - fraction of the energy squared s for the pomeron;
0893 cc yp - rapidity for the pomeron;
0894 cc xprem - x+ for the projectile remnant;
0895 cc xmrem - x- for the target remnant;
0896 cc b - impact parameter between the pomeron ends;
0897 cc iqq = 0  - total,
0898 cc iqq = 1  - 1-cut,
0899 cc iqq = 2  - Y+,
0900 cc iqq = -2 - Y-,
0901 cc iqq = 3  - 1-cut(soft),
0902 cc iqq = 4  - 1+(gg),
0903 cc iqq = 5  - 1+(qg),
0904 cc iqq = 6  - 1+(gq),
0905 cc iqq = 7  - 1+(difr)
0906 cc iqq = -7 - 1-(difr)
0907 cc-----------------------------------------------------------------------
0908 c      double precision xh,yp,xprem0,xmrem0
0909 c      include 'epos.inc'
0910 c      include 'epos.incsem'
0911 c
0912 c      om2p=0.d0
0913 c      sy=xh*engy**2
0914 c      xprem=sngl(xprem0)
0915 c      xmrem=sngl(xmrem0)
0916 c      xp=dsqrt(xh)*dexp(yp)
0917 c      if(xh.ne.0.d0)then
0918 c        xm=xh/xp
0919 c      else
0920 c        xm=0.
0921 c      endif
0922 c      rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
0923 c      zb=exp(-b**2/(4.*.0389*rp))
0924 c
0925 c      if(iqq.eq.0)then
0926 c        om2p=psvy(xp,xprem,xm,xmrem,b,2)
0927 c     *  +psvy(xp,xprem,xm,xmrem,b,-2)
0928 c     *  +psvy(xp,xprem,xm,xmrem,b,3)
0929 c     *  +psvy(xp,xprem,xm,xmrem,b,-3)
0930 c     *  +psvy(xp,xprem,xm,xmrem,b,9)
0931 c     *  +psvy(xp,xprem,xm,xmrem,b,-9)
0932 c     *  +psvx(xp,xprem,xm,xmrem,b,1)
0933 c     *  +psvx(xp,xprem,xm,xmrem,b,2)
0934 c     *  +psvx(xp,xprem,xm,xmrem,b,-2)
0935 c     *  +psvx(xp,xprem,xm,xmrem,b,6)
0936 c     *  +psvx(xp,xprem,xm,xmrem,b,-6)
0937 c        om2p=om2p+(chad(iclpro)*chad(icltar)*gamhad(iclpro)
0938 c     *  *gamhad(icltar)*sy**dels*(xp*xm)**(-alppar)*zb/rp
0939 c     *  +psvin(sy,xp,xm,zb,1)+psvin(sy,xp,xm,zb,2)
0940 c     *  +psvin(sy,xp,xm,zb,3)+psvin(sy,xp,xm,zb,4))
0941 c      elseif(iqq.eq.1)then
0942 c        om2p=psvy(xp,xprem,xm,xmrem,b,2)+psvy(xp,xprem,xm,xmrem,b,-2)
0943 c     *  +psvx(xp,xprem,xm,xmrem,b,1)
0944 c      elseif(iqq.eq.2)then
0945 c        om2p=psvy(xp,xprem,xm,xmrem,b,3)
0946 c     *  +psvx(xp,xprem,xm,xmrem,b,2)
0947 c      elseif(iqq.eq.-2)then
0948 c        om2p=psvy(xp,xprem,xm,xmrem,b,-3)
0949 c     *  +psvx(xp,xprem,xm,xmrem,b,-2)
0950 c      elseif(iqq.eq.3)then
0951 c        om2p=psvy(xp,xprem,xm,xmrem,b,4)+psvy(xp,xprem,xm,xmrem,b,-4)
0952 c     *  +psvx(xp,xprem,xm,xmrem,b,3)
0953 c      elseif(iqq.eq.4)then
0954 c        om2p=psvy(xp,xprem,xm,xmrem,b,5)+psvy(xp,xprem,xm,xmrem,b,7)
0955 c     *  +psvy(xp,xprem,xm,xmrem,b,-5)+psvy(xp,xprem,xm,xmrem,b,-7)
0956 c     *  +psvx(xp,xprem,xm,xmrem,b,4)+psvx(xp,xprem,xm,xmrem,b,-4)
0957 c      elseif(iqq.eq.5)then
0958 c        om2p=psvy(xp,xprem,xm,xmrem,b,6)+psvy(xp,xprem,xm,xmrem,b,-8)
0959 c     *  +psvx(xp,xprem,xm,xmrem,b,5)
0960 c      elseif(iqq.eq.6)then
0961 c        om2p=psvy(xp,xprem,xm,xmrem,b,-6)+psvy(xp,xprem,xm,xmrem,b,8)
0962 c     *  +psvx(xp,xprem,xm,xmrem,b,-5)
0963 c      elseif(iqq.eq.7)then
0964 c        om2p=psvy(xp,xprem,xm,xmrem,b,9)
0965 c     *  +psvx(xp,xprem,xm,xmrem,b,6)
0966 c      elseif(iqq.eq.-7)then
0967 c        om2p=psvy(xp,xprem,xm,xmrem,b,-9)
0968 c     *  +psvx(xp,xprem,xm,xmrem,b,-6)
0969 c      else
0970 c        stop'om2p-wrong iqq!!!'
0971 c      endif
0972 c      return
0973 c      end
0974 c
0975 cc-----------------------------------------------------------------------
0976 c      double precision function om3p(xh,yp,xleg,xprem,xmrem,xlrem
0977 c     *,b1,b2,b12,iqq)
0978 cc-----------------------------------------------------------------------
0979 cc om3p - chi~(x,y) for cut pomeron (nuclear effects)
0980 cc xh     - fraction of the energy squared s for the pomeron;
0981 cc yp     - rapidity for the pomeron;
0982 cc xleg   - x for the pomeron leg;
0983 cc xprem  - x+ for the projectile remnant;
0984 cc xmrem  - x- for the target remnant;
0985 cc xlrem  - x for the leg remnant;
0986 cc b1     - impact parameter between the pomeron ends;
0987 cc b2     - impact parameter for the second pomeron end;
0988 cc iqq = 1  - uncut+,
0989 cc iqq = 2  - cut+,
0990 cc iqq = 3  - scr+,
0991 cc iqq = 4  - diffr+,
0992 cc iqq = 5  - uncut-,
0993 cc iqq = 6  - cut-,
0994 cc iqq = 7  - scr-,
0995 cc iqq = 8  - diff-
0996 cc iqq = 9  - uncut-h+,
0997 cc iqq = 10 - uncut-h-,
0998 cc iqq = 11 - uncut-YY+,
0999 cc iqq = 12 - uncut-YY-,
1000 cc-----------------------------------------------------------------------
1001 c      double precision xh,yp,xleg,xprem,xmrem,xlrem
1002 c
1003 c      om3p=0.d0
1004 c      return !!!!!!!!!!!!!!!
1005 cc      if(iqq.ne.1.and.iqq.ne.5.and.iqq.ne.9.and.iqq.ne.10
1006 cc     *.and.iqq.ne.11.and.iqq.ne.12)return
1007 c
1008 cc$$$      xp=dsqrt(xh)*exp(yp)
1009 cc$$$      if(xh.ne.0.d0)then
1010 cc$$$        xm=xh/xp
1011 cc$$$      else
1012 cc$$$        xm=0.d0
1013 cc$$$      endif
1014 cc$$$
1015 cc$$$      return
1016 c      end
1017 c
1018 cc-----------------------------------------------------------------------
1019 c      double precision function om4p(xx1,xx2,xx3,xx4
1020 c     *,b12,b13,b14,b23,b24,b34,iqq)
1021 cc-----------------------------------------------------------------------
1022 cc om4p - chi for 2-leg contributions
1023 cc xx_i - x+- for pomeron ends;
1024 cc b_ij - impact parameter diff. between pomeron ends;
1025 cc iqq = 1   - uncut-H,
1026 cc iqq = 2   - uncut-YY+,
1027 cc iqq = 3   - uncut-YY-
1028 cc-----------------------------------------------------------------------
1029 c      double precision xx1,xx2xx3,xx4
1030 c      om4p=0.d0
1031 c      return
1032 c      end
1033 c
1034 cc------------------------------------------------------------------------
1035 c      function omi5pp(sy,xpp,xpm,z,iqq)   !former psfsh1
1036 cc-----------------------------------------------------------------------
1037 cc omi5pp - integrated semihard interaction eikonal
1038 cc sy - energy squared for the hard interaction,
1039 cc z - impact parameter factor, z=exp(-b**2/rp),
1040 cc iqq - type of the hard interaction:
1041 cc 0  - soft, 1 - gg, 2 - qg, 3 - gq
1042 cc-----------------------------------------------------------------------
1043 c      common /ar3/    x1(7),a1(7)
1044 c      common /ar9/    x9(3),a9(3)
1045 c      include 'epos.inc'
1046 c      include 'epos.incsem'
1047 c      fsy(zsy)=zsy**dels   !*(1.-1./zsy)**betpom
1048 c
1049 c      omi5pp=0.
1050 c      if(iclpro.eq.4.and.iqq.eq.2.or.icltar.eq.4.and.iqq.eq.3)then
1051 c        spmin=4.*q2min+2.*qcmass**2
1052 c      elseif(iqq.ne.0)then
1053 c        spmin=4.*q2min
1054 c      else
1055 c        spmin=0.
1056 c      endif
1057 c      if(sy.le.spmin)return
1058 c
1059 c      rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
1060 c      alpq=(alppar+1.)/2.
1061 c      if(iqq.eq.3)then
1062 c        iclt=iclpro
1063 c        iclp=icltar
1064 c      else
1065 c        iclp=iclpro
1066 c        iclt=icltar
1067 c      endif
1068 c
1069 c      if(iqq.eq.0)then
1070 c        xpmax=(1.-spmin/sy)**(1.+alplea(iclp))
1071 c        do i=1,3
1072 c        do m=1,2
1073 c          xp=1.-(xpmax*(.5+x9(i)*(m-1.5)))**(1./(1.+alplea(iclp)))
1074 c          xmmax=(1.-spmin/sy/xp)**(1.+alplea(iclt))
1075 c          do i1=1,3
1076 c          do m1=1,2
1077 c            xm=1.-(xmmax*(.5+x9(i1)*(m1-1.5)))**(1./(1.+alplea(iclt)))
1078 c
1079 c            sy1=sy*xp*xm
1080 c            rh=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy1))
1081 c            omi5pp=omi5pp+a9(i)*a9(i1)*fsy(sy1)*xmmax*z**(rp/rh)/rh
1082 c     *      *(xp*xm)**(-alppar)
1083 c          enddo
1084 c          enddo
1085 c        enddo
1086 c        enddo
1087 c        omi5pp=omi5pp*xpmax/(1.+alplea(iclp))/(1.+alplea(iclt))
1088 c     *  *chad(iclpro)*chad(icltar)*gamhad(iclpro)*gamhad(icltar)
1089 c     *  *(xpp*xpm)**(1.-alppar)/4.
1090 c        return
1091 c      else
1092 c
1093 c        xmin=(spmin/sy)**(delh-dels)
1094 c        do i=1,3
1095 c        do m=1,2
1096 c          zh=(.5*(1.+xmin-(2*m-3)*x9(i)*(1.-xmin)))**(1./(delh-dels))
1097 c          if(iclpro.eq.4.and.iqq.eq.2.or.icltar.eq.4.and.iqq.eq.3)then
1098 c            call psjti0(zh*sy,sgq,sgqb,4,0)
1099 c            call psjti0(zh*sy,sqq,sqqb,4,1)
1100 c          else
1101 c            call psjti0(zh*sy,sgg,sggb,0,0)
1102 c            call psjti0(zh*sy,sgq,sgqb,0,1)
1103 c            call psjti0(zh*sy,sqq,sqqb,1,1)
1104 c            call psjti0(zh*sy,sqaq,sqaqb,-1,1)
1105 c            call psjti0(zh*sy,sqqp,sqqpb,1,2)
1106 c            sqq=(sqq+sqaq+2.*(naflav-1)*sqqp)/naflav/2.
1107 c          endif
1108 c
1109 c          if(iqq.eq.1)then
1110 c            stg=0.
1111 c            do i1=1,3
1112 c            do m1=1,2
1113 c              xx=.5+x9(i1)*(m1-1.5)
1114 c              xp=zh**xx
1115 c              xm=zh/xp
1116 c
1117 c              xp1max=(1.-xp)**(1.+alplea(iclp))
1118 c              xm1max=(1.-xm)**(1.+alplea(iclt))
1119 c              do i2=1,3
1120 c              do m2=1,2
1121 c                xp1=1.-(xp1max*(.5+x9(i2)*(m2-1.5)))
1122 c     *          **(1./(1.+alplea(iclp)))
1123 c                do i3=1,3
1124 c                do m3=1,2
1125 c                  xm1=1.-(xm1max*(.5+x9(i3)*(m3-1.5)))
1126 c     *            **(1./(1.+alplea(iclt)))
1127 c                  if(xp1.lt.xp.or.xm1.lt.xm)write (*,*)'xp1,xm1,xp,xm'
1128 c     *            ,xp1,xm1,xp,xm
1129 c
1130 c                  rh=r2had(iclpro)+r2had(icltar)+slopom
1131 c     *            *log(xp1*xm1/xp/xm)
1132 c                  glu1=(1.-xp/xp1)**betpom*(1.-glusea)
1133 c                  sea1=EsoftQZero(xp/xp1)*glusea
1134 c                  glu2=(1.-xm/xm1)**betpom*(1.-glusea)
1135 c                  sea2=EsoftQZero(xm/xm1)*glusea
1136 c                  stg=stg+a9(i1)*a9(i2)*a9(i3)*(glu1*glu2*sgg
1137 c     *            +(glu1*sea2+sea1*glu2)*sgq+sea1*sea2*sqq)
1138 c     *            *xp1max*xm1max*(xp1*xm1)**(dels-alppar)
1139 c     *            *z**(rp/rh)/rh
1140 c                enddo
1141 c                enddo
1142 c              enddo
1143 c              enddo
1144 c            enddo
1145 c            enddo
1146 c            omi5pp=omi5pp-a9(i)*log(zh)*stg/zh**delh
1147 c
1148 c          else
1149 c            stq=0.
1150 c            xpmin=zh**(dels+.5)
1151 c            do i1=1,3
1152 c            do m1=1,2
1153 c              xp=(.5*(1.+xpmin-(2*m1-3)*x9(i1)*(1.-xpmin)))
1154 c     *        **(1./(dels+.5))
1155 c              xm=zh/xp
1156 c              if(xp*xpp.lt..99999)then
1157 c                uv1=psdfh4(xp*xpp,q2min,0.,iclp,1)
1158 c                dv1=psdfh4(xp*xpp,q2min,0.,iclp,2)
1159 c                xm1max=(1.-xm)**(1.+alplea(iclt))
1160 c                do i2=1,3
1161 c                do m2=1,2
1162 c                  xm1=1.-(xm1max*(.5+x9(i2)*(m2-1.5)))
1163 c     *            **(1./(1.+alplea(iclt)))
1164 c
1165 c                  rh=r2had(iclpro)+r2had(icltar)+slopom*log(xm1/xm)
1166 c                  glu2=(1.-xm/xm1)**betpom*(1.-glusea)
1167 c                  sea2=EsoftQZero(xm/xm1)*glusea
1168 c                  stq=stq+a9(i1)*a9(i2)*(glu2*sgq+sea2*sqq)*(uv1+dv1)
1169 c     *            *z**(rp/rh)/rh*xm1max*xm1**(dels-alppar)/sqrt(xp)
1170 c     *            *((1.-xp)/(1.-xp*xpp))**(1.-alpq+alplea(iclp))
1171 c                enddo
1172 c                enddo
1173 c              endif
1174 c            enddo
1175 c            enddo
1176 c            stq=stq*(1.-xpmin)
1177 c            omi5pp=omi5pp+a9(i)*stq/zh**delh
1178 c          endif
1179 c        enddo
1180 c        enddo
1181 c      endif
1182 c
1183 c      omi5pp=omi5pp*(1.-xmin)/(delh-dels)
1184 c      if(iqq.eq.1)then
1185 c        omi5pp=omi5pp*chad(iclp)*chad(iclt)*gamhad(iclp)
1186 c     *  *gamhad(iclt)*ffrr**2*(xpp*xpm)**(1.-alppar)
1187 c     *  /(1.+alplea(iclp))/(1.+alplea(iclt))*pi/8.*factk
1188 c      else
1189 c        omi5pp=omi5pp*chad(iclp)*chad(iclt)*ffrr*gamhad(iclt)
1190 c     *  *xpp**(1.-alpq)*xpm**(1.-alppar)/(.5+dels)
1191 c     *  /(1.+alplea(iclt))/16.*factk
1192 c      endif
1193 c      return
1194 c      end
1195 c
1196 c------------------------------------------------------------------------
1197       function om52pi(sy,xpp,xpm,iqq,je1,je2)   !modified om51pp
1198 c-----------------------------------------------------------------------
1199 c      sy  - energy squared for the hard interaction
1200 c
1201 c      iqq = 0  - sea-sea,
1202 c      iqq = 1  - val-sea,
1203 c      iqq = 2  - sea-val,
1204 c      iqq = 3  - val-val,
1205 c
1206 c      je = emission type
1207 c               0 ... no emissions
1208 c               1 ... emissions
1209 c            else ... all
1210 c
1211 c       already b-averaged  (\int d2b /sigine*10)
1212 c-----------------------------------------------------------------------
1213       common /ar3/    x1(7),a1(7)
1214       common /psar7/  delx,alam3p,gam3p
1215       include 'epos.inc'
1216       include 'epos.incsem'
1217       if(iqq.lt.0.or.iqq.gt.3)stop'om52pi: unvalid  iqq'
1218 
1219       om52pi=0.
1220 
1221       ef1=0
1222       ef2=0
1223       ef3=0
1224       ef4=0
1225       if( je1.ge.1             .and. je2.ge.1)             ef1=1
1226       if( je1.ge.1             .and.(je2.eq.0.or.je2.eq.2))ef2=1
1227       if((je1.eq.0.or.je1.eq.2).and. je2.ge.1)             ef3=1
1228       if((je1.eq.0.or.je1.eq.2).and.(je2.eq.0.or.je2.eq.2))ef4=1
1229 
1230       spmin=4.*q2min
1231       if(sy.le.spmin)goto999
1232 
1233       if(iqq.eq.1)then
1234         iclv=iclpro
1235 ctp060829        icls=icltar
1236       elseif(iqq.eq.2)then
1237 ctp060829        icls=iclpro
1238         iclv=icltar
1239       endif
1240 
1241       delss=dels
1242       if(iqq.eq.3)delss=-0.5
1243       xmin=spmin/sy
1244       xmin=xmin**(delh-delss)
1245       alpq=(alppar+1.)/2.
1246 
1247 c numerical integration over zh
1248       do i=1,7
1249       do m=1,2
1250         zh=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./(delh-delss))
1251          sgg=  ef1  *pijet(2,q2min,q2min,zh*sy,0,0)
1252      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,0,0)
1253      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,0,0)
1254          sgq=  ef1  *pijet(2,q2min,q2min,zh*sy,0,1)
1255      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,0,1)
1256      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,0,1)
1257          sqq=  ef1  *pijet(2,q2min,q2min,zh*sy,1,1)
1258      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,1,1)
1259      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,1,1)
1260         sqaq=  ef1  *pijet(2,q2min,q2min,zh*sy,-1,1)
1261      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,-1,1)
1262      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,-1,1)
1263         sqqp=  ef1  *pijet(2,q2min,q2min,zh*sy,1,2)
1264      *   + (ef2+ef3)*pijet(1,q2min,q2min,zh*sy,1,2)
1265      *   +     ef4  *pijet(0,q2min,q2min,zh*sy,1,2)
1266         sqqi=sqq
1267         sqq=(sqq+sqaq+2.*(naflav-1)*sqqp)/naflav/2.
1268         if(iqq.eq.0)then
1269           stg=0.
1270           do i1=1,7
1271           do m1=1,2
1272             xx=.5+x1(i1)*(m1-1.5)
1273             xp=zh**xx
1274             xm=zh/xp
1275             glu1=EsoftGluonTil(xp)
1276             sea1=EsoftQuarkTil(xp)
1277             glu2=EsoftGluonTil(xm)
1278             sea2=EsoftQuarkTil(xm)
1279             dstg= glu1*glu2*sgg
1280      *            +(glu1*sea2+sea1*glu2)*sgq   !ccccc
1281      *              +sea1*sea2*sqq   !ccccc
1282             stg=stg+a1(i1)*dstg
1283           enddo
1284           enddo
1285           om52pi=om52pi-a1(i)*log(zh)*stg/zh**delh
1286         elseif(iqq.eq.3)then
1287           stq=0.  !int^1_(sqrt(z)) dx_p / x_p / sqrt(1-x_p) =int^(tmax)_(0) dt
1288           tmax=sqrt(1.-sqrt(zh))        !t=ln((1+sqrt(1-x_p))/(1-sqrt(1-x_p)))
1289           tmax=log((1.+tmax)/(1.-tmax))
1290           if(tmax.gt.1.e-20)then
1291           do i1=1,7
1292           do m1=1,2
1293             t=tmax*(.5+x1(i1)*(m1-1.5))
1294             z01=((1.d0-exp(-1.d0*t))/(1.d0+exp(-1.d0*t)))**2
1295             xp=1.-z01
1296             xm=zh/xp
1297             if(xp*xpp.le..9999.and.xm*xpm.le..9999
1298      *      .or.xm*xpp.le..9999.and.xp*xpm.le..9999)then
1299               stq=stq+a1(i1)
1300      *               *(psharg(xp*xpp,xm*xpm,sqqi,sqqp,sqaq)
1301      *                 +psharg(xm*xpp,xp*xpm,sqqi,sqqp,sqaq))
1302      *            *max(1e-20,1.-xp)**(.5-alpq)
1303      *            *max(1e-20,1.-xm)**(-alpq)
1304      *               *xp**delss*xm**delss
1305      *        *xpp**alppar/gamhad(iclpro)             ! Eval
1306      *        *xpm**alppar/gamhad(icltar)             ! Eval
1307             endif
1308           enddo
1309           enddo
1310           stq=stq*tmax
1311           endif
1312           om52pi=om52pi+a1(i)*stq/zh**delh
1313         elseif(iqq.eq.1.or.iqq.eq.2)then
1314           stq=0.
1315           tmax=acos(sqrt(zh))
1316           do i1=1,7
1317           do m1=1,2
1318             t=tmax*(.5+x1(i1)*(m1-1.5))
1319             xp=cos(t)**2
1320             xm=zh/xp
1321             if(xp*xpp.lt..99999)then
1322               uv1=psdfh4(xp*xpp,q2min,0.,iclv,1)      ! Eval
1323               dv1=psdfh4(xp*xpp,q2min,0.,iclv,2)      ! Eval
1324               glu2=EsoftGluonTil(xm)
1325               sea2=EsoftQuarkTil(xm)
1326               dstq=0
1327               if(xp.ne.1.)
1328      *        dstq=(glu2*sgq+sea2*sqq)*(uv1+dv1)
1329      *        *(1.-xp*xpp)**(-1.+alpq-alplea(iclv)) ! Eval
1330      *        *xp**(delss-.5)*(1.-xp)**(-alpq+.5)    ! Eval *sqrt(1-x)/sqrt(x)
1331      *        *xpp**alppar/gamhad(iclv)             ! Eval
1332               stq=stq+a1(i1)*dstq
1333             endif
1334           enddo
1335           enddo
1336           stq=stq*tmax
1337           om52pi=om52pi+a1(i)*stq/zh**delh
1338         else
1339           stop'om52pi: unvalid  iqq (2).            '
1340         endif
1341       enddo
1342       enddo
1343 
1344       om52pi=om52pi*(1.-xmin)/(delh-delss)
1345 
1346       if(iqq.eq.0)then
1347         om52pi=om52pi/4
1348       elseif(iqq.eq.3)then
1349         om52pi=om52pi/4
1350      *  * utgam1(2.+alplea(iclpro)-alpq)                           ! Eval
1351      *     /utgam1(1.+alplea(iclpro))/utgam1(1.-alpq)           ! Eval
1352      *  * utgam1(2.+alplea(icltar)-alpq)                           ! Eval
1353      *     /utgam1(1.+alplea(icltar))/utgam1(1.-alpq)           ! Eval
1354      *  /xpp**alpq/xpm**alpq                                       ! Eval
1355       elseif(iqq.le.2)then
1356         om52pi=om52pi/2
1357      *  *utgam1(2.+alplea(iclv)-alpq)/utgam1(1.+alplea(iclv)) ! Eval
1358      *  /utgam1(1.-alpq)                                      ! Eval
1359      *  /xpp**alpq                                            ! Eval
1360       endif
1361 
1362  999  continue
1363       om52pi=om52pi*factk * .0390   /sigine*10  /2.
1364        end
1365 
1366 c------------------------------------------------------------------------
1367       function psharg(zh1,zh2,sqq,sqqp,sqaq)
1368 c-----------------------------------------------------------------------
1369       include 'epos.incsem'
1370       include 'epos.inc'
1371 
1372       alpq=(alppar+1.)/2.
1373       if(zh1.le..9999.and.zh2.le..9999)then
1374         uv1=psdfh4(zh1,q2min,0.,iclpro,1)
1375         dv1=psdfh4(zh1,q2min,0.,iclpro,2)
1376         uv2=psdfh4(zh2,q2min,0.,icltar,1)
1377         dv2=psdfh4(zh2,q2min,0.,icltar,2)
1378         if(iclpro.eq.2.and.icltar.eq.2)then       !proton
1379           fff=sqq*(uv1*uv2+dv1*dv2)+sqqp*(uv1*dv2+dv1*uv2)
1380         elseif(iclpro.eq.1.or.icltar.eq.1)then   !pion
1381           fff=sqq*uv1*uv2+sqaq*dv1*dv2+sqqp*(uv1*dv2+dv1*uv2)
1382         elseif(iclpro.eq.3.or.icltar.eq.3)then   !kaon
1383           fff=sqq*uv1*uv2+sqqp*(uv1*dv2+dv1*uv2+dv1*dv2)
1384         elseif(iclpro.eq.4.or.icltar.eq.4)then   !J/psi
1385           fff=sqq*uv1*(uv2+dv2)
1386         else
1387           fff=0.
1388           call utstop("Projectile not know in psharg !&")
1389         endif
1390         psharg=fff
1391      *               *(1.-zh1)**(-1.+alpq-alplea(iclpro))
1392      *               *(1.-zh2)**(-1.+alpq-alplea(icltar))
1393       else
1394         psharg=0.
1395       endif
1396       return
1397       end
1398 
1399 c------------------------------------------------------------------------
1400       function om51pp(sy,xpp,z,iqq)   !former psfsh
1401 c-----------------------------------------------------------------------
1402 c om51pp - semihard interaction eikonal
1403 c sy  - energy squared for the hard interaction,
1404 c z   - impact parameter factor, z=exp(-b**2/rp),
1405 c iqq - type of the hard interaction:
1406 c   0 - gg, 1 - qg, 2 - gq, 3 - gg(int), 4 - gg(proj), 5 - qg(proj),
1407 c   6 - gg(int)|b=0, 7 - <b^2*gg(int)>, 8 - gg(proj)|b=0,
1408 c   9 - <b^2*gg(proj)>, 10 - qg(proj)|b=0, 11 - <b^2*qg(proj)>
1409 c-----------------------------------------------------------------------
1410       common /ar3/    x1(7),a1(7)
1411       common /psar7/  delx,alam3p,gam3p
1412       include 'epos.inc'
1413       include 'epos.incsem'
1414 
1415       om51pp=0.
1416       if(iqq.eq.0.or.iqq.eq.3.or.iqq.eq.4
1417      *.or.iqq.eq.6.or.iqq.eq.7.or.iqq.eq.8.or.iqq.eq.9
1418      *.or.iclpro.ne.4.and.(iqq.eq.1.or.iqq.eq.5
1419      *.or.iqq.eq.10.or.iqq.eq.11)
1420      *.or.icltar.ne.4.and.iqq.eq.2)then
1421         spmin=4.*q2min
1422       else
1423         spmin=4.*q2min+2.*qcmass**2
1424       endif
1425       if(sy.le.spmin)goto999
1426 
1427       icls=iclpro
1428       if(iqq.eq.1.or.iqq.eq.5.or.iqq.eq.10.or.iqq.eq.11)then
1429         iclv=iclpro
1430         icls=icltar
1431       elseif(iqq.eq.2)then
1432         icls=iclpro
1433         iclv=icltar
1434       endif
1435 
1436       xmin=spmin/sy
1437       xmin=xmin**(delh-dels)
1438       rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
1439       alpq=(alppar+1.)/2.
1440 
1441 c numerical integration over zh
1442       do i=1,7
1443       do m=1,2
1444         zh=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./
1445      *  (delh-dels))
1446         if(iqq.eq.0.or.iqq.eq.3.or.iqq.eq.4
1447      *  .or.iqq.eq.6.or.iqq.eq.7.or.iqq.eq.8.or.iqq.eq.9
1448      *  .or.iclpro.ne.4.and.(iqq.eq.1.or.iqq.eq.5
1449      *  .or.iqq.eq.10.or.iqq.eq.11)
1450      *  .or.icltar.ne.4.and.iqq.eq.2)then
1451           call psjti0(zh*sy,sgg,sggb,0,0)  !inclusive (sj) and born (sjb)
1452           call psjti0(zh*sy,sgq,sgqb,0,1)
1453           call psjti0(zh*sy,sqq,sqqb,1,1)
1454           call psjti0(zh*sy,sqaq,sqaqb,-1,1)
1455           call psjti0(zh*sy,sqqp,sqqpb,1,2)
1456           sqq=(sqq+sqaq+2.*(naflav-1)*sqqp)/naflav/2.
1457 c...........test.......
1458 c      tgg=   psjet(q2min,q2min,q2min,zh*sy,0,0,0)
1459 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,0,0,0)
1460 c     *   +  psborn(q2min,q2min,q2min,zh*sy,0,0,0,1)
1461 c      tgq=   psjet(q2min,q2min,q2min,zh*sy,0,1,0)
1462 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,0,1,0)
1463 c     *   +  psborn(q2min,q2min,q2min,zh*sy,0,1,0,1)
1464 c      tqq=   psjet(q2min,q2min,q2min,zh*sy,1,1,0)
1465 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,1,1,0)
1466 c     *   +  psborn(q2min,q2min,q2min,zh*sy,1,1,0,1)
1467 c      tqa=   psjet(q2min,q2min,q2min,zh*sy,-1,1,0)
1468 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,-1,1,0)
1469 c     *   +  psborn(q2min,q2min,q2min,zh*sy,-1,1,0,1)
1470 c      tqqp=  psjet(q2min,q2min,q2min,zh*sy,1,2,0)
1471 c     *   +2*psjet1(q2min,q2min,q2min,zh*sy,1,2,0)
1472 c     *   +  psborn(q2min,q2min,q2min,zh*sy,1,2,0,1)
1473 c      write(6,'(f12.2,3x,2f7.3,2(3x,2f7.3))')
1474 c     * zh*sy,tgg,sgg, tgq,sgq, tqqp,sqqp
1475 c.......................
1476         else
1477           call psjti0(zh*sy,sgq,sgqb,4,0)
1478           call psjti0(zh*sy,sqq,sqqb,4,1)
1479         endif
1480 
1481         if(iqq.eq.0.or.iqq.eq.3.or.iqq.eq.4
1482      *  .or.iqq.eq.6.or.iqq.eq.7.or.iqq.eq.8.or.iqq.eq.9)then
1483           stg=0.
1484           do i1=1,7
1485           do m1=1,2
1486             xx=.5+x1(i1)*(m1-1.5)
1487             xp=zh**xx
1488             xm=zh/xp
1489             glu1=(1.-xp)**betpom*(1.-glusea)
1490             sea1=EsoftQZero(xp)*glusea
1491             glu2=(1.-xm)**betpom*(1.-glusea)
1492             sea2=EsoftQZero(xm)*glusea
1493             rh=0.
1494             if(iqq.eq.0)then
1495               rh=r2had(iclpro)+r2had(icltar)-slopom*log(zh)
1496             elseif(iqq.eq.3.or.iqq.eq.4)then
1497               rh=1.
1498             elseif(iqq.eq.6.or.iqq.eq.7)then
1499               rh=alam3p-slopom*log(zh)
1500             elseif(iqq.eq.8.or.iqq.eq.9)then
1501               rh=r2had(iclpro)+.5*alam3p-slopom*log(zh)
1502             endif
1503             dstg=(glu1*glu2*sgg+
1504      *      (glu1*sea2+sea1*glu2)*sgq+sea1*sea2*sqq)
1505      *      *z**(rp/rh)/rh
1506             if(iqq.eq.7.or.iqq.eq.9)dstg=dstg*rh**2
1507             stg=stg+a1(i1)*dstg
1508           enddo
1509           enddo
1510           om51pp=om51pp-a1(i)*log(zh)*stg/zh**delh
1511         else
1512           stq=0.
1513           tmax=acos(sqrt(zh))
1514           do i1=1,7
1515           do m1=1,2
1516             t=tmax*(.5+x1(i1)*(m1-1.5))
1517             xp=cos(t)**2
1518             xm=zh/xp
1519             if(xp*xpp.lt..99999)then
1520               uv1=psdfh4(xp*xpp,q2min,0.,iclv,1)
1521               dv1=psdfh4(xp*xpp,q2min,0.,iclv,2)
1522               glu2=(1.-xm)**betpom*(1.-glusea)
1523               sea2=EsoftQZero(xm)*glusea
1524               rh=0.
1525               if(iqq.le.2)then
1526                 rh=r2had(iclpro)+r2had(icltar)-slopom*log(xm)
1527               elseif(iqq.eq.5)then
1528                 rh=1.
1529               elseif(iqq.le.10.or.iqq.le.11)then
1530                 rh=r2had(iclpro)+.5*alam3p-slopom*log(xm)
1531               endif
1532               dstq=0
1533               if(xp.ne.1.)
1534      *        dstq=(glu2*sgq+sea2*sqq)*(uv1+dv1)
1535      *        *z**(rp/rh)/rh
1536      *        *(1.-xp*xpp)**(-1.+alpq-alplea(iclv))
1537      *        *xp**(dels-.5)*(1.-xp)**(-alpq+.5)
1538               if(iqq.eq.11)dstq=dstq*rh**2
1539               stq=stq+a1(i1)*dstq
1540             endif
1541           enddo
1542           enddo
1543           stq=stq*tmax
1544           om51pp=om51pp+a1(i)*stq/zh**delh
1545         endif
1546       enddo
1547       enddo
1548 
1549       om51pp=om51pp*(1.-xmin)/(delh-dels)/sy**delh/2.
1550       if(iqq.eq.0)then
1551         om51pp=om51pp*chad(iclpro)*chad(icltar)*gamhad(iclpro)
1552      *  *gamhad(icltar)*ffrr**2*pi
1553       elseif(iqq.eq.3)then
1554         om51pp=om51pp*ffrr**2*pi*4.*.0389
1555       elseif(iqq.eq.6)then
1556         om51pp=om51pp*ffrr**2*pi
1557       elseif(iqq.eq.7)then
1558         om51pp=om51pp*ffrr**2*pi*(4.*.0389)**2
1559       elseif(iqq.eq.4.or.iqq.eq.8.or.iqq.eq.9)then
1560         om51pp=om51pp*ffrr**2*pi*chad(iclpro)*gamhad(iclpro)
1561         if(iqq.eq.4)om51pp=om51pp*4.*.0389
1562         if(iqq.eq.9)om51pp=om51pp*(4.*.0389)**2
1563       elseif(iqq.le.2)then
1564         om51pp=om51pp*chad(iclpro)*chad(icltar)*ffrr*gamhad(icls)
1565      *  *utgam1(2.+alplea(iclv)-alpq)/utgam1(1.+alplea(iclv))
1566      *  /utgam1(1.-alpq)/2./xpp**alpq
1567       elseif(iqq.eq.5.or.iqq.eq.10.or.iqq.eq.11)then
1568         om51pp=om51pp*chad(iclv)*ffrr
1569      *  *utgam1(2.+alplea(iclv)-alpq)/utgam1(1.+alplea(iclv))
1570      *  /utgam1(1.-alpq)/2./xpp**alpq
1571         if(iqq.eq.5)om51pp=om51pp*4.*.0389
1572         if(iqq.eq.11)om51pp=om51pp*(4.*.0389)**2
1573       endif
1574  999  continue
1575       end
1576 
1577 c-------------------------------------------------------------------------------
1578       subroutine epocrossc(niter,gtot,gprod,gabs,gcoh,gqel,gdd)
1579 c-------------------------------------------------------------------------------
1580 c epocrossc - nucleus-nucleus (nucleus-hydrogen) interaction cross sections
1581 c by calculation will real nuclear profiles and eikonal (simplified simulations)
1582 c gtot  - total cross section
1583 c gprod - production cross section (all diffraction included)
1584 c gabs  - cut Pomerons cross section (no diffraction at all)
1585 c gdd   - proj (ionudi=2) or proj or targ (ionudi=0/3) excited diffraction
1586 c         cross section
1587 c gcoh  - coherent (elastic with respect to the projectile) cross section
1588 c      (non excited diff proj if ionudi=2, non excited proj+targ if ionudi=0/3)
1589 c
1590 c Be careful : this function is not symmetric for gdd and gqel (only projectile
1591 c diffraction) in case of ionudi=2.
1592 c (target diffraction is not treated explicitely and contributes to
1593 c gprod, gdd, gcoh and gtot).
1594 c
1595 c WARNING : results are sure only in case of ionudi=1 (no substraction from
1596 c           diffractive part) in particular for AA with A > 10 (nuclear diff
1597 c           not well described). For pA seems to be OK with ionudi 2 and 3.
1598 c
1599 c code from QGSJET programs by S.Ostapchenko
1600 c-------------------------------------------------------------------------------
1601       include 'epos.inc'
1602       include 'epos.incems'
1603       common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
1604      *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
1605       common/geom/rmproj,rmtarg,bmax,bkmx
1606       dimension wabs(28),wdd(28),wcoh(28),wprod(28),wqel(28)
1607      &         ,b0(28),ai(28)
1608       common /ar3/ x1(7),a1(7)
1609       double precision xgabs,xgdd,xgprod,xgcoh,xgqel
1610 
1611       call utpri('epocrs',ish,ishini,2)
1612       if(ish.ge.2)write(ifch,201)niter,bmax
1613       kollini=koll        !koll modified
1614       do i=1,7
1615        b0(15-i)=bmax*sqrt((1.+x1(i))/2.)
1616        b0(i)=bmax*sqrt((1.-x1(i))/2.)
1617        ai(i)=a1(i)*bmax**2*pi*5.05        !factor change cs
1618        ai(15-i)=ai(i)
1619       enddo
1620       if(maproj.gt.1.or.matarg.gt.1)then
1621         difn=max(difnuc(maproj),difnuc(matarg))
1622       else
1623         difn=1.
1624       endif
1625       do i=1,7
1626         tp=(1.+x1(i))/2.
1627         tm=(1.-x1(i))/2.
1628         b0(14+i)=bmax-log(tp)*difn
1629         b0(29-i)=bmax-log(tm)*difn
1630         ai(14+i)=a1(i)*b0(14+i)/tp*10.*difn*pi
1631         ai(29-i)=a1(i)*b0(29-i)/tm*10.*difn*pi
1632       enddo
1633       do i=1,28
1634        wabs(i)=0.
1635        wdd(i)=0.
1636        wprod(i)=0.
1637        wcoh(i)=0.
1638        wqel(i)=0.
1639       enddo
1640       do nc=1,niter
1641         if(maproj.eq.1)then
1642           xproj(1)=0.
1643           yproj(1)=0.
1644           zproj(1)=0.
1645         else
1646           call conxyz('p',mamx,xproj,yproj,zproj,ypjtl-yhaha)
1647         endif
1648         if(matarg.eq.1)then
1649           xtarg(1)=0.
1650           ytarg(1)=0.
1651           ztarg(1)=0.
1652         else
1653           call conxyz('t',mamx,xtarg,ytarg,ztarg,yhaha)
1654         endif
1655 
1656         do i=1,28
1657           call epogcr(b0(i),xgabs,xgdd,xgprod,xgcoh,xgqel)
1658           wabs(i)=wabs(i)+sngl(xgabs)
1659           wdd(i)=wdd(i)+sngl(xgdd)
1660           wprod(i)=wprod(i)+sngl(xgprod)
1661           wcoh(i)=wcoh(i)+sngl(xgcoh)
1662           wqel(i)=wqel(i)+sngl(xgqel)
1663         enddo
1664       enddo
1665 
1666       gabs=0.
1667       gdd=0.
1668       gcoh=0.
1669       gprod=0.
1670       gqel=0.
1671       do i=1,28
1672        wabs(i)=wabs(i)/niter
1673        wdd(i)=wdd(i)/niter
1674        wcoh(i)=wcoh(i)/niter
1675        wprod(i)=wprod(i)/niter
1676        wqel(i)=wqel(i)/niter
1677        gabs=gabs+ai(i)*wabs(i)
1678        gdd=gdd+ai(i)*wdd(i)
1679        gcoh=gcoh+ai(i)*wcoh(i)
1680        gqel=gqel+ai(i)*wqel(i)
1681        gprod=gprod+ai(i)*wprod(i)
1682       enddo
1683 
1684 
1685       gtot=gprod+gcoh            !total=all cut (with diff) + all uncut
1686       if(ish.ge.2)write (ifch,202)gtot,gprod,gabs,gdd,gcoh,gqel
1687 
1688 201   format(2x,'epocrossc - A-B interaction cross sections,'
1689      *,' N of iter.:',i5,' bmax:',f5.2)
1690 202   format(2x,'epocrossc: gtot=',e10.3,2x,'gprod=',e10.3,2x
1691      *,'gabs=',e10.3/4x,'gdd=',e10.3,2x,'gcoh=',e10.3,'gqel=',e10.3)
1692 
1693 
1694       koll=kollini
1695       call utprix('epocrs',ish,ishini,2)
1696 
1697       return
1698       end
1699 
1700 c-------------------------------------------------------------------------------
1701       subroutine epogcr(b,gabs,gdd,gprod,gcoh,gqel)
1702 c-------------------------------------------------------------------------------
1703 c epogcr - integrands (b-profiles) for nucleus-nucleus cross sections
1704 c b - impact parameter
1705 c code from QGSJET programs by S.Ostapchenko
1706 c-------------------------------------------------------------------------------
1707       include 'epos.inc'
1708       include 'epos.incems'
1709       include 'epos.incpar'
1710       common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
1711      *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
1712       common/geom/rmproj,rmtarg,bmax,bkmx
1713       common/scrangle/ phik3(kollmx),thetak3(kollmx)
1714       double precision vin,gabs,gdd,gprod,gcoh,fdd,gqel,fdt,vdt,vcu
1715 
1716       if(ish.ge.9)write (ifch,201)b
1717       gprod=1d0
1718       gabs=1d0
1719       gdd=1d0
1720       fdd=1d0
1721       fdt=1d0
1722       bx=0
1723       by=0
1724 
1725       if(maproj.eq.1.and.matarg.eq.1)then
1726         if(b.gt.bkmx)then
1727           koll=0
1728         else
1729           koll=1
1730           bk(1)=b
1731           iproj(1)=1
1732           itarg(1)=1
1733           lproj(1)=1
1734           ltarg(1)=1
1735           lproj3(1)=1
1736           ltarg3(1)=1
1737           kproj3(1,1)=1
1738           ktarg3(1,1)=1
1739           kproj(1,1)=1
1740           ktarg(1,1)=1
1741         endif
1742       else
1743         bx=b
1744         by=0.
1745         koll=0
1746         do i=1,maproj
1747           lproj(i)=0
1748           lproj3(i)=0
1749         enddo
1750         do j=1,matarg
1751           ltarg(j)=0
1752           ltarg3(j)=0
1753         enddo
1754         do 12 i=1,maproj
1755         do 11 j=1,matarg
1756           bij=sqrt((xproj(i)+bx-xtarg(j))**2+(yproj(i)+by-ytarg(j))**2)
1757           if(bij.gt.bkmx)goto 11
1758 
1759           koll=koll+1
1760           if(koll.gt.kollmx)call utstop('epogcr: kollmx too small&')
1761           bk(koll)=bij
1762           bkx(koll)=xproj(i)+bx-xtarg(j)
1763           bky(koll)=yproj(i)+by-ytarg(j)
1764           iproj(koll)=i
1765           itarg(koll)=j
1766           lproj(i)=lproj(i)+1
1767           ltarg(j)=ltarg(j)+1
1768           kproj(i,lproj(i))=koll
1769           ktarg(j,ltarg(j))=koll
1770           if(iscreen.ne.0.and.bij.le.bkmxndif)then
1771             if(zbrmax.gt.0..and.bij.gt.zbcut+zbrmax*rangen())goto 11
1772             lproj3(i)=lproj3(i)+1
1773             ltarg3(j)=ltarg3(j)+1
1774             kproj3(i,lproj3(i))=koll
1775             ktarg3(j,ltarg3(j))=koll
1776 c define angle for anti-shadowing
1777             if(abs(bky(koll)).gt.1.e-6)then
1778               if(abs(bkx(koll)).gt.1.e-6)then
1779                 phik3(koll)=atan(bky(koll)/bkx(koll))
1780               else
1781                 phik3(koll)=sign(0.5*pi,bky(koll))
1782               endif
1783             elseif(bkx(koll).lt.0.)then
1784               phik3(koll)=pi
1785             endif
1786             if(bk(koll).gt.0.)then
1787               thetak3(koll)=atan(bglaubx/bk(koll))
1788             else
1789               thetak3(koll)=0.5*pi
1790             endif
1791           endif
1792 
1793  11     continue
1794  12     continue
1795       endif
1796       if(koll.eq.0)then
1797         gabs=0d0
1798         gdd=0d0
1799         gprod=0d0
1800         gcoh=0d0
1801         gqel=0d0
1802         goto 1000
1803       endif
1804       if(iscreen.ne.0)call CalcScrPair(b)
1805 
1806       irea=-1
1807       call GfunParK(irea)
1808       if(ionudi.eq.0
1809      &  .and.(maproj.ne.1.or.matarg.ne.1).and.nglevt.eq.0)then
1810         gabs=0d0
1811         gdd=0d0
1812         gprod=0d0
1813         gcoh=0d0
1814         gqel=0d0
1815         goto 1000
1816       endif
1817       call integom1(irea)
1818 
1819       do n=1,maproj
1820        call epov(n,vin,vcu,vdt)
1821        gprod=gprod*vin
1822        gabs=gabs*vcu
1823        fdd=fdd*(1.-rexdif(iclpro))
1824      &        **(1.+rexres(iclpro)*float(lproj(n)-1))
1825        fdt=fdt*vdt
1826       enddo
1827       gprod=min(gprod,1.d0)
1828       gcoh=1d0-2d0*sqrt(gprod)+gprod
1829       gprod=1d0-gprod
1830       gabs=max(0d0,1d0-gabs)          !cut (no diffraction)
1831       gdd=max(0d0,gprod-gabs)       !diffractive part
1832       gqel=0d0
1833       if(ionudi.eq.2.and.maproj+matarg.gt.2)then
1834         gqel=fdd*gdd      !quasielastic = diffractive without excited proj.
1835         if(iLHC.eq.1)gqel=gqel-fdd*fdt*gdd  !DPE counted as inelastic
1836         gdd=gdd-gqel             !only excited projectile diffraction
1837       elseif(iLHC.ne.1)then
1838         gqel=fdd*fdt*gdd !quasielastic = diffractive without excited proj. or targ
1839         gdd=gdd-gqel     !inelastic part due to excited diffraction
1840       endif
1841  1000 continue
1842       if(ish.ge.9)write (ifch,202)gabs,gdd,gprod,gcoh,gqel,fdd,fdt
1843 
1844 201   format(2x,'epogcr-integrands for nucleus-nucleus cross sections,'
1845      *,' b=',e10.3)
1846 202   format(2x,'epogcr: gabs=',e10.3,2x,'gdd=',e10.3,2x,'gprod=',e10.3
1847      *,2x,'gcoh=',e10.3,2x,'gqel=',e10.3,2x,'fdd=',e10.3,' fdt=',e10.3)
1848       return
1849       end
1850 
1851 c=============================================================================
1852       subroutine epov(n,vin,vcu,vdt)
1853 c epov - eikonal factors for nucleus-nucleus interaction
1854 c (used for cross-section calculation)
1855 c n - projectile nucleon indice
1856 c vin - all uncut pomerons
1857 c vcu - all uncut non diff pomerons
1858 c vdt - non diffractive excitation factor for target
1859 c code from QGSJET programs by S.Ostapchenko
1860 c----------------------------------------------------------------------------
1861       include 'epos.inc'
1862       include 'epos.incems'
1863       common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
1864      *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
1865       double precision vvv2,vvv1,dv,vin,vcu,vdt,PhiExpoK,PhiExpoK2
1866 
1867       if(ish.ge.9)write (ifch,201)xproj(n),yproj(n)
1868 
1869       vin=0.d0
1870       vcu=0.d0
1871       vvv1=1.d0
1872       vvv2=1.d0
1873       dv=1.d0
1874       do m=1,lproj(n)
1875         k=kproj(n,m)
1876         vvv2=vvv2*max(0.d0,PhiExpoK2(k,1.d0,1.d0))
1877         vvv1=vvv1*max(0.d0,PhiExpoK(k,1.d0,1.d0))
1878         dv=dv*(1.-rexdif(icltar))
1879      &        **(1.+rexres(icltar)*float(ltarg(m)-1))
1880       enddo
1881       vcu=vvv2
1882       vin=vvv1                    !exp(-2 * chi)
1883       vdt=dv
1884 
1885       if(ish.ge.9)write (ifch,202)vin,vcu,vdt
1886       if(ish.ge.9)write (ifch,203)
1887 
1888 201   format(2x,'epov - eikonal factor: nucleon coordinates x=',
1889      *e10.3,2x,'y=',e10.3)
1890 202   format(2x,'vin=',e10.3,2x,'vcu=',e10.3,2x,'vdt=',e10.3)
1891 203   format(2x,'epov - end')
1892       return
1893       end
1894 
1895 c------------------------------------------------------------------------
1896       subroutine psfz(iqq,gz2,b)
1897 c-----------------------------------------------------------------------
1898 c hadron-nucleus cross sections calculation
1899 c b - impact parameter squared
1900 C iqq - 1 = elastic cross section
1901 C       2 = inelastic cross section
1902 c-----------------------------------------------------------------------
1903       double precision PhiExpo
1904       include 'epos.inc'
1905       include 'epos.incems'
1906       include 'epos.incpar'
1907       common /ar3/ x1(7),a1(7)
1908       external pttcs,pprcs
1909 
1910       gz2=0.
1911       e1=exp(-1.)
1912       if(iomega.eq.2)then      !no dif
1913         rs=r2had(iclpro)+r2had(icltar)+slopom*log(engy**2)
1914       else
1915         rs=r2had(iclpro)+r2had(icltar)+max(slopom,slopoms)*log(engy**2)
1916      &     +gwidth*(r2had(iclpro)+r2had(icltar))
1917      &     +bmxdif(iclpro,icltar)/4./0.0389
1918       endif
1919       rpom=4.*.0389*rs
1920       kollini=koll        !koll modified in zzfz
1921       koll=1
1922       if(iscreen.ne.0.and.(maproj.gt.1.or.matarg.gt.1))then
1923         call zzfz(zzp,zzt,kollth,b)
1924         koll=kollth
1925       else
1926         zzp=0.
1927         zzt=0.
1928       endif
1929 
1930       do i1=1,7
1931       do m=1,2
1932         z=.5+x1(i1)*(m-1.5)
1933         zv1=exp(-z)
1934         zv2=(e1*z)
1935         b1=sqrt(-rpom*log(zv1))
1936         b2=sqrt(-rpom*log(zv2))
1937 
1938         if(maproj.eq.1.and.matarg.eq.1)then
1939           cg1=1.
1940           cg2=1.
1941         elseif(matarg.eq.1)then
1942           cg1=ptrot(pprcs,b,b1)
1943           cg2=ptrot(pprcs,b,b2)
1944         else
1945           cg1=ptrot(pttcs,b,b1)
1946           cg2=ptrot(pttcs,b,b2)
1947         endif
1948 
1949         vv21=sngl(Phiexpo(zzp,zzt,1.,1.d0,1.d0,engy**2,b1))
1950         vv22=sngl(Phiexpo(zzp,zzt,1.,1.d0,1.d0,engy**2,b2))
1951         if(iqq.ne.1)then
1952           gz2=gz2+a1(i1)*(cg1*(1.-vv21)+cg2*(1.-vv22)/z)
1953         else
1954           vv11=sngl(Phiexpo(zzp,zzt,0.5,1.d0,1.d0,engy**2,b1))
1955           vv12=sngl(Phiexpo(zzp,zzt,0.5,1.d0,1.d0,engy**2,b2))
1956           gz2=gz2+a1(i1)*(cg1*(vv21-2.*vv11+1.)
1957      &                   +cg2*(vv22-2.*vv12+1.)/z)
1958         endif
1959       enddo
1960       enddo
1961       gz2=gz2*rpom*0.5
1962 
1963       koll=kollini
1964 
1965       return
1966       end
1967 
1968 c------------------------------------------------------------------------
1969       subroutine zzfz(zzp,zzt,kollth,b)
1970 c-----------------------------------------------------------------------
1971 c hadron-nucleus cross sections calculation
1972 c b - impact parameter squared
1973 C xsfct - 0.5 = total cross section
1974 C         1.0 = inelastic cross section
1975 c-----------------------------------------------------------------------
1976       common /psar50/ zznuc,b2xnuc
1977       include 'epos.inc'
1978       include 'epos.incems'
1979       include 'epos.incpar'
1980       common /ar3/ x1(7),a1(7)
1981       external  pttcs,pprcs,pttzz,pprzz
1982 
1983       zzp=0.
1984       zzt=0.
1985       kollth=1
1986       if(iscreen.eq.0.or.(maproj.eq.1.and.matarg.eq.1))return
1987 
1988       rs=r2had(iclpro)+r2had(icltar)+slopom*log(engy**2)
1989       rpom=4.*.0389*rs
1990       bgl2=2.*rpom*epscrp
1991       zzpp=epscrw*fscra(engy/egyscr)
1992 c caculate the radius where Z is saturated at epscrx to define the bases
1993 c of nuclear shadowing
1994       satrad=0.
1995       if(zzpp.gt.0.)satrad=-bgl2*log(epscrx/zzpp)
1996       bglx=zbrads*sqrt(max(0.1,satrad))
1997       fzbrmax=1.
1998       if(zbrmax.gt.0)fzbrmax=zbrmax
1999       fzbcut=1.
2000       if(zbcut.gt.0)fzbcut=zbcut*bglx
2001       fzbrads=1.
2002       if(bglx.gt.0)fzbrads=bglx
2003       fnuc=1.2*fzbcut/fzbrads
2004       b2xnuc=bgl2+4.*fzbrmax*sqrt(float(maproj*matarg))*fnuc
2005 
2006 
2007       e1=exp(-1.)
2008 
2009       colp=0.
2010       colt=0.
2011       do i1=1,7
2012       do m=1,2
2013         z=.5+x1(i1)*(m-1.5)
2014         zv1=exp(-z)
2015         zv2=(e1*z)
2016         b1=sqrt(-rpom*log(zv1))
2017         b2=sqrt(-rpom*log(zv2))
2018 
2019 
2020         if(maproj.gt.1)then
2021           cg1=ptrot(pprcs,b,b1)
2022           cg2=ptrot(pprcs,b,b2)
2023           colnuc=a1(i1)*(cg1+cg2/z)
2024           colp=colp+colnuc
2025           rho=0.05
2026           zznuc=epscrw*fscro(engy/egyscr,rho)
2027           zp1=ptrot(pprzz,b,b1)
2028           zp2=ptrot(pprzz,b,b2)
2029           zzp=zzp+a1(i1)*(zp1+zp2/z)
2030         endif
2031         if(matarg.gt.1)then
2032           cg1=ptrot(pttcs,b,b1)
2033           cg2=ptrot(pttcs,b,b2)
2034           colnuc=a1(i1)*(cg1+cg2/z)
2035           colt=colt+colnuc
2036           rho=0.05
2037           zznuc=epscrw*fscro(engy/egyscr,rho)
2038           zt1=ptrot(pttzz,b,b1)
2039           zt2=ptrot(pttzz,b,b2)
2040           zzt=zzt+a1(i1)*(zt1+zt2/z)
2041         endif
2042 
2043       enddo
2044       enddo
2045       colp=sqrt(colp)
2046       colt=sqrt(colt)
2047       if(colp.gt.1.)then
2048         kollth=nint(max(1.,colp))
2049         colp=fnuc*log(colp)
2050         zzp=sqrt(zzp)
2051         zzp=0.01*zzp*colp*bgl2
2052 c saturation
2053         zzp=min(zzp,colp*epscrx)
2054       else
2055         zzp=0.
2056       endif
2057       if(colt.gt.1.)then
2058         kollth=nint(max(1.,kollth+colt))
2059         colt=fnuc*log(colt)
2060         zzt=sqrt(zzt)
2061         zzt=0.01*zzt*colt*bgl2
2062 c saturation
2063         zzt=min(zzt,colt*epscrx)
2064       else
2065         zzt=0.
2066       endif
2067 c      zzp=zzp*2.   !correction to have formula=MC
2068 c      zzt=zzt*2.
2069 
2070 c      print *,'ici',b,zzp,zzt,kollth,b2xnuc
2071 
2072       return
2073       end
2074 
2075 
2076 c------------------------------------------------------------------------
2077       function ptgau(func,bm,ipt,iqq)
2078 c-----------------------------------------------------------------------
2079 c impact parameter integration for impact parameters <bm -
2080 c for nucleus-nucleus and hadron-nucleus cross-sections calculation
2081 c ipt=1 : projectile, ipt=2 : target
2082 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2083 c-----------------------------------------------------------------------
2084       include 'epos.inc'
2085       common /ar3/ x1(7),a1(7)
2086       external func
2087 
2088       ptgau=0.
2089       do i=1,7
2090       do m=1,2
2091         b=bm*sqrt(.5+x1(i)*(m-1.5))
2092         ptgau=ptgau+func(b,ipt,iqq)*a1(i)
2093       enddo
2094       enddo
2095       ptgau=ptgau*bm**2*pi*.5
2096       return
2097       end
2098 
2099 c------------------------------------------------------------------------
2100       function ptgau1(bm,ipt,iqq)
2101 c-----------------------------------------------------------------------
2102 c impact parameter integration for impact parameters >bm -
2103 c for hadron-nucleus cross-sections calculation
2104 c ipt=1 : projectile, ipt=2 : target
2105 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2106 c-----------------------------------------------------------------------
2107       include 'epos.inc'
2108       common /ar5/    x5(2),a5(2)
2109 
2110       ptgau1=0.
2111       if(ipt.eq.1)then
2112         difn=difnuc(maproj)
2113       else
2114         difn=difnuc(matarg)
2115       endif
2116       do i=1,2
2117         b=bm+x5(i)*difn
2118         ptgau1=ptgau1+ptfau(b,ipt,iqq)*a5(i)*exp(x5(i))*b*2.*pi*difn
2119       enddo
2120       return
2121       end
2122 c------------------------------------------------------------------------
2123       function ptgau2(bm,iqq)
2124 c-----------------------------------------------------------------------
2125 c impact parameter integration for impact parameters >bm -
2126 c for nucleus-nucleus cross-sections calculation
2127 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2128 c-----------------------------------------------------------------------
2129       include 'epos.inc'
2130       common /ar5/    x5(2),a5(2)
2131 
2132       ptgau2=0.
2133       difn=difnuc(maproj)+difnuc(matarg)
2134       do i=1,2
2135         b=bm+x5(i)*difn
2136         ptgau2=ptgau2+ptfauAA(b,iqq)*a5(i)*exp(x5(i))*b*2.*pi*difn
2137       enddo
2138       return
2139       end
2140 
2141 
2142 c------------------------------------------------------------------------
2143       function ptfau(b,ipt,iqq)
2144 c-----------------------------------------------------------------------
2145 c ptfau - integrands for hadron-nucleus cross-sections calculation
2146 c ipt=1 : projectile, ipt=2 : target
2147 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2148 c-----------------------------------------------------------------------
2149       include 'epos.inc'
2150       common /psar35/ anorm,anormp
2151 
2152       call psfz(iqq,gz2,b)
2153 
2154       if(ipt.eq.1)then
2155         ptfau=1.-max(0.,(1.-anormp*gz2))**maproj
2156       else
2157         ptfau=1.-max(0.,(1.-anorm*gz2))**matarg
2158       endif
2159 
2160       return
2161       end
2162 
2163 c------------------------------------------------------------------------
2164       function ptfauAA(b,iqq)
2165 c-----------------------------------------------------------------------
2166 c ptfau - integrands for hadron-nucleus cross-sections calculation
2167 c iqq=1 : elastic xsection, iqq=2 : inelastic cross section
2168 c-----------------------------------------------------------------------
2169       include 'epos.inc'
2170       common /ar3/    x1(7),a1(7)
2171       common /psar35/ anorm,anormp
2172       external pprcs
2173 
2174       ptfauAA=0.
2175       e1=exp(-1.)
2176       rs=r2had(iclpro)+r2had(icltar)+max(slopom,slopoms)*log(engy**2)
2177      &     +gwidth*(r2had(iclpro)+r2had(icltar))
2178      &     +bmxdif(iclpro,icltar)/4./0.0389
2179       rpom=4.*.0389*rs
2180       do i1=1,7
2181       do m=1,2
2182         z=.5+x1(i1)*(m-1.5)
2183         zv1=exp(-z)
2184         zv2=(e1*z)
2185         b1=sqrt(-rpom*log(zv1))
2186         b2=sqrt(-rpom*log(zv2))
2187         call psfz(iqq,gz21,b1)
2188         call psfz(iqq,gz22,b2)
2189         ptfau1=max(0.,(1.-anorm*gz21))**matarg
2190         ptfau2=max(0.,(1.-anorm*gz22))**matarg
2191         cg1=ptrot(pprcs,b,b1)
2192         cg2=ptrot(pprcs,b,b2)
2193         ptfauAA=ptfauAA+a1(i1)*(cg1*(1.-ptfau1)+cg2*(1.-ptfau2)/z)
2194       enddo
2195       enddo
2196       ptfauAA=ptfauAA*rpom/2.
2197       ptfauAA=1.-max(0.,(1.-anormp*ptfauAA))**maproj
2198 
2199       return
2200       end
2201 
2202 c------------------------------------------------------------------------
2203       function ptrot(func,s,b)
2204 c-----------------------------------------------------------------------
2205 c convolution of nuclear profile functions (axial angle integration)
2206 c-----------------------------------------------------------------------
2207       common /ar8/ x2(4),a2
2208       external func
2209 
2210       ptrot=0.
2211       do i=1,4
2212         sb1=b**2+s**2-2.*b*s*(2.*x2(i)-1.)
2213         sb2=b**2+s**2-2.*b*s*(1.-2.*x2(i))
2214        ptrot=ptrot+(func(sb1)+func(sb2))
2215       enddo
2216       ptrot=ptrot*a2
2217       return
2218       end
2219 
2220 c------------------------------------------------------------------------
2221       function pttcs(b0)
2222 c-----------------------------------------------------------------------
2223 c ptt - nuclear profile function value at imp param squared b*difnuc**2
2224 c-----------------------------------------------------------------------
2225       include 'epos.inc'
2226       common /psar34/ rrr,rrrm
2227       common /ar5/    x5(2),a5(2)
2228       common /ar9/    x9(3),a9(3)
2229 
2230       b=b0/difnuc(matarg)**2
2231       pttcs=0.
2232       zm=rrrm**2-b
2233       if(zm.gt.4.*b)then
2234         zm=sqrt(zm)
2235       else
2236         zm=2.*sqrt(b)
2237       endif
2238 
2239       do i=1,3
2240         z1=zm*(1.+x9(i))*0.5
2241         z2=zm*(1.-x9(i))*0.5
2242         quq=sqrt(b+z1**2)-rrr
2243         if (quq.lt.85.)pttcs=pttcs+a9(i)/(1.+exp(quq))
2244         quq=sqrt(b+z2**2)-rrr
2245         if (quq.lt.85.)pttcs=pttcs+a9(i)/(1.+exp(quq))
2246       enddo
2247       pttcs=pttcs*zm*0.5
2248 
2249       dt=0.
2250       do i=1,2
2251         z1=x5(i)+zm
2252         quq=sqrt(b+z1**2)-rrr-x5(i)
2253         if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
2254       enddo
2255 
2256       pttcs=pttcs+dt
2257       return
2258       end
2259 
2260 
2261 c------------------------------------------------------------------------
2262       function pttzz(b0)
2263 c-----------------------------------------------------------------------
2264 c ptt - nuclear Z function value at imp param squared b*difnuc**2
2265 c-----------------------------------------------------------------------
2266       include 'epos.inc'
2267       include 'epos.incpar'
2268       common /psar34/ rrr,rrrm
2269       common /psar50/ zznuc,b2xnuc
2270       common /ar5/    x5(2),a5(2)
2271       common /ar9/    x9(3),a9(3)
2272 
2273       pttzz=0.
2274       b=b0/difnuc(matarg)**2
2275 c      absb=max(1.e-9,sqrt(b0)-zbcut)
2276       absb=max(1.e-9,sqrt(b0))
2277       bsq=absb*absb
2278       zm=rrrm**2-b
2279       if(zm.gt.4.*b)then
2280         zm=sqrt(zm)
2281       else
2282         zm=2.*sqrt(b)
2283       endif
2284 
2285       do i=1,3
2286         z1=zm*(1.+x9(i))*0.5
2287         z2=zm*(1.-x9(i))*0.5
2288         quq=sqrt(b+z1**2)-rrr
2289         if (quq.lt.85.)pttzz=pttzz+a9(i)/(1.+exp(quq))
2290         quq=sqrt(b+z2**2)-rrr
2291         if (quq.lt.85.)pttzz=pttzz+a9(i)/(1.+exp(quq))
2292       enddo
2293       pttzz=pttzz*zm*0.5
2294 
2295       dt=0.
2296       do i=1,2
2297         z1=x5(i)+zm
2298         quq=sqrt(b+z1**2)-rrr-x5(i)
2299         if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
2300       enddo
2301 
2302       pttzz=max(0.,(pttzz+dt)-1.)*zznuc*exp(-bsq/2./b2xnuc)
2303 
2304       return
2305       end
2306 
2307 c------------------------------------------------------------------------
2308       function pprcs(b0)
2309 c-----------------------------------------------------------------------
2310 c ppr - nuclear profile function value at imp param squared b*difnuc**2
2311 c-----------------------------------------------------------------------
2312       include 'epos.inc'
2313       common /psar41/ rrrp,rrrmp
2314       common /ar5/    x5(2),a5(2)
2315       common /ar9/    x9(3),a9(3)
2316 
2317       b=b0/difnuc(maproj)**2
2318       pprcs=0.
2319       zm=rrrmp**2-b
2320       if(zm.gt.4.*b)then
2321         zm=sqrt(zm)
2322       else
2323         zm=2.*sqrt(b)
2324       endif
2325 
2326       do i=1,3
2327         z1=zm*(1.+x9(i))*0.5
2328         z2=zm*(1.-x9(i))*0.5
2329         quq=sqrt(b+z1**2)-rrrp
2330         if (quq.lt.85.)pprcs=pprcs+a9(i)/(1.+exp(quq))
2331         quq=sqrt(b+z2**2)-rrrp
2332         if (quq.lt.85.)pprcs=pprcs+a9(i)/(1.+exp(quq))
2333       enddo
2334       pprcs=pprcs*zm*0.5
2335 
2336       dt=0.
2337       do i=1,2
2338         z1=x5(i)+zm
2339         quq=sqrt(b+z1**2)-rrrp-x5(i)
2340         if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
2341       enddo
2342 
2343       pprcs=pprcs+dt
2344       return
2345       end
2346 
2347 c------------------------------------------------------------------------
2348       function pprzz(b0)
2349 c-----------------------------------------------------------------------
2350 c ppr - Z nuclear function value at imp param squared b*difnuc**2
2351 c-----------------------------------------------------------------------
2352       include 'epos.inc'
2353       include 'epos.incpar'
2354       common /psar41/ rrrp,rrrmp
2355       common /psar50/ zznuc,b2xnuc
2356       common /ar5/    x5(2),a5(2)
2357       common /ar9/    x9(3),a9(3)
2358 
2359       pprzz=0.
2360       b=b0/difnuc(maproj)**2
2361 c      absb=max(1.e-9,sqrt(b0)-zbcut)
2362       absb=max(1.e-9,sqrt(b0))
2363       bsq=absb*absb
2364       zm=rrrmp**2-b
2365       if(zm.gt.4.*b)then
2366         zm=sqrt(zm)
2367       else
2368         zm=2.*sqrt(b)
2369       endif
2370 
2371       do i=1,3
2372         z1=zm*(1.+x9(i))*0.5
2373         z2=zm*(1.-x9(i))*0.5
2374         quq=sqrt(b+z1**2)-rrrp
2375         if (quq.lt.85.)pprzz=pprzz+a9(i)/(1.+exp(quq))
2376         quq=sqrt(b+z2**2)-rrrp
2377         if (quq.lt.85.)pprzz=pprzz+a9(i)/(1.+exp(quq))
2378       enddo
2379       pprzz=pprzz*zm*0.5
2380 
2381       dt=0.
2382       do i=1,2
2383         z1=x5(i)+zm
2384         quq=sqrt(b+z1**2)-rrrp-x5(i)
2385         if (quq.lt.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
2386       enddo
2387 
2388       pprzz=max(0.,(pprzz+dt)-1.)*zznuc*exp(-bsq/2./b2xnuc)
2389 
2390       return
2391       end
2392 
2393 c------------------------------------------------------------------------------
2394       function pscrse(ek,mapr,matg,iqq)
2395 c------------------------------------------------------------------------------
2396 c hadron-nucleus (hadron-proton) and nucl-nucl particle production cross section
2397 c ek     - lab kinetic energy for the interaction
2398 c maproj - projec mass number
2399 c matarg - target mass number
2400 c iqq=1    - ela cross section
2401 c     >2   - ine cross section (2 used for cut (changing iomega), 3 uses table,
2402 c                               4 used for ine without table)
2403 c------------------------------------------------------------------------------
2404       dimension wk(3),wa(3),wb(3)
2405       include 'epos.inc'
2406       common /psar33/ asect(7,4,7),asectn(7,7,7)
2407       common /psar34/ rrr,rrrm
2408       common /psar35/ anorm,anormp
2409       common /psar41/ rrrp,rrrmp
2410       external ptfau,ptfauAA
2411 
2412       pscrse=0.
2413       call idmass(1120,amt1)
2414       call idmass(1220,amt2)
2415       amtar=0.5*(amt1+amt2)
2416       if(matg.eq.1)amtar=amt1
2417       if(mapr.eq.1)then
2418         call idmass(idproj,ampro)
2419       else
2420         ampro=amtar
2421       endif
2422       egy=ek+ampro
2423 c      p=sqrt(max(0.,egy**2-ampro**2))
2424       egy=sqrt( 2*egy*amtar+amtar**2+ampro**2 )
2425 
2426       if(isetcs.le.1.or.iqq.ne.3)then
2427         maprojsave=maproj
2428         matargsave=matarg
2429         engysave=engy
2430         maproj=mapr
2431         matarg=matg
2432         engy=egy
2433         if(matg.eq.1.and.mapr.eq.1)then
2434           if(iqq.eq.1)then !sig ela
2435             call psfz(1,gz2,0.)
2436           else             !sig ine
2437             call psfz(2,gz2,0.)
2438           endif
2439           gin=gz2*pi*10.
2440         elseif(mapr.eq.1)then
2441           rad=radnuc(matg)
2442           bm=rad+2.
2443           rrr=rad/difnuc(matg)
2444           rrrm=rrr+log(9.)
2445           anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matg)**2
2446           if(iqq.ne.1)then
2447             gin=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig ine
2448           else
2449             gin=(ptgau(ptfau,bm,2,1)+ptgau1(bm,2,1))*10. !sig ela
2450           endif
2451         elseif(matg.eq.1)then
2452           rad=radnuc(mapr)
2453           bm=rad+2.
2454           rrrp=rad/difnuc(mapr)
2455           rrrmp=rrrp+log(9.)
2456           anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(mapr)**2
2457           if(iqq.ne.1)then
2458             gin=(ptgau(ptfau,bm,1,2)+ptgau1(bm,1,2))*10. !sig ine
2459           else
2460             gin=(ptgau(ptfau,bm,1,1)+ptgau1(bm,1,1))*10. !sig ela
2461           endif
2462          else
2463           rad=radnuc(matg)+1.
2464           radp=radnuc(mapr)+1.
2465           bm=rad+radp+2.
2466           rrr=rad/difnuc(matg)
2467           rrrm=rrr+log(9.)
2468           rrrp=radp/difnuc(mapr)
2469           rrrmp=rrrp+log(9.)
2470           anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matg)**2
2471           anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(mapr)**2
2472           if(iqq.ne.1)then
2473             gin=(ptgau(ptfauAA,bm,2,2)+ptgau2(bm,2))*10. !sig ine
2474           else
2475             gin=(ptgau(ptfauAA,bm,2,1)+ptgau2(bm,1))*10. !sig ela
2476           endif
2477         endif
2478         pscrse=gin
2479         maproj=maprojsave
2480         matarg=matargsave
2481         engy=engysave
2482       else
2483         ye=log10(max(1.,egy/1.5))+1.
2484         je=min(5,int(ye))
2485 
2486         wk(2)=ye-je
2487         wk(3)=wk(2)*(wk(2)-1.)*.5
2488         wk(1)=1.-wk(2)+wk(3)
2489         wk(2)=wk(2)-2.*wk(3)
2490 
2491         ya=matg
2492         ya=log(ya)/.69315+1.
2493         ja=min(int(ya),4)
2494         wa(2)=ya-ja
2495         wa(3)=wa(2)*(wa(2)-1.)*.5
2496         wa(1)=1.-wa(2)+wa(3)
2497         wa(2)=wa(2)-2.*wa(3)
2498 
2499         if(mapr.eq.1)then
2500 
2501           do i=1,3
2502             do m=1,3
2503               pscrse=pscrse+asect(je+i-1,iclpro,ja+m-1)*wk(i)*wa(m)
2504             enddo
2505           enddo
2506 
2507         else
2508 
2509           yb=mapr
2510           yb=log(yb)/.69315+1.
2511           jb=min(int(yb),4)
2512           wb(2)=yb-jb
2513           wb(3)=wb(2)*(wb(2)-1.)*.5
2514           wb(1)=1.-wb(2)+wb(3)
2515           wb(2)=wb(2)-2.*wb(3)
2516 
2517           do i=1,3
2518             do m=1,3
2519               do n=1,3
2520             pscrse=pscrse+asectn(je+i-1,jb+n-1,ja+m-1)*wk(i)*wa(m)*wb(n)
2521               enddo
2522             enddo
2523           enddo
2524 
2525         endif
2526 
2527         pscrse=exp(pscrse)
2528       endif
2529       return
2530       end
2531 
2532 c------------------------------------------------------------------------------
2533       function eposcrse(ek,mapro,matar,id)
2534 c------------------------------------------------------------------------------
2535 c inelastic cross section of epos
2536 c (id=0 corresponds to air)
2537 c ek     - kinetic energy for the interaction
2538 c maproj - projec mass number     (1<maproj<64)
2539 c matarg - target mass number     (1<matarg<64)
2540 c------------------------------------------------------------------------------
2541       include 'epos.inc'
2542 
2543       eposcrse=0.
2544       if(id.eq.0)then
2545         do k=1,3
2546           mt=int(airanxs(k))
2547           eposcrse=eposcrse+airwnxs(k)*pscrse(ek,mapro,mt,3)
2548         enddo
2549       else
2550         eposcrse=pscrse(ek,mapro,matar,3)
2551       endif
2552 
2553       return
2554       end
2555 
2556 c------------------------------------------------------------------------------
2557       function eposinecrse(ek,mapro,matar,id)
2558 c------------------------------------------------------------------------------
2559 c inelastic cross section of epos not using tabulated xs
2560 c (id=0 corresponds to air)
2561 c ek     - kinetic energy for the interaction
2562 c maproj - projec mass number     (1<maproj<64)
2563 c matarg - target mass number     (1<matarg<64)
2564 c------------------------------------------------------------------------------
2565       include 'epos.inc'
2566 
2567       eposinecrse=0.
2568       if(id.eq.0)then
2569         do k=1,3
2570           mt=int(airanxs(k))
2571           eposinecrse=eposinecrse+airwnxs(k)*pscrse(ek,mapro,mt,4)
2572         enddo
2573       else
2574         eposinecrse=pscrse(ek,mapro,matar,4)
2575       endif
2576 
2577       return
2578       end
2579 
2580 c------------------------------------------------------------------------------
2581       function eposelacrse(ek,mapro,matar,id)
2582 c------------------------------------------------------------------------------
2583 c elastic cross section of epos
2584 c (id=0 corresponds to air)
2585 c ek     - kinetic energy for the interaction
2586 c maproj - projec mass number     (1<maproj<64)
2587 c matarg - target mass number     (1<matarg<64)
2588 c------------------------------------------------------------------------------
2589       include 'epos.inc'
2590 
2591       eposelacrse=0.
2592       if(id.eq.0)then
2593         do k=1,3
2594           mt=int(airanxs(k))
2595           eposelacrse=eposelacrse+airwnxs(k)*pscrse(ek,mapro,mt,1)
2596         enddo
2597       else
2598         eposelacrse=pscrse(ek,mapro,matar,1)
2599       endif
2600 
2601       return
2602       end
2603 
2604 
2605 c------------------------------------------------------------------------------
2606       function eposcutcrse(ek,mapro,matar,id)
2607 c------------------------------------------------------------------------------
2608 c total cross section of epos
2609 c (id=0 corresponds to air)
2610 c ek     - kinetic energy for the interaction
2611 c maproj - projec mass number     (1<maproj<64)
2612 c matarg - target mass number     (1<matarg<64)
2613 c------------------------------------------------------------------------------
2614       include 'epos.inc'
2615 
2616       eposcutcrse=0.
2617       iomegasave=iomega
2618       iomega=2
2619       if(id.eq.0)then
2620         do k=1,3
2621           mt=int(airanxs(k))
2622           eposcutcrse=eposcutcrse+airwnxs(k)*pscrse(ek,mapro,mt,2)
2623         enddo
2624       else
2625         eposcutcrse=pscrse(ek,mapro,matar,2)
2626       endif
2627       iomega=iomegasave
2628 
2629       return
2630       end
2631 
2632 c------------------------------------------------------------------------------
2633       subroutine crseaaEpos(sigt,sigi,sigc,sige)
2634 c------------------------------------------------------------------------------
2635 c nucleus-nucleus (hadron) cross section of epos from simplified (realistic)
2636 c simulations
2637 c (id=0 corresponds to air)
2638 c  sigt = sig tot
2639 c  sigi = sig inelastic (cut + projectile diffraction)
2640 c  sigc = sig cut
2641 c  sige = sig elastic (includes target diffraction)
2642 c------------------------------------------------------------------------------
2643       include 'epos.inc'
2644       niter=20000
2645       if(idtarg.eq.0)then
2646         sigt=0.
2647         sigc=0.
2648         sigi=0.
2649         sige=0.
2650         sigd=0.
2651         sigql=0.
2652         do k=1,3
2653           matarg=int(airanxs(k))
2654           call epocrossc(niter,xsigt,xsigi,xsigc,xsige,xsigql,xsigd)
2655           sigt=sigt+airwnxs(k)*xsigt
2656           sigi=sigi+airwnxs(k)*xsigi
2657           sigc=sigc+airwnxs(k)*xsigc
2658           sige=sige+airwnxs(k)*xsige
2659           sigd=sigd+airwnxs(k)*xsigd
2660           sigql=sigql+airwnxs(k)*xsigql
2661         enddo
2662       else
2663         call epocrossc(niter,sigt,sigi,sigc,sige,sigql,sigd)
2664       endif
2665       if(ionudi.ne.1)then
2666         sige=sige+sigql      !add non-excited diffractive projectile to elastic
2667         sigi=sigi-sigql      !do not count non-excited diffractive projectile in inelastic
2668         if(maproj+matarg.gt.2)then
2669           sigc=sigc+sigd*0.95   !for absorbtion cross section remove 5% of the
2670                                 !excited projectile diffractive cross section
2671                                 !which "looks like" non excited (approximation)
2672         endif
2673       endif
2674       end
2675 
2676 
2677 cc------------------------------------------------------------------------
2678 c      function pshard1(sy,xpp,xpm,z)
2679 cc-----------------------------------------------------------------------
2680 cc pshard - qq-pomeron eikonal
2681 cc sy - energy squared for the pomeron,
2682 cc xpp - lc+ for the pomeron,
2683 cc xpm - lc- for the pomeron
2684 cc-----------------------------------------------------------------------
2685 c      common /ar3/   x1(7),a1(7)
2686 c      common /ar9/   x9(3),a9(3)
2687 c      include 'epos.inc'
2688 c      include 'epos.incsem'
2689 c
2690 c      pshard1=0.
2691 c      if(iclpro.ne.4.and.icltar.ne.4)then
2692 c        spmin=4.*q2min
2693 c      else
2694 c        spmin=4.*q2min+2.*qcmass**2
2695 c      endif
2696 c      if(sy.le.spmin)return
2697 c
2698 c      rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
2699 c      alpq=(alppar+1.)/2.
2700 c      xmin=spmin/sy             !min hard pomeron mass share
2701 c      xminl=xmin**(delh+.5)
2702 c
2703 c      do i=1,3
2704 c      do m=1,2
2705 c        zh=(.5*(1.+xminl-(2*m-3)*x9(i)*(1.-xminl)))**(1./(delh+.5))
2706 c        if(iclpro.ne.4.and.icltar.ne.4)then
2707 c          call psjti0(zh*sy,sqq,sqqb,1,1)
2708 c          call psjti0(zh*sy,sqqp,sqqpb,1,2)
2709 c          call psjti0(zh*sy,sqaq,sqaqb,-1,1)
2710 c        else
2711 c          call psjti0(zh*sy,sqq,sqqb,4,1)
2712 c          sqq=0.
2713 c          sqaq=0.
2714 c        endif
2715 c
2716 c        stq=0.
2717 c        do i1=1,3
2718 c        do m1=1,2
2719 c          xx=.5+x9(i1)*(m1-1.5)
2720 c          xp=zh**xx
2721 c          xm=zh/xp
2722 c          if(xp*xpp.le..9999.and.xm*xpm.le..9999.or.
2723 c     *    xm*xpp.le..9999.and.xp*xpm.le..9999)then
2724 c          stq=stq+a9(i1)*psharf(xp*xpp,xm*xpm,sqq,sqqp,sqaq)
2725 c     *    *(1.-xp)**(1.+alplea(iclpro)-alpq)
2726 c     *    *(1.-xm)**(1.+alplea(icltar)-alpq)
2727 c          endif
2728 c        enddo
2729 c        enddo
2730 c        pshard1=pshard1-a9(i)*stq/zh**(delh+0.5)*log(zh)
2731 c      enddo
2732 c      enddo
2733 c      pshard1=pshard1*(1.-xminl)/(delh+.5)/4.*factk
2734 c     **chad(iclpro)*chad(icltar)*(xpp*xpm)**(1.-alpq)
2735 c     **z**(rp/(r2had(iclpro)+r2had(icltar)))
2736 c     */(8.*pi*(r2had(iclpro)+r2had(icltar)))
2737 c      return
2738 c      end
2739 c
2740 c------------------------------------------------------------------------
2741       function pshard(sy,xpp,xpm)
2742 c-----------------------------------------------------------------------
2743 c pshard - qq-pomeron eikonal
2744 c sy - energy squared for the pomeron,
2745 c xpp - lc+ for the pomeron,
2746 c xpm - lc- for the pomeron
2747 c-----------------------------------------------------------------------
2748       double precision z01
2749       common /ar3/   x1(7),a1(7)
2750       include 'epos.inc'
2751       include 'epos.incsem'
2752 
2753       pshard=0.
2754       if(iclpro.ne.4.and.icltar.ne.4)then
2755         spmin=4.*q2min
2756       else
2757         spmin=4.*q2min+2.*qcmass**2
2758       endif
2759       if(sy.le.spmin)return
2760 
2761       alpq=(alppar+1.)/2.
2762       xmin=spmin/sy             !min hard pomeron mass share
2763       xminl=xmin**(delh+.5)
2764 
2765       do i=1,7
2766       do m=1,2
2767         zh=(.5*(1.+xminl-(2*m-3)*x1(i)*(1.-xminl)))**(1./(delh+.5))
2768         if(iclpro.ne.4.and.icltar.ne.4)then
2769           call psjti0(zh*sy,sqq,sqqb,1,1)
2770           call psjti0(zh*sy,sqqp,sqqpb,1,2)
2771           call psjti0(zh*sy,sqaq,sqaqb,-1,1)
2772         else
2773           call psjti0(zh*sy,sqq,sqqb,4,1)
2774           sqqp=0.
2775           sqaq=0.
2776         endif
2777 
2778         stq=0.  !int^1_(sqrt(z)) dx_p / x_p / sqrt(1-x_p) =int^(tmax)_(0) dt
2779         tmax=sqrt(1.-sqrt(zh))        !t=ln((1+sqrt(1-x_p))/(1-sqrt(1-x_p)))
2780         tmax=log((1.+tmax)/(1.-tmax))
2781         if(tmax.gt.1.e-20)then
2782         do i1=1,7
2783         do m1=1,2
2784           t=tmax*(.5+x1(i1)*(m1-1.5))
2785           z01=((1.d0-exp(-1.d0*t))/(1.d0+exp(-1.d0*t)))**2
2786           xp=1.-z01
2787           xm=zh/xp
2788           if(xp*xpp.le..9999.and.xm*xpm.le..9999.or.
2789      *    xm*xpp.le..9999.and.xp*xpm.le..9999)then
2790           stq=stq+a1(i1)*(psharf(xp*xpp,xm*xpm,sqq,sqqp,sqaq)+
2791      *    psharf(xm*xpp,xp*xpm,sqq,sqqp,sqaq))
2792      *    *z01**(.5-alpq)/(1.-xm)**alpq
2793           endif
2794         enddo
2795         enddo
2796         stq=stq*tmax
2797         endif
2798         pshard=pshard+a1(i)*stq/zh**(delh+0.5)
2799       enddo
2800       enddo
2801       pshard=pshard*(1.-xminl)/(delh+.5)/4.*
2802      *utgam1(2.+alplea(iclpro)-alpq)/utgam1(1.+alplea(iclpro))/
2803      *utgam1(1.-alpq)*
2804      *utgam1(2.+alplea(icltar)-alpq)/utgam1(1.+alplea(icltar))/
2805      *utgam1(1.-alpq)*
2806      *chad(iclpro)*chad(icltar)/(8.*pi*(r2had(iclpro)+r2had(icltar)))*
2807      *(xpp*xpm)**(-alpq)/sy**delh
2808       return
2809       end
2810 
2811 c------------------------------------------------------------------------
2812       function psharf(zh1,zh2,sqq,sqqp,sqaq)
2813 c-----------------------------------------------------------------------
2814       include 'epos.incsem'
2815       include 'epos.inc'
2816 
2817       alpq=(alppar+1.)/2.
2818       if(zh1.le..9999.and.zh2.le..9999)then
2819         uv1=psdfh4(zh1,q2min,0.,iclpro,1)
2820         dv1=psdfh4(zh1,q2min,0.,iclpro,2)
2821         uv2=psdfh4(zh2,q2min,0.,icltar,1)
2822         dv2=psdfh4(zh2,q2min,0.,icltar,2)
2823         if(iclpro.eq.2.and.icltar.eq.2)then       !proton
2824           fff=sqq*(uv1*uv2+dv1*dv2)+sqqp*(uv1*dv2+dv1*uv2)
2825         elseif(iclpro.eq.1.or.icltar.eq.1)then   !pion
2826           fff=sqq*uv1*uv2+sqaq*dv1*dv2+sqqp*(uv1*dv2+dv1*uv2)
2827         elseif(iclpro.eq.3.or.icltar.eq.3)then   !kaon
2828           fff=sqq*uv1*uv2+sqqp*(uv1*dv2+dv1*uv2+dv1*dv2)
2829         elseif(iclpro.eq.4.or.icltar.eq.4)then   !J/psi
2830           fff=sqq*uv1*(uv2+dv2)
2831         else
2832           fff=0.
2833           call utstop("Projectile not know in psharg !&")
2834         endif
2835         psharf=fff*(1.-zh1)**(-1.+alpq-alplea(iclpro))*
2836      *  (1.-zh2)**(-1.+alpq-alplea(icltar))
2837       else
2838         psharf=0.
2839       endif
2840       return
2841       end
2842 
2843 c------------------------------------------------------------------------
2844       function psvin(sy,xpp,xpm,z,iqq)
2845 c-----------------------------------------------------------------------
2846 c psvin - contributions to the interaction eikonal
2847 c sy  - energy squared for the hard interaction,
2848 c xpp - lc+ for the sh pomeron,
2849 c xpm - lc- for the sh pomeron,
2850 c z   - impact parameter factor, z=exp(-b**2/4*rp),
2851 c iqq = 1  - gg,
2852 c iqq = 2  - qg,
2853 c iqq = 3  - gq,
2854 c iqq = 4  - qq,
2855 c iqq = 5  - gg(int),
2856 c iqq = 6  - gg(proj),
2857 c iqq = 7  - qg(proj),
2858 c iqq = 9  - total uncut-integrated,
2859 c iqq = 10 - total cut,
2860 c iqq = 14  - gg(int)|b=0,
2861 c iqq = 15  - <b^2*gg(int)>,
2862 c iqq = 16  - gg(proj)|b=0,
2863 c iqq = 17  - <b^2*gg(proj)>,
2864 c iqq = 18  - qg(proj)|b=0,
2865 c iqq = 19  - <b^2*qg(proj)>
2866 c-----------------------------------------------------------------------
2867       dimension wk(3),wi(3),wj(3),wz(3),fa(3)
2868       common /psar2/  edmax,epmax
2869       common /psar4/  fhgg(11,10,8),fhqg(11,10,80)
2870      *,fhgq(11,10,80),fhqq(11,10,80),fhgg0(11,10),fhgg1(11,10,4)
2871      *,fhqg1(11,10,40),fhgg01(11),fhgg02(11),fhgg11(11,4)
2872      *,fhgg12(11,4),fhqg11(11,10,4),fhqg12(11,10,4)
2873      *,ftoint(11,14,2,2,3)
2874       common /psar7/  delx,alam3p,gam3p
2875       include 'epos.inc'
2876       include 'epos.incsem'
2877 
2878       if(iqq.eq.3)then
2879         xp=xpm
2880         xm=xpp
2881         iclp=icltar
2882         iclt=iclpro
2883       else
2884         xp=xpp
2885         xm=xpm
2886         iclp=iclpro
2887         iclt=icltar
2888       endif
2889       rp=r2had(iclpro)+r2had(icltar)+slopom*log(max(1.,sy))
2890 
2891       psvin=0.
2892       if(iqq.eq.1.or.iqq.eq.5.or.iqq.eq.6.or.iqq.eq.14
2893      *.or.iqq.eq.15.or.iqq.eq.16.or.iqq.eq.17
2894      *.or.iclpro.ne.4.and.(iqq.eq.2.or.iqq.eq.7
2895      *.or.iqq.eq.18.or.iqq.eq.19)
2896      *.or.icltar.ne.4.and.iqq.eq.3
2897      *.or.iclpro.ne.4.and.icltar.ne.4)then
2898         spmin=4.*q2min
2899       else
2900         spmin=4.*q2min+2.*qcmass**2
2901       endif
2902       if(sy.le.spmin.and.(iqq.le.7.or.iqq.gt.13))return
2903 
2904       if(iqq.le.7.or.iqq.gt.13)then
2905         yl=log(sy/spmin)/log(epmax/2./spmin)*10.+1
2906         k=int(yl)
2907         if(k.gt.9)k=9
2908         wk(2)=yl-k
2909         wk(3)=wk(2)*(wk(2)-1.)*.5
2910         wk(1)=1.-wk(2)+wk(3)
2911         wk(2)=wk(2)-2.*wk(3)
2912 
2913         if(iqq.ne.4)then  !---------------- not 4 ------------------
2914 
2915           if(iqq.eq.5)then
2916             if(k.eq.1)then
2917               psvin=max(0.,exp(fhgg01(k+1))*wk(2)
2918      *        +exp(fhgg01(k+2))*wk(3))
2919             else
2920               psvin=exp(fhgg01(k)*wk(1)+fhgg01(k+1)*wk(2)
2921      *        +fhgg01(k+2)*wk(3))
2922             endif
2923             psvin=psvin*factk*sy**delh
2924             return
2925 
2926           elseif(iqq.eq.15)then
2927             if(k.eq.1)then
2928               psvin=max(0.,exp(fhgg02(k+1))*wk(2)
2929      *        +exp(fhgg02(k+2))*wk(3))
2930             else
2931               psvin=exp(fhgg02(k)*wk(1)+fhgg02(k+1)*wk(2)
2932      *        +fhgg02(k+2)*wk(3))
2933             endif
2934             psvin=psvin*factk*sy**delh
2935             return
2936 
2937           elseif(iqq.eq.6)then
2938             if(k.eq.1)then
2939               psvin=max(0.,exp(fhgg11(k+1,iclpro))*wk(2)
2940      *        +exp(fhgg11(k+2,iclpro))*wk(3))
2941             else
2942               psvin=exp(fhgg11(k,iclpro)*wk(1)+fhgg11(k+1,iclpro)*wk(2)
2943      *        +fhgg11(k+2,iclpro)*wk(3))
2944             endif
2945             psvin=psvin*factk*sy**delh*xp**(-alppar)
2946             return
2947 
2948           elseif(iqq.eq.17)then
2949             if(k.eq.1)then
2950               psvin=max(0.,exp(fhgg12(k+1,iclpro))*wk(2)
2951      *        +exp(fhgg12(k+2,iclpro))*wk(3))
2952             else
2953               psvin=exp(fhgg12(k,iclpro)*wk(1)+fhgg12(k+1,iclpro)*wk(2)
2954      *        +fhgg12(k+2,iclpro)*wk(3))
2955             endif
2956             psvin=psvin*factk*sy**delh*xp**(-alppar)
2957             return
2958 
2959           elseif(iqq.eq.7.or.iqq.eq.19)then
2960             if(xp.lt..2)then
2961               xl=log(10.*xp)/log(2.)+5.
2962             else
2963               xl=5.*xp+5.
2964             endif
2965             i=int(xl)
2966             if(i.lt.1)i=1
2967             if(i.eq.5)i=4
2968             if(i.gt.8)i=8
2969             wi(2)=xl-i
2970             wi(3)=wi(2)*(wi(2)-1.)*.5
2971             wi(1)=1.-wi(2)+wi(3)
2972             wi(2)=wi(2)-2.*wi(3)
2973             do k1=1,3
2974               fa(k1)=0.
2975             do i1=1,3
2976               k2=k+k1-1
2977               fhhh=0.
2978               if(iqq.eq.7)then
2979                 fhhh=fhqg11(k2,i+i1-1,iclpro)
2980               elseif(iqq.eq.19)then
2981                 fhhh=fhqg12(k2,i+i1-1,iclpro)
2982               endif
2983               fa(k1)=fa(k1)+fhhh*wi(i1)
2984             enddo
2985             enddo
2986             if(k.eq.1)then
2987               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
2988             else
2989               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
2990             endif
2991             psvin=psvin*factk*sy**delh
2992             return
2993           endif
2994 
2995           jz=int(10.*z)
2996           if(jz.gt.8)jz=8
2997           if(jz.lt.1)jz=1
2998           wz(2)=10.*z-jz
2999           wz(3)=wz(2)*(wz(2)-1.)*.5
3000           wz(1)=1.-wz(2)+wz(3)
3001           wz(2)=wz(2)-2.*wz(3)
3002 
3003           if(iqq.eq.14)then
3004             do k1=1,3
3005               k2=k+k1-1
3006               fa(k1)=fhgg0(k2,jz)*wz(1)+fhgg0(k2,jz+1)
3007      *        *wz(2)+fhgg0(k2,jz+2)*wz(3)
3008             enddo
3009             if(k.eq.1)then
3010               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3011             else
3012               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3013             endif
3014             psvin=psvin*z*factk*sy**delh
3015 
3016           elseif(iqq.eq.16)then
3017             do k1=1,3
3018               k2=k+k1-1
3019               fa(k1)=fhgg1(k2,jz,iclpro)*wz(1)+fhgg1(k2,jz+1,iclpro)
3020      *        *wz(2)+fhgg1(k2,jz+2,iclpro)*wz(3)
3021             enddo
3022             if(k.eq.1)then
3023               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3024             else
3025               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3026             endif
3027             psvin=psvin*z*factk*sy**delh*xp**(-alppar)
3028 
3029           elseif(iqq.eq.18)then
3030             if(xp.lt..2)then
3031               xl=log(10.*xp)/log(2.)+5.
3032             else
3033               xl=5.*xp+5.
3034             endif
3035             i=int(xl)
3036             if(i.lt.1)i=1
3037             if(i.eq.5)i=4
3038             if(i.gt.8)i=8
3039             wi(2)=xl-i
3040             wi(3)=wi(2)*(wi(2)-1.)*.5
3041             wi(1)=1.-wi(2)+wi(3)
3042             wi(2)=wi(2)-2.*wi(3)
3043             do k1=1,3
3044               fa(k1)=0.
3045             do i1=1,3
3046             do l1=1,3
3047               k2=k+k1-1
3048               l2=jz+l1-1+10*(iclpro-1)
3049               fhhh=fhqg1(k2,i+i1-1,l2)
3050               fa(k1)=fa(k1)+fhhh*wi(i1)*wz(l1)
3051             enddo
3052             enddo
3053             enddo
3054             if(k.eq.1)then
3055               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3056             else
3057               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3058             endif
3059             psvin=psvin*z*factk*sy**delh
3060 
3061           elseif(iqq.eq.1)then   !1111111111111111111111111111111111
3062 
3063             do k1=1,3
3064               k2=k+k1-1
3065               iclpt=iclpro+4*(icltar-1)
3066               fa(k1)=fhgg(k2,jz,iclpt)*wz(1)+fhgg(k2,jz+1,iclpt)
3067      *        *wz(2)+fhgg(k2,jz+2,iclpt)*wz(3)
3068             enddo
3069             if(k.eq.1)then
3070               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3071             else
3072               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3073             endif
3074             psvin=psvin*z*factk*sy**delh*(xp*xm)**(-alppar)
3075 
3076           else  ! 2222222222222222222222 3333333333333333333333 ....
3077 
3078             if(xp.lt..2)then
3079               xl=log(10.*xp)/log(2.)+5.
3080             else
3081               xl=5.*xp+5.
3082             endif
3083             i=int(xl)
3084             if(i.lt.1)i=1
3085             if(i.eq.5)i=4
3086             if(i.gt.8)i=8
3087             wi(2)=xl-i
3088             wi(3)=wi(2)*(wi(2)-1.)*.5
3089             wi(1)=1.-wi(2)+wi(3)
3090             wi(2)=wi(2)-2.*wi(3)
3091             do k1=1,3
3092               fa(k1)=0.
3093             do i1=1,3
3094             do l1=1,3
3095               k2=k+k1-1
3096               fhhh=0.
3097               if(iqq.eq.2)then
3098                 l2=jz+l1-1+10*(iclpro+4*(icltar-1)-1)
3099                 fhhh=fhqg(k2,i+i1-1,l2)
3100               elseif(iqq.eq.3)then
3101                 l2=jz+l1-1+10*(iclpro+4*(icltar-1)-1)
3102                 fhhh=fhgq(k2,i+i1-1,l2)
3103               endif
3104               fa(k1)=fa(k1)+fhhh*wi(i1)*wz(l1)
3105             enddo
3106             enddo
3107             enddo
3108             if(k.eq.1)then
3109               psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3110             else
3111               psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3112             endif
3113             psvin=psvin*xm**(-alppar)*z*factk*sy**delh
3114           endif
3115 
3116         else ! ------------- 4444444444444444444 -----------------------
3117 
3118           if(xp.lt..2)then
3119             xl1=log(10.*xp)/log(2.)+5.
3120           else
3121             xl1=5.*xp+5.
3122           endif
3123           i=max(1,int(xl1))
3124           if(i.eq.5)i=4
3125           i=min(8,i)
3126           wi(2)=xl1-i
3127           wi(3)=wi(2)*(wi(2)-1.)*.5
3128           wi(1)=1.-wi(2)+wi(3)
3129           wi(2)=wi(2)-2.*wi(3)
3130 
3131           if(xm.lt..2)then
3132             xl2=log(10.*xm)/log(2.)+5.
3133           else
3134             xl2=5.*xm+5.
3135           endif
3136           j=max(1,int(xl2))
3137           if(j.eq.5)j=4
3138           j=min(8,j)
3139           wj(2)=xl2-j
3140           wj(3)=wj(2)*(wj(2)-1.)*.5
3141           wj(1)=1.-wj(2)+wj(3)
3142           wj(2)=wj(2)-2.*wj(3)
3143 
3144           do k1=1,3
3145             fa(k1)=0.
3146           do i1=1,3
3147           do j1=1,3
3148             k2=k+k1-1
3149             j2=j+j1-1+10*(iclp+4*(iclt-1)-1)
3150             fa(k1)=fa(k1)+fhqq(k2,i+i1-1,j2)*wi(i1)*wj(j1)
3151           enddo
3152           enddo
3153           enddo
3154           if(k.eq.1)then
3155             psvin=max(0.,exp(fa(2))*wk(2)+exp(fa(3))*wk(3))
3156           else
3157             psvin=exp(fa(1)*wk(1)+fa(2)*wk(2)+fa(3)*wk(3))
3158           endif
3159           psvin=psvin*z**(rp/(r2had(iclpro)+r2had(icltar)))*
3160      *    factk*sy**delh
3161 
3162         endif !--------------------------------------------
3163 
3164         return
3165       endif
3166 
3167       yl=log(sy)/log(1.e8)*10.+1
3168       k=max(1,int(yl))
3169       k=min(k,9)     !?????????????9
3170       wk(2)=yl-k
3171       wk(3)=wk(2)*(wk(2)-1.)*.5
3172       wk(1)=1.-wk(2)+wk(3)
3173       wk(2)=wk(2)-2.*wk(3)
3174 
3175       if(z.gt..1)then
3176         zz=10.*z+4
3177       else
3178         zz=50.*z
3179       endif
3180       jz=min(12,int(zz))
3181       if(jz.eq.0)jz=1
3182       if(jz.eq.4)jz=3
3183       wz(2)=zz-jz
3184       wz(3)=wz(2)*(wz(2)-1.)*.5
3185       wz(1)=1.-wz(2)+wz(3)
3186       wz(2)=wz(2)-2.*wz(3)
3187 
3188       if(iqq.eq.9)then
3189         do k1=1,3
3190         do l1=1,3
3191           k2=k+k1-1
3192           l2=jz+l1-1
3193           psvin=psvin+ftoint(k2,l2,icdp,icdt,iclp)*wk(k1)*wz(l1)
3194         enddo
3195         enddo
3196         psvin=exp(psvin)*z
3197 
3198       endif
3199       return
3200       end
3201 
3202 c------------------------------------------------------------------------
3203       function psbint(q1,q2,qqcut,ss,m1,l1,jdis)
3204 c-----------------------------------------------------------------------
3205 c psbint - born cross-section interpolation
3206 c q1 - virtuality cutoff at current end of the ladder;
3207 c q2 - virtuality cutoff at opposite end of the ladder;
3208 c qqcut - p_t cutoff for the born process;
3209 c s  - total c.m. energy squared for the scattering,
3210 c m1 - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
3211 c l1 - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
3212 c-----------------------------------------------------------------------
3213       dimension wi(3),wk(3)
3214       common /psar2/  edmax,epmax
3215       common /psar21/ csbor(20,160,2)
3216       include 'epos.incsem'
3217       double precision psuds
3218 
3219       psbint=0.
3220       if(jdis.eq.0)then
3221         qq=max(q1,q2)
3222       else
3223         qq=max(q1/4.,q2)
3224       endif
3225       qq=max(qq,qqcut)
3226       if(iabs(m1).ne.4)then
3227         q2mass=0.
3228         if(m1.ne.0.and.m1.eq.l1)then
3229           m=2
3230           l=2
3231         elseif(m1.ne.0.and.m1.eq.-l1)then
3232           m=3
3233           l=1
3234         elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
3235           m=3
3236           l=2
3237         else
3238           m=min(1,iabs(m1))+1
3239           l=min(1,iabs(l1))+1
3240         endif
3241       else
3242         q2mass=qcmass**2
3243         m=4
3244         l=min(1,iabs(l1))+1
3245       endif
3246       s=ss-q2mass
3247       spmin=4.*q2min+q2mass
3248       s2min=4.*qq+q2mass
3249       if(s.le.s2min)return
3250 
3251       p1=s/(1.+q2mass/s)
3252       if(p1.gt.4.*qq)then
3253         tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
3254       else
3255         tmin=2.*qq
3256       endif
3257       qmax=p1/4.
3258       tmax=p1/2.
3259 
3260       ml=20*(m-1)+80*(l-1)
3261       qli=log(qq/q2min)/log(qmax/q2min)*19.+1.
3262       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
3263       k=int(sl)
3264       i=int(qli)
3265       if(k.lt.1)k=1
3266       if(i.lt.1)i=1
3267       if(k.gt.18)k=18
3268       if(i.gt.18)i=18
3269 
3270       wi(2)=qli-i
3271       wi(3)=wi(2)*(wi(2)-1.)*.5
3272       wi(1)=1.-wi(2)+wi(3)
3273       wi(2)=wi(2)-2.*wi(3)
3274 
3275       wk(2)=sl-k
3276       wk(3)=wk(2)*(wk(2)-1.)*.5
3277       wk(1)=1.-wk(2)+wk(3)
3278       wk(2)=wk(2)-2.*wk(3)
3279 
3280       do i1=1,3
3281       do k1=1,3
3282         psbint=psbint+csbor(i+i1-1,k+k1+ml-1,jdis+1)
3283      *  *wi(i1)*wk(k1)
3284       enddo
3285       enddo
3286       psbint=exp(psbint)*(1./tmin-1./tmax)
3287       if(jdis.eq.0.and.qq.gt.q1)then
3288         psbint=psbint*sngl(psuds(qq,m1)/psuds(q1,m1))
3289       elseif(jdis.eq.1.and.4.*qq.gt.q1)then
3290         psbint=psbint*sngl(psuds(4.*qq,m1)/psuds(q1,m1))
3291       endif
3292       if(qq.gt.q2)psbint=psbint*sngl(psuds(qq,l1)/psuds(q2,l1))
3293       return
3294       end
3295 
3296 c-----------------------------------------------------------------------
3297       function psborn(q1,q2,qqcut,s,j,l,jdis,md)
3298 c-----------------------------------------------------------------------
3299 c
3300 c    hard 2->2 parton scattering born cross-section
3301 c       including sudakov on both sides
3302 c
3303 c q1 - virtuality cutoff at current end of the ladder;
3304 c q2 - virtuality cutoff at opposite end of the ladder;
3305 c qqcut - p_t cutoff for the born process;
3306 c s - c.m. energy squared for the scattering;
3307 c j - parton type at current end of the ladder (0 - g, 1,2 etc. - q);
3308 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
3309 c-----------------------------------------------------------------------
3310       common /ar3/   x1(7),a1(7)
3311       double precision sud0,psbornd,psuds
3312       include 'epos.inc'
3313       include 'epos.incsem'
3314 
3315       psborn=0
3316 
3317       if(jdis.eq.0)then
3318         qq=max(q1,q2)
3319       else
3320         qq=max(q1/4.,q2)
3321       endif
3322       qq=max(qq,qqcut)
3323 c      if(j.ne.3)then  !kkkkkkkkkk  charm is 3 ???
3324       if(j.ne.4)then
3325         j1=j
3326         q2mass=0.
3327       else
3328         j1=4
3329         q2mass=qcmass**2
3330       endif
3331       p1=s/(1.+q2mass/s)
3332       if(p1.gt.4.*qq)then
3333         tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
3334       else
3335         tmin=2.*qq
3336 !        return !tmin=2.*qq   !kkkkkkk !?????????????  tp  why not ?
3337       endif
3338       tmax=p1/2.
3339       sud0=psuds(q1,j1)*psuds(q2,l)
3340 
3341       psbornd=0.d0
3342       do i=1,7
3343       do m=1,2
3344         t=2.*tmin/(1.+tmin/tmax-x1(i)*(2*m-3)
3345      &  *(1.-tmin/tmax))
3346         qt=t*(1.-t/p1)
3347         if(qt.lt..999*qq.and.ish.ge.1)write(ifch,*)'psborn:qt,qq,q1,q2'
3348      &                                             ,qq,qt,q1,q2
3349 
3350         if(jdis.eq.0)then
3351           scale=qt
3352         else
3353           scale=qt*4.
3354         endif
3355         if(j1.eq.0.and.l.eq.0)then
3356           fb=ffborn(s,t, 1. , 0. , 0. , 0. , 0. )    !gg
3357         elseif(j1*l.eq.0)then
3358           fb=ffborn(s,t, 0. , 1. , 0. , 0. , 0.)     !qg
3359         elseif(j1.eq.l)then
3360           fb=ffborn(s,t, 0. , 0. , 1. , 0. , 0.)     !qq
3361         elseif(j1.eq.-l)then
3362           fb=ffborn(s,t, 0. , 0. , 0. , 1. , 0.)     !qq
3363         else
3364           fb=ffborn(s,t, 0. , 0. , 0. , 0. , 1.)     !qq
3365         endif
3366         fb=fb*pssalf(qt/qcdlam)**2
3367         psbornd=psbornd+dble(a1(i)*fb)*dble(t)**2
3368      &  *psuds(scale,j1)*psuds(qt,l)
3369       enddo
3370       enddo
3371       psbornd=psbornd*dble(2.*pi**3)/dble(s)**2/sud0*2
3372      *    /2   !CS for parton pair
3373       if(md.eq.1)psbornd=psbornd*(1./tmin-1./tmax)
3374       psborn=sngl(psbornd)
3375       return
3376       end
3377 
3378 c------------------------------------------------------------------------
3379       function psdgh(s,qq,long)
3380 c-----------------------------------------------------------------------
3381 c psdgh
3382 c s - energy squared for the interaction (hadron-hadron),
3383 c-----------------------------------------------------------------------
3384       common/ar3/    x1(7),a1(7)
3385       common /cnsta/ pi,pii,hquer,prom,piom,ainfin
3386       include 'epos.incsem'
3387       double precision psuds
3388 
3389       xd=qq/s
3390       if(long.eq.0)then
3391         psdgh=(psdfh4(xd,q2min,0.,2,1)/2.25+psdfh4(xd,q2min,0.,2,2)/9.
3392      *  +psdfh4(xd,q2min,0.,2,3)/9.+
3393      *  2.*(psdfh4(xd,q2min,0.,2,-1)+psdfh4(xd,q2min,0.,2,-2)+
3394      *  psdfh4(xd,q2min,0.,2,-3))/4.5)
3395      *  *sngl(psuds(qq,1)/psuds(q2min,1))*4.*pi**2*alfe/qq
3396       else
3397         psdgh=0.
3398       endif
3399 
3400       dgh=0.
3401       if(long.eq.0)then
3402         s2min=qq/(1.-q2ini/qq)
3403       else
3404         s2min=4.*max(q2min,qcmass**2)+qq
3405         s2min=s2min/(1.-4.*q2ini/(s2min-qq))
3406       endif
3407       xmin=s2min/s
3408 
3409       if(xmin.lt.1.)then
3410         do i=1,7          !numerical integration over z1
3411         do m=1,2
3412           if(long.eq.0)then
3413             z1=qq/s+(xmin-qq/s)*((1.-qq/s)/(xmin-qq/s))
3414      *      **(.5+(m-1.5)*x1(i))
3415           else
3416             z1=.5*(1.+xmin+(2*m-3)*x1(i)*(1.-xmin))
3417           endif
3418           call psdint(z1*s,qq,sds,sdn,sdb,sdt,sdr,1,long)
3419           call psdint(z1*s,qq,sdsg,sdng,sdbg,sdtg,sdrg,0,long)
3420           tu=psdfh4(z1,q2min,0.,2,1)
3421           td=psdfh4(z1,q2min,0.,2,2)
3422           ts=psdfh4(z1,q2min,0.,2,3)
3423           tg=psdfh4(z1,q2min,0.,2,0)
3424           tsea=2.*(psdfh4(z1,q2min,0.,2,-1)+psdfh4(z1,q2min,0.,2,-2)
3425      *    +psdfh4(z1,q2min,0.,2,-3))
3426           gy=sdn*(tu/2.25+td/9.+ts/9.+tsea/4.5)+sdtg*tg/4.5
3427      *    +sdt*(tu+td+ts+tsea)/4.5
3428           dgh=dgh+a1(i)*gy*(1.-qq/s/z1)
3429         enddo
3430         enddo
3431         dgh=dgh*log((1.-qq/s)/(xmin-qq/s))*.5
3432       endif
3433       psdgh=psdgh+dgh
3434       return
3435       end
3436 
3437 c------------------------------------------------------------------------
3438       function psdh(s,qq,iclpro0,long)
3439 c-----------------------------------------------------------------------
3440 c pshard - hard quark-quark interaction cross-section
3441 c s - energy squared for the interaction (hadron-hadron),
3442 c iclpro0 - type of the primary hadron (nucleon)
3443 c-----------------------------------------------------------------------
3444       common /ar3/   x1(7),a1(7)
3445       include 'epos.incsem'
3446       include 'epos.inc'
3447       double precision psuds
3448 
3449       xd=qq/s
3450       qqs=q2min
3451       if(long.eq.0.and.(idisco.eq.0.or.idisco.eq.1))then
3452         psdh=(psdfh4(xd,qqs,0.,iclpro0,1)/2.25+
3453      *  psdfh4(xd,qqs,0.,iclpro0,2)/9.)
3454      *  *sngl(psuds(qq,1)/psuds(qqs,1))
3455      *  *4.*pi**2*alfe/qq
3456       else
3457         psdh=0.
3458       endif
3459 
3460       dh=0.
3461       if(long.eq.0)then
3462         s2min=qq/(1.-q2ini/qq)
3463       else
3464         s2min=4.*max(q2min,qcmass**2)+qq
3465         s2min=s2min/(1.-4.*q2ini/(s2min-qq))
3466       endif
3467       xmin=s2min/s
3468       if(xmin.lt.1.)then
3469         do i=1,7          !numerical integration over z1
3470         do m=1,2
3471           if(long.eq.0)then
3472             z1=qq/s+(xmin-qq/s)*((1.-qq/s)/(xmin-qq/s))
3473      *      **(.5+(m-1.5)*x1(i))
3474           else
3475             z1=.5*(1.+xmin+(2*m-3)*x1(i)*(1.-xmin))
3476           endif
3477           call psdint(z1*s,qq,sds,sdn,sdb,sdt,sdr,1,long)
3478           tu=psdfh4(z1,qqs,0.,iclpro0,1)
3479           td=psdfh4(z1,qqs,0.,iclpro0,2)
3480           gy=sdt*(tu+td)/4.5+sdn*(tu/2.25+td/9.)
3481           if(long.eq.0)then
3482             gy=gy*(1.-qq/s/z1)
3483           else
3484             gy=gy/z1
3485           endif
3486           dh=dh+a1(i)*gy
3487         enddo
3488         enddo
3489         if(long.eq.0)then
3490           dh=dh*log((1.-qq/s)/(xmin-qq/s))*.5
3491         else
3492           dh=dh*(1.-xmin)*.5
3493         endif
3494       endif
3495       psdh=psdh+dh
3496       return
3497       end
3498 
3499 c------------------------------------------------------------------------
3500       function psdsh(s,qq,iclpro0,dqsh,long)
3501 c-----------------------------------------------------------------------
3502 c psdsh - semihard interaction eikonal
3503 c s - energy squared for the interaction (hadron-hadron),
3504 c iclpro0 - hadron class,
3505 c z - impact parameter factor, z=exp(-b**2/rp),
3506 c iqq - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
3507 c-----------------------------------------------------------------------
3508       common /ar3/    x1(7),a1(7)
3509       include 'epos.inc'
3510       include 'epos.incsem'
3511       double precision psuds
3512 
3513       xd=qq/s
3514       if(long.eq.0.and.(idisco.eq.0.or.idisco.eq.1))then
3515         dqsh=fzeroSeaZZ(xd,iclpro0)/xd**dels
3516      *  *ffrr*4.*pi*gamhad(iclpro0)/
3517      *  4.5*sngl(psuds(qq,1)/psuds(q2min,1))
3518      *  *4.*pi**2*alfe/qq
3519       else
3520         dqsh=0.
3521       endif
3522 
3523       if(long.eq.0)then
3524         s2min=qq/(1.-q2ini/qq)
3525       else
3526         s2min=qq+4.*max(q2min,qcmass**2)
3527       endif
3528       xmin=s2min/s
3529       xmin=xmin**(delh-dels)
3530       dsh=0.
3531       if(xmin.lt.1.)then
3532 c numerical integration over z1
3533         do i=1,7
3534         do m=1,2
3535           z1=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./
3536      *    (delh-dels))
3537           call psdint(z1*s,qq,sdsg,sdng,sdbg,sdtg,sdrg,0,long)
3538           call psdint(z1*s,qq,sdsq,sdnq,sdbq,sdtq,sdrq,1,long)
3539           dsh=dsh+a1(i)/z1**delh*(sdtg*fzeroGluZZ(z1,iclpro0)
3540      *    +(sdtq+sdnq)*fzeroSeaZZ(z1,iclpro0))
3541         enddo
3542         enddo
3543         dsh=dsh*(1.-xmin)/(delh-dels)/2.
3544       endif
3545       psdsh=dqsh+dsh*ffrr*4.*pi*gamhad(iclpro0)/4.5  !*ccorr(1,1,iclpro0)
3546       return
3547       end
3548 
3549 cc------------------------------------------------------------------------
3550 c      function psdsh1(s,qq,iclpro0,dqsh,long)
3551 cc-----------------------------------------------------------------------
3552 cc psdsh - semihard interaction eikonal
3553 cc s - energy squared for the interaction (hadron-hadron),
3554 cc iclpro0 - hadron class,
3555 cc z - impact parameter factor, z=exp(-b**2/rp),
3556 cc iqq - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
3557 cc-----------------------------------------------------------------------
3558 c      common /ar3/    x1(7),a1(7)
3559 c      include 'epos.inc'
3560 c      include 'epos.incsem'
3561 cc      double precision psuds
3562 c
3563 c      psdsh1=0.       !only for plotting in psaevp : not use any more
3564 c
3565 cc$$$      xd=qq/s
3566 cc$$$      write(ifch,*)'Psdsh1 for xd,qq',xd,qq
3567 cc$$$      if(long.eq.0.and.(idisco.eq.0.or.idisco.eq.1))then
3568 cc$$$        dqsh=psftist(xd)/4.5*sngl(psuds(qq,1)/psuds(q2min,1))
3569 cc$$$     *  *4.*pi**2*alfe/qq
3570 cc$$$      else
3571 cc$$$        dqsh=0.
3572 cc$$$      endif
3573 cc$$$
3574 cc$$$      if(long.eq.0)then
3575 cc$$$        s2min=qq/(1.-q2ini/qq)
3576 cc$$$      else
3577 cc$$$        s2min=qq+4.*max(q2min,qcmass**2)
3578 cc$$$      endif
3579 cc$$$      xmin=s2min/s
3580 cc$$$      xmin=xmin**(delh-dels)
3581 cc$$$      dsh=0.
3582 cc$$$      if(xmin.lt.1.)then
3583 cc$$$c numerical integration over z1
3584 cc$$$        do i=1,7
3585 cc$$$        do m=1,2
3586 cc$$$          z1=(.5*(1.+xmin-(2*m-3)*x1(i)*(1.-xmin)))**(1./
3587 cc$$$     *    (delh-dels))
3588 cc$$$          call psdint(z1*s,qq,sdsg,sdng,sdbg,sdtg,sdrg,0,long)
3589 cc$$$          call psdint(z1*s,qq,sdsq,sdnq,sdbq,sdtq,sdrq,1,long)
3590 cc$$$          dsh=dsh+a1(i)/z1**delh*(sdtg*psftigt(z1)
3591 cc$$$     *    +(sdtq+sdnq)*psftist(z1))*z1**dels
3592 cc$$$        enddo
3593 cc$$$        enddo
3594 cc$$$        dsh=dsh*(1.-xmin)/(delh-dels)/2.
3595 cc$$$      endif
3596 cc$$$      psdsh1=dqsh+dsh/4.5
3597 c      return
3598 c      end
3599 c
3600 
3601 c------------------------------------------------------------------------
3602       function psev0(q1,qq,xx,j)
3603 c-----------------------------------------------------------------------
3604       double precision xx,psuds,psev00
3605       common /ar3/   x1(7),a1(7)
3606       include 'epos.incsem'
3607 
3608       psev0=0.
3609       psev00=0.d0
3610       do i=1,7
3611       do m=1,2
3612         if(j.eq.1)then           !g->q
3613           qi=2.*q1/(1.+q1/qq+(1.-q1/qq)*(2.*m-3.)*x1(i))
3614           psev00=psev00+a1(i)*qi*psuds(qi,0)/psuds(qi,1)
3615      *    /log(qi*(1.d0-xx)/qcdlam)
3616         else                     !q->g
3617           qi=(.5*(q1+qq+(q1-qq)*(2.*m-3.)*x1(i)))
3618           psev00=psev00+a1(i)/qi/psuds(qi,0)*psuds(qi,1)
3619      *    /log(qi*(1.d0-xx)/qcdlam)
3620         endif
3621       enddo
3622       enddo
3623 
3624       if(j.eq.1)then
3625         psev00=psev00*(1.d0/q1-1.d0/qq)*psuds(qq,1)/psuds(qq,0)/2.d0
3626       else
3627         psev00=psev00*(qq-q1)*psuds(qq,0)/psuds(qq,1)/2.d0
3628       endif
3629       psev00=psev00/log(log(qq*(1.d0-xx)/qcdlam)
3630      &             /log(q1*(1.d0-xx)/qcdlam))
3631       psev0=sngl(psev00)
3632       return
3633       end
3634 
3635 c------------------------------------------------------------------------
3636       function psev(q1,qq,xx,j,l,n)
3637 c------------------------------------------------------------------------
3638       double precision xx,zmax,zmax1,zmin,zmin1,z,psuds,fk,fq
3639      &,fz1,fz2
3640       common /ar3/   x1(7),a1(7)
3641       include 'epos.incsem'
3642 
3643       zmax=1.d0-q2ini/qq
3644       zmin=xx/zmax
3645       qmax=qq
3646       fz1=0.d0
3647       fz2=0.d0
3648 
3649       if(zmin.lt.zmax)then
3650       if(zmin.lt..1d0)then
3651         zmax1=min(.1d0,zmax)
3652         do i=1,7
3653         do m=1,2
3654           if(n.eq.2)then
3655             z=xx+(zmin-xx)*((zmax1-xx)/(zmin-xx))**(.5+(m-1.5)*x1(i))
3656           elseif(j.eq.1)then
3657             z=zmin*(zmax1/zmin)**(.5+(m-1.5)*x1(i))
3658           else
3659             z=(.5d0*(zmax1+zmin+(zmax1-zmin)*(2*m-3)*x1(i)))
3660           endif
3661           qmin=max(q2ini/(1.d0-xx/z),q2ini/(1.d0-z))
3662           qmin=max(qmin,q1)
3663 
3664           do k=1,2
3665             fq=0.d0
3666             do i1=1,7
3667             do m1=1,2
3668               if(n.eq.2)then
3669                 qi=qmin*(qmax/qmin)**(.5+x1(i1)*(m1-1.5))
3670               else
3671                 qi=(.5*(qmax+qmin+(qmax-qmin)*(2.*m1-3.)*x1(i1)))
3672               endif
3673 
3674               if(j.eq.3.and.k.eq.1)then
3675                 fk=0.d0
3676               else
3677                 if(n.eq.2)then
3678                   fk=dble(psevi0(q1,qi,xx/z,min(2,j),k))
3679                 else
3680                   fk=dble(psevi(q1,qi,xx/z,j,k)/qi)
3681                 endif
3682               endif
3683               qt=qi*(1.d0-z)
3684               fq=fq+a1(i1)*fk/psuds(qi,l-1)*pssalf(qt/qcdlam)
3685             enddo
3686             enddo
3687             if(n.eq.2)then
3688               fq=fq*log(qmax/qmin)*(1.d0-xx/z)
3689             elseif(j.eq.1)then
3690               fq=fq*(qmax-qmin)
3691             else
3692               fq=fq*(qmax-qmin)/z
3693             endif
3694             fz1=fz1+a1(i)*fq*psfap(z,k-1,l-1)
3695           enddo
3696         enddo
3697         enddo
3698         if(n.eq.2)then
3699           fz1=fz1*log((zmax1-xx)/(zmin-xx))/4.
3700         elseif(j.eq.1)then
3701           fz1=fz1*log(zmax1/zmin)/4.
3702         else
3703           fz1=fz1*(zmax1-zmin)/4.
3704         endif
3705       endif
3706 
3707       if(zmax.gt..1d0)then
3708         zmin1=max(.1d0,zmin)
3709         do i=1,7
3710         do m=1,2
3711           z=1.d0-(1.d0-zmax)*((1.d0-zmin1)/(1.d0-zmax))**
3712      *    (.5+x1(i)*(m-1.5))
3713           qmin=max(q2ini/(1.d0-z),q2ini/(1.d0-xx/z))
3714           qmin=max(qmin,q1)
3715 
3716           do k=1,2
3717             fq=0.
3718             do i1=1,7
3719             do m1=1,2
3720               if(n.eq.2)then
3721                 qi=qmin*(qmax/qmin)**(.5+x1(i1)*(m1-1.5))
3722               else
3723                 qi=(.5*(qmax+qmin+(qmax-qmin)*(2.*m1-3.)*x1(i1)))
3724               endif
3725 
3726               if(j.eq.3.and.k.eq.1)then
3727                 fk=0.d0
3728               else
3729                 if(n.eq.2)then
3730                   fk=dble(psevi0(q1,qi,xx/z,min(2,j),k))
3731                 else
3732                   fk=dble(psevi(q1,qi,xx/z,j,k)/qi)
3733                 endif
3734               endif
3735               qt=qi*(1.d0-z)
3736               fq=fq+a1(i1)*fk/psuds(qi,l-1)*pssalf(qt/qcdlam)
3737             enddo
3738             enddo
3739             if(n.eq.2)then
3740               fq=fq*log(qmax/qmin)
3741             else
3742               fq=fq*(qmax-qmin)
3743             endif
3744             fz2=fz2+a1(i)*fq*psfap(z,k-1,l-1)*(1.d0/z-1.d0)
3745           enddo
3746         enddo
3747         enddo
3748         fz2=fz2*log((1.d0-zmin1)/(1.d0-zmax))/4.
3749       endif
3750       endif
3751       psev=sngl((fz1+fz2)*psuds(qq,l-1))
3752       return
3753       end
3754 
3755 c------------------------------------------------------------------------
3756       function psevi0(q1,qq,xx,m,l)
3757 c------------------------------------------------------------------------
3758       double precision xx,xmax,psuds
3759       dimension wi(3),wj(3),wk(3)
3760       common /psar2/  edmax,epmax
3761       common /psar31/ evk0(21,21,54)
3762       include 'epos.inc'
3763       include 'epos.incsem'
3764 
3765       xmax=1.d0-2.d0*q2ini/epmax
3766       qmin=max(1.d0*q2min,q2ini/(1.d0-xx))
3767       qm1=max(q1,qmin)
3768       if(qq.gt..5001*epmax.and.ish.ge.1)then
3769         write(ifch,*)'0-extrap.:q1,qq,epmax,xx,m,l:',q1,qq,epmax,xx,m,l
3770 c        stop
3771       endif
3772       if(xx.ge.xmax.or.qq.le.1.000*qm1)then
3773         psevi0=0.
3774 c        write (*,*)'xx,xmax,qq,qm1,qmin,q1',xx,xmax,qq,qm1,qmin,q1
3775         return
3776       endif
3777 
3778       if(m.eq.l)then
3779         psevi0=1.
3780       else
3781         if(xx.lt..1d0)then
3782           yx=log(10.d0*xx)+13.
3783           k=int(yx)
3784           if(k.gt.11)k=11
3785           if(k.lt.1)k=1
3786         elseif(xx.lt..9d0)then
3787           yx=10.*xx+12.
3788           k=int(yx)
3789           if(k.gt.19)k=19
3790         else
3791           yx=log(10.d0*(1.d0-xx))/log(10.d0*(1.d0-xmax))*6.+21
3792           k=int(yx)
3793           if(k.gt.25)k=25
3794         endif
3795         wk(2)=yx-k
3796         wk(3)=wk(2)*(wk(2)-1.)*.5
3797         wk(1)=1.-wk(2)+wk(3)
3798         wk(2)=wk(2)-2.*wk(3)
3799 
3800         qli=log(qq/qmin)/log(.5*epmax/qmin)*20.+1.
3801         qlj=log(qm1/qmin)/log(qq/qmin)*20.+1.
3802         i=int(qli)
3803         if(i.gt.19)i=19
3804         if(i.lt.1)i=1
3805         wi(2)=qli-i
3806         wi(3)=wi(2)*(wi(2)-1.)*.5
3807         wi(1)=1.-wi(2)+wi(3)
3808         wi(2)=wi(2)-2.*wi(3)
3809 
3810         j=int(qlj)
3811         if(j.lt.1)j=1
3812         if(j.gt.19)j=19
3813         wj(2)=qlj-j
3814         wj(3)=wj(2)*(wj(2)-1.)*.5
3815         wj(1)=1.-wj(2)+wj(3)
3816         wj(2)=wj(2)-2.*wj(3)
3817 
3818         psevi0=0.
3819         do i1=1,3
3820         do j1=1,3
3821         do k1=1,3
3822           psevi0=psevi0+evk0(i+i1-1,j+j1-1,k+k1-1+27*(m-1))
3823      *    *wi(i1)*wj(j1)*wk(k1)
3824         enddo
3825         enddo
3826         enddo
3827         psevi0=exp(psevi0)
3828       endif
3829       psevi0=psevi0*psfap(xx,m-1,l-1)*log(log(qq*(1.d0-xx)/qcdlam)
3830      */log(qm1*(1.d0-xx)/qcdlam))*sngl(psuds(qq,m-1)/psuds(q1,m-1))/4.5
3831       return
3832       end
3833 
3834 c------------------------------------------------------------------------
3835       function psevi(q1,qq,xx,m,l)
3836 c------------------------------------------------------------------------
3837 c       m l: 1 1 ... gluon -> gluon
3838 c            2 1 ... quark -> gluon
3839 c            1 2 ... gluon -> quark
3840 c            3 2 ... quark -> quark non singlet
3841 c            2 2 ... quark -> quark all
3842 c                             singlet = all - non singlet
3843 c-----------------------------------------------------------------------
3844       double precision xx,xmax,psuds
3845       dimension wi(3),wj(3),wk(3)
3846       common /psar2/  edmax,epmax
3847       common /psar32/ evk(21,21,135)
3848       include 'epos.inc'
3849       include 'epos.incsem'
3850 
3851       psevi=0.
3852       xmax=1.d0-2.d0*q2ini/epmax
3853       if(qq.gt..5001*epmax.and.ish.ge.1)then
3854         write(ifch,*)'1-extrap.:q1,qq,epmax,xx,m,l:',q1,qq,epmax,xx,m,l
3855 c        stop
3856       endif
3857       qmin=max(1.d0*q2min,q2ini/(1.d0-xx))
3858       qm1=max(q1,qmin)
3859       if(xx.ge.xmax.or.qq.le.1.0001*qm1)then
3860         return
3861       endif
3862       qmin1=max(1.d0*qmin,q2ini/(1.d0-dsqrt(xx)))
3863       if(qq.le.1.0001*qmin1)then
3864         psevi=psevi0(q1,qq,xx,min(m,2),l)
3865         return
3866       endif
3867 
3868       if(xx.lt..1d0)then
3869         yx=log(10.d0*xx)+13.
3870         k=int(yx)
3871         if(k.gt.11)k=11
3872         if(k.lt.1)k=1
3873       elseif(xx.lt..9d0)then
3874         yx=10.*xx+12.
3875         k=int(yx)
3876         if(k.gt.19)k=19
3877       else
3878         yx=log(10.d0*(1.d0-xx))/log(10.d0*(1.d0-xmax))*6.+21
3879         k=int(yx)
3880         if(k.gt.25)k=25
3881       endif
3882       wk(2)=yx-k
3883       wk(3)=wk(2)*(wk(2)-1.)*.5
3884       wk(1)=1.-wk(2)+wk(3)
3885       wk(2)=wk(2)-2.*wk(3)
3886 
3887       qli=log(qq/qmin)/log(.5*epmax/qmin)*20.+1.
3888       qlj=log(qm1/qmin)/log(qq/qmin)*20.+1.
3889       i=int(qli)
3890       if(i.lt.1)i=1
3891       if(i.gt.19)i=19
3892       wi(2)=qli-i
3893       wi(3)=wi(2)*(wi(2)-1.)*.5
3894       wi(1)=1.-wi(2)+wi(3)
3895       wi(2)=wi(2)-2.*wi(3)
3896 
3897       j=int(qlj)
3898       if(j.lt.1)j=1
3899       if(j.gt.19)j=19
3900       wj(2)=qlj-j
3901       wj(3)=wj(2)*(wj(2)-1.)*.5
3902       wj(1)=1.-wj(2)+wj(3)
3903       wj(2)=wj(2)-2.*wj(3)
3904 
3905       do i1=1,3
3906       do j1=1,3
3907       do k1=1,3
3908         if(m.eq.3)then
3909           k2=k+k1-1+108
3910         else
3911           k2=k+k1-1+27*(m-1)+54*(l-1)
3912         endif
3913         psevi=psevi+evk(i+i1-1,j+j1-1,k2)
3914      *  *wi(i1)*wj(j1)*wk(k1)
3915       enddo
3916       enddo
3917       enddo
3918       psevi=exp(psevi)*psfap(xx,m-1,l-1)*log(log(qq*(1.d0-xx)/qcdlam)
3919      */log(qm1*(1.d0-xx)/qcdlam))/4.5
3920       if(q1.lt.qm1)psevi=psevi*sngl(psuds(qm1,m-1)/psuds(q1,m-1))
3921       return
3922       end
3923 
3924 c------------------------------------------------------------------------
3925       function psjci(q1,s,l1)
3926 c-----------------------------------------------------------------------
3927 c psjci - inclusive ordered ladder cross-section interpolation for c-quark
3928 c q1 - virtuality cutoff at current end of the ladder
3929 c s - total c.m. energy squared for the ladder,
3930 c l1 - parton type at current end of the ladder (0-g, 1,2,etc.-q)
3931 c-----------------------------------------------------------------------
3932       dimension wi(3),wk(3)
3933       common /psar2/  edmax,epmax
3934       common /psar23/ cschar(20,20,2)
3935       include 'epos.incsem'
3936 
3937       psjci=0.
3938       q2mass=qcmass**2
3939       spmin=4.*q2min+q2mass
3940       qq=q1
3941       s2min=4.*qq+q2mass
3942       if(s.le.s2min)return
3943 
3944       smins=s2min/(1.-q2ini/q1)
3945 c      if(s.le.smins)goto 1
3946       if(s.le.smins.or.qq.le.q2min)goto 1        !??????? ctp070618
3947 
3948       p1=s/(1.+q2mass/s)
3949       if(p1.gt.4.*qq)then
3950         tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
3951       else
3952         tmin=2.*qq
3953       endif
3954       tmax=p1/2.
3955       qmax=p1/4.
3956 
3957       l=min(1,iabs(l1))+1
3958       qli=log(qq/q2min)/log(qmax/q2min)*19.+1.
3959       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
3960       k=int(sl)
3961       i=int(qli)
3962       if(i.lt.1)i=1
3963       if(k.gt.18)k=18
3964       if(i.gt.18)i=18
3965 
3966       wi(2)=qli-i
3967       wi(3)=wi(2)*(wi(2)-1.)*.5
3968       wi(1)=1.-wi(2)+wi(3)
3969       wi(2)=wi(2)-2.*wi(3)
3970 
3971       wk(2)=sl-k
3972       wk(3)=wk(2)*(wk(2)-1.)*.5
3973       wk(1)=1.-wk(2)+wk(3)
3974       wk(2)=wk(2)-2.*wk(3)
3975 
3976       do i1=1,3
3977       do k1=1,3
3978         psjci=psjci+cschar(i+i1-1,k+k1-1,l)*wi(i1)*wk(k1)
3979       enddo
3980       enddo
3981       psjci=exp(psjci)*(1./tmin-1./tmax)
3982       return
3983 1     psjci=psbint(q2min,q1,0.,s,4,l1,0)
3984       return
3985       end
3986 
3987 c-----------------------------------------------------------------------
3988       function psjct(s,l)
3989 c-----------------------------------------------------------------------
3990 c psjct - unordered ladder cross-section for c-quark
3991 c s - c.m. energy squared for the scattering;
3992 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
3993 c-----------------------------------------------------------------------
3994       double precision xx,zmax,qmax,qmin,qi,zmin,fsj,z,s2,sj
3995       common /ar3/   x1(7),a1(7)
3996       include 'epos.inc'
3997       include 'epos.incsem'
3998 
3999       psjct=0.
4000       q2mass=qcmass**2
4001       zmax=dble(s)/(dble(s)+dble(5.*q2mass))
4002       qmax=zmax**2*dble(q2mass)/(1.d0-zmax)
4003       qmin=dble(q2min)
4004 
4005       if(qmax.lt.qmin.and.ish.ge.1)write(ifch,*)'psjct:qmin,qmax'
4006      *                                          ,qmin,qmax
4007       do i=1,7
4008       do m=1,2
4009         qi=2.d0*qmin/(1.d0+qmin/qmax+dble((2*m-3)*x1(i))
4010      *              *(1.d0-qmin/qmax))
4011         zmax=(2.d0/(1.d0+dsqrt(1.d0+4.d0*dble(q2mass)/qi)))**delh
4012         zmin=(5.d0*qi/dble(s))**delh
4013 
4014         fsj=0.d0
4015         if(zmax.lt.zmin.and.ish.ge.1)write(ifch,*)'psjct:zmin,zmax'
4016      *                                            ,zmin,zmax
4017         do i1=1,7
4018         do m1=1,2
4019           z=(.5d0*(zmax+zmin+dble((2*m1-3)*x1(i1))
4020      *      *(zmax-zmin)))**(1./delh)
4021           s2=z*dble(s)-qi
4022           xx=z
4023           sj=dble(psjti(sngl(qi),q2min,sngl(s2),0,l,0)*psfap(xx,1,0))*z
4024           fsj=fsj+dble(a1(i1))*sj*dble(pssalf(sngl(qi)/qcdlam))/z**delh
4025         enddo
4026         enddo
4027         fsj=fsj*(zmax-zmin)
4028         psjct=psjct+a1(i)*sngl(fsj*qi)
4029       enddo
4030       enddo
4031       psjct=psjct*sngl(1./qmin-1./qmax)/delh/4.
4032       return
4033       end
4034 
4035 c------------------------------------------------------------------------
4036       function psjet1(q1,q2,qqcut,s,j,l,jdis)
4037 c-----------------------------------------------------------------------
4038 c psjet1 - ordered parton ladder cross-section
4039 c q1 - virtuality cutoff at current end of the ladder;
4040 c q2 - virtuality cutoff at opposite end of the ladder;
4041 c qqcut - p_t cutoff for the born process;
4042 c s - c.m. energy squared for the scattering;
4043 c j - parton type at current end of the ladder (0 - g, 1,2 etc. - q);
4044 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
4045 c-----------------------------------------------------------------------
4046       double precision xx,z,qq,xmax,xmin,s2min,smin,p1,q2ms,q2inis,xmin1
4047      *,sh,qtmin,t,xmax1,fx1,fx2,psuds
4048       common /ar3/   x1(7),a1(7)
4049       common /ar9/ x9(3),a9(3)
4050       include 'epos.inc'
4051       include 'epos.incsem'
4052 
4053       psjet1=0.
4054       if(jdis.eq.0)then
4055         qq=dble(max(q1,q2))
4056       elseif(jdis.eq.1)then
4057         qq=dble(max(q1/4.,q2))
4058       else
4059         qq=dble(max(q1,q2/4.))
4060       endif
4061       qq=max(qq,dble(qqcut))
4062       if(l.ne.3)then
4063         q2mass=0.
4064       else
4065         q2mass=qcmass**2
4066       endif
4067       s2min=dble(q2mass)+4.d0*qq
4068       if(jdis.eq.0.or.jdis.eq.2)then
4069         smin=s2min/(1.d0-dble(q2ini)/qq)
4070       else
4071         smin=s2min/(1.d0-dble(q2ini)/qq/4.d0)
4072       endif
4073       if(dble(s).le.smin)return
4074 
4075       q2ms=dble(q2mass)/dble(s)
4076       q2inis=dble(q2ini)/dble(s)
4077       p1=dble(s)/(1.d0+q2ms)
4078 
4079 
4080       if(jdis.eq.0.or.jdis.eq.2)then
4081         xmax=.5d0*(1.d0+q2ms)+dsqrt(.25d0*(1.d0-q2ms)**2-4.d0*q2inis)
4082       else
4083         xmax=.5d0*(1.+q2ms)+dsqrt(.25d0*(1.-q2ms)**2-q2inis)
4084       endif
4085       xmin=max(1.d0+q2ms-xmax,s2min/dble(s))
4086       if(xmin.ge.xmax.and.ish.ge.1)then
4087         write(ifch,*)'jti1,xmin,xmax',xmin,xmax
4088 c        return
4089       endif
4090 
4091       fx1=0.d0
4092       fx2=0.d0
4093       if(xmax.gt..8d0)then
4094         xmin1=max(xmin,.8d0)
4095         do i=1,3
4096         do m=1,2
4097           z=1.d0-(1.d0-xmax)*((1.d0-xmin1)/(1.d0-xmax))**
4098      *    (.5d0+dble(x9(i)*(m-1.5)))
4099           sh=z*dble(s)
4100           xx=z
4101           p1=sh/(1.d0+dble(q2mass)/sh)
4102 
4103           if(jdis.eq.0.or.jdis.eq.2)then
4104             qtmin=max(qq,dble(q2ini)/(1.d0-z))
4105           else
4106             qtmin=max(qq,dble(q2ini)/(1.d0-z)/4.d0)
4107           endif
4108           tmin=2.d0*dble(qtmin)/(1.d0+dsqrt(1.d0-4.d0*dble(qtmin)/p1))
4109           tmax=p1/2.d0
4110 
4111           ft=0.
4112           if(tmin.ge.tmax.and.ish.ge.1)write(ifch,*)'psjet1:tmin,tmax'
4113      *                                              ,tmin,tmax
4114           do i1=1,3
4115           do m1=1,2
4116             t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
4117      &      *(1.d0-tmin/tmax))
4118             qt=sngl(t*(1.d0-t/p1))
4119 c            if(qt.lt.qtmin)write (*,*)'psjet1:qt,qq',qt,qq
4120 
4121             if(jdis.eq.0)then
4122               scale1=qt
4123               scale2=qt
4124             elseif(jdis.eq.1)then
4125               scale1=qt*4.
4126               scale2=qt
4127             elseif(jdis.eq.2)then
4128               scale1=qt
4129               scale2=qt*4.
4130             endif
4131             fb=0.
4132             do n=1,3
4133               fb=fb+psjetj(q1,scale1,sngl(t),xx,sngl(sh),j,l,n)
4134             enddo
4135             ft=ft+a9(i1)*fb*pssalf(qt/qcdlam)**2*sngl(t**2
4136      *      *psuds(scale2,l))
4137           enddo
4138           enddo
4139           fx1=fx1+dble(a9(i)*ft)*(1.d0/tmin-1.d0/tmax)/sh**2*(1.d0-z)
4140         enddo
4141         enddo
4142         fx1=fx1*dlog((1.d0-xmin1)/(1.d0-xmax))
4143       endif
4144 
4145       if(xmin.lt..8d0)then
4146         xmax1=min(xmax,.8d0)**(-delh)
4147         xmin1=xmin**(-delh)
4148         do i=1,3
4149         do m=1,2
4150           z=(.5d0*(xmax1+xmin1+(xmin1-xmax1)*dble((2*m-3)*x9(i))))
4151      *    **(-1./delh)
4152           sh=z*dble(s)
4153           xx=z
4154           p1=sh/(1.d0+dble(q2mass)/sh)
4155 
4156           if(jdis.eq.0.or.jdis.eq.2)then
4157             qtmin=max(qq,dble(q2ini)/(1.d0-z))
4158           else
4159             qtmin=max(qq,dble(q2ini)/(1.d0-z)/4.d0)
4160           endif
4161           tmin=2.d0*dble(qtmin)/(1.d0+dsqrt(1.d0-4.d0*dble(qtmin)/p1))
4162           tmax=p1/2.d0
4163 
4164           ft=0.
4165           if(tmin.ge.tmax.and.ish.ge.1)write(ifch,*)'psjet1:tmin,tmax'
4166      &                                              ,tmin,tmax
4167           do i1=1,3
4168           do m1=1,2
4169             t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
4170      &      *(1.d0-tmin/tmax))
4171             qt=sngl(t*(1.d0-t/p1))
4172           if(qt.lt.sngl(qtmin).and.ish.ge.1)write(ifch,*)'psjet1:qt,qq'
4173      &                                               ,qt,qq
4174 
4175             if(jdis.eq.0)then
4176               scale1=qt
4177               scale2=qt
4178             elseif(jdis.eq.1)then
4179               scale1=qt*4.
4180               scale2=qt
4181             elseif(jdis.eq.2)then
4182               scale1=qt
4183               scale2=qt*4.
4184             endif
4185             fb=0.
4186             do n=1,3
4187               fb=fb+psjetj(q1,scale1,sngl(t),xx,sngl(sh),j,l,n)
4188             enddo
4189             ft=ft+a9(i1)*fb*pssalf(qt/qcdlam)**2*sngl(t**2
4190      *      *psuds(scale2,l))
4191           enddo
4192           enddo
4193         fx2=fx2+dble(a9(i)*ft)*(1.d0/tmin-1.d0/tmax)/sh**2*z**(1.+delh)
4194         enddo
4195         enddo
4196         fx2=fx2*(xmin1-xmax1)/dble(delh)
4197       endif
4198       psjet1=sngl((fx1+fx2)/psuds(q2,l))*pi**3*2
4199      *    /2    !CS for parton pair
4200       return
4201       end
4202 
4203 c-----------------------------------------------------------------------
4204       function psjet(q1,q2,qqcut,s,j,l,jdis)
4205 c-----------------------------------------------------------------------
4206 c     parton ladder cross-section
4207 c     with at least one emission on each side
4208 c
4209 c q1 - virtuality cutoff at current end of the ladder;
4210 c q2 - virtuality cutoff at opposite end of the ladder;
4211 c qqcut - p_t cutoff for the born process;
4212 c s - c.m. energy squared for the scattering;
4213 c j - parton type at current end of the ladder (0 - g, 1,2 etc. - q);
4214 c l - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q).
4215 c-----------------------------------------------------------------------
4216       double precision xx1,xx2,qq,s2min,xmin,xmax,xmin1,xmax1,t,tmin
4217      *,tmax,sh,z,qtmin,ft,fx1,fx2
4218       common /ar3/   x1(7),a1(7)
4219       common /ar9/ x9(3),a9(3)
4220       include 'epos.inc'
4221       include 'epos.incsem'
4222       common/ccctest/iiitest
4223       iiitest=0
4224 
4225       psjet=0.
4226       if(jdis.eq.0)then
4227         qq=dble(max(q1,q2))
4228       else
4229         qq=dble(max(q1/4.,q2))
4230       endif
4231       qq=max(qq,dble(qqcut))
4232       s2min=4.d0*qq
4233       if(dble(s).le.s2min/(1.d0-dble(q2ini)/qq)**2)return   !kkkkkkk
4234 
4235       phi=acos(1.-54.*q2ini/s)/3.
4236       zmax=(1.+2.*cos(phi))**2/9.                 !kkkkkkk
4237       zmin=(1.-cos(phi)+sqrt(3.d0)*sin(phi))/3.   !kkkkkkk
4238       zmin=max(zmin**2,sngl(s2min/dble(s)))
4239       if(zmin.gt.zmax.and.ish.ge.1)write(ifch,*)'psjet:zmin,zmax'
4240      *                                           ,zmin,zmax
4241       zmin=zmin**(-delh)
4242       zmax=zmax**(-delh)
4243       do i=1,3
4244       do m=1,2
4245         z=dble(.5*(zmax+zmin+(zmin-zmax)*(2*m-3)*x9(i)))**(-1./delh)
4246         xmin=dsqrt(z)
4247         sh=z*dble(s)
4248 
4249         qtmin=max(qq,dble(q2ini)/(1.d0-dsqrt(z)))
4250         tmin=max(0.d0,1.d0-4.d0*qtmin/sh)
4251         tmin=2.d0*qtmin/(1.d0+dsqrt(tmin))         !kkkkkkk
4252         tmax=sh/2.d0
4253 
4254         ft=0.d0
4255 c        if(tmin.gt.tmax)write (*,*)'psjet:tmin,tmax',tmin,tmax
4256         do i1=1,3
4257         do m1=1,2
4258           t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
4259      &    *(1.d0-tmin/tmax))
4260           qt=t*(1.d0-t/sh)
4261 c          if(qt.lt.qtmin)write (*,*)'psjet:qt,qq',qt,qq
4262           xmax=1.d0-q2ini/qt
4263           xmin=max(dsqrt(z),z/xmax)   !xm>xp !!!
4264           if(xmin.gt.xmax.and.ish.ge.1)write(ifch,*)'psjet:xmin,xmax'
4265      *                                              ,xmin,xmax
4266           fx1=0.d0
4267           fx2=0.d0
4268           if(xmax.gt..8d0)then
4269             xmin1=max(xmin,.8d0)
4270             do i2=1,3
4271             do m2=1,2
4272               xx1=1.d0-(1.d0-xmax)*((1.d0-xmin1)/(1.d0-xmax))**
4273      *        dble(.5+x9(i2)*(m2-1.5))
4274               xx2=z/xx1
4275 
4276               fb=0.
4277                 fb=fb+psjeti(q1,q2,qt,sngl(t),xx1,xx2,sngl(sh)
4278      *                       ,j,l,jdis)
4279      *          +psjeti(q1,q2,qt,sngl(t),xx2,xx1,sngl(sh)
4280      *                       ,j,l,jdis)
4281               fx1=fx1+dble(a9(i2)*fb)*(1.d0/xx1-1.d0)
4282      *                               *pssalf(qt/qcdlam)**2
4283             enddo
4284             enddo
4285             fx1=fx1*dlog((1.d0-xmin1)/(1.d0-xmax))
4286           endif
4287           if(xmin.lt..8d0)then
4288             xmax1=min(xmax,.8d0)
4289             do i2=1,3
4290             do m2=1,2
4291               xx1=xmin*(xmax1/xmin)**dble(.5+x9(i2)*(m2-1.5))
4292               xx2=z/xx1
4293 
4294               fb=0.
4295                 fb=fb+psjeti(q1,q2,qt,sngl(t),xx1,xx2,sngl(sh)
4296      *                       ,j,l,jdis)
4297      *          +psjeti(q1,q2,qt,sngl(t),xx2,xx1,sngl(sh)
4298      *                       ,j,l,jdis)
4299               fx2=fx2+dble(a9(i2))*fb*pssalf(qt/qcdlam)**2
4300             enddo
4301             enddo
4302             fx2=fx2*dlog(xmax1/xmin)
4303           endif
4304           ft=ft+dble(a9(i1))*(fx1+fx2)*t**2
4305         enddo
4306         enddo
4307         ft=ft*(1.d0/tmin-1.d0/tmax)
4308         psjet=psjet+a9(i)*sngl(ft*z**(1.+delh)/sh**2)
4309       enddo
4310       enddo
4311       psjet=psjet*(zmin-zmax)/delh*pi**3
4312      *         /2.    !CS for parton pair
4313       return
4314       end
4315 
4316 c-----------------------------------------------------------------------
4317       function pijet(ii,qi,qq,sk,m1,l1) !polynomial interpol of jet CS
4318 c-----------------------------------------------------------------------
4319 c  ii ..... type of CS (2 = bothside, 1 = oneside, 0 = no emission, Born)
4320 c  qi ..... virtuality cutoff at current end of the ladder
4321 c  qq ..... virtuality cutoff of Born
4322 c  sk ..... energy squared for the scattering
4323 c  m1,l1 .. parton types
4324 c-----------------------------------------------------------------------
4325       include 'epos.incsem'
4326       common/psar2/edmax,epmax
4327       common/tabcsjet/ksmax,iqmax,jqmax,csjet(0:2,2,20,20,20,3,2)
4328       real wi(3),wj(3),wk(3)
4329       common/cpijet/npijet
4330       data npijet/0/
4331       npijet=npijet+1
4332       if(npijet.eq.1)call MakeCSTable
4333 
4334       if(m1.ne.0.and.m1.eq.l1)then
4335         m=2
4336         l=2
4337       elseif(m1.ne.0.and.m1.eq.-l1)then
4338         m=3
4339         l=1
4340       elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4341         m=3
4342         l=2
4343       else
4344         m=min(1,iabs(m1))+1
4345         l=min(1,iabs(l1))+1
4346       endif
4347 
4348       qqmin=min(qi,qq)
4349       qmax=sk/4.
4350       spmin=4.*q2min
4351       spmed=spmin*(epmax/2./spmin)**(1./(ksmax-1.))
4352       if(sk.le.spmed)then
4353         kk=2
4354         spmax=spmed
4355       else
4356         kk=1
4357         spmax=epmax/2.
4358       endif
4359 
4360       qli=1.+log(qi/q2min)/log(qmax/q2min)*(iqmax-1)
4361       qlj=1.+log(qq/qqmin)/log(qmax/qqmin)*(jqmax-1)
4362       sl= 1.+log(sk/spmin)/log(spmax/spmin)*(ksmax-1)
4363       k=int(sl)
4364       i=int(qli)
4365       j=int(qlj)
4366       if(k.lt.1)k=1
4367       if(j.lt.1)j=1
4368       if(i.lt.1)i=1
4369       if(k.gt.(ksmax-2))k=ksmax-2
4370       if(i.gt.(iqmax-2))i=iqmax-2
4371       if(j.gt.(jqmax-2))j=jqmax-2
4372 
4373       wi(2)=qli-i
4374       wi(3)=wi(2)*(wi(2)-1.)*.5
4375       wi(1)=1.-wi(2)+wi(3)
4376       wi(2)=wi(2)-2.*wi(3)
4377 
4378       wj(2)=qlj-j
4379       wj(3)=wj(2)*(wj(2)-1.)*.5
4380       wj(1)=1.-wj(2)+wj(3)
4381       wj(2)=wj(2)-2.*wj(3)
4382 
4383       wk(2)=sl-k
4384       wk(3)=wk(2)*(wk(2)-1.)*.5
4385       wk(1)=1.-wk(2)+wk(3)
4386       wk(2)=wk(2)-2.*wk(3)
4387 
4388       pijet=0
4389       do i1=1,3
4390       do j1=1,3
4391       do k1=1,3
4392         pijet=pijet+csjet(ii,kk,k+k1-1,i+i1-1,j+j1-1,m,l)
4393      *  *wi(i1)*wj(j1)*wk(k1)
4394       enddo
4395       enddo
4396       enddo
4397           ! if(ii.eq.2)print*,' '
4398           ! write(*,'(i2,f6.0,i2,3x,3(2f5.2,2x),f5.2)')
4399           !*  ii,sk,k,(wk(kk1),csjet(ii,kk,k+kk1-1,1,1,m,l),kk1=1,3) ,pijet
4400       end
4401 
4402 c-----------------------------------------------------------------------
4403       subroutine MakeCSTable     !tabulates psjet
4404 c-----------------------------------------------------------------------
4405 c   last two indices of table: parton types
4406 c        1 1 ... gg
4407 c        1 2 ... gq
4408 c        2 1 ... qg
4409 c        2 2 ... qq
4410 c        3 1 ... qa
4411 c        3 2 ... qq'
4412 c-----------------------------------------------------------------------
4413       include 'epos.incsem'
4414       common/psar2/edmax,epmax
4415       common/tabcsjet/ksmax,iqmax,jqmax,csjet(0:2,2,20,20,20,3,2)
4416       write (*,'(a,$)')'(CS table'
4417       ksmax=10
4418       iqmax=3
4419       jqmax=3
4420       spmin=4.*q2min
4421       do kk=1,2
4422        if(kk.eq.1)then
4423          spmax=epmax/2.
4424        else               !if(kk.eq.2)
4425          spmax=spmin*(epmax/2./spmin)**(1./(ksmax-1.))
4426        endif
4427        do m=1,3                 !parton type at upper end of the ladder
4428         write (*,'(a,$)')'.'
4429          do l=1,2              !parton type at lower end of the ladder
4430          m1=m-1
4431          l1=l-1
4432          if(m.eq.3.and.l.eq.1)l1=-m1
4433         do k=1,ksmax
4434           sk=spmin*(spmax/spmin)**((k-1.)/(ksmax-1.))
4435           qmax=sk/4.
4436           do i=1,iqmax
4437            qi=q2min*(qmax/q2min)**((i-1.)/(iqmax-1.))
4438            do j=1,jqmax
4439             qq=qi*(qmax/qi)**((j-1.)/(jqmax-1.))
4440                 !write(*,'(i3,4f8.3,2i4,$)')j, qi,q2min,qq,sk,m1,l1
4441             csjet(2,kk,k,i,j,m,l)= psjet(qi,q2min,qq,sk,m1,l1,0)
4442             csjet(1,kk,k,i,j,m,l)=psjet1(qi,q2min,qq,sk,m1,l1,0)
4443             csjet(0,kk,k,i,j,m,l)=psborn(qi,q2min,qq,sk,m1,l1,0,1)
4444        !   if(i.eq.1.and.j.eq.1.and.m.eq.1.and.l.eq.1)
4445        ! *write(*,'(2f8.2,f13.2,2i3,3x,i3,3f8.3)')
4446        ! * qi,qq,sk,m1,l1,k,csjet(2,kk,k,i,j,m,l)
4447        ! *             ,csjet(1,kk,k,i,j,m,l),csjet(0,kk,k,i,j,m,l)
4448            enddo
4449           enddo
4450          enddo
4451         enddo
4452        enddo
4453       enddo
4454       write (*,'(a,$)')'done)'
4455       end
4456 
4457 c-----------------------------------------------------------------------
4458       function psjeti(q1,q2,qt,t,xx1,xx2,s,j,l,jdis)
4459 c-----------------------------------------------------------------------
4460 c
4461 c      E~qcd_ji * E~qcd_lk * B_ik
4462 c
4463 c        B_ik = psbori = contribution to Born xsection:
4464 c                         dsigmaBorn/d2pt/dy
4465 c                         = s/pi * delta(s+t+u) * 2*pi*alpha**2 /s**2 * B_ik
4466 c
4467 c        E~qcd: at least one emission
4468 c
4469 c q1  - virtuality cutoff at current end of the ladder
4470 c q2  - virtuality cutoff at opposite end of the ladder
4471 c xx1 - feinman x for the first parton for the born process
4472 c xx2 - feinman x for the second parton for the born process
4473 c s   - c.m. energy squared for the born scattering
4474 c t   - invariant variable for the scattering |(p1-p3)**2|,
4475 c j   - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
4476 c l   - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
4477 c-----------------------------------------------------------------------
4478 c reminder
4479 c     psevi: 1 1 ... gluon -> gluon
4480 c            2 1 ... quark -> gluon
4481 c            1 2 ... gluon -> quark
4482 c            3 2 ... quark -> quark non singlet
4483 c            2 2 ... quark -> quark all
4484 c                          singlet = all - non singlet
4485 c-----------------------------------------------------------------------
4486       double precision xx1,xx2
4487       include 'epos.incsem'
4488       common/ccctest/iiitest
4489 
4490       if(jdis.eq.0)then
4491         scale=qt
4492       else
4493         scale=qt*4.
4494       endif
4495       if(j.eq.0.and.l.eq.0)then  ! gluon-gluon --->
4496         akg1=psevi(q1,scale,xx1,1,1)                  !gluon contribution
4497         akg2=psevi(q2,qt,xx2,1,1)                  !gluon contribution
4498         aks1=psevi(q1,scale,xx1,1,2)/naflav/2.  !singlet contribution per quark
4499         aks2=psevi(q2,qt,xx2,1,2)/naflav/2.  !singlet contribution per quark
4500         psjeti=ffborn(s,t,akg1*akg2
4501      *              ,(akg1*aks2+aks1*akg2)*naflav*2.    !ccccc
4502      *               ,aks1*aks2*naflav*2.
4503      *               ,aks1*aks2*naflav*2.
4504      *               ,aks1*aks2*naflav*2.*(naflav-1)*2.
4505      *)
4506       elseif(j.eq.0)then     !  gluon-quark --->
4507         akg1=psevi(q1,scale,xx1,1,1)                  !gluon contribution
4508         akg2=psevi(q2,qt,xx2,2,1)                  !gluon contribution
4509         aks1=psevi(q1,scale,xx1,1,2)/naflav/2.         !singlet contribution
4510         akns2=psevi(q2,qt,xx2,3,2)                 !nonsinglet contribution
4511         aks2=(psevi(q2,qt,xx2,2,2)-akns2)/naflav/2. !singlet contribution
4512         psjeti=ffborn(s,t,akg1*akg2
4513      *              ,(akg1*(akns2+aks2*naflav*2.)+aks1*akg2*naflav*2.)
4514      *              ,aks1*(akns2+aks2*naflav*2.)
4515      *              ,aks1*(akns2+aks2*naflav*2.)
4516      *              ,aks1*(akns2+aks2*naflav*2.)*(naflav-1)*2.)
4517       elseif(l.eq.0)then   ! quark-gluon --->
4518         akg1=psevi(q1,scale,xx1,2,1)                  !gluon contribution
4519         akg2=psevi(q2,qt,xx2,1,1)                  !gluon contribution
4520         akns1=psevi(q1,scale,xx1,3,2)                 !nonsinglet contribution
4521         aks1=(psevi(q1,scale,xx1,2,2)-akns1)/naflav/2. !singlet contribution
4522         aks2=psevi(q2,qt,xx2,1,2)/naflav/2.         !singlet contribution
4523         psjeti=ffborn(s,t,akg1*akg2
4524      *             ,(akg2*(akns1+aks1*naflav*2.)+aks2*akg1*naflav*2.)
4525      *             ,aks2*(akns1+aks1*naflav*2.)
4526      *             ,aks2*(akns1+aks1*naflav*2.)
4527      *             ,aks2*(akns1+aks1*naflav*2.)*(naflav-1)*2.)
4528       else     !  quark-quark --->
4529         akg1=psevi(q1,scale,xx1,2,1)                  !gluon contribution
4530         akg2=psevi(q2,qt,xx2,2,1)                  !gluon contribution
4531         akns1=psevi(q1,scale,xx1,3,2)                 !nonsinglet contribution
4532         aks1=(psevi(q1,scale,xx1,2,2)-akns1)/naflav/2.!singlet contribution
4533         akns2=psevi(q2,qt,xx2,3,2)                 !nonsinglet contribution
4534         aks2=(psevi(q2,qt,xx2,2,2)-akns2)/naflav/2.!singlet contribution
4535 
4536         if(j.eq.l)then
4537          psjeti=ffborn(s,t,akg1*akg2
4538      *     ,(akg2*(akns1+aks1*naflav*2.)+akg1*(akns2+aks2*naflav*2.))
4539      *     ,((akns1+aks1)*(akns2+aks2)+aks1*aks2*(2.*naflav-1.))
4540      *     ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
4541      *     ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)*(naflav-1)*2.)
4542         elseif(j.eq.-l)then
4543          psjeti=ffborn(s,t,akg1*akg2
4544      *     ,(akg2*(akns1+aks1*naflav*2.)+akg1*(akns2+aks2*naflav*2.))
4545      *     ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
4546      *     ,((akns1+aks1)*(akns2+aks2)+aks1*aks2*(2.*naflav-1.))
4547      *     ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)*(naflav-1)*2.)
4548         else                           !j.ne.l,-l
4549          psjeti=ffborn(s,t,akg1*akg2
4550      *    ,(akg2*(akns1+aks1*naflav*2.)+akg1*(akns2+aks2*naflav*2.))
4551      *    ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
4552      *    ,(akns1*aks2+akns2*aks1+aks1*aks2*naflav*2.)
4553      *    ,(akns1*akns2+akns1*aks2*(naflav-1)*2.
4554      *    +akns2*aks1*(naflav-1)*2.+aks1*aks2*naflav*2.*(naflav-1)*2.))
4555         endif
4556       endif
4557       return
4558       end
4559 
4560 c-----------------------------------------------------------------------
4561       function psjetj(q1,scale,t,xx,s,j,l,n)
4562 c-----------------------------------------------------------------------
4563 c psjetj - integrand for the ordered ladder cross-section
4564 c q1 - virtuality cutoff at current end of the ladder,
4565 c scale - born process scale,
4566 c t  - invariant variable for the scattering |(p1-p3)**2|,
4567 c xx - feinman x for the first parton for the born process
4568 c s  - c.m. energy squared for the born scattering,
4569 c j  - parton type at current end of the ladder (0 - g, 1,-1,2,... - q)
4570 c l  - parton type at opposite end of the ladder (0 - g, 1,-1,2,... - q)
4571 c n  - subprocess number
4572 c-----------------------------------------------------------------------
4573       double precision xx
4574       include 'epos.incsem'
4575 
4576       m=min(1,iabs(j))+1
4577       if(l.ne.3)then
4578         if(l.eq.0)then
4579           psjetj=psevi(q1,scale,xx,m,1)*(psbori(s,t,0,0,n)+               !gg
4580      *    psbori(s,s-t,0,0,n))/2.
4581      *    +psevi(q1,scale,xx,m,2)*(psbori(s,t,1,0,n)+                     !qg
4582      *    psbori(s,s-t,1,0,n))
4583         elseif(j.eq.0)then
4584           aks=psevi(q1,scale,xx,1,2)/naflav/2.  !singlet contribution per quark
4585           psjetj=psevi(q1,scale,xx,1,1)*(psbori(s,t,0,1,n)+               !gq
4586      *    psbori(s,s-t,0,1,n))
4587      *    +aks*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2.             !qq
4588      *    +aks*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n))              !qq~
4589      *    +aks*(psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))*(naflav-1)*2.   !qq'
4590         else
4591           akg=psevi(q1,scale,xx,2,1)                  !gluon contribution
4592           akns=psevi(q1,scale,xx,3,2)                 !nonsinglet contribution
4593           aks=(psevi(q1,scale,xx,2,2)-akns)/naflav/2.  !singlet contribution
4594           if(j.eq.l)then
4595             psjetj=akg*(psbori(s,t,0,1,n)+psbori(s,s-t,0,1,n))        !gq
4596      *      +(akns+aks)*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2.    !qq
4597      *      +aks*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n))            !qq~
4598      *      +aks*(psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))*(naflav-1)*2. !qq'
4599           elseif(j.eq.-l)then
4600             psjetj=akg*(psbori(s,t,0,1,n)+psbori(s,s-t,0,1,n))        !gq
4601      *      +aks*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2.           !qq
4602      *      +(akns+aks)*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n))     !qq~
4603      *      +aks*(psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))*(naflav-1)*2.!qq'
4604           else
4605             psjetj=akg*(psbori(s,t,0,1,n)+psbori(s,s-t,0,1,n))        !gq
4606      *      +aks*(psbori(s,t,1,1,n)+psbori(s,s-t,1,1,n))/2.           !qq
4607      *      +aks*(psbori(s,t,-1,1,n)+psbori(s,s-t,-1,1,n))            !qq~
4608      *      +(akns+aks*(naflav-1)*2.)*
4609      *      (psbori(s,t,1,2,n)+psbori(s,s-t,1,2,n))                   !qq'
4610           endif
4611         endif
4612       elseif(n.eq.1)then
4613         p1=s/(1.+qcmass**2/s)
4614         psjetj=psevi(q1,scale,xx,m,1)*(psbori(s,t,4,0,n)+                 !cg
4615      *  psbori(s,p1-t,4,0,n))
4616      *  +psevi(q1,scale,xx,m,2)*(psbori(s,t,4,1,n)+                       !cq
4617      *  psbori(s,p1-t,4,1,n))
4618       else
4619         psjetj=0.
4620       endif
4621       return
4622       end
4623 
4624 c------------------------------------------------------------------------
4625       function psjti(q1,qqcut,s,m1,l1,jdis)
4626 c-----------------------------------------------------------------------
4627 c psjti - inclusive hard cross-section interpolation - for any ordering
4628 c in the ladder
4629 c q1 - virtuality cutoff at current end of the ladder
4630 c qqcut - p_t cutoff for the born process;
4631 c s  - total c.m. energy squared for the ladder
4632 c m1 - parton type at current end of the ladder (0-g, 1,2,etc.-q)
4633 c l1 - parton type at opposite end of the ladder (0-g, 1,2,etc.-q)
4634 c-----------------------------------------------------------------------
4635       dimension wi(3),wj(3),wk(3)
4636       common /psar2/  edmax,epmax
4637       common /psar19/ cstot(20,20,240)
4638       include 'epos.incsem'
4639 
4640       psjti=0.
4641 c      jdis1=jdis
4642       if(jdis.eq.0)then
4643         qqmin=q1
4644         qmax=s/4.
4645       else
4646         qqmin=max(q2min,q1/4.)
4647         qmax=s
4648       endif
4649       qq=max(qqmin,qqcut)
4650       spmin=4.*q2min
4651       s2min=4.*qq
4652       if(s.le.s2min)return
4653 
4654       if(jdis.eq.0)then
4655         smins=s2min/(1.-q2ini/qq)
4656       else
4657         smins=s2min/(1.-q2ini/qq/4.)
4658       endif
4659       if(s.le.smins)goto 1
4660 
4661       if(s.gt.4.*qq)then
4662         tmin=2.*qq/(1.+sqrt(1.-4.*qq/s))
4663       else
4664         tmin=2.*qq
4665       endif
4666       tmax=s/2.
4667 
4668       if(m1.ne.0.and.m1.eq.l1)then
4669         m=2
4670         l=2
4671       elseif(m1.ne.0.and.m1.eq.-l1)then
4672         m=3
4673         l=1
4674       elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4675         m=3
4676         l=2
4677       else
4678         m=min(1,iabs(m1))+1
4679         l=min(1,iabs(l1))+1
4680       endif
4681 
4682       ml=20*(m-1)+60*(l-1)+120*jdis
4683       qli=log(q1/q2min)/log(qmax/q2min)*19.+1.
4684       qlj=log(qq/qqmin)/log(s/4./qqmin)*19.+1.
4685       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
4686       k=int(sl)
4687       i=int(qli)
4688       j=int(qlj)
4689       if(j.lt.1)j=1
4690       if(i.lt.1)i=1
4691       if(k.gt.18)k=18
4692       if(i.gt.18)i=18
4693       if(j.gt.18)j=18
4694 
4695       wi(2)=qli-i
4696       wi(3)=wi(2)*(wi(2)-1.)*.5
4697       wi(1)=1.-wi(2)+wi(3)
4698       wi(2)=wi(2)-2.*wi(3)
4699 
4700       wj(2)=qlj-j
4701       wj(3)=wj(2)*(wj(2)-1.)*.5
4702       wj(1)=1.-wj(2)+wj(3)
4703       wj(2)=wj(2)-2.*wj(3)
4704 
4705       wk(2)=sl-k
4706       wk(3)=wk(2)*(wk(2)-1.)*.5
4707       wk(1)=1.-wk(2)+wk(3)
4708       wk(2)=wk(2)-2.*wk(3)
4709 
4710       do i1=1,3
4711       do j1=1,3
4712       do k1=1,3
4713         psjti=psjti+cstot(i+i1-1,j+j1-1,k+k1+ml-1)
4714      *  *wi(i1)*wj(j1)*wk(k1)
4715       enddo
4716       enddo
4717       enddo
4718       psjti=exp(psjti)*(1./tmin-1./tmax)
4719       return
4720 1     continue
4721       psjti=psbint(q1,q2min,qqcut,s,m1,l1,jdis)
4722       return
4723       end
4724 
4725 c------------------------------------------------------------------------
4726       subroutine psjti0(ss,sj,sjb,m1,l1)
4727 c-----------------------------------------------------------------------
4728 c psjti0 - inclusive hard cross-section interpolation -
4729 c for minimal virtuality cutoff in the ladder
4730 c s - total c.m. energy squared for the ladder,
4731 c sj - inclusive jet cross-section,
4732 c sjb - born cross-section,
4733 c m1 - parton type at current end of the ladder (0-g, 1,2,etc.-q)
4734 c l1 - parton type at opposite end of the ladder (0-g, 1,2,etc.-q)
4735 c-----------------------------------------------------------------------
4736       dimension wk(3)
4737       common /psar2/  edmax,epmax
4738       common /psar22/ cstotzero(20,4,2),csborzer(20,4,2)
4739       include 'epos.incsem'
4740 
4741       sj=0.
4742       sjb=0.
4743       if(iabs(m1).ne.4)then
4744         q2mass=0.
4745         if(m1.ne.0.and.m1.eq.l1)then
4746           m=2
4747           l=2
4748         elseif(m1.ne.0.and.m1.eq.-l1)then
4749           m=3
4750           l=1
4751         elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4752           m=3
4753           l=2
4754         else
4755           m=min(1,iabs(m1))+1
4756           l=min(1,iabs(l1))+1
4757         endif
4758       else
4759         q2mass=qcmass**2
4760         m=4
4761         l=min(1,iabs(l1))+1
4762       endif
4763       s=ss-q2mass
4764       qq=q2min
4765       spmin=4.*qq+q2mass
4766       if(s.le.spmin)return
4767 
4768       p1=s/(1.+q2mass/s)
4769       if(p1.gt.4.*qq)then
4770         tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
4771       else
4772         tmin=2.*qq
4773       endif
4774       tmax=.5*p1
4775 
4776       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
4777       k=int(sl)
4778       if(k.gt.18)k=18
4779       wk(2)=sl-k
4780       wk(3)=wk(2)*(wk(2)-1.)*.5
4781       wk(1)=1.-wk(2)+wk(3)
4782       wk(2)=wk(2)-2.*wk(3)
4783 
4784       do k1=1,3
4785         sj=sj+cstotzero(k+k1-1,m,l)*wk(k1)
4786         sjb=sjb+csborzer(k+k1-1,m,l)*wk(k1)
4787       enddo
4788 
4789       sjb=exp(sjb)*(1./tmin-1./tmax)
4790       sj=max(sjb,exp(sj)*(1./tmin-1./tmax))
4791       return
4792       end
4793 
4794 c------------------------------------------------------------------------
4795       function psjti1(q1,q2,qqcut,s,m1,l1,jdis)
4796 c-----------------------------------------------------------------------
4797 c psjti1 - inclusive hard cross-section interpolation - for strict order
4798 c in the ladder
4799 c q1 - virtuality cutoff at current end of the ladder
4800 c q2 - virtuality cutoff at opposite end of the ladder
4801 c qqcut - p_t cutoff for the born process;
4802 c s - total c.m. energy squared for the ladder,
4803 c m1 - parton type at current end of the ladder (0-g, 1,2,etc.-q)
4804 c l1 - parton type at opposite end of the ladder (0-g, 1,2,etc.-q)
4805 c-----------------------------------------------------------------------
4806       dimension wi(3),wj(3),wk(3)
4807       common /psar2/  edmax,epmax
4808       common /psar20/ csord(20,20,240)
4809       include 'epos.incsem'
4810       double precision psuds
4811 
4812       psjti1=0.
4813       if(jdis.eq.0)then
4814         qqmin=max(q1,q2)
4815       else
4816         qqmin=max(q1,q2/4.)
4817       endif
4818       qq=max(qqmin,qqcut)
4819       spmin=4.*q2min
4820       s2min=4.*qq
4821       if(s.le.s2min)return
4822 
4823       smins=s2min/(1.-q2ini/qq)
4824       if(s.le.smins)goto 1
4825 
4826       if(s.gt.4.*qq)then
4827         tmin=2.*qq/(1.+sqrt(1.-4.*qq/s))
4828       else
4829         tmin=2.*qq
4830       endif
4831       tmax=s/2.
4832 
4833       if(m1.ne.0.and.m1.eq.l1)then
4834         m=2
4835         l=2
4836       elseif(m1.ne.0.and.m1.eq.-l1)then
4837         m=3
4838         l=1
4839       elseif(m1.ne.0.and.l1.ne.0.and.m1.ne.l1)then
4840         m=3
4841         l=2
4842       else
4843         m=min(1,iabs(m1))+1
4844         l=min(1,iabs(l1))+1
4845       endif
4846 
4847       ml=20*(m-1)+60*(l-1)+120*jdis
4848       qli=log(q1/q2min)/log(s/4./q2min)*19.+1.
4849       qlj=log(qq/qqmin)/log(s/4./qqmin)*19.+1.
4850       sl=log(s/spmin)/log(epmax/2./spmin)*19.+1.
4851       k=int(sl)
4852       i=int(qli)
4853       j=int(qlj)
4854       if(j.lt.1)j=1
4855       if(i.lt.1)i=1
4856       if(k.gt.18)k=18
4857       if(i.gt.18)i=18
4858       if(j.gt.18)j=18
4859 
4860       wi(2)=qli-i
4861       wi(3)=wi(2)*(wi(2)-1.)*.5
4862       wi(1)=1.-wi(2)+wi(3)
4863       wi(2)=wi(2)-2.*wi(3)
4864 
4865       wj(2)=qlj-j
4866       wj(3)=wj(2)*(wj(2)-1.)*.5
4867       wj(1)=1.-wj(2)+wj(3)
4868       wj(2)=wj(2)-2.*wj(3)
4869 
4870       wk(2)=sl-k
4871       wk(3)=wk(2)*(wk(2)-1.)*.5
4872       wk(1)=1.-wk(2)+wk(3)
4873       wk(2)=wk(2)-2.*wk(3)
4874 
4875       do i1=1,3
4876       do j1=1,3
4877       do k1=1,3
4878         k2=k+k1+ml-1
4879         psjti1=psjti1+csord(i+i1-1,j+j1-1,k2)
4880      *  *wi(i1)*wj(j1)*wk(k1)
4881       enddo
4882       enddo
4883       enddo
4884       psjti1=exp(psjti1)*(1./tmin-1./tmax)
4885 
4886       if(jdis.eq.0.and.qq.gt.q2)then
4887         psjti1=psjti1*sngl(psuds(qq,l1)/psuds(q2,l1))
4888       elseif(jdis.eq.1.and.4.*qq.gt.q2)then
4889         psjti1=psjti1*sngl(psuds(4.*qq,l1)/psuds(q2,l1))
4890       endif
4891       return
4892 1     continue
4893       if(jdis.eq.0)then
4894         psjti1=psbint(q1,q2,qqcut,s,m1,l1,0)
4895       else
4896         psjti1=psbint(q2,q1,qqcut,s,l1,m1,1)
4897       endif
4898       return
4899       end
4900 
4901 c------------------------------------------------------------------------
4902       function pspdfg(xx,qqs,qq,iclpro0,j)
4903 c-----------------------------------------------------------------------
4904 c pspdf - parton distribution function
4905 c qq  - virtuality scale
4906 c qqs - initial virtuality for the input distributions
4907 c iclpro0 - hadron class
4908 c j   - parton type
4909 c-----------------------------------------------------------------------
4910       double precision z
4911       common/ar3/    x1(7),a1(7)
4912       include 'epos.incsem'
4913       double precision psuds
4914 
4915       pspdfg=psdfh4(xx,qqs,0.,iclpro0,j)
4916       if(j.gt.0)pspdfg=pspdfg+psdfh4(xx,qqs,0.,iclpro0,-j)  !+sea contr.
4917       pspdfg=pspdfg*sngl(psuds(qq,j)/psuds(qqs,j))
4918 
4919       xmin=xx/(1.-q2ini/qq)
4920       if(xmin.ge.1.)return
4921 
4922       dpd1=0.
4923       dpd2=0.
4924       xm=max(xmin,.3)
4925       do i=1,7         !numerical integration over zx
4926       do m=1,2
4927         zx=1.-(1.-xm)*(.5+(m-1.5)*x1(i))**.25
4928         z=xx/zx
4929 
4930         if(j.eq.0)then
4931           aks=psevi(qqs,qq,z,2,1)                  !quark contribution
4932           akg=psevi(qqs,qq,z,1,1)                  !gluon contribution
4933           akns=0.
4934         else
4935           akg=psevi(qqs,qq,z,1,2)/naflav/2.         !gluon contribution
4936           akns=psevi(qqs,qq,z,3,2)            !nonsinglet contribution
4937           aks=(psevi(qqs,qq,z,2,2)-akns)/naflav/2.  !quark contribution
4938         endif
4939 
4940         fz=akg*psdfh4(zx,qqs,0.,iclpro0,0)
4941      *  +akns*psdfh4(zx,qqs,0.,iclpro0,j)
4942      *  +aks*(psdfh4(zx,qqs,0.,iclpro0,1)+
4943      *  2.*psdfh4(zx,qqs,0.,iclpro0,-1)
4944      *  +psdfh4(zx,qqs,0.,iclpro0,2)+2.*psdfh4(zx,qqs,0.,iclpro0,-2)
4945      *  +2.*psdfh4(zx,qqs,0.,iclpro0,-3))
4946         if(j.gt.0)fz=fz+akns*psdfh4(zx,qqs,0.,iclpro0,-j)
4947 
4948         dpd1=dpd1+a1(i)*fz/zx**2/(1.-zx)**3
4949       enddo
4950       enddo
4951       dpd1=dpd1*(1.-xm)**4/8.*xx
4952 
4953       if(xm.gt.xmin)then
4954         do i=1,7         !numerical integration
4955         do m=1,2
4956           zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))**(.5-(m-1.5)*x1(i))
4957           z=xx/zx
4958 
4959           if(j.eq.0)then
4960             aks=psevi(qqs,qq,z,2,1)                  !quark contribution
4961             akg=psevi(qqs,qq,z,1,1)                  !gluon contribution
4962             akns=0.
4963           else
4964             akg=psevi(qqs,qq,z,1,2)/naflav/2.         !gluon contribution
4965             akns=psevi(qqs,qq,z,3,2)            !nonsinglet contribution
4966             aks=(psevi(qqs,qq,z,2,2)-akns)/naflav/2.  !quark contribution
4967           endif
4968 
4969           fz=akg*psdfh4(zx,qqs,0.,iclpro0,0)
4970      *    +akns*psdfh4(zx,qqs,0.,iclpro0,j)
4971      *    +aks*(psdfh4(zx,qqs,0.,iclpro0,1)
4972      *    +2.*psdfh4(zx,qqs,0.,iclpro0,-1)
4973      *    +psdfh4(zx,qqs,0.,iclpro0,2)+2.*psdfh4(zx,qqs,0.,iclpro0,-2)
4974      *    +2.*psdfh4(zx,qqs,0.,iclpro0,-3))
4975           if(j.gt.0)fz=fz+akns*psdfh4(zx,qqs,0.,iclpro0,-j)
4976 
4977           dpd2=dpd2+a1(i)*fz*(1.-xx/zx)/zx
4978         enddo
4979         enddo
4980         dpd2=dpd2*log((xm-xx)/(xmin-xx))*.5*xx
4981       endif
4982       pspdfg=pspdfg+dpd2+dpd1
4983       return
4984       end
4985 
4986 c-----------------------------------------------------------------------
4987       subroutine psaevp
4988 c-----------------------------------------------------------------------
4989       include 'epos.inc'
4990       include 'epos.incsem'
4991       qq=xpar1
4992       jmod=nint(xpar2)
4993       iologb=1
4994 
4995       if(jmod.eq.0)then            !??????????????ttttttt
4996       write(*,*)"no more triple Pomeron, xpar2=0 in psaevp not accepted"
4997       write(*,*)"use xpar2=1 instead"
4998       jmod=1
4999       endif
5000 
5001       do i=1,nrbins
5002         if(iologb.eq.0)then
5003           xx=xminim+(xmaxim-xminim)*(i-.5)/nrbins
5004         else
5005           xx=xminim*(xmaxim/xminim)**((i-.5)/nrbins)
5006         endif
5007         ar(i,1)=xx
5008         ar(i,2)=0.
5009         if(jmod.eq.0)then            !evolution+matrix element +3P (ours)
5010           ww=qq/xx
5011           ar(i,3)=(psdh(ww,qq,2,0)+psdh(ww,qq,2,1)
5012 c     *    +psdsh1(ww,qq,2,dqsh,0)+psdsh1(ww,qq,2,dqsh,1)
5013      *    )/(4.*pi**2*alfe)*qq
5014         elseif(jmod.eq.1)then        !evolution+matrix element (ours)
5015           ww=qq/xx
5016           ar(i,3)=(psdh(ww,qq,2,0)+psdh(ww,qq,2,1)+
5017      *    psdsh(ww,qq,2,dqsh,0)+psdsh(ww,qq,2,dqsh,1)
5018      *    )/(4.*pi**2*alfe)*qq
5019         elseif(jmod.eq.2)then    !just evolution (grv)
5020           ar(i,3)=(pspdfg(xx,q2min,qq,2,1)/2.25+
5021      *    pspdfg(xx,q2min,qq,2,2)/9.+
5022      *    pspdfg(xx,q2min,qq,2,-1)*2./3.6+
5023      *    pspdfg(xx,q2min,qq,2,-3)*2./9.)
5024           if(naflav.eq.4)ar(i,3)=ar(i,3)+pspdfg(xx,q2min,qq,2,-4)
5025      *    *2./2.25
5026         elseif(jmod.eq.3)then    !grv
5027           ar(i,3)=(psdfh4(xx,qq,0.,2,1)+2.*psdfh4(xx,qq,0.,2,-1))/2.25
5028      *    +(psdfh4(xx,qq,0.,2,2)+2.*psdfh4(xx,qq,0.,2,-2))/9.
5029      *    +2.*psdfh4(xx,qq,0.,2,-3)/9.  !
5030         elseif(jmod.eq.4)then         !just evolution (ours)
5031           ar(i,3)=(fparton(xx,qq,1)/2.25+fparton(xx,qq,2)/9.+
5032      *    fparton(xx,qq,-1)*6./4.5)                     !uv+dv+6*sea
5033           if(naflav.eq.4)ar(i,3)=ar(i,3)+fparton(xx,qq,-4)*2./2.25
5034         elseif(jmod.eq.5)then         !grv+res
5035           ww=qq/xx
5036           ar(i,3)=(psdgh(ww,qq,0)+psdgh(ww,qq,1)
5037      *    )/(4.*pi**2*alfe)*qq
5038         endif
5039         ar(i,4)=0.
5040       enddo
5041       return
5042       end
5043 
5044 c------------------------------------------------------------------------
5045       subroutine pscs(c,s)
5046 c-----------------------------------------------------------------------
5047 c pscs - cos (c) and sin (s) generation for uniformly distributed angle
5048 c-----------------------------------------------------------------------
5049 1     s1=2.*rangen()-1.
5050       s2=2.*rangen()-1.
5051       s3=s1*s1+s2*s2
5052       if(s3.gt.1.)goto 1
5053       s3=sqrt(s3)
5054       c=s1/s3
5055       s=s2/s3
5056       return
5057       end
5058 
5059 c------------------------------------------------------------------------
5060       subroutine psdefrot(ep,s0x,c0x,s0,c0)
5061 c-----------------------------------------------------------------------
5062 c psdefrot - determination of the parameters the spacial rotation to the
5063 c system for 4-vector ep
5064 c s0, c0 - sin and cos for the zx-rotation;
5065 c s0x, c0x - sin and cos for the xy-rotation
5066 c-----------------------------------------------------------------------
5067       dimension ep(4)
5068 
5069 c transverse momentum square for the current parton (ep)
5070       pt2=ep(3)**2+ep(4)**2
5071       if(pt2.ne.0.)then
5072         pt=sqrt(pt2)
5073 c system rotation to get pt=0 - euler angles are determined (c0x = cos t
5074 c s0x = sin theta, c0 = cos phi, s0 = sin phi)
5075         c0x=ep(3)/pt
5076         s0x=ep(4)/pt
5077 c total momentum for the gluon
5078         pl=sqrt(pt2+ep(2)**2)
5079         s0=pt/pl
5080         c0=ep(2)/pl
5081       else
5082         c0x=1.
5083         s0x=0.
5084         pl=abs(ep(2))
5085         s0=0.
5086         c0=ep(2)/pl
5087       endif
5088 
5089       ep(2)=pl
5090       ep(3)=0.
5091       ep(4)=0.
5092       return
5093       end
5094 
5095 c------------------------------------------------------------------------
5096       subroutine psdeftr(s,ep,ey)
5097 c-----------------------------------------------------------------------
5098 c psdeftr - determination of the parameters for the lorentz transform to
5099 c rest frame system for 4-vector ep of mass squared s
5100 c-----------------------------------------------------------------------
5101       dimension ey(3)
5102       double precision ep(4)
5103 
5104       do i=1,3
5105         if(ep(i+1).eq.0.d0)then
5106           ey(i)=1.
5107         else
5108           wp=ep(1)+ep(i+1)
5109           wm=ep(1)-ep(i+1)
5110           if(wp.gt.1.e-8.and.wm/wp.lt.1.e-8)then
5111             ww=s
5112             do l=1,3
5113               if(l.ne.i)ww=ww+ep(l+1)**2
5114             enddo
5115             wm=ww/wp
5116           elseif(wm.gt.1.e-8.and.wp/wm.lt.1.e-8)then
5117             ww=s
5118             do l=1,3
5119               if(l.ne.i)ww=ww+ep(l+1)**2
5120             enddo
5121             wp=ww/wm
5122           endif
5123           ey(i)=sqrt(wm/wp)
5124           ep(1)=wp*ey(i)
5125           ep(i+1)=0.
5126         endif
5127       enddo
5128       ep(1)=dsqrt(dble(s))
5129       return
5130       end
5131 
5132 c------------------------------------------------------------------------
5133       function psdfh4(xxx,qqs,qq,icq,iq)
5134 c------------------------------------------------------------------------
5135 c psdfh4 - GRV structure functions
5136 c------------------------------------------------------------------------
5137       common /psar8/  stmass ,amhadr(8),qcmass
5138       common /psar36/ alvc
5139 
5140       psdfh4=0.
5141 !      if(x.gt..99999)return
5142       x=min(xxx,0.99999)              !warning ! but necessary for idraflx
5143 
5144       if(icq.eq.2)then
5145         if(qqs.le.0.232**2)return
5146         sq=log(log(qqs/.232**2)/log(.23/.232**2))
5147         if(sq.le.0.)return
5148         if(iq.eq.0)then                                 !gluon
5149           alg=.524
5150           betg=1.088
5151           aag=1.742-.93*sq
5152           bbg=-.399*sq**2
5153           ag=7.486-2.185*sq
5154           bg=16.69-22.74*sq+5.779*sq*sq
5155           cg=-25.59+29.71*sq-7.296*sq*sq
5156           dg=2.792+2.215*sq+.422*sq*sq-.104*sq*sq*sq
5157           eg=.807+2.005*sq
5158           eeg=3.841+.361*sq
5159           psdfh4=(1.-x)**dg*(x**aag*(ag+bg*x+cg*x**2)*log(1./x)**bbg
5160      *    +sq**alg*exp(-eg+sqrt(eeg*sq**betg*log(1./x))))
5161         elseif(iq.eq.1.or.iq.eq.2)then                  !u_v or d_v
5162           aau=.59-.024*sq
5163           bbu=.131+.063*sq
5164           auu=2.284+.802*sq+.055*sq*sq
5165           au=-.449-.138*sq-.076*sq*sq
5166           bu=.213+2.669*sq-.728*sq*sq
5167           cu=8.854-9.135*sq+1.979*sq*sq
5168           du=2.997+.753*sq-.076*sq*sq
5169           uv=auu*x**aau*(1.-x)**du*
5170      *    (1.+au*x**bbu+bu*x+cu*x**1.5)
5171 
5172           aad=.376
5173           bbd=.486+.062*sq
5174           add=.371+.083*sq+.039*sq*sq
5175           ad=-.509+3.31*sq-1.248*sq*sq
5176           bd=12.41-10.52*sq+2.267*sq*sq
5177           ccd=6.373-6.208*sq+1.418*sq*sq
5178           dd=3.691+.799*sq-.071*sq*sq
5179           dv=add*x**aad*(1.-x)**dd*
5180      *    (1.+ad*x**bbd+bd*x+ccd*x**1.5)
5181 
5182           if(iq.eq.1)then                              !u_v
5183             psdfh4=uv
5184           elseif(iq.eq.2)then                          !d_v
5185             psdfh4=dv
5186           endif
5187         elseif(iq.eq.-3)then                           !s_sea
5188           als=.914
5189           bets=.577
5190           aas=1.798-.596*sq
5191           as=-5.548+3.669*sqrt(sq)-.616*sq
5192           bs=18.92-16.73*sqrt(sq)+5.168*sq
5193           ds=6.379-.35*sq+.142*sq*sq
5194           es=3.981+1.638*sq
5195           ees=6.402
5196           psdfh4=(1.-x)**ds*sq**als/log(1./x)**aas*(1.+as*sqrt(x)
5197      *    +bs*x)*exp(-es+sqrt(ees*sq**bets*log(1./x)))
5198         elseif(iabs(iq).lt.3)then                      !u_sea or d_sea
5199           aadel=.409-.005*sq
5200           bbdel=.799+.071*sq
5201           addel=.082+.014*sq+.008*sq*sq
5202           adel=-38.07+36.13*sq-.656*sq*sq
5203           bdel=90.31-74.15*sq+7.645*sq*sq
5204           ccdel=0.
5205           ddel=7.486+1.217*sq-.159*sq*sq
5206           delv=addel*x**aadel*(1.-x)**ddel*
5207      *    (1.+adel*x**bbdel+bdel*x+ccdel*x**1.5)
5208 
5209           alud=1.451
5210           betud=.271
5211           aaud=.41-.232*sq
5212           bbud=.534-.457*sq
5213           aud=.89-.14*sq
5214           bud=-.981
5215           cud=.32+.683*sq
5216           dud=4.752+1.164*sq+.286*sq*sq
5217           eud=4.119+1.713*sq
5218           eeud=.682+2.978*sq
5219           udsea=(1.-x)**dud*(x**aaud*(aud+bud*x+cud*x**2)
5220      *    *log(1./x)**bbud+sq**alud*exp(-eud+sqrt(eeud*sq**betud*
5221      *    log(1./x))))
5222 
5223           if(iq.eq.-1)then                           !u_sea
5224             psdfh4=(udsea-delv)/2.
5225           elseif(iq.eq.-2)then                       !d_sea
5226             psdfh4=(udsea+delv)/2.
5227           endif
5228         else
5229           psdfh4=0.
5230         endif
5231       elseif(icq.eq.1.or.icq.eq.3)then
5232         if(qqs.le.0.204**2)return
5233         sq=log(log(qqs/.204**2)/log(.26/.204**2))
5234         if(sq.le.0.)return
5235         if(iq.eq.1.or.iq.eq.2)then
5236           aapi=.517-.02*sq
5237           api=-.037-.578*sq
5238           bpi=.241+.251*sq
5239           dpi=.383+.624*sq
5240           anorm=1.212+.498*sq+.009*sq**2
5241           psdfh4=.5*anorm*x**aapi*(1.-x)**dpi*
5242      *    (1.+api*sqrt(x)+bpi*x)
5243         elseif(iq.eq.0)then
5244           alfpi=.504
5245           betpi=.226
5246           aapi=2.251-1.339*sqrt(sq)
5247           api=2.668-1.265*sq+.156*sq**2
5248           bbpi=0.
5249           bpi=-1.839+.386*sq
5250           cpi=-1.014+.92*sq-.101*sq**2
5251           dpi=-.077+1.466*sq
5252           epi=1.245+1.833*sq
5253           eppi=.51+3.844*sq
5254           psdfh4=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
5255      *    log(1./x)**bbpi+sq**alfpi*
5256      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
5257         elseif(iq.eq.-3)then
5258           alfpi=.823
5259           betpi=.65
5260           aapi=1.036-.709*sq
5261           api=-1.245+.713*sq
5262           bpi=5.58-1.281*sq
5263           dpi=2.746-.191*sq
5264           epi=5.101+1.294*sq
5265           eppi=4.854-.437*sq
5266           psdfh4=sq**alfpi/log(1./x)**aapi*(1.-x)**dpi*
5267      *    (1.+api*sqrt(x)+bpi*x)*
5268      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x)))
5269         elseif(iabs(iq).lt.3)then
5270           alfpi=1.147
5271           betpi=1.241
5272           aapi=.309-.134*sqrt(sq)
5273           api=.219-.054*sq
5274           bbpi=.893-.264*sqrt(sq)
5275           bpi=-.593+.24*sq
5276           cpi=1.1-.452*sq
5277           dpi=3.526+.491*sq
5278           epi=4.521+1.583*sq
5279           eppi=3.102
5280           psdfh4=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
5281      *    log(1./x)**bbpi+sq**alfpi*
5282      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
5283         else
5284           psdfh4=0.
5285         endif
5286       elseif(icq.eq.0)then
5287         if(qqs.le.0.204**2)return
5288         sq=log(log(qqs/.204**2)/log(.26/.204**2))
5289         if(sq.le.0.)return
5290         if(iq.eq.0)then
5291           alfpi=.504
5292           betpi=.226
5293           aapi=2.251-1.339*sqrt(sq)
5294           api=2.668-1.265*sq+.156*sq**2
5295           bbpi=0.
5296           bpi=-1.839+.386*sq
5297           cpi=-1.014+.92*sq-.101*sq**2
5298           dpi=-.077+1.466*sq
5299           epi=1.245+1.833*sq
5300           eppi=.51+3.844*sq
5301           psdfh4=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
5302      *    log(1./x)**bbpi+sq**alfpi*
5303      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
5304      *    *.543
5305         else
5306           alfpi=.823
5307           betpi=.65
5308           aapi=1.036-.709*sq
5309           api=-1.245+.713*sq
5310           bpi=5.58-1.281*sq
5311           dpi=2.746-.191*sq
5312           epi=5.101+1.294*sq
5313           eppi=4.854-.437*sq
5314           str=sq**alfpi/log(1./x)**aapi*(1.-x)**dpi*
5315      *    (1.+api*sqrt(x)+bpi*x)*
5316      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x)))
5317           if(iq.eq.3)then
5318             psdfh4=str*.543*2.
5319           else
5320             aapi=.517-.02*sq
5321             api=-.037-.578*sq
5322             bpi=.241+.251*sq
5323             dpi=.383+.624*sq
5324             anorm=1.212+.498*sq+.009*sq**2
5325             val=.5*anorm*x**aapi*(1.-x)**dpi*
5326      *      (1.+api*sqrt(x)+bpi*x)
5327 
5328             alfpi=1.147
5329             betpi=1.241
5330             aapi=.309-.134*sqrt(sq)
5331             api=.219-.054*sq
5332             bbpi=.893-.264*sqrt(sq)
5333             bpi=-.593+.24*sq
5334             cpi=1.1-.452*sq
5335             dpi=3.526+.491*sq
5336             epi=4.521+1.583*sq
5337             eppi=3.102
5338             sea=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
5339      *      log(1./x)**bbpi+sq**alfpi*
5340      *      exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
5341             if(iq.eq.1)then
5342               psdfh4=(.836*(val+2.*sea)-.587*str)
5343             elseif(iq.eq.2)then
5344               psdfh4=(.25*(val+2.*sea)+.587*str)
5345             else
5346               psdfh4=0.
5347             endif
5348           endif
5349         endif
5350         psdfh4=psdfh4/(1.+qq/.59)**2
5351 
5352       elseif(icq.eq.4)then
5353         if(qqs.le.qcmass**2)return
5354         sq=log(log(qqs/qcmass**2)/log(.23/qcmass**2))
5355         if(sq.le.0.)return
5356         if(iq.eq.2)then
5357           psdfh4=x**3*(1.-x)**alvc*(alvc+3.)*(alvc+2.)*(alvc+1.)
5358         else
5359           aapi=.517-.02*sq
5360           api=-.037-.578*sq
5361           bpi=.241+.251*sq
5362           dpi=.383+.624*sq
5363           anorm=1.212+.498*sq+.009*sq**2
5364           psdfh4=.5*anorm*x**aapi*(1.-x)**dpi*
5365      *    (1.+api*sqrt(x)+bpi*x)
5366         endif
5367       else
5368         psdfh4=0.
5369       endif
5370       return
5371       end
5372 
5373 
5374 c------------------------------------------------------------------------
5375       function psfap(x,j,l)
5376 c-----------------------------------------------------------------------
5377 c psfap - altarelli-parisi function (multiplied by x)
5378 c x - light cone momentum share value,
5379 c j - type of the parent parton (0-g;1,2,etc.-q)
5380 c l - type of the daughter parton (0-g;1,2,etc.-q)
5381 c-----------------------------------------------------------------------
5382       double precision x
5383       include 'epos.incsem'
5384 
5385       if(j.eq.0)then
5386         if(l.eq.0)then
5387           psfap=((1.d0-x)/x+x/(1.d0-x)+x*(1.d0-x))*6.d0
5388         else
5389           psfap=(x**2+(1.d0-x)**2)*naflav
5390         endif
5391       else
5392         if(l.eq.0)then
5393           psfap=(1.d0+(1.d0-x)**2)/x/.75d0
5394         else
5395           psfap=(x**2+1.d0)/(1.d0-x)/.75d0
5396         endif
5397       endif
5398       return
5399       end
5400 
5401 cc------------------------------------------------------------------------
5402 c      function psgen(a1,a2)
5403 cc-----------------------------------------------------------------------
5404 cc psgen - x-values generation according to distribution
5405 cc x1^(-a1) x2^(-0.5)
5406 cc-----------------------------------------------------------------------
5407 c      common/lept1/engy,elepti,elepto,angmue,icinpu
5408 c
5409 c      aa=max(a1,a2)
5410 c1     continue
5411 c      if(aa.lt.1.)then
5412 c        x1=.5*rangen()**(1./(1.-aa))
5413 c      elseif(aa.eq.1.)then
5414 c        x1=.5/engy**rangen()
5415 c      else
5416 c        x1=.5*(1.+rangen()*(engy**(aa-1.)-1.))**(1./(1.-aa))
5417 c      endif
5418 c      if(x1.lt.1.e-7.or.x1.gt..999999)then
5419 c        goto 1
5420 c      endif
5421 c      if(rangen().lt..5)then
5422 c        gb=x1**(aa-a1)*.5**aa/(1.-x1)**a2
5423 c      else
5424 c        x1=1.-x1
5425 c        gb=(1.-x1)**(aa-a2)*.5**aa/x1**a1
5426 c      endif
5427 c      if(rangen().gt.gb)goto 1
5428 c      psgen=x1
5429 c      return
5430 c      end
5431 c
5432 c------------------------------------------------------------------------
5433       function psidd(icc)
5434 c-----------------------------------------------------------------------
5435 c psidd - kink type decoder
5436 c-----------------------------------------------------------------------
5437       if(icc.eq.0)then                    !g
5438         psidd=9
5439       elseif(iabs(icc).le.2)then          !u,u~,d,d~
5440         psidd=icc
5441       elseif(iabs(icc).eq.4)then          !s,s~
5442         psidd=icc/4*3
5443       elseif(iabs(icc).gt.10)then         !c,c~ etc.
5444         psidd=icc/10
5445       elseif(icc.eq.3)then                !ud
5446         psidd=1200
5447       elseif(icc.eq.-3)then               !u~d~
5448         psidd=-1200
5449       elseif(icc.eq.6)then                !uu
5450         psidd=1100
5451       elseif(icc.eq.-6)then               !u~u~
5452         psidd=-1100
5453       elseif(icc.eq.7)then                !dd
5454         psidd=2200
5455       elseif(icc.eq.-7)then               !d~d~
5456         psidd=-2200
5457       else
5458         psidd=0.
5459         write (*,*)'psidd?????????',icc
5460       endif
5461       return
5462       end
5463 
5464 cc------------------------------------------------------------------------
5465 c       function pslam(s,a,b)
5466 cc-----------------------------------------------------------------------
5467 cc kinematical function for two particle decay - maximal pt-value
5468 cc a - first particle mass squared,
5469 cc b - second particle mass squared,
5470 cc s - two particle invariant mass squared
5471 cc-----------------------------------------------------------------------
5472 c       pslam=.25/s*(s+a-b)**2-a
5473 c       return
5474 c       end
5475 c
5476 c------------------------------------------------------------------------
5477       function psjvrg1(qt,s,y0)
5478 c-----------------------------------------------------------------------
5479       common /ar3/   x1(7),a1(7)
5480       common /cnsta/ pi,pii,hquer,prom,piom,ainfin
5481       include 'epos.incsem'
5482       double precision xt,ymin,ymax,y,xmin,xmax,xx1,xx2
5483 
5484       psjvrg1=0.
5485       if(s.le.4.*qt)return
5486 
5487       xt=2.d0*sqrt(dble(qt)/dble(s))
5488       ymax=min(dble(y0),log(1d0/xt+sqrt((1d0/xt-1d0)*(1d0/xt+1d0))))
5489       ymin=-ymax
5490 
5491       do i=1,7
5492       do m=1,2
5493         y=.5d0*(ymax+ymin+(ymin-ymax)*dble((2*m-3)*x1(i)))
5494         xmin=xt**2/2.d0/(2.d0-xt*exp(-y))
5495         xmax=1.d0-xt*exp(y)/2.d0
5496 
5497         fx=0.
5498         do i1=1,7
5499         do m1=1,2
5500           xx1=xt*exp(y)/2d0+xmin*(xmax/xmin)**dble(.5+x1(i1)*(m1-1.5))
5501           xx2=xt*exp(-y)*xx1/(2.d0*xx1-xt*exp(y))
5502           z=sngl(xx1*xx2)
5503           sh=z*s
5504           t=sngl(dble(sh)/2d0*(1d0
5505      &                      -sqrt(max(0d0,1d0-4d0*dble(qt)/dble(sh)))))
5506           ft=psjvrx(t,qt,sngl(xx1),sngl(xx2),sh)
5507           fx=fx+a1(i1)*ft/sh**2
5508         enddo
5509         enddo
5510         fx=fx*sngl(log(xmax/xmin))
5511         psjvrg1=psjvrg1+a1(i)*fx
5512       enddo
5513       enddo
5514       psjvrg1=psjvrg1*sngl(ymax-ymin)*pi**3
5515      **pssalf(qt/qcdlam)**2*sqrt(qt)
5516       return
5517       end
5518 
5519 c-----------------------------------------------------------------------
5520       function psjvrx(t,qt,xx1,xx2,s)
5521 c-----------------------------------------------------------------------
5522       include 'epos.incsem'
5523 
5524       g1=psdfh4(xx1,qt,0.,2,0)
5525       ub1=psdfh4(xx1,qt,0.,2,-1)
5526       u1=psdfh4(xx1,qt,0.,2,1)+ub1
5527       db1=psdfh4(xx1,qt,0.,2,-2)
5528       d1=psdfh4(xx1,qt,0.,2,2)+db1
5529       sb1=psdfh4(xx1,qt,0.,2,-3)
5530       s1=sb1
5531       g2=psdfh4(xx2,qt,0.,2,0)
5532       ub2=psdfh4(xx2,qt,0.,2,-1)
5533       u2=psdfh4(xx2,qt,0.,2,1)+ub2
5534       db2=psdfh4(xx2,qt,0.,2,-2)
5535       d2=psdfh4(xx2,qt,0.,2,2)+db2
5536       sb2=psdfh4(xx2,qt,0.,2,-3)
5537       s2=sb2
5538 
5539       psjvrx=g1*g2*(psbori(s,t,0,0,1)+psbori(s,s-t,0,0,1)
5540      *+psbori(s,t,0,0,2)+psbori(s,s-t,0,0,2))/2.
5541      *+(psbori(s,t,0,1,1)+psbori(s,s-t,0,1,1))*
5542      *(g2*(u1+ub1+d1+db1+s1+sb1)+g1*(u2+ub2+d2+db2+s2+sb2))
5543      *+(psbori(s,t,1,1,1)+psbori(s,s-t,1,1,1))/2.*
5544      *(u1*u2+ub1*ub2+d1*d2+db1*db2+s1*s2+sb1*sb2)
5545      *+(psbori(s,t,1,-1,1)+psbori(s,s-t,1,-1,1)+psbori(s,t,1,-1,2)+
5546      *psbori(s,s-t,1,-1,2)+psbori(s,t,1,-1,3)+psbori(s,s-t,1,-1,3))*
5547      *(u1*ub2+ub1*u2+d1*db2+db1*d2+s1*sb2+sb1*s2)
5548      *+(psbori(s,t,1,2,1)+psbori(s,s-t,1,2,1))*
5549      *((u1+ub1)*(d2+db2+s2+sb2)+(u2+ub2)*(d1+db1+s1+sb1)+
5550      *(d1+db1)*(u2+ub2+s2+sb2)+(d2+db2)*(u1+ub1+s1+sb1)+
5551      *(s1+sb1)*(u2+ub2+d2+db2)+(s2+sb2)*(u1+ub1+d1+db1))
5552       return
5553       end
5554 
5555 c------------------------------------------------------------------------
5556       function psjwo1(qt,s,y0)
5557 c-----------------------------------------------------------------------
5558       common /ar3/   x1(7),a1(7)
5559       common /cnsta/ pi,pii,hquer,prom,piom,ainfin
5560       double precision xt,ymax,ymin,y,xmin,xmax,xx1,xx2
5561       include 'epos.incsem'
5562 
5563       psjwo1=0.
5564       if(s.le.4.*qt)return
5565 
5566       xt=2.d0*sqrt(dble(qt)/dble(s))
5567       ymax=min(dble(y0),log(1d0/xt+sqrt((1d0/xt-1d0)*(1d0/xt+1d0))))
5568       ymin=-ymax
5569 
5570       do i=1,7
5571       do m=1,2
5572         y=.5d0*(ymax+ymin+(ymin-ymax)*dble(2*m-3)*dble(x1(i)))
5573         xmin=xt**2/2.d0/(2.d0-xt*exp(-y))
5574         xmax=1.d0-xt*exp(y)/2.d0
5575 
5576         fx=0.
5577         do i1=1,7
5578         do m1=1,2
5579           xx1=xt*exp(y)/2.d0+xmin*(xmax/xmin)**dble(.5+x1(i1)*(m1-1.5))
5580           xx2=xt*exp(-y)/(2.d0-xt*exp(y)/xx1)
5581           z=sngl(xx1*xx2)
5582           sh=z*s
5583           t=sngl(dble(sh)/2d0*(1d0-sqrt(1d0-4d0*dble(qt)/dble(sh))))
5584           ft=psjwox(t,qt,sngl(xx1),sngl(xx2),sh)
5585           fx=fx+a1(i1)*ft/sh**2
5586         enddo
5587         enddo
5588         fx=fx*log(xmax/xmin)
5589         psjwo1=psjwo1+a1(i)*fx
5590       enddo
5591       enddo
5592       psjwo1=psjwo1*sngl(ymax-ymin)*pi**3
5593      **pssalf(qt/qcdlam)**2*sqrt(qt)
5594       return
5595       end
5596 
5597 c-----------------------------------------------------------------------
5598       function psjwox(t,qt,xx1,xx2,s)
5599 c-----------------------------------------------------------------------
5600       double precision x,scale,upv1,dnv1,sea1,str1,chm1,gl1,
5601      *upv2,dnv2,sea2,str2,chm2,gl2
5602       scale=sqrt(qt)
5603       x=xx1
5604       call strdo1(x,scale,upv1,dnv1,sea1,str1,chm1,gl1)
5605       x=xx2
5606       call strdo1(x,scale,upv2,dnv2,sea2,str2,chm2,gl2)
5607 
5608       psjwox=gl1*gl2*(psbori(s,t,0,0,1)+psbori(s,s-t,0,0,1)
5609      *+psbori(s,t,0,0,2)+psbori(s,s-t,0,0,2)+psbori(s,t,0,0,3)
5610      *+psbori(s,s-t,0,0,3))/2.
5611      *+(psbori(s,t,0,1,1)+psbori(s,s-t,0,1,1)
5612      *+psbori(s,t,0,1,2)+psbori(s,s-t,0,1,2)+psbori(s,t,0,1,3)
5613      *+psbori(s,s-t,0,1,3))*(gl2*(upv1+dnv1+4.*sea1+2.*str1+2.*chm1)+
5614      *gl1*(upv2+dnv2+4.*sea2+2.*str2+2.*chm2))
5615      *+(psbori(s,t,1,1,1)+psbori(s,s-t,1,1,1)
5616      *+psbori(s,t,1,1,2)+psbori(s,s-t,1,1,2)+psbori(s,t,1,1,3)+
5617      *psbori(s,s-t,1,1,3))/2.*
5618      *((upv1+sea1)*(upv2+sea2)+(dnv1+sea1)*(dnv2+sea2)+2.*sea1*sea2
5619      *+2.*str1*str2+2.*chm1*chm2)
5620      *+(psbori(s,t,1,-1,1)+psbori(s,s-t,1,-1,1)+psbori(s,t,1,-1,2)+
5621      *psbori(s,s-t,1,-1,2)+psbori(s,t,1,-1,3)+psbori(s,s-t,1,-1,3))*
5622      *((upv1+sea1)*sea2+sea1*(upv2+sea2)+(dnv1+sea1)*sea2+
5623      *sea1*(dnv2+sea2)+2.*str1*str2+2.*chm1*chm2)
5624      *+(psbori(s,t,1,2,1)
5625      *+psbori(s,s-t,1,2,1)+psbori(s,t,1,2,2)+psbori(s,s-t,1,2,2)
5626      *+psbori(s,t,1,2,3)+psbori(s,s-t,1,2,3))*
5627      *(upv1*dnv2+upv2*dnv1+(upv1+dnv1)*(2.*sea2+2.*str2+2.*chm2)+
5628      *(upv2+dnv2)*(2.*sea1+2.*str1+2.*chm1)+
5629      *4.*sea1*(2.*sea2+2.*str2+2.*chm2)+2.*str1*(4.*sea2+2.*chm2)+
5630      *2.*chm1*(4.*sea2+2.*str2))
5631       return
5632       end
5633 
5634 c------------------------------------------------------------------------
5635       subroutine pslcsh(wp1,wm1,wp2,wm2,samqt,amqpt)
5636 c-----------------------------------------------------------------------
5637 c pslcsh - sh pomeron lc momentum sharing between two strings
5638 c------------------------------------------------------------------------
5639       double precision amqt(4),yqm(4),yqm1(4),xlp(4),xlm(4),am23,sx,y2
5640      *,wp1,wp2,wm1,wm2,s,sq,psutz,yqmax,y,amjp,amjm,y1,s12,s34,x34,amqpt
5641       dimension samqt(4)
5642       include 'epos.inc'
5643 
5644       s=wp1*wm1
5645       sq=dsqrt(s)
5646       do i=1,4
5647         amqt(i)=dble(samqt(i))
5648         yqm(i)=dlog(sq/amqt(i)*psutz(s,amqt(i)**2,(amqpt-amqt(i))**2))
5649       enddo
5650       yqmax=max(yqm(1),yqm(2))
5651 
5652 1     y=yqmax*dble(rangen())
5653       j=int(1.5+rangen())
5654       if(y.gt.yqm(j))goto 1
5655 
5656       amjp=amqt(j)*dexp(y)
5657       amjm=amqt(j)*dexp(-y)
5658       do i=3,4
5659         am23=amqt(3-j)+amqt(7-i)
5660         sx=(am23+amjp)*(am23+amjm)
5661         yqm1(i)=dlog(sq/amqt(i)*psutz(s,amqt(i)**2,sx))
5662       enddo
5663       yqmax1=max(yqm1(3),yqm1(4))
5664       if(dble(rangen()).gt.yqmax1/max(yqm(3),yqm(4)))goto 1
5665 
5666       y1=yqmax1*dble(rangen())
5667       j1=int(3.5+rangen())
5668       if(y1.gt.yqm1(j1))goto 1
5669 
5670       amjp1=amqt(j1)*exp(y1)
5671       amjm1=amqt(j1)*exp(-y1)
5672       s12=(amqt(3-j)+amjp)*(amqt(3-j)+amjm)
5673       s34=(amqt(7-j1)+amjp1)*(amqt(7-j1)+amjm1)
5674       y2=dlog(sq/(amqt(3-j)+amjp)*psutz(s,s12,s34))
5675 
5676       xlp(j)=amqt(j)/sq*dexp(y+y2)
5677       xlm(j)=amqt(j)/sq*dexp(-y-y2)
5678       xlp(3-j)=amqt(3-j)/sq*dexp(y2)
5679       xlm(3-j)=amqt(3-j)/sq*dexp(-y2)
5680       x34=1.-xlm(1)-xlm(2)
5681       xlm(7-j1)=x34/(1.+amjp1/amqt(7-j1))
5682       xlm(j1)=x34-xlm(7-j1)
5683 c      write (*,*)'xlc',xlp(1),xlp(2),xlm(3),xlm(4)
5684       if(dble(rangen()).gt.(xlp(1)*xlp(2)*xlm(3)*xlm(4))**(-alpqua)*
5685      *(xlp(j)*(1.d0-xlp(j))*xlm(j1)*(1.d0-xlm(j1))))goto 1
5686 
5687       wp2=xlp(2)*wp1
5688       wp1=xlp(1)*wp1
5689       wm2=xlm(4)*wm1
5690       wm1=xlm(3)*wm1
5691 c      write (*,*)'wp1,wm1,wp2,wm2',wp1,wm1,wp2,wm2
5692       return
5693       end
5694 
5695 c------------------------------------------------------------------------
5696       function psnorm(ep)
5697 c-----------------------------------------------------------------------
5698 c 4-vector squared calculation
5699 c-----------------------------------------------------------------------
5700       double precision sm2,ep(4)
5701       sm2=ep(1)**2
5702       do i=1,3
5703         sm2=sm2-ep(i+1)**2
5704       enddo
5705       psnorm=sm2
5706       return
5707       end
5708 
5709 c------------------------------------------------------------------------
5710       subroutine psrotat(ep,s0x,c0x,s0,c0)
5711 c-----------------------------------------------------------------------
5712 c psrotat - spacial rotation to the lab. system for 4-vector ep
5713 c s0, c0 - sin and cos for the zx-rotation;
5714 c s0x, c0x - sin and cos for the xy-rotation
5715 c-----------------------------------------------------------------------
5716       dimension ep(4),ep1(3)
5717 
5718       ep1(3)=ep(4)
5719       ep1(2)=ep(2)*s0+ep(3)*c0
5720       ep1(1)=ep(2)*c0-ep(3)*s0
5721 
5722       ep(2)=ep1(1)
5723       ep(4)=ep1(2)*s0x+ep1(3)*c0x
5724       ep(3)=ep1(2)*c0x-ep1(3)*s0x
5725       return
5726       end
5727 
5728 cc------------------------------------------------------------------------
5729 c      subroutine psrotat1(ep,s0x,c0x,s0,c0)
5730 cc-----------------------------------------------------------------------
5731 cc psrotat - spacial rotation to the lab. system for 4-vector ep
5732 cc s0, c0 - sin and cos for the zx-rotation;
5733 cc s0x, c0x - sin and cos for the xy-rotation
5734 cc-----------------------------------------------------------------------
5735 c      dimension ep(4),ep1(3)
5736 c
5737 c      ep1(1)=ep(2)
5738 c      ep1(3)=-ep(3)*s0x+ep(4)*c0x
5739 c      ep1(2)=ep(3)*c0x+ep(4)*s0x
5740 c
5741 c      ep(4)=ep1(3)
5742 c      ep(3)=-ep1(1)*s0+ep1(2)*c0
5743 c      ep(2)=ep1(1)*c0+ep1(2)*s0
5744 c      return
5745 c      end
5746 c
5747 c-----------------------------------------------------------------------
5748       function pssalf(qq)
5749 c-----------------------------------------------------------------------
5750 c pssalf - effective qcd coupling (alpha_s/2/pi)
5751 c-----------------------------------------------------------------------
5752       include "epos.incsem"
5753       pssalf=2./(11.-naflav/1.5)/log(qq)
5754       return
5755       end
5756 
5757 c------------------------------------------------------------------------
5758       subroutine pstrans(ep,ey,jj)
5759 c-----------------------------------------------------------------------
5760 c pstrans - lorentz boosts according to the parameters ey ( determining
5761 c shift along the z,x,y-axis respectively (ey(1),ey(2),ey(3)))
5762 c jj=1 - inverse transformation to the lab. system;
5763 c jj=-1 - direct transformation
5764 c-----------------------------------------------------------------------
5765       dimension ey(3),ep(4)
5766 
5767       if(jj.eq.1)then
5768 c lorentz transform to lab. system according to 1/ey(i) parameters
5769         do i=1,3
5770           if(ey(4-i).ne.1.)then
5771             wp=(ep(1)+ep(5-i))/ey(4-i)
5772             wm=(ep(1)-ep(5-i))*ey(4-i)
5773             ep(1)=.5*(wp+wm)
5774             ep(5-i)=.5*(wp-wm)
5775           endif
5776         enddo
5777       else
5778 c lorentz transform to lab. system according to ey(i) parameters
5779         do i=1,3
5780           if(ey(i).ne.1.)then
5781             wp=(ep(1)+ep(i+1))*ey(i)
5782             wm=(ep(1)-ep(i+1))/ey(i)
5783             ep(1)=.5*(wp+wm)
5784             ep(i+1)=.5*(wp-wm)
5785           endif
5786         enddo
5787       endif
5788       return
5789       end
5790 
5791 c------------------------------------------------------------------------
5792       double precision function psuds(q,m)
5793 c-----------------------------------------------------------------------
5794 c psuds - spacelike sudakov formfactor
5795 c q - maximal value of the effective momentum,
5796 c m - type of parton (0 - g, 1,2, etc. - q)
5797 c-----------------------------------------------------------------------
5798       dimension wi(3)
5799       common /psar15/ sudx(40,2)
5800       include 'epos.incsem'
5801       double precision dps,qlm,ffacs,qlm0,qlmi
5802 
5803       j=min(iabs(m),1)+1
5804 
5805       if(q.gt.q2ini)then
5806         qli=log(q/q2min)*2.+1.
5807         i=int(qli)
5808         if(i.lt.1)i=1
5809         if(i.gt.38)i=38
5810         wi(2)=qli-i
5811         wi(3)=wi(2)*(wi(2)-1.)*.5
5812         wi(1)=1.-wi(2)+wi(3)
5813         wi(2)=wi(2)-2.*wi(3)
5814         dps=0.d0
5815         do i1=1,3
5816           dps=dps+dble(sudx(i+i1-1,j)*wi(i1))
5817         enddo
5818 
5819         qlm0=dble(log(q2ini/qcdlam))
5820         qlm=dble(log(q/qcdlam))
5821         qlmi=qlm-qlm0         !=log(q/q2ini)
5822         psuds=(qlm*log(qlm/qlm0)-qlmi)
5823 
5824         ffacs=(11.d0-dble(naflav)/1.5d0)/12.d0
5825         if(j.eq.1)then
5826           psuds=(psuds-ffacs*log(qlm/qlm0)
5827      *    +dps*(1.d0-dble(q2ini/q)))/ffacs
5828         else
5829           psuds=(psuds-log(qlm/qlm0)*.75d0
5830      *    +dps*(1.d0-dble(q2ini/q)))*4.d0/9.d0/ffacs
5831         endif
5832         psuds=exp(-psuds)
5833       else
5834         psuds=1.d0
5835       endif
5836       return
5837       end
5838 
5839 c------------------------------------------------------------------------
5840       function psudx(q,j)
5841 c-----------------------------------------------------------------------
5842 c psudx - part of the bspacelike sudakov formfactor
5843 c q - maximal value of the effective momentum,
5844 c j - type of parton (1 - g, 2 - q)
5845 c-----------------------------------------------------------------------
5846       common /ar3/    x1(7),a1(7)
5847       include 'epos.incsem'
5848 
5849       psudx=0.
5850 
5851       do i=1,7
5852       do m=1,2
5853         qt=.5*(q2ini+q-x1(i)*(2.*m-3.)*(q2ini-q))
5854         if(j.eq.1)then
5855           zm=1.-qt/q
5856           dps=((11.-naflav/1.5)/12.-zm**2*(1.-naflav/12.)+
5857      *    (zm**3/3.-zm**4/4.)*(1.-naflav/3.))*q/qt
5858         else
5859           dps=(1.-qt/q/4.)
5860         endif
5861         psudx=psudx+a1(i)*dps/log(qt/qcdlam)
5862       enddo
5863       enddo
5864       psudx=psudx*.5
5865       return
5866       end
5867 
5868 c------------------------------------------------------------------------
5869       double precision function psutz(s,a,b)
5870 c-----------------------------------------------------------------------
5871 c psutz - kinematical function for two particle decay - light cone momen
5872 c share for the particle of mass squared a,
5873 c b - partner's mass squared,
5874 c s - two particle invariant mass
5875 c-----------------------------------------------------------------------
5876       double precision a1,b1,s1,x,dx,s,a,b
5877       a1=dsqrt(a)
5878       b1=dsqrt(b)
5879       s1=dsqrt(s)
5880       x=(1.d0+(a1-b1)*(a1+b1)/s)/2.d0
5881       dx=(x-a1/s1)*(x+a1/s1)
5882 c      x=.5*(1.+(a-b)/s)
5883 c      dx=(x*x-a/s)
5884       if(dx.gt.0.d0)then
5885         x=x+dsqrt(dx)
5886       else
5887         x=a1/s1
5888       endif
5889       psutz=min(0.999999999d0,x)
5890       return
5891       end
5892 
5893 c------------------------------------------------------------------------
5894       block data ptdata
5895 c-----------------------------------------------------------------------
5896 c constants for numerical integration (gaussian weights)
5897 c-----------------------------------------------------------------------
5898       common /ar3/ x1(7),a1(7)
5899       common /ar4/ x4(2),a4(2)
5900       common /ar5/ x5(2),a5(2)
5901       common /ar8/ x2(4),a2
5902       common /ar9/ x9(3),a9(3)
5903 
5904       data x1/.9862838,.9284349,.8272013,.6872929,.5152486,
5905      *.3191124,.1080549/
5906       data a1/.03511946,.08015809,.1215186,.1572032,
5907      *.1855384,.2051985,.2152639/
5908       data x2/.00960736,.0842652,.222215,.402455/
5909       data a2/.392699/
5910       data x4/ 0.339981,0.861136/
5911       data a4/ 0.652145,0.347855/
5912       data x5/.585786,3.41421/
5913       data a5/.853553,.146447/
5914       data x9/.93247,.661209,.238619/
5915       data a9/.171324,.360762,.467914/
5916       end
5917 
5918 c------------------------------------------------------------------------
5919       subroutine strdo1(x,scale,upv,dnv,sea,str,chm,gl)
5920 c------------------------------------------------------------------------
5921 c :::::::::::: duke owens set 1 ::::::::::::::::::::::::::::
5922 c------------------------------------------------------------------------
5923       implicit double precision(a-h,o-z)
5924       double precision
5925      +       f(5),a(6,5),b1(3,6,5)
5926       data q0,ql1/2.d0,.2d0/
5927       data b1/3.d0,0.d0,0.d0,.419d0,.004383d0,-.007412d0,
5928      &3.46d0,.72432d0,-.065998d0,4.4d0,-4.8644d0,1.3274d0,
5929      &6*0.d0,1.d0,
5930      &0.d0,0.d0,.763d0,-.23696d0,.025836d0,4.d0,.62664d0,-.019163d0,
5931      &0.d0,-.42068d0,.032809d0,6*0.d0,1.265d0,-1.1323d0,.29268d0,
5932      &0.d0,-.37162d0,-.028977d0,8.05d0,1.5877d0,-.15291d0,
5933      &0.d0,6.3059d0,-.27342d0,0.d0,-10.543d0,-3.1674d0,
5934      &0.d0,14.698d0,9.798d0,0.d0,.13479d0,-.074693d0,
5935      &-.0355d0,-.22237d0,-.057685d0,6.3494d0,3.2649d0,-.90945d0,
5936      &0.d0,-3.0331d0,1.5042d0,0.d0,17.431d0,-11.255d0,
5937      &0.d0,-17.861d0,15.571d0,1.564d0,-1.7112d0,.63751d0,
5938      &0.d0,-.94892d0,.32505d0,6.d0,1.4345d0,-1.0485d0,
5939      &9.d0,-7.1858d0,.25494d0,0.d0,-16.457d0,10.947d0,
5940      &0.d0,15.261d0,-10.085d0/
5941       wn=1.d0
5942       s= log( log( max(q0,scale)/ql1)/ log(q0/ql1))
5943       do 10 i=1,5
5944       do 10 j=1,6
5945    10 a(j,i)=b1(1,j,i)+s*(b1(2,j,i)+s*b1(3,j,i))
5946       do 40 i=1,5
5947    40 f(i)=a(1,i)*x**a(2,i)*(wn-x)**a(3,i)*(wn+x*
5948      &    (a(4,i)+x*(a(5,i)+x*a(6,i))))
5949       do 50 i=1,2
5950       aa=wn+a(2,i)+a(3,i)
5951    50 f(i)=f(i)*utgam2(aa)/((wn+a(2,i)*a(4,i)/aa)
5952      &*utgam2(a(2,i))*utgam2(wn+a(3,i)))
5953       upv=f(1)-f(2)
5954       dnv=f(2)
5955       sea=f(3)/6.d0
5956       str=sea
5957       chm=f(4)
5958       gl =f(5)
5959       return
5960       end
5961 
5962 
5963 
5964 c------------------------------------------------------------------------
5965       function fzeroGluZZ(z,k)   ! former psftild
5966 c-----------------------------------------------------------------------
5967 c
5968 c    fzeroGluZZComplete = fzeroGluZZ * z^(-1-dels) * gamsoft * gamhad
5969 c
5970 c  A = 8*pi*s0*gampar*gamtilde
5971 c integration over semihard pomeron light cone momentum share xp==u
5972 c
5973 c fzeroGluZZ = (1-glusea) * engy^epszero
5974 c  * int(du) u^(epszero-alppar+dels) (1-u)^alplea * (1-z/u)**betpom
5975 c
5976 c z - light cone x of the gluon,
5977 c k - hadron class
5978 c-----------------------------------------------------------------------
5979       double precision xpmin,xp
5980       include 'epos.inc'
5981       common /ar3/   x1(7),a1(7)
5982       include 'epos.incsem'
5983 
5984       fzeroGluZZ=0.
5985       xpmin=z
5986       xpmin=xpmin**(1.-alppar+dels+epszero)
5987       do i=1,7
5988       do m=1,2
5989         xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
5990      *  (1.-alppar+dels+epszero))
5991         fzeroGluZZ=fzeroGluZZ+a1(i)*(1.-xp)**alplea(k)*(1.-z/xp)**betpom
5992       enddo
5993       enddo
5994       fzeroGluZZ=
5995      *  fzeroGluZZ*.5*(1.-xpmin)/(1.-alppar+dels+epszero)
5996      *     *(1.-glusea)  *engy**epszero
5997       return
5998       end
5999 
6000 c------------------------------------------------------------------------
6001       function fzeroSeaZZ(z,k)     ! former psftile
6002 c-----------------------------------------------------------------------
6003 c
6004 c    fzeroSeaZZComplete = fzeroSeaZZ * z^(-1-dels) * gamsoft * gamhad
6005 c
6006 c  gamsoft = 8*pi*s0*gampar*gamtilde
6007 c integration over semihard pomeron light cone momentum share xp==u
6008 c
6009 c fzeroSeaZZ = glusea * engy^epszero
6010 c   * int(du) u^(epszero-alppar+dels) (1-u)^alplea * EsoftQZero(z/u)
6011 c
6012 c z - light cone x of the quark,
6013 c k - hadron class
6014 c-----------------------------------------------------------------------
6015       double precision xpmin,xp
6016       common /ar3/   x1(7),a1(7)
6017       include 'epos.inc'
6018       include 'epos.incsem'
6019 
6020       fzeroSeaZZ=0.
6021       xpmin=z
6022       xpmin=xpmin**(1.-alppar+dels+epszero)
6023       do i=1,7
6024       do m=1,2
6025         xp=(.5*(1.+xpmin+(2*m-3)*x1(i)*(1.-xpmin)))**(1./
6026      *  (1.-alppar+dels+epszero))
6027         zz=z/xp
6028         fzeroSeaZZ=fzeroSeaZZ+a1(i)*(1.-xp)**alplea(k)*EsoftQZero(zz)
6029       enddo
6030       enddo
6031       fzeroSeaZZ=fzeroSeaZZ*.5*(1.-xpmin)/(1.-alppar+dels+epszero)
6032      *     *glusea  *engy**epszero
6033       return
6034       end
6035 
6036 
6037 c########################################################################
6038 c########################################################################
6039       subroutine psaini
6040 c########################################################################
6041 c########################################################################
6042 
6043 c-----------------------------------------------------------------------
6044 c common initialization procedure
6045 c if isetcs = 0, alpD, betD, etc ... in inirj are not used and xkappa=1
6046 c if isetcs = 1, alpD, betD, etc ... in inirj are not used but xkappa.ne.1
6047 c if isetcs = 2, alpD, betD, xkappa, etc ... in inirj are used and
6048 c                cross section from calculation in inics are read.
6049 c    if epos.inics doesn't exist, it produces only the calculated part of it.
6050 c if isetcs = 3, alpD, betD, xkappa, etc ... in inirj are used and
6051 c                cross section from simulation in inics are read.
6052 c    if epos.inics doesn't exist, it produces the calculated AND the
6053 c    simulated part of it both for ionudi=1 and 3. Only the values for
6054 c    ionudi=1 (elastic for diffraction counted in xs) are always correct.
6055 c    AA xs with ionudi=3 do not always correspond to MC simulations.
6056 c-----------------------------------------------------------------------
6057       include 'epos.inc'
6058       include 'epos.incpar'
6059       include 'epos.incsem'
6060       include 'epos.incems'
6061       logical lcalc!,lcalc2
6062 c      double precision om5p,xh,yh,v3pom(4),om2p
6063       dimension gamhad0(nclha),r2had0(nclha),chad0(nclha)
6064      *,alplea0(nclha),asect11(7,4,7),asect13(7,4,7),asect21(7,4,7)
6065      *,asect23(7,4,7),asect31(7,7,7),asect33(7,7,7)
6066      *,asect41(7,7,7),asect43(7,7,7)!,cgam(idxD)
6067       common /psar2/  edmax,epmax
6068       common /psar4/  fhgg(11,10,8),fhqg(11,10,80)
6069      *,fhgq(11,10,80),fhqq(11,10,80),fhgg0(11,10),fhgg1(11,10,4)
6070      *,fhqg1(11,10,40),fhgg01(11),fhgg02(11),fhgg11(11,4)
6071      *,fhgg12(11,4),fhqg11(11,10,4),fhqg12(11,10,4)
6072      *,ftoint(11,14,2,2,3)
6073       common /psar7/  delx,alam3p,gam3p
6074       common /psar9/  alpr
6075       common /psar15/ sudx(40,2)
6076       common /psar19/ cstot(20,20,240)
6077       common /psar20/ csord(20,20,240)
6078       common /psar21/ csbor(20,160,2)
6079       common /psar22/ cstotzero(20,4,2),csborzer(20,4,2)
6080       common /psar23/ cschar(20,20,2)
6081       common /psar25/ csdsi(21,21,104)
6082       common /psar27/ csds(21,26,4),csdt(21,26,2),csdr(21,26,2)
6083       common /psar33/ asect(7,4,7),asectn(7,7,7)
6084       common /psar34/ rrr,rrrm
6085       common /psar35/ anorm,anormp
6086       common /psar41/ rrrp,rrrmp
6087       common /psar36/ alvc
6088       common /psar37/ coefom1,coefom2
6089       common /psar38/ vfro(11,14,3,2)
6090       common /psar39/ vnorm(11,14,3,2,2)
6091 c$$$      common /psar40/ coefxu1(idxD,nclha,10)
6092 c$$$     *,coefxu2(idxD,idxD,nclha,10),coefxc2(idxD,idxD,nclha,10)
6093       common/producetab/ producetables              !used to link with CRMC
6094       logical producetables
6095       common /ar3/    x1(7),a1(7)
6096       common /testj/  ajeth(4),ajete(5),ajet0(7)
6097       parameter(nbkbin=40)
6098       common /kfitd/ xkappafit(nclegy,nclha,nclha,nbkbin),xkappa,bkbin
6099       common/geom/rmproj,rmtarg,bmax,bkmx
6100       character textini*38
6101       external ptfau,ptfauAA
6102 
6103 
6104       call utpri('psaini',ish,ishini,4)
6105 
6106 c    for fragmentation
6107 c    -----------------
6108 c number of flavors in fragmentation not less than active flavor in hard string 
6109       nrflav=min(max(nrflav,naflav),nflavems)
6110       pmqu2=pmqu**2
6111       difud=pmqd**2-pmqu2
6112       difus=pmqs**2-pmqu2
6113       difuuu=(pmqq+pmqu+pmqu)**2-pmqu2
6114       difuud=(pudd*pmqq+pmqd+pmqu)**2-pmqu2
6115       difuus=(puds*pmqq+pmqs+pmqu)**2-pmqu2
6116       difudd=(pudd*pudd*pmqq+pmqd+pmqd)**2-pmqu2
6117       difuds=(pudd*puds*pmqq+pmqs+pmqd)**2-pmqu2
6118       difuss=(puds*puds*pmqq+pmqs+pmqs)**2-pmqu2
6119       if(nrflav.gt.3)then
6120         difuc=pmqc**2-pmqu2
6121         difuuc=(pudc*pmqq+pmqc+pmqu)**2-pmqu2
6122         difudc=(pudd*pudc*pmqq+pmqc+pmqd)**2-pmqu2
6123         difusc=(puds*pudc*pmqq+pmqc+pmqs)**2-pmqu2
6124         difucc=(pudc*pudc*pmqq+pmqc+pmqs)**2-pmqu2
6125       else
6126         difuc=0.
6127         difuuc=0.
6128         difudc=0.
6129         difusc=0.
6130         difucc=0.
6131         rstrac(1)=0.
6132         rstrac(2)=0.
6133         rstrac(3)=0.
6134         rstrac(4)=0.
6135       endif
6136 
6137       if(iappl.ne.6)then
6138 
6139       do i=1,4
6140       ajeth(i)=0.
6141       enddo
6142       do i=1,5
6143       ajete(i)=0.
6144       ajet0(i)=0.
6145       enddo
6146       ajet0(6)=0.
6147       ajet0(7)=0.
6148 
6149 
6150       if(isetcs.le.1)then              !for Kfit
6151         bkbin=0.3
6152       else
6153         bkbin=0.1
6154       endif
6155       xkappa=1.
6156 
6157       edmax=edmaxi  !1.e12     defined in epos-bas
6158       epmax=epmaxi  !1.e12     defined in epos-bas
6159 
6160 c fix enhanced diagrams at minimum energy = 2.5
6161       delx=1.5 !sqrt(egymin*egymin/exp(1.))
6162 c arbitrary value for alam3p (not good if too small (infinite loop in rsh))
6163       alam3p=0.5*(r2had(1)+r2had(2)+r2had(3)) !0.6
6164       gam3p=.1
6165 
6166 
6167 
6168 c   interface to 'bas'
6169 c    ----------------
6170 
6171       dels=alppom-1.
6172       alpqua=(alppar+1.)/2.
6173       if(abs(alpqua).lt.1.e-6)call utstop('alpar should not be -1 !&')
6174       alpr=-2.+alpqua      !x-exponent for remnant mass
6175 
6176 
6177 c   omega coeffs
6178 c    ----------------
6179       coefom0=utgam1(1.+dels-alppar)*utgam1(1.+alplea(iclpro))
6180      */utgam1(2.+alplea(iclpro)+dels-alppar)
6181      **utgam1(1.+dels-alppar)*utgam1(1.+alplea(icltar))
6182      */utgam1(2.+alplea(icltar)+dels-alppar)
6183       coefom1=1.-utgam1(1.+dels-alppar)**2*utgam1(1.+alplea(iclpro))
6184      */utgam1(1.+alplea(iclpro)+2.*(1.+dels-alppar))
6185      **utgam1(1.+dels-alppar)**2*utgam1(1.+alplea(icltar))
6186      */utgam1(1.+alplea(icltar)+2.*(1.+dels-alppar))/coefom0**2
6187       coefom2=3.*coefom1-1.
6188      *+utgam1(1.+dels-alppar)**3*utgam1(1.+alplea(iclpro))
6189      */utgam1(1.+alplea(iclpro)+3.*(1.+dels-alppar))
6190      **utgam1(1.+dels-alppar)**3*utgam1(1.+alplea(icltar))
6191      */utgam1(1.+alplea(icltar)+3.*(1.+dels-alppar))/coefom0**3
6192       if(ish.ge.4)write(ifch,*)'coefom',coefom0,coefom1,coefom2,delx
6193 
6194 c soft pomeron: abbreviations
6195 c---------------------------------------
6196       if(iappl.eq.1.or.iappl.eq.8.or.iappl.eq.9)then
6197 
6198 
6199 c---------------------------------------
6200 c auxiliary constants:
6201 c---------------------------------------
6202         stmass=.05               !string mass cutoff
6203 
6204 c---------------------------------------
6205 c parton density normalization
6206         sq=log(log(q2min/.232**2)/log(.23/.232**2))
6207         du=2.997+.753*sq-.076*sq*sq
6208         qnorm=0.
6209         do i=1,7
6210         do m=1,2
6211           xx=.5+x1(i)*(m-1.5)
6212           xxq=1.-xx**(1./(1.+du))
6213           qnorm=qnorm+a1(i)*(psdfh4(xxq,q2min,0.,2,1)+
6214      *    psdfh4(xxq,q2min,0.,2,2))/(1.-xxq)**du
6215         enddo
6216         enddo
6217         qnorm=qnorm*.5/(1.+du)
6218         qnormp=qnorm
6219 ckkkkk-----------------------------
6220 c        ffrr=(1.-qnorm)/4./pi/gamhad(2)
6221 c     *  *utgam1(2.+betpom-dels)/utgam1(1.-dels)
6222 c     *  /utgam1(1.+betpom)/utgam1(1.+alplea(2))/
6223 c     *  utgam1(2.-alppar)*utgam1(3.+alplea(2)-alppar)
6224 c      ffrr=(1.-qnorm)/4./pi/gamhad(2)
6225 c     *  *utgam1(2.+betpom-dels)/utgam1(1.-dels)
6226 c     *  /utgam1(1.+betpom)
6227 c      write(6,*)'===========',ffrr
6228         ffrr=gamtil
6229      *  /utgam1(1.+alplea(2))/
6230      *  utgam1(2.-alppar)*utgam1(3.+alplea(2)-alppar)
6231       gamsoft=ffrr*4.*pi
6232 ckkkkkkk-------------------------------
6233         if(ish.ge.4)write (ifch,*)'rr,qnorm',ffrr,qnorm
6234 
6235 
6236         sq=log(log(q2min/.232**2)/log(.25/.232**2))
6237         dpi=.367+.563*sq
6238         qnorm=0.
6239         do i=1,7
6240         do m=1,2
6241           xx=.5+x1(i)*(m-1.5)
6242           xxq=1.-xx**(1./(1.+dpi))
6243           qnorm=qnorm+a1(i)*(psdfh4(xxq,q2min,0.,1,1)+
6244      *    psdfh4(xxq,q2min,0.,1,2))/(1.-xxq)**dpi
6245         enddo
6246         enddo
6247         qnorm=qnorm*.5/(1.+dpi)
6248         cftmp=1./(1.-qnormp)*(1.-qnorm)
6249      *  *utgam1(alplea(2)+1.)/utgam1(alplea(2)+3.-alppar)
6250      *  /utgam1(alplea(1)+1.)*utgam1(alplea(1)+3.-alppar)
6251         gamhad(1)=gamhad(2)*cftmp
6252         if(gamhadsi(1).lt.0.)then
6253           gamhads(1)=gamhad(1)
6254         else
6255           gamhads(1)=gamhad(1)*gamhadsi(1)
6256         endif
6257         gamhad(1)=gamhads(1)
6258         if(ish.ge.4)
6259      *  write (ifch,*)'gamhad(1),gamhads(1)',gamhad(1),gamhads(1)
6260 
6261         if(gamhadsi(2).lt.0.)then
6262           gamhads(2)=gamhad(2)
6263         else
6264           gamhads(2)=gamhad(2)*gamhadsi(2)
6265         endif
6266         gamhad(2)=gamhads(2)
6267         if(ish.ge.4)
6268      *  write (ifch,*)'gamhad(2),gamhads(2)',gamhad(2),gamhads(2)
6269 
6270         qnorm=0.
6271         do i=1,7
6272         do m=1,2
6273           xx=.5+x1(i)*(m-1.5)
6274           xxq=1.-xx**(1./(1.+dpi))
6275           qnorm=qnorm+a1(i)*(psdfh4(xxq,q2min,0.,1,1)+
6276      *    psdfh4(xxq,q2min,0.,1,2))/(1.-xxq)**dpi
6277         enddo
6278         enddo
6279         qnorm=qnorm*.5/(1.+dpi)
6280         cftmp=1./(1.-qnormp)*(1.-qnorm)
6281      *  *utgam1(alplea(2)+1.)/utgam1(alplea(2)+3.-alppar)
6282      *  /utgam1(alplea(3)+1.)*utgam1(alplea(3)+3.-alppar)
6283         gamhad(3)=gamhad(2)*cftmp
6284         if(gamhadsi(3).lt.0.)then
6285           gamhads(3)=gamhad(3)
6286         else
6287           gamhads(3)=gamhad(3)*gamhadsi(3)
6288         endif
6289         gamhad(3)=gamhads(3)
6290         if(ish.ge.4)
6291      *  write (ifch,*)'gamhad(3),gamhads(3)',gamhad(3),gamhads(3)
6292 
6293         quamas=.35
6294         gamhad(4)=gamhad(1)*(quamas/qcmass)**2
6295         if(gamhadsi(4).lt.0.)then
6296           gamhads(4)=gamhad(4)
6297         else
6298           gamhads(4)=gamhad(4)*gamhadsi(4)
6299         endif
6300         gamhad(4)=gamhads(4)
6301         if(ish.ge.4)
6302      *  write (ifch,*)'gamhad(4),gamhads(4)',gamhad(4),gamhads(4)
6303         gnorm=0.
6304         do i=1,7
6305         do m=1,2
6306           xx=.5+x1(i)*(m-1.5)
6307           xxg=xx**(1./(1.-dels))
6308           gnorm=gnorm+a1(i)*(fzeroGluZZ(xxg,4)+fzeroSeaZZ(xxg,4))
6309         enddo
6310         enddo
6311         gnorm=gnorm/(1.-dels)*2.*pi*gamhad(4)*ffrr
6312         alvc=6./(1.-gnorm)-4.
6313         if(ish.ge.4) write (ifch,*)'rr,qnorm,gnorm,alvc',
6314      *  ffrr,qnorm,gnorm,alvc
6315 
6316 c        write (*,*)'rr-c,qnorm,gnorm,alvc',ffrr,qnorm,gnorm,alvc
6317       endif
6318 
6319 c-----------------------------------------------
6320 c tabulation of inclusive jet cross sections
6321 c--------------------------------------------------
6322 
6323       do i=1,40
6324         qi=q2min*exp(.5*(i-1))
6325         sudx(i,1)=psudx(qi,1)
6326         sudx(i,2)=psudx(qi,2)
6327       enddo
6328       if(ish.ge.4)write(ifch,*)'bare cross sections ...'
6329 
6330       call psaevc
6331 
6332 ccc      call MakeCSTable
6333 
6334       inquire(file=fnii(1:nfnii),exist=lcalc)
6335       if(lcalc)then
6336        if(inicnt.eq.1)then
6337         write(ifmt,'(3a)')'read from ',fnii(1:nfnii),' ...'
6338         open(1,file=fnii(1:nfnii),status='old')
6339         read (1,*)qcdlam0,q2min0,q2ini0,naflav0,epmax0,pt2cut0
6340         if(qcdlam0.ne.qcdlam)write(ifmt,'(a)')'initl: wrong qcdlam'
6341         if(q2min0 .ne.q2min )write(ifmt,'(a)')'initl: wrong q2min'
6342         if(q2ini0 .ne.q2ini )write(ifmt,'(a)')'initl: wrong q2ini'
6343         if(naflav0.ne.naflav)write(ifmt,'(a)')'initl: wrong naflav'
6344         if(epmax0 .ne.epmax )write(ifmt,'(a)')'initl: wrong epmax'
6345         if(pt2cut0 .ne.pt2cut )write(ifmt,'(a)')'initl: wrong pt2cut'
6346         if(qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min .or.q2ini0 .ne.q2ini
6347      *  .or.naflav0.ne.naflav.or.epmax0 .ne.epmax.or. pt2cut.ne.pt2cut0)
6348      *  then
6349           write(ifmt,'(//a//)')'   initl has to be reinitialized!!!'
6350           stop
6351         endif
6352         read (1,*)csbor,csord,cstot,cstotzero,csborzer
6353         close(1)
6354        endif
6355 
6356        goto 1
6357 
6358       elseif(.not.producetables)then
6359         write(ifmt,*) "Missing epos.initl file !"        
6360         write(ifmt,*) "Please correct the defined path ",
6361      &"or force production ..."
6362         stop
6363 
6364       endif
6365 
6366       write(ifmt,'(a)')'initl does not exist -> calculate tables  ...'
6367 
6368       write (*,*)'Born xsection csbor'
6369       spmin=4.*q2min
6370       spminc=4.*q2min+qcmass**2
6371       do m=1,4   !parton type at upper end of the ladder (1...4 - g,u,d,c)
6372       do k=1,20
6373         if(m.ne.4)then
6374           sk=spmin*(epmax/2./spmin)**((k-1)/19.)
6375           p1=sk
6376         else
6377           sk=spminc*(epmax/2./spminc)**((k-1)/19.)
6378           p1=sk/(1.+qcmass**2/sk)
6379         endif
6380         qmax=p1/4.
6381       do i=1,20
6382         qq=q2min*(qmax/q2min)**((i-1)/19.)
6383       do l=1,2    !parton type at lower end of the ladder
6384         k1=k+20*(m-1)+80*(l-1)
6385         m1=m-1
6386         if(m.eq.3.and.l.eq.1)then  !dd~
6387           l1=-m1
6388         else                       !du
6389           l1=l-1
6390         endif                                       !born cr.-sect.
6391         csbor(i,k1,1)=log(max(1.e-30,psborn(qq,qq,qq,sk,m1,l1,0,0)))
6392         if(m.ne.4)then
6393         csbor(i,k1,2)=log(max(1.e-30,psborn(4.*qq,qq,qq,sk,m1,l1,1,0)))
6394         endif
6395       enddo
6396       enddo
6397       enddo
6398       enddo
6399 
6400       write (*,*)'ordered jet xsection csord'
6401       do m=1,4            !parton type at upper end of the ladder
6402       do k=1,20
6403         write (*,*)'   m=',m,'/4  k=',k,'/20'
6404         if(m.ne.4)then
6405           sk=spmin*(epmax/2./spmin)**((k-1)/19.)  !c.m. energy squared for the hard
6406           p1=sk
6407         else
6408           sk=spminc*(epmax/2./spminc)**((k-1)/19.)
6409           p1=sk/(1.+qcmass**2/sk)
6410         endif
6411         qmax=p1/4.
6412         tmax=p1/2.
6413       do i=1,20             !cross-sections initialization
6414         qi=q2min*(qmax/q2min)**((i-1)/19.)
6415       do j=1,20
6416         qq=qi*(qmax/qi)**((j-1)/19.)
6417         if(p1.gt.4.*qq)then
6418           tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
6419         else
6420           tmin=2.*qq
6421         endif
6422       do l=1,2              !parton type at lower end of the ladder
6423         m1=m-1
6424         if(m.eq.3.and.l.eq.1)then
6425           l1=-m1
6426         else
6427           l1=l-1
6428         endif
6429         if(m.ne.4)then
6430           k1=k+20*(m-1)+60*(l-1)
6431           if(k.eq.1.or.i.eq.20.or.j.eq.20)then
6432             csord(i,j,k1)=log(max(1.e-30,psborn(qi,qq,qq,sk,m1,l1,0,0)))
6433             csord(i,j,k1+120)=
6434      *                 log(max(1.e-30,psborn(4.*qq,qi,qq,sk,l1,m1,1,0)))
6435           else
6436             csord(i,j,k1)=log(psjet1(qi,qq,qq,sk,m1,l1,0)
6437      *      /(1./tmin-1./tmax)+psborn(qi,qq,qq,sk,m1,l1,0,0))
6438             csord(i,j,k1+120)=log(psjet1(qi,4.*qq,qq,sk,m1,l1,2)
6439      *      /(1./tmin-1./tmax)+psborn(4.*qq,qi,qq,sk,l1,m1,1,0))
6440 
6441           endif
6442         elseif(j.eq.1)then
6443           if(k.eq.1.or.i.eq.20)then
6444          cschar(i,k,l)=log(max(1.e-30,psborn(q2min,qi,qq,sk,m1,l1,0,0)))
6445           else
6446             cschar(i,k,l)=log(psjet1(qi,q2min,qq,sk,l1,m1,0)
6447      *      /(1./tmin-1./tmax)+psborn(q2min,qi,qq,sk,m1,l1,0,0))
6448           endif
6449         endif
6450       enddo
6451       enddo
6452       enddo
6453       enddo
6454       enddo
6455 
6456       write (ifmt,*)'tests:'
6457       write (ifmt,'(a,a)')' n-1      sk       qi       qj       qq  '
6458      * ,'      born   born-i      ord    ord-i  '
6459       do k=1,7
6460           sk=spmin*(epmax/2./spmin)**((k-1)/19.)
6461           if(k.ge.5)sk=spmin*1.5**(k-4)
6462       do n=1,2
6463         if(n.eq.1)then
6464           qmax1=sk/4.
6465           qmax2=sk/4.
6466         else             !if(n.eq.2)then
6467           qmax1=sk/4.
6468           qmax2=sk
6469         endif
6470       do i=1,3
6471         qi=q2min*(qmax1/q2min)**((i-1)/3.)
6472       do j=1,3
6473         qj=q2min*(qmax2/q2min)**((j-1)/3.)
6474         qqmax=sk/4.
6475         if(n.eq.1)then
6476           qqmin=max(qi,qj)
6477         else
6478           qqmin=max(qi,qj/4.)
6479         endif
6480       do lq=1,3
6481         qq=qqmin*(qqmax/qqmin)**((lq-1)/3.)
6482         if(sk.gt.4.*qq)then
6483           tmin=2.*qq/(1.+sqrt(1.-4.*qq/sk))
6484         else
6485           tmin=2.*qq
6486         endif
6487         tmax=sk/2.
6488       do m=1,1             !parton type at upper end of the ladder (1
6489       do l=1,1              !parton type at lower end of the ladder (1
6490         m1=m-1
6491         if(m.eq.3.and.l.eq.1)then
6492           l1=-m1
6493         else
6494           l1=l-1
6495         endif
6496        a=psborn(qj,qi,qq,sk,l1,m1,n-1,0)*(1./tmin-1./tmax)
6497        b=psbint(qj,qi,qq,sk,l1,m1,n-1)
6498        c=psjet1(qi,qj,qq,sk,m1,l1,2*(n-1))
6499      *    +psborn(qj,qi,qq,sk,l1,m1,n-1,0)*(1./tmin-1./tmax)
6500        d=psjti1(qi,qj,qq,sk,m1,l1,n-1)
6501        write (ifmt,'(i3,4f9.1,3x,4f9.4)')n-1,sk,qi,qj,qq,a,b,c,d
6502       enddo
6503       enddo
6504       enddo
6505       enddo
6506       enddo
6507       enddo
6508       enddo
6509 
6510       write (*,*)'jet xsection cstot'
6511       do k=1,20
6512         write (*,*)'k=',k,'/20'
6513         sk=spmin*(epmax/2./spmin)**((k-1)/19.)  !c.m. energy squared for the hard
6514         qmax=sk/4.
6515         tmax=sk/2.
6516       do i=1,20             !cross-sections initialization
6517       do n=1,2
6518         if(n.eq.1)then
6519           qi=q2min*(qmax/q2min)**((i-1)/19.)
6520         else
6521           qi=q2min*(4.*qmax/q2min)**((i-1)/19.)
6522         endif
6523       do j=1,20
6524         if(n.eq.1)then
6525           qq=qi*(qmax/qi)**((j-1)/19.)
6526         else
6527           qq=max(q2min,qi/4.)*(qmax/max(q2min,qi/4.))**
6528      *    ((j-1)/19.)
6529         endif
6530         if(sk.gt.4.*qq)then
6531           tmin=2.*qq/(1.+sqrt(1.-4.*qq/sk))
6532         else
6533           tmin=2.*qq
6534         endif
6535       do m=1,3              !parton type at upper end of the ladder (1
6536       do l=1,2              !parton type at lower end of the ladder (1
6537         m1=m-1
6538         if(m.eq.3.and.l.eq.1)then
6539           l1=-m1
6540         else
6541           l1=l-1
6542         endif
6543         k1=k+20*(m-1)+60*(l-1)+120*(n-1)
6544         if(k.eq.1.or.i.eq.20.or.j.eq.20)then
6545        cstot(i,j,k1)=log(max(1.e-30,psborn(qi,q2min,qq,sk,m1,l1,n-1,0)))
6546         else
6547           if(n.eq.1)then
6548             cstot(i,j,k1)=log((psjet(qi,q2min,qq,sk,m1,l1,0)+
6549      *      psjti1(qi,q2min,qq,sk,m1,l1,0)+
6550      *      psjti1(q2min,qi,qq,sk,l1,m1,0)
6551      *      -psbint(qi,q2min,qq,sk,m1,l1,0))/(1./tmin-1./tmax))
6552           else
6553             cstot(i,j,k1)=log((psjet(qi,q2min,qq,sk,m1,l1,1)+
6554      *      psjet1(qi,q2min,qq,sk,m1,l1,1)+
6555      *      psjti1(q2min,qi,qq,sk,l1,m1,1))/(1./tmin-1./tmax))
6556           endif
6557         endif
6558       enddo
6559       enddo
6560       enddo
6561       enddo
6562       enddo
6563       enddo
6564 
6565 c total and born hard cross-sections logarithms for minimal cutoff
6566 c (q2min), interpolated in the psjti0 procedure
6567       spmin=4.*q2min
6568       spminc=4.*q2min+qcmass**2
6569       do m=1,4
6570       do l=1,2
6571         m1=m-1
6572         if(m.eq.3.and.l.eq.1)then
6573           l1=-m1
6574         else
6575           l1=l-1
6576         endif
6577       do k=1,20
6578         if(m.ne.4)then
6579           sk=spmin*(epmax/2./spmin)**((k-1)/19.)  !c.m. energy squared for the hard
6580           p1=sk
6581           qq=q2min
6582         else
6583           sk=spminc*(epmax/2./spminc)**((k-1)/19.)
6584           p1=sk/(1.+qcmass**2/sk)
6585           qq=q2min
6586         endif
6587         if(p1.gt.4.*qq)then
6588           tmin=2.*qq/(1.+sqrt(1.-4.*qq/p1))
6589         else
6590           tmin=2.*qq
6591         endif
6592         tmax=p1/2.
6593 
6594         k1=k+20*(m-1)+80*(l-1)
6595         csborzer(k,m,l)
6596      *      =log(max(1.e-30,psborn(q2min,q2min,qq,sk,m1,l1,0,0)))
6597         if(k.eq.1)then
6598           cstotzero(k,m,l)=csborzer(k,m,l)
6599         elseif(m.ne.4)then
6600           cstotzero(k,m,l)=log(psjti(q2min,qq,sk,m1,l1,0)/
6601      *    (1./tmin-1./tmax))
6602         else
6603           smins=2.5*q2min*(1.+sqrt(1.+4.*qcmass**2/q2min))
6604           if(sk.le.smins)then
6605             cstotzero(k,m,l)=log(psjci(q2min,sk,l1)/(1./tmin-1./tmax))
6606           else
6607             cstotzero(k,m,l)=log((psjci(q2min,sk,l1)+psjct(sk,l1))
6608      *      /(1./tmin-1./tmax))
6609           endif
6610         endif
6611       enddo
6612       enddo
6613       enddo
6614 
6615       write(ifmt,'(a)')'write to initl ...'
6616       open(1,file=fnii(1:nfnii),status='unknown')
6617       write (1,*)qcdlam,q2min,q2ini,naflav,epmax,pt2cut
6618       write (1,*)csbor,csord,cstot,cstotzero,csborzer,cschar
6619       close(1)
6620 
6621 1     continue
6622 
6623       if(iappl.ne.8)goto 3
6624       if(ish.ge.3)write(ifch,*)'dis cross sections ...'
6625       inquire(file=fnid(1:nfnid),exist=lcalc)
6626       if(lcalc)then
6627        if(inicnt.eq.1)then
6628         write(ifmt,'(3a)')'read from ',fnid(1:nfnid),' ...'
6629         open(1,file=fnid(1:nfnid),status='old')
6630         read (1,*)qcdlam0,q2min0,q2ini0,naflav0,epmax0,edmax0
6631         if(qcdlam0.ne.qcdlam)write(ifmt,'(a)')'inidi: wrong qcdlam'
6632         if(q2min0 .ne.q2min )write(ifmt,'(a)')'inidi: wrong q2min'
6633         if(q2ini0 .ne.q2ini )write(ifmt,'(a)')'inidi: wrong q2ini'
6634         if(naflav0.ne.naflav)write(ifmt,'(a)')'inidi: wrong naflav'
6635         if(epmax0 .ne.epmax )write(ifmt,'(a)')'inidi: wrong epmax'
6636         if(edmax0 .ne.edmax )write(ifmt,'(a)')'inidi: wrong edmax'
6637         if(qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min.or.q2ini0 .ne.q2ini
6638      *  .or.naflav0.ne.naflav.or.epmax0 .ne.epmax
6639      *  .or.edmax0 .ne.edmax)then
6640            write(ifmt,'(//a//)')'   inidi has to be reinitialized!!!'
6641            stop
6642         endif
6643         read (1,*)csdsi,csds,csdt,csdr
6644         close(1)
6645        endif
6646        goto 3
6647 
6648       elseif(.not.producetables)then
6649         write(ifmt,*) "Missing epos.inidi file !"        
6650         write(ifmt,*) "Please correct the defined path ",
6651      &"or force production ..."
6652         stop
6653 
6654       endif
6655 
6656       write(ifmt,'(a)')'inidi does not exist -> calculate tables  ...'
6657       do j=1,21
6658         qq=q2min*exp(.5*(j-1))                !photon virtuality
6659 
6660         do m=1,2               !parton type at the end of the ladder
6661           q2mass=qcmass**2
6662           s2min=4.*max(q2mass,q2min)+qq
6663           if(m.eq.2)s2min=s2min/(1.-4.*q2ini/(s2min-qq))
6664         do k=1,26
6665           write (*,*)'sin,j,m,k',j,m,k
6666           sk=s2min*(edmax/s2min)**(.04*(k-1))      !c.m. energy squared
6667           if(k.eq.26)sk=1.01*sk
6668           qmin=q2min
6669           if(m.eq.1)then
6670             qmax=(sk-qq)/4.
6671           else
6672             qmax=(sk-qq+sqrt((sk-qq)**2-16.*sk*q2ini))/8.
6673           endif
6674 
6675           do i=1,21               !cross-sections calculation
6676             qi=qmin*(qmax/qmin)**((i-1)/20.)
6677             tmax=.5*sk
6678             qtq=4.*max(q2mass,qi)/(sk-qq)
6679             if(qtq.lt.1.)then
6680               tmin=.5*sk*qtq/(1.+sqrt(1.-qtq))
6681             else
6682               tmin=.5*sk
6683             endif
6684 
6685             do ilong=1,2
6686               k1=k+26*(m-1)+52*(ilong-1)
6687               if(m.eq.1)then
6688                 if(tmax.gt.1.01*tmin)then
6689                   sij=psds(qi,qq,sk,m-1,ilong-1)
6690                   if(sij.lt.0.)write (*,*)'qi,qq,sk,m,long,sij',
6691      *            qi,qq,sk,m,ilong,sij
6692                   csdsi(i,j,k1)=log(max(0.,sij)/(1./tmin-1./tmax)
6693      *            +psdbor(qi,qq,sk,ilong-1))
6694                 else
6695                   csdsi(i,j,k1)=
6696      *            log(max(1.e-25,psdbor(qi,qq,sk,ilong-1)))
6697                 endif
6698               else
6699                 csdsi(i,j,k1)=psds(qi,qq,sk,m-1,ilong-1)
6700               endif
6701             enddo
6702           enddo
6703         enddo
6704         enddo
6705       enddo
6706 
6707       do j=1,21
6708         qq=q2min*exp(.5*(j-1))                       !photon virtuality
6709         s2min=max(4.*qq,16.*q2min)    !pt2dis=qq
6710       do m=1,2
6711       do k=1,26
6712         do ilong=1,2
6713           k1=k+26*(m-1)+52*(ilong-1)
6714           csds(j,k,m+2*(ilong-1))=csdsi(1,j,k1)
6715         enddo
6716 
6717         sk=(s2min+qq)*(edmax/(s2min+qq))**(.04*(k-1))
6718         csdt(j,k,m)=psdres(qq,sk,s2min,m-1)
6719         csdr(j,k,m)=psdrga(qq,sk-qq,s2min,m-1)
6720       enddo
6721       enddo
6722       enddo
6723 
6724       write(ifmt,'(a)')'write to inidi ...'
6725 
6726       write(ifmt,'(a)')'write to inidi ...'
6727       open(1,file=fnid(1:nfnid),status='unknown')
6728       write (1,*)qcdlam,q2min,q2ini,naflav,epmax,edmax
6729       write (1,*)csdsi,csds,csdt,csdr
6730       close(1)
6731 3     continue
6732 
6733 c---------------------------------------
6734 c tabulation of semihard eikonals
6735 c---------------------------------------
6736 
6737 !!!!!!!!!      if(iappl.eq.1)then
6738 
6739       if(ish.ge.4)write(ifch,*)'semihard eikonals ...'
6740 5     continue
6741       inquire(file=fnrj,exist=lcalc)
6742       if(lcalc)then
6743        if(inicnt.eq.1)then
6744         write(ifmt,'(3a)')'read from ',fnrj(1:nfnrj),' ...'
6745         open(1,file=fnrj(1:nfnrj),status='old')
6746         read (1,*)alpqua0,alplea0,alppom0,slopom0,
6747      *  gamhad0,r2had0,chad0,
6748      *  qcdlam0,q2min0,q2ini0,betpom0,glusea0,naflav0,
6749      *  factk0,pt2cut0,gamtil0
6750         if(alpqua0.ne.alpqua)write(ifmt,'(a,2f8.4)')
6751      *  'inirj: wrong alpqua',alpqua0,alpqua
6752         if(alppom0.ne.alppom)write(ifmt,'(a,2f8.4)')
6753      *  'inirj: wrong alppom',alppom0,alppom
6754         if(slopom0.ne.slopom)write(ifmt,'(a,2f8.4)')
6755      *  'inirj: wrong slopom',slopom0,slopom
6756         iii=2
6757         if(gamhad0(iii).ne.gamhad(iii))write(ifmt,'(a,i1,a,2f8.4)')
6758      *  'inirj: wrong gamhad(',iii,')',gamhad0(iii),gamhad(iii)
6759         do iii=1,3
6760         if(r2had0(iii) .ne.r2had(iii) )write(ifmt,'(a,i1,a,2f8.4)')
6761      *  'inirj: wrong r2had(',iii,')',r2had0(iii),r2had(iii)
6762         if(chad0(iii)  .ne.chad(iii)  )write(ifmt,'(a,i1,a,2f8.4)')
6763      *  'inirj: wrong chad(',iii,')',chad0(iii),chad(iii)
6764         if(alplea0(iii).ne.alplea0(iii))write(ifmt,'(a,i1,a,2f8.4)')
6765      *  'inirj: wrong alplea(',iii,')',alplea0(iii),alplea(iii)
6766         enddo
6767         if(qcdlam0.ne.qcdlam)write(ifmt,'(a,2f8.4)')
6768      *  'inirj: wrong qcdlam',qcdlam0,qcdlam
6769         if(q2min0 .ne.q2min )write(ifmt,'(a,2f8.4)')
6770      *  'inirj: wrong q2min',q2min0,q2min
6771         if(q2ini0 .ne.q2ini )write(ifmt,'(a,2f8.4)')
6772      *  'inirj: wrong q2ini',q2ini0,q2ini
6773         if(betpom0.ne.betpom)write(ifmt,'(a,2f8.4)')
6774      *  'inirj: wrong betpom',betpom0,betpom
6775         if(glusea0.ne.glusea)write(ifmt,'(a,2f8.4)')
6776      *  'inirj: wrong glusea',glusea0,glusea
6777         if(naflav0.ne.naflav)write(ifmt,'(a,2f8.4)')
6778      *  'inirj: wrong naflav',naflav0,naflav
6779         if(factk0 .ne.factk )write(ifmt,'(a,2f8.4)')
6780      *  'inirj: wrong factk', factk0,factk
6781         if(pt2cut0 .ne.pt2cut )write(ifmt,'(a,2f8.4)')
6782      *  'inirj: wrong pt2cut', pt2cut0,pt2cut
6783         if(gamtil0 .ne.gamtil )write(ifmt,'(a,2f8.4)')
6784      *  'inirj: wrong gamtil', gamtil0,gamtil
6785         if(alpqua0.ne.alpqua.or.alppom0.ne.alppom
6786      *  .or.slopom0.ne.slopom.or.gamhad0(2).ne.gamhad(2)
6787      *  .or.r2had0(1).ne.r2had(1).or.r2had0(2).ne.r2had(2)
6788      *  .or.r2had0(3).ne.r2had(3)
6789      *  .or.chad0(1).ne.chad(1).or.chad0(2).ne.chad(2)
6790      *  .or.chad0(3).ne.chad(3)
6791      *  .or.alplea0(1).ne.alplea(1).or.alplea0(2).ne.alplea(2)
6792      *  .or.alplea0(3).ne.alplea(3)
6793      *  .or.qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min
6794      *  .or.q2ini0 .ne.q2ini.or.gamtil0.ne.gamtil
6795      *  .or.betpom0.ne.betpom.or.glusea0.ne.glusea.or.naflav0.ne.naflav
6796      *  .or.factk0 .ne.factk .or.pt2cut0.ne.pt2cut)then
6797            write(ifmt,'(//a//)')'   inirj has to be reinitialized!!!!'
6798            stop
6799         endif
6800 
6801         read(1,*)fhgg,fhqg,fhgq,fhqq,fhgg0,fhgg1,fhqg1
6802      *  ,fhgg01,fhgg02,fhgg11,fhgg12,fhqg11,fhqg12
6803      *  ,ftoint,vfro,vnorm,coefxu1,coefxu2,coefxc2
6804         read(1,*)bkbin0,iclpro10,iclpro20,icltar10,icltar20,iclegy10
6805      *   ,iclegy20,egylow0,egymax0,iomega0,egyscr0,epscrw0,epscrp0
6806         if(isetcs.gt.1)then
6807         textini='                                      '
6808         if(iclpro10.ne.iclpro1)write(textini,'(a,2i8)')
6809      *  'inirj: wrong iclpro1  ',iclpro10,iclpro1
6810         if(iclpro20.ne.iclpro2)write(textini,'(a,2i8)')
6811      *  'inirj: wrong iclpro2  ',iclpro20,iclpro2
6812         if(icltar10.ne.icltar1)write(textini,'(a,2i8)')
6813      *  'inirj: wrong icltar1  ',icltar10,icltar1
6814         if(icltar20.ne.icltar2)write(textini,'(a,2i8)')
6815      *  'inirj: wrong icltar2  ',icltar20,icltar2
6816         if(iclegy10.ne.iclegy1)write(textini,'(a,2i8)')
6817      *  'inirj: wrong iclegy1  ',iclegy10,iclegy1
6818         if(iclegy20.ne.iclegy2)write(textini,'(a,2i8)')
6819      *  'inirj: wrong iclegy2  ',iclegy20,iclegy2
6820         if(iomega0.ne.iomega)write(textini,'(a,2i8)')
6821      *  'inirj: wrong iomega   ',iomega0,iomega
6822         if(egylow0.ne.egylow)write(textini,'(a,2f8.4)')
6823      *  'inirj: wrong egylow   ',egylow0,egylow
6824         if(egymax0.ne.egymax)write(textini,'(a,2f8.4)')
6825      *  'inirj: wrong egymax   ',egymax0,egymax
6826         if(epscrw0.ne.epscrw)write(textini,'(a,2f8.4)')
6827      *  'inirj: wrong epscrw    ',epscrw0,epscrw
6828         if(epscrp0.ne.epscrp)write(textini,'(a,2f8.4)')
6829      *  'inirj: wrong epscrp   ',epscrp0,epscrp
6830         if(bkbin0.ne.bkbin)write(textini,'(a,2f8.4)')
6831      *  'inirj: wrong bkbin',bkbin0,bkbin
6832         if(textini.ne.'                                      ')then
6833            write(ifmt,'(//10x,a//10x,a//)')textini,
6834      *     'inirj has to be reinitialized!!!!'
6835            stop
6836         endif
6837         do iiipro=iclpro1,iclpro2
6838         do iiitar=icltar1,icltar2
6839         do iiiegy=iclegy1,iclegy2
6840         do iiib=1,nbkbin
6841           read(1,*)xkappafit(iiiegy,iiipro,iiitar,iiib)
6842         enddo
6843         xkappafit(iiiegy,iiipro,iiitar,nbkbin)=1.
6844         do iiib=2,nbkbin-1
6845           if(xkappafit(iiiegy,iiipro,iiitar,iiib).lt.1.)then
6846             xkappafit(iiiegy,iiipro,iiitar,iiib)=max(1.,0.5*
6847      *        (xkappafit(iiiegy,iiipro,iiitar,iiib-1)
6848      *        +xkappafit(iiiegy,iiipro,iiitar,iiib+1)))
6849           endif
6850         enddo
6851         do iiidf=idxD0,idxD
6852          read(1,*)alpDs(iiidf,iiiegy,iiipro,iiitar),
6853      *   alpDps(iiidf,iiiegy,iiipro,iiitar),
6854      *   alpDpps(iiidf,iiiegy,iiipro,iiitar),
6855      *   betDs(iiidf,iiiegy,iiipro,iiitar),
6856      *   betDps(iiidf,iiiegy,iiipro,iiitar),
6857      *   betDpps(iiidf,iiiegy,iiipro,iiitar),
6858      *   gamDs(iiidf,iiiegy,iiipro,iiitar),
6859      *   delDs(iiidf,iiiegy,iiipro,iiitar)
6860         enddo
6861         enddo
6862         enddo
6863         enddo
6864       endif
6865 
6866         close(1)
6867 
6868       endif
6869 
6870 
6871         goto 4
6872 
6873       elseif(.not.producetables)then
6874         write(ifmt,*) "Missing epos.inirj file !"        
6875         write(ifmt,*) "Please correct the defined path ",
6876      &"or force production ..."
6877         stop
6878 
6879       endif
6880 
6881       write(ifmt,'(a)')'inirj does not exist -> calculate tables  ...'
6882 
6883       engysave=engy
6884       maprojsave=maproj
6885       matargsave=matarg
6886       iclpros=iclpro
6887       icltars=icltar
6888       spmin=4.*q2min
6889       spminc=4.*q2min+2.*qcmass**2
6890       icltar=2
6891 
6892       write(ifmt,'(a)')'  tabulate om5 ...'
6893 
6894       do iy=1,11
6895         sy=spmin*(epmax/2./spmin)**((iy-1)/10.)
6896         syc=spminc*(epmax/2./spminc)**((iy-1)/10.)
6897         iclpro=2
6898         icltar=2
6899         if(iy.eq.1)then
6900           fhgg01(iy)=-80.
6901           fhgg02(iy)=-80.
6902         else
6903           fhgg01(iy)=log(om51pp(sy,1.,1.,3))
6904           fhgg02(iy)=log(om51pp(sy,1.,1.,7))
6905         endif
6906 
6907         do iclpro=iclpro1,iclpro2
6908           if(iy.eq.1)then
6909             fhgg11(iy,iclpro)=-80.
6910             fhgg12(iy,iclpro)=-80.
6911           else
6912             fhgg11(iy,iclpro)=log(om51pp(sy,1.,1.,4))
6913             fhgg12(iy,iclpro)=log(om51pp(sy,1.,1.,9))
6914           endif
6915           do ix=1,10
6916             if(ix.le.5)then
6917               xp=.1*2.**(ix-5)
6918             else
6919               xp=.2*(ix-5)
6920             endif
6921             if(iy.eq.1)then
6922               fhqg11(iy,ix,iclpro)=-80.
6923               fhqg12(iy,ix,iclpro)=-80.
6924             elseif(iclpro.eq.4)then
6925               fhqg11(iy,ix,iclpro)=log(om51pp(syc,1.,1.,5))
6926               fhqg12(iy,ix,iclpro)=log(om51pp(syc,1.,1.,11))
6927             else
6928               fhqg11(iy,ix,iclpro)=log(om51pp(sy,xp,1.,5))
6929               fhqg12(iy,ix,iclpro)=log(om51pp(sy,xp,1.,11))
6930             endif
6931           enddo
6932         enddo
6933 
6934       do iz=1,10
6935         z=.1*iz
6936 
6937         iclpro=2
6938         icltar=2
6939         if(iy.eq.1)then
6940           fhgg0(iy,iz)=-80.
6941         else
6942           fhgg0(iy,iz)=log(om51pp(sy,1.,z,6)/z)
6943         endif
6944 
6945         do iclpro=iclpro1,iclpro2
6946           if(iy.eq.1)then
6947             fhgg1(iy,iz,iclpro)=-80.
6948           else
6949             fhgg1(iy,iz,iclpro)=log(om51pp(sy,1.,z,8)/z)
6950           endif
6951 
6952           do ix=1,10
6953             if(ix.le.5)then
6954               xp=.1*2.**(ix-5)
6955             else
6956               xp=.2*(ix-5)
6957             endif
6958             if(iy.eq.1)then
6959               fhqg1(iy,ix,iz+10*(iclpro-1))=-80.
6960             elseif(iclpro.eq.4)then
6961               fhqg1(iy,ix,iz+10*(iclpro-1))=log(om51pp(syc,xp,z,10)/z)
6962             else
6963               fhqg1(iy,ix,iz+10*(iclpro-1))=log(om51pp(sy,xp,z,10)/z)
6964             endif
6965           enddo
6966         enddo
6967       enddo
6968       enddo
6969 
6970       do iclpro=iclpro1,iclpro2 !hadron type (1 - pion, 2 - nucleon, 3 - kaon, 4 - charm)
6971       do icltar=icltar1,icltar2 !hadron type (2 - nucleon)
6972         do iy=1,11
6973           sy=spmin*(epmax/2./spmin)**((iy-1)/10.)
6974           syc=spminc*(epmax/2./spminc)**((iy-1)/10.)
6975           do iz=1,10
6976             z=.1*iz
6977             if(iy.eq.1)then
6978               fhgg(iy,iz,iclpro+4*(icltar-1))=-80.
6979             else
6980               fhgg(iy,iz,iclpro+4*(icltar-1))=log(om51pp(sy,1.,z,0)/z)
6981             endif
6982 
6983           do ix=1,10
6984             if(ix.le.5)then
6985               xp=.1*2.**(ix-5)
6986             else
6987               xp=.2*(ix-5)
6988             endif
6989             if(iy.eq.1)then
6990               fhqg(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=-80.
6991               fhgq(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=-80.
6992             else
6993               if(iclpro.ne.4)then
6994                 syx=sy
6995               else
6996                 syx=syc
6997               endif
6998               fhqg(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=
6999      *        log(om51pp(syx,xp,z,1)/z)
7000               if(icltar.ne.4)then
7001                 syx=sy
7002               else
7003                 syx=syc
7004               endif
7005               fhgq(iy,ix,iz+10*(iclpro+4*(icltar-1)-1))=
7006      *        log(om51pp(syx,xp,z,2)/z)
7007             endif
7008           enddo
7009           enddo
7010 
7011           do ix1=1,10
7012             if(ix1.le.5)then
7013               xpph=.1*2.**(ix1-5)
7014             else
7015               xpph=.2*(ix1-5)
7016             endif
7017           do ix2=1,10
7018             if(ix2.le.5)then
7019               xmm=.1*2.**(ix2-5)
7020             else
7021               xmm=.2*(ix2-5)
7022             endif
7023 
7024             if(iy.eq.1)then
7025               fhqq(iy,ix1,ix2+10*(iclpro+4*(icltar-1)-1))=-80.
7026             else
7027               if(iclpro.ne.4.and.icltar.ne.4)then
7028                 syx=sy
7029               else
7030                 syx=syc
7031               endif
7032               fhqq(iy,ix1,ix2+10*(iclpro+4*(icltar-1)-1))=
7033      *        log(pshard(syx,xpph,xmm))
7034             endif
7035           enddo
7036           enddo
7037         enddo
7038       enddo
7039 
7040       enddo
7041 
7042       if(isetcs.gt.1)then
7043 
7044 
7045         write(ifmt,'(a)')'  tabulate fit parameters ...'
7046 
7047       engysave=engy
7048       do iclpro=iclpro1,iclpro2 !hadron type (1 - pion, 2 - nucleon, 3 - kaon, 4 - charm)
7049       do icltar=icltar1,icltar2 !hadron type (2 - nucleon)
7050       do iclegy=iclegy2,iclegy1,-1
7051         call param
7052       enddo
7053       do iiclegy=iclegy2,iclegy1,-1
7054         engy=egyfac**(iiclegy-1)*egylow
7055         call paramini(0)
7056         call Kfit(iiclegy)
7057       enddo
7058       enddo
7059       enddo
7060       engy=engysave
7061 
7062       endif
7063 
7064       write(ifmt,'(a)')'  write to inirj ...'
7065       open(1,file=fnrj,status='unknown')
7066       write (1,*)alpqua,alplea,alppom,slopom,gamhad,r2had,chad,
7067      *qcdlam,q2min,q2ini,betpom,glusea,naflav,factk,pt2cut,gamtil
7068       write (1,*)fhgg,fhqg,fhgq,fhqq,fhgg0,fhgg1,fhqg1
7069      *,fhgg01,fhgg02,fhgg11,fhgg12,fhqg11,fhqg12
7070      *,ftoint,vfro,vnorm,coefxu1,coefxu2,coefxc2
7071       write(1,*)bkbin,iclpro1,iclpro2,icltar1,icltar2,iclegy1,iclegy2
7072      *,egylow,egymax,iomega,egyscr,epscrw,epscrp
7073       do iiipro=iclpro1,iclpro2
7074        do iiitar=icltar1,icltar2
7075         do iiiegy=iclegy1,iclegy2
7076         do iiib=1,nbkbin
7077           write(1,*)xkappafit(iiiegy,iiipro,iiitar,iiib)
7078         enddo
7079         do iiidf=idxD0,idxD
7080          write(1,*)alpDs(iiidf,iiiegy,iiipro,iiitar),
7081      *   alpDps(iiidf,iiiegy,iiipro,iiitar),
7082      *   alpDpps(iiidf,iiiegy,iiipro,iiitar),
7083      *   betDs(iiidf,iiiegy,iiipro,iiitar),
7084      *   betDps(iiidf,iiiegy,iiipro,iiitar),
7085      *   betDpps(iiidf,iiiegy,iiipro,iiitar),
7086      *   gamDs(iiidf,iiiegy,iiipro,iiitar),
7087      *   delDs(iiidf,iiiegy,iiipro,iiitar)
7088         enddo
7089         enddo
7090        enddo
7091       enddo
7092 
7093       close(1)
7094 
7095       engy=engysave
7096       maproj=maprojsave
7097       matarg=matargsave
7098       iclpro=iclpros
7099       icltar=icltars
7100       inicnt=1
7101       goto 5
7102 
7103 4     continue
7104 
7105 c--------------------------------------
7106 c inelastic cross sections
7107 c---------------------------------------
7108 
7109       if(isetcs.ge.2)then !--------------------
7110 
7111       if(ish.ge.4)write(ifch,*)'cross sections ...'
7112  6    continue
7113       inquire(file=fncs,exist=lcalc)
7114       if(lcalc)then
7115        if(inicnt.eq.1)then
7116         write(ifmt,'(3a)')'read from ',fncs(1:nfncs),' ...'
7117         open(1,file=fncs(1:nfncs),status='old')
7118         read (1,*)alpqua0,alplea0,alppom0,slopom0,
7119      *  gamhad0,r2had0,chad0,
7120      *  qcdlam0,q2min0,q2ini0,betpom0,glusea0,naflav0,
7121      *  factk0,pt2cut0
7122         if(alpqua0.ne.alpqua)write(ifmt,'(a,2f8.4)')
7123      *  'inics: wrong alpqua',alpqua0,alpqua
7124         if(alppom0.ne.alppom)write(ifmt,'(a,2f8.4)')
7125      *  'inics: wrong alppom',alppom0,alppom
7126         if(slopom0.ne.slopom)write(ifmt,'(a,2f8.4)')
7127      *  'inics: wrong slopom',slopom0,slopom
7128         iii=2
7129         if(gamhad0(iii).ne.gamhad(iii))write(ifmt,'(a,i1,a,2f8.4)')
7130      *  'inics: wrong gamhad(',iii,')',gamhad0(iii),gamhad(iii)
7131         do iii=1,3
7132         if(r2had0(iii) .ne.r2had(iii) )write(ifmt,'(a,i1,a,2f8.4)')
7133      *  'inics: wrong r2had(',iii,')',r2had0(iii),r2had(iii)
7134         if(chad0(iii)  .ne.chad(iii)  )write(ifmt,'(a,i1,a,2f8.4)')
7135      *  'inics: wrong chad(',iii,')',chad0(iii),chad(iii)
7136         if(alplea0(iii).ne.alplea0(iii))write(ifmt,'(a,i1,a,2f8.4)')
7137      *  'inics: wrong alplea(',iii,')',alplea0(iii),alplea(iii)
7138         enddo
7139         if(qcdlam0.ne.qcdlam)write(ifmt,'(a,2f8.4)')
7140      *  'inics: wrong qcdlam',qcdlam0,qcdlam
7141         if(q2min0 .ne.q2min )write(ifmt,'(a,2f8.4)')
7142      *  'inics: wrong q2min',q2min0,q2min
7143         if(q2ini0 .ne.q2ini )write(ifmt,'(a,2f8.4)')
7144      *  'inics: wrong q2ini',q2ini0,q2ini
7145         if(betpom0.ne.betpom)write(ifmt,'(a,2f8.4)')
7146      *  'inics: wrong betpom',betpom0,betpom
7147         if(glusea0.ne.glusea)write(ifmt,'(a,2f8.4)')
7148      *  'inics: wrong glusea',glusea0,glusea
7149         if(naflav0.ne.naflav)write(ifmt,'(a,2f8.4)')
7150      *  'inics: wrong naflav',naflav0,naflav
7151         if(factk0 .ne.factk )write(ifmt,'(a,2f8.4)')
7152      *  'inics: wrong factk', factk0,factk
7153         if(pt2cut0 .ne.pt2cut )write(ifmt,'(a,2f8.4)')
7154      *  'inics: wrong pt2cut', pt2cut0,pt2cut
7155         if(alpqua0.ne.alpqua.or.alppom0.ne.alppom
7156      *  .or.slopom0.ne.slopom.or.gamhad0(2).ne.gamhad(2)
7157      *  .or.r2had0(1).ne.r2had(1).or.r2had0(2).ne.r2had(2)
7158      *  .or.r2had0(3).ne.r2had(3)
7159      *  .or.chad0(1).ne.chad(1).or.chad0(2).ne.chad(2)
7160      *  .or.chad0(3).ne.chad(3)
7161      *  .or.alplea0(1).ne.alplea(1).or.alplea0(2).ne.alplea(2)
7162      *  .or.alplea0(3).ne.alplea(3)
7163      *  .or.qcdlam0.ne.qcdlam.or.q2min0 .ne.q2min
7164      *  .or.q2ini0 .ne.q2ini
7165      *  .or.betpom0.ne.betpom.or.glusea0.ne.glusea.or.naflav0.ne.naflav
7166      *  .or.factk0 .ne.factk .or.pt2cut0.ne.pt2cut)then
7167            write(ifmt,'(//a//)')'   inics has to be reinitialized!!!!'
7168            stop
7169         endif
7170 
7171         read(1,*)isetcs0,iclpro10,iclpro20,icltar10,icltar20,iclegy10
7172      *   ,iclegy20,egylow0,egymax0,iomega0,egyscr0,epscrw0,epscrp0
7173 
7174         if(iclpro10.ne.iclpro1)write(ifmt,'(a,2i2)')
7175      *  'inics: wrong iclpro1',iclpro10,iclpro1
7176         if(iclpro20.ne.iclpro2)write(ifmt,'(a,2i2)')
7177      *  'inics: wrong iclpro2',iclpro20,iclpro2
7178         if(icltar10.ne.icltar1)write(ifmt,'(a,2i2)')
7179      *  'inics: wrong icltar1',icltar10,icltar1
7180         if(icltar20.ne.icltar2)write(ifmt,'(a,2i2)')
7181      *  'inics: wrong icltar2',icltar20,icltar2
7182         if(iclegy10.ne.iclegy1)write(ifmt,'(a,2i4)')
7183      *  'inics: wrong iclegy1',iclegy10,iclegy1
7184         if(iclegy20.ne.iclegy2)write(ifmt,'(a,2i4)')
7185      *  'inics: wrong iclegy2',iclegy20,iclegy2
7186         if(iomega0.ne.iomega)write(textini,'(a,2i8)')
7187      *  'inics: wrong iomega ',iomega0,iomega
7188         if(egylow0.ne.egylow)write(ifmt,'(a,2f8.4)')
7189      *  'inics: wrong egylow',egylow0,egylow
7190         if(egymax0.ne.egymax)write(ifmt,'(a,2f12.4)')
7191      *  'inics: wrong egymax',egymax0,egymax
7192         if(egyscr0.ne.egyscr)write(ifmt,'(a,2f8.4)')
7193      *  'inics: wrong egyscr ',egyscr0,egyscr
7194         if(epscrw0.ne.epscrw)write(ifmt,'(a,2f8.4)')
7195      *  'inics: wrong epscrw',epscrw0,epscrw
7196         if(epscrp0.ne.epscrp)write(ifmt,'(a,2f8.4)')
7197      *  'inics: wrong epscrp',epscrp0,epscrp
7198         if(isetcs0.lt.isetcs)write(ifmt,'(a,2f8.4)')
7199      *  'inics: wrong isetcs',isetcs0,isetcs
7200         if(iclpro10.ne.iclpro1.or.iclpro20.ne.iclpro2
7201      *   .or.icltar10.ne.icltar1.or.icltar20.ne.icltar2
7202      *   .or.iclegy10.ne.iclegy1.or.iclegy20.ne.iclegy2
7203      *   .or.egylow0.ne.egylow.or.egymax0.ne.egymax
7204      *   .or.egyscr0.ne.egyscr.or.epscrw0.ne.epscrw.or.isetcs0.lt.isetcs
7205      *   .or.epscrp0.ne.epscrp)then
7206            write(ifmt,'(//a//)')'   inics has to be reinitialized!!!!'
7207            stop
7208         endif
7209         if(isetcs.eq.2)then
7210           if(ionudi.eq.1)then
7211             read (1,*)asect,asect13,asect21,asect23,asectn
7212      *               ,asect33,asect41,asect43
7213           else  !ionudi=3
7214             read (1,*)asect11,asect,asect21,asect23,asect31
7215      *               ,asectn,asect41,asect43
7216           endif
7217         elseif(isetcs.eq.3)then
7218           if(ionudi.eq.1)then
7219             read (1,*)asect11,asect13,asect,asect23,asect31
7220      *               ,asect33,asectn,asect43
7221           else  !ionudi=3
7222             read (1,*)asect11,asect13,asect21,asect,asect31
7223      *               ,asect33,asect41,asectn
7224           endif
7225         else
7226            write(ifmt,'(//a//)')' Wrong isetcs in psaini !!!!'
7227         endif
7228 
7229         close(1)
7230 
7231       endif
7232 
7233 
7234         goto 7
7235 
7236 
7237       elseif(.not.producetables)then
7238         write(ifmt,*) "Missing epos.inics file !"        
7239         write(ifmt,*) "Please correct the defined path ",
7240      &"or force production ..."
7241         stop
7242 
7243       endif
7244 
7245       ifradesave=ifrade
7246       iremnsave=iremn
7247       idprojsave=idproj
7248       idprojinsave=idprojin
7249       idtargsave=idtarg
7250       idtarginsave=idtargin
7251       laprojsave=laproj
7252       latargsave=latarg
7253       maprojsave=maproj
7254       matargsave=matarg
7255       icltarsave=icltar
7256       iclprosave=iclpro
7257       engysave=engy
7258       pnllsave=pnll
7259       elabsave=elab
7260       ecmssave=ecms
7261       iclegysave=iclegy
7262       nrevtsave=nrevt
7263       neventsave=nevent
7264       ntevtsave=ntevt
7265       isetcssave=isetcs
7266       noebinsave=noebin
7267       isigmasave=isigma
7268       bminimsave=bminim
7269       bmaximsave=bmaxim
7270       bimevtsave=bimevt
7271       bkmxndifsave=bkmxndif
7272 c      fctrmxsave=fctrmx
7273       ionudisave=ionudi
7274 
7275 
7276       isetcs=2
7277       isigma=1
7278       noebin=1
7279       idtarg=1120
7280       idtargin=1120
7281       bminim=0.
7282       bmaxim=10000.
7283       ifrade=0            !to save time, no fragmentation
7284       iremn=0             !to save time, simple remnants
7285       ionudi=3            !to have both ionudi=1 and 3 in tables
7286 
7287       write(ifmt,'(a)')'inics does not exist -> calculate tables  ...'
7288 
7289 c initialize random numbers
7290       if(seedj.ne.0d0)then
7291         call ranfini(seedj,iseqsim,2)
7292       else
7293         stop 'seedi = 0 ... Please define it !'
7294       endif
7295       call aseed(2)
7296 
7297       laproj=-1
7298       maproj=1
7299       icltar=2
7300       do iclpro=1,4
7301        if(iclpro.lt.iclpro1.or.iclpro.gt.iclpro2)then
7302          do ie=1,7
7303            do iia=1,7
7304              asect11(ie,iclpro,iia)=0.
7305              asect21(ie,iclpro,iia)=0.
7306              asect13(ie,iclpro,iia)=0.
7307              asect23(ie,iclpro,iia)=0.
7308            enddo
7309          enddo
7310        else
7311          do ie=1,7
7312            engy=1.5*10.**(ie-1)
7313            call paramini(0)
7314            bkmxndif=conbmxndif()
7315            if(ish.ge.1)
7316      &     write(ifch,*)'  calcul.   ',ie,'  (',iclpro,')',engy
7317            write(ifmt,*)'  calcul.   ',ie,'  (',iclpro,')',engy
7318 
7319            sigine=0.
7320            do iia=1,7
7321             matarg=2**(iia-1)
7322             if(matarg.eq.1)then !hadron-proton interaction
7323 c ine=cut+diff
7324               call psfz(2,gz2,0.)
7325               gin=gz2*pi*10.
7326 c cut
7327               iomegasave=iomega
7328               iomega=2
7329               call psfz(2,gz2,0.)
7330               iomega=iomegasave
7331               gcut=gz2*pi*10.
7332 c diff
7333               difpart=gin-gcut
7334 c  non excited projectile and target
7335               gqela=(1.-rexdif(iclpro))*(1.-rexdif(icltar))*difpart
7336               gin3=max(1.,gin-gqela)              
7337             else
7338               call conini
7339               rad=radnuc(matarg)
7340               bm=rad+2.
7341               rrr=rad/difnuc(matarg)
7342               rrrm=rrr+log(9.)
7343               anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matarg)**2
7344 c             gela=(ptgau(ptfau,bm,2,1)+ptgau1(bm,2,1))*10. !sig_ela
7345 c in=cut+diff
7346               gcut=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig_in
7347               gin=gcut
7348 c cut
7349               iomegasave=iomega
7350               iomega=2
7351               gcut=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig_cut
7352               iomega=iomegasave
7353 c diff
7354               difpart=gin-gcut
7355 c  non excited projectile
7356               gqela=(1.-rexdif(iclpro))
7357      &             **(1.+rexres(iclpro)*float(matarg-1)**0.3)
7358 c  non excited target
7359               gqela=gqela*(1.-rexdif(icltar))
7360               gqela=gqela*difpart
7361               gin3=max(1.,gin-gqela)
7362             endif
7363             if(ish.ge.1)write (ifch,226)matarg,gin,gin3
7364 226         format(2x,'psaini: hadron-nucleus (',i3,') cross sections:'/
7365      *       4x,'gin,gin3=',2e10.3)
7366             write(ifmt,*)'  matarg,gin,gin3:',matarg,gin,gin3
7367             asect11(ie,iclpro,iia)=log(gin)
7368             asect13(ie,iclpro,iia)=log(gin3)
7369            enddo
7370          enddo
7371 
7372          if(isetcssave.ge.3)then
7373 
7374          if(iclpro.eq.1)then
7375           idprojin=120
7376          elseif(iclpro.eq.2)then
7377           idprojin=1120
7378          elseif(iclpro.eq.3)then
7379           idprojin=130
7380          endif
7381          do ie=1,7
7382           engy=1.5*10.**(ie-1)
7383            if(engy.le.egymin)engy=egymin
7384            if(engy.ge.egymax)engy=egymax
7385            write(ifmt,*)'  simul.   ',ie,'  (',iclpro,')',engy
7386            if(ish.ge.1)
7387      &     write(ifch,*)'  simul.   ',ie,'  (',iclpro,')',engy
7388            do iia=1,7
7389             matarg=2**(iia-1)
7390             latarg=min(1,matarg/2)
7391 c            fctrmx=max(ftcrmxsave,float(matarg))          !to get stable pA and AA cross section, this number has to be large for large A
7392             ntevt=0
7393             nrevt=0
7394             pnll=-1.
7395             elab=-1.
7396             ecms=-1.
7397             ekin=-1.
7398             call conini
7399             call ainit
7400             nevent=50000
7401             if(matarg.eq.1)nevent=1
7402             call epocrossc(nevent,sigt,sigi,sigc,sige,sigql,sigd)
7403 c do not count non-excited diffractive projectile in inelastic
7404             sigi3=sigi-sigql
7405             if(ish.ge.1)write (ifch,228)matarg,sigi,sigi3
7406  228        format(2x,'simul.: hadron-nucleus (',i3,') cross sections:'/
7407      *       4x,'gin,gin3=',2e10.3)
7408             write(ifmt,*)'  matarg,sigi,sigi3 :',matarg,sigi,sigi3
7409             asect21(ie,iclpro,iia)=log(sigi)
7410             asect23(ie,iclpro,iia)=log(sigi3)
7411 c            do  n=1,nevent
7412 c              ntry=0
7413 c 222          ntevt=ntevt+1
7414 c              iret=0
7415 c              ntry=ntry+1
7416 c              bimevt=-1.
7417 c              if(ntry.lt.10000)then
7418 cc if random sign for projectile, set it here
7419 c                idproj=idprojin*(1-2*int(rangen()+0.5d0))
7420 c                call emsaaa(iret)
7421 c                if(iret.gt.0)goto 222
7422 c              else
7423 c                ntevt=ntry
7424 c              endif
7425 c            enddo
7426 c            a=pi*bmax**2
7427 c            if(a.gt.0..and.ntevt.gt.0.)then
7428 c             xs=anintine/float(ntevt)*a*10.
7429 c             write(ifmt,*)'  matarg,nevent,ntevt,bmax,xs :'
7430 c     .       ,matarg,anintine,ntevt,bmax,xs
7431 c             write(ifch,*)'  matarg,nevent,ntevt,bmax,xs :'
7432 c     .       ,matarg,anintine,ntevt,bmax,xs
7433 c             asect2(ie,iclpro,iia)=log(xs)
7434 c            else
7435 c             write(ifmt,*)' Problem ? ',iclpro,matarg,bmax,ntevt
7436 c             asect2(ie,iclpro,iia)=0.
7437 c            endif
7438           enddo
7439         enddo
7440         else
7441           do ie=1,7
7442             do iia=1,7
7443               asect21(ie,iclpro,iia)=0.
7444               asect23(ie,iclpro,iia)=0.
7445             enddo
7446           enddo
7447         endif
7448        endif
7449       enddo
7450 
7451       idprojin=1120
7452       iclpro=2
7453       icltar=2
7454       do ie=1,7
7455         engy=1.5*10.**(ie-1)
7456         call paramini(0)
7457         bkmxndif=conbmxndif()
7458         if(ish.ge.1)
7459      &  write(ifch,*)'  calcul. AB  ',ie,engy
7460         write(ifmt,*)'  calcul. AB  ',ie,engy
7461 
7462         do iia=1,7
7463           maproj=2**(iia-1)
7464           laproj=max(1,maproj/2)
7465         do iib=1,7
7466           matarg=2**(iib-1)
7467           latarg=max(1,matarg/2)
7468           sigine=0.
7469           if(matarg.eq.1.and.maproj.eq.1)then !proton-proton interaction
7470 c ine=cut+diff
7471             call psfz(2,gz2,0.)
7472             gin=gz2*pi*10.
7473 c cut
7474             iomegasave=iomega
7475             iomega=2
7476             call psfz(2,gz2,0.)
7477             iomega=iomegasave
7478             gcut=gz2*pi*10.
7479 c diff
7480             difpart=gin-gcut
7481 c  non excited projectile and target
7482             gqela=(1.-rexdif(iclpro))*(1.-rexdif(icltar))*difpart
7483             gin3=max(1.,gin-gqela)              
7484           else
7485             call conini
7486             if(maproj.eq.1)then
7487               rad=radnuc(matarg)
7488               bm=rad+2.
7489               rrr=rad/difnuc(matarg)
7490               rrrm=rrr+log(9.)
7491               anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matarg)**2
7492 c              gela=(ptgau(ptfau,bm,2,1)+ptgau1(bm,2,1))*10. !sig_ela
7493 c in=cut+diff
7494               gcut=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig_in
7495               gin=gcut
7496 c cut
7497               iomegasave=iomega
7498               iomega=2
7499               gcut=(ptgau(ptfau,bm,2,2)+ptgau1(bm,2,2))*10. !sig_cut
7500               iomega=iomegasave
7501 c diff
7502               difpart=gin-gcut
7503 c  non excited projectile
7504               gqela=(1.-rexdif(iclpro))
7505      &             **(1.+rexres(iclpro)*float(matarg-1)**0.3)
7506 c  non excited target
7507               gqela=gqela*(1.-rexdif(icltar))**(1.+float(matarg)**0.3)
7508               gqela=gqela*difpart
7509               gin3=max(1.,gin-gqela)
7510             elseif(matarg.eq.1)then
7511               radp=radnuc(maproj)
7512               bm=radp+2.
7513               rrrp=radp/difnuc(maproj)
7514               rrrmp=rrrp+log(9.)
7515               anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(maproj)**2
7516 c              gtot=(ptgau(ptfau,bm,1,1)+ptgau1(bm,1,1))*10. !sig_in
7517 c in=cut+diff
7518               gcut=(ptgau(ptfau,bm,1,2)+ptgau1(bm,1,2))*10. !sig_in
7519               gin=gcut     !in=cut+diff
7520 c cut
7521               iomegasave=iomega
7522               iomega=2
7523               gcut=(ptgau(ptfau,bm,1,2)+ptgau1(bm,1,2))*10. !sig_cut
7524               iomega=iomegasave
7525 c diff
7526               difpart=gin-gcut
7527 c  non excited projectile
7528               gqela=(1.-rexdif(iclpro))**(1.+float(maproj)**0.3)
7529 c  non excited target
7530               gqela=gqela*(1.-rexdif(icltar))
7531      &             **(1.+rexres(icltar)*float(maproj-1)**0.3)
7532               gqela=gqela*difpart
7533               gin3=max(1.,gin-gqela)
7534             else
7535               rad=radnuc(matarg)+1.
7536               radp=radnuc(maproj)+1.
7537               bm=rad+radp+2.
7538               rrr=rad/difnuc(matarg)
7539               rrrm=rrr+log(9.)
7540               rrrp=radp/difnuc(maproj)
7541               rrrmp=rrrp+log(9.)
7542               anorm=1.5/pi/rrr**3/(1.+(pi/rrr)**2)/difnuc(matarg)**2
7543               anormp=1.5/pi/rrrp**3/(1.+(pi/rrrp)**2)/difnuc(maproj)**2
7544 c ine=cut+diff
7545 c              gtot=(ptgau(ptfauAA,bm,2,1)+ptgau2(bm,1))*10.
7546               gcut=(ptgau(ptfauAA,bm,2,2)+ptgau2(bm,2))*10.
7547 c              gin=gtot
7548               gin=gcut
7549 c cut
7550               iomegasave=iomega
7551               iomega=2
7552               gcut=(ptgau(ptfauAA,bm,2,2)+ptgau2(bm,2))*10. !sig_cut
7553               iomega=iomegasave
7554 c diff
7555               difpart=gin-gcut
7556 c  non excited projectile
7557               gqelap=(1.-rexdif(iclpro))
7558      &             **(1.+rexres(iclpro)*float(matarg-1)**0.3)
7559               gqelap=gqelap**(1.+float(maproj)**0.3)
7560 c  non excited target
7561               gqelat=(1.-rexdif(icltar))
7562      &             **(1.+rexres(icltar)*float(maproj-1)**0.3)
7563               gqelat=gqelat**(1.+float(maproj)**0.3)
7564               gqela=gqelap*gqelat*difpart
7565               gin3=gin-gqela
7566             endif
7567           endif
7568           if(ish.ge.1)write (ifch,227)maproj,matarg,gin,gin3
7569  227      format(2x,'psaini: nucleus-nucleus (',i3,'-',i3
7570      *       ,') cross sections:',/,4x,'gin,gin3=',2e10.3)
7571             write(ifmt,*)'  maproj,matarg,gin,gin3 :'
7572      *       ,maproj,matarg,gin,gin3
7573             asect31(ie,iia,iib)=log(gin)
7574             asect33(ie,iia,iib)=log(gin3)
7575 
7576           enddo
7577         enddo
7578       enddo
7579 
7580       if(isetcssave.ge.3)then
7581 
7582       do ie=1,7
7583         engy=1.5*10.**(ie-1)
7584         if(engy.le.egymin)engy=egymin
7585         if(engy.ge.egymax)engy=egymax
7586         write(ifmt,*)'  AB xs   ',ie,engy
7587         if(ish.ge.1)
7588      &  write(ifch,*)'  AB xs   ',ie,engy
7589         do iia=1,7
7590           maproj=2**(iia-1)
7591           laproj=max(1,maproj/2)
7592         do iib=1,7
7593           matarg=2**(iib-1)
7594           latarg=max(1,matarg/2)
7595 c          fctrmx=max(ftcrmxsave,float(max(maproj,matarg))) !to get stable pA and AA cross section, this number has to be large for large A
7596           ntevt=0
7597           nrevt=0
7598           pnll=-1.
7599           elab=-1.
7600           ecms=-1.
7601           ekin=-1.
7602           call conini
7603           call ainit
7604           nevent=10000
7605           if(maproj+matarg.eq.2)nevent=1
7606           call epocrossc(nevent,sigt,sigi,sigc,sige,sigql,sigd)
7607 c do not count non-excited diffractive projectile in inelastic
7608           sigi3=sigi-sigql
7609           if(ish.ge.1)write (ifch,229)maproj,matarg,sigi,sigi3
7610  229      format(2x,'simul.: nucleus-nucleus (',i3,'-',i3
7611      *       ,') cross sections:',/,4x,'gin,gin3=',2e10.3)
7612          write(ifmt,*)'  maproj,matarg,sigi,sigi3 :',maproj,matarg
7613      &                                               ,sigi,sigi3
7614           asect41(ie,iia,iib)=log(sigi)
7615           asect43(ie,iia,iib)=log(sigi3)
7616 
7617 c          do  n=1,nevent
7618 c            ntry=0
7619 c 223        ntevt=ntevt+1
7620 c            iret=0
7621 c            ntry=ntry+1
7622 c            bimevt=-1.
7623 c            if(ntry.lt.10000)then
7624 c              call emsaaa(iret)
7625 c              if(iret.gt.0)goto 223
7626 c            else
7627 c              ntevt=ntry
7628 c            endif
7629 c          enddo
7630 c          a=pi*bmax**2
7631 c          if(a.gt.0..and.ntevt.gt.0.)then
7632 c            xs=anintine/float(ntevt)*a*10.
7633 c          write(ifmt,*)'  maproj,matarg,nevent,ntevt,bmax,xs :'
7634 c     &                         ,maproj,matarg,anintine,ntevt,bmax,xs
7635 c          write(ifch,*)'  maproj,matarg,nevent,ntevt,bmax,xs :'
7636 c     &                         ,maproj,matarg,anintine,ntevt,bmax,xs
7637 c            asect4(ie,iia,iib)=log(xs)
7638 c          else
7639 c            write(ifmt,*)' Problem ? ',maproj,matarg,bmax,ntevt
7640 c            asect4(ie,iia,iib)=0.
7641 c          endif
7642         enddo
7643       enddo
7644       enddo
7645       else
7646         do ie=1,7
7647           do iia=1,7
7648             do iib=1,7
7649               asect41(ie,iia,iib)=0.
7650               asect43(ie,iia,iib)=0.
7651             enddo
7652           enddo
7653         enddo
7654       endif
7655 
7656       ifrade=ifradesave
7657       iremn=iremnsave
7658       idproj=idprojsave
7659       idprojin=idprojinsave
7660       idtarg=idtargsave
7661       idtargin=idtarginsave
7662       laproj=laprojsave
7663       latarg=latargsave
7664       maproj=maprojsave
7665       matarg=matargsave
7666       icltar=icltarsave
7667       iclpro=iclprosave
7668       engy=engysave
7669       pnll=pnllsave
7670       elab=elabsave
7671       ecms=ecmssave
7672       iclegy=iclegysave
7673       nrevt=nrevtsave
7674       nevent=neventsave
7675       ntevt=ntevtsave
7676       isetcs=isetcssave
7677       noebin=noebinsave
7678       isigma=isigmasave
7679       bminim=bminimsave
7680       bmaxim=bmaximsave
7681       bimevt=bimevtsave
7682       bkmxndif=bkmxndifsave
7683       ionudi=ionudisave
7684 c      fctrmx=fctrmxsave
7685       inicnt=1
7686 
7687       write(ifmt,'(a)')'write to inics ...'
7688       open(1,file=fncs,status='unknown')
7689       write (1,*)alpqua,alplea,alppom,slopom,gamhad,r2had,chad,
7690      *qcdlam,q2min,q2ini,betpom,glusea,naflav,factk,pt2cut
7691       write(1,*)isetcs,iclpro1,iclpro2,icltar1,icltar2,iclegy1,iclegy2
7692      *,egylow,egymax,iomega,egyscr,epscrw,epscrp
7693       write (1,*)asect11,asect13,asect21,asect23
7694      *          ,asect31,asect33,asect41,asect43
7695 
7696       close(1)
7697 
7698 
7699       goto 6
7700 
7701  7    continue
7702 
7703       endif !----------isetcs.ge.2-----------
7704 
7705       endif
7706 
7707       call utprix('psaini',ish,ishini,4)
7708 
7709       return
7710       end
7711 
7712 cc-----------------------------------------------------------------------
7713 c      function fjetxx(jpp,je1,je2)
7714 cc-----------------------------------------------------------------------
7715 cc   almost exactly psjet, just with Eqcd replaced by fparton
7716 cc    for testing
7717 cc   gives indeed the same result as jetx
7718 cc   so the integration seems correct
7719 cc-----------------------------------------------------------------------
7720 c      double precision xx1,xx2,s2min,xmin,xmax,xmin1,xmax1,t,tmin
7721 c     *,tmax,sh,z,qtmin,ft,fx1,fx2
7722 c      common /ar3/   x1(7),a1(7)
7723 c      common /ar9/ x9(3),a9(3)
7724 c      include 'epos.inc'
7725 c      include 'epos.incsem'
7726 c
7727 c      fjetxx=0.
7728 c      s=engy*engy
7729 c      s2min=4.d0*q2min
7730 c
7731 c      zmin=s2min/dble(s)
7732 c      zmax=1
7733 c
7734 c      zmin=zmin**(-delh)
7735 c      zmax=zmax**(-delh)
7736 c      do i=1,3
7737 c      do m=1,2
7738 c        z=dble(.5*(zmax+zmin+(zmin-zmax)*(2*m-3)*x9(i)))**(-1./delh)
7739 c        xmin=dsqrt(z)
7740 c        sh=z*dble(s)
7741 c        qtmin=max(dble(q2min),dble(q2ini)/(1.d0-dsqrt(z)))
7742 c        tmin=max(0.d0,1.d0-4.d0*qtmin/sh)
7743 c        tmin=2.d0*qtmin/(1.d0+dsqrt(tmin))
7744 c        tmax=sh/2.d0
7745 c        ft=0.d0
7746 c        do i1=1,3
7747 c        do m1=1,2
7748 c          t=2.d0*tmin/(1.d0+tmin/tmax-dble(x9(i1)*(2*m1-3))
7749 c     &    *(1.d0-tmin/tmax))
7750 c          qt=t*(1.d0-t/sh)
7751 c          xmax=1.d0-q2ini/qt
7752 c          xmin=max(dsqrt(z),z/xmax)   !xm<xp !!!
7753 c          if(xmin.gt.xmax.and.ish.ge.1)write(ifmt,*)'fjetxx:xmin,xmax'
7754 c     *                                              ,xmin,xmax
7755 c          fx1=0.d0
7756 c          fx2=0.d0
7757 c          if(xmax.gt..8d0)then
7758 c            xmin1=max(xmin,.8d0)
7759 c            do i2=1,3
7760 c            do m2=1,2
7761 c              xx1=1.d0-(1.d0-xmax)*((1.d0-xmin1)/(1.d0-xmax))**
7762 c     *        dble(.5+x9(i2)*(m2-1.5))
7763 c              xx2=z/xx1
7764 c                fb=ffsigj(sngl(t),qt,sngl(xx1),sngl(xx2),jpp,je1,je2)
7765 c     *       +ffsigj(sngl(t),qt,sngl(xx2),sngl(xx1),jpp,je1,je2)
7766 c              fx1=fx1+dble(a9(i2)*fb)*(1.d0/xx1-1.d0)
7767 c     *                               *pssalf(qt/qcdlam)**2
7768 c            enddo
7769 c            enddo
7770 c            fx1=fx1*dlog((1.d0-xmin1)/(1.d0-xmax))
7771 c          endif
7772 c          if(xmin.lt..8d0)then
7773 c            xmax1=min(xmax,.8d0)
7774 c            do i2=1,3
7775 c            do m2=1,2
7776 c              xx1=xmin*(xmax1/xmin)**dble(.5+x9(i2)*(m2-1.5))
7777 c              xx2=z/xx1
7778 c
7779 c              fb=0.
7780 c              fb=fb
7781 c     *             +ffsigj(sngl(t),qt,sngl(xx1),sngl(xx2),jpp,je1,je2)
7782 c     *       +ffsigj(sngl(t),qt,sngl(xx2),sngl(xx1),jpp,je1,je2)
7783 c              fx2=fx2+dble(a9(i2))*fb*pssalf(qt/qcdlam)**2
7784 c            enddo
7785 c            enddo
7786 c            fx2=fx2*dlog(xmax1/xmin)
7787 c          endif
7788 c          ft=ft+dble(a9(i1))*(fx1+fx2)*t**2
7789 c        enddo
7790 c        enddo
7791 c        ft=ft*(1.d0/tmin-1.d0/tmax)
7792 c        fjetxx=fjetxx+a9(i)*sngl(ft*z**(1.+delh)/sh**2)
7793 c     *          /z  ! ffsig = xp f xm f sigma
7794 c      enddo
7795 c      enddo
7796 c      fjetxx=fjetxx*(zmin-zmax)/delh*pi**3
7797 c  !   *         /2.   !???????????????  kkkkkkkkk
7798 c      return
7799 c      end
7800 c
7801 c