Back to home page

Project CMSSW displayed by LXR

 
 

    


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

0001 C======================================================================C
0002 C                                                                      C
0003 C     QQQ        GGG      SSSS    JJJJJJJ   EEEEEEE   TTTTTTT     I I  C
0004 C    Q   Q      G   G    S    S         J   E            T        I I  C
0005 C   Q     Q    G         S              J   E            T        I I  C
0006 C   Q     Q    G   GGG    SSSS          J   EEEEE        T    ==  I I  C
0007 C   Q   Q Q    G     G        S         J   E            T        I I  C
0008 C    Q   Q      G   G    S    S    J   J    E            T        I I  C
0009 C     QQQQQ      GGG      SSSS      JJJ     EEEEEEE      T        I I  C
0010 C                                                                      C
0011 C                                                                      C
0012 C----------------------------------------------------------------------C
0013 C                                                                      C
0014 C                  QUARK - GLUON - STRING - JET - II MODEL             C
0015 C                                                                      C
0016 C                HIGH ENERGY HADRON INTERACTION PROGRAM                C
0017 C                                                                      C
0018 C                                  BY                                  C
0019 C                                                                      C
0020 C                           S. OSTAPCHENKO                             C
0021 C                                                                      C
0022 C Institute for Physics, Norwegian University for Science & Tech       C
0023 C D.V. Skobeltsyn Institute of Nuclear Physics, Moscow State UniversityC
0024 C                  e-mail: sergei@tf.phys.ntnu.no                      C
0025 C----------------------------------------------------------------------C
0026 C         Publication to be cited when using this program:             C
0027 C         S. Ostapchenko, Phys. Rev. D 83 (2011) 014018                C
0028 C----------------------------------------------------------------------C
0029 C                        LIST OF MODIFICATIONS                         C
0030 C                                                                      C
0031 C (Any modification of this program has to be approved by the author)  C
0032 C                                                                      C
0033 C 24.01.2005 - beta-version completed (qgsjet-II-01)                   C
0034 C 12.04.2005 - final version (qgsjet-II-02)                            C
0035 C 12.12.2005 - technical update -  version II-03:                      C
0036 C    improved treatment of Pomeron cuts (all "net" cuts included);     C
0037 C    improved treatment of nuclear config. (more consistent diffr.);   C
0038 C    "baryon junction" mechanism included (motivated by RHIC data);    C
0039 C    better parameter calibration, e.g. including RHIC data            C
0040 C 21.02.2006 - some commons enlarged to avoid frequent rejects  D.H.   C
0041 C 26.04.2006 - reduce unnecessary looping in qgsha              D.H.   C
0042 C                                                                      C
0043 C 01.10.2010 - new version  (qgsjet-II-04, not released):              C
0044 C   treating all enhanced diagrams (incuding 'Pomeron loops');         C
0045 C   calibration to LHC data on multiparticle production;               C
0046 C   a number of cosmetic improvements,                                 C
0047 C   e.g. more efficient simulation procedure (a factor of ~10 win)     C
0048 C                                                                      C
0049 C 26.06.2012 - final version (qgsjet-II-04):                           C
0050 C additional parameter retuning applied                                C
0051 C (mainly to TOTEM data on total/elastic pp cross sections);           C
0052 C remnant treatment for pion-hadron/nucleus collisions improved        C
0053 C                                                                      C
0054 C                 last modification:  26.06.2012                       C
0055 C                 Version qgsjet-II-04 (for CONEX)                     C
0056 C                                                                      C
0057 C small corrections to adapt to CORSIKA : 25.07.2012 by T.Pierog       C
0058 C=======================================================================
0059 
0060 
0061 
0062 c=============================================================================
0063       subroutine qgset
0064 c-----------------------------------------------------------------------------
0065 c common model parameters setting
0066 c-----------------------------------------------------------------------------
0067       implicit double precision (a-h,o-z)
0068       integer debug
0069       character*7 ty
0070       character*2 tyq
0071       parameter(iapmax=208)
0072       common /qgarr1/  ia(2),icz,icp
0073       common /qgarr2/  scm,wp0,wm0
0074       common /qgarr3/  rmin,emax,eev
0075       common /qgarr6/  pi,bm,amws
0076       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
0077       common /qgarr8/  wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
0078       common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
0079       common /qgarr11/ b10
0080       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
0081       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
0082       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
0083       common /qgarr18/ alm,qt0,qtf,betp,dgqq
0084       common /qgarr19/ ahl(3)
0085       common /qgarr20/ spmax
0086       common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
0087       common /qgarr28/ arr(5)
0088       common /qgarr26/ factk,fqscal
0089       common /qgarr41/ ty(6)
0090       common /qgarr42/ tyq(16)
0091       common /qgarr43/ moniou
0092       common /qgarr51/ epsxmn
0093       common /opt/     jopt
0094       common /qgdebug/ debug
0095       common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3)  !used to link with nexus
0096      *,bqgs,bmaxqgs,bmaxnex,bminnex
0097 
0098       moniou=6             !output channel for debugging
0099       debug=0              !debugging level
0100                            !(0 - no debugging, 1 - very geheral,
0101                            !2 - more detailed, 3 - all function calls,
0102                            !4 - all returned values, 5 - technical)
0103       if(debug.ge.1)write (moniou,210)
0104 
0105       bqgs=0.d0            !used to link with nexus
0106       bmaxqgs=0.d0         !used to link with nexus
0107       bmaxnex=-1.d0        !used to link with nexus
0108       bminnex=0.d0         !used to link with nexus
0109 
0110       jopt=1               !parameter option
0111 
0112       if(jopt.eq.1)then       !tunable parameters
0113 c soft Pomeron parameters
0114        dels=.165d0            !overcriticality
0115        alfp=.135d0            !trajectory slope
0116        sigs=1.01d0            !soft parton cross section
0117 c coupling to DGLAP
0118        qt0=3.d0               !q**2 cutoff
0119        betp=2.2d0             !gluon distribution hardness for soft Pomeron
0120        dgqq=.16d0             !sea quark/gluon relative weight
0121 c multi-Pomeron vertex parameters
0122        r3p=.0076d0            !triple-Pomeron coupling (/4/pi)
0123        g3p=.35d0              !factor for multu-Pomeron couplings
0124        sgap=exp(1.5d0)        !minimal rap-gap between 3P-vertices
0125 c Pomeron-hadron coupling
0126        rq(1,1)=1.d0           !pion: vertex slope for 1st diffr. eigenst.
0127        rq(2,1)=.15d0          !pion: vertex slope for 2nd diffr. eigenst.
0128        cd(1,1)=1.75d0         !pion: relat. strenth for 1st diffr. eigenst.
0129        rq(1,2)=2.52d0         !proton: vertex slope for 1st diffr. eigenst.
0130        rq(2,2)=.2d0           !proton: vertex slope for 2nd diffr. eigenst.
0131        cd(1,2)=1.58d0         !proton: relat. strenth for 1st diffr. eigenst.
0132        rq(1,3)=.75d0          !kaon: vertex slope for 1st diffr. eigenst.
0133        rq(2,3)=.15d0          !kaon: vertex slope for 2nd diffr. eigenst.
0134        cd(1,3)=1.75d0         !kaon: relat. strenth for 1st diffr. eigenst.
0135 
0136 c parameters for soft/hard fragmentation:
0137 
0138        qtf=.15d0              !q**2 cutoff for timelike cascades
0139        almpt=1.5d0            !string fragmentation parameter
0140        wwm=1.d0               !switching to 2-particle string decay (threshold)
0141 c leading state exponents
0142        ahl(1)=0.d0            !pion
0143        ahl(2)=1.3d0           !proton
0144        ahl(3)=-0.5            !kaon
0145 c remnant excitation probabilities
0146        wex(1)=.5d0            !pion
0147        wex(2)=.4d0            !proton
0148        wex(3)=.5d0            !kaon
0149 c dc(i) - relative probabilities for qq~(qqq~q~)-pair creation from vacuum
0150        dc(1)=.077d0           !udu~d~
0151        dc(2)=.08d0            !ss~
0152        dc(4)=.4d0             !ss~ (intrinsic)
0153 c be(i) - parameters for pt-distributions
0154        be(1)=.225d0           !uu~(dd~)
0155        be(2)=.43d0            !qqq~q~
0156        be(3)=.48d0            !ss~
0157        ptdif=.15d0            !diffractive momentum transfer
0158        ptndi=.19d0            !non-diffractive momentum transfer
0159 
0160 c parameters for nuclear spectator part fragmentation:
0161 
0162        rmin=3.35d0    !coupling radius squared (fm^2)
0163        emax=.11d0     !relative critical energy ( / <E_ex>, <E_ex>~12.5 MeV )
0164        eev=.25d0      !relative evaporation energy ( / <E_ex>, <E_ex>~12.5 MeV )
0165 
0166       else
0167        stop'wrong option!!!'
0168       endif
0169 
0170       do i=1,3         !relative strenth of 2nd diffr. eigenst. [2-CD(1,icz)]
0171        cd(2,i)=2.d0-cd(1,i)
0172       enddo
0173 
0174 !other parameters and constants:
0175 
0176       spmax=1.d11             !max energy squared for tabulations
0177       delh=0.25d0             !effective exponent for weighting (technical)
0178       epsxmn=.01d0            !pt-resolution scale (technical)
0179       alm=.04d0               !lambda_qcd squared
0180       factk=1.5d0             !k-factor value
0181       fqscal=4.d0             !factor for fact. scale (Mf^2=p_t^2/fqscal)
0182       deta=.11111d0           !ratio of etas production to all pions (1/9)
0183       dc(3)=.000d0            !to switch off charmed particles set to 0.000
0184       dc(5)=.0d0              !to switch off charmed particles set to 0.000
0185 c weigts for diffractive eigenstates
0186       cc(1,1)=.5d0            !pion
0187       cc(2,1)=.5d0
0188       cc(1,2)=.5d0            !proton
0189       cc(2,2)=.5d0
0190       cc(1,3)=.5d0            !kaon
0191       cc(2,3)=.5d0
0192 c auxiliary constants
0193       b10=.43876194d0         !initial value of the pseudorandom sequence
0194       pi=3.1416d0             !pi-value
0195       amws=.523d0             !diffusive radius for saxon-wood density
0196 c regge intercepts for the uu~, qqq~q~, us~, uc~ trajectories
0197       arr(1)=0.5d0            !qq~-trajectory
0198       arr(2)=-0.5d0           !qqq~q~-trajectory
0199       arr(3)=0.d0             !us~-trajectory
0200 c lowest resonance masses for low-mass excitations
0201       dmmin(1)=.76d0          !rho
0202       dmmin(2)=1.23d0         !delta
0203       dmmin(3)=.89d0          !K*
0204 c mass and width for resonance contribution to low mass diffraction
0205       dmres(1)=1.23d0         !pion
0206       dmres(2)=1.44d0         !proton
0207       dmres(3)=1.27d0         !kaon
0208       wdres(1)=.3d0           !pion
0209       wdres(2)=.3d0           !proton
0210       wdres(3)=.1d0           !kaon
0211 c proton, kaon, pion, d-meson, lambda, lambda_c, eta masses
0212       amn=0.93827999
0213       amk=.496d0
0214       am0=.14d0
0215       amc=1.868d0
0216       amlam=1.116d0
0217       amlamc=2.27d0
0218       ameta=.548d0
0219       ammu=.1057d0
0220 c initial particle classes
0221       ty(1)='pion   '
0222       ty(2)='nucleon'
0223       ty(3)='kaon   '
0224 c parton types
0225       tyq(1)='DD'
0226       tyq(2)='UU'
0227       tyq(3)='C '
0228       tyq(4)='S '
0229       tyq(5)='UD'
0230       tyq(6)='D '
0231       tyq(7)='U '
0232       tyq(8)='g '
0233       tyq(9)='u '
0234       tyq(10)='d '
0235       tyq(11)='ud'
0236       tyq(12)='s '
0237       tyq(13)='c '
0238       tyq(14)='uu'
0239       tyq(15)='dd'
0240       if(debug.ge.2)write (moniou,202)
0241 
0242 210   format(2x,'qgset - common model parameters setting')
0243 202   format(2x,'qgset - end')
0244       return
0245       end
0246 
0247 c=============================================================================
0248       subroutine qgaini( DATDIR )
0249 c-----------------------------------------------------------------------------
0250 c common initialization procedure
0251 c-----------------------------------------------------------------------------
0252       implicit double precision (a-h,o-z)
0253       CHARACTER DATDIR*(132)
0254       real qggamfun
0255       integer debug
0256       character *7 ty
0257       logical lcalc
0258       parameter(iapmax=208)
0259       dimension mij(40,40,4),nij(40,40,4),cs1(40,40,160)
0260      *,evs(40,100,3,2),ixemax(40,3,2),gz0(5),gz1(3)
0261      *,qfan0(11,14),qfan2(11,11,3),fann(14)
0262       common /qgarr1/  ia(2),icz,icp
0263       common /qgarr2/  scm,wp0,wm0
0264       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
0265      *,cr1(2),cr2(2),cr3(2)
0266       common /qgarr6/  pi,bm,amws
0267       common /qgarr10/ am(7),ammu
0268       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
0269       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
0270       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
0271       common /qgarr18/ alm,qt0,qtf,betp,dgqq
0272       common /qgarr19/ ahl(3)
0273       common /qgarr20/ spmax
0274       common /qgarr24/ qpomr(11,11,216,12,2)
0275       common /qgarr25/ ahv(3)
0276       common /qgarr26/ factk,fqscal
0277       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
0278      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
0279       common /qgarr28/ arr(5)
0280       common /qgarr29/ cstot(40,40,160)
0281       common /qgarr30/ cs0(40,40,160)
0282       common /qgarr31/ csborn(40,160)
0283       common /qgarr33/ fsud(10,2)
0284       common /qgarr34/ qrt(10,101,2)
0285       common /qgarr35/ qlegc0(51,10,11,6,8),qlegc(51,10,11,11,30)
0286       common /qgarr38/ qpomc(11,100,11,11,48)
0287       common /qgarr39/ qpomi(51,11,15),qpomis(51,11,11,11,9)
0288       common /qgarr41/ ty(6)
0289       common /qgarr43/ moniou
0290       common /qgarr47/ gsect(10,5,6)
0291       common /qgarr48/ qgsasect(10,6,6)
0292       common /qgarr51/ epsxmn
0293       common /qgarr52/ evk(40,40,100,3,2)
0294 c auxiliary common blocks to calculate hadron-nucleus cross-sections
0295       common /arr1/   trnuc(56),twsnuc(56),twbnuc(56)
0296       common /arr3/   x1(7),a1(7)
0297       common /opt/    jopt
0298       common /qgdebug/debug
0299       character*500 fnIIdat,fnIIncs                        !used to link with nexus
0300       common /version/ version                             !used to link with nexus
0301       common/qgsIIfname/fnIIdat, fnIIncs, ifIIdat, ifIIncs !used to link with nexus
0302       common/qgsIInfname/ nfnIIdat, nfnIIncs               !used to link with nexus
0303       common/producetab/ producetables              !used to link with CRMC
0304       logical producetables
0305 
0306       if(debug.ge.1)write (moniou,210)
0307       version = 204
0308 
0309 c-------------------------------------------------
0310       write(*,100)
0311  100  format(' ',
0312      *           '====================================================',
0313      *     /,' ','|                                                  |',
0314      *     /,' ','|         QUARK GLUON STRING JET -II MODEL         |',
0315      *     /,' ','|                                                  |',
0316      *     /,' ','|         HADRONIC INTERACTION MONTE CARLO         |',
0317      *     /,' ','|                        BY                        |',
0318      *     /,' ','|                 S. OSTAPCHENKO                   |',
0319      *     /,' ','|                                                  |',
0320      *     /,' ','|             e-mail: sergei@tf.phys.ntnu.no       |',
0321      *     /,' ','|                                                  |',
0322      *     /,' ','|                   Version II-04                  |',
0323      *     /,' ','|                                                  |',
0324      *     /,' ','| Publication to be cited when using this program: |',
0325      *     /,' ','| S.Ostapchenko, PRD 83 (2011) 014018              |',
0326      *     /,' ','|                                                  |',
0327      *     /,' ','| last modification:  26.06.2012                   |',
0328      *     /,' ','|                                                  |',
0329      *     /,' ','| Any modification has to be approved by the author|',
0330      *     /,' ','====================================================',
0331      *     /)
0332 
0333 
0334 c-----------------------------------------------------------------------------
0335 c normalization of parton density in the soft pomeron
0336       rr=qggamfun(real(2.d0+betp-dels))/qggamfun(real(1.d0-dels))
0337      */qggamfun(real(1.d0+betp))/4.d0/pi
0338 
0339       ahv(1)=.383d0+.624d0*dlog(dlog(qt0/.204d0**2)
0340      */dlog(.26d0/.204d0**2))
0341       ahv(3)=ahv(1)
0342       sq=dlog(dlog(qt0/.232d0**2)/dlog(.23d0/.232d0**2))
0343       ahv(2)=2.997d0+.753d0*sq-.076d0*sq*sq
0344 c valence quark momentum share
0345       qnorm1=0.d0
0346       do i=1,7
0347       do m=1,2
0348        tp=1.d0-(.5d0+x1(i)*(m-1.5d0))**(2.d0/3.d0)
0349        xp=1.d0-tp**(1.d0/(1.d0+ahv(1)))
0350        qnorm1=qnorm1+a1(i)*(qggrv(xp,qt0,1,1)+qggrv(xp,qt0,1,2))
0351      * /dsqrt(1.d0-tp)
0352       enddo
0353       enddo
0354       qnorm1=qnorm1/(1.d0+ahv(1))/3.d0
0355       qnorm2=0.d0
0356       do i=1,7
0357       do m=1,2
0358        tp=1.d0-(.5d0+x1(i)*(m-1.5d0))**(2.d0/3.d0)
0359        xp=1.d0-tp**(1.d0/(1.d0+ahv(2)))
0360        qnorm2=qnorm2+a1(i)*(qggrv(xp,qt0,2,1)+qggrv(xp,qt0,2,2))
0361      * /dsqrt(1.d0-tp)
0362       enddo
0363       enddo
0364       qnorm2=qnorm2/(1.d0+ahv(2))/3.d0
0365 c fp(i) - pomeron vertex constant (i=icz)
0366       fp(2)=(1.d0-qnorm2)*(2.d0+ahl(2))*(1.d0+ahl(2))
0367 
0368       gnorm=0.d0
0369       seanrm=0.d0
0370       do i=1,7
0371       do m=1,2
0372        xxg=(.5d0+x1(i)*(m-1.5d0))**(1.d0/(1.d0-dels))
0373        gnorm=gnorm+a1(i)*qgftld(xxg,2)
0374        seanrm=seanrm+a1(i)*qgftle(xxg,2)
0375       enddo
0376       enddo
0377       gnorm=gnorm/(1.d0-dels)*fp(2)*rr*2.d0*pi
0378       seanrm=seanrm/(1.d0-dels)*fp(2)*rr*2.d0*pi
0379       if(debug.ge.1)write (moniou,*)'rr,fp,norm,qnorm2,gnorm,seanrm'
0380      *,rr,fp(2),qnorm2+gnorm+seanrm,qnorm2,gnorm,seanrm
0381 
0382       do icz=1,3,2
0383        fp(icz)=(1.d0-qnorm1)*(2.d0+ahl(icz))*(1.d0+ahl(icz))
0384        gnorm=0.d0
0385        seanrm=0.d0
0386        do i=1,7
0387        do m=1,2
0388         xxg=(.5d0+x1(i)*(m-1.5d0))**(1.d0/(1.d0-dels))
0389         gnorm=gnorm+a1(i)*qgftld(xxg,icz)
0390         seanrm=seanrm+a1(i)*qgftle(xxg,icz)
0391        enddo
0392        enddo
0393        gnorm=gnorm/(1.d0-dels)*fp(icz)*rr*2.d0*pi
0394        seanrm=seanrm/(1.d0-dels)*fp(icz)*rr*2.d0*pi
0395 
0396        if(debug.ge.1)write (moniou,*)'fp,norm,qnorm1,gnorm,seanrm'
0397      * ,fp(icz),qnorm1+gnorm+seanrm,qnorm1,gnorm,seanrm
0398       enddo
0399 
0400       do icz=1,3
0401        gsoft(icz)=fp(icz)*fp(2)*sigs*4.d0*.0389d0
0402      * *qggamfun(real(1.d0+dels))**2*qggamfun(real(1.d0+ahl(icz)))
0403      * *qggamfun(real(1.d0+ahl(2)))/qggamfun(real(2.d0+dels+ahl(icz)))
0404      * /qggamfun(real(2.d0+dels+ahl(2)))
0405       enddo
0406 
0407 c-----------------------------------------------------------------------------
0408 c reading cross sections from the file
0409       if(ifIIdat.ne.1)then
0410        inquire(file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
0411      *        ,exist=lcalc)
0412       else
0413        inquire(file=fnIIdat(1:nfnIIdat),exist=lcalc)       !used to link with nexus
0414       endif
0415       lzmaUse=0
0416       if(lcalc)then
0417          if(ifIIdat.ne.1)then
0418             open(1,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
0419      *           ,status='old')
0420          else                   !used to link with nexus
0421             if (LEN(fnIIdat).gt.6.and.
0422      *           fnIIdat(nfnIIdat-4:nfnIIdat) .eq. ".lzma") then
0423                lzmaUse=1
0424                call LzmaOpenFile(fnIIdat(1:nfnIIdat))
0425             else
0426                open(ifIIdat,file=fnIIdat(1:nfnIIdat),status='old')
0427             endif
0428          endif
0429 
0430        if (lzmaUse.ne.0) then
0431 
0432           if(debug.ge.0)write (moniou,214) 'qgsdat-II-04.lzma'
0433 
0434           call LzmaFillArray(csborn,size(csborn))
0435           call LzmaFillArray(cs0,size(cs0))
0436           call LzmaFillArray(cstot,size(cstot))
0437           call LzmaFillArray(evk,size(evk))
0438           call LzmaFillArray(qpomi,size(qpomi))
0439           call LzmaFillArray(qpomis,size(qpomis))
0440           call LzmaFillArray(qlegi,size(qlegi))
0441           call LzmaFillArray(qfanu,size(qfanu))
0442           call LzmaFillArray(qfanc,size(qfanc))
0443           call LzmaFillArray(qdfan,size(qdfan))
0444           call LzmaFillArray(qpomr,size(qpomr))
0445           call LzmaFillArray(gsect,size(gsect))
0446           call LzmaFillArray(qlegc0,size(qlegc0))
0447           call LzmaFillArray(qlegc,size(qlegc))
0448           call LzmaFillArray(qpomc,size(qpomc))
0449           call LzmaFillArray(fsud,size(fsud))
0450           call LzmaFillArray(qrt,size(qrt))
0451           call LzmaFillArray(qrev,size(qrev))
0452           call LzmaFillArray(fsud,size(fsud))
0453           call LzmaFillArray(qrt,size(qrt))
0454           call LzmaCloseFile()
0455        else
0456           if(debug.ge.0)write (moniou,214) 'qgsdat-II-04'
0457           read (1,*)csborn,cs0,cstot,evk,qpomi,qpomis,qlegi,qfanu,qfanc
0458      *         ,qdfan,qpomr,gsect,qlegc0,qlegc,qpomc,fsud,qrt,qrev,fsud,
0459      *         qrt
0460           close(1)
0461        endif
0462 
0463        if(debug.ge.0)write (moniou,*)'done'
0464        goto 10
0465       elseif(.not.producetables)then
0466         write(moniou,*) "Missing QGSDAT-II-04 file !"        
0467         write(moniou,*) "Please correct the defined path ",
0468      &"or force production ..."
0469         stop
0470       endif
0471 
0472 c--------------------------------------------------
0473 c qcd evolution and qcd ladder cross sections
0474 c--------------------------------------------------
0475       if(debug.ge.0)write (moniou,201)
0476       do i=1,40
0477       do m=1,3
0478       do k=1,2
0479        ixemax(i,m,k)=99
0480       do j=1,40
0481       do l=1,100
0482        evk(i,j,l,m,k)=0.d0
0483       enddo
0484       enddo
0485       enddo
0486       enddo
0487       enddo
0488 
0489       n=1
0490 1     n=n+1
0491       do m=1,3
0492       do k=1,2
0493        if(m.ne.3.or.k.ne.1)then
0494         do i=1,39
0495          if(ixemax(i,m,k).gt.0)then
0496           qi=spmax**((i-1)/39.d0)
0497           qq=qi*(spmax/qi)**(1.d0/39.d0)
0498           do l=1,99
0499            if(l.le.37)then
0500             xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
0501            elseif(l.le.69)then
0502             xx=.1d0+.8d0*(l-37.d0)/32.d0
0503            else
0504             xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
0505            endif
0506 
0507            ev=qgev(qi,qq,qq,xx,m,k)/qgfap(xx,m,k)
0508            if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
0509             evs(i,l,m,k)=dlog(1.d0+ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
0510      *      /dlog(dlog(qq/alm)/dlog(qi/alm)))
0511            else
0512             evs(i,l,m,k)=dlog(1.d0+ev/.3d0*(dlog(epsxmn)+.75d0)
0513      *      /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
0514            endif
0515           enddo
0516          endif
0517         enddo
0518        endif
0519       enddo
0520       enddo
0521 
0522       jec=0
0523       do m=1,3
0524       do k=1,2
0525        if(m.ne.3.or.k.ne.1)then
0526         do i=1,39
0527          if(ixemax(i,m,k).gt.0)then
0528           qi=spmax**((i-1)/39.d0)
0529           qq=qi*(spmax/qi)**(1.d0/39.d0)
0530           imx=ixemax(i,m,k)
0531           do l=imx,1,-1
0532            if(l.le.37)then
0533             xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
0534            elseif(l.le.69)then
0535             xx=.1d0+.8d0*(l-37.d0)/32.d0
0536            else
0537             xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
0538            endif
0539 
0540            if(abs(evs(i,l,m,k)-evk(i,2,l,m,k)).gt.1.d-3)then
0541             evk(i,2,l,m,k)=evs(i,l,m,k)
0542             jec=1
0543            elseif(ixemax(i,m,k).eq.l)then
0544             ixemax(i,m,k)=l-1
0545            endif
0546           enddo
0547          endif
0548         enddo
0549        endif
0550       enddo
0551       enddo
0552 
0553       do i=1,39
0554        qi=spmax**((i-1)/39.d0)
0555        qj=qi*(spmax/qi)**(1.d0/39.d0)
0556        qq=qi*(spmax/qi)**(2.d0/39.d0)
0557        do l=99,1,-1
0558         if(l.le.37)then
0559          xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
0560         elseif(l.le.69)then
0561          xx=.1d0+.8d0*(l-37.d0)/32.d0
0562         else
0563          xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
0564         endif
0565         do m=1,3
0566         do k=1,2
0567          if(m.ne.3.or.k.ne.1)then
0568           ev=(qgev(qi,qj,qq,xx,m,k)
0569      *    +qgevi(qi,qj,xx,m,k)*qgsudx(qq,k)/qgsudx(qj,k)
0570      *    +qgevi(qj,qq,xx,m,k)*qgsudx(qj,m)/qgsudx(qi,m))/qgfap(xx,m,k)
0571           if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
0572            evk(i,3,l,m,k)=dlog(ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
0573      *     /dlog(dlog(qq/alm)/dlog(qi/alm)))
0574           else
0575            evk(i,3,l,m,k)=dlog(ev/.3d0*(dlog(epsxmn)+.75d0)
0576      *     /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
0577           endif
0578          endif
0579         enddo
0580         enddo
0581        enddo
0582       enddo
0583       if(jec.ne.0)goto 1
0584 
0585       do i=1,39
0586        qi=spmax**((i-1)/39.d0)
0587       do j=4,40
0588        qj=qi*(spmax/qi)**((j-2)/39.d0)
0589        qq=qi*(spmax/qi)**((j-1)/39.d0)
0590        do l=99,1,-1
0591         if(l.le.37)then
0592          xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
0593         elseif(l.le.69)then
0594          xx=.1d0+.8d0*(l-37.d0)/32.d0
0595         else
0596          xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
0597         endif
0598         do m=1,3
0599         do k=1,2
0600          if(m.ne.3.or.k.ne.1)then
0601           ev=(qgev(qi,qj,qq,xx,m,k)
0602      *    +qgevi(qi,qj,xx,m,k)*qgsudx(qq,k)/qgsudx(qj,k)
0603      *    +qgevi(qj,qq,xx,m,k)*qgsudx(qj,m)/qgsudx(qi,m))/qgfap(xx,m,k)
0604           if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
0605            evk(i,j,l,m,k)=dlog(ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
0606      *     /dlog(dlog(qq/alm)/dlog(qi/alm)))
0607           else
0608            evk(i,j,l,m,k)=dlog(ev/.3d0*(dlog(epsxmn)+.75d0)
0609      *     /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
0610           endif
0611          endif
0612         enddo
0613         enddo
0614        enddo
0615       enddo
0616       enddo
0617 
0618 c--------------------------------------------------
0619 c qcd ladder cross sections
0620       do i=1,40
0621        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)  !q^2 cutoff for born process
0622        s2min=qi*4.d0*fqscal          !energy threshold for 2->2 subprocess
0623       do m=1,2                                !parton types (1-g, 2-q)
0624       do l=1,2                                !parton types (1-g, 2-q)
0625        l1=2*l-1
0626       do k=1,40
0627        sk=s2min*(spmax/s2min)**((k-1)/39.d0)  !c.m. energy squared
0628        k1=k+40*(m-1)+80*(l-1)
0629        csborn(i,k1)=dlog(qgborn(qi,qi,sk,m-1,l1-1)) !born cross-section (2->2)
0630        if(.not.(csborn(i,k1).ge.0.d0.or.csborn(i,k1).lt.0.d0))stop
0631       enddo
0632       enddo
0633       enddo
0634       enddo
0635 
0636       do i=1,40
0637        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0638       do j=1,40
0639        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0640        s2min=qj*4.d0*fqscal
0641        smin=s2min/(1.d0-epsxmn)
0642       do m=1,2
0643       do l=1,2
0644        l1=2*l-1
0645        ml=m+2*l-2
0646       do k=1,40
0647        sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0648        k1=k+40*(m-1)+80*(l-1)
0649 
0650        tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0651        sjtot=qgjett(qi,qj,sk,m-1,l-1)
0652        sjord1=qgjeto(qi,qj,sk,m-1,l-1)
0653        sjord2=qgjeto(qj,qi,sk,l-1,m-1)
0654        born=qgborn(qi,qj,sk,m-1,l1-1)
0655        if(k.eq.1.or.j.eq.40.or.i.eq.40.or.sk.le.smin)then
0656         cstot(i,j,k1)=dlog(born)
0657         cs0(i,j,k1)=cstot(i,j,k1)
0658        else
0659         cstot(i,j,k1)=dlog(born+(sjtot+sjord1+sjord2)
0660      *  /(1.d0/tmin-2.d0/sk))
0661         cs0(i,j,k1)=dlog(born+sjord1/(1.d0/tmin-2.d0/sk))
0662        endif
0663        if(.not.(cstot(i,j,k1).ge.0.d0.or.cstot(i,j,k1).lt.0.d0))stop
0664        if(.not.(cs0(i,j,k1).ge.0.d0.or.cs0(i,j,k1).lt.0.d0))stop
0665       enddo
0666       enddo
0667       enddo
0668       enddo
0669       enddo
0670       goto 3
0671 
0672 c--------------------------------------------------
0673 c alternative calculation (not used)
0674       do i=1,40
0675        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0676       do j=1,40
0677        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0678        s2min=qj*4.d0*fqscal
0679       do m=1,2
0680       do l=1,2
0681        l1=2*l-1
0682        ml=m+2*l-2
0683       do k=1,40
0684        sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0685        k1=k+40*(m-1)+80*(l-1)
0686        cstot(i,j,k1)=dlog(qgborn(qi,qj,sk,m-1,l1-1))
0687        cs0(i,j,k1)=cstot(i,j,k1)
0688        mij(i,j,ml)=2
0689        nij(i,j,ml)=2
0690       enddo
0691       enddo
0692       enddo
0693       enddo
0694       enddo
0695 
0696       n=2                             !number of ladder rungs considered
0697 2     if(debug.ge.1)write (moniou,202)n,mij(1,1,1),nij(1,1,1)
0698       do i=1,39
0699        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)       !q^2 for upper parton
0700       do j=1,39
0701        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0) !q^2 for downer parton
0702        s2min=qj*4.d0*fqscal                !energy threshold for 2->2 subprocess
0703        smin=s2min/(1.d0-epsxmn)            !energy threshold for 2->3 subprocess
0704       do m=1,2                                     !parton types (1-g, 2-q)
0705       do l=1,2                                     !parton types (1-g, 2-q)
0706        l1=2*l-1
0707        ml=m+2*l-2
0708        kmin=nij(i,j,ml)                  !lowest energy bin for another rung
0709        if(kmin.le.40)then
0710         do k=kmin,40
0711          sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0712          if(sk.le.smin)then
0713           nij(i,j,ml)=nij(i,j,ml)+1
0714          else
0715           k1=k+40*(m-1)+80*(l-1)
0716           tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0717           cs1(i,j,k1)=dlog(qgjet1(qi,qj,sk,s2min,m,l)
0718      *    /(1.d0/tmin-2.d0/sk)+qgborn(qi,qj,sk,m-1,l1-1))
0719          endif
0720         enddo
0721        endif
0722       enddo
0723       enddo
0724       enddo
0725       enddo
0726 
0727       do i=1,39
0728        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0729       do j=1,39
0730        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0731        s2min=qj*4.d0*fqscal
0732       do m=1,2
0733       do l=1,2
0734        ml=m+2*l-2
0735        kmin=nij(i,j,ml)
0736        if(kmin.le.40)then
0737         do k=40,kmin,-1
0738          sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0739          tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0740          k1=k+40*(m-1)+80*(l-1)
0741          if(abs(cs1(i,j,k1)-cs0(i,j,k1)).gt.1.d-2)then
0742           cs0(i,j,k1)=cs1(i,j,k1)
0743          elseif(k.eq.nij(i,j,ml))then
0744           nij(i,j,ml)=nij(i,j,ml)+1
0745          endif
0746         enddo
0747        endif
0748       enddo
0749       enddo
0750       enddo
0751       enddo
0752 
0753       do i=1,39
0754        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0755       do j=1,39
0756        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0757        s2min=qj*4.d0*fqscal         !min energy squared for 2->2 subprocess
0758        smin=s2min/(1.d0-epsxmn)     !min energy squared for 2->3 subprocess
0759       do m=1,2
0760       do l=1,2
0761        ml=m+2*l-2
0762        kmin=mij(i,j,ml)             !min energy bin for more ladder rungs
0763        if(kmin.le.40)then
0764         do k=kmin,40
0765          sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0766          if(sk.le.smin)then
0767           mij(i,j,ml)=mij(i,j,ml)+1
0768          else
0769           k1=k+40*(m-1)+80*(l-1)
0770           tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0771           cs1(i,j,k1)=dlog((qgjet(qi,qj,sk,s2min,m,l)
0772      *    +qgjit1(qj,qi,sk,l,m))/(1.d0/tmin-2.d0/sk))
0773          endif
0774         enddo
0775        endif
0776       enddo
0777       enddo
0778       enddo
0779       enddo
0780 
0781 c--------------------------------------------------
0782 c check convergence
0783       do i=1,39
0784        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
0785       do j=1,39
0786        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
0787        s2min=qj*4.d0*fqscal
0788       do m=1,2
0789       do l=1,2
0790        ml=m+2*l-2
0791        kmin=mij(i,j,ml)             !min energy bin for more ladder rungs
0792        if(kmin.le.40)then
0793         do k=40,kmin,-1
0794          sk=s2min*(spmax/s2min)**((k-1)/39.d0)
0795          tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
0796          k1=k+40*(m-1)+80*(l-1)
0797          if(abs(cs1(i,j,k1)-cstot(i,j,k1)).gt.1.d-2)then
0798           cstot(i,j,k1)=cs1(i,j,k1)
0799          elseif(k.eq.mij(i,j,ml))then
0800           mij(i,j,ml)=mij(i,j,ml)+1
0801          endif
0802         enddo
0803        endif
0804       enddo
0805       enddo
0806       enddo
0807       enddo
0808 
0809       n=n+1                         !one more rung
0810       do i=1,39
0811       do j=1,39
0812       do l=1,4
0813        if(mij(i,j,l).le.40.or.nij(i,j,l).le.40)goto 2
0814       enddo
0815       enddo
0816       enddo
0817 
0818 3     if(debug.ge.2)write (moniou,205)
0819 c-------------------------------------------------
0820 c itermediate Pomeron
0821       if(debug.ge.1)write (moniou,210)
0822       s2min=4.d0*fqscal*qt0
0823       do iy=1,51
0824        sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
0825        rp=alfp*log(sy)*4.d0*.0389d0
0826       do iz=1,11
0827        if(iz.gt.6)then
0828         z=.2d0*(iz-6)
0829         b=sqrt(-log(z)*rp)
0830        else
0831         b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0832         z=exp(-b*b/rp)
0833        endif
0834 
0835        qpomi(iy,iz,1)=dlog(qgpint(sy,b*b)
0836      * /sy**dels/sigs/z*rp/4.d0/.0389d0+1.d0)
0837       enddo
0838       enddo
0839 
0840 c-------------------------------------------------
0841 c loop contribution
0842       do iy=1,51
0843        sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
0844        rp=alfp*log(sy)*4.d0*.0389d0
0845       do iz=1,11
0846        if(iz.gt.6)then
0847         z=.2d0*(iz-6)
0848         b=sqrt(-log(z)*rp)
0849        else
0850         b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0851         z=exp(-b*b/rp)
0852        endif
0853       do iqq=2,4
0854        qpomi(iy,iz,iqq)=qpomi(iy,iz,1)
0855       enddo
0856       enddo
0857       enddo
0858 
0859       do iy=2,51
0860        sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
0861        rp=alfp*log(sy)*4.d0*.0389d0
0862        do iz=1,11
0863        do iqq=2,4
0864         qpomi(iy,iz,iqq)=qpomi(iy-1,iz,iqq)
0865        enddo
0866        enddo
0867        n=0
0868 4      n=n+1
0869        nrep=0
0870        do iz=1,11
0871         if(iz.gt.6)then
0872          z=.2d0*(iz-6)
0873          b=sqrt(-log(z)*rp)
0874         else
0875          b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0876          z=exp(-b*b/rp)
0877         endif
0878         call qgloop(sy,b*b,fann,1)
0879         do iqq=1,3
0880          if(fann(iqq).gt.0.d0)then
0881           qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
0882      *    /4.d0/.0389d0)
0883          elseif(iy.gt.2)then
0884           qfan0(iz,iqq)=min(2.d0*qpomi(iy-1,iz,iqq+1)
0885      *    -qpomi(iy-2,iz,iqq+1),qpomi(iy-1,iz,iqq+1))
0886          else
0887           stop'loop<0: iy=2'
0888          endif
0889          if(qfan0(iz,iqq).lt.-20.d0)then
0890           qfan0(iz,iqq)=-20.d0
0891          endif
0892          if(abs(qfan0(iz,iqq)-qpomi(iy,iz,iqq+1)).gt.1.d-3)nrep=1
0893         enddo
0894        enddo
0895        do iz=1,11
0896         if(iz.gt.6)then
0897          z=.2d0*(iz-6)
0898          b=sqrt(-log(z)*rp)
0899         else
0900          b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0901          z=exp(-b*b/rp)
0902         endif
0903        do iqq=2,4
0904         qpomi(iy,iz,iqq)=qfan0(iz,iqq-1)
0905         if(.not.(qpomi(iy,iz,iqq).le.0.d0
0906      *  .or.qpomi(iy,iz,iqq).gt.0.d0))stop'qpom-nan'
0907        enddo
0908        enddo
0909        if(nrep.eq.1.and.n.lt.100)goto 4
0910       enddo
0911 
0912 c-------------------------------------------------
0913 c cut loops
0914       do iy=1,51
0915       do iz=1,11
0916        do iqq=5,7
0917         qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-3)
0918        enddo
0919        qpomi(iy,iz,8)=qpomi(iy,iz,2)
0920        do iqq=9,10
0921         qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-7)
0922         qpomi(iy,iz,iqq+2)=qpomi(iy,iz,iqq-7)
0923        enddo
0924        do iqq=13,15
0925         qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-11)
0926        enddo
0927       enddo
0928       enddo
0929 
0930       do iy=2,51
0931        sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
0932        rp=alfp*log(sy)*4.d0*.0389d0
0933        do iz=1,11
0934        do iqq=5,15
0935         qpomi(iy,iz,iqq)=qpomi(iy-1,iz,iqq)
0936        enddo
0937        enddo
0938        n=0
0939 5      n=n+1
0940        nrep=0
0941        do iz=1,11
0942         if(iz.gt.6)then
0943          z=.2d0*(iz-6)
0944          b=sqrt(-log(z)*rp)
0945         else
0946          b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0947          z=exp(-b*b/rp)
0948         endif
0949         call qgloop(sy,b*b,fann,2)
0950         do iqq=4,14
0951          if(fann(iqq).gt.0.d0)then
0952           qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
0953      *    /4.d0/.0389d0)
0954          elseif(iy.gt.2)then
0955           qfan0(iz,iqq)=min(2.d0*qpomi(iy-1,iz,iqq+1)
0956      *    -qpomi(iy-2,iz,iqq+1),qpomi(iy-1,iz,iqq+1))
0957          else
0958           stop'loop<0: iy=2'
0959          endif
0960          if(qfan0(iz,iqq).lt.-20.d0)then
0961           qfan0(iz,iqq)=-20.d0
0962          endif
0963          if(abs(qfan0(iz,iqq)-qpomi(iy,iz,iqq+1)).gt.1.d-3)nrep=1
0964         enddo
0965        enddo
0966        do iz=1,11
0967         if(iz.gt.6)then
0968          z=.2d0*(iz-6)
0969          b=sqrt(-log(z)*rp)
0970         else
0971          b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
0972          z=exp(-b*b/rp)
0973         endif
0974        do iqq=5,15
0975         qpomi(iy,iz,iqq)=qfan0(iz,iqq-1)
0976         if(.not.(qpomi(iy,iz,iqq).le.0.d0
0977      *  .or.qpomi(iy,iz,iqq).gt.0.d0))stop'qpomi-nan'
0978        enddo
0979        enddo
0980        if(nrep.eq.1.and.n.lt.50)goto 5
0981       enddo
0982 
0983 c-------------------------------------------------
0984 c cut loops with proj/targ screening corrections
0985       do iv=1,11
0986        vvx=dble(iv-1)/10.d0
0987       do iv1=1,11
0988        vvxt=dble(iv1-1)/10.d0
0989 
0990        do iz=1,11
0991         do iqq=1,8
0992          qpomis(1,iz,iv,iv1,iqq)=0.d0
0993         enddo
0994         qpomis(1,iz,iv,iv1,1)=qpomi(1,iz,1)
0995         qpomis(1,iz,iv,iv1,4)=qpomi(1,iz,1)
0996        enddo
0997 
0998        do iy=2,51
0999         sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1000         rp=alfp*log(sy)*4.d0*.0389d0
1001         do iz=1,11
1002         do iqq=1,8
1003          qpomis(iy,iz,iv,iv1,iqq)=qpomis(iy-1,iz,iv,iv1,iqq)
1004         enddo
1005         enddo
1006 
1007         n=0
1008 6       n=n+1
1009         nrep=0
1010         do iz=1,11
1011          if(iz.gt.6)then
1012           z=.2d0*(iz-6)
1013           b=sqrt(-log(z)*rp)
1014          else
1015           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1016           z=exp(-b*b/rp)
1017          endif
1018          call qgloos(sy,b*b,vvx,vvxt,fann)
1019          vi=qgpini(sy,b*b,0.d0,0.d0,2)
1020          vic=min(vi,qgpini(sy,b*b,0.d0,0.d0,8))
1021          vicng=min(vic,qgpini(sy,b*b,0.d0,0.d0,11))
1022          do iqq=1,8
1023           if(fann(iqq).gt.0.d0)then
1024            if(iqq.eq.1.or.iqq.eq.4)then
1025             qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
1026      *      /4.d0/.0389d0)
1027            elseif(iqq.eq.3)then
1028             qfan0(iz,iqq)=dlog(fann(iqq)/(.5d0*max(0.d0,1.d0
1029      *      -exp(-2.d0*vic)*(1.d0+2.d0*vic))+vicng*exp(-2.d0*vic)))
1030            elseif(iqq.gt.6)then
1031             qfan0(iz,iqq)=dlog(fann(iqq)*2.d0/((1.d0-exp(-vi))**2
1032      *      +(exp(2.d0*(vi-vic))-1.d0)*exp(-2.d0*vi)))
1033            else
1034             qfan0(iz,iqq)=dlog(fann(iqq)/(1.d0-exp(-vi)))
1035            endif
1036           elseif(iy.gt.2)then
1037            qfan0(iz,iqq)=min(2.d0*qpomis(iy-1,iz,iv,iv1,iqq)
1038      *     -qpomis(iy-2,iz,iv,iv1,iqq),qpomis(iy-1,iz,iv,iv1,iqq))
1039           else
1040            qfan0(iz,iqq)=qpomis(iy-1,iz,iv,iv1,iqq)
1041           endif
1042           if(iqq.gt.5)qfan0(iz,iqq)=min(qfan0(iz,iqq),qfan0(iz,iqq-1))
1043           qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
1044           if(abs(qfan0(iz,iqq)-qpomis(iy,iz,iv,iv1,iqq)).gt.1.d-3)
1045      *    nrep=1
1046          enddo
1047         enddo
1048 
1049         do iz=1,11
1050          if(iz.gt.6)then
1051           z=.2d0*(iz-6)
1052           b=sqrt(-log(z)*rp)
1053          else
1054           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1055           z=exp(-b*b/rp)
1056          endif
1057          do iqq=1,8
1058           qpomis(iy,iz,iv,iv1,iqq)=qfan0(iz,iqq)
1059           if(iqq.eq.1.or.iqq.eq.4)then
1060            dpx=exp(qpomis(iy,iz,iv,iv1,iqq))*g3p**2*sigs
1061      *     *sy**dels*z/rp*4.d0*.0389d0
1062           else
1063            dpx=exp(qpomis(iy,iz,iv,iv1,iqq))
1064           endif
1065          enddo
1066         enddo
1067         if(nrep.eq.1.and.n.lt.50)goto 6
1068        enddo
1069       enddo
1070       enddo
1071 
1072 c-------------------------------------------------
1073 c integrated Pomeron leg eikonals
1074       if(debug.ge.1)write (moniou,212)
1075       do icz=1,3
1076       do icdp=1,2
1077        if(cd(icdp,icz).ne.0.d0)then
1078         do iy=1,51
1079          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1080          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1081         do iz=1,11
1082          if(iz.gt.6)then
1083           z=.2d0*(iz-6)
1084           b=sqrt(-log(z)*rp)
1085          else
1086           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1087           z=exp(-b*b/rp)
1088          endif
1089 
1090          qxl=qgleg(sy,b*b,icdp,icz)
1091          qlegi(iy,iz,icdp,icz,1)=log(qxl/z)
1092         enddo
1093         enddo
1094        endif
1095       enddo
1096       enddo
1097 
1098 c-------------------------------------------------
1099 c loop-legs
1100       do icz=1,3
1101       do icdp=1,2
1102        if(cd(icdp,icz).ne.0.d0)then
1103         do iy=1,51
1104          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1105          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1106         do iz=1,11
1107          if(iz.gt.6)then
1108           z=.2d0*(iz-6)
1109           b=sqrt(-log(z)*rp)
1110          else
1111           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1112           z=exp(-b*b/rp)
1113          endif
1114          if(iy.eq.1)then
1115           do iqq=2,7
1116            qlegi(iy,iz,icdp,icz,iqq)=qlegi(iy,iz,icdp,icz,1)
1117           enddo
1118          else
1119           call qglool(sy,b*b,icdp,icz,fann)
1120           do iqq=2,7
1121            if(fann(iqq-1).gt.0.d0)then
1122             qlegi(iy,iz,icdp,icz,iqq)=log(fann(iqq-1)/z)
1123            else
1124             qlegi(iy,iz,icdp,icz,iqq)=2.d0*qlegi(iy-1,iz,icdp,icz,iqq)
1125      *      -qlegi(iy-2,iz,icdp,icz,iqq)
1126            endif
1127            qlegi(iy,iz,icdp,icz,iqq)=max(qlegi(iy,iz,icdp,icz,iqq)
1128      *     ,-20.d0)
1129            if(.not.(qlegi(iy,iz,icdp,icz,iqq).le.0.d0
1130      *     .or.qlegi(iy,iz,icdp,icz,iqq).gt.0.d0))stop'leg-nan'
1131           enddo
1132          endif
1133         enddo
1134         enddo
1135        endif
1136       enddo
1137       enddo
1138 
1139 c-------------------------------------------------
1140 c uncut fan-contributions
1141       if(debug.ge.1)write (moniou,213)
1142       do icz=1,3
1143       do iv=1,11
1144        vvx=dble(iv-1)/10.d0
1145       do icdp=1,2
1146        if(cd(icdp,icz).ne.0.d0)then
1147         do iy=1,51
1148         do iz=1,11
1149         do iqq=1,2
1150          qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)=qlegi(iy,iz,icdp,icz,iqq+1)
1151         enddo
1152         enddo
1153         enddo
1154 
1155         do iy=2,51
1156          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1157          rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
1158          do iz=1,11
1159          do iqq=1,2
1160           qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)
1161      *    =qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
1162          enddo
1163          enddo
1164 
1165          n=1
1166 7        n=n+1
1167          nrep=0
1168          do iz=1,11
1169           if(iz.gt.6)then
1170            z=.2d0*dble(iz-6)
1171            b=dsqrt(-dlog(z)*rp)
1172           else
1173            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1174            z=dexp(-b*b/rp)
1175           endif
1176           call qgfan(sy,b*b,vvx,icdp,icz,fann)
1177           do iqq=1,2
1178            if(fann(iqq).gt.0.d0)then
1179             qfan0(iz,iqq)=dlog(fann(iqq)/z)
1180            else
1181             qfan0(iz,iqq)=min(qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
1182      *      ,2.d0*qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
1183      *      -qfanu(iy-2,iz,iv,icdp+2*(icz-1),iqq))
1184            endif
1185            qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
1186            if(abs(qfan0(iz,iqq)-qfanu(iy,iz,iv,icdp+2*(icz-1),iqq))
1187      *     .gt.1.d-3)nrep=1
1188           enddo
1189          enddo
1190 
1191          do iz=1,11
1192          do iqq=1,2
1193           qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)=qfan0(iz,iqq)
1194          enddo
1195          enddo
1196          if(nrep.eq.1)goto 7
1197 
1198          do iz=1,11
1199          do iqq=1,2
1200           if(iz.gt.6)then
1201            z=.2d0*dble(iz-6)
1202            b=dsqrt(-dlog(z)*rp)
1203           else
1204            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1205            z=dexp(-b*b/rp)
1206           endif
1207           if(.not.(qfanu(iy,iz,iv,icdp+2*(icz-1),iqq).le.0.d0
1208      *    .or.qfanu(iy,iz,iv,icdp+2*(icz-1),iqq).gt.0.d0))stop'fan-nn'
1209          enddo
1210          enddo
1211         enddo
1212        endif
1213       enddo
1214       enddo
1215       enddo
1216 
1217 c-------------------------------------------------
1218 c cut fan contributions
1219       if(debug.ge.1)write (moniou,215)
1220       do icz=1,3                                !hadron class
1221       do icdp=1,2                                 !diffractive eigenstate
1222        if(cd(icdp,icz).ne.0.d0)then
1223 c vvx,vvxp,vvxpl - screening corrections from targ. and nuclear proj. fans
1224         do iv=1,11
1225          vvx=dble(iv-1)/10.d0
1226         do iv1=1,1+5*(icz-1)*(3-icz)
1227          vvxp=dble(iv1-1)/5.d0
1228         do iv2=1,1+5*(icz-1)*(3-icz)
1229          vvxpl=vvx*dble(iv2-1)/5.d0
1230         do iy=1,51                                !initialization
1231         do iz=1,11
1232          do iqq=1,9
1233           qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp
1234      *    +2*(iqq-1))=qfanu(iy,iz,iv,icdp+2*(icz-1),1)
1235          enddo
1236         enddo
1237         enddo
1238 
1239         do iy=2,51
1240          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1241          rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
1242          do iz=1,11
1243          do iqq=1,9
1244           qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp
1245      *    +2*(iqq-1))=qfanc(iy-1,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1
1246      *    +6*(iv2-1)),icdp+2*(iqq-1))
1247          enddo
1248          enddo
1249 
1250          n=1
1251 8        n=n+1                          !number of t-channel iterations
1252          nrep=0
1253          do iz=1,11
1254           if(iz.gt.6)then
1255            z=.2d0*dble(iz-6)
1256            b=dsqrt(-dlog(z)*rp)
1257           else
1258            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1259            z=dexp(-b*b/rp)
1260           endif
1261           call qgfanc(sy,b*b,vvx,vvxp,vvxpl,icdp,icz,fann)
1262           fann(7)=min(fann(7),fann(8))
1263           do iqq=1,9
1264            if(fann(iqq).gt.0.d0)then
1265             qfan0(iz,iqq)=dlog(fann(iqq)/z)
1266            else
1267             qfan0(iz,iqq)=min(2.d0*qfanc(iy-1,iz,iv,icz
1268      *      +(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1))
1269      *      -qfanc(iy-2,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
1270      *      ,icdp+2*(iqq-1)),qfanc(iy-1,iz,iv,icz
1271      *      +(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1)))
1272            endif
1273            qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
1274           enddo
1275          enddo
1276 
1277          do iz=1,11
1278          do iqq=1,9
1279           if(abs(qfan0(iz,iqq)-qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)
1280      *    *(iv1+1+6*(iv2-1)),icdp+2*(iqq-1))).gt.1.d-3)nrep=1
1281           qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
1282      *    ,icdp+2*(iqq-1))=qfan0(iz,iqq)
1283          enddo
1284          enddo
1285          if(nrep.eq.1.and.n.lt.50)goto 8
1286 
1287          do iz=1,11
1288           if(iz.gt.6)then
1289            z=.2d0*dble(iz-6)
1290            b=dsqrt(-dlog(z)*rp)
1291           else
1292            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1293            z=dexp(-b*b/rp)
1294           endif
1295          do iqq=1,9
1296           if(.not.(qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
1297      *    ,icdp+2*(iqq-1)).le.0.d0.or.qfanc(iy,iz,iv,icz+(icz-1)
1298      *    *(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1)).gt.0.d0))
1299      *    stop'fanc-nan'
1300          enddo
1301          enddo
1302         enddo
1303         enddo
1304         enddo
1305         enddo
1306        endif
1307       enddo
1308       enddo
1309 
1310 c-------------------------------------------------
1311 c zigzag fans
1312       do icz=1,3                                  !hadron class
1313       do icdp=1,2                                 !diffractive eigenstate
1314        if(cd(icdp,icz).ne.0.d0)then
1315         do iy=1,11
1316          sy=sgap**2*(spmax/sgap**2)**((iy-1)/10.d0)
1317          rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
1318         do iz=1,11
1319          if(iz.gt.6)then
1320           z=.2d0*dble(iz-6)
1321           bb=-dlog(z)*rp
1322          else
1323           bb=-rp*(dlog(0.2d0)+2.d0*dble(iz-7))
1324           z=dexp(-bb/rp)
1325          endif
1326         do iv=1,11
1327          vvxt0=dble(iv-1)/10.d0
1328         do iv1=1,6
1329          vvxt=vvxt0+(1.d0-vvxt0)*dble(iv1-1)/5.d0
1330         do iv2=1,1+5*(icz-1)*(3-icz)
1331          vvxpt=dble(iv2-1)/5.d0
1332         do iv3=1,1+5*(icz-1)*(3-icz)
1333          vvxp0=vvxpt*dble(iv3-1)/5.d0
1334         do iv4=1,1+5*(icz-1)*(3-icz)
1335          vvxpl=dble(iv4-1)/5.d0
1336 
1337          dfan=qgrev(sy,bb,vvxt0,vvxt,vvxpt,vvxp0,vvxpl,icdp,icz)
1338          if(dfan.gt.0.d0)then
1339           qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)
1340      *    *(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp)=dlog(dfan/z)
1341          else
1342           qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1
1343      *    +6*(iv3-1)+36*(iv4-1)),icdp)=2.d0*qrev(iy-1,iz,iv+11*(iv1-1)
1344      *    ,icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp)
1345      *    -qrev(iy-2,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1
1346      *    +6*(iv3-1)+36*(iv4-1)),icdp)
1347          endif
1348          qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)
1349      *   +36*(iv4-1)),icdp)=max(qrev(iy,iz,iv+11*(iv1-1),icz
1350      *   +(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp),-20.d0)
1351 
1352          if(.not.(qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)
1353      *   *(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp).le.0.d0.or.qrev(iy,iz
1354      *   ,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)
1355      *   +36*(iv4-1)),icdp).gt.0.d0))stop'fanc-nan'
1356         enddo
1357         enddo
1358         enddo
1359         enddo
1360         enddo
1361         enddo
1362         enddo
1363        endif
1364       enddo
1365       enddo
1366 
1367 c-------------------------------------------------
1368 c diffractive fans
1369       icz=2
1370       do icdp=1,2
1371        if(cd(icdp,icz).ne.0.d0)then
1372         do iy=1,21
1373          xpomr=(1.d5/sgap**2)**(-dble(iy-1)/20.d0)/sgap**2
1374           rp=(rq(icdp,icz)-alfp*dlog(xpomr))*2.d0*.0389d0
1375          if(iy.gt.1)then
1376           do iy1=1,11
1377           do iz=1,11
1378           do iqq=1,3
1379            qdfan(iy,iy1,iz,icdp,iqq)=qdfan(iy-1,iy1,iz,icdp,iqq)
1380           enddo
1381           enddo
1382           enddo
1383          endif
1384 
1385          n=0
1386 9        n=n+1
1387          nrep=0
1388          do iy1=1,11
1389           xpomr1=(xpomr*sgap**2)**(dble(11-iy1)/10.d0)/sgap
1390          do iz=1,11
1391           if(iz.gt.6)then
1392            z=.2d0*dble(iz-6)
1393            b=dsqrt(-dlog(z)*rp)
1394           else
1395            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1396            z=dexp(-b*b/rp)
1397           endif
1398           call qgdfan(xpomr,xpomr1,b*b,icdp,fann,n)
1399           do iqq=1,3
1400            if(fann(iqq).gt.0.d0)then
1401             qfan2(iy1,iz,iqq)=dlog(fann(iqq)/z)
1402            else
1403             qfan2(iy1,iz,iqq)=qfan2(iy1-1,iz,iqq)
1404            endif
1405            if(n.gt.1.and.abs(qfan2(iy1,iz,iqq)
1406      *     -qdfan(iy,iy1,iz,icdp,iqq)).gt.1.d-3)nrep=1
1407           enddo
1408          enddo
1409          enddo
1410 
1411          do iy1=1,11
1412          do iz=1,11
1413          do iqq=1,3
1414           qdfan(iy,iy1,iz,icdp,iqq)=qfan2(iy1,iz,iqq)
1415          enddo
1416          enddo
1417          enddo
1418          if((n.eq.1.or.nrep.eq.1).and.iy.gt.1)goto 9
1419 
1420          do iy1=1,11
1421           xpomr1=(xpomr*sgap**2)**(dble(11-iy1)/10.d0)/sgap
1422           do iz=1,11
1423            if(iz.gt.6)then
1424             z=.2d0*dble(iz-6)
1425             b=dsqrt(-dlog(z)*rp)
1426            else
1427             b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
1428             z=dexp(-b*b/rp)
1429            endif
1430            do iqq=1,3
1431             if(iqq.ne.3)then
1432              dpx=dexp(qdfan(iy,iy1,iz,icdp,iqq))*z
1433             else
1434              dpx=dexp(qdfan(iy,iy1,iz,icdp,iqq))*z
1435      *       *dlog(xpomr1/xpomr/sgap)
1436             endif
1437             if(.not.(qdfan(iy,iy1,iz,icdp,iqq).le.0.d0
1438      *      .or.qdfan(iy,iy1,iz,icdp,iqq).gt.0.d0))stop'qdfan-nan'
1439            enddo
1440           enddo
1441          enddo
1442         enddo
1443        endif
1444       enddo
1445 
1446 c-------------------------------------------------
1447 c integrated Pomeron eikonals
1448       do icz=1,3
1449       do icdp=1,2
1450       do icdt=1,2
1451        if(cd(icdp,icz).ne.0.d0.and.cd(icdt,2).ne.0.d0)then
1452         do iy=1,11
1453          e0n=10.d0**iy
1454          sy=2.d0*e0n*am(2)+am(2)**2+am(icz)**2
1455          rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
1456         do iz=1,11
1457          if(iz.gt.6)then
1458           z=.2d0*(iz-6)
1459           b=sqrt(-log(z)*rp)
1460          else
1461           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
1462           z=exp(-b*b/rp)
1463          endif
1464 
1465          vsoft=gsoft(icz)*sy**dels/rp*cd(icdp,icz)*cd(icdt,2)
1466          vgg=qgfsh(sy,b*b,icdp,icdt,icz,0)
1467          vqg=qgfsh(sy,b*b,icdp,icdt,icz,1)
1468          vgq=qgfsh(sy,b*b,icdp,icdt,icz,2)
1469          vqq=qghard(sy,b*b,icdp,icdt,icz)
1470 
1471          qxp=vsoft*z+vgg+vqg+vgq+vqq
1472          do iv=1,6
1473           vvx=(iv-1)/5.d0
1474          do iv1=1,1+5*(icz-1)*(3-icz)
1475           vvxp=(iv1-1)/5.d0
1476          do iv2=1,6
1477           vvxt=(iv2-1)/5.d0
1478 
1479           v3p=qg3pom(sy,b,vvx,vvxp,vvxt,icdp,icdt,icz)
1480           v1p=qgpcut(sy,b,vvx,vvxp,vvxt,icdp,icdt,icz)
1481           qxp1=qxp+v3p
1482           qxpc=qxp+v1p
1483           if(qxp1.gt.0.d0)then
1484            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
1485      *     ,icdp+2*(icdt-1)+4*(icz-1),1)=log(qxp1/z)
1486           else
1487            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
1488      *     +4*(icz-1),1)=min(2.d0*qpomr(iy-1,iz,iv+6*(iv1-1)
1489      *     +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),1)-qpomr(iy-2,iz
1490      *     ,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),1)
1491      *     ,qpomr(iy-1,iz,iv+6*(iv1-1)+36*(iv2-1)
1492      *     ,icdp+2*(icdt-1)+4*(icz-1),1))
1493           endif
1494           if(qxpc.gt.0.d0)then
1495            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
1496      *     ,icdp+2*(icdt-1)+4*(icz-1),2)=log(qxpc/z)
1497           else
1498            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
1499      *     +4*(icz-1),2)=min(2.d0*qpomr(iy-1,iz,iv+6*(iv1-1)
1500      *     +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),2)-qpomr(iy-2,iz
1501      *     ,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),2)
1502      *     ,qpomr(iy-1,iz,iv+6*(iv1-1)+36*(iv2-1)
1503      *     ,icdp+2*(icdt-1)+4*(icz-1),2))
1504           endif
1505 
1506           do iqq=1,2
1507            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
1508      *     +4*(icz-1),iqq)=max(qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
1509      *     ,icdp+2*(icdt-1)+4*(icz-1),iqq),-20.d0)
1510 
1511            if(.not.(qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
1512      *     +4*(icz-1),iqq).le.0.d0.or.qpomr(iy,iz,iv+6*(iv1-1)
1513      *     +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),iqq).gt.0.d0))
1514      *     stop'qpomr-nan'
1515           enddo
1516          enddo
1517          enddo
1518          enddo
1519         enddo
1520         enddo
1521        endif
1522       enddo
1523       enddo
1524       enddo
1525 
1526 c-------------------------------------------------
1527 c interaction cross sections
1528       ia(1)=1
1529       do iy=1,10
1530        e0n=10.d0**iy                               !interaction energy
1531        scm=2.d0*e0n*am(2)+am(2)**2+am(icz)**2
1532 
1533        do iiz=1,3
1534         icz=iiz                                    !hadron class
1535         rp=(rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0389d0 !slope (in fm^2)
1536         g0=pi*rp*10.d0                  !factor for cross-sections (in mb)
1537 
1538         do iia=1,6
1539          if(iia.le.4)then
1540           ia(2)=4**(iia-1)                         !target mass number
1541          elseif(iia.eq.5)then
1542           ia(2)=14
1543          else
1544           ia(2)=40
1545          endif
1546          if(debug.ge.1)write (moniou,206)e0n,ty(icz),ia(2)
1547 c-------------------------------------------------
1548 c nuclear densities
1549          if(ia(2).lt.10)then                       !light nuclei - gaussian
1550           rnuc(2)=.9d0*float(ia(2))**.3333         !nuclear radius
1551           wsnuc(2)=amws                            !not used
1552           wbnuc(2)=0.d0                            !not used
1553          elseif(ia(2).le.56)then                   !3-parameter Fermi
1554           rnuc(2)=trnuc(ia(2))                     !nuclear radius
1555           wsnuc(2)=twsnuc(ia(2))                   !diffuseness
1556           wbnuc(2)=twbnuc(ia(2))                   !'wine-bottle' parameter
1557          else                                      !2-parameter Fermi
1558 c rnuc - wood-saxon density radius (fit to the data of murthy et al.)
1559           rnuc(2)=1.19d0*dble(ia(2))**(1.d0/3.d0)
1560      *    -1.38d0*dble(ia(2))**(-1.d0/3.d0)        !nuclear radius
1561           wsnuc(2)=amws                            !diffuseness
1562           wbnuc(2)=0.d0                            !not used
1563          endif
1564 
1565          if(ia(2).eq.1)then               !hadron-proton interaction
1566           call qgfz(0.d0,gz0,0,0)
1567           gtot=gz0(1)                     !total cross-section
1568           gin=(gz0(2)+gz0(3)+gz0(4))*.5d0 !inelastic cross section
1569           bel=gz0(5)                      !elastic scattering slope
1570           gel=gtot-gin                    !elastic cross section
1571           gdp=gz0(3)*.5d0     !projectile low mass diffr. (+double LMD)
1572           gdt=gz0(4)*.5d0                 !target low mass diffraction
1573           if(iy.le.10)gsect(iy,icz,iia)=log(gin)
1574 
1575           if(debug.ge.1)write (moniou,225)gtot,gin,gel,gdp,gdt,bel
1576          else                             !hadron-nucleus interaction
1577           bm=rnuc(2)+dlog(29.d0)*wsnuc(2) !for numerical integration
1578           anorm=qganrm(rnuc(2),wsnuc(2),wbnuc(2))*rp !density normalization
1579           call qggau(gz1)                 !integration over b<bm
1580           call qggau1(gz1)                !integration over b>bm
1581           gin=gz1(1)+gz1(2)+gz1(3)        !inelastic cross section
1582           if(iy.le.10)gsect(iy,icz,iia)=log(gin*10.d0)
1583 
1584           if(debug.ge.1)write (moniou,224)
1585      *    gin*10.d0,gz1(3)*10.d0,gz1(2)*10.d0
1586          endif
1587          if(.not.(gsect(iy,icz,iia).le.0.d0
1588      *   .or.gsect(iy,icz,iia).gt.0.d0))stop'qpomr-nan'
1589         enddo
1590        enddo
1591       enddo
1592 
1593 c-------------------------------------------------
1594 c cut Pomeron leg eikonals
1595       if(debug.ge.1)write (moniou,223)
1596       do icz=1,3                                    !hadron class
1597       do icdp=1,2
1598        if(cd(icdp,icz).ne.0.d0)then
1599         do iy=1,51
1600          sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
1601          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1602         do iz=1,11
1603          if(iz.gt.6)then
1604           z=.2d0*(iz-6)
1605           bb=-log(z)*rp                             !impact parameter^2
1606          else
1607           bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1608           z=exp(-bb/rp)
1609          endif
1610         do ix=1,10
1611          if(ix.le.5)then
1612           xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0)     !Pomeron LC+ momentum
1613          else
1614           xp=.2d0*(ix-5)
1615          endif
1616          sys=xp*sy
1617 
1618          vs=qgls(sys,xp,bb,icdp,icz)
1619          vg=qglsh(sys,xp,bb,icdp,icz,0)
1620          if(xp.lt..99d0)then
1621           vq=qglsh(sys,xp,bb,icdp,icz,1)
1622      *    /dsqrt(xp)*(1.d0-xp)**(ahv(icz)-ahl(icz))
1623          else
1624           vq=0.d0
1625          endif
1626          qlegc0(iy,ix,iz,icdp+2*(icz-1),1)=dlog((vs+vg+vq)/vs)
1627          qlegc0(iy,ix,iz,icdp+2*(icz-1),2)=dlog((vs+vg)/vs)
1628         enddo
1629         enddo
1630         enddo
1631        endif
1632       enddo
1633       enddo
1634 
1635       do icz=1,3                                    !hadron class
1636       do icdp=1,2
1637        if(cd(icdp,icz).ne.0.d0)then
1638         do iy=1,51
1639          sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
1640          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1641         do iz=1,11
1642          if(iz.gt.6)then
1643           z=.2d0*(iz-6)
1644           bb=-log(z)*rp                             !impact parameter^2
1645          else
1646           bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1647           z=exp(-bb/rp)
1648          endif
1649         do ix=1,10
1650          if(ix.le.5)then
1651           xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0)     !Pomeron LC+ momentum
1652          else
1653           xp=.2d0*(ix-5)
1654          endif
1655          sys=xp*sy
1656 
1657          do iqq=1,3
1658           call qgloolc(sys,xp,bb,icdp,icz,iqq,fann(2*iqq-1)
1659      *    ,fann(2*iqq))
1660          enddo
1661          do iqq=1,6
1662           if(fann(iqq).gt.0.d0)then
1663            qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
1664      *     =dlog(fann(iqq)/qgls(sys,xp,bb,icdp,icz))
1665           else
1666            qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
1667      *     =min(2.d0*qlegc0(iy-1,ix,iz,icdp+2*(icz-1),iqq+2)
1668      *     -qlegc0(iy-2,ix,iz,icdp+2*(icz-1),iqq+2)
1669      *     ,qlegc0(iy-1,ix,iz,icdp+2*(icz-1),iqq+2))
1670           endif
1671           qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
1672      *     =max(qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2),-20.d0)
1673          enddo
1674         enddo
1675         enddo
1676         enddo
1677        endif
1678       enddo
1679       enddo
1680 
1681       do icz=1,3                                    !hadron class
1682       do icdp=1,2                                   !diffr. eigenstate
1683        if(cd(icdp,icz).ne.0.d0)then
1684         do iv=1,11
1685          vvx=dble(iv-1)/10.d0
1686          do iy=1,51                                 !initialization
1687          do ix=1,10
1688          do iz=1,11
1689           do iqq=1,3
1690            qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1691      *     =qlegc0(iy,ix,iz,icdp+2*(icz-1),2*iqq+1)
1692           enddo
1693          enddo
1694          enddo
1695          enddo
1696 
1697          do iy=2,51
1698           sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
1699           rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1700 
1701           do ix=1,10
1702           do iz=1,11
1703           do iqq=1,3
1704            qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1705      *     =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1706           enddo
1707           enddo
1708           enddo
1709 
1710           n=1
1711 43        n=n+1                          !number of t-channel iterations
1712           nrep=0
1713           do iz=1,11
1714            if(iz.gt.6)then
1715             z=.2d0*(iz-6)
1716             bb=-log(z)*rp                           !impact parameter^2
1717            else
1718             bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1719             z=exp(-bb/rp)
1720            endif
1721           do ix=1,10
1722            if(ix.le.5)then
1723             xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0)   !Pomeron LC+ momentum
1724            else
1725             xp=.2d0*(ix-5)
1726            endif
1727            sys=xp*sy
1728 
1729            do iqq=1,3
1730             fann(iqq)=qglscr(sys,xp,bb,vvx,icdp,icz,iqq)
1731             if(fann(iqq).gt.0.d0)then
1732              qfan2(ix,iz,iqq)=dlog(fann(iqq)/qgls(sys,xp,bb,icdp,icz))
1733             elseif(iy.gt.2)then
1734              qfan2(ix,iz,iqq)
1735      *       =min(2.d0*qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1736      *       -qlegc(iy-2,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1737      *       ,qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)))
1738             else
1739              qfan2(ix,iz,iqq)
1740      *       =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1741             endif
1742             qfan2(ix,iz,iqq)=max(qfan2(ix,iz,iqq),-20.d0)
1743             if(abs(qfan2(ix,iz,iqq)-qlegc(iy,ix,iv,iz
1744      *      ,icdp+2*(icz-1)+6*(iqq-1))).gt.1.d-3)nrep=1
1745            enddo
1746           enddo
1747           enddo
1748 
1749           do iz=1,11
1750            if(iz.gt.6)then
1751             z=.2d0*(iz-6)
1752             bb=-log(z)*rp                           !impact parameter
1753            else
1754             bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1755             z=exp(-bb/rp)
1756            endif
1757           do ix=1,10
1758            if(ix.le.5)then
1759             xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0)   !Pomeron LC+ momentum
1760            else
1761             xp=.2d0*(ix-5)
1762            endif
1763            sys=xp*sy
1764 
1765           do iqq=1,3
1766            qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))=qfan2(ix,iz,iqq)
1767 
1768            if(.not.(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).le.0.d0
1769      *     .or.qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).gt.0.d0))
1770      *     stop'qlegc-nan'
1771           enddo
1772           enddo
1773           enddo
1774           if(nrep.eq.1.and.n.lt.50)goto 43
1775          enddo
1776         enddo
1777        endif
1778       enddo
1779       enddo
1780 
1781 c soft pre-evolution
1782       do icz=1,3                                    !hadron class
1783       do icdp=1,2                                   !diffr. eigenstate
1784        if(cd(icdp,icz).ne.0.d0)then
1785         do iv=1,11
1786          vvx=dble(iv-1)/10.d0
1787         do iy=1,51
1788          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
1789          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
1790         do iz=1,11
1791          if(iz.gt.6)then
1792           z=.2d0*(iz-6)
1793           bb=-log(z)*rp                             !impact parameter
1794          else
1795           bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1796           z=exp(-bb/rp)
1797          endif
1798         do ix=1,10
1799          if(ix.le.5)then
1800           xp=.2d0*(sgap/sy)**((6-ix)/5.d0)          !Pomeron LC+ momentum
1801          else
1802           xp=.2d0*(ix-5)
1803          endif
1804          sys=xp*sy
1805 
1806          if(iy.eq.1)then
1807           qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+18)=0.d0
1808           qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+24)=0.d0
1809          else
1810           do iqq=4,5
1811            fann(iqq)=qglh(sys,xp,bb,vvx,icdp,icz,iqq-4)
1812            if(fann(iqq).gt.0.d0)then
1813             qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1814      *      =dlog(fann(iqq))
1815            elseif(iy.gt.2)then
1816             qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1817      *      =min(2.d0*qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1818      *      -qlegc(iy-2,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1819      *      ,qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)))
1820            else
1821             qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1822      *      =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1823            endif
1824            qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
1825      *     =max(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)),-20.d0)
1826 
1827            if(.not.(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).le.0.d0
1828      *     .or.qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).gt.0.d0))
1829      *     stop'qlegc-nan'
1830           enddo
1831          endif
1832         enddo
1833         enddo
1834         enddo
1835         enddo
1836        endif
1837       enddo
1838       enddo
1839 
1840 c-------------------------------------------------
1841 c cut Pomeron eikonals
1842       if(debug.ge.1)write (moniou,226)
1843       do icz=1,3                                    !proj. class
1844       do icdp=1,2
1845       do icdt=1,2
1846        if(cd(icdp,icz).ne.0.d0.and.cd(icdt,2).ne.0.d0)then
1847         do iy=1,11
1848          sy=sgap**2*(spmax/sgap**2)**((iy-1)/10.d0)
1849          rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
1850         do iz=1,11
1851          if(iz.gt.6)then
1852           z=.2d0*(iz-6)
1853           bb=-log(z)*rp                             !impact parameter^2
1854          else
1855           bb=-rp*(log(0.2d0)+2.d0*(iz-7))
1856           z=exp(-bb/rp)
1857          endif
1858         do iv=1,11
1859          vvx=(iv-1)/10.d0                           !relative scr. strenth
1860 
1861         do ix1=1,10
1862          if(ix1.le.5)then
1863           xp=.2d0*(5.d0*sgap/sy)**((6-ix1)/5.d0)    !Pomeron LC+ momentum
1864          else
1865           xp=.2d0*(ix1-5)
1866          endif
1867         do ix2=1,10
1868          if(ix2.le.5)then
1869           xm=.2d0*(sgap/sy/xp)**((6-ix2)/5.d0)      !Pomeron LC- momentum
1870          else
1871           xm=.2d0*(ix2-5)
1872          endif
1873          sys=xp*xm*sy
1874 
1875          do iqq=1,4
1876           vv=qgcutp(sys,xp,xm,bb,vvx,icdp,icdt,icz,iqq)
1877           if(vv.gt.0.d0)then
1878            qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1879      *     +12*(iqq-1))=dlog(vv/z)
1880           elseif(iy.gt.2)then
1881            qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1882      *     +12*(iqq-1))=min(2.d0*qpomc(iy-1,ix1+10*(ix2-1),iz,iv
1883      *     ,icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1))-qpomc(iy-2
1884      *     ,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1))
1885      *     ,qpomc(iy-1,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1886      *     +12*(iqq-1)))
1887           else
1888            qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1889      *     +12*(iqq-1))=qpomc(iy-1,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)
1890      *     +4*(icz-1)+12*(iqq-1))
1891           endif
1892            qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
1893      *     +12*(iqq-1))=max(qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp
1894      *     +2*(icdt-1)+4*(icz-1)+12*(iqq-1)),-20.d0)
1895 
1896           if(.not.(qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz
1897      *    -1)+12*(iqq-1)).le.0.d0.or.qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp
1898      *    +2*(icdt-1)+4*(icz-1)+12*(iqq-1)).gt.0.d0))stop'qpomc-nan'
1899          enddo
1900         enddo
1901         enddo
1902         enddo
1903         enddo
1904         enddo
1905        endif
1906       enddo
1907       enddo
1908       enddo
1909 
1910 c-----------------------------------------------------------------------------
1911 c timelike Sudakov formfactor
1912       if(debug.ge.1)write (moniou,221)
1913       do m=1,2                     !parton type (1-g, 2-q)
1914        fsud(1,m)=0.d0
1915       do k=2,10
1916        qmax=qtf*4.d0**(1.d0+k)     !effective virtuality (qt**2/z**2/(1-z)**2)
1917        fsud(k,m)=qgsudt(qmax,m)
1918       enddo
1919       enddo
1920 c-----------------------------------------------------------------------------
1921 c effective virtuality (used for inversion in timelike branching)
1922       if(debug.ge.1)write (moniou,222)
1923       do m=1,2                     !parton type (1-g, 2-q)
1924       do k=1,10
1925        qlmax=1.38629d0*(k-1)
1926        qrt(k,1,m)=0.d0
1927        qrt(k,101,m)=qlmax
1928       do i=1,99                    !bins in Sudakov formfactor
1929        if(k.eq.1)then
1930         qrt(k,i+1,m)=0.d0
1931        else
1932         qrt(k,i+1,m)=qgroot(qlmax,.01d0*i,m)
1933        endif
1934       enddo
1935       enddo
1936       enddo
1937 
1938 c-----------------------------------------------------------------------------
1939 c writing cross sections to the file
1940       if(debug.ge.1)write (moniou,220)
1941       if(ifIIdat.ne.1)then
1942        open(1,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
1943      * ,status='unknown')
1944       else                                              !used to link with nexus
1945        open(ifIIdat,file=fnIIdat(1:nfnIIdat),status='unknown')
1946       endif
1947       write (1,*)csborn,cs0,cstot,evk,qpomi,qpomis,qlegi,qfanu,qfanc
1948      *,qdfan,qpomr,gsect,qlegc0,qlegc,qpomc,fsud,qrt,qrev,fsud,qrt
1949       close(1)
1950 
1951 10    continue
1952 c-----------------------------------------------------------------------------
1953 c nuclear cross sections
1954       if(ifIIncs.ne.2)then
1955        inquire(file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
1956      * ,exist=lcalc)
1957       else                                                  !ctp
1958        inquire(file=fnIIncs(1:nfnIIncs),exist=lcalc)
1959       endif
1960 
1961       if(lcalc)then
1962        if(debug.ge.0)write (moniou,207)
1963        if(ifIIncs.ne.2)then
1964         open(2,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
1965      *  ,status='old')
1966        else                                                  !ctp
1967         open(ifIIncs,file=fnIIncs(1:nfnIIncs),status='old')
1968        endif
1969        read (2,*)qgsasect
1970        close(2)
1971 
1972       elseif(.not.producetables)then
1973         write(moniou,*) "Missing sectnu-II-04 file !"        
1974         write(moniou,*) "Please correct the defined path ",
1975      &"or force production ..."
1976         stop
1977 
1978       else
1979        niter=5000                   !number of iterations
1980        do ie=1,10
1981         e0n=10.d0**ie               !interaction energy (per nucleon)
1982        do iia1=1,6
1983         iap=2**iia1                 !proj. mass number
1984        do iia2=1,6
1985         if(iia2.le.4)then
1986          iat=4**(iia2-1)            !targ. mass number
1987         elseif(iia2.eq.5)then
1988          iat=14
1989         else
1990          iat=40
1991         endif
1992         if(debug.ge.1)write (moniou,208)e0n,iap,iat
1993 
1994         call qgini(e0n,2,iap,iat)
1995         call qgcrossc(niter,gtot,gprod,gabs,gdd,gqel,gcoh)
1996         if(debug.ge.1)write (moniou,209)gtot,gprod,gabs,gdd,gqel,gcoh
1997         qgsasect(ie,iia1,iia2)=log(gprod)
1998        enddo
1999        enddo
2000        enddo
2001        if(ifIIncs.ne.2)then
2002         open(2,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
2003      *  ,status='unknown')
2004        else                                                  !ctp
2005         open(ifIIncs,file=fnIIncs(1:nfnIIncs),status='unknown')
2006        endif
2007        write (2,*)qgsasect
2008        close(2)
2009       endif
2010 
2011       if(debug.ge.3)write (moniou,218)
2012 201   format(2x,'qgaini: hard cross sections calculation')
2013 202   format(2x,'qgaini: number of rungs considered:',i2
2014      */4x,'starting energy bin for ordered and general ladders:',3i4)
2015 205   format(2x,'qgaini: pretabulation of the interaction eikonals')
2016 206   format(2x,'qgaini: initial particle energy:',e10.3,2x
2017      *,'its type:',a7,2x,'target mass number:',i2)
2018 207   format(2x,'qgaini: nuclear cross sections readout from the file'
2019      *,' sectnu-II-04')
2020 208   format(2x,'qgaini: initial nucleus energy:',e10.3,2x
2021      *,'projectile mass:',i2,2x,'target mass:',i2)
2022 209   format(2x,'gtot',d10.3,'  gprod',d10.3,'  gabs',d10.3
2023      */2x,'gdd',d10.3,'  gqel',d10.3,' gcoh',d10.3)
2024 210   format(2x,'qgaini - main initialization procedure')
2025 212   format(2x,'qgaini: integrated Pomeron leg eikonals')
2026 213   format(2x,'qgaini: integrated fan contributions')
2027 214   format(2x,'qgaini: cross sections readout from the file: ', A,2x)
2028 c     *,' qgsdat-II-04')
2029 215   format(2x,'qgaini: integrated cut fan contributions')
2030 c216   format(2x,'qgaini: integrated cut Pomeron eikonals')
2031 218   format(2x,'qgaini - end')
2032 220   format(2x,'qgaini: cross sections are written to the file'
2033      *,' qgsdat-II-04')
2034 221   format(2x,'qgaini: timelike Sudakov formfactor')
2035 222   format(2x,'qgaini: effective virtuality for inversion')
2036 223   format(2x,'qgaini: cut Pomeron leg eikonals')
2037 224   format(2x,'qgaini: hadron-nucleus cross sections:'
2038      */4x,'gin=',e10.3,2x,'gdifr_targ=',e10.3,2x
2039      *,'gdifr_proj=',e10.3)
2040 225   format(2x,'qgaini: hadron-proton cross sections:'
2041      */4x,'gtot=',e10.3,2x,'gin=',e10.3,2x,'gel=',e10.3/4x
2042      *,'gdifrp=',e10.3,2x,'gdifrt=',e10.3,2x,'b_el=',e10.3,2x)
2043 226   format(2x,'qgaini: cut Pomeron eikonals (semi-hard)')
2044       return
2045       end
2046 
2047 c=============================================================================
2048       subroutine qgini(e0n,icp0,iap,iat)
2049 c-----------------------------------------------------------------------------
2050 c additional initialization procedure
2051 c e0n  - interaction energy (per hadron/nucleon),
2052 c icp0 - hadron type (+-1 - pi+-, +-2 - p(p~), +-3 - n(n~),
2053 c                     +-4 - K+-, +-5 - K_l/s),
2054 c iap  - projectile mass number (1 - for a hadron),
2055 c iat  - target mass number
2056 c-----------------------------------------------------------------------------
2057       implicit double precision (a-h,o-z)
2058       integer debug
2059       parameter(iapmax=208)
2060       common /qgarr1/  ia(2),icz,icp
2061       common /qgarr2/  scm,wp0,wm0
2062       common /qgarr4/  ey0(3)
2063       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
2064      *,cr1(2),cr2(2),cr3(2)
2065       common /qgarr6/  pi,bm,amws
2066       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
2067       common /qgarr10/ am(7),ammu
2068       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2069       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2070       common /qgarr43/ moniou
2071       common /arr1/    trnuc(56),twsnuc(56),twbnuc(56)
2072       common /qgdebug/ debug
2073       common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3)  !used to link with nexus
2074      *,bqgs,bmaxqgs,bmaxnex,bminnex
2075 
2076       if(debug.ge.1)write (moniou,201)icp0,iap,iat,e0n
2077       icp=icp0
2078       ia(1)=iap
2079       ia(2)=iat
2080 
2081       icz=iabs(icp)/2+1  !!!!!particle class (1 - pion, 2 - nucleon, 3 - kaon)
2082 
2083       scm=2.d0*e0n*am(2)+am(2)**2+am(icz)**2   !c.m. energy squared
2084       ey0(1)=dsqrt(scm)/(e0n+am(2)+dsqrt(e0n-am(icz))
2085      **dsqrt(e0n+am(icz)))                     !Lorentz boost to lab. frame
2086       ey0(2)=1.d0
2087       ey0(3)=1.d0
2088       wp0=dsqrt(scm)                           !initial LC+ mometum
2089       wm0=wp0                                  !initial LC- mometum
2090 
2091 c-------------------------------------------------
2092 c nuclear radii and weights for nuclear configurations - procedure qggea
2093       do i=1,2
2094        if(ia(i).lt.10.and.ia(i).ne.1)then      !gaussian density
2095         rnuc(i)=.9d0*float(ia(i))**.3333       !nuclear radius
2096         if(ia(i).eq.2)rnuc(i)=3.16d0
2097 c rnuc -> rnuc * a / (a-1) - to use van-hove method (in qggea)
2098         rnuc(i)=rnuc(i)*dsqrt(2.d0*ia(i)/(ia(i)-1.d0))
2099                            !rnuc -> rnuc*a/(a-1) - to use Van-Hove method
2100       elseif(ia(i).ne.1)then
2101         if(ia(i).le.56)then                    !3-parameter Fermi
2102          rnuc(i)=trnuc(ia(i))                  !nuclear radius
2103          wsnuc(i)=twsnuc(ia(i))                !diffuseness
2104          wbnuc(i)=twbnuc(ia(i))                !'wine-bottle' parameter
2105         else
2106          rnuc(i)=1.19*float(ia(i))**(1./3.)-1.38*float(ia(i))**(-1./3.)
2107          wsnuc(i)=amws                         !diffuseness
2108          wbnuc(i)=0.d0
2109         endif
2110         cr1(i)=1.d0+3.d0/rnuc(i)*wsnuc(i)+6.d0/(rnuc(i)/wsnuc(i))**2
2111      *  +6.d0/(rnuc(i)/wsnuc(i))**3
2112         cr2(i)=3.d0/rnuc(i)*wsnuc(i)
2113         cr3(i)=3.d0/rnuc(i)*wsnuc(i)+6.d0/(rnuc(i)/wsnuc(i))**2
2114        endif
2115       enddo
2116 
2117       if(ia(1).ne.1)then                              !primary nucleus
2118        bm=rnuc(1)+rnuc(2)+5.d0*max(wsnuc(1),wsnuc(2)) !b-cutoff
2119       elseif(ia(2).ne.1)then                          !hadron-nucleus
2120        bm=rnuc(2)+5.d0*wsnuc(2)                       !b-cutoff
2121       else                                            !hadron-proton
2122        bm=3.d0*dsqrt((rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0398d0)
2123       endif
2124 
2125       bmaxqgs=bm                                      !used to link with nexus
2126 
2127       if(debug.ge.3)write (moniou,202)
2128 201   format(2x,'qgini - miniinitialization: particle type icp0=',
2129      *i2,2x,'projectile mass number iap=',i2/4x,
2130      *'target mass number iat=',i2,' interaction energy e0n=',e10.3)
2131 202   format(2x,'qgini - end')
2132       return
2133       end
2134 
2135 c=============================================================================
2136       double precision function qgpint(sy,bb)
2137 c-----------------------------------------------------------------------------
2138 c qgpint - interm. Pomeron eikonal
2139 c sy  - pomeron mass squared,
2140 c bb  - impact parameter squared
2141 c-----------------------------------------------------------------------------
2142       implicit double precision (a-h,o-z)
2143       integer debug
2144       common /qgarr6/  pi,bm,amws
2145       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2146       common /qgarr18/ alm,qt0,qtf,betp,dgqq
2147       common /qgarr26/ factk,fqscal
2148       common /qgarr43/ moniou
2149       common /qgdebug/  debug
2150       common /arr3/   x1(7),a1(7)
2151 
2152       if(debug.ge.2)write (moniou,201)sy,bb
2153 
2154       qgpint=0.d0
2155       s2min=4.d0*fqscal*qt0
2156       xmin=s2min/sy
2157       if(xmin.ge.1.d0)return
2158 
2159       xmin=xmin**(delh-dels)
2160 c numerical integration over z1
2161       do i=1,7
2162       do m=1,2
2163        z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
2164      * **(1.d0/(delh-dels))
2165        ww=z1*sy
2166        sjqq=qgjit(qt0,qt0,ww,2,2)  !inclusive qq cross-section
2167        sjqg=qgjit(qt0,qt0,ww,1,2)  !inclusive qg cross-section
2168        sjgg=qgjit(qt0,qt0,ww,1,1)  !inclusive gg cross-section
2169 
2170        st2=0.d0
2171        do j=1,7
2172        do k=1,2
2173         xx=.5d0*(1.d0+x1(j)*(2*k-3))
2174         xp=z1**xx
2175         xm=z1/xp
2176         glu1=qgppdi(xp,0)
2177         sea1=qgppdi(xp,1)
2178         glu2=qgppdi(xm,0)
2179         sea2=qgppdi(xm,1)
2180         st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
2181      *  +sea1*sea2*sjqq)
2182        enddo
2183        enddo
2184        rh=-alfp*dlog(z1)
2185        qgpint=qgpint-a1(i)*dlog(z1)/z1**delh*st2
2186      * *exp(-bb/(4.d0*.0389d0*rh))/rh
2187       enddo
2188       enddo
2189       qgpint=qgpint*(1.d0-xmin)/(delh-dels)*factk*rr**2/2.d0*pi
2190 
2191       if(debug.ge.3)write (moniou,202)qgpint
2192 201   format(2x,'qgpint - interm. Pomeron eikonal:'
2193      */4x,'sy=',e10.3,2x,'bb=',e10.3)
2194 202   format(2x,'qgpint=',e10.3)
2195       return
2196       end
2197 
2198 c------------------------------------------------------------------------
2199       double precision function qgpini(sy,bb,vvx,vvxt,iqq)
2200 c-----------------------------------------------------------------------
2201 c qgpini - intermediate gg-Pomeron eikonal
2202 c sy   - pomeron mass squared,
2203 c bb   - impact parameter squared,
2204 c vvx  - total / projectile screening factor,
2205 c vvxt - target screening factor
2206 c vvx  - total/projectile screening factor:
2207 c vvx  = 0                                                    (iqq=1,...15)
2208 c vvx  = 1 - exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]  (iqq=16)
2209 c vvx  = 1 + exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]
2210 c          - exp[-2*sum_{i} chi_proj(i)-sum_j chi_targ(j)]
2211 c          - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]    (iqq=17 uncut)
2212 c vvx  = 1 - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]    (iqq=17,...19)
2213 c vvx  = 1 - exp[-sum_{i} chi_proj(i)]                        (iqq=20,...23)
2214 c vvxt - target screening factor:
2215 c vvxt = 0                                                    (iqq=1,...19)
2216 c vvxt = 1 - exp[-sum_j chi_targ(j)]                          (iqq=20,...23)
2217 c uncut eikonals:
2218 c iqq=0  - single soft Pomeron
2219 c iqq=1  - single Pomeron
2220 c iqq=2  - general loop contribution
2221 c iqq=3  - single Pomeron end on one side
2222 c iqq=4  - single Pomeron ends on both sides
2223 c cut eikonals:
2224 c iqq=5  - single cut Pomeron
2225 c iqq=6  - single cut Pomeron with single end
2226 c iqq=7  - single cut Pomeron with 2 single ends
2227 c iqq=8  - any cuts except the complete rap-gap
2228 c iqq=9  - single cut Pomeron end at one side
2229 c iqq=10 - single cut Pomeron end at one side and single Pomeron on the other
2230 c iqq=11 - no rap-gap at one side
2231 c iqq=12 - no rap-gap at one side and single Pomeron on the other
2232 c iqq=13 - single cut soft Pomeron
2233 c iqq=14 - single cut soft Pomeron with single end
2234 c iqq=15 - single cut soft Pomeron with 2 single ends
2235 c  with proj/targ screening corrections:
2236 c iqq=16 - single cut Pomeron
2237 c iqq=17 - uncut / cut end / loop sequence
2238 c iqq=18 - no rap-gap at the end
2239 c iqq=19 - single cut Pomeron end
2240 c iqq=20 - diffractive cut, Puu
2241 c iqq=21 - diffractive cut, Puu-Puc
2242 c iqq=22 - diffractive cut, Pcc
2243 c iqq=23 - diffractive cut, Pcc+Pcu
2244 c-----------------------------------------------------------------------
2245       implicit double precision (a-h,o-z)
2246       integer debug
2247       dimension wk(3),wz(3),wi(3),wj(3)
2248       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2249       common /qgarr18/ alm,qt0,qtf,betp,dgqq
2250       common /qgarr20/ spmax
2251       common /qgarr26/ factk,fqscal
2252       common /qgarr39/ qpomi(51,11,15),qpomis(51,11,11,11,9)
2253       common /qgarr43/ moniou
2254       common /qgdebug/  debug
2255 
2256       qgpini=0.d0
2257       pinm=0.d0
2258       s2min=4.d0*fqscal*qt0
2259       rp=alfp*dlog(sy)*4.d0*.0389d0
2260       z=exp(-bb/rp)
2261       if(iqq.le.1.and.(sy.le.s2min.or.iqq.eq.0))goto 1
2262 
2263       yl=log(sy/sgap)/log(spmax/sgap)*50.d0+1.d0
2264       k=max(1,int(1.00001d0*yl-1.d0))
2265       k=min(k,49)
2266       wk(2)=yl-k
2267       if(yl.le.2.d0)then
2268        iymax=2
2269        wk(1)=1.d0-wk(2)
2270       else
2271        wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
2272        wk(1)=1.d0-wk(2)+wk(3)
2273        wk(2)=wk(2)-2.d0*wk(3)
2274        iymax=3
2275       endif
2276 
2277       if(z.gt..2d0)then
2278        zz=5.d0*z+6.d0
2279       else
2280        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
2281       endif
2282       jz=min(9,int(zz))
2283       jz=max(1,jz)
2284       if(zz.lt.1.d0)then
2285        wz(2)=zz-jz
2286        wz(1)=1.d0-wz(2)
2287        izmax=2
2288       else
2289        if(jz.eq.6)jz=5
2290        wz(2)=zz-jz
2291        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
2292        wz(1)=1.d0-wz(2)+wz(3)
2293        wz(2)=wz(2)-2.d0*wz(3)
2294        izmax=3
2295       endif
2296 
2297       if(iqq.le.15)then
2298        iqr=iqq
2299        if(sy.le.sgap**2.and.iqq.le.12)iqr=1
2300        do l1=1,izmax
2301         l2=jz+l1-1
2302        do k1=1,iymax
2303         k2=k+k1-1
2304         qgpini=qgpini+qpomi(k2,l2,iqr)*wk(k1)*wz(l1)
2305        enddo
2306        enddo
2307        if(zz.lt.1.d0)then
2308         do k1=1,iymax
2309          k2=k+k1-1
2310          pinm=pinm+qpomi(k2,1,iqr)*wk(k1)
2311         enddo
2312         qgpini=min(qgpini,pinm)
2313        endif
2314 
2315       else
2316        vi=vvx*10.d0+1.d0
2317        i=max(1,int(vi))
2318        i=min(i,9)
2319        wi(2)=vi-i
2320        wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
2321        wi(1)=1.d0-wi(2)+wi(3)
2322        wi(2)=wi(2)-2.d0*wi(3)
2323 
2324        if(iqq.le.19)then
2325         do i1=1,3
2326          i2=i+i1-1
2327         do l1=1,izmax
2328          l2=jz+l1-1
2329         do k1=1,iymax
2330          k2=k+k1-1
2331          qgpini=qgpini+qpomis(k2,l2,i2,1,iqq-15)*wk(k1)*wz(l1)*wi(i1)
2332         enddo
2333         enddo
2334         enddo
2335         if(zz.lt.1.d0)then
2336          do i1=1,3
2337           i2=i+i1-1
2338          do k1=1,iymax
2339           k2=k+k1-1
2340           pinm=pinm+qpomis(k2,1,i2,1,iqq-15)*wk(k1)*wi(i1)
2341          enddo
2342          enddo
2343          qgpini=min(qgpini,pinm)
2344         endif
2345 
2346        else
2347         vj=vvxt*10.d0+1.d0
2348         j=max(1,int(vj))
2349         j=min(j,9)
2350         wj(2)=vj-j
2351         wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
2352         wj(1)=1.d0-wj(2)+wj(3)
2353         wj(2)=wj(2)-2.d0*wj(3)
2354         jmax=3
2355 
2356         do j1=1,jmax
2357          j2=j+j1-1
2358         do i1=1,3
2359          i2=i+i1-1
2360         do l1=1,izmax
2361          l2=jz+l1-1
2362         do k1=1,iymax
2363          k2=k+k1-1
2364          qgpini=qgpini+qpomis(k2,l2,i2,j2,iqq-15)
2365      *   *wk(k1)*wz(l1)*wi(i1)*wj(j1)
2366         enddo
2367         enddo
2368         enddo
2369         enddo
2370         if(zz.lt.1.d0)then
2371          do j1=1,jmax
2372           j2=j+j1-1
2373          do i1=1,3
2374           i2=i+i1-1
2375          do k1=1,iymax
2376           k2=k+k1-1
2377           pinm=pinm+qpomis(k2,1,i2,j2,iqq-15)*wk(k1)*wi(i1)*wj(j1)
2378          enddo
2379          enddo
2380          enddo
2381          qgpini=min(qgpini,pinm)
2382         endif
2383        endif
2384       endif
2385 1     qgpini=exp(qgpini)
2386       if(iqq.le.16.or.iqq.eq.19)qgpini=qgpini
2387      **sy**dels*sigs*g3p**2*z/rp*4.d0*.0389d0
2388       return
2389       end
2390 
2391 c=============================================================================
2392       double precision function qgleg(sy,bb,icdp,icz)
2393 c-----------------------------------------------------------------------------
2394 c qgleg - integrated Pomeron leg eikonal
2395 c sy  - pomeron mass squared,
2396 c bb  - impact parameter squared,
2397 c icz - hadron class
2398 c-----------------------------------------------------------------------------
2399       implicit double precision (a-h,o-z)
2400       integer debug
2401       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2402       common /qgarr19/ ahl(3)
2403       common /qgarr25/ ahv(3)
2404       common /qgarr43/ moniou
2405       common /qgdebug/  debug
2406       common /arr3/   x1(7),a1(7)
2407 
2408       if(debug.ge.2)write (moniou,201)sy,bb,icz
2409 
2410       qgleg=0.d0
2411       if(sy.lt.1.001d0)then
2412        tmin=1.d0
2413       else
2414        tmin=(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels)
2415       endif
2416       if(debug.ge.3)write (moniou,203)tmin
2417       do i1=1,7
2418       do m1=1,2
2419        tp=1.d0-(.5d0*(1.d0+tmin)+x1(i1)*(m1-1.5d0)*(1.d0-tmin))
2420      * **(1./(1.+dels))
2421        if(tp.gt.1.d-9)then
2422         xp=1.d0-tp**(1.d0/(1.d0+ahl(icz)))
2423        else
2424         xp=1.d0
2425        endif
2426 
2427        ws=qgls(xp*sy,xp,bb,icdp,icz)
2428        wg=qglsh(xp*sy,xp,bb,icdp,icz,0)
2429        wq=qglsh(xp*sy,xp,bb,icdp,icz,1)/dsqrt(xp)
2430      * *(1.d0-xp)**(ahv(icz)-ahl(icz))
2431 
2432        qgleg=qgleg+a1(i1)*(ws+wg+wq)/(1.d0-tp)**dels
2433       enddo
2434       enddo
2435       qgleg=qgleg/2.d0/(1.+ahl(icz))/(1.d0+dels)
2436 
2437       if(debug.ge.3)write (moniou,202)qgleg
2438 201   format(2x,'qgleg - Pomeron leg eikonal:'
2439      */4x,'s=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
2440 202   format(2x,'qgleg=',e10.3)
2441 203   format(2x,'qgleg:',2x,'tmin=',e10.3)
2442       return
2443       end
2444 
2445 c------------------------------------------------------------------------
2446       double precision function qglegi(sy,bb,icdp,icz,iqq)
2447 c-----------------------------------------------------------------------
2448 c qglegi - integrated Pomeron leg eikonal
2449 c sy   - pomeron mass squared,
2450 c bb   - impact parameter squared,
2451 c icdp - diffractive state for the hadron,
2452 c icz  - hadron class
2453 c iqq=1 - single leg Pomeron
2454 c iqq=2 - all loops
2455 c iqq=3 - single Pomeron end
2456 c iqq=4 - single cut Pomeron
2457 c iqq=5 - single cut Pomeron with single Pomeron end
2458 c iqq=6 - single cut Pomeron end
2459 c iqq=7 - no rap-gap at the end
2460 c-----------------------------------------------------------------------
2461       implicit double precision (a-h,o-z)
2462       integer debug
2463       dimension wk(3),wz(3)
2464       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2465       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2466       common /qgarr19/ ahl(3)
2467       common /qgarr20/ spmax
2468       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
2469      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
2470       common /qgarr43/ moniou
2471       common /qgdebug/  debug
2472 
2473       qglegi=0.d0
2474       xlegm=0.d0
2475       rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
2476       z=exp(-bb/rp)
2477       if(z.gt..2d0)then
2478        zz=5.d0*z+6.d0
2479       else
2480        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
2481       endif
2482       jz=min(9,int(zz))
2483       jz=max(1,jz)
2484       if(zz.lt.1.d0)then
2485        wz(2)=zz-jz
2486        wz(1)=1.d0-wz(2)
2487        izmax=2
2488       else
2489        if(jz.eq.6)jz=5
2490        wz(2)=zz-jz
2491        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
2492        wz(1)=1.d0-wz(2)+wz(3)
2493        wz(2)=wz(2)-2.d0*wz(3)
2494        izmax=3
2495       endif
2496 
2497       yl=log(sy/sgap)/log(spmax/sgap)*50.d0+1.d0
2498       k=max(1,int(yl))
2499       k=min(k,49)
2500       wk(2)=yl-k
2501       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
2502       wk(1)=1.d0-wk(2)+wk(3)
2503       wk(2)=wk(2)-2.d0*wk(3)
2504       iymax=3
2505 
2506       iqr=iqq
2507       if(sy.le.sgap**2)iqr=1
2508       do l1=1,izmax
2509        l2=jz+l1-1
2510       do k1=1,iymax
2511        k2=k+k1-1
2512        qglegi=qglegi+qlegi(k2,l2,icdp,icz,iqr)*wk(k1)*wz(l1)
2513       enddo
2514       enddo
2515       if(zz.lt.1.d0)then
2516        do k1=1,iymax
2517         k2=k+k1-1
2518         xlegm=xlegm+qlegi(k2,1,icdp,icz,iqr)*wk(k1)
2519        enddo
2520        qglegi=min(qglegi,xlegm)
2521       endif
2522       qglegi=exp(qglegi)*z
2523      **(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
2524       return
2525       end
2526 
2527 c=============================================================================
2528       double precision function qgls(sy,xp,bb,icdp,icz)
2529 c-----------------------------------------------------------------------------
2530 c qgls - soft pomeron leg eikonal
2531 c sy   - pomeron mass squared,
2532 c xp   - pomeron light cone momentum,
2533 c bb   - impact parameter squared,
2534 c icdp - diffractive state for the connected hadron,
2535 c icz  - hadron class
2536 c-----------------------------------------------------------------------------
2537       implicit double precision (a-h,o-z)
2538       integer debug
2539       common /qgarr6/  pi,bm,amws
2540       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2541       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2542       common /qgarr43/ moniou
2543       common /qgdebug/  debug
2544 
2545       if(debug.ge.2)write (moniou,201)sy,bb,icz
2546 
2547       rp=rq(icdp,icz)+alfp*log(sy/xp)
2548       qgls=sy**dels*fp(icz)*g3p*sigs/rp*exp(-bb/(4.d0*.0389d0*rp))
2549      **cd(icdp,icz)
2550 
2551       if(debug.ge.3)write (moniou,202)qgls
2552 201   format(2x,'qgls - soft pomeron leg eikonal:'
2553      */4x,'sy=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
2554 202   format(2x,'qgls=',e10.3)
2555       return
2556       end
2557 
2558 c=============================================================================
2559       double precision function qglsh(sy,xp,bb,icdp,icz,iqq)
2560 c-----------------------------------------------------------------------------
2561 c qglsh - unintegrated Pomeron leg eikonal
2562 c sy  - pomeron mass squared,
2563 c xp  - light cone momentum share,
2564 c bb  - impact parameter squared,
2565 c icz - hadron class
2566 c iqq=0 - gluon/sea quark contribution,
2567 c iqq=1 - valence quark contribution
2568 c-----------------------------------------------------------------------------
2569       implicit double precision (a-h,o-z)
2570       integer debug
2571       common /qgarr6/  pi,bm,amws
2572       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2573       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2574       common /qgarr18/ alm,qt0,qtf,betp,dgqq
2575       common /qgarr19/ ahl(3)
2576       common /qgarr25/ ahv(3)
2577       common /qgarr26/ factk,fqscal
2578       common /qgarr43/ moniou
2579       common /qgdebug/  debug
2580       common /arr3/   x1(7),a1(7)
2581 
2582       if(debug.ge.2)write (moniou,201)sy,bb,icz
2583 
2584       qglsh=0.d0
2585       s2min=4.d0*fqscal*qt0
2586       if(sy.lt.1.001d0*s2min)return
2587 
2588       xmin=(s2min/sy)**(delh-dels)
2589 c numerical integration over zh
2590       do i1=1,7
2591       do m1=1,2
2592        zh=(.5d0*(1.d0+xmin-(2*m1-3)*x1(i1)*(1.d0-xmin)))
2593      * **(1.d0/(delh-dels))
2594        ww=zh*sy         !c.m. energy squared for hard interaction
2595        sjqq=qgjit(qt0,qt0,ww,2,2)
2596        sjqg=qgjit(qt0,qt0,ww,1,2)
2597        sjgg=qgjit(qt0,qt0,ww,1,1)
2598        if(debug.ge.3)write (moniou,203)ww,sjqq+sjqg+sjgg
2599 
2600        if(iqq.eq.0)then
2601         stg=0.d0
2602         do i2=1,7
2603         do m2=1,2
2604          xx=.5d0*(1.d0+x1(i2)*(2*m2-3))
2605          xph=zh**xx
2606          xmh=zh/xph
2607          glu1=qgppdi(xph,0)
2608          sea1=qgppdi(xph,1)
2609          glu2=qgppdi(xmh,0)
2610          sea2=qgppdi(xmh,1)
2611          rh=rq(icdp,icz)-alfp*dlog(zh*xp)
2612 
2613          stsum=(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
2614      *   +sea1*sea2*sjqq)*exp(-bb/(4.d0*.0389d0*rh))/rh
2615          stg=stg+a1(i2)*stsum
2616         enddo
2617         enddo
2618         qglsh=qglsh-a1(i1)*dlog(zh)/zh**delh*stg
2619 
2620        elseif(iqq.eq.1)then
2621         xmh=zh
2622         glu2=qgppdi(xmh,0)
2623         sea2=qgppdi(xmh,1)
2624         rh=rq(icdp,icz)-alfp*dlog(zh)
2625 
2626         stq=(glu2*sjqg+sea2*sjqq)*exp(-bb/(4.d0*.0389d0*rh))/rh
2627         qglsh=qglsh+a1(i1)/zh**delh*stq
2628      *  *(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))/dsqrt(xp)
2629        endif
2630       enddo
2631       enddo
2632       if(iqq.eq.0)then
2633        qglsh=qglsh*rr**2*(1.d0-xmin)/(delh-dels)*fp(icz)*g3p*factk
2634      * /2.d0*pi*cd(icdp,icz)
2635       elseif(iqq.eq.1)then
2636        qglsh=qglsh*rr*(1.d0-xmin)/(delh-dels)*g3p*factk/4.d0
2637      * *cd(icdp,icz)
2638       endif
2639 
2640       if(debug.ge.3)write (moniou,202)qglsh
2641 201   format(2x,'qglsh - unintegrated Pomeron leg eikonal:'
2642      */4x,'s=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
2643 202   format(2x,'qglsh=',e10.3)
2644 203   format(2x,'qglsh:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
2645       return
2646       end
2647 
2648 c------------------------------------------------------------------------
2649       subroutine qgloop(sy,bb,fann,jj)
2650 c-----------------------------------------------------------------------
2651 c qgloop - intermediate Pomeron eikonal with loops
2652 c sy   - pomeron mass squared,
2653 c bb   - impact parameter squared,
2654 c jj=1 - uncut loops (iqq=1,...3)
2655 c jj=2 - cut loops (iqq=4,...11)
2656 c iqq=1  - general loop contribution
2657 c iqq=2  - single Pomeron end on one side
2658 c iqq=3  - single Pomeron ends on both sides
2659 c iqq=4  - single cut Pomeron
2660 c iqq=5  - single cut Pomeron with single end
2661 c iqq=6  - single cut Pomeron with 2 single ends
2662 c iqq=7  - any cuts except the complete rap-gap
2663 c iqq=8  - single cut Pomeron at one side
2664 c iqq=9  - single cut Pomeron at one side and single Pomeron on the other
2665 c iqq=10 - no rap-gap at one side
2666 c iqq=11 - no rap-gap at one side and single Pomeron on the other
2667 c iqq=12 - single cut soft Pomeron
2668 c iqq=13 - single cut soft Pomeron with single end
2669 c iqq=14 - single cut soft Pomeron with 2 single ends
2670 c-----------------------------------------------------------------------
2671       implicit double precision (a-h,o-z)
2672       integer debug
2673       dimension fann(14)
2674       common /qgarr6/  pi,bm,amws
2675       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2676       common /qgarr43/ moniou
2677       common /qgdebug/  debug
2678       common /arr3/   x1(7),a1(7)
2679 
2680       do iqq=1,14
2681        fann(iqq)=0.d0
2682       enddo
2683       if(sy.le.sgap**2)goto 1
2684       do ix1=1,7
2685       do mx1=1,2
2686        xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
2687        rp=-alfp*log(xpomr)*4.d0*.0389d0
2688        rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
2689        rp2=rp*rp1/(rp+rp1)
2690       do ix2=1,7
2691       do mx2=1,2
2692        z=.5d0+x1(ix2)*(mx2-1.5d0)
2693        bb0=-rp2*log(z)
2694       do ix3=1,7
2695       do mx3=1,2
2696        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
2697        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
2698      * +bb0*sin(phi)**2
2699        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
2700      * +bb0*sin(phi)**2
2701 
2702        vi=qgpini(xpomr*sy,bb1,0.d0,0.d0,1)
2703        vit=min(vi,qgpini(xpomr*sy,bb1,0.d0,0.d0,2))
2704        v1i0=qgpini(1.d0/xpomr,bb2,0.d0,0.d0,4)
2705        v1i1=min(v1i0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,3))
2706        v1i=min(v1i1,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,2))
2707        if(jj.eq.1)then
2708         do iqq=1,3
2709          if(iqq.eq.1)then
2710           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2711      *    +min(0.d0,1.d0-exp(-vit)-vit)*(1.d0-exp(-v1i))
2712          elseif(iqq.eq.2)then
2713           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2714          elseif(iqq.eq.3)then
2715           dpx=vi*(v1i1-v1i0)
2716          else
2717           dpx=0.d0
2718          endif
2719          fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
2720         enddo
2721 
2722        else
2723         v1ic0=min(v1i0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,7))
2724         v1ic1=min(v1ic0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,6))
2725         v1ic=min(v1ic1,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,5))
2726         v1icn=min(v1i,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,8))
2727         vict=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
2728         victn=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
2729         victg=min(victn,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
2730         vict1=min(victg,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
2731 
2732         vis=min(vi,qgpini(xpomr*sy,bb1,0.d0,0.d0,0))
2733         v1ic0s=min(v1ic0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,15))
2734         v1ic1s=min(v1ic0s,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,14))
2735         v1ics=min(v1ic1s,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,13))
2736         victs=min(vict,qgpini(xpomr*sy,bb1,0.d0,0.d0,13))
2737         do iqq=4,14
2738          if(iqq.eq.4)then
2739           dpx=vi*(v1ic*exp(-2.d0*v1icn)-v1ic1)
2740      *    +vict*(exp(-2.d0*victn)-1.d0)*v1ic*exp(-2.d0*v1icn)
2741          elseif(iqq.eq.5)then
2742           dpx=vi*(v1ic*exp(-2.d0*v1icn)-v1ic1)
2743          elseif(iqq.eq.6)then
2744           dpx=vi*(v1ic1-v1ic0)
2745          elseif(iqq.eq.7)then
2746           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2747      *    +.5d0*min(0.d0,1.d0-exp(-vit)-vit)*(1.d0-exp(-2.d0*v1icn))
2748      *    +.5d0*min(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn)
2749      *    *max(0.d0,1.d0-exp(-v1i)-.5d0*(1.d0-exp(-2.d0*v1icn)))
2750          elseif(iqq.eq.8)then
2751           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2752      *    +vict1*(exp(-2.d0*victn)-1.d0)*(1.d0-exp(-v1i))
2753          elseif(iqq.eq.9)then
2754           dpx=vi*(v1i1-v1i0)
2755      *    +vict1*(exp(-2.d0*victn)-1.d0)*v1i1
2756          elseif(iqq.eq.10)then
2757           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
2758      *    +(.5d0*max(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn
2759      *    *exp(-2.d0*victn))+victg*(exp(-2.d0*victn)-1.d0))
2760      *    *(1.d0-exp(-v1i))
2761          elseif(iqq.eq.11)then
2762           dpx=vi*(v1i1-v1i0)
2763      *    +(.5d0*max(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn
2764      *    *exp(-2.d0*victn))+victg*(exp(-2.d0*victn)-1.d0))*v1i1
2765          elseif(iqq.eq.12)then
2766           dpx=vis*(v1ics*exp(-2.d0*v1icn)-v1ic1s)
2767      *    +victs*(exp(-2.d0*victn)-1.d0)*v1ics*exp(-2.d0*v1icn)
2768          elseif(iqq.eq.13)then
2769           dpx=vis*(v1ics*exp(-2.d0*v1icn)-v1ic1s)
2770          elseif(iqq.eq.14)then
2771           dpx=vis*(v1ic1s-v1ic0s)
2772          else
2773           dpx=0.d0
2774          endif
2775          fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
2776         enddo
2777        endif
2778       enddo
2779       enddo
2780       enddo
2781       enddo
2782       enddo
2783       enddo
2784 1     dpin=qgpini(sy,bb,0.d0,0.d0,1)
2785       do iqq=1,11
2786        fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
2787      * +dpin
2788       enddo
2789       dpins=min(dpin,qgpini(sy,bb,0.d0,0.d0,0))
2790       do iqq=12,14
2791        fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
2792      * +dpins
2793       enddo
2794       return
2795       end
2796 
2797 c------------------------------------------------------------------------
2798       subroutine qgloos(sy,bb,vvx,vvxt,fann)
2799 c-----------------------------------------------------------------------
2800 c qgloos - intermediate Pomeron eikonal with screening corrections
2801 c sy   - pomeron mass squared,
2802 c bb   - impact parameter squared,
2803 c vvx  - total/projectile screening factor:
2804 c vvx  = 1 - exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]  (iqq=1)
2805 c vvx  = 1 + exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]
2806 c          - exp[-2*sum_{i} chi_proj(i)-sum_j chi_targ(j)]
2807 c          - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]    (iqq=2 uncut)
2808 c vvx  = 1 - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]    (iqq=2,...4)
2809 c vvx  = 1 - exp[-sum_{i} chi_proj(i)]                        (iqq=5,...8)
2810 c vvxt - target screening factor:
2811 c vvxt = 0                                                    (iqq=1,...4)
2812 c vvxt = 1 - exp[-sum_j chi_targ(j)]                          (iqq=5,...8)
2813 c iqq=1  - single cut Pomeron
2814 c iqq=2  - uncut / cut end / loop sequence
2815 c iqq=3  - no rap-gap at the end
2816 c iqq=4  - single cut Pomeron end
2817 c iqq=5  - diffractive cut, Puu
2818 c iqq=6  - diffractive cut, Puu-Puc
2819 c iqq=7  - diffractive cut, Pcc
2820 c iqq=8  - diffractive cut, Pcc+Pcu
2821 c-----------------------------------------------------------------------
2822       implicit double precision (a-h,o-z)
2823       integer debug
2824       dimension fann(14)
2825       common /qgarr6/  pi,bm,amws
2826       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2827       common /qgarr43/ moniou
2828       common /qgdebug/  debug
2829       common /arr3/   x1(7),a1(7)
2830 
2831       do iqq=1,8
2832        fann(iqq)=0.d0
2833       enddo
2834       if(sy.le.sgap**2)goto 1
2835 
2836       do ix1=1,7
2837       do mx1=1,2
2838        xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
2839        rp=-alfp*log(xpomr)*4.d0*.0389d0
2840        rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
2841        rp2=rp*rp1/(rp+rp1)
2842       do ix2=1,7
2843       do mx2=1,2
2844        z=.5d0+x1(ix2)*(mx2-1.5d0)
2845        bb0=-rp2*log(z)
2846       do ix3=1,7
2847       do mx3=1,2
2848        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
2849        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
2850      * +bb0*sin(phi)**2
2851        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
2852      * +bb0*sin(phi)**2
2853 
2854        vit=qgpini(xpomr*sy,bb1,0.d0,0.d0,2)
2855        vicn=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
2856        vicng=min(vicn,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
2857        vicpe=min(vicng,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
2858        vic1=min(vicpe,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
2859 
2860        viu=qgpini(1.d0/xpomr,bb2,0.d0,0.d0,2)
2861        v1icn=min(viu,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,8))
2862        v1i=qgpini(1.d0/xpomr,bb2,vvx,0.d0,16)*exp(-2.d0*v1icn)
2863        vi=qgpini(1.d0/xpomr,bb2,vvx,0.d0,17)*(1.d0-exp(-viu))
2864        vduu=qgpini(1.d0/xpomr,bb2,vvx,vvxt,20)*(1.d0-exp(-viu))
2865        vduc=max(0.d0,vduu-qgpini(1.d0/xpomr,bb2,vvx,vvxt,21)
2866      * *(1.d0-exp(-viu)))
2867        vdcc=qgpini(1.d0/xpomr,bb2,vvx,vvxt,22)*((1.d0-exp(-viu))**2
2868      * +(exp(2.d0*(viu-v1icn))-1.d0)*exp(-2.d0*viu))/2.d0
2869        vdcu=max(0.d0,qgpini(1.d0/xpomr,bb2,vvx,vvxt,23)
2870      * *((1.d0-exp(-viu))**2+(exp(2.d0*(viu-v1icn))-1.d0)
2871      * *exp(-2.d0*viu))/2.d0-vdcc)
2872 
2873        do iqq=1,8
2874         if(iqq.eq.1)then       !single cut Pomeron
2875          dpx=-vvx*v1i*vic1*exp(-2.d0*vicn)
2876         elseif(iqq.eq.2)then   !uncut / cut end / loop sequence
2877          dpx=-(1.d0-exp(-vit))*vi*vvx
2878         elseif(iqq.eq.3)then   !no rap-gap at the end
2879          dpx=-(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
2880      *   +vicng*exp(-2.d0*vicn))*vi*vvx
2881         elseif(iqq.eq.4)then   !single cut Pomeron end
2882          dpx=-vicpe*exp(-2.d0*vicn)*vi*vvx
2883         elseif(iqq.eq.5)then   !Puu
2884          dpx=(1.d0-exp(-vit))
2885      *   *(vduu*((1.d0-vvx)*(1.d0-vvxt)*(1.d0-vvx*vvxt)-1.d0)
2886      *   -vdcu*(1.d0-vvx)**2*(1.d0-vvxt)*vvxt)
2887         elseif(iqq.eq.6)then   !Puu-Puc
2888          dpx=(1.d0-exp(-vit))
2889      *   *((vduu-vduc)*((1.d0-vvx)*(1.d0-vvxt)*(1.d0-vvx*vvxt)-1.d0)
2890      *   -(vdcc+vdcu)*(1.d0-vvx)**2*(1.d0-vvxt)*vvxt)
2891         elseif(iqq.eq.7)then   !Pcc
2892          dpx=.5d0*((1.d0-exp(-vit))**2
2893      *   +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
2894      *   *(vdcc*((1.d0-vvx)**2*(1.d0-vvxt)**2-1.d0)
2895      *   -vduc*(1.d0-vvx)*(1.d0-vvxt)**2*vvx)
2896         elseif(iqq.eq.8)then   !Pcc+Pcu
2897          dpx=.5d0*((1.d0-exp(-vit))**2
2898      *   +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
2899      *   *((vdcc+vdcu)*((1.d0-vvx)**2*(1.d0-vvxt)**2-1.d0)
2900      *   +(vduu-vduc)*(1.d0-vvx)*(1.d0-vvxt)**2*vvx)
2901         else
2902          dpx=0.d0
2903         endif
2904         fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
2905        enddo
2906       enddo
2907       enddo
2908       enddo
2909       enddo
2910       enddo
2911       enddo
2912 1     vit=qgpini(sy,bb,0.d0,0.d0,2)
2913       vicn=min(vit,qgpini(sy,bb,0.d0,0.d0,8))
2914       vicng=min(vicn,qgpini(sy,bb,0.d0,0.d0,11))
2915       vicpe=min(vicng,qgpini(sy,bb,0.d0,0.d0,9))
2916       vic1=min(vicpe,qgpini(sy,bb,0.d0,0.d0,5))
2917       do iqq=1,8
2918        fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
2919        if(iqq.eq.1)then
2920         fann(iqq)=fann(iqq)*exp(2.d0*vicn)+vic1
2921        elseif(iqq.eq.3)then
2922         fann(iqq)=fann(iqq)+vicng*exp(-2.d0*vicn)
2923      *  +.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
2924        elseif(iqq.eq.4)then
2925         fann(iqq)=fann(iqq)*exp(2.d0*vicn)+vicpe
2926        elseif(iqq.lt.7)then
2927         fann(iqq)=fann(iqq)+(1.d0-exp(-vit))
2928        else
2929         fann(iqq)=fann(iqq)+.5d0*((1.d0-exp(-vit))**2
2930      *  +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
2931        endif
2932       enddo
2933       return
2934       end
2935 
2936 c------------------------------------------------------------------------
2937       subroutine qglool(sy,bb,icdp,icz,fann)
2938 c-----------------------------------------------------------------------
2939 c qglool - integrated Pomeron leg eikonal with loops
2940 c sy   - pomeron mass squared,
2941 c bb   - impact parameter squared,
2942 c icz  - hadron class
2943 c iqq=1 - all
2944 c iqq=2 - single Pomeron end
2945 c iqq=3 - single cut Pomeron
2946 c iqq=4 - single cut Pomeron with single Pomeron end
2947 c iqq=5 - single cut Pomeron end
2948 c iqq=6 - no rap-gap at the end
2949 c-----------------------------------------------------------------------
2950       implicit double precision (a-h,o-z)
2951       integer debug
2952       dimension fann(14)
2953       common /qgarr6/  pi,bm,amws
2954       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
2955       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
2956       common /qgarr19/ ahl(3)
2957       common /qgarr43/ moniou
2958       common /qgdebug/  debug
2959       common /arr3/   x1(7),a1(7)
2960 
2961       do iqq=1,6
2962        fann(iqq)=0.d0
2963       enddo
2964       if(sy.le.sgap**2)goto 1
2965 
2966       do ix1=1,7
2967       do mx1=1,2
2968        xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
2969        rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
2970        rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
2971        rp2=rp*rp1/(rp+rp1)
2972       do ix2=1,7
2973       do mx2=1,2
2974        z=.5d0+x1(ix2)*(mx2-1.5d0)
2975        bb0=-rp2*log(z)
2976       do ix3=1,7
2977       do mx3=1,2
2978        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
2979        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
2980      * +bb0*sin(phi)**2
2981        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
2982      * +bb0*sin(phi)**2
2983 
2984        vpl=qglegi(1.d0/xpomr,bb2,icdp,icz,1)
2985        v1i0=qgpini(xpomr*sy,bb1,0.d0,0.d0,4)
2986        v1i1=min(v1i0,qgpini(xpomr*sy,bb1,0.d0,0.d0,3))
2987        v1i=min(v1i1,qgpini(xpomr*sy,bb1,0.d0,0.d0,2))
2988        v1ic0=min(v1i0,qgpini(xpomr*sy,bb1,0.d0,0.d0,7))
2989        v1ic1=min(v1ic0,qgpini(xpomr*sy,bb1,0.d0,0.d0,6))
2990        v1ic=min(v1ic1,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
2991        v1icn=min(v1i,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
2992        vicn0=min(v1i1,qgpini(xpomr*sy,bb1,0.d0,0.d0,12))
2993        vicn=min(vicn0,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
2994        vic0=min(vicn0,qgpini(xpomr*sy,bb1,0.d0,0.d0,10))
2995        vic1=min(vic0,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
2996        vicn=min(vicn,v1icn)
2997        vic1=min(vicn,vic1)
2998        do iqq=1,6
2999         if(iqq.eq.1)then
3000          dpx=vpl*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
3001         elseif(iqq.eq.2)then
3002          dpx=vpl*(v1i1-v1i0)
3003         elseif(iqq.eq.3)then
3004          dpx=vpl*(v1ic*exp(-2.d0*v1icn)-v1ic1)
3005         elseif(iqq.eq.4)then
3006          dpx=vpl*(v1ic1-v1ic0)
3007         elseif(iqq.eq.5)then
3008          dpx=vpl*(vic1*exp(-2.d0*v1icn)-vic0)
3009         elseif(iqq.eq.6)then
3010          dpx=vpl*(.5d0*max(0.d0,1.d0-exp(-2.d0*v1icn)-2.d0*v1icn
3011      *   *exp(-2.d0*v1icn))+vicn*exp(-2.d0*v1icn)-vicn0)
3012         else
3013          dpx=0.d0
3014         endif
3015         fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3016        enddo
3017       enddo
3018       enddo
3019       enddo
3020       enddo
3021       enddo
3022       enddo
3023 1     dlool=qglegi(sy,bb,icdp,icz,1)
3024       do iqq=1,6
3025        fann(iqq)=(fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
3026      * +dlool)/(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
3027       enddo
3028       return
3029       end
3030 
3031 c------------------------------------------------------------------------
3032       double precision function qgrev(sy,bb,vvxt0,vvxt,vvxpt,vvxp0
3033      *,vvxpl,icdp,icz)
3034 c-----------------------------------------------------------------------
3035 c qgrev - zigzag contribution
3036 c sy    - c.m. energy squared,
3037 c bb    - impact parameter squared,
3038 c icdp  - diffractive state for the projectile,
3039 c icz   - hadron class,
3040 c vvxt0 = 1 - exp[-sum_j chi^(3)_targ(j)]
3041 c vvxt  = 1 - exp[-sum_j chi_targ(j)]
3042 c vvxpt = 1 - exp[-sum_{i>I} chi^(6)_proj(i)]
3043 c vvxp0 = 1 - exp[-sum_{i>I} chi^(3)_proj(i)]
3044 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
3045 c-----------------------------------------------------------------------
3046       implicit double precision (a-h,o-z)
3047       integer debug
3048       common /qgarr6/  pi,bm,amws
3049       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3050       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3051       common /qgarr19/ ahl(3)
3052       common /qgarr43/ moniou
3053       common /qgdebug/  debug
3054       common /arr3/   x1(7),a1(7)
3055 
3056       qgrev=0.d0
3057       if(sy.lt..999d0*sgap**2)return
3058 
3059       do ix1=1,7
3060       do mx1=1,2
3061        xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
3062        rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
3063        rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
3064        rp2=rp*rp1/(rp+rp1)
3065       do ix2=1,7
3066       do mx2=1,2
3067        z=.5d0+x1(ix2)*(mx2-1.5d0)
3068        bb0=-rp2*log(z)
3069       do ix3=1,7
3070       do mx3=1,2
3071        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3072        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3073      * +bb0*sin(phi)**2
3074        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3075      * +bb0*sin(phi)**2
3076 
3077        vvx=1.d0-(1.d0-vvxt)*(1.d0-vvxpl)
3078        vpf=qgfani(1.d0/xpomr,bb2,vvx,0.d0,0.d0,icdp,icz,1)
3079 
3080        viu=qgpini(xpomr*sy,bb1,0.d0,0.d0,2)
3081        viloop=(1.d0-exp(-viu))
3082        vim=2.d0*min(viu,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
3083 
3084        if(vvxt.eq.0.d0)then
3085         vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxpl)*exp(-vpf)
3086         vvxtin=0.d0
3087         vi=max(0.d0,qgpini(xpomr*sy,bb1,vvxpin,vvxtin,21)*viloop
3088      *  -qgpini(xpomr*sy,bb1,vvxpin,vvxtin,23)
3089      *  *(viloop**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0)
3090 
3091         dpx=vi*(1.d0-exp(-vpf))
3092        else
3093         vpf0=min(vpf,qgfani(1.d0/xpomr,bb2,vvx,vvxp0,vvxpl,icdp,icz,3))
3094         vpft=max(vpf,qgfani(1.d0/xpomr,bb2,vvx,vvxpt,vvxpl,icdp,icz,6))
3095         vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxpl)*exp(-vpf0)
3096         vvxtin=vvxt0
3097         vi=max(0.d0,qgpini(xpomr*sy,bb1,vvxpin,vvxtin,21)*viloop
3098      *  -qgpini(xpomr*sy,bb1,vvxpin,vvxtin,23)
3099      *  *(viloop**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0)
3100         if(vvxpt.eq.1.d0)then
3101          dpx=vi*(1.d0-exp(-vpft))
3102         else
3103          dpx=vi*(1.d0-exp(-vpft)+((1.d0-vvxt)**2*(max(0.d0
3104      *   ,1.d0-exp(-vpft)*(1.d0+vpft))-max(0.d0,1.d0-exp(-vpf0)
3105      *   *(1.d0+vpf0))*(1.d0-vvxp0)/(1.d0-vvxpt))
3106      *   +vpft*((1.d0-vvxt)**2*exp(-vpft)-exp(-vpf0)*(1.d0-vvxpl)
3107      *   *(1.d0-vvxp0)/(1.d0-vvxpt)*(1.d0-vvxt0)**2)
3108      *   -vpf0*exp(-vpf0)*(1.d0-vvxp0)/(1.d0-vvxpt)*((1.d0-vvxt)**2
3109      *   -(1.d0-vvxpl)*(1.d0-vvxt0)**2))/(1.d0-(1.d0-vvxt)**2))
3110          if(dpx.le.0.d0)dpx=vi*(1.d0-exp(-vpft))
3111         endif
3112        endif
3113 
3114        qgrev=qgrev+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3115       enddo
3116       enddo
3117       enddo
3118       enddo
3119       enddo
3120       enddo
3121       qgrev=qgrev/8.d0*pi*r3p/.0389d0/g3p**3
3122       if(.not.(qgrev.gt.0.d0.and.qgrev.lt.1.d10))stop'qgrev=NAN'
3123       return
3124       end
3125 
3126 c------------------------------------------------------------------------
3127       double precision function qgrevi(sy,bb,vvxt0,vvxt,vvxpt,vvxp0
3128      *,vvxpl,icdp,icz)
3129 c-----------------------------------------------------------------------
3130 c qgrevi - zigzag contribution (interpolation)
3131 c sy    - c.m. energy squared,
3132 c bb    - impact parameter squared,
3133 c icdp  - diffractive state for the projectile,
3134 c icz   - hadron class,
3135 c vvxt0 = 1 - exp[-sum_j chi^(3)_targ(j)]
3136 c vvxt  = 1 - exp[-sum_j chi_targ(j)
3137 c vvxpt = 1 - exp[-sum_{i>I} chi^(6)_proj(i)]
3138 c vvxp0 = 1 - exp[-sum_{i>I} chi^(3)_proj(i)]
3139 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
3140 c-----------------------------------------------------------------------
3141       implicit double precision (a-h,o-z)
3142       integer debug
3143       dimension wk(3),wz(3),wj(3),wi(3),wm2(3),wm3(3),wm4(3)
3144       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3145       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3146       common /qgarr19/ ahl(3)
3147       common /qgarr20/ spmax
3148       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
3149      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
3150       common /qgarr43/ moniou
3151       common /qgdebug/  debug
3152 
3153       qgrevi=0.d0
3154       revm=0.d0
3155       if(sy.le.sgap**2)return
3156 
3157       rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
3158       z=dexp(-bb/rp)
3159       if(z.gt..2d0)then
3160        zz=5.d0*z+6.d0
3161       else
3162        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
3163       endif
3164       jz=min(9,int(zz))
3165       jz=max(1,jz)
3166       if(zz.lt.1.d0)then
3167        wz(2)=zz-jz
3168        wz(1)=1.d0-wz(2)
3169        izmax=2
3170       else
3171        if(jz.eq.6)jz=5
3172        wz(2)=zz-jz
3173        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
3174        wz(1)=1.d0-wz(2)+wz(3)
3175        wz(2)=wz(2)-2.d0*wz(3)
3176        izmax=3
3177       endif
3178 
3179       yl=dlog(sy/sgap**2)/dlog(spmax/sgap**2)*10.d0+1.d0
3180       k=max(1,int(1.00001d0*yl-1.d0))
3181       k=min(k,9)
3182       wk(2)=yl-k
3183       if(yl.le.2.d0)then
3184        iymax=2
3185        wk(1)=1.d0-wk(2)
3186       else
3187        wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
3188        wk(1)=1.d0-wk(2)+wk(3)
3189        wk(2)=wk(2)-2.d0*wk(3)
3190        iymax=3
3191       endif
3192 
3193       if(vvxt0.gt..99d0)then
3194        j=11
3195        wj(1)=1.d0
3196        ivmax=1
3197        i=1
3198        wi(1)=1.d0
3199        iv1max=1
3200       else
3201        vl=max(1.d0,vvxt0*10.d0+1.d0)
3202        j=min(int(vl),9)
3203        wj(2)=vl-dble(j)
3204        wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
3205        wj(1)=1.d0-wj(2)+wj(3)
3206        wj(2)=wj(2)-2.d0*wj(3)
3207        ivmax=3
3208 
3209        vl1=max(1.d0,(vvxt-vvxt0)/(1.d0-vvxt0)*5.d0+1.d0)
3210        i=min(int(vl1),4)
3211        wi(2)=vl1-dble(i)
3212        wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
3213        wi(1)=1.d0-wi(2)+wi(3)
3214        wi(2)=wi(2)-2.d0*wi(3)
3215        iv1max=3
3216       endif
3217 
3218       if(icz.ne.2.or.vvxpt+vvxp0+vvxpl.eq.0.d0)then !hadron (no proj. nucl. corr.)
3219        ll=icz+(icz-1)*(3-icz)*2
3220        do i1=1,iv1max
3221         i2=i+i1-2
3222        do j1=1,ivmax
3223         j2=j+j1-1
3224        do l1=1,izmax
3225         l2=jz+l1-1
3226        do k1=1,iymax
3227         k2=k+k1-1
3228         qgrevi=qgrevi+qrev(k2,l2,j2+11*i2,ll,icdp)
3229      *  *wk(k1)*wz(l1)*wj(j1)*wi(i1)
3230        enddo
3231        enddo
3232        enddo
3233        enddo
3234        if(zz.lt.1.d0)then
3235         do i1=1,iv1max
3236          i2=i+i1-2
3237         do j1=1,ivmax
3238          j2=j+j1-1
3239         do k1=1,iymax
3240          k2=k+k1-1
3241          revm=revm+qrev(k2,1,j2+11*i2,ll,icdp)*wk(k1)*wj(j1)*wi(i1)
3242         enddo
3243         enddo
3244         enddo
3245         qgrevi=min(qgrevi,revm)
3246        endif
3247 
3248       else
3249        vm2=max(1.d0,vvxpt*5.d0+1.d0)
3250        m2=min(int(vm2),5)
3251        wm2(2)=vm2-dble(m2)
3252        wm2(1)=1.d0-wm2(2)
3253        im2max=2
3254 
3255        if(vvxpt.lt.1.d-2)then
3256         m3=1
3257         wm3(1)=1.d0
3258         im3max=1
3259        else
3260         vm3=max(1.d0,vvxp0/vvxpt*5.d0+1.d0)
3261         m3=min(int(vm3),5)
3262         wm3(2)=vm3-dble(m3)
3263         wm3(1)=1.d0-wm3(2)
3264         im3max=2
3265        endif
3266 
3267        vm4=max(1.d0,vvxpl*5.d0+1.d0)
3268        m4=min(int(vm4),5)
3269        wm4(2)=vm4-dble(m4)
3270        wm4(1)=1.d0-wm4(2)
3271        im4max=2
3272 
3273        do mn4=1,im4max
3274        do mn3=1,im3max
3275        do mn2=1,im2max
3276         mn=icz+m2+mn2+6*(m3+mn3-2)+36*(m4+mn4-2)
3277        do i1=1,iv1max
3278         i2=i+i1-2
3279        do j1=1,ivmax
3280         j2=j+j1-1
3281        do l1=1,izmax
3282         l2=jz+l1-1
3283        do k1=1,iymax
3284         k2=k+k1-1
3285         qgrevi=qgrevi+qrev(k2,l2,j2+11*i2,mn,icdp)
3286      *  *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wm2(mn2)*wm3(mn3)*wm4(mn4)
3287        enddo
3288        enddo
3289        enddo
3290        enddo
3291        enddo
3292        enddo
3293        enddo
3294        if(zz.lt.1.d0)then
3295         do mn4=1,im4max
3296         do mn3=1,im3max
3297         do mn2=1,im2max
3298          mn=icz+m2+mn2+6*(m3+mn3-2)+36*(m4+mn4-2)
3299         do i1=1,iv1max
3300          i2=i+i1-2
3301         do j1=1,ivmax
3302          j2=j+j1-1
3303         do k1=1,iymax
3304          k2=k+k1-1
3305          revm=revm+qrev(k2,1,j2+11*i2,mn,icdp)
3306      *   *wk(k1)*wj(j1)*wi(i1)*wm2(mn2)*wm3(mn3)*wm4(mn4)
3307         enddo
3308         enddo
3309         enddo
3310         enddo
3311         enddo
3312         enddo
3313         qgrevi=min(qgrevi,revm)
3314        endif
3315       endif
3316       qgrevi=dexp(qgrevi)*z*dlog(sy/sgap**2)
3317      **(1.d0-(1.d0-vvxt)**2)*(1.d0-vvxpt)
3318       return
3319       end
3320 
3321 c------------------------------------------------------------------------
3322       subroutine qgfan(sy,bb,vvx,icdp,icz,fann)
3323 c-----------------------------------------------------------------------
3324 c qgfan - integrated fan-contributions
3325 c sy    - c.m. energy squared,
3326 c bb    - impact parameter squared,
3327 c icdp  - diffractive state for the projectile,
3328 c icz   - hadron class
3329 c vvx  = 1 - exp[-sum_j chi_targ(j) - sum_{i<I} chi_proj(i)]
3330 c iqq=1  - general fan with loops
3331 c iqq=2  - general fan with single pomeron end
3332 c-----------------------------------------------------------------------
3333       implicit double precision (a-h,o-z)
3334       integer debug
3335       dimension fann(14)
3336       common /qgarr6/  pi,bm,amws
3337       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3338       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3339       common /qgarr19/ ahl(3)
3340       common /qgarr43/ moniou
3341       common /qgdebug/  debug
3342       common /arr3/   x1(7),a1(7)
3343 
3344       do iqq=1,2
3345        fann(iqq)=0.d0
3346       enddo
3347       if(sy.le.sgap**2)goto 1
3348 
3349       do ix1=1,7
3350       do mx1=1,2
3351        xpomr1=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
3352        rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
3353        rp1=alfp*log(xpomr1*sy)*4.d0*.0389d0
3354        rp2=rp*rp1/(rp+rp1)
3355        do ix2=1,7
3356        do mx2=1,2
3357         z=.5d0+x1(ix2)*(mx2-1.5d0)
3358         bb0=-rp2*log(z)
3359        do ix3=1,7
3360        do mx3=1,2
3361         phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3362         bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3363      *  +bb0*sin(phi)**2
3364         bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3365      *  +bb0*sin(phi)**2
3366 
3367         vpf1=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,2)
3368         vpf=min(vpf1,qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1))
3369         v1i1=qgpini(xpomr1*sy,bb1,0.d0,0.d0,3)
3370         v1i=min(v1i1,qgpini(xpomr1*sy,bb1,0.d0,0.d0,2))
3371         do iqq=1,2
3372          if(iqq.eq.1)then
3373           dpx=(1.d0-exp(-v1i))*(min(0.d0,1.d0-exp(-vpf)-vpf)
3374      *    *(1.d0-vvx)-vpf*vvx)
3375          else
3376           dpx=v1i1*(min(0.d0,1.d0-exp(-vpf)-vpf)*(1.d0-vvx)-vpf*vvx)
3377          endif
3378          fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3379         enddo
3380        enddo
3381        enddo
3382        enddo
3383        enddo
3384       enddo
3385       enddo
3386 1     continue
3387       do iqq=1,2
3388        fann(iqq)=(fann(iqq)*dlog(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
3389      * +qglegi(sy,bb,icdp,icz,iqq+1))
3390      * /(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
3391       enddo
3392       return
3393       end
3394 
3395 c------------------------------------------------------------------------
3396       subroutine qgfanc(sy,bb,vvx,vvxp,vvxpl,icdp,icz,fann)
3397 c-----------------------------------------------------------------------
3398 c qgfan - cut fan-contributions
3399 c sy    - c.m. energy squared,
3400 c bb    - impact parameter squared,
3401 c icdp  - diffractive state for the projectile,
3402 c icz   - hadron class,
3403 c vvx   = 1 - exp[-sum_j chi_targ(j) - sum_{i<I} chi_proj(i)]
3404 c vvxp  = 1 - exp[-sum_{i>I} chi^(3)_proj(i)] (iqq=1,2,3)
3405 c vvxp  = 1 - exp[-sum_{i>I} chi^(6)_proj(i)] (iqq=4)
3406 c vvxp  = 1 - exp[-sum_{i>I} chi_proj(i)]     (iqq=5-9)
3407 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
3408 c iqq=1 - cut handle fan
3409 c iqq=2 - no rap-gap at the end
3410 c iqq=3 - single cut Pomeron end
3411 c iqq=4 - total fan-like contribution
3412 c iqq=5 - leg-like cut
3413 c iqq=6 - leg-like cut with cut handle
3414 c iqq=7 - single Pomeron cut
3415 c iqq=8 - leg-like cut with single cut Pomeron end
3416 c iqq=9 - leg-like cut without a rap-gap at the end
3417 c-----------------------------------------------------------------------
3418       implicit double precision (a-h,o-z)
3419       integer debug
3420       dimension fann(14)
3421       common /qgarr6/  pi,bm,amws
3422       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3423       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3424       common /qgarr19/ ahl(3)
3425       common /qgarr43/ moniou
3426       common /qgdebug/  debug
3427       common /arr3/   x1(7),a1(7)
3428 
3429       do iqq=1,9
3430        fann(iqq)=0.d0
3431       enddo
3432       if(sy.le.sgap**2)goto 1
3433 
3434       if(vvx.gt..999d0)then
3435        vvxs=0.d0
3436       else
3437        vvxs=(1.d0-vvx)**2/(1.d0-vvxpl)
3438       endif
3439 
3440       do ix1=1,7
3441       do mx1=1,2
3442        xpomr1=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
3443        rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
3444        rp1=alfp*log(xpomr1*sy)*4.d0*.0389d0
3445        rp2=rp*rp1/(rp+rp1)
3446        do ix2=1,7
3447        do mx2=1,2
3448         z=.5d0+x1(ix2)*(mx2-1.5d0)
3449         bb0=-rp2*log(z)
3450        do ix3=1,7
3451        do mx3=1,2
3452         phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3453         bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3454      *  +bb0*sin(phi)**2
3455         bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3456      *  +bb0*sin(phi)**2
3457 
3458         vi=qgpini(xpomr1*sy,bb1,0.d0,0.d0,2)
3459         vicn=min(vi,qgpini(xpomr1*sy,bb1,0.d0,0.d0,8))
3460         vicgap=min(vicn,qgpini(xpomr1*sy,bb1,0.d0,0.d0,11))
3461         vic1p=min(vicgap,qgpini(xpomr1*sy,bb1,0.d0,0.d0,9))
3462         vic1=min(vic1p,qgpini(xpomr1*sy,bb1,0.d0,0.d0,5))
3463 
3464         vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
3465         vpfc0=min(vpf
3466      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,3))
3467         vpfct=max(vpf
3468      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,6))
3469         vpf1p=min(vpf
3470      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,7))
3471         vpf1p0=min(vpf1p
3472      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,8))
3473         vpfc1=min(vpf1p0
3474      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,9))
3475         do iqq=1,9
3476          if(iqq.eq.1)then      !cut handle
3477           dpx=(1.d0-exp(-vi))
3478      *    *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
3479      *    +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
3480          elseif(iqq.eq.2)then  !no rap-gap at the end
3481           dpx=(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
3482      *    +vicgap*exp(-2.d0*vicn))
3483      *    *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
3484      *    +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
3485          elseif(iqq.eq.3)then  !single cut Pomeron end
3486           dpx=vic1p*exp(-2.d0*vicn)
3487      *    *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
3488      *    +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
3489          elseif(iqq.eq.4)then  !total fan-like contribution
3490           dpx=(1.d0-exp(-vi))
3491      *    *((1.d0-vvxpl)*(min(0.d0,1.d0-exp(-vpfct)-vpfct)
3492      *    +vvxp*(exp(-vpfct)-exp(-vpf)))-vpfct*vvxpl)
3493          elseif(iqq.eq.5)then  !leg-like cut
3494           dpx=(1.d0-exp(-vi))*vpf1p
3495      *    *((1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3496          elseif(iqq.eq.6)then  !leg-like cut with cut handle
3497           dpx=(1.d0-exp(-vi))
3498      *    *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3499      *    -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
3500      *    *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
3501          elseif(iqq.eq.7)then  !single Pomeron cut
3502           dpx=vic1*exp(-2.d0*vicn)
3503      *    *vpfc1*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3504          elseif(iqq.eq.8)then  !leg-like cut with single cut Pomeron end
3505           dpx=vic1p*exp(-2.d0*vicn)
3506      *    *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3507      *    -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
3508      *    *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
3509          elseif(iqq.eq.9)then  !leg-like cut without a rap-gap at the end
3510           dpx=(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
3511      *    +vicgap*exp(-2.d0*vicn))
3512      *    *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
3513      *    -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
3514      *    *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
3515          else
3516           dpx=0.d0
3517          endif
3518          fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3519         enddo
3520        enddo
3521        enddo
3522        enddo
3523        enddo
3524       enddo
3525       enddo
3526 1     continue
3527       dfan=qglegi(sy,bb,icdp,icz,2)
3528       dfangap=min(dfan,qglegi(sy,bb,icdp,icz,7))
3529       dfan1p=min(dfangap,qglegi(sy,bb,icdp,icz,6))
3530       dfanc1=min(dfan1p,qglegi(sy,bb,icdp,icz,4))
3531       do iqq=1,9
3532        fann(iqq)=fann(iqq)*dlog(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
3533        if(iqq.eq.2.or.iqq.eq.9)then
3534         fann(iqq)=fann(iqq)+dfangap
3535        elseif(iqq.eq.3.or.iqq.eq.8)then
3536         fann(iqq)=fann(iqq)+dfan1p
3537        elseif(iqq.eq.7)then
3538         fann(iqq)=fann(iqq)+dfanc1
3539        else
3540         fann(iqq)=fann(iqq)+dfan
3541        endif
3542        fann(iqq)=fann(iqq)
3543      * /(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
3544       enddo
3545       return
3546       end
3547 
3548 c------------------------------------------------------------------------
3549       double precision function qgfani(sy,bb,vvx,vvxp,vvxpl
3550      *,icdp,icz,iqq)
3551 c-----------------------------------------------------------------------
3552 c qgfani - integrated fan-contributions
3553 c sy   - c.m. energy squared,
3554 c bb   - impact parameter squared,
3555 c icdp - diffractive state for the projectile,
3556 c icz  - hadron class,
3557 c vvx   = 1 - exp[-sum_j chi_targ(j) - sum_{i<I} chi_proj(i)]
3558 c vvxp=vvxpl=0                                (iqq=1,2)
3559 c vvxp  = 1 - exp[-sum_{i>I} chi^(3)_proj(i)] (iqq=3,4,5)
3560 c vvxp  = 1 - exp[-sum_{i>I} chi^(6)_proj(i)] (iqq=6)
3561 c vvxp  = 1 - exp[-sum_{i>I} chi_proj(i)]     (iqq=7-11)
3562 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
3563 c uncut fans:
3564 c iqq=1  - general fan with loops
3565 c iqq=2  - general fan with single pomeron end
3566 c cut fans:
3567 c iqq=3  - cut handle fan
3568 c iqq=4  - no rap-gap at the end
3569 c iqq=5  - single cut Pomeron end
3570 c iqq=6  - total fan-like contribution
3571 c iqq=7  - leg-like cut
3572 c iqq=8  - leg-like cut with cut handle
3573 c iqq=9  - single Pomeron cut
3574 c iqq=10 - leg-like cut with single cut Pomeron end
3575 c iqq=11 - leg-like cut without a rap-gap at the end
3576 c-----------------------------------------------------------------------
3577       implicit double precision (a-h,o-z)
3578       integer debug
3579       dimension wk(3),wz(3),wj(3),wi(3),wn(3)
3580       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3581       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3582       common /qgarr19/ ahl(3)
3583       common /qgarr20/ spmax
3584       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
3585      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
3586       common /qgarr43/ moniou
3587       common /qgdebug/  debug
3588 
3589       qgfani=0.d0
3590       fanm=0.d0
3591 
3592       if(sy.le.sgap**2)then
3593        qgfani=qglegi(sy,bb,icdp,icz,1)
3594        return
3595       endif
3596 
3597       rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
3598       z=dexp(-bb/rp)
3599       if(z.gt..2d0)then
3600        zz=5.d0*z+6.d0
3601       else
3602        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
3603       endif
3604       jz=min(9,int(zz))
3605       jz=max(1,jz)
3606       if(zz.lt.1.d0)then
3607        wz(2)=zz-jz
3608        wz(1)=1.d0-wz(2)
3609        izmax=2
3610       else
3611        if(jz.eq.6)jz=5
3612        wz(2)=zz-jz
3613        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
3614        wz(1)=1.d0-wz(2)+wz(3)
3615        wz(2)=wz(2)-2.d0*wz(3)
3616        izmax=3
3617       endif
3618 
3619       yl=dlog(sy/sgap)/dlog(spmax/sgap)*50.d0+1.d0
3620       k=max(1,int(1.00001d0*yl-1.d0))
3621       k=min(k,49)
3622       wk(2)=yl-k
3623       if(yl.le.2.d0)then
3624        iymax=2
3625        wk(1)=1.d0-wk(2)
3626       else
3627        wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
3628        wk(1)=1.d0-wk(2)+wk(3)
3629        wk(2)=wk(2)-2.d0*wk(3)
3630        iymax=3
3631       endif
3632 
3633       vl=max(1.d0,vvx*10.d0+1.d0)
3634       if(vvx.eq.0.d0)then
3635        ivmax=1
3636        j=1
3637        wj(1)=1.d0
3638       else
3639        j=min(int(vl),9)
3640        wj(2)=vl-dble(j)
3641        wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
3642        wj(1)=1.d0-wj(2)+wj(3)
3643        wj(2)=wj(2)-2.d0*wj(3)
3644        ivmax=3
3645       endif
3646 
3647       if(iqq.le.2)then
3648        ii=icdp+2*(icz-1)
3649        do j1=1,ivmax
3650         j2=j+j1-1
3651        do l1=1,izmax
3652         l2=jz+l1-1
3653        do k1=1,iymax
3654         k2=k+k1-1
3655         qgfani=qgfani+qfanu(k2,l2,j2,ii,iqq)
3656      *  *wk(k1)*wz(l1)*wj(j1)
3657        enddo
3658        enddo
3659        enddo
3660        if(zz.lt.1.d0)then
3661         do j1=1,ivmax
3662          j2=j+j1-1
3663         do k1=1,iymax
3664          k2=k+k1-1
3665          fanm=fanm+qfanu(k2,1,j2,ii,iqq)*wk(k1)*wj(j1)
3666         enddo
3667         enddo
3668         qgfani=min(qgfani,fanm)
3669        endif
3670 
3671       elseif(icz.ne.2.or.vvxp+vvxpl.eq.0.d0)then  !hadron (no proj. nucl. corr.)
3672        ii=icdp+2*(iqq-3)
3673        ll=icz+(icz-1)*(3-icz)*2
3674        do j1=1,ivmax
3675         j2=j+j1-1
3676        do l1=1,izmax
3677         l2=jz+l1-1
3678        do k1=1,iymax
3679         k2=k+k1-1
3680         qgfani=qgfani+qfanc(k2,l2,j2,ll,ii)*wk(k1)*wz(l1)*wj(j1)
3681        enddo
3682        enddo
3683        enddo
3684        if(zz.lt.1.d0)then
3685         do j1=1,ivmax
3686          j2=j+j1-1
3687         do k1=1,iymax
3688          k2=k+k1-1
3689          fanm=fanm+qfanc(k2,1,j2,ll,ii)*wk(k1)*wj(j1)
3690         enddo
3691         enddo
3692         qgfani=min(qgfani,fanm)
3693        endif
3694 
3695       else
3696        iv1max=2
3697        vl1=max(1.d0,vvxp*5.d0+1.d0)
3698        i=min(int(vl1),5)
3699        wi(2)=vl1-i
3700        wi(1)=1.d0-wi(2)
3701 
3702        if(vvx.lt..01d0)then                 !weak (no) screening
3703         iv2max=1
3704          n=1
3705         wn(1)=1.d0
3706        else                                    !nuclear effects
3707         iv2max=2
3708         vl2=max(1.d0,vvxpl/vvx*5.d0+1.d0)
3709         n=min(int(vl2),5)
3710         wn(2)=vl2-n
3711         wn(1)=1.d0-wn(2)
3712        endif
3713 
3714        ii=icdp+2*(iqq-3)
3715        do n1=1,iv2max
3716         n2=n+n1-2
3717        do i1=1,iv1max
3718         i2=i+i1+2
3719        do j1=1,ivmax
3720         j2=j+j1-1
3721        do l1=1,izmax
3722         l2=jz+l1-1
3723        do k1=1,iymax
3724         k2=k+k1-1
3725         qgfani=qgfani+qfanc(k2,l2,j2,i2+6*n2,ii)
3726      *  *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wn(n1)
3727        enddo
3728        enddo
3729        enddo
3730        enddo
3731        enddo
3732        if(zz.lt.1.d0)then
3733         do n1=1,iv2max
3734          n2=n+n1-2
3735         do i1=1,iv1max
3736          i2=i+i1+2
3737         do j1=1,ivmax
3738          j2=j+j1-1
3739         do k1=1,iymax
3740          k2=k+k1-1
3741          fanm=fanm+qfanc(k2,1,j2,i2+6*n2,ii)
3742      *   *wk(k1)*wj(j1)*wi(i1)*wn(n1)
3743         enddo
3744         enddo
3745         enddo
3746         enddo
3747         qgfani=min(qgfani,fanm)
3748        endif
3749       endif
3750       qgfani=dexp(qgfani)*z
3751      **(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
3752       return
3753       end
3754 
3755 c------------------------------------------------------------------------
3756       subroutine qgdfan(xpomr,xpomr1,bb,icdp,fann,nn)
3757 c-----------------------------------------------------------------------
3758 c qgdfan - diffractive fans
3759 c xpomr - pomeron lc momentum,
3760 c xpomr1 - rapgap,
3761 c bb    - impact parameter squared,
3762 c icdp - diffractive state for the projectile,
3763 c-----------------------------------------------------------------------
3764       implicit double precision (a-h,o-z)
3765       integer debug
3766       dimension fann(14),dps(3)
3767       common /qgarr6/  pi,bm,amws
3768       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3769       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3770       common /qgarr19/ ahl(3)
3771       common /qgarr43/ moniou
3772       common /qgdebug/  debug
3773       common /arr3/   x1(7),a1(7)
3774 
3775       icz=2
3776       do iqq=1,3
3777        fann(iqq)=0.d0
3778       enddo
3779 
3780       rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
3781       rp1=alfp*log(xpomr1/xpomr)*4.d0*.0389d0
3782       rp2=rp*rp1/(rp+rp1)
3783       do ix2=1,7
3784       do mx2=1,2
3785        z=.5d0+x1(ix2)*(mx2-1.5d0)
3786        bb0=-rp2*log(z)
3787       do ix3=1,7
3788       do mx3=1,2
3789        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3790        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3791      * +bb0*sin(phi)**2
3792        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3793      * +bb0*sin(phi)**2
3794 
3795        vpf=qgfani(1.d0/xpomr1,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
3796        v1i1=qgpini(xpomr1/xpomr,bb1,0.d0,0.d0,3)
3797        v1i=min(v1i1,qgpini(xpomr1/xpomr,bb1,0.d0,0.d0,2))
3798 
3799        do iqq=1,2
3800         if(iqq.eq.1)then
3801          dpx=(1.d0-exp(-v1i))*(1.d0-exp(-vpf))**2
3802         else
3803          dpx=v1i1*(1.d0-exp(-vpf))**2
3804         endif
3805         fann(iqq)=fann(iqq)+a1(ix2)*a1(ix3)*dpx/z*rp2
3806        enddo
3807       enddo
3808       enddo
3809       enddo
3810       enddo
3811 
3812       do ix1=1,7
3813       do mx1=1,2
3814        xpomr2=xpomr1*(xpomr/xpomr1*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))
3815        rp=(rq(icdp,icz)-alfp*log(xpomr2))*2.d0*.0389d0
3816        rp1=alfp*log(xpomr2/xpomr)*4.d0*.0389d0
3817        rp2=rp*rp1/(rp+rp1)
3818        do ix2=1,7
3819        do mx2=1,2
3820         z=.5d0+x1(ix2)*(mx2-1.5d0)
3821         bb0=-rp2*log(z)
3822        do ix3=1,7
3823        do mx3=1,2
3824         phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3825         bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3826      *  +bb0*sin(phi)**2
3827         bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3828      *  +bb0*sin(phi)**2
3829 
3830         vpf=qgfani(1.d0/xpomr2,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
3831         v1i=qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,2)
3832         dpx=(1.d0-exp(-v1i))*(1.d0-exp(-vpf))**2/2.d0
3833         fann(3)=fann(3)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3834        enddo
3835        enddo
3836        enddo
3837        enddo
3838       enddo
3839       enddo
3840       do iqq=1,3
3841        fann(iqq)=fann(iqq)*(r3p*pi/.0389d0)/g3p**3/8.d0
3842       enddo
3843 
3844       if(nn.gt.1.and.xpomr1/xpomr.gt.sgap**2)then
3845        do iqq=1,3
3846         dps(iqq)=0.d0
3847        enddo
3848        do ix1=1,7
3849        do mx1=1,2
3850         xpomr2=xpomr1/sgap*(xpomr/xpomr1*sgap**2)
3851      *  **(.5d0+x1(ix1)*(mx1-1.5d0))
3852         rp=(rq(icdp,icz)-alfp*log(xpomr2))*2.d0*.0389d0
3853         rp1=alfp*log(xpomr2/xpomr)*4.d0*.0389d0
3854         rp2=rp*rp1/(rp+rp1)
3855         do ix2=1,7
3856         do mx2=1,2
3857          z=.5d0+x1(ix2)*(mx2-1.5d0)
3858          bb0=-rp2*log(z)
3859         do ix3=1,7
3860         do mx3=1,2
3861          phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
3862           bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
3863      *   +bb0*sin(phi)**2
3864          bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
3865      *   +bb0*sin(phi)**2
3866 
3867          vpf=qgfani(1.d0/xpomr2,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
3868          v1i1=qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,3)
3869          v1i=min(v1i1,qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,2))
3870          vpdf=qgdfani(xpomr2,xpomr1,bb2,icdp,1)
3871          vpdfi=qgdfani(xpomr2,xpomr1,bb2,icdp,3)
3872          do iqq=1,3
3873           if(iqq.eq.1)then
3874            dpx=(1.d0-exp(-v1i))*vpdf*(exp(2.d0*(vpdfi-vpf))-1.d0)
3875           elseif(iqq.eq.2)then
3876            dpx=v1i1*vpdf*(exp(2.d0*(vpdfi-vpf))-1.d0)
3877           elseif(iqq.eq.3)then
3878            dpx=(1.d0-exp(-v1i))*((exp(2.d0*vpdfi)-1.d0)*exp(-2.d0*vpf)
3879      *     -2.d0*vpdfi)/2.d0/dlog(xpomr1/xpomr/sgap)
3880           endif
3881           dps(iqq)=dps(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
3882          enddo
3883         enddo
3884         enddo
3885         enddo
3886         enddo
3887        enddo
3888        enddo
3889        do iqq=1,3
3890         fann(iqq)=fann(iqq)+dps(iqq)*dlog(xpomr1/xpomr/sgap**2)
3891      *  *(r3p*pi/.0389d0)/g3p**3/8.d0
3892        enddo
3893       endif
3894       return
3895       end
3896 
3897 c------------------------------------------------------------------------
3898       double precision function qgdfani(xpomr,xpomr1,bb,icdp,iqq)
3899 c-----------------------------------------------------------------------
3900 c qgfani - integrated fan-contributions
3901 c xpomr - pomeron lc momentum,
3902 c xpomr1 - rapgap,
3903 c bb    - impact parameter squared,
3904 c icdp - diffractive state for the projectile,
3905 c icz  - hadron class
3906 c iqq=1 - total unintegrated,
3907 c iqq=2 - single end unintegrated,
3908 c iqq=3 - total integrated
3909 c-----------------------------------------------------------------------
3910       implicit double precision (a-h,o-z)
3911       integer debug
3912       dimension wk(3),wz(3),wj(3)
3913       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
3914       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
3915       common /qgarr19/ ahl(3)
3916       common /qgarr20/ spmax
3917       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
3918      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
3919       common /qgarr43/ moniou
3920       common /qgdebug/  debug
3921 
3922       qgdfani=0.d0
3923       dfanm=0.d0
3924       if(xpomr*sgap**2.gt.1.d0)return
3925 
3926       icz=2
3927       rp=(rq(icdp,icz)-alfp*dlog(xpomr))*2.d0*.0389d0
3928       z=dexp(-bb/rp)
3929       if(z.gt..2d0)then
3930        zz=5.d0*z+6.d0
3931       else
3932        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
3933       endif
3934       jz=min(9,int(zz))
3935       jz=max(1,jz)
3936       if(zz.lt.1.d0)then
3937        wz(2)=zz-jz
3938        wz(1)=1.d0-wz(2)
3939        izmax=2
3940       else
3941        if(jz.eq.6)jz=5
3942        wz(2)=zz-jz
3943        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
3944        wz(1)=1.d0-wz(2)+wz(3)
3945        wz(2)=wz(2)-2.d0*wz(3)
3946        izmax=3
3947       endif
3948 
3949       if(xpomr*sgap**2.gt..9999d0)then
3950        k=1
3951        j=1
3952        wk(1)=1.d0
3953        wj(1)=1.d0
3954        iymax=1
3955        iy1max=1
3956       else
3957        yl=-dlog(xpomr*sgap**2)/dlog(1.d5/sgap**2)*20.d0+1.d0
3958        k=max(1,int(1.00001d0*yl-1.d0))
3959        k=min(k,19)
3960        wk(2)=yl-k
3961        if(yl.le.2.d0)then
3962         iymax=2
3963         wk(1)=1.d0-wk(2)
3964        else
3965         wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
3966         wk(1)=1.d0-wk(2)+wk(3)
3967         wk(2)=wk(2)-2.d0*wk(3)
3968         iymax=3
3969        endif
3970 
3971        yl1=11.d0-dlog(xpomr1*sgap)/dlog(xpomr*sgap**2)*10.d0
3972        j=max(1,int(yl1))
3973        j=min(j,9)
3974        wj(2)=yl1-dble(j)
3975        wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
3976        wj(1)=1.d0-wj(2)+wj(3)
3977        wj(2)=wj(2)-2.d0*wj(3)
3978        iy1max=3
3979       endif
3980 
3981       do l1=1,izmax
3982        l2=jz+l1-1
3983       do j1=1,iy1max
3984        j2=j+j1-1
3985       do k1=1,iymax
3986        k2=k+k1-1
3987        qgdfani=qgdfani+qdfan(k2,j2,l2,icdp,iqq)
3988      * *wk(k1)*wz(l1)*wj(j1)
3989       enddo
3990       enddo
3991       enddo
3992       if(zz.lt.1.d0)then
3993        do j1=1,iy1max
3994         j2=j+j1-1
3995        do k1=1,iymax
3996         k2=k+k1-1
3997         dfanm=dfanm+qdfan(k2,j2,1,icdp,iqq)*wk(k1)*wj(j1)
3998        enddo
3999        enddo
4000        qgdfani=min(qgdfani,dfanm)
4001       endif
4002       qgdfani=dexp(qgdfani)*z
4003       if(iqq.eq.3)qgdfani=qgdfani*max(0.d0,dlog(xpomr1/xpomr/sgap))
4004       return
4005       end
4006 
4007 c=============================================================================
4008       double precision function qg3pom(sy,b,vvx,vvxp,vvxt
4009      *,icdp,icdt,icz)
4010 c-----------------------------------------------------------------------
4011 c qg3pom - integrated 3p-contributions to the interaction eikonal
4012 c sy   - pomeron mass squared,
4013 c b    - impact parameter,
4014 c icdp - diffractive state for the projectile,
4015 c icdt - diffractive state for the target,
4016 c icz  - hadron class
4017 c vvx  = 1 - exp[-sum_{j<J} chi_targ(j) - sum_{i<I} chi_proj(i)]
4018 c vvxp = 1 - exp[-sum_{i>I} chi_proj(i)]
4019 c vvxt = 1 - exp[-sum_{j>J} chi_targ(j)]
4020 c------------------------------------------------------------------------
4021       implicit double precision (a-h,o-z)
4022       integer debug
4023       common /qgarr6/  pi,bm,amws
4024       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4025       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4026       common /qgdebug/  debug
4027       common /qgarr43/ moniou
4028       common /arr3/   x1(7),a1(7)
4029 
4030       qg3pom=0.d0
4031       if(sy.le.sgap**2)return
4032 
4033       do ix1=1,7
4034       do mx1=1,2
4035        xpomr1=(sy/sgap**2)**(-(.5+x1(ix1)*(mx1-1.5)))/sgap
4036        rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
4037        rp2=(rq(icdt,2)+alfp*log(xpomr1*sy))*4.d0*.0389d0
4038        rp=rp1*rp2/(rp1+rp2)
4039       do ib1=1,7
4040       do mb1=1,2
4041        z=.5d0+x1(ib1)*(mb1-1.5d0)
4042        bb0=-rp*dlog(z)
4043       do ib2=1,7
4044       do mb2=1,2
4045        phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
4046        bb1=(b*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
4047        bb2=(b*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
4048 
4049        v1p0=qglegi(1.d0/xpomr1,bb1,icdp,icz,1)
4050        v1t0=qglegi(xpomr1*sy,bb2,icdt,2,1)
4051        v1p1=min(v1p0,qglegi(1.d0/xpomr1,bb1,icdp,icz,3))
4052        v1t1=min(v1t0,qglegi(xpomr1*sy,bb2,icdt,2,3))
4053        v1p=min(v1p1,qglegi(1.d0/xpomr1,bb1,icdp,icz,2))
4054        v1t=min(v1t1,qglegi(xpomr1*sy,bb2,icdt,2,2))
4055 
4056        vpf0=min(v1p,qgfani(1.d0/xpomr1,bb1
4057      * ,1.d0-(1.d0-vvx)*(1.d0-vvxt),0.d0,0.d0,icdp,icz,1))
4058        vtf0=min(v1t,qgfani(xpomr1*sy,bb2
4059      * ,1.d0-(1.d0-vvx)*(1.d0-vvxp),0.d0,0.d0,icdt,2,1))
4060 
4061        n=1
4062 1      n=n+1
4063        vpf=qgfani(1.d0/xpomr1,bb1
4064      * ,1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf0),0.d0,0.d0,icdp,icz,1)
4065        vtf=qgfani(xpomr1*sy,bb2
4066      * ,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf0),0.d0,0.d0,icdt,2,1)
4067        if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.lt.100)
4068      * then
4069         vpf0=vpf
4070         vtf0=vtf
4071         goto 1
4072        endif
4073 
4074        dpx=(1.d0-vvx)*(min(0.d0,1.d0-exp(-vpf)-vpf)
4075      * *min(0.d0,1.d0-exp(-vtf)-vtf)
4076      * +vpf*min(0.d0,1.d0-exp(-vtf)-vtf)
4077      * +vtf*min(0.d0,1.d0-exp(-vpf)-vpf))-vvx*vpf*vtf
4078      * -.5d0*(vtf-v1t)*(min(0.d0,1.d0-exp(-vpf)-vpf)
4079      * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf)
4080      * -vpf*(1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf)))
4081      * -.5d0*(vpf-v1p)*(min(0.d0,1.d0-exp(-vtf)-vtf)
4082      * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)
4083      * -vtf*(1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)))
4084      * +.5d0*(v1t-v1t1)*v1p0+.5d0*(v1p-v1p1)*v1t0
4085        dpx=min(1.d0,dpx)
4086 
4087        qg3pom=qg3pom+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
4088       enddo
4089       enddo
4090       enddo
4091       enddo
4092       enddo
4093       enddo
4094       qg3pom=qg3pom/8.d0*log(sy/sgap**2)*(r3p*pi/.0389d0)/g3p**3
4095       return
4096       end
4097 
4098 c------------------------------------------------------------------------
4099       double precision function qgpcut(sy,b,vvx,vvxp,vvxt
4100      *,icdp,icdt,icz)
4101 c-----------------------------------------------------------------------
4102 c qglool - integrated Pomeron leg eikonal with loops
4103 c sy   - pomeron mass squared,
4104 c bb   - impact parameter squared,
4105 c vvx  = 1 - exp[-sum_{j<J} chi_targ(j) - sum_{i<I} chi_proj(i)]
4106 c vvxp = 1 - exp[-sum_{i>I} chi_proj(i)]
4107 c vvxt = 1 - exp[-sum_{j>J} chi_targ(j)]
4108 c icz  - hadron class
4109 c-----------------------------------------------------------------------
4110       implicit double precision (a-h,o-z)
4111       integer debug
4112       common /qgarr6/  pi,bm,amws
4113       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4114       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4115       common /qgarr19/ ahl(3)
4116       common /qgarr43/ moniou
4117       common /qgdebug/  debug
4118       common /arr3/   x1(7),a1(7)
4119 
4120       qgpcut=0.d0
4121       if(sy.le.sgap**2)return
4122 
4123       do ix1=1,7
4124       do mx1=1,2
4125        xpomr1=(sy/sgap**2)**(-(.5+x1(ix1)*(mx1-1.5)))/sgap
4126        rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
4127        rp2=(rq(icdt,2)+alfp*log(xpomr1*sy))*4.d0*.0389d0
4128        rp=rp1*rp2/(rp1+rp2)
4129       do ib1=1,7
4130       do mb1=1,2
4131        z=.5d0+x1(ib1)*(mb1-1.5d0)
4132        bb0=-rp*dlog(z)
4133       do ib2=1,7
4134       do mb2=1,2
4135        phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
4136        bb1=(b*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
4137        bb2=(b*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
4138 
4139        vpl=qglegi(1.d0/xpomr1,bb1,icdp,icz,1)
4140        vtl=qglegi(xpomr1*sy,bb2,icdt,2,1)
4141        vpf0=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
4142      * ,0.d0,0.d0,icdp,icz,1)
4143        vtf0=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)
4144      * ,0.d0,0.d0,icdt,2,1)
4145 
4146        n=1
4147 1      n=n+1
4148        vpf=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
4149      * *exp(-vtf0),0.d0,0.d0,icdp,icz,1)
4150        vtf=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf0)
4151      * ,0.d0,0.d0,icdt,2,1)
4152        if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.lt.100)
4153      * then
4154         vpf0=vpf
4155         vtf0=vtf
4156         goto 1
4157        endif
4158 
4159        vpls=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
4160      * *exp(-vtf),vvxp,0.d0,icdp,icz,9)
4161        vtls=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)
4162      * ,vvxt,0.d0,icdt,2,9)
4163        vploop0=qglegi(1.d0/xpomr1,bb1,icdp,icz,5)
4164        vploop=min(vploop0,qglegi(1.d0/xpomr1,bb1,icdp,icz,4))
4165        vtloop0=qglegi(xpomr1*sy,bb2,icdt,2,5)
4166        vtloop=min(vtloop0,qglegi(xpomr1*sy,bb2,icdt,2,4))
4167 
4168        dpx=(vpls*vtloop+vtls*vploop)*(((1.d0-vvx)*(1.d0-vvxp)
4169      * *(1.d0-vvxt))**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
4170      * +vpl*(vtloop-vtloop0)+vtl*(vploop-vploop0)
4171 
4172        qgpcut=qgpcut+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
4173       enddo
4174       enddo
4175       enddo
4176       enddo
4177       enddo
4178       enddo
4179       qgpcut=qgpcut/16.d0*log(sy/sgap**2)*(r3p*pi/.0389d0)/g3p**3
4180       return
4181       end
4182 
4183 c------------------------------------------------------------------------
4184       double precision function qgpomi(sy,bb,vvx,vvxp,vvxt
4185      *,icdp,icdt,icz,iqq)
4186 c-----------------------------------------------------------------------
4187 c qgpomi - integrated  eikonal contributions
4188 c sy   - pomeron mass squared,
4189 c bb   - impact parameter squared,
4190 c icdp - diffractive state for the projectile,
4191 c icdt - diffractive state for the target,
4192 c icz  - projectile class
4193 c-----------------------------------------------------------------------
4194       implicit double precision (a-h,o-z)
4195       integer debug
4196       dimension wk(3),wz(3),wi(3),wj(3),wm(3)
4197       common /qgarr10/ am(7),ammu
4198       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4199       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4200       common /qgarr24/ qpomr(11,11,216,12,2)
4201       common /qgdebug/  debug
4202       common /qgarr43/ moniou
4203 
4204       qgpomi=0.d0
4205       pomm=0.d0
4206       if(cd(icdp,icz).eq.0.d0.or.cd(icdt,2).eq.0.d0)return
4207 
4208       rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
4209       z=exp(-bb/rp)
4210       if(z.gt..2d0)then
4211        zz=5.d0*z+6.d0
4212       else
4213        zz=(-bb/rp-log(0.2d0))/2.d0+7.d0
4214       endif
4215       jz=min(9,int(zz))
4216       jz=max(1,jz)
4217       if(zz.lt.1.d0)then
4218        wz(2)=zz-jz
4219        wz(1)=1.d0-wz(2)
4220        izmax=2
4221       else
4222        if(jz.eq.6)jz=5
4223        wz(2)=zz-jz
4224        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
4225        wz(1)=1.d0-wz(2)+wz(3)
4226        wz(2)=wz(2)-2.d0*wz(3)
4227        izmax=3
4228       endif
4229 
4230       yl=dlog10((sy-am(2)**2-am(icz)**2)/2.d0/am(2))
4231       k=max(1,int(yl))
4232       k=min(k,9)
4233       wk(2)=yl-k
4234       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
4235       wk(1)=1.d0-wk(2)+wk(3)
4236       wk(2)=wk(2)-2.d0*wk(3)
4237 
4238       ml=icdp+2*(icdt-1)+4*(icz-1)
4239       if(vvx+vvxp+vvxt.eq.0.d0)then  !hadron-proton (no nucl. screening)
4240        do l1=1,izmax
4241         l2=jz+l1-1
4242        do k1=1,3
4243         k2=k+k1-1
4244         qgpomi=qgpomi+qpomr(k2,l2,1,ml,iqq)*wk(k1)*wz(l1)
4245        enddo
4246        enddo
4247        if(zz.lt.1.d0)then
4248         do k1=1,3
4249          k2=k+k1-1
4250          pomm=pomm+qpomr(k2,1,1,ml,iqq)*wk(k1)
4251         enddo
4252         qgpomi=min(qgpomi,pomm)
4253        endif
4254       else
4255        vl=max(1.d0,vvx*5.d0+1.d0)
4256        j=min(int(vl),4)
4257        wj(2)=vl-j
4258        wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
4259        wj(1)=1.d0-wj(2)+wj(3)
4260        wj(2)=wj(2)-2.d0*wj(3)
4261 
4262        if(icz.ne.2.or.vvxp.eq.0.d0)then   !hadron-nucleus (no proj. nucl. scr.)
4263         i1max=1
4264         i=1
4265         wi(1)=1.d0
4266        else
4267         i1max=3
4268         vl1=max(1.d0,vvxp*5.d0+1.d0)
4269         i=min(int(vl1),4)
4270         wi(2)=vl1-i
4271         wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
4272         wi(1)=1.d0-wi(2)+wi(3)
4273         wi(2)=wi(2)-2.d0*wi(3)
4274        endif
4275 
4276        vl2=max(1.d0,vvxt*5.d0+1.d0)
4277        m=min(int(vl2),4)
4278        wm(2)=vl2-m
4279        wm(3)=wm(2)*(wm(2)-1.d0)*.5d0
4280        wm(1)=1.d0-wm(2)+wm(3)
4281        wm(2)=wm(2)-2.d0*wm(3)
4282 
4283        do m1=1,3
4284         m2=m+m1-2
4285        do i1=1,i1max
4286         i2=i+i1-2
4287        do j1=1,3
4288         j2=j+j1-1
4289         mij=j2+6*i2+36*m2
4290        do l1=1,izmax
4291         l2=jz+l1-1
4292        do k1=1,3
4293         k2=k+k1-1
4294         qgpomi=qgpomi+qpomr(k2,l2,mij,ml,iqq)
4295      *  *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wm(m1)
4296        enddo
4297        enddo
4298        enddo
4299        enddo
4300        enddo
4301        if(zz.lt.1.d0)then
4302         do m1=1,3
4303          m2=m+m1-2
4304         do i1=1,i1max
4305          i2=i+i1-2
4306         do j1=1,3
4307          j2=j+j1-1
4308          mij=j2+6*i2+36*m2
4309         do k1=1,3
4310          k2=k+k1-1
4311          pomm=pomm+qpomr(k2,1,mij,ml,iqq)*wk(k1)*wj(j1)*wi(i1)*wm(m1)
4312         enddo
4313         enddo
4314         enddo
4315         enddo
4316         qgpomi=min(qgpomi,pomm)
4317        endif
4318       endif
4319       qgpomi=exp(qgpomi)*z
4320       return
4321       end
4322 
4323 c------------------------------------------------------------------------
4324       double precision function qgppdi(xp,iqq)
4325 c-----------------------------------------------------------------------
4326 c qgppdi - parton distributions in the Pomeron
4327 c xp    - parton LC momentum share,
4328 c iqq=0 - gluon
4329 c iqq=1 - sea quark
4330 c-----------------------------------------------------------------------
4331       implicit double precision (a-h,o-z)
4332       integer debug
4333       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4334       common /qgarr20/ spmax
4335       common /qgarr43/ moniou
4336       common /qgdebug/  debug
4337 
4338 c... initialize
4339       qgppdi=0.d0
4340       if(debug.ge.3)write (moniou,201)xp,iqq
4341       if(xp.ge..9999999d0)then
4342        qgppdi=0.d0
4343       else
4344        if(iqq.eq.0)then                             !gluon
4345         qgppdi=(1.d0-xp)**betp*(1.d0-dgqq)
4346        elseif(iqq.eq.1)then                         !quark
4347         qgppdi=qgftlf(xp)*dgqq
4348        endif
4349       endif
4350       if(debug.ge.4)write (moniou,202)qgppdi
4351 
4352 201   format(2x,'qgppdi - parton distr. in the Pomeron (interpol.):'
4353      */4x,'xp=',e10.3,2x,'iqq=',i1)
4354 202   format(2x,'qgppdi=',e10.3)
4355       return
4356       end
4357 
4358 c=============================================================================
4359       double precision function qgvpdf(x,icz)
4360 c-----------------------------------------------------------------------------
4361 c qgvpdf - valence quark structure function
4362 c x   - Feinman x,
4363 c icz - hadron class
4364 c-----------------------------------------------------------------------------
4365       implicit double precision (a-h,o-z)
4366       integer debug
4367       common /qgarr6/  pi,bm,amws
4368       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4369       common /qgarr25/ ahv(3)
4370       common /qgarr43/ moniou
4371       common /qgdebug/  debug
4372 
4373       qgvpdf=(qggrv(x,qt0,icz,1)+qggrv(x,qt0,icz,2))*(1.d0-x)**ahv(icz)
4374       return
4375       end
4376 
4377 c=============================================================================
4378       double precision function qgspdf(x,icz)
4379 c-----------------------------------------------------------------------------
4380 c qgspdf - sea quark structure function
4381 c x   - Feinman x,
4382 c icz - hadron class
4383 c-----------------------------------------------------------------------------
4384       implicit double precision (a-h,o-z)
4385       integer debug
4386       parameter(iapmax=208)
4387       common /qgarr6/  pi,bm,amws
4388       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4389       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4390       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4391       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4392       common /qgarr43/ moniou
4393       common /qgdebug/  debug
4394       common /arr3/   x1(7),a1(7)
4395 
4396       qgspdf=0.d0
4397       if(x*sgap.ge.1.d0)goto 1
4398 
4399       do icdp=1,2
4400        rp=(rq(icdp,icz)-alfp*log(x))*2.d0*.0389d0
4401        if(cd(icdp,icz).ne.0.d0)then
4402         dps=0.d0
4403         do ix=1,7
4404         do mx=1,2
4405          xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
4406         do ib=1,7
4407         do mb=1,2
4408          z=.5d0+x1(ib)*(mb-1.5d0)
4409          bb=-rp*log(z)
4410 
4411          v1p1=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,2)
4412          v1p=min(v1p1,qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1))
4413          dps=dps+a1(ix)*a1(ib)*(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
4414      *   *qgftlf(x/xpomr)*(xpomr/x)**dels/z
4415         enddo
4416         enddo
4417         enddo
4418         enddo
4419         qgspdf=qgspdf-dps*dlog(x*sgap)*rp/g3p**2*pi*rr*(r3p*pi/.0389d0)
4420      *  *dgqq*cc(icdp,icz)
4421        endif
4422       enddo
4423 
4424 1     qgspdf=qgspdf+4.*pi*rr*fp(icz)*qgftle(x,icz)/x**dels
4425       return
4426       end
4427 
4428 c=============================================================================
4429       double precision function qggpdf(x,icz)
4430 c-----------------------------------------------------------------------------
4431 c qggpdf - gluon structure function (xg(x,qt0))
4432 c x   - Feinman x,
4433 c icz - hadron class
4434 c-----------------------------------------------------------------------------
4435       implicit double precision (a-h,o-z)
4436       integer debug
4437       parameter(iapmax=208)
4438       common /qgarr6/  pi,bm,amws
4439       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4440       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4441       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4442       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4443       common /qgarr43/ moniou
4444       common /qgdebug/  debug
4445       common /arr3/   x1(7),a1(7)
4446 
4447       qggpdf=0.d0
4448       if(x*sgap.ge.1.d0)goto 1
4449 
4450       do icdp=1,2
4451        rp=(rq(icdp,icz)-alfp*log(x))*2.d0*.0389d0
4452        if(cd(icdp,icz).ne.0.d0)then
4453         dps=0.d0
4454         do ix=1,7
4455         do mx=1,2
4456          xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
4457         do ib=1,7
4458         do mb=1,2
4459          z=.5d0+x1(ib)*(mb-1.5d0)
4460          bb=-rp*log(z)
4461 
4462          v1p1=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,2)
4463          v1p=min(v1p1,qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1))
4464          dps=dps+a1(ix)*a1(ib)*(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
4465      *   *(1.d0-x/xpomr)**betp*(xpomr/x)**dels/z
4466         enddo
4467         enddo
4468         enddo
4469         enddo
4470         qggpdf=qggpdf-dps*dlog(x*sgap)*rp/g3p**2*pi*rr*(r3p*pi/.0389d0)
4471      *  *(1.d0-dgqq)*cc(icdp,icz)
4472        endif
4473       enddo
4474 
4475 1     qggpdf=qggpdf+4.*pi*rr*fp(icz)*qgftld(x,icz)/x**dels
4476       return
4477       end
4478 
4479 c=============================================================================
4480       double precision function qgpdfb(x,bb,icz,jj)
4481 c-----------------------------------------------------------------------------
4482 c qgpdfb - b-dependent parton momentum distributions (xf(x,b,qt0))
4483 c x   - Feinman x,
4484 c icz - hadron class
4485 c jj=0 - g,
4486 c jj=1 - q
4487 c-----------------------------------------------------------------------------
4488       implicit double precision (a-h,o-z)
4489       integer debug
4490       parameter(iapmax=208)
4491       common /qgarr6/  pi,bm,amws
4492       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4493       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4494       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4495       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4496       common /qgarr43/ moniou
4497       common /qgdebug/  debug
4498       common /arr3/   x1(7),a1(7)
4499 
4500       qgpdfb=0.d0
4501       if(x*sgap.lt.1.d0)then
4502        do icdp=1,2
4503         if(cd(icdp,icz).ne.0.d0)then
4504          dps=0.d0
4505          do ix=1,7
4506          do mx=1,2
4507           xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
4508           rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
4509           rp1=alfp*dlog(xpomr/x)*4.d0*.0389d0
4510           rp2=rp1*rp/(rp1+rp)
4511          do ix2=1,7
4512          do mx2=1,2
4513           bb0=-rp2*log(.5d0+x1(ix2)*(mx2-1.5d0))
4514          do ix3=1,7
4515          do mx3=1,2
4516           phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
4517           bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
4518      *    +bb0*sin(phi)**2
4519           bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
4520      *    +bb0*sin(phi)**2
4521 
4522           if(jj.eq.0)then
4523            v1i=(1.d0-x/xpomr)**betp*(1.d0-dgqq)
4524           else
4525            v1i=qgftlf(x/xpomr)*dgqq
4526           endif
4527           v1p1=qgfani(1.d0/xpomr,bb2,0.d0,0.d0,0.d0,icdp,icz,2)
4528           v1p=min(v1p1,qgfani(1.d0/xpomr,bb2,0.d0,0.d0,0.d0,icdp,icz,1))
4529 
4530           dps=dps+a1(ix)*a1(ix2)*a1(ix3)*v1i
4531      *    *(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
4532      *    *(xpomr/x)**dels*rp/(rp1+rp)*exp(bb2/rp-bb/(rp1+rp))
4533          enddo
4534          enddo
4535          enddo
4536          enddo
4537          enddo
4538          enddo
4539          qgpdfb=qgpdfb-dps*dlog(x*sgap)*pi*rr*r3p/g3p**2/.0389d0/2.d0
4540      *   *cc(icdp,icz)
4541         endif
4542        enddo
4543 
4544        do icdp=1,2
4545         rp=(rq(icdp,icz)-alfp*dlog(x))*4.d0*.0389d0
4546         if(jj.eq.0)then
4547          qgpdfb=qgpdfb+4.d0*rr*fp(icz)*qgftld(x,icz)/x**dels
4548      *   /rp*exp(-bb/rp)*cc(icdp,icz)
4549         else
4550          qgpdfb=qgpdfb+4.d0*rr*fp(icz)*qgftle(x,icz)/x**dels
4551      *   /rp*exp(-bb/rp)*cc(icdp,icz)
4552         endif
4553        enddo
4554       endif
4555       return
4556       end
4557 
4558 c------------------------------------------------------------------------
4559       double precision function qgpdfi(x,bb,icz,jj)
4560 c-----------------------------------------------------------------------
4561 c qgpdfi - b-dependent parton momentum distributions
4562 c-----------------------------------------------------------------------
4563       implicit double precision (a-h,o-z)
4564       integer debug
4565       dimension wk(3),wz(3)
4566       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4567       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4568       common /qgarr20/ spmax
4569       common /qgarr53/ qpdfb(51,11,3,2)
4570       common /qgarr43/ moniou
4571       common /qgdebug/  debug
4572 
4573       qgpdfi=0.d0
4574       rp=(rq(1,icz)-alfp*dlog(x))*4.d0*.0389d0
4575       if(rp.le.1.d-10)then
4576        z=1.d0
4577       else
4578        z=exp(-bb/rp)
4579       endif
4580       if(z.lt..2d0*exp(-10.d0))then
4581        izmax=2
4582        jz=1
4583        wz(2)=5.d0*z*exp(10.d0)
4584        wz(1)=1.d0-wz(2)
4585       else
4586        if(z.gt..2d0)then
4587         zz=5.d0*z+6.d0
4588        else
4589         zz=(-bb/rp-log(0.2d0))/2.d0+7.d0
4590        endif
4591        jz=min(9,int(zz))
4592        jz=max(2,jz)
4593        if(jz.eq.6)jz=5
4594        wz(2)=zz-jz
4595        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
4596        wz(1)=1.d0-wz(2)+wz(3)
4597        wz(2)=wz(2)-2.d0*wz(3)
4598        izmax=3
4599       endif
4600 
4601       yl=-dlog(x)/log(spmax)*50.d0+1.d0
4602       k=max(1,int(yl))
4603       k=min(k,49)
4604       wk(2)=yl-k
4605       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
4606       wk(1)=1.d0-wk(2)+wk(3)
4607       wk(2)=wk(2)-2.d0*wk(3)
4608 
4609       do j1=1,izmax
4610        j2=jz+j1-1
4611       do k1=1,3
4612        k2=k+k1-1
4613        qgpdfi=qgpdfi+qpdfb(k2,j2,icz,jj+1)*wk(k1)*wz(j1)
4614       enddo
4615       enddo
4616       qgpdfi=exp(qgpdfi)*z*4.d0*rr*fp(icz)/x**dels/rp
4617       if(jj.eq.0)then
4618        qgpdfi=qgpdfi*qgftld(x,icz)
4619       else
4620        qgpdfi=qgpdfi*qgftle(x,icz)
4621       endif
4622       return
4623       end
4624 
4625 c=============================================================================
4626       double precision function qgdgdf(x,xpomr,icz,jj)
4627 c-----------------------------------------------------------------------------
4628 c qgdgdf - diffractive gluon pdf xpomr*g_d^3(x,xpomr,qt0)
4629 c x   - Feinman x,
4630 c icz - hadron class
4631 c-----------------------------------------------------------------------------
4632       implicit double precision (a-h,o-z)
4633       integer debug
4634       parameter(iapmax=208)
4635       common /qgarr6/  pi,bm,amws
4636       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4637       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4638       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4639       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4640       common /qgarr43/ moniou
4641       common /qgdebug/  debug
4642       common /arr3/   x1(7),a1(7)
4643 
4644       qgdgdf=0.d0
4645       do icdp=1,2
4646       if(cd(icdp,icz).ne.0.d0)then
4647        dps=0.d0
4648        if(jj.eq.1)then
4649         rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
4650         do ib=1,7
4651         do mb=1,2
4652          z=.5d0+x1(ib)*(mb-1.5d0)
4653          bb=-rp*log(z)
4654 
4655          v1p=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1)
4656          dps=dps+a1(ib)*(1.d0-exp(-v1p))**2/z
4657         enddo
4658         enddo
4659         dps=dps*rp*pi*rr*(r3p*pi/.0389d0)*cc(icdp,icz)/g3p**2
4660      *  *(1.d0-x/xpomr)**betp*(1.d0-dgqq)*(xpomr/x)**dels
4661 
4662        elseif(jj.eq.2.and.xpomr/x.gt.sgap)then
4663         do ix1=1,7
4664         do mx1=1,2
4665          xpomr1=(x/xpomr*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))*xpomr/sgap
4666          rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
4667          do ib=1,7
4668          do mb=1,2
4669           z=.5d0+x1(ib)*(mb-1.5d0)
4670           bb=-rp*log(z)
4671 
4672           vpf=qgfani(1.d0/xpomr1,bb,0.d0,0.d0,0.d0,icdp,icz,1)
4673           vpdf1=qgdfani(xpomr1,xpomr,bb,icdp,2)
4674           vpdf=min(vpdf1,qgdfani(xpomr1,xpomr,bb,icdp,1))
4675           vpdfi=qgdfani(xpomr1,xpomr,bb,icdp,3)
4676            dpx=vpdf*exp(2.d0*vpdfi-2.d0*vpf)-vpdf1
4677 
4678           dps=dps+a1(ix1)*a1(ib)*dpx/z*rp
4679      *    *(1.d0-x/xpomr1)**betp*(xpomr1/x)**dels
4680          enddo
4681          enddo
4682         enddo
4683         enddo
4684         dps=dps*rr*pi*(r3p*pi/.0389d0)*dlog(xpomr/x/sgap)/g3p**2
4685      *  *(1.d0-dgqq)*cc(icdp,icz)
4686        endif
4687        qgdgdf=qgdgdf+dps
4688       endif
4689       enddo
4690       return
4691       end
4692 
4693 c=============================================================================
4694       double precision function qgdpdf(x,xpomr,icz,jj)
4695 c-----------------------------------------------------------------------------
4696 c qgdpdf - diffractive structure function
4697 c x   - Feinman x,
4698 c icz - hadron class
4699 c-----------------------------------------------------------------------------
4700       implicit double precision (a-h,o-z)
4701       integer debug
4702       parameter(iapmax=208)
4703       common /qgarr6/  pi,bm,amws
4704       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4705       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
4706       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4707       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4708       common /qgarr43/ moniou
4709       common /qgdebug/  debug
4710       common /arr3/   x1(7),a1(7)
4711 
4712       qgdpdf=0.d0
4713       do icdp=1,2
4714       if(cd(icdp,icz).ne.0.d0)then
4715        dps=0.d0
4716        if(jj.eq.1)then
4717         rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
4718         do ib=1,7
4719         do mb=1,2
4720          z=.5d0+x1(ib)*(mb-1.5d0)
4721          bb=-rp*log(z)
4722 
4723          v1p=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1)
4724          dps=dps+a1(ib)*(1.d0-exp(-v1p))**2/z
4725         enddo
4726         enddo
4727         dps=dps*rp*pi*rr*(r3p*pi/.0389d0)*cc(icdp,icz)/g3p**2
4728      *  *qgftlf(x/xpomr)*dgqq*(xpomr/x)**dels
4729 
4730        elseif(jj.eq.2.and.xpomr/x.gt.sgap)then
4731         do ix1=1,7
4732         do mx1=1,2
4733          xpomr1=(x/xpomr*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))*xpomr/sgap
4734          rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
4735          do ib=1,7
4736          do mb=1,2
4737           z=.5d0+x1(ib)*(mb-1.5d0)
4738           bb=-rp*log(z)
4739 
4740           vpf=qgfani(1.d0/xpomr1,bb,0.d0,0.d0,0.d0,icdp,icz,1)
4741           vpdf1=qgdfani(xpomr1,xpomr,bb,icdp,2)
4742           vpdf=min(vpdf1,qgdfani(xpomr1,xpomr,bb,icdp,1))
4743           vpdfi=qgdfani(xpomr1,xpomr,bb,icdp,3)
4744            dpx=vpdf*exp(2.d0*vpdfi-2.d0*vpf)-vpdf1
4745 
4746           dps=dps+a1(ix1)*a1(ib)*dpx/z*rp
4747      *    *qgftlf(x/xpomr1)*(xpomr1/x)**dels
4748          enddo
4749          enddo
4750         enddo
4751         enddo
4752         dps=dps*rr*pi*(r3p*pi/.0389d0)*dlog(xpomr/x/sgap)/g3p**2
4753      *  *dgqq*cc(icdp,icz)
4754        endif
4755        qgdpdf=qgdpdf+dps
4756       endif
4757       enddo
4758       qgdpdf=qgdpdf/4.5d0
4759       return
4760       end
4761 
4762 c=============================================================================
4763       double precision function qgfsh(sy,bb,icdp,icdt,icz,iqq)
4764 c-----------------------------------------------------------------------------
4765 c qgfsh - semihard interaction eikonal
4766 c sy  - pomeron mass squared,
4767 c bb  - impact parameter squared,
4768 c icz - hadron class
4769 c iqq - type of the hard interaction (0-gg, 1-q_vg, 2-gq_v)
4770 c-----------------------------------------------------------------------------
4771       implicit double precision (a-h,o-z)
4772       integer debug
4773       common /qgarr6/  pi,bm,amws
4774       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
4775       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4776       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4777       common /qgarr25/ ahv(3)
4778       common /qgarr26/ factk,fqscal
4779       common /arr3/   x1(7),a1(7)
4780       common /qgarr43/ moniou
4781       common /qgdebug/  debug
4782 
4783       if(debug.ge.2)write (moniou,201)sy,bb,iqq,icz
4784 
4785       qgfsh=0.d0
4786       s2min=4.d0*fqscal*qt0
4787       xmin=s2min/sy
4788       if(xmin.ge.1.d0)return
4789       xmin=xmin**(delh-dels)
4790       if(iqq.eq.1)then
4791        icv=icz
4792        icq=2
4793       elseif(iqq.eq.2)then
4794        icv=2
4795        icq=icz
4796       endif
4797       if(debug.ge.3)write (moniou,205)xmin,iqq
4798 
4799 c numerical integration over z1
4800       do i=1,7
4801       do m=1,2
4802        z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
4803      * **(1.d0/(delh-dels))
4804        ww=z1*sy
4805        sjqq=qgjit(qt0,qt0,ww,2,2)
4806        sjqg=qgjit(qt0,qt0,ww,1,2)
4807        sjgg=qgjit(qt0,qt0,ww,1,1)
4808        if(debug.ge.3)write (moniou,203)ww,sjqq+sjqg+sjgg
4809 
4810        if(iqq.eq.0)then
4811         st2=0.d0
4812         do j=1,7
4813         do k=1,2
4814          xx=.5d0*(1.d0+x1(j)*(2*k-3))
4815          xp=z1**xx
4816          xm=z1/xp
4817          glu1=qgftld(xp,icz)
4818          sea1=qgftle(xp,icz)
4819          glu2=qgftld(xm,2)
4820          sea2=qgftle(xm,2)
4821          st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
4822      *   +sea1*sea2*sjqq)
4823         enddo
4824         enddo
4825         rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(z1)
4826         qgfsh=qgfsh-a1(i)*dlog(z1)/z1**delh*st2
4827      *  *exp(-bb/(4.d0*.0389d0*rh))/rh
4828 
4829        else
4830         st2=0.d0
4831         alh=.5d0+dels
4832         xam=z1**alh
4833 
4834         do j=1,7
4835         do k=1,2
4836          xp=(.5d0*(1.d0+xam+x1(j)*(2*k-3)*(1.d0-xam)))**(1.d0/alh)
4837          xm=z1/xp
4838          glu=qgftld(xm,icq)
4839          sea=qgftle(xm,icq)
4840          rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xm)
4841 
4842          fst=(glu*sjqg+sea*sjqq)*(1.d0-xp)**ahv(icv)
4843      *   *(qggrv(xp,qt0,icv,1)+qggrv(xp,qt0,icv,2))/dsqrt(xp)
4844      *   *exp(-bb/(4.d0*.0389d0*rh))/rh
4845          st2=st2+a1(j)*fst
4846         enddo
4847         enddo
4848         st2=st2*(1.d0-xam)/alh
4849         qgfsh=qgfsh+a1(i)/z1**delh*st2
4850        endif
4851       enddo
4852       enddo
4853 
4854       if(iqq.eq.0)then
4855        qgfsh=qgfsh*rr**2*(1.d0-xmin)/(delh-dels)*fp(icz)*fp(2)*factk
4856      * /2.d0*pi*cd(icdp,icz)*cd(icdt,2)
4857       else
4858        qgfsh=qgfsh*rr*fp(icq)*(1.d0-xmin)/(delh-dels)*factk/8.d0
4859      * *cd(icdp,icz)*cd(icdt,2)
4860       endif
4861 
4862       if(debug.ge.3)write (moniou,202)qgfsh
4863 201   format(2x,'qgfsh - semihard interaction eikonal:'
4864      */4x,'sy=',e10.3,2x,'bb=',e10.3,2x,'iqq=',i1,2x,'icz=',i1)
4865 202   format(2x,'qgfsh=',e10.3)
4866 203   format(2x,'qgfsh:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
4867 205   format(2x,'qgfsh:',2x,'xmin=',e10.3,2x,'iqq=',i3)
4868       return
4869       end
4870 
4871 c=============================================================================
4872       double precision function qgftld(z,icz)
4873 c-----------------------------------------------------------------------------
4874 c qgftld - auxilliary function for semihard eikonals calculation -
4875 c (proportional to gluon sf: g(z)*z^(1+dels)) -
4876 c integration over semihard block light cone momentum share x
4877 c z - x-cutoff from below,
4878 c icz - type of the hadron to which the semihard block is connected
4879 c-----------------------------------------------------------------------------
4880       implicit double precision (a-h,o-z)
4881       integer debug
4882       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4883       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4884       common /qgarr19/ ahl(3)
4885       common /qgarr43/ moniou
4886       common /qgdebug/    debug
4887       common /arr3/     x1(7),a1(7)
4888 
4889       if(debug.ge.2)write (moniou,201)z,icz
4890 
4891       qgftld=0.d0
4892       xpmin=z**(1.d0+dels)
4893       do i1=1,7
4894       do m1=1,2
4895        tp=1.d0-(1.d0-xpmin)*(.5d0+x1(i1)*(m1-1.5d0))
4896      * **(1.d0/(1.d0+ahl(icz)))
4897        xp=tp**(1.d0/(1.d0+dels))
4898        qgftld=qgftld+a1(i1)*((1.d0-xp)/(1.d0-tp))**ahl(icz)
4899      * *(1.d0-z/xp)**betp
4900       enddo
4901       enddo
4902       qgftld=qgftld*.5d0*(1.d0-xpmin)**(ahl(icz)+1.d0)
4903      */(ahl(icz)+1.d0)/(1.d0+dels)*(1.d0-dgqq)
4904 
4905       if(debug.ge.3)write (moniou,202)qgftld
4906 201   format(2x,'qgftld:',2x,'z=',e10.3,2x,'icz=',i1)
4907 202   format(2x,'qgftld=',e10.3)
4908       return
4909       end
4910 
4911 c------------------------------------------------------------------------
4912       double precision function qgftle(z,icz)
4913 c-----------------------------------------------------------------------
4914 c qgftle - auxilliary function for semihard eikonals calculation
4915 c (proportional to sea quark sf: q_s(z)*z^(1+dels)) -
4916 c integration over semihard pomeron light cone momentum share x
4917 c z - light cone x of the quark,
4918 c icz - type of the hadron to which the semihard block is connected
4919 c-----------------------------------------------------------------------------
4920       implicit double precision (a-h,o-z)
4921       integer debug
4922       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4923       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4924       common /qgarr19/ ahl(3)
4925       common /qgarr43/ moniou
4926       common /qgdebug/  debug
4927       common /arr3/   x1(7),a1(7)
4928 
4929       if(debug.ge.2)write (moniou,201)z,icz
4930 
4931       qgftle=0.d0
4932       xpmin=z**(1.d0+dels)
4933       do i1=1,7
4934       do m1=1,2
4935        tp=1.d0-(1.d0-xpmin)*(.5d0+x1(i1)*(m1-1.5d0))
4936      * **(1.d0/(1.d0+ahl(icz)))
4937        xp=tp**(1.d0/(1.d0+dels))
4938        qgftle=qgftle+a1(i1)*((1.d0-xp)/(1.d0-tp))**ahl(icz)
4939      * *qgftlf(z/xp)
4940       enddo
4941       enddo
4942       qgftle=qgftle*.5d0*(1.d0-xpmin)**(ahl(icz)+1.d0)
4943      */(ahl(icz)+1.d0)/(1.d0+dels)*dgqq
4944 
4945       if(debug.ge.3)write (moniou,202)qgftle
4946 201   format(2x,'qgftle:',2x,'z=',e10.3,2x,'icz=',i1)
4947 202   format(2x,'qgftle=',e10.3)
4948       return
4949       end
4950 
4951 c------------------------------------------------------------------------
4952       double precision function qgftlf(zz)
4953 c-----------------------------------------------------------------------
4954 c qgftlf - auxilliary function for semihard eikonals calculation
4955 c zz - ratio of the quark and pomeron light cone x (zz=x_G/x_P)
4956 c integration over quark to gluon light cone momentum ratio (z=x/x_G):
4957 c qgftlf=int(dz) z^dels * (1-zz/z)^betp * P_qG(z)
4958 c-----------------------------------------------------------------------
4959       implicit double precision (a-h,o-z)
4960       integer debug
4961       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
4962       common /qgarr18/ alm,qt0,qtf,betp,dgqq
4963       common /qgarr43/ moniou
4964       common /qgdebug/  debug
4965       common /arr3/   x1(7),a1(7)
4966 
4967       if(debug.ge.2)write (moniou,201)zz
4968 201   format(2x,'qgftlf:',2x,'zz=',e10.3)
4969 
4970       qgftlf=0.d0
4971       zmin=zz**(1.d0+dels)
4972       do i=1,7
4973       do m=1,2
4974         z=(.5d0*(1.d0+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))**(1.d0/
4975      *  (1.d0+dels))
4976         qgftlf=qgftlf+a1(i)*max(1.d-9,(1.d0-zz/z))**betp
4977      *  *(z**2+(1.d0-z)**2)
4978       enddo
4979       enddo
4980       qgftlf=qgftlf*1.5d0*(1.d0-zmin)/(1.d0+dels)   !1.5=naflav/2 at Q0
4981 
4982       if(debug.ge.3)write (moniou,202)qgftlf
4983 202   format(2x,'qgftlf=',e10.3)
4984       return
4985       end
4986 
4987 c=============================================================================
4988       subroutine qgfz(b,gz,iddp1,iddp2)
4989 c----------------------------------------------------------------------------
4990 c hadron-hadron and hadron-nucleus cross sections calculation
4991 c----------------------------------------------------------------------------
4992       implicit double precision (a-h,o-z)
4993       integer debug
4994       parameter(iapmax=208)
4995       dimension gz(5),wt1(3),wt2(3)
4996       common /qgarr1/  ia(2),icz,icp
4997       common /qgarr2/  scm,wp0,wm0
4998       common /qgarr6/  pi,bm,amws
4999       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
5000       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
5001       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
5002       common /qgarr43/ moniou
5003       common /arr3/   x1(7),a1(7)
5004       common /qgdebug/  debug
5005 
5006       if(debug.ge.2)write (moniou,201)b,iddp1,iddp2
5007       do l=1,5
5008        gz(l)=0.d0
5009       enddo
5010       rp=(rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0389d0
5011       g0=0.d0
5012       if(ia(2).eq.1.and.iddp1.eq.0.and.iddp2.eq.0)then
5013        g0=pi*rp*10.d0                     !normalization factor (in mb)
5014        bm=2.d0*dsqrt(rp)                  !impact parameter for exp. fall-down
5015       endif
5016 
5017       do i1=1,7
5018       do m=1,2
5019        z=.5d0+x1(i1)*(m-1.5d0)
5020        bb1=rp*z
5021        bb2=rp*(1.d0-dlog(z))
5022 
5023        do l=1,3
5024         wt1(l)=0.d0
5025         wt2(l)=0.d0
5026        enddo
5027 
5028        if(ia(2).eq.1)then
5029         do idd1=1,2
5030         do idd2=1,2
5031          vv1=exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,idd1,idd2,icz,1))
5032          vv2=exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,idd1,idd2,icz,1))
5033 
5034          do l=1,2
5035           wt1(l)=wt1(l)+cc(idd1,icz)*cc(idd2,2)*vv1**l
5036           wt2(l)=wt2(l)+cc(idd1,icz)*cc(idd2,2)*vv2**l
5037          enddo
5038          do idd3=1,2
5039           wt1(3)=wt1(3)+cc(idd1,icz)*cc(idd2,2)*cc(idd3,icz)*vv1
5040      *    *exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,idd3,idd2,icz,1))
5041           wt2(3)=wt2(3)+cc(idd1,icz)*cc(idd2,2)*cc(idd3,icz)*vv2
5042      *    *exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,idd3,idd2,icz,1))
5043          enddo
5044         enddo
5045         enddo
5046         do l=1,2
5047          gz(l)=gz(l)+a1(i1)*((1.d0-wt1(l))+(1.d0-wt2(l))/z)
5048         enddo
5049         gz(3)=gz(3)+a1(i1)*((wt1(2)-wt1(3))+(wt2(2)-wt2(3))/z)
5050         gz(4)=gz(4)+a1(i1)*((wt1(3)-wt1(1)**2)+(wt2(3)-wt2(1)**2)/z)
5051         gz(5)=gz(5)+a1(i1)*((1.d0-wt1(1))*z+(1.d0-wt2(1))/z*(1.-log(z)))
5052 
5053        else
5054         do idd1=1,2
5055         do idd2=1,2
5056          vv1=exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,iddp1,idd1,icz,1)
5057      *   -qgpomi(scm,bb1,0.d0,0.d0,0.d0,iddp2,idd2,icz,1))
5058          vv2=exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,iddp1,idd1,icz,1)
5059      *   -qgpomi(scm,bb2,0.d0,0.d0,0.d0,iddp2,idd2,icz,1))
5060 
5061          if(idd1.eq.idd2)then
5062           wt1(1)=wt1(1)+cc(idd1,2)*vv1
5063           wt2(1)=wt2(1)+cc(idd1,2)*vv2
5064          endif
5065          wt1(2)=wt1(2)+cc(idd1,2)*cc(idd2,2)*vv1
5066          wt2(2)=wt2(2)+cc(idd1,2)*cc(idd2,2)*vv2
5067         enddo
5068         enddo
5069         cg1=qgrot(b,dsqrt(bb1))
5070         cg2=qgrot(b,dsqrt(bb2))
5071         do l=1,2
5072          gz(l)=gz(l)+a1(i1)*(cg1*(1.d0-wt1(l))+cg2*(1.d0-wt2(l))/z)
5073         enddo
5074        endif
5075       enddo
5076       enddo
5077       if(ia(2).eq.1.and.iddp1.eq.0.and.iddp2.eq.0)then     !hadron-proton
5078        do l=1,5
5079         gz(l)=gz(l)*g0
5080        enddo
5081        gz(5)=gz(5)/gz(1)*(rq(1,icz)+rq(1,2)+alfp*log(scm))*2.d0
5082       endif
5083 
5084       if(debug.ge.2)write (moniou,203)gz
5085       if(debug.ge.3)write (moniou,202)
5086 201   format(2x,'qgfz - hadronic cross-sections calculation'
5087      */4x,'b=',e10.3,2x,'iddp=',2i3)
5088 202   format(2x,'qgfz - end')
5089 203   format(2x,'qgfz: gz=',5e10.3)
5090       return
5091       end
5092 
5093 c=============================================================================
5094       double precision function qghard(sy,bb,icdp,icdt,icz)
5095 c-----------------------------------------------------------------------------
5096 c qghard - hard quark-quark interaction cross-section
5097 c s - energy squared for the interaction (hadron-hadron),
5098 c icz - type of the primaty hadron (nucleon)
5099 c----------------------------------------------------------------------------
5100       implicit double precision (a-h,o-z)
5101       integer debug
5102       common /qgarr6/  pi,bm,amws
5103       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
5104       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
5105       common /qgarr18/ alm,qt0,qtf,betp,dgqq
5106       common /qgarr25/ ahv(3)
5107       common /qgarr26/ factk,fqscal
5108       common /arr3/   x1(7),a1(7)
5109       common /qgarr43/ moniou
5110       common /qgdebug/  debug
5111 
5112       if(debug.ge.2)write (moniou,201)sy,icz
5113 
5114       qghard=0.d0
5115       s2min=4.d0*fqscal*qt0
5116       xmin=s2min/sy
5117       if(xmin.ge.1.d0)return
5118       xmin=xmin**(delh+.5d0)
5119 
5120 c numerical integration over z1
5121       do i=1,7
5122       do m=1,2
5123        z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
5124      * **(1.d0/(delh+.5d0))
5125 
5126        st2=0.d0
5127        do j=1,7
5128        do k=1,2
5129         xx=.5d0*(1.d0+x1(j)*(2*k-3))
5130         xp=z1**xx
5131         xm=z1/xp
5132         st2=st2+a1(j)*(1.d0-xp)**ahv(icz)*(1.d0-xm)**ahv(2)
5133      *  *(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))
5134      *  *(qggrv(xm,qt0,2,1)+qggrv(xm,qt0,2,2))/dsqrt(z1)
5135        enddo
5136        enddo
5137        sj=qgjit(qt0,qt0,z1*sy,2,2)
5138        st2=-st2*dlog(z1)*sj
5139        if(debug.ge.3)write (moniou,203)z1*sy,sj
5140 
5141        qghard=qghard+a1(i)/z1**delh*st2
5142       enddo
5143       enddo
5144       qghard=qghard*(1.d0-xmin)/(.5d0+delh)*.25d0*factk
5145       rh=rq(icdp,icz)+rq(icdt,2)
5146       qghard=qghard/(8.d0*pi*rh)*exp(-bb/(4.d0*.0389d0*rh))
5147      **cd(icdp,icz)*cd(icdt,2)
5148 
5149       if(debug.ge.2)write (moniou,202)qghard
5150 201   format(2x,'qghard - hard quark-quark interaction eikonal:'
5151      */2x,'s=',e10.3,2x,'icz=',i1)
5152 202   format(2x,'qghard=',e10.3)
5153 203   format(2x,'qghard:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
5154       return
5155       end
5156 
5157 c=============================================================================
5158       subroutine qgbdef(bba,bbb,xxa,yya,xxb,yyb,xxp,yyp,jb)
5159 c-----------------------------------------------------------------------
5160 c qgbdef - defines coordinates (xxp,yyp) of a multi-pomeron vertex
5161 c------------------------------------------------------------------------
5162       implicit double precision (a-h,o-z)
5163 
5164       xx=xxa-xxb
5165       yy=yya-yyb
5166       bb=xx**2+yy**2
5167       if(bb.lt.1.d-5)then
5168        xxp=xxb+dsqrt(bba)
5169        yyp=yyb
5170       elseif(abs(yy).lt.1.d-8)then
5171        xxp=(bba-bbb+xxb**2-xxa**2)/2.d0/(xxb-xxa)
5172        yyp=yyb+(2*jb-3)*dsqrt(max(0.d0,bbb-(xxb-xxp)**2))
5173       else
5174        bbd=bb+bbb-bba
5175        discr=max(0.d0,4.d0*bb*bbb-bbd**2)
5176        xxp=(xx*bbd+(2*jb-3)*abs(yy)*dsqrt(discr))/2.d0/bb
5177        yyp=(bbd-2.d0*xx*xxp)/2.d0/yy
5178        xxp=xxp+xxb
5179        yyp=yyp+yyb
5180       endif
5181       return
5182       end
5183 
5184 c=============================================================================
5185       subroutine qgv(x,y,xb,vin,vdd,vabs)
5186 c xxv - eikonal dependent factor for hadron-nucleus interaction
5187 c (used for total and diffractive hadron-nucleus cross-sections calculation)
5188 c----------------------------------------------------------------------------
5189       implicit double precision (a-h,o-z)
5190       integer debug
5191       parameter(iapmax=208)
5192       dimension xb(iapmax,3),vabs(2)
5193       common /qgarr1/  ia(2),icz,icp
5194       common /qgarr2/  scm,wp0,wm0
5195       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
5196       common /qgarr43/ moniou
5197       common /qgdebug/  debug
5198 
5199       if(debug.ge.2)write (moniou,201)x,y
5200 
5201       vin=0.d0
5202       vdd=0.d0
5203       do iddp1=1,2
5204        dv=0.d0
5205        do m=1,ia(2)
5206         bb=(x-xb(m,1))**2+(y-xb(m,2))**2
5207         dv=dv+qgpomi(scm,bb,0.d0,0.d0,0.d0,iddp1,iddt(m),icz,1)
5208        enddo
5209        dv=exp(-dv)
5210        vabs(iddp1)=1.d0-dv**2       !1-exp(-2 * chi_i)
5211        vdd=vdd+cc(iddp1,icz)*dv**2  !sum_i cc(i) exp(-2 * chi_i)
5212        vin=vin+cc(iddp1,icz)*dv     !sum_i cc(i) exp(-chi_i)
5213       enddo
5214       vin=1.d0-vin**2               !1-sum_ij cc(i) cc(j) exp(-chi_i-chi_j)
5215       vdd=vdd+vin-1.d0
5216           !sum_i cc(i) exp(-2*chi_i) - sum_ij cc(i) cc(j) exp(-chi_i-chi_j)
5217 
5218       if(debug.ge.3)write (moniou,202)vin,vdd,vabs
5219 201   format(2x,'qgv - eikonal factor: nucleon coordinates x='
5220      *  ,e10.3,2x,'y=',e10.3)
5221 202   format(2x,'vin=',e10.3,2x,'vdd=',e10.3,2x,'vabs=',2e10.3)
5222       return
5223       end
5224 
5225 
5226 c=============================================================================
5227       subroutine qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt
5228      *  ,vvxpl,vvxtl,ip,it)
5229 c-----------------------------------------------------------------------
5230 c qgfdf - configuration of fan contributions (cut and uncut fans)
5231 c xxp, yyp -  coordinates of the multi-Pomeron vertex,
5232 c xpomr    - LC momentum share of the multi-Pomeron vertex,
5233 c ip       - proj. index,
5234 c it       - targ. index
5235 c vvx   = 1 - exp[-sum_{j<J} chi_targ(j) - sum_{i<I} chi_proj(i)]
5236 c vvxp  = 1 - exp[-sum_{i>I} chi_proj(i)]
5237 c vvxt  = 1 - exp[-sum_{j>J} chi_targ(j)]
5238 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
5239 c vvxtl = 1 - exp[-sum_{j<J} chi_targ(j)]
5240 c------------------------------------------------------------------------
5241       implicit double precision (a-h,o-z)
5242       integer debug
5243       parameter(iapmax=208)
5244       dimension vpac(iapmax),vtac(iapmax)
5245       common /qgarr1/  ia(2),icz,icp
5246       common /qgarr2/  scm,wp0,wm0
5247       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
5248       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
5249       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
5250       common /qgarr43/ moniou
5251       common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
5252      *,iconb(iapmax)
5253       common /qgdebug/   debug
5254 
5255       if(debug.ge.3)write (moniou,201)xxp,yyp,xpomr,ip,it
5256 
5257       vvx=0.d0
5258       vvxp=0.d0
5259       vvxt=0.d0
5260       vvxpl=0.d0
5261       vvxtl=0.d0
5262       if(scm.le.sgap**2)return
5263 
5264       sumup0=0.d0                      !proj. fans without targ. screening
5265       do ipp=1,ia(1)
5266        if(iconab(ipp,it).eq.0)then    !no connection
5267                                       !(nucleon too far from the vertex)
5268         vpac(ipp)=0.d0
5269        else
5270         bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
5271         vpac(ipp)=qgfani(1.d0/xpomr,bbp,1.d0-exp(-sumup0),0.d0,0.d0
5272      *  ,iddp(ipp),icz,1)
5273         sumup0=sumup0+vpac(ipp)
5274        endif
5275       enddo
5276 
5277       sumut0=0.d0                      !targ. fans without proj. screening
5278       do itt=1,ia(2)
5279        if(iconab(ip,itt).eq.0)then     !no connection
5280         vtac(itt)=0.d0
5281        else
5282         bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
5283         vtac(itt)=qgfani(xpomr*scm,bbt,1.d0-exp(-sumut0),0.d0,0.d0
5284      *  ,iddt(itt),2,1)
5285         sumut0=sumut0+vtac(itt)
5286        endif
5287       enddo
5288 
5289       nn=0
5290 1     nn=nn+1
5291       sumup=0.d0                       !proj. fans with targ. screening
5292       do ipp=1,ia(1)
5293        if(iconab(ipp,it).eq.0)then    !no connection
5294         vpac(ipp)=0.d0
5295        else
5296         bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
5297         vpac(ipp)=qgfani(1.d0/xpomr,bbp,1.d0-exp(-sumup-sumut0)
5298      *  ,0.d0,0.d0,iddp(ipp),icz,1)
5299         sumup=sumup+vpac(ipp)
5300        endif
5301       enddo
5302 
5303       sumut=0.d0                      !targ. uncut fans with proj. screening
5304       do itt=1,ia(2)
5305        if(iconab(ip,itt).eq.0)then
5306         vtac(itt)=0.d0
5307        else
5308         bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
5309         vtac(itt)=qgfani(xpomr*scm,bbt,1.d0-exp(-sumut-sumup0)
5310      *  ,0.d0,0.d0,iddt(itt),2,1)
5311         sumut=sumut+vtac(itt)
5312        endif
5313       enddo
5314 
5315       if((abs(sumup-sumup0).gt..01d0.or.abs(sumut-sumut0).gt..01d0)
5316      *.and.nn.lt.100)then
5317        sumup0=sumup
5318        sumut0=sumut
5319        goto 1
5320       endif
5321 
5322       if(ia(1).gt.1)then
5323        do ipp=1,ia(1)
5324         if(ipp.lt.ip)then
5325          vvxpl=vvxpl+vpac(ipp)
5326         elseif(ipp.gt.ip)then
5327          vvxp=vvxp+vpac(ipp)
5328         endif
5329        enddo
5330       endif
5331 
5332       if(ia(2).gt.1)then
5333        do itt=1,ia(2)
5334         if(itt.lt.it)then
5335          vvxtl=vvxtl+vtac(itt)
5336         elseif(itt.gt.it)then
5337          vvxt=vvxt+vtac(itt)
5338         endif
5339        enddo
5340       endif
5341       vvx=1.d0-exp(-vvxpl-vvxtl)
5342       vvxp=1.d0-exp(-vvxp)
5343       vvxpl=1.d0-exp(-vvxpl)
5344       vvxt=1.d0-exp(-vvxt)
5345       vvxtl=1.d0-exp(-vvxtl)
5346       if(debug.ge.4)write (moniou,202)
5347 
5348 201   format(2x,'qgfdf - configuration of fan contributions:'
5349      */2x,'xxp=',e10.3,2x,'yyp=',e10.3,2x,'xpomr=',e10.3
5350      *,2x,'ip=',i3,2x,'it=',i3)
5351 202   format(2x,'qgfdf - end')
5352       return
5353       end
5354 
5355 c=============================================================================
5356       subroutine qgconf
5357 c-----------------------------------------------------------------------------
5358 c interaction (cut Pomeron) configuration:
5359 c b - impact parameter,
5360 c xa(1-iap,3), xb(1-iat,3) - proj. and targ. nucleon coordinates,
5361 c iddp(1-iap), iddt(1-iat) - proj. and targ. nucleon diffractive eigenstates,
5362 c icona(1-iap) - connection for proj. nucleons (0 if too far from the target),
5363 c iconab(1-iap,1-iat) - connection for proj.-targ. nucleons (0 if too far from
5364 c each other),
5365 c nwp, nwt - numbers of wounded proj. and targ. nucleons (inelastic or diff.),
5366 c iwp(1-iap), iwt(1-iat) - indexes for wounded proj. and targ. nucleons
5367 c (0 - intact, 1 - inel., 2,3 - diffr., -1 - recoiled from diffraction),
5368 c ncola(1-iap), ncolb(1-iat) - index for inel.-wounded proj. and targ. nucleons,
5369 c nbpom  - total number of Pomeron blocks,
5370 c ias(k) (ibs(k)) - index of the proj. (targ.) nucleon for k-th Pomeron block,
5371 c bbpom(k) - squared impact parameter (between proj. and targ.) for k-th block,
5372 c vvxpom(k) - relative strenth of A-screening corrections for k-th block,
5373 c nqs(k) - number of single Pomerons in k-th block (without cut 3P-vertexes),
5374 c npompr(k) - number of proj. leg Pomerons in k-th block,
5375 c npomtg(k) - number of targ. leg Pomerons in k-th block,
5376 c npomin(k) - number of interm. Pomerons (between 2 3P-vertexes) in k-th block,
5377 c xpopin(n,k) - LC momentum of the upper 3P-vertex for n-th interm. Pomeron
5378 c in k-th block,
5379 c xpomin(n,k) - LC momentum of the lower 3P-vertex for n-th interm. Pomeron
5380 c in k-th block,
5381 c nnpr(i,k) - proj. participant index for i-th single Pomeron in k-th block,
5382 c nntg(i,k) - targ. participant index for i-th single Pomeron in k-th block,
5383 c ilpr(i,k) - proj. index for i-th proj. leg Pomeron in k-th block,
5384 c iltg(i,k) - proj. index for i-th targ. leg Pomeron in k-th block,
5385 c lnpr(i,k) - proj. participant index for i-th proj. leg Pomeron in k-th block,
5386 c lntg(i,k) - targ. participant index for i-th targ. leg Pomeron in k-th block,
5387 c lqa(ip) - number of cut Pomerons connected to ip-th proj. nucleon (hadron),
5388 c lqb(it) - number of cut Pomerons connected to it-th targ. nucleon (hadron),
5389 c nbpi(n,ip) - block index for n-th Pomeron connected to ip-th proj. nucleon,
5390 c nbti(n,it) - block index for n-th Pomeron connected to it-th targ. nucleon,
5391 c idnpi(n,ip) - type of n-th Pomeron (0 - single, 1 - leg) connected to ip-th
5392 c proj. nucleon,
5393 c idnti(n,it) - type of n-th Pomeron (0 - single, 1 - leg) connected to it-th
5394 c targ. nucleon,
5395 c nppi(n,ip) - index in the block of n-th Pomeron connected to ip-th proj.
5396 c nucleon (for single Pomerons),
5397 c npti(n,it) - index in the block of n-th Pomeron connected to it-th targ.
5398 c nucleon (for single Pomerons),
5399 c nlpi(n,ip) - index in the block of n-th Pomeron connected to ip-th proj.
5400 c nucleon (for leg Pomerons),
5401 c nlti(n,it) - index in the block of n-th Pomeron connected to it-th targ.
5402 c nucleon (for leg Pomerons),
5403 c iprcn(ip) - index of the recoiled targ. nucleon for ip-th proj. nucleon
5404 c (undergoing diffraction),
5405 c itgcn(it) - index of the recoiled proj. nucleon for it-th targ. nucleon
5406 c (undergoing diffraction),
5407 c bpompr(n,ip) - squared impact parameter for n-th leg Pomeron connected
5408 c to ip-th proj. nucleon,
5409 c bpomtg(n,it) - squared impact parameter for n-th leg Pomeron connected
5410 c to it-th targ. nucleon,
5411 c vvxpr(n,ip) - relative strenth of A-screening corrections for n-th leg
5412 c Pomeron connected to ip-th proj. nucleon,
5413 c vvxtg(n,it) - relative strenth of A-screening corrections for n-th leg
5414 c Pomeron connected to it-th targ. nucleon,
5415 c xpompr(n,ip) - LC momentum of the 3P-vertex for n-th leg Pomeron connected
5416 c to ip-th proj. nucleon,
5417 c xpomtg(n,it) - LC momentum of the 3P-vertex for n-th leg Pomeron connected
5418 c to it-th targ. nucleon
5419 c-----------------------------------------------------------------------------
5420       implicit double precision (a-h,o-z)
5421       integer debug
5422       parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
5423       dimension xas(iapmax,3),vabs(2),vabsi(2,iapmax),wdifi(iapmax)
5424      *,vpac(iapmax),vtac(iapmax),xpomip(npmax),xpomim(npmax)
5425      *,vvxim(npmax),bpomim(npmax),xpompi(legmax),xpomti(legmax)
5426      *,vvxpi(legmax),vvxti(legmax),bpompi(legmax),bpomti(legmax)
5427      *,ipompi(legmax),ipomti(legmax),ncola(iapmax),ncolb(iapmax)
5428      *,wdp(2,iapmax),wdt(2,iapmax),wabs(2,2),xrapmin(100),xrapmax(100)
5429       common /qgarr1/  ia(2),icz,icp
5430       common /qgarr2/  scm,wp0,wm0
5431       common /qgarr4/  ey0(3)
5432       common /qgarr6/  pi,bm,amws
5433       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
5434       common /qgarr9/  iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
5435      *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
5436      *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
5437      *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
5438      *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
5439      *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
5440      *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
5441      *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
5442       common /qgarr10/ am(7),ammu
5443       common /qgarr11/ b10
5444       common /qgarr12/ nsp
5445       common /qgarr13/ nsf,iaf(iapmax)
5446       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
5447       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
5448       common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
5449      *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
5450      *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
5451      *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
5452      *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
5453      *,bpomin(npmax,npbmax)
5454       common /qgarr43/ moniou
5455       common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
5456      *,iconb(iapmax)
5457       common /qgarr55/ nwt,nwp       !N of wounded targ.(proj.) nucleons
5458       common /qgarr56/ nspec,nspect  !N of spectators targ.(proj.) nucleons
5459       common /qgdebug/  debug
5460       common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3) !used to link with nexus
5461      *,bqgs,bmaxqgs,bmaxnex,bminnex
5462       common/jdiff/bdiff,jdiff     !for external use: impact parameter
5463                                    !for diffraction, diffraction type
5464 ctp from epos
5465       integer ng1evt,ng2evt,ikoevt
5466       real    rglevt,sglevt,eglevt,fglevt,typevt
5467       common/c2evt/ng1evt,ng2evt,rglevt,sglevt,eglevt,fglevt,ikoevt
5468      *,typevt            !in epos.inc
5469 
5470       external qgran
5471 
5472       if(debug.ge.1)write (moniou,201)
5473       nsp=0
5474       nsf=0
5475       nsp0=nsp
5476 
5477 c initialization
5478 1     continue
5479       do i=1,ia(1)
5480        iddp(i)=1+int(qgran(b10)+cc(2,icz)) !diffractive eigenstates for proj.
5481       enddo
5482       do i=1,ia(2)
5483        iddt(i)=1+int(qgran(b10)+cc(2,2))   !diffractive eigenstates for targ.
5484       enddo
5485 
5486 c-------------------------------------------------
5487 c squared impact parameter is sampled uniformly (b**2<bm**2)
5488       b=bm*dsqrt(qgran(b10))
5489       if(debug.ge.1)write (moniou,202)b
5490 
5491       if(bmaxnex.ge.0.d0)then              !used to link with nexus
5492        b1=bminnex
5493        b2=min(bm,bmaxnex)
5494        if(b1.gt.b2)stop'bmin > bmax in qgsjet'
5495        b=dsqrt(b1*b1+(b2*b2-b1*b1)*qgran(b10))
5496        bqgs=b
5497       endif
5498 
5499 c-------------------------------------------------
5500 c nuclear configurations
5501       if(debug.ge.1)write (moniou,203)
5502       if(ia(1).gt.1)then          !projectile nucleon coordinates
5503        call qggea(ia(1),xa,1)     !xa(n,i), i=1,2,3 - x,y,z for n-th nucleon
5504       else
5505        do i=1,3
5506         xa(1,i)=0.d0              !projectile hadron
5507        enddo
5508       endif
5509       if(ia(2).gt.1)then          !target nucleon coordinates
5510        call qggea(ia(2),xb,2)     !xb(n,i), i=1,2,3 - x,y,z for n-th nucleon
5511       else
5512        do i=1,3
5513         xb(1,i)=0.d0              !target proton
5514        enddo
5515       endif
5516 
5517 c-------------------------------------------------
5518 c check connections
5519       if(debug.ge.1)write (moniou,204)
5520       do it=1,ia(2)
5521        iconb(it)=0
5522       enddo
5523 
5524       do ip=1,ia(1)
5525        icdp=iddp(ip)
5526        icona(ip)=0
5527        do it=1,ia(2)
5528         icdt=iddt(it)
5529         bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
5530         vv1p=qgpomi(scm,bbp,0.d0,0.d0,0.d0,icdp,icdt,icz,1)
5531         if(vv1p.gt.1.d-3)then
5532          if(debug.ge.2)write (moniou,205)ip,it
5533          iconab(ip,it)=1
5534          icona(ip)=1
5535          iconb(it)=1
5536          if(debug.ge.2)write (moniou,206)ip
5537          if(debug.ge.2)write (moniou,207)it
5538         else
5539          iconab(ip,it)=0
5540         endif
5541        enddo
5542       enddo
5543 
5544       nrej=0
5545 2     nrej=nrej+1
5546       if(debug.ge.2)write (moniou,208)nrej
5547       if(nrej.gt.10)then
5548        if(debug.ge.1)write (moniou,209)
5549        goto 1
5550       endif
5551       nsp=nsp0
5552       nbpom=0
5553       nwp=0
5554       nwt=0
5555       do i=1,ia(1)
5556        lqa(i)=0
5557        iwp(i)=0
5558        ncola(i)=0
5559        wdp(1,i)=0.d0
5560        wdp(2,i)=0.d0
5561       enddo
5562       do i=1,ia(2)
5563        lqb(i)=0
5564        iwt(i)=0
5565        ncolb(i)=0
5566        wdt(1,i)=0.d0
5567        wdt(2,i)=0.d0
5568       enddo
5569       nqs(1)=0
5570       npomin(1)=0
5571       npompr(1)=0
5572       npomtg(1)=0
5573 
5574 c-------------------------------------------------
5575 c Pomeron configuration
5576       if(debug.ge.1)write (moniou,210)
5577       do 4 ip=1,ia(1)             !loop over all projectile nucleons
5578        if(debug.ge.2)write (moniou,211)ip
5579        if(icona(ip).eq.0)goto 4
5580        x=xa(ip,1)+b               !proj. x is shifted by the impact parameter b
5581        y=xa(ip,2)
5582        icdp=iddp(ip)              !diffr. eigenstate for ip
5583 
5584        do 3 it=1,ia(2)            !loop over all target nucleons
5585         if(debug.ge.2)write (moniou,212)it
5586         if(iconab(ip,it).eq.0)goto 3
5587         icdt=iddt(it)                         !diffr. eigenstate for it
5588         bbp=(x-xb(it,1))**2+(y-xb(it,2))**2   !distance squared between ip, it
5589 
5590 c calculate nuclear screening factors for "middle point" -> eikonals
5591         xpomr=1.d0/dsqrt(scm)
5592         xxp=.5d0*(x+xb(it,1))
5593         yyp=.5d0*(y+xb(it,2))
5594         call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
5595      *  ,ip,it)
5596         vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)        !total eikonal
5597         vv1p=min(vv,qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,2)) !1P-eikonal
5598         if(debug.ge.2)write (moniou,213)vv,vv1p
5599 
5600         if(qgran(b10).gt.1.d0-exp(-2.d0*vv))goto 3 !1.-exp(-2*vv) - probability
5601                                                    !for inelastic interaction
5602         iwt(it)=1
5603         iwp(ip)=1
5604         ncola(ip)=ncola(ip)+1                   !N of binary collisions for ip
5605         ncolb(it)=ncolb(it)+1                   !N of binary collisions for it
5606 
5607         n=npgen(2.d0*vv,1,50) !number of elem. inter. for (ip-it) collision
5608         nbpom=nbpom+1         !new Pomeron block
5609         if(nbpom.gt.npbmax)then
5610          goto 2
5611         endif
5612         ias(nbpom)=ip         !proj. index for current elementary interaction
5613         ibs(nbpom)=it         !targ. index for current elementary interaction
5614         bbpom(nbpom)=bbp      !distance squared between ip, it
5615         vvxpom(nbpom)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
5616         if(debug.ge.2)write (moniou,214)nbpom,ip,it,n
5617 
5618         nqs(nbpom)=0
5619         npomin(nbpom)=0
5620         npompr(nbpom)=0
5621         npomtg(nbpom)=0
5622         do i=1,n
5623          if(qgran(b10).lt.vv1p/vv.or.scm.le.sgap**2)then  !single Pomeron
5624           if(debug.ge.2)write (moniou,215)i
5625           np=nqs(nbpom)+1
5626           if(np.gt.legmax)then
5627            goto 2
5628           endif
5629           nqs(nbpom)=np                  !update Pomeron number in the block
5630           l0=lqa(ip)+1
5631           if(l0.gt.npnmax)then
5632            goto 2
5633           endif
5634           lqa(ip)=l0                     !update number of connections for proj.
5635           nnpr(np,nbpom)=l0              !index for connected proj. participant
5636           nbpi(l0,ip)=nbpom
5637           idnpi(l0,ip)=0
5638           nppi(l0,ip)=np
5639           l0=lqb(it)+1
5640           if(l0.gt.npnmax)then
5641            goto 2
5642           endif
5643           lqb(it)=l0
5644           nntg(np,nbpom)=l0              !index for connected targ. participant
5645           nbti(l0,it)=nbpom
5646           idnti(l0,it)=0
5647           npti(l0,it)=np
5648 
5649          else                            !multi-Pomeron vertex
5650           if(debug.ge.2)write (moniou,219)
5651           call qg3pdf(vvxpi,vvxti,xpompi,xpomti,bpompi,bpomti,xpomip
5652      *    ,xpomim,vvxim,bpomim,npompi,npomti,npin,ipompi,ipomti
5653      *    ,wdp,wdt,ip,it,iret)
5654           if(iret.ne.0)goto 2
5655 
5656           if(npin.ne.0)then
5657            if(debug.ge.2)write (moniou,220)i,npin
5658            npomin(nbpom)=npomin(nbpom)+npin
5659            if(npomin(nbpom).gt.npmax)then
5660             goto 2
5661            endif
5662            do l=1,npin
5663             l1=npomin(nbpom)+l-npin
5664             xpopin(l1,nbpom)=xpomip(l)
5665             xpomin(l1,nbpom)=xpomim(l)
5666             vvxin(l1,nbpom)=vvxim(l)
5667             bpomin(l1,nbpom)=bpomim(l)
5668            enddo
5669           endif
5670           if(npompi.ne.0)then
5671            if(debug.ge.2)write (moniou,221)i,npompi
5672            do m=1,npompi
5673             np=npompr(nbpom)+1
5674             if(np.gt.legmax)then
5675              goto 2
5676             endif
5677             npompr(nbpom)=np
5678             ipp=ipompi(m)
5679             iwp(ipp)=1
5680             ilpr(np,nbpom)=ipp
5681             l0=lqa(ipp)+1
5682             if(l0.gt.npnmax)then
5683              goto 2
5684             endif
5685             lqa(ipp)=l0
5686             lnpr(np,nbpom)=l0
5687             nbpi(l0,ipp)=nbpom
5688             idnpi(l0,ipp)=1
5689             nlpi(l0,ipp)=np
5690             vvxpr(l0,ipp)=vvxpi(m)
5691             xpompr(l0,ipp)=1.d0/xpompi(m)/scm
5692             bpompr(l0,ipp)=bpompi(m)
5693            enddo
5694           endif
5695           if(npomti.ne.0)then
5696            if(debug.ge.2)write (moniou,222)i,npomti
5697            do m=1,npomti
5698             np=npomtg(nbpom)+1
5699             if(np.gt.legmax)then
5700              goto 2
5701             endif
5702             npomtg(nbpom)=np
5703             itt=ipomti(m)
5704             iwt(itt)=1
5705             iltg(np,nbpom)=itt
5706             l0=lqb(itt)+1
5707             if(l0.gt.npnmax)then
5708              goto 2
5709             endif
5710             lqb(itt)=l0
5711             lntg(np,nbpom)=l0
5712             nbti(l0,itt)=nbpom
5713             idnti(l0,itt)=1
5714             nlti(l0,itt)=np
5715             vvxtg(l0,itt)=vvxti(m)
5716             xpomtg(l0,itt)=xpomti(m)
5717             bpomtg(l0,itt)=bpomti(m)
5718            enddo
5719           endif
5720          endif
5721         enddo                   !end of Pomeron loop
5722 3      continue                 !end of it-loop
5723 4     continue                  !end of ip-loop
5724 
5725 c-------------------------------------------------
5726 c   diffraction (hadron-hadron case)
5727       if(ia(1).eq.1.and.ia(2).eq.1.and.iwp(1).eq.0.and.iwt(1).eq.0)then
5728        wel=0.d0
5729        winel=0.d0
5730        do icdp=1,2
5731        do icdt=1,2
5732         vv=qgpomi(scm,b*b,0.d0,0.d0,0.d0,icdp,icdt,icz,1)   !total eikonal
5733         wabs(icdp,icdt)=exp(-vv)
5734         wel=wel+cc(icdp,icz)*cc(icdt,2)*wabs(icdp,icdt)
5735         winel=winel+cc(icdp,icz)*cc(icdt,2)*wabs(icdp,icdt)**2
5736        enddo
5737        enddo
5738        if(qgran(b10).le.wel**2/winel)then
5739         if(debug.ge.1)write (moniou,231)
5740         goto 1
5741        endif
5742 
5743        wdifp=cc(1,icz)*cc(2,icz)*(cc(1,2)**2*(wabs(1,1)-wabs(2,1))**2
5744      * +cc(2,2)**2*(wabs(1,2)-wabs(2,2))**2+2.d0*cc(1,2)*cc(2,2)
5745      * *(wabs(1,1)-wabs(2,1))*(wabs(1,2)-wabs(2,2)))
5746        wdift=cc(1,2)*cc(2,2)*(cc(1,icz)**2*(wabs(1,1)-wabs(1,2))**2
5747      * +cc(2,icz)**2*(wabs(2,1)-wabs(2,2))**2+2.d0*cc(1,icz)*cc(2,icz)
5748      * *(wabs(1,1)-wabs(1,2))*(wabs(2,1)-wabs(2,2)))
5749        wdifd=cc(1,icz)*cc(2,icz)*cc(1,2)*cc(2,2)
5750      * *(wabs(1,1)+wabs(2,2)-wabs(1,2)-wabs(2,1))**2
5751        aks=(wdifp+wdift+wdifd)*qgran(b10)
5752        if(aks.lt.wdifp)then
5753         nwp=nwp+1
5754         iwp(1)=2
5755         iprcn(1)=1
5756         iwt(1)=-1
5757        elseif(aks.lt.wdifp+wdift)then
5758         nwt=nwt+1
5759         iwt(1)=2
5760         itgcn(1)=1
5761         iwp(1)=-1
5762        else
5763         nwp=nwp+1
5764         nwt=nwt+1
5765         iwp(1)=2
5766         iwt(1)=2
5767         iprcn(1)=1
5768         itgcn(1)=1
5769        endif
5770        goto 9
5771       endif
5772 
5773 c-------------------------------------------------
5774 c   diffraction (hadron-nucleus & nucleus-nucleus)
5775       do ip=1,ia(1)             !loop over all projectile nucleons
5776        x=xa(ip,1)+b             !proj. x is shifted by b
5777        y=xa(ip,2)
5778        if(iwp(ip).ne.0)then
5779         nwp=nwp+1               !one more wounded proj. nucleon
5780         if(lqa(ip).eq.0.and.(wdp(1,ip).ne.0.d0.or.wdp(2,ip).ne.0.d0))
5781      *  then
5782          icdps=iddp(ip)
5783          xpomr=1.d0/dsqrt(scm)
5784          do it=1,ia(2)
5785           if(iconab(ip,it).ne.0)then
5786             bbp=(x-xb(it,1))**2+(y-xb(it,2))**2
5787            xxp=.5d0*(x+xb(it,1))
5788            yyp=.5d0*(y+xb(it,2))
5789            icdt=iddt(it)
5790            do icdp=1,2
5791             iddp(ip)=icdp
5792             call qgfdf(xxp,yyp,xpomr,vpac,vtac
5793      *      ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
5794             vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)   !total eikonal
5795             wdp(icdp,ip)=wdp(icdp,ip)*exp(-vv)
5796            enddo
5797           endif
5798          enddo
5799          iddp(ip)=icdps
5800          wdifr=cc(1,icz)*cc(2,icz)*(wdp(1,ip)-wdp(2,ip))**2
5801      *   /(cc(1,icz)*wdp(1,ip)**2+cc(2,icz)*wdp(2,ip)**2)
5802          if(qgran(b10).lt.wdifr)iwp(ip)=3                     !LMD excitation
5803         endif
5804 
5805        elseif(icona(ip).ne.0)then
5806         if(debug.ge.2)write (moniou,223)ip
5807         vabs(1)=0.d0
5808         vabs(2)=0.d0
5809         icdps=iddp(ip)
5810         do it=1,ia(2)
5811           bbp=(x-xb(it,1))**2+(y-xb(it,2))**2
5812          icdt=iddt(it)
5813          do icdp=1,2
5814           if(iconab(ip,it).eq.0)then
5815            vabsi(icdp,it)=0.d0
5816           else
5817            iddp(ip)=icdp
5818            xpomr=1.d0/dsqrt(scm)
5819            xxp=.5d0*(x+xb(it,1))
5820            yyp=.5d0*(y+xb(it,2))
5821            call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
5822      *     ,ip,it)
5823            vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)   !total eikonal
5824            vabsi(icdp,it)=vv
5825            vabs(icdp)=vabs(icdp)+vv
5826           endif
5827          enddo
5828         enddo
5829         iddp(ip)=icdps
5830         wdifr=cc(1,icz)*cc(2,icz)*(exp(-vabs(1))-exp(-vabs(2)))**2
5831      *  /(cc(1,icz)*exp(-2.d0*vabs(1))+cc(2,icz)*exp(-2.d0*vabs(2)))
5832 
5833         if(qgran(b10).lt.wdifr)then       !projectile diffraction
5834          wdift=0.d0
5835          do it=1,ia(2)
5836           if(iwt(it).ne.-1)then
5837            wdifi(it)=cc(1,icz)*cc(2,icz)*(exp(-vabsi(1,it))
5838      *     -exp(-vabsi(2,it)))**2/(cc(1,icz)*exp(-2.d0*vabsi(1,it))
5839      *     +cc(2,icz)*exp(-2.d0*vabsi(2,it)))
5840            wdift=wdift+wdifi(it)
5841           else
5842            wdifi(it)=0.d0
5843           endif
5844          enddo
5845          if(wdift.ne.0.d0)then
5846           nwp=nwp+1
5847           iwp(ip)=2
5848           aks=qgran(b10)*wdift
5849           do it=1,ia(2)
5850            aks=aks-wdifi(it)
5851            if(aks.lt.0.d0)goto 5
5852           enddo
5853 5          continue
5854           iprcn(ip)=it
5855           if(iwt(it).eq.0)iwt(it)=-1
5856           if(debug.ge.2)write (moniou,224)ip,it
5857          endif
5858         endif
5859        endif
5860       enddo                            !end of ip-loop
5861 
5862       do 8 it=1,ia(2)                     !check target diffraction
5863        if(iwt(it).gt.0)then
5864         nwt=nwt+1                         !one more wounded targ. nucleon
5865         if(lqb(it).eq.0.and.(wdt(1,it).ne.0.d0.or.wdt(2,it).ne.0.d0))
5866      *  then
5867          icdts=iddt(it)
5868          xpomr=1.d0/dsqrt(scm)
5869          do ip=1,ia(1)
5870           if(iconab(ip,it).ne.0)then
5871            bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
5872            xxp=.5d0*(xa(ip,1)+b+xb(it,1))
5873            yyp=.5d0*(xa(ip,2)+xb(it,2))
5874            icdp=iddp(ip)
5875            do icdt=1,2
5876             iddt(it)=icdt
5877             call qgfdf(xxp,yyp,xpomr,vpac,vtac
5878      *      ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
5879             vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)   !total eikonal
5880              wdt(icdt,it)=wdt(icdt,it)*exp(-vv)
5881            enddo
5882           endif
5883          enddo
5884          iddt(it)=icdts
5885          wdifr=cc(1,2)*cc(2,2)*(wdt(1,it)-wdt(2,it))**2
5886      *   /(cc(1,2)*wdt(1,it)**2+cc(2,2)*wdt(2,it)**2)
5887          if(qgran(b10).lt.wdifr)iwt(it)=3
5888         endif
5889 
5890        elseif(iconb(it).ne.0)then
5891         if(debug.ge.2)write (moniou,225)it
5892         vabs(1)=0.d0
5893         vabs(2)=0.d0
5894         icdts=iddt(it)
5895         do ip=1,ia(1)
5896          bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
5897          icdp=iddp(ip)
5898          do icdt=1,2
5899           if(iconab(ip,it).eq.0)then
5900            vabsi(icdt,ip)=0.d0
5901           else
5902            iddt(it)=icdt
5903            xpomr=1.d0/dsqrt(scm)
5904            xxp=.5d0*(xa(ip,1)+b+xb(it,1))
5905            yyp=.5d0*(xa(ip,2)+xb(it,2))
5906            call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
5907      *     ,ip,it)
5908            vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)   !total eikonal
5909            vabsi(icdt,ip)=vv
5910            vabs(icdt)=vabs(icdt)+vv
5911           endif
5912          enddo
5913         enddo
5914         iddt(it)=icdts
5915         wdifr=cc(1,2)*cc(2,2)*(exp(-vabs(1))-exp(-vabs(2)))**2
5916      *  /(cc(1,2)*exp(-2.d0*vabs(1))+cc(2,2)*exp(-2.d0*vabs(2)))
5917 
5918         if(qgran(b10).lt.wdifr)then       !target diffraction
5919          wdift=0.d0
5920          do ip=1,ia(1)
5921           if(iwp(ip).eq.-1)then
5922            wdifi(ip)=0.d0
5923           else
5924            if(iwp(ip).eq.2)then
5925             itt=iprcn(ip)
5926             if(itt.eq.it)goto 7
5927             if(iwt(itt).eq.2)then
5928              wdifi(ip)=0.d0
5929              goto 6
5930             endif
5931            endif
5932            wdifi(ip)=cc(1,2)*cc(2,2)*(exp(-vabsi(1,ip))
5933      *     -exp(-vabsi(2,ip)))**2/(cc(1,2)*exp(-2.d0*vabsi(1,ip))
5934      *     +cc(2,2)*exp(-2.d0*vabsi(2,ip)))
5935           endif
5936 6          wdift=wdift+wdifi(ip)
5937          enddo
5938          if(wdift.eq.0.d0)goto 8
5939          nwt=nwt+1
5940          iwt(it)=2
5941          aks=qgran(b10)*wdift
5942          do ip=1,ia(1)
5943           aks=aks-wdifi(ip)
5944           if(aks.lt.0.d0)goto 7
5945          enddo
5946 7         continue
5947          itgcn(it)=ip
5948          if(debug.ge.2)write (moniou,226)it,ip
5949          if(iwp(ip).eq.0)then
5950           iwp(ip)=-1
5951          elseif(iwp(ip).eq.2)then
5952           itt=iprcn(ip)
5953           iprcn(ip)=it
5954           if(itt.ne.it.and.iwt(itt).eq.-1)iwt(itt)=0
5955          endif
5956         endif
5957        endif
5958 8     continue
5959 
5960 c check diffractive cross sections (hadron-proton only)
5961 9     jdiff=0                             !non-diffractive
5962       if(ia(1).eq.1.and.ia(2).eq.1.and.(nwp.ne.0.or.nwt.ne.0)
5963      *.and.nqs(1).eq.0)then
5964        if(lqa(1).eq.0.and.lqb(1).eq.0)then
5965         if(nbpom.eq.0.or.npomin(1).eq.0)then
5966          if(iwp(1).ge.2.and.iwt(1).lt.2)then
5967           jdiff=6                         !SD(LM)-proj
5968          elseif(iwp(1).lt.2.and.iwt(1).ge.2)then
5969           jdiff=7                         !SD(LM)-targ
5970          elseif(iwp(1).ge.2.and.iwt(1).ge.2)then
5971           jdiff=8                         !DD(LM)
5972          else
5973           goto 12
5974          endif
5975         else
5976          if(iwp(1).lt.2.and.iwt(1).lt.2)then
5977           jdiff=9                         !CD(DPE)
5978          else
5979           jdiff=10                        !CD+LMD
5980          endif
5981         endif
5982        elseif(lqa(1).gt.0.and.lqb(1).eq.0.and.iwt(1).lt.2)then
5983         jdiff=1                          !SD(HM)-proj
5984        elseif(lqa(1).eq.0.and.lqb(1).gt.0.and.iwp(1).lt.2)then
5985         jdiff=2                          !SD(HM)-targ
5986        elseif(lqa(1).gt.0.and.lqb(1).eq.0.and.iwt(1).ge.2)then
5987         jdiff=3                          !DD(LHM)-proj
5988        elseif(lqa(1).eq.0.and.lqb(1).gt.0.and.iwp(1).ge.2)then
5989         jdiff=4                          !DD(LHM)-targ
5990 
5991        elseif(lqa(1).gt.0.and.lqb(1).gt.0)then
5992         if(npompr(1).eq.0)stop'problem with npompr!!!'
5993         xrapmax(1)=1.d0
5994         do i=1,npompr(1)
5995          xrapmax(1)=min(xrapmax(1),1.d0/xpompr(i,1)/scm)
5996         enddo
5997         if(npomtg(1).eq.0)stop'problem with npomtg!!!'
5998         xrapmin(1)=1.d0/scm
5999         do i=1,npomtg(1)
6000          xrapmin(1)=max(xrapmin(1),xpomtg(i,1))
6001         enddo
6002         if(xrapmin(1).gt..999d0*xrapmax(1))goto 12
6003         nraps=1
6004         irap=1
6005 11      if(nraps.gt.90)stop'nraps>90'
6006         if(npomin(1).gt.0)then
6007          do i=1,npomin(1)
6008           if(xpomin(i,1).lt..999d0*xrapmax(irap)
6009      *    .and.xpopin(i,1).gt.1.001d0*xrapmin(irap))then
6010            if(xpomin(i,1).lt.1.001d0*xrapmin(irap)
6011      *     .and.xpopin(i,1).gt..999d0*xrapmax(irap))then
6012             nraps=nraps-1
6013             if(nraps.eq.0)goto 12
6014             irap=irap-1
6015             goto 11
6016            elseif(xpopin(i,1).gt..999d0*xrapmax(irap))then
6017             xrapmax(irap)=xpomin(i,1)
6018             if(xrapmin(irap).gt..999d0*xrapmax(irap))then
6019              nraps=nraps-1
6020              if(nraps.eq.0)goto 12
6021              irap=irap-1
6022              goto 11
6023             endif
6024            elseif(xpomin(i,1).lt.1.001d0*xrapmin(irap))then
6025             xrapmin(irap)=xpopin(i,1)
6026             if(xrapmin(irap).gt..999d0*xrapmax(irap))then
6027              nraps=nraps-1
6028              if(nraps.eq.0)goto 12
6029              irap=irap-1
6030              goto 11
6031             endif
6032            else
6033             xrapmin(irap+1)=xrapmin(irap)
6034             xrapmin(irap)=xpopin(i,1)
6035             xrapmax(irap+1)=xpomin(i,1)
6036             if(xrapmin(irap).lt..999d0*xrapmax(irap)
6037      *      .and.xrapmin(irap+1).lt..999d0*xrapmax(irap+1))then
6038              irap=irap+1
6039              nraps=nraps+1
6040              goto 11
6041             elseif(xrapmin(irap).lt..999d0*xrapmax(irap))then
6042              goto 11
6043             elseif(xrapmin(irap+1).lt..999d0*xrapmax(irap+1))then
6044              xrapmin(irap)=xrapmin(irap+1)
6045              xrapmax(irap)=xrapmax(irap+1)
6046              goto 11
6047             else
6048              nraps=nraps-1
6049              if(nraps.eq.0)goto 12
6050              irap=irap-1
6051              goto 11
6052             endif
6053            endif
6054           endif
6055          enddo                           !end of npin-loop
6056         endif
6057         jdiff=5                          !DD(HM)
6058        endif
6059       endif                              !end of diffr. check
6060 12    bdiff=b
6061 
6062 ctp define collision type
6063       typevt=0                      !no interaction
6064       if(ia(1).eq.1.and.ia(2).eq.1.and.(nwp.gt.0.or.nwt.gt.0))then !only for h-h
6065        if(jdiff.eq.0)then                                  !ND (no rap-gaps)
6066         typevt=1
6067        elseif(jdiff.eq.8.or.jdiff.eq.10.or.
6068      *       (jdiff.gt.2.and.jdiff.lt.6))then !DD + (CD+LMD)
6069         typevt=2                           
6070        elseif(jdiff.eq.1.or.jdiff.eq.6)then                  !SD pro
6071         typevt=4  
6072        elseif(jdiff.eq.2.or.jdiff.eq.7)then                  !SD tar
6073         typevt=-4  
6074        elseif(jdiff.eq.9)then                                !CD
6075         typevt=3
6076        else
6077         stop'problem with typevt!'
6078        endif
6079       endif
6080 
6081 
6082 c form projectile spectator part
6083       if(debug.ge.1)write (moniou,227)
6084       nspec=0
6085       do ip=1,ia(1)
6086        if(iwp(ip).eq.0)then
6087         if(debug.ge.2)write (moniou,228)ip
6088         nspec=nspec+1
6089         do l=1,3
6090          xas(nspec,l)=xa(ip,l)
6091         enddo
6092        endif
6093       enddo
6094 
6095       nspect=0
6096       do it=1,ia(2)
6097        if(iwt(it).eq.0)nspect=nspect+1
6098       enddo
6099 
6100 c inelastic interaction: energy sharing and particle production
6101       if(nwp.ne.0.or.nwt.ne.0)then
6102        if(ia(1).eq.nspec.or.ia(2).eq.nspect)stop'ia(1)=nspec!!!'
6103        if(debug.ge.1)write (moniou,229)
6104 
6105        call qgsha(nbpom,ncola,ncolb,iret)
6106        if(iret.ne.0)goto 1
6107        if(nsp.le.nsp0+2)then
6108         if(debug.ge.1)write (moniou,230)
6109         goto 1
6110        endif
6111       else                                 !no interaction
6112        if(debug.ge.1)write (moniou,231)
6113        goto 1
6114       endif
6115       if(debug.ge.1)write (moniou,232)nsp
6116 
6117 c fragmentation of the projectile spectator part
6118       if(debug.ge.1)write (moniou,233)
6119       call qgfrgm(nspec,xas)
6120       if(debug.ge.1)write (moniou,234)nsf
6121       if(debug.ge.1)write (moniou,235)
6122 
6123 201   format(2x,'qgconf - configuration of the interaction')
6124 202   format(2x,'qgconf: impact parameter b=',e10.3,' fm')
6125 203   format(2x,'qgconf: nuclear configurations')
6126 204   format(2x,'qgconf: check connections')
6127 205   format(2x,'qgconf: ',i3,'-th proj. nucleon may interact with '
6128      *,i3,'-th target nucleon')
6129 206   format(2x,'qgconf: ',i3,'-th projectile nucleon may interact')
6130 207   format(2x,'qgconf: ',i3,'-th target nucleon may interact')
6131 208   format(2x,'qgconf: ',i3,'-th rejection,'
6132      *,' redo Pomeron configuration')
6133 209   format(2x,'qgconf: too many rejections,'
6134      *,' redo nuclear configuartions')
6135 210   format(2x,'qgconf: Pomeron configuration')
6136 211   format(2x,'qgconf: check ',i3,'-th projectile nucleon')
6137 212   format(2x,'qgconf: interaction with ',i3,'-th target nucleon?')
6138 213   format(2x,'qgconf: eikonals - total: ',e10.3,2x,'single: ',e10.3)
6139 214   format(2x,'qgconf: ',i4,'-th Pomeron block connected to ',i3
6140      *,'-th proj. nucleon and'/4x,i3,'-th targ. nucleon;'
6141      *,' number of element. processes in the block: ',i3)
6142 215   format(2x,'qgconf: ',i3
6143      *,'-th process in the block is single cut Pomeron')
6144 219   format(2x,'qgconf: configuration of multi-Pomeron vertexes')
6145 220   format(2x,'qgconf: ',i3,'-