Back to home page

Project CMSSW displayed by LXR

 
 

    


File indexing completed on 2024-04-06 12:14:09

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,'-th process in the block contains '
6146      *,i3,' interm. Pomerons')
6147 221   format(2x,'qgconf: ',i3,'-th process in the block contains '
6148      *,i3,' proj. legs')
6149 222   format(2x,'qgconf: ',i3,'-th process in the block contains '
6150      *,i3,' targ. legs')
6151 223   format(2x,'qgconf: check diffraction for ',i3,'-th proj. nucleon')
6152 224   format(2x,'qgconf: diffr. of ',i3,'-th proj. nucleon,'
6153      *,' recoil of ',i3,'-th targ. nucleon')
6154 225   format(2x,'qgconf: check diffraction for ',i3,'-th targ. nucleon')
6155 226   format(2x,'qgconf: diffr. of ',i3,'-th targ. nucleon,'
6156      *,' recoil of ',i3,'-th proj. nucleon')
6157 227   format(2x,'qgconf: projectile spectator part')
6158 228   format(2x,'qgconf: ',i3,'-th proj. nucleon stays idle')
6159 229   format(2x,'qgconf: inelastic interaction: energy sharing'
6160      *,' and particle production')
6161 230   format(2x,'qgconf: no particle produced - rejection')
6162 231   format(2x,'qgconf: no interaction - rejection')
6163 232   format(2x,'qgconf: ',i5,' particles have been produced')
6164 233   format(2x,'qgconf: fragmentation of the proj. spectator part')
6165 234   format(2x,'qgconf: ',i3,' proj. fragments have been produced')
6166 235   format(2x,'qgconf - end')
6167       return
6168       end
6169 
6170 c=============================================================================
6171       subroutine qg3pdf(vvxpi,vvxti,xpompi,xpomti,bpompi,bpomti
6172      *,xpomip,xpomim,vvxim,bpomim,nppr,nptg,npin,ipompi,ipomti
6173      *,wdp,wdt,ip,it,iret)
6174 c-----------------------------------------------------------------------
6175 c qg3pdf - configuration for multi-Pomeron/diffractive contributions
6176 c ip,it - indexes of proj. and targ. nucleons for current collision
6177 c to determine:
6178 c nppr - number of proj. leg Pomerons in the process,
6179 c nptg - number of targ. leg Pomerons in the process,
6180 c npin - number of interm. Pomerons (between 2 3P-vertexes) in the process,
6181 c xpomip(i) - LC momentum of the upper 3P-vertex for i-th interm. Pomeron
6182 c in the process,
6183 c xpomim(i) - LC momentum of the lower 3P-vertex for i-th interm. Pomeron
6184 c in the process,
6185 c ipompi(i) - proj. index for i-th proj. leg Pomeron in the process,
6186 c ipomti(i) - proj. index for i-th targ. leg Pomeron in the process,
6187 c bpompi(i) - squared impact param. for i-th proj. leg Pomeron in the process,
6188 c bpomti(i) - squared impact param. for i-th targ. leg Pomeron in the process,
6189 c vvxpi(i) - relative strenth of scr. corrections for i-th proj. leg Pomeron,
6190 c vvxti(i) - relative strenth of scr. corrections for i-th targ. leg Pomeron,
6191 c xpompi(i) - LC momentum of the 3P-vertex for i-th proj. leg Pomeron,
6192 c xpomti(i) - LC momentum of the 3P-vertex for i-th targ. leg Pomeron
6193 c iret=1 - reject configuration
6194 c-----------------------------------------------------------------------
6195       implicit double precision (a-h,o-z)
6196       integer debug
6197       parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900
6198      *,levmax=20,legmax=900)
6199       dimension vpac(iapmax),vtac(iapmax)
6200      *,vpac0(iapmax),vtac0(iapmax),vpact(iapmax),vtact(iapmax)
6201      *,xpomip(npmax),xpomim(npmax),vvxim(npmax),bpomim(npmax)
6202      *,xpompi(legmax),xpomti(legmax)
6203      *,vvxpi(legmax),vvxti(legmax),bpompi(legmax),bpomti(legmax)
6204      *,ipompi(legmax),ipomti(legmax),ippr0(legmax),iptg0(legmax)
6205      *,nppm(levmax),ippm(legmax,levmax),ii(levmax),xpomm(levmax)
6206      *,wgpm(levmax),xxm(levmax),yym(levmax)
6207      *,itypr0(legmax),itytg0(legmax),itypm(legmax,levmax),vv(12)
6208      *,wdp(2,iapmax),wdt(2,iapmax)
6209       common /qgarr1/  ia(2),icz,icp
6210       common /qgarr2/  scm,wp0,wm0
6211       common /qgarr6/  pi,bm,amws
6212       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
6213       common /qgarr9/  iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
6214      *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
6215      *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
6216      *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
6217      *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
6218      *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
6219      *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
6220      *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
6221       common /qgarr11/ b10
6222       common /qgarr12/ nsp
6223       common /qgarr13/ nsf,iaf(iapmax)
6224       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
6225       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
6226       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
6227       common /qgarr19/ ahl(3)
6228       common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
6229      *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
6230      *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
6231      *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
6232      *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
6233      *,bpomin(npmax,npbmax)
6234       common /qgarr43/ moniou
6235       common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
6236      *,iconb(iapmax)
6237       common /qgdebug/  debug
6238       external qgran
6239 
6240       if(debug.ge.2)write (moniou,201)ip,it
6241 
6242       if(scm.le.sgap**2)stop'qg3pdf: scm<sgap**2!'
6243       iret=0
6244       vpacng=0.d0
6245       vtacng=0.d0
6246       vpacpe=0.d0
6247       vtacpe=0.d0
6248       vimp=0.d0
6249       viuc=0.d0
6250       viuu=0.d0
6251       vip=0.d0
6252       vicc=0.d0
6253       vicu=0.d0
6254 c normalization of rejection function
6255       xpomr=1.d0/dsqrt(scm)
6256       bpt=dsqrt((xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2)
6257       rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomr))*4.d0*.0389d0
6258       rp2=(rq(iddt(it),2)+alfp*dlog(xpomr*scm))*4.d0*.0389d0
6259       rp0=rp1*rp2/(rp1+rp2)
6260       bbpr=(bpt*rp1/(rp1+rp2))**2
6261       bbtg=(bpt*rp2/(rp1+rp2))**2
6262       call qgbdef(bbpr,bbtg,xa(ip,1)+b,xa(ip,2),xb(it,1),xb(it,2)
6263      *,xxp,yyp,1)
6264 
6265       rpmax=max(rq(iddp(ip),icz),rq(iddt(it),2))*4.d0*.0389d0
6266       rpmin=min(rq(iddp(ip),icz),rq(iddt(it),2))*4.d0*.0389d0
6267       if(rpmax.eq.rpmin)then
6268        rpmax=rpmax+alfp*dlog(scm)*2.d0*.0389d0
6269        rpmin=rpmin+alfp*dlog(scm)*2.d0*.0389d0
6270       else
6271        rpmin=rpmin+alfp*dlog(scm/sgap)*4.d0*.0389d0
6272       endif
6273       rp0=rpmax*rpmin/(rpmax+rpmin)
6274 
6275       call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
6276      *,ip,it)
6277       vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
6278       vpl=qglegi(1.d0/xpomr,bbpr,iddp(ip),icz,2)
6279       vplc=min(vpl
6280      *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,7))
6281       vplc0=min(vplc
6282      *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,8))
6283       vplcpe=min(vplc0
6284      *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,10))
6285       vplcp=min(vplcpe
6286      *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,9))
6287 
6288       vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
6289       vtl=qglegi(xpomr*scm,bbtg,iddt(it),2,2)
6290       vtlc=min(vtl
6291      *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,7))
6292       vtlc0=min(vtlc
6293      *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,8))
6294       vtlcpe=min(vtlc0
6295      *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,10))
6296       vtlcp=min(vtlcpe
6297      *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,9))
6298 
6299       sumcp0=0.d0
6300       sumup=0.d0
6301       do i=1,ia(1)
6302        sumup=sumup+vpac(i)
6303       enddo
6304       vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
6305       do i=1,ia(1)-ip+1
6306        ipp=ia(1)-i+1
6307        bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
6308        sumup=sumup-vpac(ipp)
6309        vpac0(ipp)=min(vpac(ipp)
6310      * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
6311      * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
6312        if(ipp.gt.ip)sumcp0=sumcp0+vpac0(ipp)
6313       enddo
6314       sumct0=0.d0
6315       sumut=0.d0
6316       do i=1,ia(2)
6317        sumut=sumut+vtac(i)
6318       enddo
6319       vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
6320       do i=1,ia(2)-it+1
6321        itt=ia(2)-i+1
6322        bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
6323        sumut=sumut-vtac(itt)
6324        vtac0(itt)=min(vtac(itt)
6325      * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
6326      * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
6327        if(itt.gt.it)sumct0=sumct0+vtac0(itt)
6328       enddo
6329       vvxp0=1.d0-exp(-sumcp0)
6330       vvxt0=1.d0-exp(-sumct0)
6331 
6332 c weights for vertex contributions:
6333 c vv(1): >1 proj. legs and >1 targ. legs
6334       vv(1)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6335      *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6336      **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6337      *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6338      **(1.d0-vvx)**2
6339      *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6340      *-(vpac(ip)-vpac0(ip)))
6341      **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
6342      **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6343      *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6344      **(1.d0-vvx)*(1.d0-vvxtl)
6345      *-2.d0*(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6346      *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6347      **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6348      **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
6349      **(1.d0-vvx)*(1.d0-vvxpl)
6350 c vv(2): 0 proj. legs and 0 targ. legs
6351       vv(2)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6352      *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)
6353      **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6354      *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
6355 c vv(3): 0 proj. legs and >1 targ. legs
6356       vv(3)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6357      *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)
6358      **((max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6359      *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6360      **(1.d0-vvxtl)
6361      *-2.d0*(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0
6362      *-(vtac(it)-vtac0(it)))
6363      **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it)))
6364 c vv(4): >1 proj. legs and 0 targ. legs
6365       vv(4)=((max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6366      *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6367      **(1.d0-vvxpl)
6368      *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6369      *-(vpac(ip)-vpac0(ip)))
6370      **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip)))
6371      **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6372      *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
6373 c vv(5): 0 proj. legs and >1 targ. (handle) legs
6374       vv(5)=4.d0*(1.d0-exp(-vpac(ip)))*(1.d0-vvx)
6375      **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6376      **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
6377       if(xpomr*scm.lt.1.1d0*sgap**2)vv(5)=0.d0
6378 c vv(6): >1 proj. (handle) legs and 0 targ. legs
6379       vv(6)=4.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6380      *-(vpac(ip)-vpac0(ip)))*(1.d0-vvxp0)
6381      *+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
6382      **(1.d0-exp(-vtac(it)))*(1.d0-vvx)
6383       if(xpomr*sgap**2.gt..9d0)vv(6)=0.d0
6384 c vv(7): >1 proj. legs and 1 targ. leg
6385       vv(7)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6386      *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6387      **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6388      *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
6389      **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
6390      **(1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxt)
6391      *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6392      *-(vpac(ip)-vpac0(ip)))
6393      **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))
6394      **(vtac(it)+vtlc)*exp(-vpac(ip)-2.d0*vtac(it))
6395      **(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
6396 c vv(8): 1 proj. leg and >1 targ. legs
6397       vv(8)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6398      *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
6399      **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
6400      **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6401      *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6402      **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxtl)
6403      *-2.d0*(vpac(ip)+vplc)*exp(-2.d0*vpac(ip)-vtac(it))
6404      **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6405      **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))
6406      **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
6407 c vv(9): 0 proj. legs and 1 targ. leg
6408       vv(9)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6409      *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
6410      **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6411      *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
6412      **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
6413 c vv(10): 1 proj. leg and 0 targ. legs
6414       vv(10)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6415      *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
6416      **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
6417      **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6418      *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
6419 c vv(11): 1 cut proj. leg and 1 targ. leg
6420       vv(11)=2.d0*vplcp*((vtlc0-vtlcpe)
6421      **exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6422      *-(vtlc-vtlc0)*(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
6423      **exp(-2.d0*vpac(ip)-vtac(it))
6424      **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvxt)
6425       if(xpomr*scm.lt.1.1d0*sgap**2)vv(11)=0.d0
6426 c vv(12): 1 proj. leg and 1 cut targ. leg
6427       vv(12)=2.d0*vtlcp*((vplc0-vplcpe)
6428      **exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6429      *-(vplc-vplc0)*(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
6430      **exp(-2.d0*vtac(it)-vpac(ip))
6431      **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)**2*(1.d0-vvxtl)
6432       if(xpomr*sgap**2.gt..9d0)vv(12)=0.d0
6433 
6434       gb0=0.d0
6435       do i=1,12
6436        gb0=gb0+max(0.d0,vv(i))/4.d0
6437       enddo
6438 
6439       if(gb0.le.0.d0)then      !so170712
6440        if(debug.ge.3)write (moniou,202)
6441        iret=1
6442        goto 31
6443       endif
6444       if(debug.ge.3)write (moniou,203)gb0
6445 
6446 1     continue
6447       xpomr=(scm/sgap**2)**(-qgran(b10))/sgap   !proposed LC momentum for 3P-vertex
6448       rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomr))*4.d0*.0389d0
6449       rp2=(rq(iddt(it),2)+alfp*dlog(xpomr*scm))*4.d0*.0389d0
6450       rp=rp1*rp2/(rp1+rp2)
6451       z=qgran(b10)
6452       phi=pi*qgran(b10)
6453       b0=dsqrt(-rp*dlog(z))
6454       bbpr=(bpt*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
6455       bbtg=(bpt*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
6456       call qgbdef(bbpr,bbtg,xa(ip,1)+b,xa(ip,2),xb(it,1),xb(it,2)
6457      *,xxp,yyp,int(1.5d0+qgran(b10)))   !determine coordinates for the vertex
6458 
6459       call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
6460      *,ip,it)
6461       vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
6462       vpl=qglegi(1.d0/xpomr,bbpr,iddp(ip),icz,2)
6463       vplc=min(vpl
6464      *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,7))
6465       vplc0=min(vplc
6466      *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,8))
6467       vplcpe=min(vplc0
6468      *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,10))
6469       vplcp=min(vplcpe
6470      *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,9))
6471 
6472       vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
6473       vtl=qglegi(xpomr*scm,bbtg,iddt(it),2,2)
6474       vtlc=min(vtl
6475      *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,7))
6476       vtlc0=min(vtlc
6477      *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,8))
6478       vtlcpe=min(vtlc0
6479      *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,10))
6480       vtlcp=min(vtlcpe
6481      *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,9))
6482 
6483       sumcp0=0.d0
6484       sumup=0.d0
6485       do i=1,ia(1)
6486        sumup=sumup+vpac(i)
6487       enddo
6488       vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
6489       do i=1,ia(1)-ip+1
6490        ipp=ia(1)-i+1
6491        bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
6492        sumup=sumup-vpac(ipp)
6493        vpac0(ipp)=min(vpac(ipp)
6494      * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
6495      * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
6496        if(ipp.gt.ip)sumcp0=sumcp0+vpac0(ipp)
6497       enddo
6498       sumct0=0.d0
6499       sumut=0.d0
6500       do i=1,ia(2)
6501        sumut=sumut+vtac(i)
6502       enddo
6503       vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
6504       do i=1,ia(2)-it+1
6505        itt=ia(2)-i+1
6506        bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
6507        sumut=sumut-vtac(itt)
6508        vtac0(itt)=min(vtac(itt)
6509      * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
6510      * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
6511        if(itt.gt.it)sumct0=sumct0+vtac0(itt)
6512       enddo
6513       vvxp0=1.d0-exp(-sumcp0)
6514       vvxt0=1.d0-exp(-sumct0)
6515 
6516 c weights for vertex contributions:
6517 c vv(1): >1 proj. legs and >1 targ. legs
6518       vv(1)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6519      *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6520      **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6521      *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6522      **(1.d0-vvx)**2
6523      *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6524      *-(vpac(ip)-vpac0(ip)))
6525      **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
6526      **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6527      *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6528      **(1.d0-vvx)*(1.d0-vvxtl)
6529      *-2.d0*(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6530      *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6531      **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6532      **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
6533      **(1.d0-vvx)*(1.d0-vvxpl)
6534 c vv(2): 0 proj. legs and 0 targ. legs
6535       vv(2)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6536      *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)
6537      **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6538      *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
6539 c vv(3): 0 proj. legs and >1 targ. legs
6540       vv(3)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6541      *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)
6542      **((max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6543      *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6544      **(1.d0-vvxtl)
6545      *-2.d0*(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0
6546      *-(vtac(it)-vtac0(it)))
6547      **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it)))
6548 c vv(4): >1 proj. legs and 0 targ. legs
6549       vv(4)=((max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6550      *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6551      **(1.d0-vvxpl)
6552      *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6553      *-(vpac(ip)-vpac0(ip)))
6554      **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip)))
6555      **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6556      *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)
6557 c vv(5): 0 proj. legs and >1 targ. (handle) legs
6558       vv(5)=4.d0*(1.d0-exp(-vpac(ip)))*(1.d0-vvx)
6559      **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6560      **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))*exp(-vtac(it))
6561       if(xpomr*scm.le.sgap**2)vv(5)=0.d0
6562 c vv(6): >1 proj. (handle) legs and 0 targ. legs
6563       vv(6)=4.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6564      *-(vpac(ip)-vpac0(ip)))*(1.d0-vvxp0)
6565      *+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))*exp(-vpac(ip))
6566      **(1.d0-exp(-vtac(it)))*(1.d0-vvx)
6567       if(xpomr*sgap**2.ge.1.d0)vv(6)=0.d0
6568 c vv(7): >1 proj. legs and 1 targ. leg
6569       vv(7)=(max(0.d0,1.d0-exp(-2.d0*vpac(ip))*(1.d0+2.d0*vpac(ip)))
6570      *+2.d0*vpac(ip)*exp(-2.d0*vpac(ip))*(1.d0-(1.d0-vvxp)**2))
6571      **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6572      *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
6573      **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
6574      **(1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxt)
6575      *-2.d0*(max(0.d0,exp(vpac(ip)-vpac0(ip))-1.d0
6576      *-(vpac(ip)-vpac0(ip)))
6577      **(1.d0-vvxp0)+(vpac(ip)-vpac0(ip))*(vvxp-vvxp0))
6578      **(vtac(it)+vtlc)*exp(-vpac(ip)-2.d0*vtac(it))
6579      **(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
6580 c vv(8): 1 proj. leg and >1 targ. legs
6581       vv(8)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6582      *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
6583      **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
6584      **(max(0.d0,1.d0-exp(-2.d0*vtac(it))*(1.d0+2.d0*vtac(it)))
6585      *+2.d0*vtac(it)*exp(-2.d0*vtac(it))*(1.d0-(1.d0-vvxt)**2))
6586      **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxtl)
6587      *-2.d0*(vpac(ip)+vplc)*exp(-2.d0*vpac(ip)-vtac(it))
6588      **(max(0.d0,exp(vtac(it)-vtac0(it))-1.d0-(vtac(it)-vtac0(it)))
6589      **(1.d0-vvxt0)+(vtac(it)-vtac0(it))*(vvxt-vvxt0))
6590      **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
6591 c vv(9): 0 proj. legs and 1 targ. leg
6592       vv(9)=((1.d0-exp(-vpac(ip)))**2*(1.d0-vvxpl)
6593      *+2.d0*(1.d0-exp(-vpac(ip)))*vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
6594      **((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6595      *-(vtac(it)+vtlc-vtac0(it)-vtlc0)
6596      **(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(it))
6597 c vv(10): 1 proj. leg and 0 targ. legs
6598       vv(10)=((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6599      *-(vpac(ip)+vplc-vpac0(ip)-vplc0)
6600      **(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ip))
6601      **((1.d0-exp(-vtac(it)))**2*(1.d0-vvxtl)
6602      *+2.d0*(1.d0-exp(-vtac(it)))*vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
6603 c vv(11): 1 cut proj. leg and 1 targ. leg
6604       vv(11)=2.d0*vplcp*((vtlc0-vtlcpe)
6605      **exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6606      *-(vtlc-vtlc0)*(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
6607      **exp(-2.d0*vpac(ip)-vtac(it))
6608      **(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvxt)
6609       if(xpomr*scm.lt.1.1d0*sgap**2)vv(11)=0.d0
6610 c vv(12): 1 proj. leg and 1 cut targ. leg
6611       vv(12)=2.d0*vtlcp*((vplc0-vplcpe)
6612      **exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6613      *-(vplc-vplc0)*(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
6614      **exp(-2.d0*vtac(it)-vpac(ip))
6615      **(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)**2*(1.d0-vvxtl)
6616       if(xpomr*sgap**2.gt..9d0)vv(12)=0.d0
6617 
6618       gb=0.d0
6619       do i=1,12
6620        vv(i)=max(0.d0,vv(i))
6621        gb=gb+vv(i)/4.d0
6622       enddo
6623       gb=gb/gb0/z*rp/rp0  /max(2.d0,dlog10(scm)-1.d0)  /2.
6624       if(debug.ge.5)write (moniou,204)xpomr,bbpr,bbtg,gb
6625 
6626       if(qgran(b10).gt.gb)goto 1
6627       if(debug.ge.3)write (moniou,205)xpomr,bbpr,bbtg,xxp,yyp
6628 
6629       vplcng=min(vplc0
6630      *,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp,vvxpl,iddp(ip),icz,11))
6631       vtlcng=min(vtlc0
6632      *,qgfani(xpomr*scm,bbtg,vvxps,vvxt,vvxtl,iddt(it),2,11))
6633 
6634       sumcpt=0.d0
6635       sumcp0=0.d0
6636       sumup=0.d0
6637       vvxp0l=0.d0
6638       do i=1,ia(1)
6639        sumup=sumup+vpac(i)
6640       enddo
6641       vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
6642       do i=1,ia(1)
6643        ipp=ia(1)-i+1
6644        bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
6645        sumup=sumup-vpac(ipp)
6646        if(ipp.ge.ip)vpact(ipp)=max(vpac(ipp)
6647      * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
6648      * ,1.d0-exp(-sumcpt),1.d0-exp(-sumup),iddp(ipp),icz,6))
6649        vpac0(ipp)=min(vpac(ipp)
6650      * ,qgfani(1.d0/xpomr,bbp,1.d0-vvxs*exp(-sumup)
6651      * ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
6652        if(ipp.gt.ip)then
6653         sumcpt=sumcpt+vpact(ipp)
6654        elseif(ipp.lt.ip)then
6655         vvxp0l=vvxp0l+vpac0(ipp)
6656        endif
6657        sumcp0=sumcp0+vpac0(ipp)
6658       enddo
6659       sumctt=0.d0
6660       sumct0=0.d0
6661       sumut=0.d0
6662       vvxt0l=0.d0
6663       do i=1,ia(2)
6664        sumut=sumut+vtac(i)
6665       enddo
6666       vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
6667       do i=1,ia(2)
6668        itt=ia(2)-i+1
6669        bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
6670        sumut=sumut-vtac(itt)
6671        if(itt.ge.it)vtact(itt)=max(vtac(itt)
6672      * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
6673      * ,1.d0-exp(-sumctt),1.d0-exp(-sumut),iddt(itt),2,6))
6674        vtac0(itt)=min(vtac(itt)
6675      * ,qgfani(xpomr*scm,bbt,1.d0-vvxs*exp(-sumut)
6676      * ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
6677        if(itt.gt.it)then
6678         sumctt=sumctt+vtact(itt)
6679        elseif(itt.lt.it)then
6680         vvxt0l=vvxt0l+vtac0(itt)
6681        endif
6682        sumct0=sumct0+vtac0(itt)
6683       enddo
6684       vvxpt=1.d0-exp(-sumcpt)
6685       vvxtt=1.d0-exp(-sumctt)
6686       vvxp0l=1.d0-exp(-vvxp0l)
6687       vvxt0l=1.d0-exp(-vvxt0l)
6688 
6689       vvt=0.d0
6690       do i=1,12
6691        vvt=vvt+vv(i)
6692       enddo
6693       if(.not.(vvt.gt.0.d0))stop'vvt<0'
6694 
6695       aks=qgran(b10)*vvt
6696       do jt=1,12
6697        aks=aks-vv(jt)
6698        if(aks.lt.0.d0)goto 2
6699       enddo
6700       stop'jt>12!'
6701 
6702 2     continue
6703       if(xpomr*scm.gt.sgap**2)then
6704        wzgp=-2.d0*(1.d0-exp(-2.d0*vpac(ip)))*(1.d0-vvxpl)**2
6705      * *(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))*(1.d0-vvxtt)
6706      * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0)
6707      * +vtact(it)*exp(-vtact(it))*(1.d0-vvxtt
6708      * -exp(vtact(it)-vtac(it))*(1.d0-vvxtl)*(1.d0-vvxt))
6709      * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0
6710      * -exp(vtac0(it)-vtac(it))*(1.d0-vvxtl)*(1.d0-vvxt)))
6711       else
6712        wzgp=0.d0
6713       endif
6714       if(xpomr*sgap**2.lt.1.d0)then
6715        wzgt=-2.d0*(1.d0-exp(-2.d0*vtac(it)))*(1.d0-vvxtl)**2
6716      * *(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))*(1.d0-vvxpt)
6717      * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0)
6718      * +vpact(ip)*exp(-vpact(ip))*(1.d0-vvxpt
6719      * -exp(vpact(ip)-vpac(ip))*(1.d0-vvxpl)*(1.d0-vvxp))
6720      * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0
6721      * -exp(vpac0(ip)-vpac(ip))*(1.d0-vvxpl)*(1.d0-vvxp)))
6722       else
6723        wzgt=0.d0
6724       endif
6725 
6726       nppr0=0
6727       nptg0=0
6728       npprh0=0
6729       nptgh0=0
6730       wgpr0=0.d0
6731       wgtg0=0.d0
6732       if(jt.eq.1.or.jt.eq.4.or.jt.eq.7)then
6733        ntry=0
6734 3      ntry=ntry+1
6735        npprh0=0
6736        if(ip.eq.ia(1).or.ntry.gt.100)then
6737         nppr0=npgen(2.d0*vpac(ip),2,20)
6738         do i=1,nppr0
6739          if(qgran(b10).le.vpac0(ip)/vpac(ip).or.xpomr*sgap**2.ge.1.d0)
6740      *   then
6741           itypr0(i)=0
6742          else
6743           npprh0=npprh0+1
6744           itypr0(i)=1
6745          endif
6746          ippr0(i)=ip
6747         enddo
6748         wh=(vpac(ip)/vpac0(ip)-1.d0)/nppr0
6749        else
6750         nppr0=npgen(2.d0*vpac(ip),1,20)
6751         do i=1,nppr0
6752          if(qgran(b10).le.vpac0(ip)/vpac(ip).or.xpomr*sgap**2.ge.1.d0)
6753      *   then
6754           itypr0(i)=0
6755          else
6756           npprh0=npprh0+1
6757           itypr0(i)=1
6758          endif
6759          ippr0(i)=ip
6760         enddo
6761         wh=(vpac(ip)/vpac0(ip)-1.d0)/nppr0
6762         do ipp=ip+1,ia(1)
6763          ninc=npgen(2.d0*vpac(ipp),0,20)
6764          if(ninc.ne.0)then
6765           nppr0=nppr0+ninc
6766           nh0=npprh0
6767           if(nppr0.gt.legmax)then
6768            iret=1
6769            goto 31
6770           endif
6771           do i=nppr0-ninc+1,nppr0
6772            if(qgran(b10).le.vpac0(ipp)/vpac(ipp)
6773      *     .or.xpomr*sgap**2.ge.1.d0)then
6774             itypr0(i)=0
6775            else
6776             npprh0=npprh0+1
6777             itypr0(i)=1
6778            endif
6779            ippr0(i)=ipp
6780           enddo
6781           if(ninc.gt.npprh0-nh0)wh=(vpac(ipp)/vpac0(ipp)-1.d0)/ninc
6782          endif
6783         enddo
6784         if(nppr0.eq.1)goto 3
6785        endif
6786        if(nppr0.le.npprh0+1)then
6787         if(jt.ne.7)then
6788          wh0=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6789      *   /(1.d0-vvxp)/(1.d0-vvxpl)
6790         else
6791          wh0=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6792      *   /(1.d0-vvxp)/(1.d0-vvxpl)
6793      *   *(vtac(it)+vtlc)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6794      *   /((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6795      *   -(vtac(it)+vtlc-vtac0(it)-vtlc0)
6796      *   *(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
6797         endif
6798         if(nppr0.eq.npprh0.and.wh0.lt.0.d0
6799      *  .or.nppr0.eq.npprh0+1.and.qgran(b10).gt.1.d0+wh*wh0)goto 3
6800        endif
6801       endif
6802 
6803       if(jt.eq.1.or.jt.eq.3.or.jt.eq.8)then
6804        ntry=0
6805 4      ntry=ntry+1
6806        nptgh0=0
6807        if(it.eq.ia(2).or.ntry.gt.100)then
6808         nptg0=npgen(2.d0*vtac(it),2,20)
6809         do i=1,nptg0
6810          if(qgran(b10).le.vtac0(it)/vtac(it).or.xpomr*scm.le.sgap**2)
6811      *   then
6812           itytg0(i)=0
6813          else
6814           nptgh0=nptgh0+1
6815           itytg0(i)=1
6816          endif
6817          iptg0(i)=it
6818         enddo
6819         wh=(vtac(it)/vtac0(it)-1.d0)/nptg0
6820        else
6821         nptg0=npgen(2.d0*vtac(it),1,20)
6822         do i=1,nptg0
6823          if(qgran(b10).le.vtac0(it)/vtac(it).or.xpomr*scm.le.sgap**2)
6824      *   then
6825           itytg0(i)=0
6826          else
6827           nptgh0=nptgh0+1
6828           itytg0(i)=1
6829          endif
6830          iptg0(i)=it
6831         enddo
6832         wh=(vtac(it)/vtac0(it)-1.d0)/nptg0
6833         do itt=it+1,ia(2)
6834          ninc=npgen(2.d0*vtac(itt),0,20)
6835          if(ninc.ne.0)then
6836           nptg0=nptg0+ninc
6837           nh0=nptgh0
6838           if(nptg0.gt.legmax)then
6839            iret=1
6840            goto 31
6841           endif
6842           do i=nptg0-ninc+1,nptg0
6843            if(qgran(b10).le.vtac0(itt)/vtac(itt)
6844      *     .or.xpomr*scm.le.sgap**2) then
6845             itytg0(i)=0
6846            else
6847             nptgh0=nptgh0+1
6848             itytg0(i)=1
6849            endif
6850            iptg0(i)=itt
6851           enddo
6852           if(ninc.gt.nptgh0-nh0)wh=(vtac(itt)/vtac0(itt)-1.d0)/ninc
6853          endif
6854         enddo
6855         if(nptg0.eq.1)goto 4
6856        endif
6857        if(nptg0.le.nptgh0+1)then
6858         if(jt.ne.8)then
6859          wh0=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
6860      *   /(1.d0-vvxt)/(1.d0-vvxtl)
6861         else
6862          wh0=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
6863      *   /(1.d0-vvxt)/(1.d0-vvxtl)
6864      *   *(vpac(ip)+vplc)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6865      *   /((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6866      *   -(vpac(ip)+vplc-vpac0(ip)-vplc0)
6867      *   *(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
6868         endif
6869         if(nptg0.eq.nptgh0.and.wh0.lt.0.d0
6870      *  .or.nptg0.eq.nptgh0+1.and.qgran(b10).gt.1.d0+wh*wh0)goto 4
6871        endif
6872       endif
6873 
6874       if(jt.eq.6)then
6875        ntry=0
6876 5      ntry=ntry+1
6877        if(ip.eq.ia(1).or.ntry.gt.100)then
6878         nppr0=npgen(vpac(ip)-vpac0(ip),2,20)
6879         do i=1,nppr0
6880          itypr0(i)=1
6881          ippr0(i)=ip
6882         enddo
6883        else
6884         nppr0=npgen(vpac(ip)-vpac0(ip),1,20)
6885         do i=1,nppr0
6886          itypr0(i)=1
6887          ippr0(i)=ip
6888         enddo
6889         do ipp=ip+1,ia(1)
6890          ninc=npgen(vpac(ipp)-vpac0(ipp),0,20)
6891          if(ninc.ne.0)then
6892           nppr0=nppr0+ninc
6893           if(nppr0.gt.legmax)then
6894            iret=1
6895            goto 31
6896           endif
6897           do i=nppr0-ninc+1,nppr0
6898            itypr0(i)=1
6899            ippr0(i)=ipp
6900           enddo
6901          endif
6902         enddo
6903         if(nppr0.eq.1)goto 5
6904        endif
6905       endif
6906 
6907       if(jt.eq.5)then
6908        ntry=0
6909 6      ntry=ntry+1
6910        if(it.eq.ia(2).or.ntry.gt.100)then
6911         nptg0=npgen(vtac(it)-vtac0(it),2,20)
6912         do i=1,nptg0
6913          itytg0(i)=1
6914          iptg0(i)=it
6915         enddo
6916        else
6917         nptg0=npgen(vtac(it)-vtac0(it),1,20)
6918         do i=1,nptg0
6919          itytg0(i)=1
6920          iptg0(i)=it
6921         enddo
6922         do itt=it+1,ia(2)
6923          ninc=npgen(vtac(itt)-vtac0(itt),0,20)
6924          if(ninc.ne.0)then
6925           nptg0=nptg0+ninc
6926           if(nptg0.gt.legmax)then
6927            iret=1
6928            goto 31
6929           endif
6930           do i=nptg0-ninc+1,nptg0
6931            itytg0(i)=1
6932            iptg0(i)=itt
6933           enddo
6934          endif
6935         enddo
6936         if(nptg0.eq.1)goto 6
6937        endif
6938       endif
6939 
6940       gbt=1.d0
6941       if((jt.eq.1.and.nptgh0.lt.nptg0.or.jt.eq.4)
6942      *.and.npprh0.eq.nppr0)then
6943        gbt=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6944      * /(1.d0-vvxp)/(1.d0-vvxpl)
6945       elseif((jt.eq.1.and.npprh0.lt.nppr0.or.jt.eq.3)
6946      *.and.nptgh0.eq.nptg0)then
6947        gbt=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
6948      * /(1.d0-vvxt)/(1.d0-vvxtl)
6949       elseif(jt.eq.1.and.nptgh0.eq.nptg0.and.npprh0.eq.nppr0)then
6950        gbt=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6951      * /(1.d0-vvxp)/(1.d0-vvxpl)
6952      * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))/(1.d0-vvxt)/(1.d0-vvxtl)
6953       elseif(jt.eq.7.and.npprh0.eq.nppr0)then
6954        gbt=1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
6955      * /(1.d0-vvxp)/(1.d0-vvxpl)
6956      * *(vtac(it)+vtlc)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6957      * /((vtac0(it)+vtlc0)*exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
6958      * -(vtac(it)+vtlc-vtac0(it)-vtlc0)
6959      * *(1.d0-exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)))
6960       elseif(jt.eq.8.and.nptgh0.eq.nptg0)then
6961        gbt=1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
6962      * /(1.d0-vvxt)/(1.d0-vvxtl)
6963      * *(vpac(ip)+vplc)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6964      * /((vpac0(ip)+vplc0)*exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6965      * -(vpac(ip)+vplc-vpac0(ip)-vplc0)
6966      * *(1.d0-exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)))
6967       endif
6968       if(qgran(b10).gt.gbt)goto 2
6969 
6970 c less important part of 'zigzag' cuts - commented out (sub-per cent effect)
6971 c      if((jt.eq.1.or.jt.eq.8)
6972 c     *  .and.qgran(b10).lt.max(0.d0,wzgp/(vv(1)+vv(8))))nppr0=0
6973 c      if((jt.eq.1.or.jt.eq.7)
6974 c     *  .and.qgran(b10).lt.max(0.d0,wzgt/(vv(1)+vv(7))))nptg0=0
6975 
6976       if(jt.eq.7.or.jt.eq.9.or.jt.eq.11.or.jt.eq.12)then
6977        nptg0=1
6978        iptg0(1)=it
6979       endif
6980       if(jt.eq.8.or.jt.eq.10.or.jt.eq.11.or.jt.eq.12)then
6981        nppr0=1
6982        ippr0(1)=ip
6983       endif
6984 
6985       if(jt.eq.8.and.nptgh0.lt.nptg0.or.jt.eq.10)then !'fan' from cut vertex
6986        vpacng=min(vpac0(ip)
6987      * ,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp0,vvxpl,iddp(ip),icz,4))
6988 
6989        factor=exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
6990        wng=(vpacng+vplcng)*factor
6991        wgap=max(0.d0,(vpac0(ip)+vplc0)*factor
6992      * -(vpac(ip)+vplc-vpac0(ip)-vplc0)*(1.d0-factor)-wng)
6993        if(qgran(b10).ge.wgap/(wgap+wng).or.xpomr*sgap**2.gt..9d0)then
6994         if(qgran(b10).lt.vpacng/(vpacng+vplcng)
6995      *  .and.xpomr*sgap**2.lt..9d0)then
6996          itypr0(1)=2            !cut 'fan' (no gap at the end)
6997         else
6998          itypr0(1)=4            !cut 'leg' (no gap at the end)
6999         endif
7000        else
7001         wfg=max(0.d0,(vpac0(ip)-vpacng)*factor
7002      *         -(vpac(ip)-vpac0(ip))*(1.d0-factor))
7003         wlg=max(0.d0,(vplc0-vplcng)*factor-(vplc-vplc0)*(1.d0-factor))
7004         if(qgran(b10).lt.wfg/(wfg+wlg))then
7005          itypr0(1)=3            !cut 'fan' (gap at the end)
7006         else
7007          itypr0(1)=5            !cut 'leg' (gap at the end)
7008         endif
7009         wgpr0=(1.d0-factor)/factor
7010        endif
7011 
7012       elseif(jt.eq.8.and.nptgh0.eq.nptg0)then !'fan' from cut/uncut vertex
7013        vpacng=min(vpac0(ip)
7014      * ,qgfani(1.d0/xpomr,bbpr,vvxts,vvxp0,vvxpl,iddp(ip),icz,4))
7015 
7016        factor=exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
7017        wng=(vpacng+vplcng)*factor*(1.d0-exp(vtac(it)
7018      * +(1.d0-nptg0)*dlog(2.d0))/(1.d0-vvxt)/(1.d0-vvxtl))
7019        wgap=max(0.d0,(vpac0(ip)+vplc0)*factor
7020      * -(vpac(ip)+vplc-vpac0(ip)-vplc0)*(1.d0-factor)
7021      * -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))/(1.d0-vvxt)/(1.d0-vvxtl)
7022      * *(vpac(ip)+vplc)*factor-wng)
7023        if(qgran(b10).ge.wgap/(wgap+wng).or.xpomr*sgap**2.gt..9d0)then
7024         if(qgran(b10).lt.vpacng/(vpacng+vplcng)
7025      *  .and.xpomr*sgap**2.lt..9d0)then
7026          itypr0(1)=2            !cut 'fan' (no gap at the end)
7027         else
7028          itypr0(1)=4            !cut 'leg' (no gap at the end)
7029         endif
7030        else
7031         wfg=max(0.d0,(vpac0(ip)-vpacng)*factor
7032      *         -(vpac(ip)-vpac0(ip))*(1.d0-factor)
7033      *  -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
7034      *  /(1.d0-vvxt)/(1.d0-vvxtl)*(vpac(ip)-vpacng)*factor)
7035         wlg=max(0.d0,(vplc0-vplcng)*factor-(vplc-vplc0)*(1.d0-factor)
7036      *  -exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
7037      *  /(1.d0-vvxt)/(1.d0-vvxtl)*(vplc-vplcng)*factor)
7038         if(qgran(b10).lt.wfg/(wfg+wlg))then
7039          itypr0(1)=3            !cut 'fan' (gap at the end)
7040         else
7041          itypr0(1)=5            !cut 'leg' (gap at the end)
7042         endif
7043         wgpr0=1.d0/factor/(1.d0-exp(vtac(it)+(1.d0-nptg0)*dlog(2.d0))
7044      *  /(1.d0-vvxt)/(1.d0-vvxtl))-1.d0
7045        endif
7046 
7047       elseif(jt.eq.11)then
7048        itypr0(1)=6
7049       elseif(jt.eq.12)then
7050        factor=exp(-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
7051        wng=max(0.d0,vplcng-vplcpe)*factor
7052      * /((vplc0-vplcpe)*factor-(vplc-vplc0)*(1.d0-factor))
7053        if(qgran(b10).le.wng)then
7054         itypr0(1)=7            !cut 'leg' (>1 cut Poms at the end)
7055        else
7056         itypr0(1)=5            !cut 'leg' (gap at the end)
7057         wgpr0=(1.d0-factor)/factor
7058        endif
7059       endif
7060 
7061       if(jt.eq.7.and.npprh0.lt.nppr0.or.jt.eq.9)then !'fan' from cut vertex
7062        vtacng=min(vtac0(it)
7063      * ,qgfani(xpomr*scm,bbtg,vvxps,vvxt0,vvxtl,iddt(it),2,4))
7064 
7065        factor=exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
7066        wng=(vtacng+vtlcng)*factor
7067        wgap=max(0.d0,(vtac0(it)+vtlc0)*factor
7068      * -(vtac(it)+vtlc-vtac0(it)-vtlc0)*(1.d0-factor)-wng)
7069        if(qgran(b10).ge.wgap/(wgap+wng)
7070      * .or.xpomr*scm.lt.1.1d0*sgap**2)then
7071         if(qgran(b10).lt.vtacng/(vtacng+vtlcng)
7072      *  .and.xpomr*scm.gt.1.1d0*sgap**2)then
7073          itytg0(1)=2            !cut 'fan' (no gap at the end)
7074         else
7075          itytg0(1)=4            !cut 'leg' (no gap at the end)
7076         endif
7077        else
7078         wfg=max(0.d0,(vtac0(it)-vtacng)*factor
7079      *         -(vtac(it)-vtac0(it))*(1.d0-factor))
7080         wlg=max(0.d0,(vtlc0-vtlcng)*factor-(vtlc-vtlc0)*(1.d0-factor))
7081         if(qgran(b10).lt.wfg/(wfg+wlg))then
7082          itytg0(1)=3            !cut 'fan' (gap at the end)
7083         else
7084          itytg0(1)=5            !cut 'leg' (gap at the end)
7085         endif
7086         wgtg0=(1.d0-factor)/factor
7087        endif
7088 
7089       elseif(jt.eq.7.and.npprh0.eq.nppr0)then !'fan' from cut/uncut vertex
7090        vtacng=min(vtac0(it)
7091      * ,qgfani(xpomr*scm,bbtg,vvxps,vvxt0,vvxtl,iddt(it),2,4))
7092 
7093        factor=exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
7094        wng=(vtacng+vtlcng)*factor*(1.d0-exp(vpac(ip)
7095      * +(1.d0-nppr0)*dlog(2.d0))/(1.d0-vvxp)/(1.d0-vvxpl))
7096        wgap=max(0.d0,(vtac0(it)+vtlc0)*factor
7097      * -(vtac(it)+vtlc-vtac0(it)-vtlc0)*(1.d0-factor)
7098      * -exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))/(1.d0-vvxp)/(1.d0-vvxpl)
7099      * *(vtac(it)+vtlc)*factor-wng)
7100        if(qgran(b10).ge.wgap/(wgap+wng)
7101      * .or.xpomr*scm.lt.1.1d0*sgap**2)then
7102         if(qgran(b10).lt.vtacng/(vtacng+vtlcng)
7103      *  .and.xpomr*scm.gt.1.1d0*sgap**2)then
7104          itytg0(1)=2            !cut 'fan' (no gap at the end)
7105         else
7106          itytg0(1)=4            !cut 'leg' (no gap at the end)
7107         endif
7108        else
7109         wfg=max(0.d0,(vtac0(it)-vtacng)*factor
7110      *         -(vtac(it)-vtac0(it))*(1.d0-factor)
7111      *  -exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
7112      *  /(1.d0-vvxp)/(1.d0-vvxpl)*(vtac(it)-vtacng)*factor)
7113         wlg=max(0.d0,(vtlc0-vtlcng)*factor-(vtlc-vtlc0)*(1.d0-factor)
7114      *  -exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
7115      *  /(1.d0-vvxp)/(1.d0-vvxpl)*(vtlc-vtlcng)*factor)
7116         if(qgran(b10).lt.wfg/(wfg+wlg))then
7117          itytg0(1)=3            !cut 'fan' (gap at the end)
7118         else
7119          itytg0(1)=5            !cut 'leg' (gap at the end)
7120         endif
7121         wgtg0=1.d0/factor/(1.d0-exp(vpac(ip)+(1.d0-nppr0)*dlog(2.d0))
7122      *  /(1.d0-vvxp)/(1.d0-vvxpl))-1.d0
7123        endif
7124 
7125       elseif(jt.eq.12)then
7126        itytg0(1)=6
7127       elseif(jt.eq.11)then
7128        factor=exp(-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
7129        wng=max(0.d0,vtlcng-vtlcpe)*factor
7130      * /((vtlc0-vtlcpe)*factor-(vtlc-vtlc0)*(1.d0-factor))
7131        if(qgran(b10).le.wng)then
7132         itytg0(1)=7            !cut 'leg' (>1 cut Poms at the end)
7133        else
7134         itytg0(1)=5            !cut 'leg' (gap at the end)
7135         wgtg0=(1.d0-factor)/factor
7136        endif
7137       endif
7138       if(debug.ge.3)write (moniou,206)nppr0,nptg0
7139 
7140       nppr=0
7141       nptg=0
7142       npin=0
7143 
7144       if(nppr0.eq.1.and.itypr0(1).eq.6)then     !single cut Pomeron
7145        nppr=1
7146        xpompi(nppr)=xpomr
7147        vvxpi(nppr)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
7148      * *exp(-vtac(it))
7149        ipompi(nppr)=ip
7150        bpompi(nppr)=bbpr
7151        if(debug.ge.4)write (moniou,209)nppr,ip,bbpr,xpompi(nppr)
7152      * ,vvxpi(nppr)
7153        nppr0=0
7154       endif
7155       if(nptg0.eq.1.and.itytg0(1).eq.6)then     !single cut Pomeron
7156        nptg=1
7157        xpomti(nptg)=xpomr
7158        vvxti(nptg)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
7159      * *exp(-vpac(ip))
7160        ipomti(nptg)=it
7161        bpomti(nptg)=bbtg
7162        if(debug.ge.4)write (moniou,217)nptg,it,bbtg,xpomti(nptg)
7163      * ,vvxti(nptg)
7164        nptg0=0
7165       endif
7166 
7167       vvxps=vvxp
7168       vvxpls=vvxpl
7169       vvxp0s=vvxp0
7170       if(nppr0.ne.0)then
7171        i=0
7172 7      i=i+1
7173        ityp=itypr0(i)
7174        if(ityp.eq.0.or.ityp.eq.2.or.ityp.eq.4)then
7175         ipp=ippr0(i)
7176         bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
7177         vvxp=0.d0
7178         vvxpl=0.d0
7179         vvxp0=0.d0
7180         if(ia(1).gt.1)then
7181          do l=1,ia(1)
7182           if(l.lt.ipp)then
7183            vvxpl=vvxpl+vpac(l)
7184           elseif(l.gt.ipp)then
7185            vvxp=vvxp+vpac(l)
7186            vvxp0=vvxp0+vpac0(l)
7187           endif
7188          enddo
7189         endif
7190         vvxp=1.d0-exp(-vvxp)
7191         vvxpl=1.d0-exp(-vvxpl)
7192         vvxp0=1.d0-exp(-vvxp0)
7193         vvxts=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*(1.d0-vvxpl)*exp(-vtac(it))
7194         if(ityp.ne.4)then
7195          vpacng=min(vpac0(ipp)
7196      *   ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,4))
7197          vpacpe=min(vpacng
7198      *   ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,5))
7199          vplcp=min(vpacpe
7200      *   ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
7201         else
7202          vplcng=min(vpac0(ipp)
7203      *   ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,11))
7204          vplcpe=min(vplcng
7205      *   ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,10))
7206          vplcp=min(vplcpe
7207      *   ,qgfani(1.d0/xpomr,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
7208         endif
7209 
7210         if(ityp.eq.0)then
7211          aks=qgran(b10)*vpac0(ipp)
7212          if(aks.le.vplcp.or.xpomr*sgap**2.gt..9d0)then
7213           itypr0(i)=6        !single cut Pomeron
7214          elseif(aks.lt.vpacpe)then
7215           itypr0(i)=-1       !'fan' (cut Pomeron end)
7216          elseif(aks.lt.vpacng)then
7217           itypr0(i)=2        !'fan' (>1 cut Poms at the end)
7218          endif
7219         elseif(ityp.eq.2)then
7220          aks=qgran(b10)*vpacng
7221          if(aks.le.vplcp.or.xpomr*sgap**2.gt..9d0)then
7222           itypr0(i)=6        !single cut Pomeron
7223          elseif(aks.lt.vpacpe)then
7224           itypr0(i)=-1       !'fan' (cut Pomeron end)
7225          endif
7226         elseif(ityp.eq.4)then
7227          aks=qgran(b10)*vplcng
7228          if(aks.le.vplcp.or.xpomr*sgap**2.gt..9d0)then
7229           itypr0(i)=6        !single cut Pomeron
7230          elseif(aks.gt.vplcpe.or.xpomr*sgap**3.gt..9d0)then
7231           itypr0(i)=7        !'leg' (>1 cut Poms at the end)
7232          endif
7233         endif
7234 
7235         if(itypr0(i).eq.6)then        !single cut Pomeron
7236          nppr=nppr+1
7237          xpompi(nppr)=xpomr
7238          vvxpi(nppr)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
7239      *   *(1.d0-vvxtl)*exp(-vtac(it))
7240          ipompi(nppr)=ipp
7241          bpompi(nppr)=bbp
7242          if(debug.ge.4)write (moniou,209)nppr,ipp,bbp,xpompi(nppr)
7243      *   ,vvxpi(nppr)
7244          nppr0=nppr0-1
7245          if(nppr0.ge.i)then
7246           do l=i,nppr0
7247            ippr0(l)=ippr0(l+1)
7248            itypr0(l)=itypr0(l+1)
7249           enddo
7250          endif
7251          i=i-1
7252         endif
7253        endif
7254        if(i.lt.nppr0)goto 7
7255       endif
7256 
7257       vvxp=vvxps
7258       vvxpl=vvxpls
7259       vvxp0=vvxp0s
7260       vvxts=vvxt
7261       vvxtls=vvxtl
7262       vvxt0s=vvxt0
7263       if(nptg0.ne.0)then
7264        i=0
7265 8      i=i+1
7266        ityt=itytg0(i)
7267        if(ityt.eq.0.or.ityt.eq.2.or.ityt.eq.4)then
7268         itt=iptg0(i)
7269         bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
7270         vvxt=0.d0
7271         vvxtl=0.d0
7272         vvxt0=0.d0
7273         if(ia(2).gt.1)then
7274          do l=1,ia(2)
7275           if(l.lt.itt)then
7276            vvxtl=vvxtl+vtac(l)
7277           elseif(l.gt.itt)then
7278            vvxt=vvxt+vtac(l)
7279            vvxt0=vvxt0+vtac0(l)
7280           endif
7281          enddo
7282         endif
7283         vvxt=1.d0-exp(-vvxt)
7284         vvxtl=1.d0-exp(-vvxtl)
7285         vvxt0=1.d0-exp(-vvxt0)
7286         vvxps=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxtl)*exp(-vpac(ip))
7287         if(ityt.ne.4)then
7288          vtacng=min(vtac0(itt)
7289      *   ,qgfani(xpomr*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,4))
7290          vtacpe=min(vtacng
7291      *   ,qgfani(xpomr*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,5))
7292          vtlcp=min(vtacpe
7293      *   ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
7294         else
7295          vtlcng=min(vtac0(itt)
7296      *   ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,11))
7297          vtlcpe=min(vtlcng
7298      *   ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,10))
7299          vtlcp=min(vtlcpe
7300      *   ,qgfani(xpomr*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
7301         endif
7302 
7303         if(ityt.eq.0)then
7304          aks=qgran(b10)*vtac0(itt)
7305          if(aks.le.vtlcp.or.xpomr*scm.lt.1.1d0*sgap**2)then
7306           itytg0(i)=6        !single cut Pomeron
7307          elseif(aks.lt.vtacpe)then
7308           itytg0(i)=-1       !'fan' (cut Pomeron end)
7309          elseif(aks.lt.vtacng)then
7310           itytg0(i)=2        !'fan' (>1 cut Poms at the end)
7311          endif
7312         elseif(ityt.eq.2)then
7313          aks=qgran(b10)*vtacng
7314          if(aks.le.vtlcp.or.xpomr*scm.lt.1.1d0*sgap**2)then
7315           itytg0(i)=6        !single cut Pomeron
7316          elseif(aks.lt.vtacpe)then
7317           itytg0(i)=-1       !'fan' (cut Pomeron end)
7318          endif
7319         elseif(ityt.eq.4)then
7320          aks=qgran(b10)*vtlcng
7321          if(aks.le.vtlcp.or.xpomr*scm.lt.1.1d0*sgap**2)then
7322           itytg0(i)=6
7323          elseif(aks.gt.vtlcpe.or.xpomr*scm.lt.1.1d0*sgap**3)then
7324           itytg0(i)=7        !'leg' (>1 cut Poms at the end)
7325          endif
7326         endif
7327 
7328         if(itytg0(i).eq.6)then        !single cut Pomeron
7329          nptg=nptg+1
7330          xpomti(nptg)=xpomr
7331          vvxti(nptg)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
7332      *   *(1.d0-vvxtl)*exp(-vpac(ip))
7333          ipomti(nptg)=itt
7334          bpomti(nptg)=bbt
7335          if(debug.ge.4)write (moniou,217)nptg,itt,bbt,xpomti(nptg)
7336      *   ,vvxti(nptg)
7337          nptg0=nptg0-1
7338          if(nptg0.ge.i)then
7339           do l=i,nptg0
7340            iptg0(l)=iptg0(l+1)
7341            itytg0(l)=itytg0(l+1)
7342           enddo
7343          endif
7344          i=i-1
7345         endif
7346        endif
7347        if(i.lt.nptg0)goto 8
7348       endif
7349       vvxt=vvxts
7350       vvxtl=vvxtls
7351       vvxt0=vvxt0s
7352 
7353       if((jt-1)*(jt-4)*(jt-7).eq.0.and.xpomr*sgap**2.lt..9d0)then
7354        vvxts=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7355        vvxt0s=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
7356        vvxs=((1.d0-vvxp)*(1.d0-vvxpl))**2*exp(-2.d0*vpac(ip))
7357        vvx0s=((1.d0-vvxp0)*(1.d0-vvxp0l))**2*exp(-2.d0*vpac0(ip))
7358 
7359        wzzp=2.d0*qgrevi(1.d0/xpomr,bbpr,vvxt0s,vvxts
7360      * ,vvxpt,vvxp0,vvxpl,iddp(ip),icz)
7361      * *((1.d0-exp(-vtact(it)))*(1.d0-vvxtt)*(1.d0-vvxs)
7362      * +vvxs*(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))
7363      * *(1.d0-vvxtt)
7364      * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0))
7365      * +vtact(it)*exp(-vtact(it))*((1.d0-vvxtt)*vvxs
7366      * -exp(vtact(it)-vtac0(it))*(1.d0-vvxt0)*(1.d0-vvxt0l)*vvx0s)
7367      * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0)
7368      * *(vvxs-vvx0s+vvxt0l*vvx0s))
7369        wzzp=max(0.d0,wzzp)
7370        nzzp=npgen(wzzp/(vv(1)+vv(4)+vv(7)),0,50)
7371       else
7372        nzzp=0
7373       endif
7374 
7375       if((jt-1)*(jt-3)*(jt-8).eq.0.and.xpomr*scm.gt.1.1d0*sgap**2)then
7376        vvxps=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7377        vvxp0s=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
7378        vvxs=((1.d0-vvxt)*(1.d0-vvxtl))**2*exp(-2.d0*vtac(it))
7379        vvx0s=((1.d0-vvxt0)*(1.d0-vvxt0l))**2*exp(-2.d0*vtac0(it))
7380        wzzt=2.d0*qgrevi(xpomr*scm,bbtg,vvxp0s,vvxps
7381      * ,vvxtt,vvxt0,vvxtl,iddt(it),2)
7382      * *((1.d0-exp(-vpact(ip)))*(1.d0-vvxpt)*(1.d0-vvxs)
7383      * +vvxs*(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))
7384      * *(1.d0-vvxpt)
7385      * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0))
7386      * +vpact(ip)*exp(-vpact(ip))*((1.d0-vvxpt)*vvxs
7387      * -exp(vpact(ip)-vpac0(ip))*(1.d0-vvxp0)*(1.d0-vvxp0l)*vvx0s)
7388      * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0)
7389      * *(vvxs-vvx0s+vvxp0l*vvx0s))
7390        wzzt=max(0.d0,wzzt)
7391        nzzt=npgen(wzzt/(vv(1)+vv(3)+vv(8)),0,50)
7392       else
7393        nzzt=0
7394       endif
7395 
7396       if(nzzp.ne.0)then
7397        bpm=(xa(ip,1)+b-xxp)**2+(xa(ip,2)-yyp)**2
7398        xpomr0=min(dsqrt(xpomr),1.d0/sgap)
7399        xpomr0=max(xpomr0,xpomr*sgap)
7400        rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomr0))*4.d0*.0389d0
7401        rp2=alfp*dlog(xpomr0/xpomr)*4.d0*.0389d0
7402        rp0=rp1*rp2/(rp1+rp2)
7403        bbp=bpm*(rp1/(rp1+rp2))**2
7404        bbi=bpm*(rp2/(rp1+rp2))**2
7405        call qgbdef(bbp,bbi,xa(ip,1)+b,xa(ip,2),xxp,yyp,xxp0,yyp0,1)
7406        call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac,vvx,vvxp,vvxt
7407      * ,vvxpl,vvxtl,ip,it)
7408 
7409        sumcp0=0.d0
7410        sumcpt=0.d0
7411        sumup=0.d0
7412        vvxp0=0.d0
7413        vvxp0l=0.d0
7414        do i=1,ia(1)
7415         sumup=sumup+vpac(i)
7416        enddo
7417        vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7418        do i=1,ia(1)
7419         ipp=ia(1)-i+1
7420         bbpi=(xa(ipp,1)+b-xxp0)**2+(xa(ipp,2)-yyp0)**2
7421         sumup=sumup-vpac(ipp)
7422         vpac0(ipp)=min(vpac(ipp)
7423      *  ,qgfani(1.d0/xpomr0,bbpi,1.d0-vvxs*exp(-sumup)
7424      *  ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7425         if(ipp.ge.ip)vpact(ipp)=max(vpac(ipp)
7426      *  ,qgfani(1.d0/xpomr0,bbpi,1.d0-vvxs*exp(-sumup)
7427      *  ,1.d0-exp(-sumcpt),1.d0-exp(-sumup),iddp(ipp),icz,6))
7428         if(ipp.gt.ip)then
7429          vvxp0=vvxp0+vpac0(ipp)
7430          sumcpt=sumcpt+vpact(ipp)
7431         elseif(ipp.lt.ip)then
7432          vvxp0l=vvxp0l+vpac0(ipp)
7433         endif
7434         sumcp0=sumcp0+vpac0(ipp)
7435        enddo
7436        vvxpt=1.d0-exp(-sumcpt)
7437        vvxp0=1.d0-exp(-vvxp0)
7438        vvxp0l=1.d0-exp(-vvxp0l)
7439 
7440        sumut=0.d0
7441        sumct0=0.d0
7442        vvxt0=0.d0
7443        vvxt0l=0.d0
7444        do i=1,ia(2)
7445         sumut=sumut+vtac(i)
7446        enddo
7447        vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7448        do i=1,ia(2)
7449         itt=ia(2)-i+1
7450         bbti=(xb(itt,1)-xxp0)**2+(xb(itt,2)-yyp0)**2
7451         sumut=sumut-vtac(itt)
7452         vtac0(itt)=min(vtac(itt)
7453      *  ,qgfani(xpomr0*scm,bbti,1.d0-vvxs*exp(-sumut)
7454      *  ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
7455         if(itt.gt.it)then
7456          vvxt0=vvxt0+vtac0(itt)
7457         elseif(itt.lt.it)then
7458         vvxt0l=vvxt0l+vtac0(itt)
7459         endif
7460         sumct0=sumct0+vtac0(itt)
7461        enddo
7462        vvxt0=1.d0-exp(-vvxt0)
7463        vvxt0l=1.d0-exp(-vvxt0l)
7464 
7465        viu=qgpini(xpomr0/xpomr,bbi,0.d0,0.d0,2)
7466        vim=2.d0*min(viu,qgpini(xpomr0/xpomr,bbi,0.d0,0.d0,8))
7467        vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
7468        vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
7469        vi=qgpini(xpomr0/xpomr,bbi,vvxpin,vvxtin,21)*(1.d0-exp(-viu))
7470      * -qgpini(xpomr0/xpomr,bbi,vvxpin,vvxtin,23)*((1.d0-exp(-viu))**2
7471      * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
7472 
7473        vvx0s=(1.d0-vvxtin)**2
7474        vvxs=((1.d0-vvxt)*(1.d0-vvxtl))**2*exp(-2.d0*vtac(it))
7475 
7476        gb0=vi                        *15.
7477      * *((1.d0-exp(-vpact(ip)))*(1.d0-vvxpt)*(1.d0-vvxs)
7478      * +vvxs*(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))
7479      * *(1.d0-vvxpt)
7480      * -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0))
7481      * +vpact(ip)*exp(-vpact(ip))*((1.d0-vvxpt)*vvxs
7482      * -exp(vpact(ip)-vpac0(ip))*(1.d0-vvxp0)*(1.d0-vvxp0l)*vvx0s)
7483      * -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0)
7484      * *(vvxs-vvx0s+vvxp0l*vvx0s))
7485 
7486        do in=1,nzzp
7487         nrej=0
7488 32      xpomri=(xpomr*sgap**2)**qgran(b10)/sgap
7489         rp1=(rq(iddp(ip),icz)-alfp*dlog(xpomri))*4.d0*.0389d0
7490         rp2=alfp*dlog(xpomri/xpomr)*4.d0*.0389d0
7491         rp=rp1*rp2/(rp1+rp2)
7492         z=qgran(b10)
7493         phi=pi*qgran(b10)
7494         b0=dsqrt(-rp*dlog(z))
7495         bbp=(dsqrt(bpm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
7496         bbi=(dsqrt(bpm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
7497         call qgbdef(bbp,bbi,xa(ip,1)+b,xa(ip,2),xxp,yyp
7498      *  ,xxi,yyi,int(1.5d0+qgran(b10)))   !coordinates for the vertex
7499         call qgfdf(xxi,yyi,xpomri,vpac,vtac
7500      *  ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
7501 
7502         sumcp0=0.d0
7503         sumcpt=0.d0
7504         sumup=0.d0
7505         vvxp0=0.d0
7506         vvxp0l=0.d0
7507         do i=1,ia(1)
7508          sumup=sumup+vpac(i)
7509         enddo
7510         vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7511         do i=1,ia(1)
7512          ipp=ia(1)-i+1
7513          bbpi=(xa(ipp,1)+b-xxi)**2+(xa(ipp,2)-yyi)**2
7514          sumup=sumup-vpac(ipp)
7515          vpac0(ipp)=min(vpac(ipp)
7516      *   ,qgfani(1.d0/xpomri,bbpi,1.d0-vvxs*exp(-sumup)
7517      *   ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7518          if(ipp.ge.ip)vpact(ipp)=max(vpac(ipp)
7519      *   ,qgfani(1.d0/xpomri,bbpi,1.d0-vvxs*exp(-sumup)
7520      *   ,1.d0-exp(-sumcpt),1.d0-exp(-sumup),iddp(ipp),icz,6))
7521          if(ipp.gt.ip)then
7522           vvxp0=vvxp0+vpac0(ipp)
7523           sumcpt=sumcpt+vpact(ipp)
7524          elseif(ipp.lt.ip)then
7525           vvxp0l=vvxp0l+vpac0(ipp)
7526          endif
7527          sumcp0=sumcp0+vpac0(ipp)
7528         enddo
7529         vvxpt=1.d0-exp(-sumcpt)
7530         vvxp0=1.d0-exp(-vvxp0)
7531         vvxp0l=1.d0-exp(-vvxp0l)
7532 
7533         sumut=0.d0
7534         sumct0=0.d0
7535         vvxt0=0.d0
7536         vvxt0l=0.d0
7537         do i=1,ia(2)
7538          sumut=sumut+vtac(i)
7539         enddo
7540         vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7541         do i=1,ia(2)
7542          itt=ia(2)-i+1
7543          bbti=(xb(itt,1)-xxi)**2+(xb(itt,2)-yyi)**2
7544          sumut=sumut-vtac(itt)
7545          vtac0(itt)=min(vtac(itt)
7546      *   ,qgfani(xpomri*scm,bbti,1.d0-vvxs*exp(-sumut)
7547      *   ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
7548          if(itt.gt.it)then
7549           vvxt0=vvxt0+vtac0(itt)
7550          elseif(itt.lt.it)then
7551           vvxt0l=vvxt0l+vtac0(itt)
7552          endif
7553          sumct0=sumct0+vtac0(itt)
7554         enddo
7555         vvxt0=1.d0-exp(-vvxt0)
7556         vvxt0l=1.d0-exp(-vvxt0l)
7557 
7558         viu=qgpini(xpomri/xpomr,bbi,0.d0,0.d0,2)
7559         vim=2.d0*min(viu,qgpini(xpomri/xpomr,bbi,0.d0,0.d0,8))
7560         vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
7561         vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
7562         vi=qgpini(xpomri/xpomr,bbi,vvxpin,vvxtin,21)*(1.d0-exp(-viu))
7563      *  -qgpini(xpomri/xpomr,bbi,vvxpin,vvxtin,23)*((1.d0-exp(-viu))**2
7564      *  +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
7565 
7566         vvx0s=(1.d0-vvxtin)**2
7567         vvxs=((1.d0-vvxt)*(1.d0-vvxtl))**2*exp(-2.d0*vtac(it))
7568 
7569         gb=vi
7570      *  *((1.d0-exp(-vpact(ip)))*(1.d0-vvxpt)*(1.d0-vvxs)
7571      *  +vvxs*(max(0.d0,1.d0-exp(-vpact(ip))*(1.d0+vpact(ip)))
7572      *  *(1.d0-vvxpt)
7573      *  -max(0.d0,1.d0-exp(-vpac0(ip))*(1.d0+vpac0(ip)))*(1.d0-vvxp0))
7574      *  +vpact(ip)*exp(-vpact(ip))*((1.d0-vvxpt)*vvxs
7575      *  -exp(vpact(ip)-vpac0(ip))*(1.d0-vvxp0)*(1.d0-vvxp0l)*vvx0s)
7576      *  -vpac0(ip)*exp(-vpac0(ip))*(1.d0-vvxp0)
7577      *  *(vvxs-vvx0s+vvxp0l*vvx0s))
7578 
7579         gb=gb/gb0/z*rp/rp0
7580         nrej=nrej+1
7581         if(qgran(b10).gt.gb.and.nrej.lt.10000)goto 32
7582 
7583         vi1p=qgpini(xpomri/xpomr,bbi,1.d0-(1.d0-vvxpin)**2*vvx0s
7584      *  ,0.d0,16)*exp(-vim)
7585         vimp=max(0.d0,(1.d0-exp(-vim)*(1.d0+vim)))/2.d0
7586 
7587         if(qgran(b10).le.(vi1p+vimp)/vi
7588      *  .or.xpomri/xpomr.lt.1.1d0*sgap**2)then
7589          if(qgran(b10).le.vi1p/(vi1p+vimp))then   !single cut Pomeron
7590           npin=npin+1
7591           if(npin.gt.npmax)then
7592            iret=1
7593            goto 31
7594           endif
7595           xpomim(npin)=1.d0/xpomr/scm
7596           xpomip(npin)=xpomri
7597           vvxim(npin)=1.d0-(1.d0-vvxpin)**2*vvx0s
7598           bpomim(npin)=bbi
7599           if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
7600      *    ,xpomim(npin),vvxim(npin),bpomim(npin)
7601          else                                     !more than 1 cut Pomeron
7602           ninc=npgen(vim,2,20)
7603           npin=npin+ninc
7604           if(npin.gt.npmax)then
7605            iret=1
7606            goto 31
7607           endif
7608           do i=npin-ninc+1,npin
7609            xpomim(i)=1.d0/xpomr/scm
7610            xpomip(i)=xpomri
7611            vvxim(i)=0.d0
7612            bpomim(i)=bbi
7613            if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
7614      *     ,vvxim(i),bpomim(i)
7615           enddo
7616          endif
7617 
7618         else                                      !additional vertices
7619          xpomz0=dsqrt(xpomr*xpomri)
7620          rp0=alfp*dlog(xpomri/xpomr)*.0389d0
7621          xxz0=.5d0*(xxp+xxi)
7622          yyz0=.5d0*(yyp+yyi)
7623          bbzp=.25d0*bbi
7624          bbzt=bbzp
7625          call qgfdf(xxz0,yyz0,xpomz0,vpac,vtac,vvx,vvxp,vvxt
7626      *   ,vvxpl,vvxtl,ip,it)
7627 
7628          vvxp0=0.d0
7629          sumup=0.d0
7630          do i=1,ia(1)
7631           sumup=sumup+vpac(i)
7632          enddo
7633          vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7634          do i=1,ia(1)
7635           ipp=ia(1)-i+1
7636           bbpi=(xa(ipp,1)+b-xxz0)**2+(xa(ipp,2)-yyz0)**2
7637           sumup=sumup-vpac(ipp)
7638           vpac0(ipp)=min(vpac(ipp)
7639      *    ,qgfani(1.d0/xpomz0,bbpi,1.d0-vvxs*exp(-sumup)
7640      *    ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7641           vvxp0=vvxp0+vpac0(ipp)
7642          enddo
7643          vvxp0=1.d0-exp(-vvxp0)
7644 
7645          sumut=0.d0
7646          vvxt0=0.d0
7647          do i=1,ia(2)
7648           sumut=sumut+vtac(i)
7649          enddo
7650          vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7651          do i=1,ia(2)
7652           itt=ia(2)-i+1
7653           bbti=(xb(itt,1)-xxz0)**2+(xb(itt,2)-yyz0)**2
7654           sumut=sumut-vtac(itt)
7655           vtac0(itt)=min(vtac(itt)
7656      *    ,qgfani(xpomz0*scm,bbti,1.d0-vvxs*exp(-sumut)
7657      *    ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
7658           vvxt0=vvxt0+vtac0(itt)
7659          enddo
7660          vvxt0=1.d0-exp(-vvxt0)
7661 
7662          viu=qgpini(xpomri/xpomz0,bbzp,0.d0,0.d0,2)
7663          vilu=1.d0-exp(-viu)
7664          vimu=2.d0*min(viu,qgpini(xpomri/xpomz0,bbzp,0.d0,0.d0,8))
7665          vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
7666          vid=qgpini(xpomz0/xpomr,bbzt,0.d0,0.d0,2)
7667          vild=1.d0-exp(-vid)
7668          vimd=2.d0*min(vid,qgpini(xpomz0/xpomr,bbzt,0.d0,0.d0,8))
7669          vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
7670 
7671          vi1pu=qgpini(xpomri/xpomz0,bbzp
7672      *   ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
7673          vguu=qgpini(xpomri/xpomz0,bbzp,vvxp0,vvxt0,21)*vilu      !uu+uc
7674          vgcu=qgpini(xpomri/xpomz0,bbzp,vvxp0,vvxt0,23)
7675      *   *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
7676          vi1pd=qgpini(xpomz0/xpomr,bbzt
7677      *   ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
7678          vgud=qgpini(xpomz0/xpomr,bbzt,vvxt0,vvxp0,21)*vild       !uu+uc
7679          vgcd=qgpini(xpomz0/xpomr,bbzt,vvxt0,vvxp0,23)
7680      *   *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
7681 
7682          gbz0=(vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd
7683      *   +vgcu*vimpd+vi1pu*vgcd+vgcu*vi1pd)*(1.d0-vvxp0)*(1.d0-vvxt0)
7684      *   +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
7685      *   +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
7686 
7687          nrej=0
7688 34       xpomz=xpomr*sgap*(xpomri/xpomr/sgap**2)**qgran(b10)
7689          rpp=alfp*dlog(xpomri/xpomz)*4.d0*.0389d0
7690          rpt=alfp*dlog(xpomz/xpomr)*4.d0*.0389d0
7691          rp=rpp*rpt/(rpp+rpt)
7692          z=qgran(b10)
7693          phi=pi*qgran(b10)
7694          b0=dsqrt(-rp*dlog(z))
7695          bbzp=(dsqrt(bbi)*rpp/(rpp+rpt)+b0*cos(phi))**2
7696      *   +(b0*sin(phi))**2
7697          bbzt=(dsqrt(bbi)*rpt/(rpp+rpt)-b0*cos(phi))**2
7698      *   +(b0*sin(phi))**2
7699          call qgbdef(bbzp,bbzt,xxi,yyi,xxp,yyp,xxz,yyz
7700      *   ,int(1.5d0+qgran(b10)))               !coordinates for the vertex
7701          call qgfdf(xxz,yyz,xpomz,vpac,vtac
7702      *   ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
7703 
7704          vvxp0=0.d0
7705          sumup=0.d0
7706          do i=1,ia(1)
7707           sumup=sumup+vpac(i)
7708          enddo
7709          vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7710          do i=1,ia(1)
7711           ipp=ia(1)-i+1
7712           bbpi=(xa(ipp,1)+b-xxz)**2+(xa(ipp,2)-yyz)**2
7713           sumup=sumup-vpac(ipp)
7714           vpac0(ipp)=min(vpac(ipp)
7715      *    ,qgfani(1.d0/xpomz,bbpi,1.d0-vvxs*exp(-sumup)
7716      *    ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7717           vvxp0=vvxp0+vpac0(ipp)
7718          enddo
7719          vvxp0=1.d0-exp(-vvxp0)
7720 
7721          sumut=0.d0
7722          vvxt0=0.d0
7723          do i=1,ia(2)
7724           sumut=sumut+vtac(i)
7725          enddo
7726          vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7727          do i=1,ia(2)
7728           itt=ia(2)-i+1
7729           bbti=(xb(itt,1)-xxz)**2+(xb(itt,2)-yyz)**2
7730           sumut=sumut-vtac(itt)
7731           vtac0(itt)=min(vtac(itt)
7732      *    ,qgfani(xpomz*scm,bbti,1.d0-vvxs*exp(-sumut)
7733      *    ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
7734           vvxt0=vvxt0+vtac0(itt)
7735          enddo
7736          vvxt0=1.d0-exp(-vvxt0)
7737 
7738          viu=qgpini(xpomri/xpomz,bbzp,0.d0,0.d0,2)
7739          vilu=1.d0-exp(-viu)
7740          vimu=2.d0*min(viu,qgpini(xpomri/xpomz,bbzp,0.d0,0.d0,8))
7741          vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
7742          vid=qgpini(xpomz/xpomr,bbzt,0.d0,0.d0,2)
7743          vild=1.d0-exp(-vid)
7744          vimd=2.d0*min(vid,qgpini(xpomz/xpomr,bbzt,0.d0,0.d0,8))
7745          vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
7746 
7747          vi1pu=qgpini(xpomri/xpomz,bbzp
7748      *   ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
7749          vguu=qgpini(xpomri/xpomz,bbzp,vvxp0,vvxt0,21)*vilu       !uu+uc
7750          vgcu=qgpini(xpomri/xpomz,bbzp,vvxp0,vvxt0,23)
7751      *   *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
7752          vi1pd=qgpini(xpomz/xpomr,bbzt
7753      *   ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
7754          vgud=qgpini(xpomz/xpomr,bbzt,vvxt0,vvxp0,21)*vild        !uu+uc
7755          vgcd=qgpini(xpomz/xpomr,bbzt,vvxt0,vvxp0,23)
7756      *   *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
7757 
7758          vvcc=vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd+vgcu*vimpd
7759      *   +vi1pu*vgcd+vgcu*vi1pd
7760          vvt=vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
7761      *   +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
7762      *   +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
7763 
7764          gbz=vvt/gbz0/z*rp/rp0  /1.4d0
7765          nrej=nrej+1
7766          if(qgran(b10).gt.gbz.and.nrej.lt.10000)goto 34
7767 
7768          aks=vvt*qgran(b10)
7769          if(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
7770      *   +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0)then
7771           jtu=0
7772           if(qgran(b10).lt.vimpd/(vimpd+vi1pd))then
7773            jtd=2
7774           else
7775            jtd=1
7776           endif
7777          elseif(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0))then
7778           jtd=0
7779           if(qgran(b10).lt.vimpu/(vimpu+vi1pu))then
7780            jtu=2
7781           else
7782            jtu=1
7783           endif
7784          else
7785           aks=vvcc*qgran(b10)
7786           if(aks.lt.vimpu*vimpd)then
7787            jtu=2
7788            jtd=2
7789           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd)then
7790            jtu=2
7791            jtd=1
7792           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd)then
7793            jtu=1
7794            jtd=2
7795           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
7796      *    +vimpu*vgcd)then
7797            jtu=2
7798            jtd=0
7799           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
7800      *    +vimpu*vgcd+vgcu*vimpd)then
7801            jtu=0
7802            jtd=2
7803           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
7804      *    +vimpu*vgcd+vgcu*vimpd+vi1pu*vgcd)then
7805            jtu=1
7806            jtd=0
7807           else
7808            jtu=0
7809            jtd=1
7810           endif
7811          endif
7812 
7813          if(jtu.eq.1)then                         !single cut Pomeron
7814           npin=npin+1
7815           if(npin.gt.npmax)then
7816            iret=1
7817            goto 31
7818           endif
7819           xpomim(npin)=1.d0/xpomz/scm
7820           xpomip(npin)=xpomri
7821           vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
7822           bpomim(npin)=bbzp
7823           if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
7824      *    ,xpomim(npin),vvxim(npin),bpomim(npin)
7825          elseif(jtu.eq.2)then                     !more than 1 cut Pomeron
7826           ninc=npgen(vimu,2,20)
7827           npin=npin+ninc
7828           if(npin.gt.npmax)then
7829            iret=1
7830            goto 31
7831           endif
7832           do i=npin-ninc+1,npin
7833            xpomim(i)=1.d0/xpomz/scm
7834            xpomip(i)=xpomri
7835            vvxim(i)=0.d0
7836            bpomim(i)=bbzp
7837            if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
7838      *     ,vvxim(i),bpomim(i)
7839           enddo
7840          endif
7841 
7842          if(jtd.eq.1)then                         !single cut Pomeron
7843           npin=npin+1
7844           if(npin.gt.npmax)then
7845            iret=1
7846            goto 31
7847           endif
7848           xpomim(npin)=1.d0/xpomr/scm
7849           xpomip(npin)=xpomz
7850           vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
7851           bpomim(npin)=bbzt
7852           if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
7853      *    ,xpomim(npin),vvxim(npin),bpomim(npin)
7854          elseif(jtu.eq.2)then                     !more than 1 cut Pomeron
7855           ninc=npgen(vimd,2,20)
7856           npin=npin+ninc
7857           if(npin.gt.npmax)then
7858            iret=1
7859            goto 31
7860           endif
7861           do i=npin-ninc+1,npin
7862            xpomim(i)=1.d0/xpomr/scm
7863            xpomip(i)=xpomz
7864            vvxim(i)=0.d0
7865            bpomim(i)=bbzt
7866            if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
7867      *     ,vvxim(i),bpomim(i)
7868           enddo
7869          endif
7870         endif
7871        enddo          !end of the zigzag-loop
7872       endif           !nzzp.ne.0
7873 
7874       if(nzzt.ne.0)then
7875        btm=(xb(it,1)-xxp)**2+(xb(it,2)-yyp)**2
7876        xpomr0=max(dsqrt(xpomr/scm),sgap/scm)
7877        xpomr0=min(xpomr0,xpomr/sgap)
7878        rp1=(rq(iddt(it),2)+alfp*dlog(xpomr0*scm))*4.d0*.0389d0
7879        rp2=alfp*dlog(xpomr/xpomr0)*4.d0*.0389d0
7880        rp0=rp1*rp2/(rp1+rp2)
7881        bbt=btm*(rp1/(rp1+rp2))**2
7882        bbi=btm*(rp2/(rp1+rp2))**2
7883        call qgbdef(bbt,bbi,xb(it,1),xb(it,2),xxp,yyp,xxp0,yyp0,1)
7884        call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac
7885      * ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
7886 
7887        sumct0=0.d0
7888        sumctt=0.d0
7889        sumut=0.d0
7890        vvxt0=0.d0
7891        vvxt0l=0.d0
7892        do i=1,ia(2)
7893         sumut=sumut+vtac(i)
7894        enddo
7895        vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7896        do i=1,ia(2)
7897         itt=ia(2)-i+1
7898         bbti=(xb(itt,1)-xxp0)**2+(xb(itt,2)-yyp0)**2
7899         sumut=sumut-vtac(itt)
7900         vtac0(itt)=min(vtac(itt)
7901      *  ,qgfani(xpomr0*scm,bbti,1.d0-vvxs*exp(-sumut)
7902      *  ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
7903         if(itt.ge.it)vtact(itt)=max(vtac(itt)
7904      *  ,qgfani(xpomr0*scm,bbti,1.d0-vvxs*exp(-sumut)
7905      *  ,1.d0-exp(-sumctt),1.d0-exp(-sumut),iddt(itt),2,6))
7906         if(itt.gt.it)then
7907          vvxt0=vvxt0+vtac0(itt)
7908          sumctt=sumctt+vtact(itt)
7909         elseif(itt.lt.it)then
7910          vvxt0l=vvxt0l+vtac0(itt)
7911         endif
7912         sumct0=sumct0+vtac0(itt)
7913        enddo
7914        vvxtt=1.d0-exp(-sumctt)
7915        vvxt0=1.d0-exp(-vvxt0)
7916        vvxt0l=1.d0-exp(-vvxt0l)
7917 
7918        sumcp0=0.d0
7919        sumup=0.d0
7920        vvxp0=0.d0
7921        vvxp0l=0.d0
7922        do i=1,ia(1)
7923         sumup=sumup+vpac(i)
7924        enddo
7925        vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
7926        do i=1,ia(1)
7927         ipp=ia(1)-i+1
7928         bbpi=(xa(ipp,1)+b-xxp0)**2+(xa(ipp,2)-yyp0)**2
7929         sumup=sumup-vpac(ipp)
7930         vpac0(ipp)=min(vpac(ipp)
7931      *  ,qgfani(1.d0/xpomr0,bbpi,1.d0-vvxs*exp(-sumup)
7932      *  ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
7933         if(ipp.gt.ip)then
7934          vvxp0=vvxp0+vpac0(ipp)
7935         elseif(ipp.lt.ip)then
7936          vvxp0l=vvxp0l+vpac0(ipp)
7937         endif
7938         sumcp0=sumcp0+vpac0(ipp)
7939        enddo
7940        vvxp0=1.d0-exp(-vvxp0)
7941        vvxp0l=1.d0-exp(-vvxp0l)
7942 
7943        viu=qgpini(xpomr/xpomr0,bbi,0.d0,0.d0,2)
7944        vim=2.d0*min(viu,qgpini(xpomr/xpomr0,bbi,0.d0,0.d0,8))
7945        vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
7946        vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
7947        vi=qgpini(xpomr/xpomr0,bbi,vvxtin,vvxpin,21)*(1.d0-exp(-viu))
7948      * -qgpini(xpomr/xpomr0,bbi,vvxtin,vvxpin,23)*((1.d0-exp(-viu))**2
7949      * +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
7950 
7951        vvx0s=(1.d0-vvxpin)**2
7952        vvxs=((1.d0-vvxp)*(1.d0-vvxpl))**2*exp(-2.d0*vpac(ip))
7953 
7954        gb0=vi                      *15.
7955      * *((1.d0-exp(-vtact(it)))*(1.d0-vvxtt)*(1.d0-vvxs)
7956      * +vvxs*(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))
7957      * *(1.d0-vvxtt)
7958      * -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0))
7959      * +vtact(it)*exp(-vtact(it))*((1.d0-vvxtt)*vvxs
7960      * -exp(vtact(it)-vtac0(it))*(1.d0-vvxt0)*(1.d0-vvxt0l)*vvx0s)
7961      * -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0)
7962      * *(vvxs-vvx0s+vvxt0l*vvx0s))
7963 
7964        do in=1,nzzt
7965         nrej=0
7966 33      xpomri=xpomr/sgap/(xpomr*scm/sgap**2)**qgran(b10)
7967         rp1=(rq(iddt(it),2)+alfp*dlog(xpomri*scm))*4.d0*.0389d0
7968         rp2=alfp*dlog(xpomr/xpomri)*4.d0*.0389d0
7969         rp=rp1*rp2/(rp1+rp2)
7970         z=qgran(b10)
7971         phi=pi*qgran(b10)
7972         b0=dsqrt(-rp*dlog(z))
7973         bbt=(dsqrt(btm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
7974         bbi=(dsqrt(btm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
7975         call qgbdef(bbt,bbi,xb(it,1),xb(it,2),xxp,yyp,xxi,yyi
7976      *  ,int(1.5d0+qgran(b10)))   !coordinates for the vertex
7977         call qgfdf(xxi,yyi,xpomri,vpac,vtac
7978      *  ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
7979 
7980         sumct0=0.d0
7981         sumctt=0.d0
7982         sumut=0.d0
7983         vvxt0=0.d0
7984         vvxt0l=0.d0
7985         do i=1,ia(2)
7986          sumut=sumut+vtac(i)
7987         enddo
7988         vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
7989         do i=1,ia(2)
7990          itt=ia(2)-i+1
7991          bbti=(xb(itt,1)-xxi)**2+(xb(itt,2)-yyi)**2
7992          sumut=sumut-vtac(itt)
7993          vtac0(itt)=min(vtac(itt)
7994      *   ,qgfani(xpomri*scm,bbti,1.d0-vvxs*exp(-sumut)
7995      *   ,1.d0-exp(-sumct0),1.d0-exp(-sumut),iddt(itt),2,3))
7996          if(itt.ge.it)vtact(itt)=max(vtac(itt)
7997      *   ,qgfani(xpomri*scm,bbti,1.d0-vvxs*exp(-sumut)
7998      *   ,1.d0-exp(-sumctt),1.d0-exp(-sumut),iddt(itt),2,6))
7999          if(itt.gt.it)then
8000           vvxt0=vvxt0+vtac0(itt)
8001           sumctt=sumctt+vtact(itt)
8002          elseif(itt.lt.it)then
8003           vvxt0l=vvxt0l+vtac0(itt)
8004          endif
8005          sumct0=sumct0+vtac0(itt)
8006         enddo
8007         vvxtt=1.d0-exp(-sumctt)
8008         vvxt0=1.d0-exp(-vvxt0)
8009         vvxt0l=1.d0-exp(-vvxt0l)
8010 
8011         sumcp0=0.d0
8012         sumup=0.d0
8013         vvxp0=0.d0
8014         vvxp0l=0.d0
8015         do i=1,ia(1)
8016          sumup=sumup+vpac(i)
8017         enddo
8018         vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8019         do i=1,ia(1)
8020          ipp=ia(1)-i+1
8021          bbpi=(xa(ipp,1)+b-xxi)**2+(xa(ipp,2)-yyi)**2
8022          sumup=sumup-vpac(ipp)
8023          vpac0(ipp)=min(vpac(ipp)
8024      *   ,qgfani(1.d0/xpomri,bbpi,1.d0-vvxs*exp(-sumup)
8025      *   ,1.d0-exp(-sumcp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
8026          if(ipp.gt.ip)then
8027           vvxp0=vvxp0+vpac0(ipp)
8028          elseif(ipp.lt.ip)then
8029           vvxp0l=vvxp0l+vpac0(ipp)
8030          endif
8031          sumcp0=sumcp0+vpac0(ipp)
8032         enddo
8033         vvxp0=1.d0-exp(-vvxp0)
8034         vvxp0l=1.d0-exp(-vvxp0l)
8035 
8036         viu=qgpini(xpomr/xpomri,bbi,0.d0,0.d0,2)
8037         vim=2.d0*min(viu,qgpini(xpomr/xpomri,bbi,0.d0,0.d0,8))
8038         vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxp0l)*exp(-vpac0(ip))
8039         vvxtin=1.d0-(1.d0-vvxt0)*(1.d0-vvxt0l)*exp(-vtac0(it))
8040         vi=qgpini(xpomr/xpomri,bbi,vvxtin,vvxpin,21)*(1.d0-exp(-viu))
8041      *  -qgpini(xpomr/xpomri,bbi,vvxtin,vvxpin,23)*((1.d0-exp(-viu))**2
8042      *  +(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0
8043 
8044         vvx0s=(1.d0-vvxpin)**2
8045         vvxs=((1.d0-vvxp)*(1.d0-vvxpl))**2*exp(-2.d0*vpac(ip))
8046 
8047         gb=vi
8048      *  *((1.d0-exp(-vtact(it)))*(1.d0-vvxtt)*(1.d0-vvxs)
8049      *  +vvxs*(max(0.d0,1.d0-exp(-vtact(it))*(1.d0+vtact(it)))
8050      *  *(1.d0-vvxtt)
8051      *  -max(0.d0,1.d0-exp(-vtac0(it))*(1.d0+vtac0(it)))*(1.d0-vvxt0))
8052      *  +vtact(it)*exp(-vtact(it))*((1.d0-vvxtt)*vvxs
8053      *  -exp(vtact(it)-vtac0(it))*(1.d0-vvxt0)*(1.d0-vvxt0l)*vvx0s)
8054      *  -vtac0(it)*exp(-vtac0(it))*(1.d0-vvxt0)
8055      *  *(vvxs-vvx0s+vvxt0l*vvx0s))
8056 
8057         gb=gb/gb0/z*rp/rp0
8058         nrej=nrej+1
8059         if(qgran(b10).gt.gb.and.nrej.lt.10000)goto 33
8060 
8061         vi1p=qgpini(xpomr/xpomri,bbi,1.d0-(1.d0-vvxtin)**2*vvx0s
8062      *  ,0.d0,16)*exp(-vim)
8063         vimp=max(0.d0,(1.d0-exp(-vim)*(1.d0+vim)))/2.d0
8064 
8065         if(qgran(b10).le.(vi1p+vimp)/vi
8066      *  .or.xpomr/xpomri.lt.1.1d0*sgap**2)then
8067          if(qgran(b10).le.vi1p/(vi1p+vimp))then   !single cut Pomeron
8068           npin=npin+1
8069           if(npin.gt.npmax)then
8070            iret=1
8071            goto 31
8072           endif
8073           xpomim(npin)=1.d0/xpomri/scm
8074           xpomip(npin)=xpomr
8075           vvxim(npin)=1.d0-(1.d0-vvxtin)**2*vvx0s
8076           bpomim(npin)=bbi
8077           if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
8078      *    ,xpomim(npin),vvxim(npin),bpomim(npin)
8079          else                                     !more than 1 cut pomeron
8080           ninc=npgen(vim,2,20)
8081           npin=npin+ninc
8082           if(npin.gt.npmax)then
8083            iret=1
8084            goto 31
8085           endif
8086           do i=npin-ninc+1,npin
8087            xpomim(i)=1.d0/xpomri/scm
8088            xpomip(i)=xpomr
8089            vvxim(i)=0.d0
8090            bpomim(i)=bbi
8091            if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
8092      *     ,vvxim(i),bpomim(i)
8093           enddo
8094          endif
8095 
8096         else                                      !additional vertices
8097          xpomz0=dsqrt(xpomr*xpomri)
8098          rp0=alfp*dlog(xpomr/xpomri)*.0389d0
8099          xxz0=.5d0*(xxp+xxi)
8100          yyz0=.5d0*(yyp+yyi)
8101          bbzp=.25d0*bbi
8102          bbzt=bbzp
8103          call qgfdf(xxz0,yyz0,xpomz0,vpac,vtac,vvx,vvxp,vvxt
8104      *   ,vvxpl,vvxtl,ip,it)
8105 
8106          vvxp0=0.d0
8107          sumup=0.d0
8108          do i=1,ia(1)
8109           sumup=sumup+vpac(i)
8110          enddo
8111          vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8112          do i=1,ia(1)
8113           ipp=ia(1)-i+1
8114           bbpi=(xa(ipp,1)+b-xxz0)**2+(xa(ipp,2)-yyz0)**2
8115           sumup=sumup-vpac(ipp)
8116           vpac0(ipp)=min(vpac(ipp)
8117      *    ,qgfani(1.d0/xpomz0,bbpi,1.d0-vvxs*exp(-sumup)
8118      *    ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
8119           vvxp0=vvxp0+vpac0(ipp)
8120          enddo
8121          vvxp0=1.d0-exp(-vvxp0)
8122 
8123          sumut=0.d0
8124          vvxt0=0.d0
8125          do i=1,ia(2)
8126           sumut=sumut+vtac(i)
8127          enddo
8128          vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
8129          do i=1,ia(2)
8130           itt=ia(2)-i+1
8131           bbti=(xb(itt,1)-xxz0)**2+(xb(itt,2)-yyz0)**2
8132           sumut=sumut-vtac(itt)
8133           vtac0(itt)=min(vtac(itt)
8134      *    ,qgfani(xpomz0*scm,bbti,1.d0-vvxs*exp(-sumut)
8135      *    ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
8136           vvxt0=vvxt0+vtac0(itt)
8137          enddo
8138          vvxt0=1.d0-exp(-vvxt0)
8139 
8140          viu=qgpini(xpomr/xpomz0,bbzp,0.d0,0.d0,2)
8141          vilu=1.d0-exp(-viu)
8142          vimu=2.d0*min(viu,qgpini(xpomr/xpomz0,bbzp,0.d0,0.d0,8))
8143          vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
8144          vid=qgpini(xpomz0/xpomri,bbzt,0.d0,0.d0,2)
8145          vild=1.d0-exp(-vid)
8146          vimd=2.d0*min(vid,qgpini(xpomz0/xpomri,bbzt,0.d0,0.d0,8))
8147          vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
8148 
8149          vi1pu=qgpini(xpomr/xpomz0,bbzp
8150      *   ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
8151          vguu=qgpini(xpomr/xpomz0,bbzp,vvxp0,vvxt0,21)*vilu       !uu+uc
8152          vgcu=qgpini(xpomr/xpomz0,bbzp,vvxp0,vvxt0,23)
8153      *   *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
8154          vi1pd=qgpini(xpomz0/xpomri,bbzt
8155      *   ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
8156          vgud=qgpini(xpomz0/xpomri,bbzt,vvxt0,vvxp0,21)*vild      !uu+uc
8157          vgcd=qgpini(xpomz0/xpomri,bbzt,vvxt0,vvxp0,23)
8158      *   *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
8159 
8160          gbz0=(vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd
8161      *   +vgcu*vimpd+vi1pu*vgcd+vgcu*vi1pd)*(1.d0-vvxp0)*(1.d0-vvxt0)
8162      *   +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
8163      *   +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
8164 
8165          nrej=0
8166 35       xpomz=xpomri*sgap*(xpomr/xpomri/sgap**2)**qgran(b10)
8167          rpt=alfp*dlog(xpomz/xpomri)*4.d0*.0389d0
8168          rpp=alfp*dlog(xpomr/xpomz)*4.d0*.0389d0
8169          rp=rpp*rpt/(rpp+rpt)
8170          z=qgran(b10)
8171          phi=pi*qgran(b10)
8172          b0=dsqrt(-rp*dlog(z))
8173          bbzt=(dsqrt(bbi)*rpt/(rpp+rpt)-b0*cos(phi))**2
8174      *   +(b0*sin(phi))**2
8175          bbzp=(dsqrt(bbi)*rpp/(rpp+rpt)+b0*cos(phi))**2
8176      *   +(b0*sin(phi))**2
8177          call qgbdef(bbzt,bbzp,xxi,yyi,xxp,yyp,xxz,yyz
8178      *   ,int(1.5d0+qgran(b10)))               !coordinates for the vertex
8179          call qgfdf(xxz,yyz,xpomz,vpac,vtac
8180      *   ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
8181 
8182          vvxp0=0.d0
8183          sumup=0.d0
8184          do i=1,ia(1)
8185           sumup=sumup+vpac(i)
8186          enddo
8187          vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8188          do i=1,ia(1)
8189           ipp=ia(1)-i+1
8190           bbpi=(xa(ipp,1)+b-xxz)**2+(xa(ipp,2)-yyz)**2
8191           sumup=sumup-vpac(ipp)
8192           vpac0(ipp)=min(vpac(ipp)
8193      *    ,qgfani(1.d0/xpomz,bbpi,1.d0-vvxs*exp(-sumup)
8194      *    ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipp),icz,3))
8195           vvxp0=vvxp0+vpac0(ipp)
8196          enddo
8197          vvxp0=1.d0-exp(-vvxp0)
8198 
8199          sumut=0.d0
8200          vvxt0=0.d0
8201          do i=1,ia(2)
8202           sumut=sumut+vtac(i)
8203          enddo
8204          vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
8205          do i=1,ia(2)
8206           itt=ia(2)-i+1
8207           bbti=(xb(itt,1)-xxz)**2+(xb(itt,2)-yyz)**2
8208           sumut=sumut-vtac(itt)
8209           vtac0(itt)=min(vtac(itt)
8210      *    ,qgfani(xpomz*scm,bbti,1.d0-vvxs*exp(-sumut)
8211      *    ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(itt),2,3))
8212           vvxt0=vvxt0+vtac0(itt)
8213          enddo
8214          vvxt0=1.d0-exp(-vvxt0)
8215 
8216          viu=qgpini(xpomr/xpomz,bbzp,0.d0,0.d0,2)
8217          vilu=1.d0-exp(-viu)
8218          vimu=2.d0*min(viu,qgpini(xpomr/xpomz,bbzp,0.d0,0.d0,8))
8219          vimpu=max(0.d0,(1.d0-exp(-vimu)*(1.d0+vimu)))/2.d0
8220          vid=qgpini(xpomz/xpomri,bbzt,0.d0,0.d0,2)
8221          vild=1.d0-exp(-vid)
8222          vimd=2.d0*min(vid,qgpini(xpomz/xpomri,bbzt,0.d0,0.d0,8))
8223          vimpd=max(0.d0,(1.d0-exp(-vimd)*(1.d0+vimd)))/2.d0
8224 
8225          vi1pu=qgpini(xpomr/xpomz,bbzp
8226      *   ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimu)
8227          vguu=qgpini(xpomr/xpomz,bbzp,vvxp0,vvxt0,21)*vilu        !uu+uc
8228          vgcu=qgpini(xpomr/xpomz,bbzp,vvxp0,vvxt0,23)
8229      *   *(vilu**2+(exp(2.d0*viu-vimu)-1.d0)*exp(-2.d0*viu))/2.d0 !cc+cu
8230          vi1pd=qgpini(xpomz/xpomri,bbzt
8231      *   ,1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2,0.d0,16)*exp(-vimd)
8232          vgud=qgpini(xpomz/xpomri,bbzt,vvxt0,vvxp0,21)*vild       !uu+uc
8233          vgcd=qgpini(xpomz/xpomri,bbzt,vvxt0,vvxp0,23)
8234      *   *(vild**2+(exp(2.d0*vid-vimd)-1.d0)*exp(-2.d0*vid))/2.d0 !cc+cu
8235 
8236          vvcc=vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd+vimpu*vgcd+vgcu*vimpd
8237      *   +vi1pu*vgcd+vgcu*vi1pd
8238          vvt=vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
8239      *   +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0
8240      *   +(vimpd+vi1pd)*vguu*(1.d0-vvxt0)*vvxp0
8241 
8242          gbz=vvt/gbz0/z*rp/rp0    /1.4d0
8243          nrej=nrej+1
8244          if(qgran(b10).gt.gbz.and.nrej.lt.10000)goto 35
8245 
8246          aks=vvt*qgran(b10)
8247          if(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0)
8248      *   +(vimpu+vi1pu)*vgud*(1.d0-vvxp0)*vvxt0)then
8249           jtu=0
8250           if(qgran(b10).lt.vimpd/(vimpd+vi1pd))then
8251            jtd=2
8252           else
8253            jtd=1
8254           endif
8255          elseif(aks.gt.vvcc*(1.d0-vvxp0)*(1.d0-vvxt0))then
8256           jtd=0
8257           if(qgran(b10).lt.vimpu/(vimpu+vi1pu))then
8258            jtu=2
8259           else
8260            jtu=1
8261           endif
8262          else
8263           aks=vvcc*qgran(b10)
8264           if(aks.lt.vimpu*vimpd)then
8265            jtu=2
8266            jtd=2
8267           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd)then
8268            jtu=2
8269            jtd=1
8270           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd)then
8271            jtu=1
8272            jtd=2
8273           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
8274      *    +vimpu*vgcd)then
8275            jtu=2
8276            jtd=0
8277           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
8278      *    +vimpu*vgcd+vgcu*vimpd)then
8279            jtu=0
8280            jtd=2
8281           elseif(aks.lt.vimpu*vimpd+vimpu*vi1pd+vi1pu*vimpd
8282      *    +vimpu*vgcd+vgcu*vimpd+vi1pu*vgcd)then
8283            jtu=1
8284            jtd=0
8285           else
8286            jtu=0
8287            jtd=1
8288           endif
8289          endif
8290 
8291          if(jtu.eq.1)then                         !single cut Pomeron
8292           npin=npin+1
8293           if(npin.gt.npmax)then
8294            iret=1
8295            goto 31
8296           endif
8297           xpomim(npin)=1.d0/xpomz/scm
8298           xpomip(npin)=xpomr
8299           vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
8300           bpomim(npin)=bbzp
8301           if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
8302      *    ,xpomim(npin),vvxim(npin),bpomim(npin)
8303          elseif(jtu.eq.2)then                     !more than 1 cut Pomeron
8304           ninc=npgen(vimu,2,20)
8305           npin=npin+ninc
8306           if(npin.gt.npmax)then
8307            iret=1
8308            goto 31
8309           endif
8310           do i=npin-ninc+1,npin
8311            xpomim(i)=1.d0/xpomz/scm
8312            xpomip(i)=xpomr
8313            vvxim(i)=0.d0
8314            bpomim(i)=bbzp
8315            if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
8316      *     ,vvxim(i),bpomim(i)
8317           enddo
8318          endif
8319 
8320          if(jtd.eq.1)then                         !single cut Pomeron
8321           npin=npin+1
8322           if(npin.gt.npmax)then
8323            iret=1
8324            goto 31
8325           endif
8326           xpomim(npin)=1.d0/xpomri/scm
8327           xpomip(npin)=xpomz
8328           vvxim(npin)=1.d0-((1.d0-vvxp0)*(1.d0-vvxt0))**2
8329           bpomim(npin)=bbzt
8330           if(debug.ge.4)write (moniou,211)npin,xpomip(npin)
8331      *    ,xpomim(npin),vvxim(npin),bpomim(npin)
8332          elseif(jtu.eq.2)then                     !more than 1 cut Pomeron
8333           ninc=npgen(vimd,2,20)
8334           npin=npin+ninc
8335           if(npin.gt.npmax)then
8336            iret=1
8337            goto 31
8338           endif
8339           do i=npin-ninc+1,npin
8340            xpomim(i)=1.d0/xpomri/scm
8341            xpomip(i)=xpomz
8342            vvxim(i)=0.d0
8343            bpomim(i)=bbzt
8344            if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
8345      *     ,vvxim(i),bpomim(i)
8346           enddo
8347          endif
8348         endif
8349        enddo          !end of the zigzag-loop
8350       endif           !nzzt.ne.0
8351 
8352       call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
8353      *,ip,it)
8354       if((jt.eq.2.or.jt.eq.3.or.jt.eq.9)
8355      *.and.qgran(b10).lt.(1.d0-exp(-vpac(ip)))*(1.d0-vvxpl)
8356      */((1.d0-exp(-vpac(ip)))*(1.d0-vvxpl)+2.d0*vvxpl))then
8357        icdps=iddp(ip)
8358        do icdp=1,2
8359         iddp(ip)=icdp
8360         call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
8361      *  ,ip,it)
8362         wdp(icdp,ip)=(1.d0-exp(-vpac(ip)))*(1.d0-vvxpl)
8363        enddo
8364        iddp(ip)=icdps
8365       endif
8366       call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
8367      *,ip,it)
8368       if((jt.eq.2.or.jt.eq.4.or.jt.eq.10)
8369      *.and.qgran(b10).lt.(1.d0-exp(-vtac(it)))*(1.d0-vvxtl)
8370      */((1.d0-exp(-vtac(it)))*(1.d0-vvxtl)+2.d0*vvxtl))then
8371        icdts=iddt(it)
8372        do icdt=1,2
8373         iddt(it)=icdt
8374         call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
8375      *  ,ip,it)
8376         wdt(icdt,it)=(1.d0-exp(-vtac(it)))*(1.d0-vvxtl)
8377        enddo
8378        iddt(it)=icdts
8379       endif
8380 
8381       if(nppr0.eq.0)goto 20
8382 
8383 c projectile 'fans'
8384       m=0
8385       nppm(1)=nppr0
8386       xpomm(1)=xpomr
8387       wgpm(1)=wgpr0
8388       xxm(1)=xxp
8389       yym(1)=yyp
8390       do i=1,nppr0
8391        ippm(i,1)=ippr0(i)
8392        itypm(i,1)=itypr0(i)
8393       enddo
8394 
8395 9     m=m+1                                 !next level multi-Pomeron vertex
8396       if(m.gt.levmax)then
8397        iret=1
8398        goto 31
8399       endif
8400       ii(m)=0
8401 10    ii(m)=ii(m)+1                         !next cut fan in the vertex
8402       if(ii(m).gt.nppm(m))then              !all fans at the level considered
8403        m=m-1                                !one level down
8404        if(m.eq.0)goto 20                    !all proj. fans considered
8405        goto 10
8406       endif
8407       l=ii(m)
8408       ipp=ippm(l,m)                         !proj. index for the leg
8409       itypom=itypm(l,m)                     !type of the cut
8410       bpm=(xa(ipp,1)+b-xxm(m))**2+(xa(ipp,2)-yym(m))**2      !b^2 for the leg
8411       if(debug.ge.4)write (moniou,208)ii(m),m,ipp,bpm
8412       if(xpomm(m)*sgap**2.gt.1.d0)stop'xpomm(m)*sgap**2>1!'
8413       if(itypom.eq.4.and.xpomm(m)*sgap**3.gt.1.d0)
8414      *stop'4:xpomm(m)*sgap**3>1!'
8415 
8416       if(debug.ge.4)write (moniou,210)m
8417       xpomr0=min(dsqrt(xpomm(m)),1.d0/sgap)
8418       xpomr0=max(xpomr0,xpomm(m)*sgap)
8419       if(itypom.eq.4)xpomr0=min(xpomr0,dsqrt(xpomm(m)/sgap))
8420       rp1=(rq(iddp(ipp),icz)-alfp*dlog(xpomr0))*4.d0*.0389d0
8421       rp2=alfp*dlog(xpomr0/xpomm(m))*4.d0*.0389d0
8422       rp0=rp1*rp2/(rp1+rp2)
8423       bbp=bpm*(rp1/(rp1+rp2))**2
8424       bbi=bpm*(rp2/(rp1+rp2))**2
8425       call qgbdef(bbp,bbi,xa(ipp,1)+b,xa(ipp,2),xxm(m),yym(m)
8426      *,xxp0,yyp0,1)
8427 
8428       call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac,vvx,vvxp,vvxt
8429      *,vvxpl,vvxtl,ipp,it)
8430       vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8431       viu=qgpini(xpomr0/xpomm(m),bbi,0.d0,0.d0,2)
8432       vim=2.d0*min(viu,qgpini(xpomr0/xpomm(m),bbi,0.d0,0.d0,8))
8433       if(itypom.eq.-1.or.itypom.eq.4)then         !single cut Pomeron at the end
8434        vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
8435      * *exp(-2.d0*vpac(ipp)-2.d0*vtac(it))
8436        vip=qgpini(xpomr0/xpomm(m),bbi,vvxi,0.d0,16)*exp(-vim)
8437       elseif(itypom.eq.2.or.itypom.eq.7)then       !>1 cut Poms at the end
8438        vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
8439       else                                         !rap-gap
8440        vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ipp))
8441        vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8442        viuu=qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,20)
8443      * *(1.d0-exp(-viu))
8444        viuc=max(0.d0,viuu
8445      * -qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,21)*(1.d0-exp(-viu)))
8446        vicc=qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,22)*.5d0
8447      * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
8448        vicu=max(0.d0,qgpini(xpomr0/xpomm(m),bbi,vvxpin,vvxtin,23)*.5d0
8449      * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
8450      * -vicc)
8451       endif
8452 
8453       if(itypom.le.3)then
8454        sumup=0.d0
8455        vvxp0=0.d0
8456        do i=1,ia(1)
8457         sumup=sumup+vpac(i)
8458        enddo
8459        vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8460        do i=1,ia(1)-ipp+1
8461         ipi=ia(1)-i+1
8462         bbl=(xa(ipi,1)+b-xxp0)**2+(xa(ipi,2)-yyp0)**2
8463         sumup=sumup-vpac(ipi)
8464         vpac0(ipi)=min(vpac(ipi)
8465      *  ,qgfani(1.d0/xpomr0,bbl,1.d0-vvxs*exp(-sumup)
8466      *  ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipi),icz,3))
8467         if(ipi.gt.ipp)vvxp0=vvxp0+vpac0(ipi)
8468        enddo
8469        vvxp0=1.d0-exp(-vvxp0)
8470        vpacng=min(vpac0(ipp)
8471      * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,4))
8472        vpacpe=min(vpacng
8473      * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,5))
8474       else
8475        vplc=qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,7)
8476        vplc0=min(vplc
8477      * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,8))
8478        vplcng=min(vplc0
8479      * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,11))
8480        vplcpe=min(vplcng
8481      * ,qgfani(1.d0/xpomr0,bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,10))
8482       endif
8483 
8484       if(itypom.eq.-1)then          !'fan' (single cut Pomeron at the end)
8485        gb0=vip*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8486      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8487      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8488      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8489      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8490      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8491      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8492      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8493      * +2.d0*((vpac0(ipp)-vpacpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8494      * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8495      * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
8496      * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
8497        gb0=gb0*40.d0
8498       elseif(itypom.eq.0)then      !'fan' (cut loop at the end - rapgap)
8499        gb0=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8500      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8501      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8502      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8503      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8504      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8505      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8506      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8507      * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8508      * *(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8509      * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8510      * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8511      * -2.d0*vicu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8512      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8513      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8514      * *(1.d0-vvx)*(1.d0-vvxt)
8515       elseif(itypom.eq.1)then      !'fan' (uncut end - rapgap)
8516        gb0=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8517      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8518      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8519      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8520      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8521      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8522      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8523      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8524      * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8525      * *(viuc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8526      * +viuu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8527      * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8528      * +2.d0*viuu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8529      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8530      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8531      * *(1.d0-vvx)*(1.d0-vvxt)
8532       elseif(itypom.eq.2)then        !'fan' (>1 cut Poms at the end)
8533        gb0=vimp*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8534      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8535      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8536      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8537      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8538      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8539      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8540      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8541      * +2.d0*(vpac0(ipp)*exp(-vpac(ipp))*(1.d0-vvxp)
8542      * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8543      * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
8544      * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
8545       elseif(itypom.eq.3)then      !'fan' (cut/uncut end - rapgap)
8546        gb0=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8547      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8548      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8549      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8550      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8551      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8552      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8553      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8554      * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8555      * *(vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8556      * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8557       elseif(itypom.eq.4)then          !'leg' (single cut Pomeron at the end)
8558        gb0=vip*((vplc0-vplcpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8559      * *(1.d0-vvxpl))*exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8560      * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8561        if(gb0.le.0.d0)then
8562         gb0=vip*vplc0*.01d0*exp(-vpac(ipp))*(1.d0-vvxp)
8563      *  *(1.d0-vvxpl)*exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8564      *  *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8565        endif
8566       elseif(itypom.eq.5)then      !'leg' (cut/uncut end - rapgap)
8567        gb0=vplcng*exp(-2.d0*vpac(ipp)-vtac(it))
8568      * *(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
8569      * *(vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8570       elseif(itypom.eq.7)then      !'leg' (>1 cut Poms at the end)
8571        gb0=vimp*(vplc0*exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
8572      * -(vplc-vplc0)*(1.d0-exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)))
8573      * *exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8574      * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8575       endif
8576       if(gb0.le.0.d0)then      !so170712
8577        iret=1
8578        goto 31
8579       endif
8580       nrej=0
8581 
8582 11    xpomm(m+1)=(xpomm(m)*sgap**2)**qgran(b10)/sgap
8583       if(itypom.eq.4)xpomm(m+1)=(xpomm(m)*sgap**3)**qgran(b10)/sgap**2
8584       rp1=(rq(iddp(ipp),icz)-alfp*dlog(xpomm(m+1)))*4.d0*.0389d0
8585       rp2=alfp*dlog(xpomm(m+1)/xpomm(m))*4.d0*.0389d0
8586       rp=rp1*rp2/(rp1+rp2)
8587       z=qgran(b10)
8588       phi=pi*qgran(b10)
8589       b0=dsqrt(-rp*dlog(z))
8590       bbp=(dsqrt(bpm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
8591       bbi=(dsqrt(bpm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
8592       call qgbdef(bbp,bbi,xa(ipp,1)+b,xa(ipp,2),xxm(m),yym(m)
8593      *,xxm(m+1),yym(m+1),int(1.5d0+qgran(b10)))   !coordinates for the vertex
8594 
8595       call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
8596      *,vvx,vvxp,vvxt,vvxpl,vvxtl,ipp,it)
8597       vvxts=1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8598       viu=qgpini(xpomm(m+1)/xpomm(m),bbi,0.d0,0.d0,2)
8599       vim=2.d0*min(viu,qgpini(xpomm(m+1)/xpomm(m),bbi,0.d0,0.d0,8))
8600       if(itypom.eq.-1.or.itypom.eq.4)then         !single cut Pomeron at the end
8601        vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
8602      * *exp(-2.d0*vpac(ipp)-2.d0*vtac(it))
8603        vip=qgpini(xpomm(m+1)/xpomm(m),bbi,vvxi,0.d0,16)*exp(-vim)
8604       elseif(itypom.eq.2.or.itypom.eq.7)then       !>1 cut Poms at the end
8605        vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
8606       else                                         !rap-gap
8607        vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ipp))
8608        vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8609        viuu=qgpini(xpomm(m+1)/xpomm(m),bbi,vvxpin,vvxtin,20)
8610      * *(1.d0-exp(-viu))
8611        viuc=max(0.d0,viuu-qgpini(xpomm(m+1)/xpomm(m),bbi
8612      * ,vvxpin,vvxtin,21)*(1.d0-exp(-viu)))
8613        vicc=qgpini(xpomm(m+1)/xpomm(m),bbi,vvxpin,vvxtin,22)*.5d0
8614      * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
8615        vicu=max(0.d0,qgpini(xpomm(m+1)/xpomm(m),bbi,vvxpin,vvxtin,23)
8616      * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
8617      * /2.d0-vicc)
8618       endif
8619 
8620       if(itypom.le.3)then
8621        sumup=0.d0
8622        vvxp0=0.d0
8623        do i=1,ia(1)
8624         sumup=sumup+vpac(i)
8625        enddo
8626        vvxs=(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8627        do i=1,ia(1)-ipp+1
8628         ipi=ia(1)-i+1
8629         bbl=(xa(ipi,1)+b-xxm(m+1))**2+(xa(ipi,2)-yym(m+1))**2
8630         sumup=sumup-vpac(ipi)
8631         vpac0(ipi)=min(vpac(ipi)
8632      *  ,qgfani(1.d0/xpomm(m+1),bbl,1.d0-vvxs*exp(-sumup)
8633      *  ,1.d0-exp(-vvxp0),1.d0-exp(-sumup),iddp(ipi),icz,3))
8634         if(ipi.gt.ipp)vvxp0=vvxp0+vpac0(ipi)
8635        enddo
8636        vvxp0=1.d0-exp(-vvxp0)
8637 
8638        vpacng=min(vpac0(ipp)
8639      * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,4))
8640        vpacpe=min(vpacng
8641      * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp0,vvxpl,iddp(ipp),icz,5))
8642       else
8643        vplc=qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp)
8644      * ,icz,7)
8645        vplc0=min(vplc
8646      * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,8))
8647        vplcng=min(vplc0
8648      * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,11))
8649        vplcpe=min(vplcng
8650      * ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,10))
8651       endif
8652 
8653       if(itypom.eq.-1)then          !'fan' (single cut Pomeron at the end)
8654        gb=vip*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8655      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8656      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8657      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8658      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8659      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8660      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8661      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8662      * +2.d0*((vpac0(ipp)-vpacpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8663      * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8664      * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
8665      * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
8666       elseif(itypom.eq.0)then      !'fan' (cut loop at the end - rapgap)
8667        gb=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8668      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8669      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8670      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8671      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8672      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8673      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8674      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8675      * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8676      * *(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8677      * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8678      * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8679      * -2.d0*vicu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8680      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8681      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8682      * *(1.d0-vvx)*(1.d0-vvxt)
8683       elseif(itypom.eq.1)then      !'fan' (uncut end - rapgap)
8684        gb=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8685      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8686      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8687      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8688      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8689      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8690      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8691      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8692      * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8693      * *(viuc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8694      * +viuu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8695      * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8696      * +2.d0*viuu*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8697      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8698      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8699      * *(1.d0-vvx)*(1.d0-vvxt)
8700       elseif(itypom.eq.2)then        !'fan' (>1 cut Poms at the end)
8701        gb=vimp*((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8702      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8703      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8704      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8705      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8706      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8707      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8708      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8709      * +2.d0*(vpac0(ipp)*exp(-vpac(ipp))*(1.d0-vvxp)
8710      * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8711      * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp))
8712      * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)*exp(-2.d0*vtac(it))
8713       elseif(itypom.eq.3)then      !'fan' (cut/uncut end - rapgap)
8714        gb=((max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8715      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8716      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8717      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8718      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8719      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8720      * +((1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8721      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl)
8722      * +2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl))
8723      * *((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8724      * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
8725      * *exp(-vtac(it))))*(1.d0-vvx)*(1.d0-vvxt)*exp(-vtac(it))
8726      * -2.d0*(vicu+wgpm(m)*viuu)*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))
8727      * -1.d0-(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8728      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8729      * *(1.d0-vvx)*(1.d0-vvxt)
8730       elseif(itypom.eq.4)then          !'leg' (single cut Pomeron at the end)
8731        gb=vip*((vplc0-vplcpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8732      * *(1.d0-vvxpl)-(vplc-vplc0)*(1.d0-exp(-vpac(ipp))*(1.d0-vvxp)
8733      * *(1.d0-vvxpl)))*exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8734      * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8735       elseif(itypom.eq.5)then      !'leg' (cut/uncut end - rapgap)
8736        gb=vplcng*exp(-2.d0*vpac(ipp)-vtac(it))
8737      * *(1.d0-vvxp)**2*(1.d0-vvxpl)*(1.d0-vvx)*(1.d0-vvxt)
8738      * *((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8739      * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
8740      * *exp(-vtac(it))))
8741       elseif(itypom.eq.7)then      !'leg' (>1 cut Poms at the end)
8742        gb=vimp*(vplc0*exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
8743      * -(vplc-vplc0)*(1.d0-exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)))
8744      * *exp(-vpac(ipp)-2.d0*vtac(it))*(1.d0-vvxp)
8745      * *(1.d0-vvx)*(1.d0-vvxt)**2*(1.d0-vvxtl)
8746       endif
8747       gb=gb/gb0/z*rp/rp0  /10.d0
8748       nrej=nrej+1
8749       if(qgran(b10).gt.gb.and.nrej.le.1000)goto 11
8750 
8751       if(itypom.eq.-1.or.itypom.eq.4)then  !'single cut Pomeron in the handle
8752        npin=npin+1
8753        if(npin.gt.npmax)then
8754         iret=1
8755         goto 31
8756        endif
8757        xpomim(npin)=1.d0/xpomm(m)/scm
8758        xpomip(npin)=xpomm(m+1)
8759        vvxim(npin)=vvxi
8760        bpomim(npin)=bbi
8761        if(debug.ge.4)write (moniou,211)npin,xpomip(npin),xpomim(npin)
8762      * ,vvxim(npin),bpomim(npin)
8763       elseif(itypom.eq.2.or.itypom.eq.7)then   !>1 cut Pomerons in the handle
8764        ninc=npgen(vim,2,20)
8765        npin=npin+ninc
8766        if(npin.gt.npmax)then
8767         iret=1
8768         goto 31
8769        endif
8770        do i=npin-ninc+1,npin
8771         xpomim(i)=1.d0/xpomm(m)/scm
8772         xpomip(i)=xpomm(m+1)
8773         vvxim(i)=0.d0
8774         bpomim(i)=bbi
8775         if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
8776      *  ,vvxim(i),bpomim(i)
8777        enddo
8778       endif
8779 
8780       if(itypom.eq.-1)then      !single cut Pomeron in the 'handle'
8781        vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8782      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8783      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8784      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8785      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8786      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8787        vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8788      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8789        vv3=2.d0*((vpac0(ipp)-vpacpe)*exp(-vpac(ipp))*(1.d0-vvxp)
8790      * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8791      * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp)
8792        if(xpomm(m+1)*sgap**2.gt..9d0.or.vv3.lt.0.d0)vv3=0.d0
8793        aks=(vv1+vv2+vv3)*qgran(b10)
8794        if(aks.lt.vv1)then
8795         jt=1                     !>1 cut fans
8796        elseif(aks.lt.vv1+vv2)then
8797         jt=2                     !diffr. cut
8798        else
8799         jt=3                     !1 cut fan
8800        endif
8801       elseif(itypom.eq.0)then    !cut 'loop' in the 'handle' (rap-gap)
8802        vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8803      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8804      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8805      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8806      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8807      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp)-vtac(it))
8808      * *(1.d0-vvxt)*(1.d0-vvxtl)*(vicc+vicu)
8809      * /(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8810      * -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8811        vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8812      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8813        vv3=2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl)
8814        aks=(vv1+vv2+vv3)*qgran(b10)
8815        if(aks.lt.vv1)then
8816         jt=1                     !>1 cut fans
8817        elseif(aks.lt.vv1+vv2)then
8818         jt=2                     !diffr. cut
8819        else
8820         jt=3                     !1 cut fan
8821        endif
8822       elseif(itypom.eq.1)then    !uncut 'handle' (rap-gap)
8823        vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8824      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8825      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8826      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8827      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8828      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8829        vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8830      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8831        vv3=2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2*(1.d0-vvxpl)
8832        vv4=2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0-(vpac(ipp)
8833      * -vpac0(ipp)))*(1.d0-vvxp0)+(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))
8834      * *exp(-vpac(ipp))*viuu/(viuu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
8835      * *exp(-vtac(it)))+viuc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it)))
8836        if(xpomm(m+1)*sgap**2.gt..9d0.or.vv4.lt.0.d0)vv4=0.d0
8837        aks=(vv1+vv2+vv3+vv4)*qgran(b10)
8838        if(aks.lt.vv1)then
8839         jt=1                     !>1 cut fans
8840        elseif(aks.lt.vv1+vv2)then
8841         jt=2                     !diffr. cut
8842        elseif(aks.lt.vv1+vv2+vv3)then
8843         jt=3                     !1 cut fan
8844        else
8845         jt=4                     !>1 cut 'handle' fans
8846        endif
8847       elseif(itypom.eq.2)then    !>1 cut Pomerons in the 'handle'
8848        vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8849      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8850      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8851      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8852      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8853      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))*exp(-vpac(ipp))
8854        vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8855      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8856        vv3=2.d0*(vpac0(ipp)*exp(-vpac(ipp))*(1.d0-vvxp)
8857      * *(1.d0-vvxpl)-(vpac(ipp)-vpac0(ipp))*(1.d0-exp(-vpac(ipp))
8858      * *(1.d0-vvxp)*(1.d0-vvxpl)))*exp(-vpac(ipp))*(1.d0-vvxp)
8859        aks=(vv1+vv2+vv3)*qgran(b10)
8860        if(aks.lt.vv1)then
8861         jt=1                     !>1 cut fans
8862        elseif(aks.lt.vv1+vv2)then
8863         jt=2                     !diffr. cut
8864        else
8865         jt=3                     !1 cut fan
8866        endif
8867 
8868       elseif(itypom.eq.3)then    !rap-gap in the 'handle'
8869        vv1=(max(0.d0,1.d0-exp(-2.d0*vpac(ipp))
8870      * *(1.d0+2.d0*vpac(ipp)))+2.d0*vpac(ipp)*exp(-2.d0*vpac(ipp))
8871      * *(1.d0-(1.d0-vvxp)**2))*(1.d0-vvxpl)
8872      * -2.d0*(max(0.d0,exp(vpac(ipp)-vpac0(ipp))-1.d0
8873      * -(vpac(ipp)-vpac0(ipp)))*(1.d0-vvxp0)
8874      * +(vpac(ipp)-vpac0(ipp))*(vvxp-vvxp0))
8875      * *exp(-vpac(ipp)-vtac(it))*(1.d0-vvxt)*(1.d0-vvxtl)
8876      * *(vicc+vicu+wgpm(m)*(viuu-viuc))
8877      * /((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8878      * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)
8879      * *exp(-vtac(it))))
8880        vv2=(1.d0-exp(-vpac(ipp)))**2*(1.d0-vvxpl)
8881      * +2.d0*(1.d0-exp(-vpac(ipp)))*vvxpl
8882        vv3=2.d0*vpacng*exp(-2.d0*vpac(ipp))*(1.d0-vvxp)**2
8883      * *(1.d0-vvxpl)
8884        aks=(vv1+vv2+vv3)*qgran(b10)
8885        if(aks.lt.vv1)then
8886         jt=1                     !>1 cut fans
8887        elseif(aks.lt.vv1+vv2)then
8888         jt=2                     !diffr. cut
8889        else
8890         jt=3                     !1 cut fan
8891        endif
8892       else
8893        jt=5                      !cut leg
8894       endif
8895 
8896       nppm(m+1)=0
8897       wgpm(m+1)=0.d0
8898       if(jt.eq.1)then                        !>1 cut fans
8899        ntry=0
8900 12     ntry=ntry+1
8901        nphm=0
8902        if(ipp.eq.ia(1).or.ntry.gt.100)then
8903         nppm(m+1)=npgen(2.d0*vpac(ipp),2,20)
8904         do i=1,nppm(m+1)
8905          if(qgran(b10).le.vpac0(ipp)/vpac(ipp)
8906      *   .or.xpomm(m+1)*sgap**2.gt..9d0)then
8907           itypm(i,m+1)=0
8908          else
8909           itypm(i,m+1)=1
8910           nphm=nphm+1
8911          endif
8912          ippm(i,m+1)=ipp
8913         enddo
8914         wh=(vpac(ipp)/vpac0(ipp)-1.d0)/nppm(m+1)
8915        else
8916         nppm(m+1)=npgen(2.d0*vpac(ipp),1,20)
8917         do i=1,nppm(m+1)
8918          if(qgran(b10).le.vpac0(ipp)/vpac(ipp)
8919      *   .or.xpomm(m+1)*sgap**2.gt..9d0)then
8920           itypm(i,m+1)=0
8921          else
8922           itypm(i,m+1)=1
8923           nphm=nphm+1
8924          endif
8925          ippm(i,m+1)=ipp
8926         enddo
8927         wh=(vpac(ipp)/vpac0(ipp)-1.d0)/nppm(m+1)
8928         do ipi=ipp+1,ia(1)
8929          ninc=npgen(2.d0*vpac(ipi),0,20)
8930          if(ninc.ne.0)then
8931           nppm(m+1)=nppm(m+1)+ninc
8932           nh0=nphm
8933           if(nppm(m+1).gt.legmax)then
8934            iret=1
8935            goto 31
8936           endif
8937           do i=nppm(m+1)-ninc+1,nppm(m+1)
8938            if(qgran(b10).le.vpac0(ipi)/vpac(ipi)
8939      *     .or.xpomm(m+1)*sgap**2.gt..9d0)then
8940             itypm(i,m+1)=0
8941            else
8942             itypm(i,m+1)=1
8943             nphm=nphm+1
8944            endif
8945            ippm(i,m+1)=ipi
8946           enddo
8947           if(ninc.gt.nphm-nh0)wh=(vpac(ipi)/vpac0(ipi)-1.d0)/ninc
8948          endif
8949         enddo
8950         if(nppm(m+1).eq.1)goto 12
8951        endif
8952 
8953        if(nphm+1.ge.nppm(m+1))then
8954         if(itypom.eq.-1.or.itypom.eq.1.or.itypom.eq.2)then
8955          gbt=1.d0-exp(vpac(ipp)+(1.d0-nphm)*dlog(2.d0))
8956      *   /(1.d0-vvxp)/(1.d0-vvxpl)
8957         elseif(itypom.eq.0)then
8958          gbt=1.d0-(vicc+vicu)*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8959      *   /(vicc*(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8960      *   -vicu*(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8961      *   *exp(vpac(ipp)+(1.d0-nphm)*dlog(2.d0))
8962      *   /(1.d0-vvxp)/(1.d0-vvxpl)
8963         elseif(itypom.eq.3)then
8964          gbt=1.d0-(vicc+vicu+wgpm(m)*(viuu-viuc))
8965      *   *(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))
8966      *   /((vicc-wgpm(m)*viuc)*(1.d0-vvxt)*(1.d0-vvxtl)
8967      *   *exp(-vtac(it))-(vicu+wgpm(m)*viuu)
8968      *   *(1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(it))))
8969      *   *exp(vpac(ipp)+(1.d0-nphm)*dlog(2.d0))
8970      *   /(1.d0-vvxp)/(1.d0-vvxpl)
8971         else
8972          stop'unknown itypom'
8973         endif
8974         if(nphm.eq.nppm(m+1).and.qgran(b10).gt.gbt
8975      *  .or.nphm+1.eq.nppm(m+1).and.qgran(b10).gt.1.d0+wh*gbt)then
8976          ntry=0
8977           goto 12
8978         endif
8979        endif
8980 
8981       elseif(jt.eq.4)then                    !>1 cut 'handle' fans
8982        ntry=0
8983 14     ntry=ntry+1
8984        if(ipp.eq.ia(1).or.ntry.gt.100)then
8985         nppm(m+1)=npgen(vpac(ipp)-vpac0(ipp),2,20)
8986         do i=1,nppm(m+1)
8987           itypm(i,m+1)=1
8988          ippm(i,m+1)=ipp
8989         enddo
8990        else
8991         nppm(m+1)=npgen(vpac(ipp)-vpac0(ipp),1,20)
8992         do i=1,nppm(m+1)
8993          itypm(i,m+1)=1
8994          ippm(i,m+1)=ipp
8995         enddo
8996         do ipi=ipp+1,ia(1)
8997          ninc=npgen(vpac(ipi)-vpac0(ipi),0,20)
8998          if(ninc.ne.0)then
8999           nppm(m+1)=nppm(m+1)+ninc
9000           if(nppm(m+1).gt.legmax)then
9001            iret=1
9002            goto 31
9003           endif
9004           do i=nppm(m+1)-ninc+1,nppm(m+1)
9005            itypm(i,m+1)=1
9006            ippm(i,m+1)=ipi
9007           enddo
9008          endif
9009         enddo
9010         if(nppm(m+1).eq.1)goto 14
9011        endif
9012 
9013       elseif(jt.eq.3)then                    !1 cut fan
9014        nppm(m+1)=1
9015        ippm(1,m+1)=ipp
9016        if(itypom.eq.-1)then             !single cut Pomeron in the 'handle'
9017         factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
9018         wng=(vpacng-vpacpe)*factor/((vpac0(ipp)-vpacpe)*factor
9019      *  -(vpac(ipp)-vpac0(ipp))*(1.d0-factor))
9020         if(qgran(b10).le.wng.or.wng.lt.0.d0
9021      *  .or.xpomm(m+1)*sgap**2.gt..9d0)then
9022          itypm(1,m+1)=2          !>1 cut Pomerons in the 'handle'
9023         else
9024          itypm(1,m+1)=3          !rap-gap in the 'handle'
9025          wgpm(m+1)=(1.d0-factor)/factor
9026         endif
9027        elseif(itypom.eq.2)then          !>1 cut Pomerons in the 'handle'
9028         factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
9029         wng=vpacng*factor/(vpac0(ipp)*factor
9030      *  -(vpac(ipp)-vpac0(ipp))*(1.d0-factor))
9031         if(qgran(b10).le.wng.or.wng.lt.0.d0
9032      *  .or.xpomm(m+1)*sgap**2.gt..9d0)then
9033          if(qgran(b10).le.vpacpe/vpacng
9034      *   .or.xpomm(m+1)*sgap**2.gt..9d0)then
9035           itypm(1,m+1)=-1        !single cut Pomeron in the 'handle'
9036          else
9037           itypm(1,m+1)=2         !>1 cut Pomerons in the 'handle'
9038          endif
9039         else
9040          itypm(1,m+1)=3          !rap-gap in the 'handle'
9041          wgpm(m+1)=(1.d0-factor)/factor
9042         endif
9043        else                             !rap-gap in the 'handle'
9044         if(qgran(b10).le.vpacpe/vpacng
9045      *  .or.xpomm(m+1)*sgap**2.gt..9d0)then
9046          itypm(1,m+1)=-1         !single cut Pomeron in the 'handle'
9047         else
9048          itypm(1,m+1)=2          !>1 cut Pomerons in the 'handle'
9049         endif
9050        endif
9051 
9052        if(itypm(1,m+1).eq.-1)then     !single cut Pomeron in the 'handle'
9053         vplcp=min(vpacpe
9054      *  ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
9055         if(qgran(b10).le.vplcp/vpacpe
9056      *  .or.xpomm(m+1)*sgap**2.gt..9d0)itypm(1,m+1)=6 !single cut Pomeron
9057        endif
9058 
9059       elseif(jt.eq.5)then                    !cut 'leg'
9060        nppm(m+1)=1
9061        ippm(1,m+1)=ipp
9062        if(itypom.eq.4)then              !single cut Pomeron at the end
9063         if(xpomm(m+1)*sgap**2.ge.1.d0)stop'=4:xpomm(m+1)*sgap**2>1'
9064         factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
9065         wng=(vplcng-vplcpe)*factor/((vplc0-vplcpe)*factor
9066      *  -(vplc-vplc0)*(1.d0-factor))
9067         if(qgran(b10).le.wng.or.wng.lt.0.d0)then
9068          itypm(1,m+1)=7          !>1 cut Pomerons at the end
9069         else
9070          itypm(1,m+1)=5          !rap-gap at the end
9071          wgpm(m+1)=(1.d0-factor)/factor
9072         endif
9073        elseif(itypom.eq.5)then          !rap-gap at the end (cut or uncut loop)
9074         if(qgran(b10).le.vplcpe/vplcng
9075      *  .or.xpomm(m+1)*sgap**2.gt..9d0)then
9076          itypm(1,m+1)=4          !single cut Pomeron at the end
9077         else
9078          itypm(1,m+1)=7          !>1 cut Pomerons at the end
9079         endif
9080        elseif(itypom.eq.7)then          !>1 cut Pomerons at the end
9081         factor=exp(-vpac(ipp))*(1.d0-vvxp)*(1.d0-vvxpl)
9082         wng=vplcng*factor/(vplc0*factor-(vplc-vplc0)*(1.d0-factor))
9083         if(qgran(b10).le.wng.or.wng.lt.0.d0
9084      *  .or.xpomm(m+1)*sgap**2.gt..9d0)then
9085          if(qgran(b10).le.vplcpe/vplcng
9086      *   .or.xpomm(m+1)*sgap**2.gt..9d0)then
9087           itypm(1,m+1)=4         !single cut Pomeron at the end
9088          else
9089           itypm(1,m+1)=7         !>1 cut Pomerons at the end
9090          endif
9091         else
9092          itypm(1,m+1)=5          !rap-gap at the end
9093          wgpm(m+1)=(1.d0-factor)/factor
9094         endif
9095        endif
9096 
9097        if(itypm(1,m+1).eq.4)then        !single cut Pomeron at the end
9098         vplcp=min(vplcpe
9099      *  ,qgfani(1.d0/xpomm(m+1),bbp,vvxts,vvxp,vvxpl,iddp(ipp),icz,9))
9100         if(qgran(b10).le.vplcp/vplcpe
9101      *  .or.xpomm(m+1)*sgap**3.gt..9d0)itypm(1,m+1)=6 !single cut Pomeron
9102        endif
9103       endif
9104 
9105       if(nppm(m+1).eq.1.and.itypm(1,m+1).eq.6)then  !record single cut Pomeron
9106        nppr=nppr+1
9107        if(nppr.gt.legmax)then
9108         iret=1
9109         goto 31
9110        endif
9111        xpompi(nppr)=xpomm(m+1)
9112        vvxpi(nppr)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
9113      * *(1.d0-vvxtl)*exp(-vtac(it))
9114        ipompi(nppr)=ipp
9115        bpompi(nppr)=bbp
9116        nppm(m+1)=0
9117        if(debug.ge.4)write (moniou,209)nppr,ipp,bbp,xpompi(nppr)
9118      * ,vvxpi(nppr)
9119 
9120       elseif(nppm(m+1).gt.1)then
9121        i=0
9122 15     i=i+1
9123        ityp=itypm(i,m+1)
9124        if(ityp.eq.0)then
9125         ipi=ippm(i,m+1)
9126         bbi=(xa(ipi,1)+b-xxm(m+1))**2+(xa(ipi,2)-yym(m+1))**2
9127         vvxp=0.d0
9128         vvxpl=0.d0
9129         vvxp0=0.d0
9130         if(ia(1).gt.1)then
9131          do l=1,ia(1)
9132           if(l.lt.ipi)then
9133            vvxpl=vvxpl+vpac(l)
9134           elseif(l.gt.ipi)then
9135            vvxp=vvxp+vpac(l)
9136            vvxp0=vvxp0+vpac0(l)
9137           endif
9138          enddo
9139         endif
9140         vvxp=1.d0-exp(-vvxp)
9141         vvxpl=1.d0-exp(-vvxpl)
9142         vvxp0=1.d0-exp(-vvxp0)
9143 
9144         vpacng=min(vpac0(ipi)
9145      *  ,qgfani(1.d0/xpomm(m+1),bbi,vvxts,vvxp0,vvxpl,iddp(ipi),icz,4))
9146         vpacpe=min(vpacng
9147      *  ,qgfani(1.d0/xpomm(m+1),bbi,vvxts,vvxp0,vvxpl,iddp(ipi),icz,5))
9148         vplcp=min(vpacpe
9149      *  ,qgfani(1.d0/xpomm(m+1),bbi,vvxts,vvxp,vvxpl,iddp(ipi),icz,9))
9150 
9151         aks=qgran(b10)*vpac0(ipi)
9152         if(aks.le.vplcp.or.xpomm(m+1)*sgap**2.gt..9d0)then
9153          itypm(i,m+1)=6          !single cut Pomeron
9154         elseif(aks.lt.vpacpe)then
9155          itypm(i,m+1)=-1         !single cut Pomeron in the 'handle'
9156         elseif(aks.lt.vpacng)then
9157          itypm(i,m+1)=2          !>1 cut Pomerons in the 'handle'
9158         endif
9159 
9160         if(itypm(i,m+1).eq.6)then      !record single cut Pomeron
9161          nppr=nppr+1
9162          if(nppr.gt.legmax)then
9163           iret=1
9164           goto 31
9165          endif
9166          xpompi(nppr)=xpomm(m+1)
9167          vvxpi(nppr)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
9168      *   *(1.d0-vvxtl)*exp(-vtac(it))
9169          ipompi(nppr)=ipi
9170          bpompi(nppr)=bbi
9171          if(debug.ge.4)write (moniou,209)nppr,ipi,bbi,xpompi(nppr)
9172      *   ,vvxpi(nppr)
9173          nppm(m+1)=nppm(m+1)-1
9174          if(nppm(m+1).ge.i)then
9175           do l=i,nppm(m+1)
9176            ippm(l,m+1)=ippm(l+1,m+1)
9177            itypm(l,m+1)=itypm(l+1,m+1)
9178           enddo
9179          endif
9180          i=i-1
9181         endif
9182        endif
9183        if(i.lt.nppm(m+1))goto 15
9184       endif
9185 
9186       if(jt.eq.2.and.qgran(b10).lt.(1.d0-exp(-vpac(ipp)))*(1.d0-vvxpl)
9187      */((1.d0-exp(-vpac(ipp)))*(1.d0-vvxpl)+2.d0*vvxpl))then
9188        if(debug.ge.4)write (moniou,212)
9189        icdps=iddp(ipp)
9190        do icdp=1,2
9191         iddp(ipp)=icdp
9192         call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
9193      *  ,vvx,vvxp,vvxt,vvxpl,vvxtl,ipp,it)
9194         wdp(icdp,ipp)=(1.d0-exp(-vpac(ipp)))*(1.d0-vvxpl)
9195        enddo
9196        iddp(ipp)=icdps
9197       endif
9198 
9199       if(nppm(m+1).ne.0)then
9200        goto 9
9201       else
9202        goto 10
9203       endif
9204 
9205 20    continue
9206       if(debug.ge.3)write (moniou,214)nppr
9207       if(nptg0.eq.0)goto 31
9208 
9209 c target 'fans'
9210       m=0
9211       nppm(1)=nptg0
9212       xpomm(1)=xpomr
9213       wgpm(1)=wgtg0
9214       xxm(1)=xxp
9215       yym(1)=yyp
9216       do i=1,nptg0
9217        ippm(i,1)=iptg0(i)
9218        itypm(i,1)=itytg0(i)
9219       enddo
9220 
9221 21    m=m+1                                   !next level multi-Pomeron vertex
9222       if(m.gt.levmax)then
9223        iret=1
9224        goto 31
9225       endif
9226       ii(m)=0
9227 22    ii(m)=ii(m)+1                           !next cut fan in the vertex
9228       if(ii(m).gt.nppm(m))then                !all fans at the level considered
9229        m=m-1                                  !one level down
9230        if(m.eq.0)goto 31                      !all targ. fans considered
9231        goto 22
9232       endif
9233       l=ii(m)
9234       itt=ippm(l,m)                           !targ. index for the leg
9235       itypom=itypm(l,m)                       !type of the cut
9236       btm=(xb(itt,1)-xxm(m))**2+(xb(itt,2)-yym(m))**2  !b^2 for the leg
9237       if(debug.ge.4)write (moniou,216)ii(m),m,itt,btm
9238       if(xpomm(m)*scm.lt.sgap**2)stop'xpomm(m)*scm<sgap**2!'
9239 
9240       if(debug.ge.4)write (moniou,210)m
9241       xpomr0=min(dsqrt(xpomm(m)/scm),xpomm(m)/sgap)
9242       xpomr0=max(xpomr0,sgap/scm)
9243       if(itypom.eq.4)xpomr0=max(xpomr0,dsqrt(xpomm(m)*sgap/scm))
9244       rp1=(rq(iddt(itt),2)+alfp*dlog(xpomr0*scm))*4.d0*.0389d0
9245       rp2=alfp*dlog(xpomm(m)/xpomr0)*4.d0*.0389d0
9246       rp0=rp1*rp2/(rp1+rp2)
9247       bbt=btm*(rp1/(rp1+rp2))**2
9248       bbi=btm*(rp2/(rp1+rp2))**2
9249       call qgbdef(bbt,bbi,xb(itt,1),xb(itt,2),xxm(m),yym(m)
9250      *,xxp0,yyp0,1)
9251 
9252       call qgfdf(xxp0,yyp0,xpomr0,vpac,vtac
9253      *,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,itt)
9254       vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9255       viu=qgpini(xpomm(m)/xpomr0,bbi,0.d0,0.d0,2)
9256       vim=2.d0*min(viu,qgpini(xpomm(m)/xpomr0,bbi,0.d0,0.d0,8))
9257       if(itypom.eq.-1.or.itypom.eq.4)then      !single cut Pomeron at the end
9258        vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
9259      * *exp(-2.d0*vpac(ip)-2.d0*vtac(itt))
9260        vip=qgpini(xpomm(m)/xpomr0,bbi,vvxi,0.d0,16)*exp(-vim)
9261       elseif(itypom.eq.2.or.itypom.eq.7)then   !>1 cut Pomerons at the end
9262        vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
9263       else                                     !rap-gap at the end
9264        vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9265        vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(itt))
9266        viuu=qgpini(xpomm(m)/xpomr0,bbi,vvxtin,vvxpin,20)
9267      * *(1.d0-exp(-viu))
9268        viuc=max(0.d0,viuu-qgpini(xpomm(m)/xpomr0,bbi
9269      * ,vvxtin,vvxpin,21)*(1.d0-exp(-viu)))
9270        vicc=qgpini(xpomm(m)/xpomr0,bbi,vvxtin,vvxpin,22)*.5d0
9271      * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
9272        vicu=max(0.d0,qgpini(xpomm(m)/xpomr0,bbi,vvxtin,vvxpin,23)*.5d0
9273      * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
9274      * -vicc)
9275       endif
9276 
9277       if(itypom.le.3)then                         !cut 'fan'
9278        sumut=0.d0
9279        vvxt0=0.d0
9280        do i=1,ia(2)
9281         sumut=sumut+vtac(i)
9282        enddo
9283        vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9284        do i=1,ia(2)-itt+1
9285         iti=ia(2)-i+1
9286         bbl=(xb(iti,1)-xxp0)**2+(xb(iti,2)-yyp0)**2
9287         sumut=sumut-vtac(iti)
9288         vtac0(iti)=min(vtac(iti)
9289      *  ,qgfani(xpomr0*scm,bbl,1.d0-vvxs*exp(-sumut)
9290      *  ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(iti),2,3))
9291         if(iti.gt.itt)vvxt0=vvxt0+vtac0(iti)
9292        enddo
9293        vvxt0=1.d0-exp(-vvxt0)
9294        vtacng=min(vtac0(itt)
9295      * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,4))
9296        vtacpe=min(vtacng
9297      * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,5))
9298       else                                        !cut 'leg'
9299        vtlc=qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,7)
9300        vtlc0=min(vtlc
9301      * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,8))
9302        vtlcng=min(vtlc0
9303      * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,11))
9304        vtlcpe=min(vtlcng
9305      * ,qgfani(xpomr0*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,10))
9306       endif
9307 
9308       if(itypom.eq.-1)then         !'fan' (single cut Pomeron at the end)
9309        gb0=vip*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9310      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9311      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9312      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9313      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9314      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9315      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9316      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9317      * +2.d0*((vtac0(itt)-vtacpe)*exp(-vtac(itt))*(1.d0-vvxt)
9318      * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9319      * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
9320      * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
9321        gb0=gb0*40.d0
9322       elseif(itypom.eq.0)then      !'fan' (cut loop at the end - rapgap)
9323        gb0=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9324      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9325      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9326      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9327      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9328      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9329      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9330      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9331      * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9332      * *(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9333      * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9334      * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9335      * -2.d0*vicu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9336      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9337      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9338      * *(1.d0-vvx)*(1.d0-vvxp)
9339       elseif(itypom.eq.1)then      !'fan' (uncut end - rapgap)
9340        gb0=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9341      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9342      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9343      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9344      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9345      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9346      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9347      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9348      * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9349      * *(viuc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9350      * +viuu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9351      * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9352      * +2.d0*viuu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9353      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9354      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9355      * *(1.d0-vvx)*(1.d0-vvxp)
9356       elseif(itypom.eq.2)then      !'fan' (>1 cut Poms at the end)
9357        gb0=vimp*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9358      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9359      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9360      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9361      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9362      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9363      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9364      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9365      * +2.d0*(vtac0(itt)*exp(-vtac(itt))*(1.d0-vvxt)
9366      * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9367      * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
9368      * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
9369       elseif(itypom.eq.3)then      !'fan' (cut/uncut end - rapgap)
9370        gb0=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9371      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9372      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9373      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9374      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9375      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9376      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9377      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9378      * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9379      * *(vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9380      * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9381       elseif(itypom.eq.4)then      !'leg' (single cut Pomeron at the end)
9382        gb0=vip*((vtlc0-vtlcpe)*exp(-vtac(itt))*(1.d0-vvxt)
9383      * *(1.d0-vvxtl))*exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9384      * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
9385        if(gb0.eq.0.d0)then
9386         gb0=vip*vtlc0*exp(-vtac(itt))*(1.d0-vvxt)
9387      * *(1.d0-vvxtl)*exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9388      * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)  *.01d0
9389        endif
9390       elseif(itypom.eq.5)then      !'leg' (cut/uncut end - rapgap)
9391        gb0=vtlcng*exp(-2.d0*vtac(itt)-vpac(ip))
9392      * *(1.d0-vvxt)**2*(1.d0-vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
9393      * *(vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9394       elseif(itypom.eq.7)then      !'leg' (>1 cut Poms at the end)
9395        gb0=vimp*(vtlc0*exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9396      * -(vtlc-vtlc0)*(1.d0-exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)))
9397      * *exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9398      * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
9399       endif
9400       if(gb0.le.0.d0)then      !so170712
9401        iret=1
9402        goto 31
9403       endif
9404       nrej=0
9405 
9406 23    xpomm(m+1)=xpomm(m)/sgap/(xpomm(m)*scm/sgap**2)**qgran(b10)
9407       if(itypom.eq.4)xpomm(m+1)=xpomm(m)/sgap
9408      */(xpomm(m)*scm/sgap**3)**qgran(b10)
9409       rp1=(rq(iddt(itt),2)+alfp*dlog(xpomm(m+1)*scm))*4.d0*.0389d0
9410       rp2=alfp*dlog(xpomm(m)/xpomm(m+1))*4.d0*.0389d0
9411       rp=rp1*rp2/(rp1+rp2)
9412       z=qgran(b10)
9413       phi=pi*qgran(b10)
9414       b0=dsqrt(-rp*dlog(z))
9415       bbt=(dsqrt(btm)*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
9416       bbi=(dsqrt(btm)*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
9417       call qgbdef(bbt,bbi,xb(itt,1),xb(itt,2),xxm(m),yym(m)
9418      *,xxm(m+1),yym(m+1),int(1.5d0+qgran(b10)))   !coordinates for the vertex
9419 
9420       call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
9421      *,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,itt)
9422       vvxps=1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9423       viu=qgpini(xpomm(m)/xpomm(m+1),bbi,0.d0,0.d0,2)
9424       vim=2.d0*min(viu,qgpini(xpomm(m)/xpomm(m+1),bbi,0.d0,0.d0,8))
9425       if(itypom.eq.-1.or.itypom.eq.4)then      !single cut Pomeron at the end
9426        vvxi=1.d0-((1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt))**2
9427      * *exp(-2.d0*vpac(ip)-2.d0*vtac(itt))
9428        vip=qgpini(xpomm(m)/xpomm(m+1),bbi,vvxi,0.d0,16)*exp(-vim)
9429       elseif(itypom.eq.2.or.itypom.eq.7)then   !>1 cut Pomerons at the end
9430         vimp=max(0.d0,1.d0-exp(-vim)*(1.d0+vim))
9431       else                                     !rap-gap at the end
9432        vvxpin=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9433        vvxtin=1.d0-(1.d0-vvxt)*(1.d0-vvxtl)*exp(-vtac(itt))
9434        viuu=qgpini(xpomm(m)/xpomm(m+1),bbi,vvxtin,vvxpin,20)
9435      * *(1.d0-exp(-viu))
9436        viuc=max(0.d0,viuu-qgpini(xpomm(m)/xpomm(m+1),bbi
9437      * ,vvxtin,vvxpin,21)*(1.d0-exp(-viu)))
9438        vicc=qgpini(xpomm(m)/xpomm(m+1),bbi,vvxtin,vvxpin,22)*.5d0
9439      * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
9440        vicu=max(0.d0,qgpini(xpomm(m)/xpomm(m+1),bbi,vvxtin,vvxpin,23)
9441      * *((1.d0-exp(-viu))**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))
9442      * /2.d0-vicc)
9443       endif
9444 
9445       if(itypom.le.3)then                         !cut 'fan'
9446        sumut=0.d0
9447        vvxt0=0.d0
9448        do i=1,ia(2)
9449         sumut=sumut+vtac(i)
9450        enddo
9451        vvxs=(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9452        do i=1,ia(2)-itt+1
9453         iti=ia(2)-i+1
9454         bbl=(xb(iti,1)-xxm(m+1))**2+(xb(iti,2)-yym(m+1))**2
9455         sumut=sumut-vtac(iti)
9456         vtac0(iti)=min(vtac(iti)
9457      *  ,qgfani(xpomm(m+1)*scm,bbl,1.d0-vvxs*exp(-sumut)
9458      *  ,1.d0-exp(-vvxt0),1.d0-exp(-sumut),iddt(iti),2,3))
9459         if(iti.gt.itt)vvxt0=vvxt0+vtac0(iti)
9460        enddo
9461        vvxt0=1.d0-exp(-vvxt0)
9462 
9463        vtacng=min(vtac0(itt)
9464      * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,4))
9465        vtacpe=min(vtacng
9466      * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt0,vvxtl,iddt(itt),2,5))
9467       else                                        !cut 'leg'
9468        vtlc=qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,7)
9469        vtlc0=min(vtlc
9470      * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,8))
9471        vtlcng=min(vtlc0
9472      * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,11))
9473        vtlcpe=min(vtlcng
9474      * ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,10))
9475       endif
9476 
9477       if(itypom.eq.-1)then         !'fan' (single cut Pomeron at the end)
9478        gb=vip*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9479      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9480      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9481      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9482      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9483      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9484      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9485      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9486      * +2.d0*((vtac0(itt)-vtacpe)*exp(-vtac(itt))*(1.d0-vvxt)
9487      * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9488      * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
9489      * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
9490       elseif(itypom.eq.0)then      !'fan' (cut loop at the end - rapgap)
9491        gb=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9492      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9493      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9494      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9495      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9496      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9497      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9498      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9499      * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9500      * *(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9501      * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9502      * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9503      * -2.d0*vicu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9504      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9505      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9506      * *(1.d0-vvx)*(1.d0-vvxp)
9507       elseif(itypom.eq.1)then      !'fan' (uncut end - rapgap)
9508        gb=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9509      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9510      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9511      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9512      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9513      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9514      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9515      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9516      * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9517      * *(viuc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9518      * +viuu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9519      * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9520      * +2.d0*viuu*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9521      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9522      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9523      * *(1.d0-vvx)*(1.d0-vvxp)
9524       elseif(itypom.eq.2)then      !'fan' (>1 cut Poms at the end)
9525        gb=vimp*((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9526      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9527      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9528      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9529      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9530      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9531      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9532      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9533      * +2.d0*(vtac0(itt)*exp(-vtac(itt))*(1.d0-vvxt)
9534      * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9535      * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt))
9536      * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)*exp(-2.d0*vpac(ip))
9537       elseif(itypom.eq.3)then      !'fan' (cut/uncut end - rapgap)
9538        gb=((max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9539      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9540      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9541      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9542      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9543      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9544      * +((1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9545      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl)
9546      * +2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl))
9547      * *((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9548      * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
9549      * *exp(-vpac(ip))))*(1.d0-vvx)*(1.d0-vvxp)*exp(-vpac(ip))
9550      * -2.d0*(vicu+wgpm(m)*viuu)*(max(0.d0,exp(vtac(itt)-vtac0(itt))
9551      * -1.d0-(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9552      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9553      * *(1.d0-vvx)*(1.d0-vvxp)
9554       elseif(itypom.eq.4)then      !'leg' (single cut Pomeron at the end)
9555        gb=vip*((vtlc0-vtlcpe)*exp(-vtac(itt))*(1.d0-vvxt)
9556      * *(1.d0-vvxtl)-(vtlc-vtlc0)*(1.d0-exp(-vtac(itt))*(1.d0-vvxt)
9557      * *(1.d0-vvxtl)))*exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9558      * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
9559       elseif(itypom.eq.5)then      !'leg' (cut/uncut end - rapgap)
9560        gb=vtlcng*exp(-2.d0*vtac(itt)-vpac(ip))
9561      * *(1.d0-vvxt)**2*(1.d0-vvxtl)*(1.d0-vvx)*(1.d0-vvxp)
9562      * *((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9563      * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
9564      * *exp(-vpac(ip))))
9565       elseif(itypom.eq.7)then      !'leg' (>1 cut Poms at the end)
9566        gb=vimp*(vtlc0*exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9567      * -(vtlc-vtlc0)*(1.d0-exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)))
9568      * *exp(-vtac(itt)-2.d0*vpac(ip))*(1.d0-vvxt)
9569      * *(1.d0-vvx)*(1.d0-vvxp)**2*(1.d0-vvxpl)
9570       endif
9571       nrej=nrej+1
9572       gb=gb/gb0/z*rp/rp0  /10.d0
9573       if(qgran(b10).gt.gb.and.nrej.le.1000)goto 23
9574 
9575       if(itypom.eq.-1.or.itypom.eq.4)then    !'single cut Pomeron in the handle
9576        npin=npin+1
9577        if(npin.gt.npmax)then
9578         iret=1
9579         goto 31
9580        endif
9581        xpomim(npin)=1.d0/xpomm(m+1)/scm
9582        xpomip(npin)=xpomm(m)
9583        vvxim(npin)=vvxi
9584        bpomim(npin)=bbi
9585        if(debug.ge.4)write (moniou,211)npin,xpomip(npin),xpomim(npin)
9586      * ,vvxim(npin),bpomim(npin)
9587       elseif(itypom.eq.2.or.itypom.eq.7)then !>1 cut Pomerons in the handle
9588        ninc=npgen(vim,2,20)
9589        npin=npin+ninc
9590        if(npin.gt.npmax)then
9591         iret=1
9592         goto 31
9593        endif
9594        do i=npin-ninc+1,npin
9595         xpomim(i)=1.d0/xpomm(m+1)/scm
9596         xpomip(i)=xpomm(m)
9597         vvxim(i)=0.d0
9598         bpomim(i)=bbi
9599         if(debug.ge.4)write (moniou,211)i,xpomip(i),xpomim(i)
9600      *  ,vvxim(i),bpomim(i)
9601        enddo
9602       endif
9603 
9604       if(itypom.eq.-1)then      !single cut Pomeron in the 'handle'
9605        vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9606      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9607      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9608      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9609      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9610      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9611        vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9612      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9613        vv3=2.d0*((vtac0(itt)-vtacpe)*exp(-vtac(itt))*(1.d0-vvxt)
9614      * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9615      * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt)
9616        if(xpomm(m+1)*scm.lt.1.1d0*sgap**2.or.vv3.lt.0.d0)vv3=0.d0
9617        aks=(vv1+vv2+vv3)*qgran(b10)
9618        if(aks.lt.vv1)then
9619         jt=1                     !>1 cut fans
9620        elseif(aks.lt.vv1+vv2)then
9621         jt=2                     !diffr. cut
9622        else
9623         jt=3                     !1 cut fan
9624        endif
9625       elseif(itypom.eq.0)then      !cut 'loop' in the 'handle'
9626        vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9627      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9628      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9629      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9630      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9631      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))
9632      * *(1.d0-vvxp)*(1.d0-vvxpl)*(vicc+vicu)
9633      * /(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9634      * -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9635        vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9636      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9637        vv3=2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl)
9638        aks=(vv1+vv2+vv3)*qgran(b10)
9639        if(aks.lt.vv1)then
9640         jt=1                     !>1 cut fans
9641        elseif(aks.lt.vv1+vv2)then
9642         jt=2                     !diffr. cut
9643        else
9644         jt=3                     !1 cut fan
9645        endif
9646       elseif(itypom.eq.1)then    !uncut 'handle' (rap-gap)
9647        vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9648      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9649      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9650      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9651      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9652      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9653        vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9654      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9655        vv3=2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2*(1.d0-vvxtl)
9656        vv4=2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0-(vtac(itt)
9657      * -vtac0(itt)))*(1.d0-vvxt0)+(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))
9658      * *exp(-vtac(itt))*viuu/(viuu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
9659      * *exp(-vpac(ip)))+viuc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip)))
9660        if(xpomm(m+1)*scm.lt.1.1d0*sgap**2.or.vv4.lt.0.d0)vv4=0.d0
9661        aks=(vv1+vv2+vv3+vv4)*qgran(b10)
9662        if(aks.lt.vv1)then
9663         jt=1                     !>1 cut fans
9664        elseif(aks.lt.vv1+vv2)then
9665         jt=2                     !diffr. cut
9666        elseif(aks.lt.vv1+vv2+vv3)then
9667         jt=3                     !1 cut fan
9668        else
9669         jt=4                     !>1 cut 'handle' fans
9670        endif
9671       elseif(itypom.eq.2)then    !>1 cut Pomerons in the 'handle'
9672        vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))
9673      * *(1.d0+2.d0*vtac(itt)))+2.d0*vtac(itt)*exp(-2.d0*vtac(itt))
9674      * *(1.d0-(1.d0-vvxt)**2))*(1.d0-vvxtl)
9675      * -2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9676      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)
9677      * +(vtac(itt)-vtac0(itt))*(vvxt-vvxt0))*exp(-vtac(itt))
9678        vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9679      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9680        vv3=2.d0*(vtac0(itt)*exp(-vtac(itt))*(1.d0-vvxt)
9681      * *(1.d0-vvxtl)-(vtac(itt)-vtac0(itt))*(1.d0-exp(-vtac(itt))
9682      * *(1.d0-vvxt)*(1.d0-vvxtl)))*exp(-vtac(itt))*(1.d0-vvxt)
9683        aks=(vv1+vv2+vv3)*qgran(b10)
9684        if(aks.lt.vv1)then
9685         jt=1                     !>1 cut fans
9686        elseif(aks.lt.vv1+vv2)then
9687         jt=2                     !diffr. cut
9688        else
9689         jt=3                     !1 cut fan
9690        endif
9691       elseif(itypom.eq.3)then    !rap-gap in the 'handle'
9692        vv1=(max(0.d0,1.d0-exp(-2.d0*vtac(itt))*(1.d0+2.d0*vtac(itt)))
9693      * +2.d0*vtac(itt)*exp(-2.d0*vtac(itt))*(1.d0-(1.d0-vvxt)**2))
9694      * *(1.d0-vvxtl)-2.d0*(max(0.d0,exp(vtac(itt)-vtac0(itt))-1.d0
9695      * -(vtac(itt)-vtac0(itt)))*(1.d0-vvxt0)+(vtac(itt)-vtac0(itt))
9696      * *(vvxt-vvxt0))*exp(-vtac(itt)-vpac(ip))*(1.d0-vvxp)*(1.d0-vvxpl)
9697      * *(vicc+vicu+wgpm(m)*(viuu-viuc))
9698      * /((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9699      * -(vicu+wgpm(m)*viuu)*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)
9700      * *exp(-vpac(ip))))
9701        vv2=(1.d0-exp(-vtac(itt)))**2*(1.d0-vvxtl)
9702      * +2.d0*(1.d0-exp(-vtac(itt)))*vvxtl
9703        vv3=2.d0*vtacng*exp(-2.d0*vtac(itt))*(1.d0-vvxt)**2
9704      * *(1.d0-vvxtl)
9705        aks=(vv1+vv2+vv3)*qgran(b10)
9706        if(aks.lt.vv1)then
9707         jt=1                     !>1 cut fans
9708        elseif(aks.lt.vv1+vv2)then
9709         jt=2                     !diffr. cut
9710        else
9711         jt=3                     !1 cut fan
9712        endif
9713       else
9714        jt=5                      !cut leg
9715       endif
9716 
9717       nppm(m+1)=0
9718       wgpm(m+1)=0.d0
9719       if(jt.eq.1)then                        !>1 cut fans
9720        ntry=0
9721 24     ntry=ntry+1
9722        nphm=0
9723        if(itt.eq.ia(2).or.ntry.gt.100)then
9724         nppm(m+1)=npgen(2.d0*vtac(itt),2,20)
9725         do i=1,nppm(m+1)
9726          if(qgran(b10).le.vtac0(itt)/vtac(itt)
9727      *   .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9728           itypm(i,m+1)=0
9729          else
9730           nphm=nphm+1
9731           itypm(i,m+1)=1
9732          endif
9733          ippm(i,m+1)=itt
9734         enddo
9735         wh=(vtac(itt)/vtac0(itt)-1.d0)/nppm(m+1)
9736        else
9737         nppm(m+1)=npgen(2.d0*vtac(itt),1,20)
9738         do i=1,nppm(m+1)
9739          if(qgran(b10).le.vtac0(itt)/vtac(itt)
9740      *   .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9741           itypm(i,m+1)=0
9742          else
9743           nphm=nphm+1
9744           itypm(i,m+1)=1
9745          endif
9746          ippm(i,m+1)=itt
9747         enddo
9748         wh=(vtac(itt)/vtac0(itt)-1.d0)/nppm(m+1)
9749         do iti=itt+1,ia(2)
9750          ninc=npgen(2.d0*vtac(iti),0,20)
9751          if(ninc.ne.0)then
9752           nppm(m+1)=nppm(m+1)+ninc
9753           nh0=nphm
9754           if(nppm(m+1).gt.legmax)then
9755            iret=1
9756            goto 31
9757           endif
9758           do i=nppm(m+1)-ninc+1,nppm(m+1)
9759            if(qgran(b10).le.vtac0(iti)/vtac(iti)
9760      *     .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9761             itypm(i,m+1)=0
9762            else
9763             nphm=nphm+1
9764             itypm(i,m+1)=1
9765            endif
9766            ippm(i,m+1)=iti
9767           enddo
9768           if(ninc.gt.nphm-nh0)wh=(vtac(iti)/vtac0(iti)-1.d0)/ninc
9769          endif
9770         enddo
9771         if(nppm(m+1).eq.1)goto 24
9772        endif
9773 
9774        if(nphm+1.ge.nppm(m+1))then
9775         if(itypom.eq.-1.or.itypom.eq.1.or.itypom.eq.2)then
9776          gbt=1.d0-exp(vtac(itt)+(1.d0-nphm)*dlog(2.d0))
9777      *   /(1.d0-vvxt)/(1.d0-vvxtl)
9778         elseif(itypom.eq.0)then
9779          gbt=1.d0-(vicc+vicu)*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9780      *   /(vicc*(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9781      *   -vicu*(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9782      *   *exp(vtac(itt)+(1.d0-nphm)*dlog(2.d0))
9783      *   /(1.d0-vvxt)/(1.d0-vvxtl)
9784         elseif(itypom.eq.3)then
9785          gbt=1.d0-(vicc+vicu+wgpm(m)*(viuu-viuc))
9786      *   *(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))
9787      *   /((vicc-wgpm(m)*viuc)*(1.d0-vvxp)*(1.d0-vvxpl)
9788      *   *exp(-vpac(ip))-(vicu+wgpm(m)*viuu)
9789      *   *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpac(ip))))
9790      *   *exp(vtac(itt)+(1.d0-nphm)*dlog(2.d0))
9791      *   /(1.d0-vvxt)/(1.d0-vvxtl)
9792         else
9793          stop'unknown itypom'
9794         endif
9795         if(nphm.eq.nppm(m+1).and.qgran(b10).gt.gbt
9796      *  .or.nphm+1.eq.nppm(m+1).and.qgran(b10).gt.1.d0+wh*gbt)then
9797          ntry=0
9798           goto 24
9799         endif
9800        endif
9801 
9802       elseif(jt.eq.4)then                    !>1 cut 'handle' fans
9803        ntry=0
9804 25     ntry=ntry+1
9805        if(itt.eq.ia(2).or.ntry.gt.100)then
9806         nppm(m+1)=npgen(vtac(itt)-vtac0(itt),2,20)
9807         do i=1,nppm(m+1)
9808          itypm(i,m+1)=1
9809          ippm(i,m+1)=itt
9810         enddo
9811        else
9812         nppm(m+1)=npgen(vtac(itt)-vtac0(itt),1,20)
9813         do i=1,nppm(m+1)
9814          itypm(i,m+1)=1
9815          ippm(i,m+1)=itt
9816         enddo
9817         do iti=itt+1,ia(2)
9818          ninc=npgen(vtac(iti)-vtac0(iti),0,20)
9819          if(ninc.ne.0)then
9820           nppm(m+1)=nppm(m+1)+ninc
9821           if(nppm(m+1).gt.legmax)then
9822            iret=1
9823            goto 31
9824           endif
9825           do i=nppm(m+1)-ninc+1,nppm(m+1)
9826            itypm(i,m+1)=1
9827            ippm(i,m+1)=iti
9828           enddo
9829          endif
9830         enddo
9831         if(nppm(m+1).eq.1)goto 25
9832        endif
9833 
9834       elseif(jt.eq.3)then                    !1 cut fan
9835        nppm(m+1)=1
9836        ippm(1,m+1)=itt
9837        if(itypom.eq.-1)then             !single cut Pomeron in the 'handle'
9838         factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9839         wng=(vtacng-vtacpe)*factor/((vtac0(itt)-vtacpe)*factor
9840      *  -(vtac(itt)-vtac0(itt))*(1.d0-factor))
9841         if(qgran(b10).le.wng.or.wng.lt.0.d0
9842      *  .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9843          itypm(1,m+1)=2          !>1 cut Pomerons in the 'handle'
9844         else
9845          itypm(1,m+1)=3          !rap-gap in the 'handle'
9846          wgpm(m+1)=(1.d0-factor)/factor
9847         endif
9848        elseif(itypom.eq.2)then          !>1 cut Pomerons in the 'handle'
9849         factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9850         wng=vtacng*factor/(vtac0(itt)*factor
9851      *  -(vtac(itt)-vtac0(itt))*(1.d0-factor))
9852         if(qgran(b10).le.wng.or.wng.lt.0.d0
9853      *  .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9854          if(qgran(b10).le.vtacpe/vtacng
9855      *   .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9856           itypm(1,m+1)=-1        !single cut Pomeron in the 'handle'
9857          else
9858           itypm(1,m+1)=2         !>1 cut Pomerons in the 'handle'
9859          endif
9860         else
9861          itypm(1,m+1)=3          !rap-gap in the 'handle'
9862          wgpm(m+1)=(1.d0-factor)/factor
9863         endif
9864        else                             !rap-gap in the 'handle'
9865         if(qgran(b10).le.vtacpe/vtacng
9866      *  .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9867          itypm(1,m+1)=-1         !single cut Pomeron in the 'handle'
9868         else
9869          itypm(1,m+1)=2          !>1 cut Pomerons in the 'handle'
9870         endif
9871        endif
9872 
9873        if(itypm(1,m+1).eq.-1)then     !single cut Pomeron in the 'handle'
9874         vtlcp=min(vtacpe
9875      *  ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
9876         if(qgran(b10).le.vtlcp/vtacpe
9877      *  .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)itypm(1,m+1)=6 !single cut Pomeron
9878        endif
9879 
9880       elseif(jt.eq.5)then                    !cut 'leg'
9881        nppm(m+1)=1
9882        ippm(1,m+1)=itt
9883        if(itypom.eq.4)then              !single cut Pomeron at the end
9884         if(xpomm(m+1)*scm.le.sgap**2)stop'=4:xpomm(m+1)*scm<sgap**2'
9885         factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9886         wng=(vtlcng-vtlcpe)*factor/((vtlc0-vtlcpe)*factor
9887      *  -(vtlc-vtlc0)*(1.d0-factor))
9888         if(qgran(b10).le.wng.or.wng.lt.0.d0)then
9889          itypm(1,m+1)=7          !>1 cut Pomerons at the end
9890         else
9891          itypm(1,m+1)=5          !rap-gap at the end
9892          wgpm(m+1)=(1.d0-factor)/factor
9893         endif
9894        elseif(itypom.eq.5)then          !rap-gap at the end (cut or uncut loop)
9895         if(qgran(b10).le.vtlcpe/vtlcng
9896      *  .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9897          itypm(1,m+1)=4          !single cut Pomeron at the end
9898         else
9899          itypm(1,m+1)=7          !>1 cut Pomerons at the end
9900         endif
9901        elseif(itypom.eq.7)then          !>1 cut Pomerons at the end
9902         factor=exp(-vtac(itt))*(1.d0-vvxt)*(1.d0-vvxtl)
9903         wng=vtlcng*factor/(vtlc0*factor-(vtlc-vtlc0)*(1.d0-factor))
9904         if(qgran(b10).le.wng.or.wng.lt.0.d0
9905      *  .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9906          if(qgran(b10).le.vtlcpe/vtlcng
9907      *   .or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9908           itypm(1,m+1)=4         !single cut Pomeron at the end
9909          else
9910           itypm(1,m+1)=7         !>1 cut Pomerons at the end
9911          endif
9912         else
9913          itypm(1,m+1)=5          !rap-gap at the end
9914          wgpm(m+1)=(1.d0-factor)/factor
9915         endif
9916        endif
9917 
9918        if(itypm(1,m+1).eq.4)then        !single cut Pomeron at the end
9919         vtlcp=min(vtlcpe
9920      *  ,qgfani(xpomm(m+1)*scm,bbt,vvxps,vvxt,vvxtl,iddt(itt),2,9))
9921         if(qgran(b10).le.vtlcp/vtlcpe
9922      *  .or.xpomm(m+1)*scm.lt.1.1d0*sgap**3)itypm(1,m+1)=6 !single cut Pomeron
9923        endif
9924       endif
9925 
9926       if(nppm(m+1).eq.1.and.itypm(1,m+1).eq.6)then  !record single cut Pomeron
9927        nptg=nptg+1
9928        if(nptg.gt.legmax)then
9929         iret=1
9930         goto 31
9931        endif
9932        xpomti(nptg)=xpomm(m+1)
9933        vvxti(nptg)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
9934      * *(1.d0-vvxtl)*exp(-vpac(ip))
9935        ipomti(nptg)=itt
9936        bpomti(nptg)=bbt
9937        nppm(m+1)=0
9938        if(debug.ge.4)write (moniou,217)nptg,itt,bbt,xpomti(nptg)
9939      * ,vvxti(nptg)
9940 
9941       elseif(nppm(m+1).gt.1)then
9942        i=0
9943 26     i=i+1
9944        ityp=itypm(i,m+1)
9945        if(ityp.eq.0)then
9946         iti=ippm(i,m+1)
9947         bbi=(xb(iti,1)-xxm(m+1))**2+(xb(iti,2)-yym(m+1))**2
9948         vvxt=0.d0
9949         vvxtl=0.d0
9950         vvxt0=0.d0
9951         if(ia(2).gt.1)then
9952          do l=1,ia(2)
9953           if(l.lt.iti)then
9954            vvxtl=vvxtl+vtac(l)
9955           elseif(l.gt.iti)then
9956            vvxt=vvxt+vtac(l)
9957            vvxt0=vvxt0+vtac0(l)
9958           endif
9959          enddo
9960         endif
9961         vvxt=1.d0-exp(-vvxt)
9962         vvxtl=1.d0-exp(-vvxtl)
9963         vvxt0=1.d0-exp(-vvxt0)
9964 
9965         vtacng=min(vtac0(iti)
9966      *  ,qgfani(xpomm(m+1)*scm,bbi,vvxps,vvxt0,vvxtl,iddt(iti),2,4))
9967         vtacpe=min(vtacng
9968      *  ,qgfani(xpomm(m+1)*scm,bbi,vvxps,vvxt0,vvxtl,iddt(iti),2,5))
9969         vtlcp=min(vtacpe
9970      *  ,qgfani(xpomm(m+1)*scm,bbi,vvxps,vvxt,vvxtl,iddt(iti),2,9))
9971 
9972         aks=qgran(b10)*vtac0(iti)
9973         if(aks.le.vtlcp.or.xpomm(m+1)*scm.lt.1.1d0*sgap**2)then
9974          itypm(i,m+1)=6          !single cut Pomeron
9975         elseif(aks.lt.vtacpe)then
9976          itypm(i,m+1)=-1         !single cut Pomeron in the 'handle'
9977         elseif(aks.lt.vtacng)then
9978          itypm(i,m+1)=2          !>1 cut Pomerons in the 'handle'
9979         endif
9980 
9981         if(itypm(i,m+1).eq.6)then      !record single cut Pomeron
9982          nptg=nptg+1
9983          if(nptg.gt.legmax)then
9984           iret=1
9985           goto 31
9986          endif
9987          xpomti(nptg)=xpomm(m+1)
9988          vvxti(nptg)=1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*(1.d0-vvxt)
9989      *   *(1.d0-vvxtl)*exp(-vpac(ip))
9990          ipomti(nptg)=iti
9991          bpomti(nptg)=bbi
9992          if(debug.ge.4)write (moniou,217)nptg,iti,bbi,xpomti(nptg)
9993      *   ,vvxti(nptg)
9994          nppm(m+1)=nppm(m+1)-1
9995          if(nppm(m+1).ge.i)then
9996           do l=i,nppm(m+1)
9997            ippm(l,m+1)=ippm(l+1,m+1)
9998            itypm(l,m+1)=itypm(l+1,m+1)
9999           enddo
10000          endif
10001          i=i-1
10002         endif
10003        endif
10004        if(i.lt.nppm(m+1))goto 26
10005       endif
10006 
10007       if(jt.eq.2.and.qgran(b10).lt.(1.d0-exp(-vtac(itt)))*(1.d0-vvxtl)
10008      */((1.d0-exp(-vtac(itt)))*(1.d0-vvxtl)+2.d0*vvxtl))then
10009        if(debug.ge.4)write (moniou,212)
10010        icdts=iddt(itt)
10011        do icdt=1,2
10012         iddt(itt)=icdt
10013         call qgfdf(xxm(m+1),yym(m+1),xpomm(m+1),vpac,vtac
10014      *  ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,itt)
10015         wdt(icdt,itt)=(1.d0-exp(-vtac(itt)))*(1.d0-vvxtl)
10016        enddo
10017        iddt(itt)=icdts
10018       endif
10019 
10020       if(nppm(m+1).ne.0)then
10021        goto 21
10022       else
10023        goto 22
10024       endif
10025 31    continue
10026       if(debug.ge.2)write (moniou,219)nppr,nptg,npin,iret
10027 
10028 201   format(2x,'qg3pdf - configuration for multi-Pomeron'
10029      *,'/diffractive contributions'
10030      */4x,i2,'-th proj. nucleon',2x,i2,'-th targ. nucleon')
10031 202   format(2x,'qg3pdf: problem with initial normalization'
10032      *,' -> rejection')
10033 203   format(2x,'qg3pdf: normalization of rejection function - ',e10.3)
10034 204   format(2x,'qg3pdf: xpomr=',e10.3,2x,'bbpr=',e10.3,2x,'bbtg=',e10.3
10035      *,2x,'gb=',e10.3)
10036 205   format(2x,'qg3pdf: xpomr=',e10.3,2x,'bbpr=',e10.3,2x,'bbtg=',e10.3
10037      *,2x,'xxp=',e10.3,2x,'yyp=',e10.3)
10038 206   format(2x,'qg3pdf: main vertex, nppr0=',i3,2x,'nptg0=',i3)
10039 208   format(2x,'qg3pdf: check',i3,'-th cut fan at ',i2,'-th level,'
10040      *,' proj. index - ',i3,2x,'b^2=',e10.3)
10041 209   format(2x,'qg3pdf: ',i3,'-th proj. leg, proj. index - ',i3
10042      *,2x,'b^2=',e10.3,2x,'xpomr=',e10.3,2x,'vvx=',e10.3)
10043 210   format(2x,'qg3pdf: new vertex at ',i3,'-th level')
10044 211   format(2x,'qg3pdf: ',i3,'-th interm. Pomeron'
10045      */4x,'xpomip=',e10.3,2x,'xpomim=',e10.3
10046      *,2x,'vvxim=',e10.3,2x,'bpomim=',e10.3)
10047 212   format(2x,'qg3pdf: diffractive cut')
10048 214   format(2x,'qg3pdf: total number of proj. legs - ',i3)
10049 216   format(2x,'qg3pdf: check',i3,'-th cut fan at ',i2,'-th level,'
10050      *,' targ. index - ',i3,2x,'b^2=',e10.3)
10051 217   format(2x,'qg3pdf: ',i3,'-th targ. leg, targ. index - ',i3
10052      *,2x,'b^2=',e10.3,2x,'xpomr=',e10.3,2x,'vvx=',e10.3)
10053 219   format(2x,'qg3pdf - end',2x,'number of proj. legs:',i3
10054      *,2x,'number of targ. legs:',i3
10055      */4x,'number of interm. Pomerons:',i3,'return flag:',i2)
10056       return
10057       end
10058 
10059 c------------------------------------------------------------------------
10060       subroutine qgloolc(sy,xp,bb,icdp,icz,iqq,fan1,fan0)
10061 c-----------------------------------------------------------------------
10062 c qgloolc - unintegrated Pomeron leg eikonal with loops
10063 c sy   - Pomeron mass squared,
10064 c xp   - Pomeron LC momentum,
10065 c bb   - impact parameter squared,
10066 c icz  - hadron class
10067 c iqq=1 - tot
10068 c iqq=2 - soft Pomeron
10069 c iqq=3 - (soft+g)-Pomeron
10070 c-----------------------------------------------------------------------
10071       implicit double precision (a-h,o-z)
10072       integer debug
10073       common /qgarr6/  pi,bm,amws
10074       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10075       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10076       common /qgarr18/ alm,qt0,qtf,betp,dgqq
10077       common /qgarr26/ factk,fqscal
10078       common /qgarr43/ moniou
10079       common /qgdebug/  debug
10080       common /arr3/   x1(7),a1(7)
10081 
10082       fan0=0.d0
10083       fan1=0.d0
10084       if(sy.le.sgap*max(1.d0,xp*sgap))goto 1
10085 
10086       do ix1=1,7
10087       do mx1=1,2
10088        xpomr=min(xp,1.d0/sgap)/(sy/sgap/max(1.d0,xp*sgap))
10089      * **(.5d0+x1(ix1)*(mx1-1.5d0))
10090        rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
10091        rp1=alfp*log(xpomr*sy/xp)*4.d0*.0389d0
10092        rp2=rp*rp1/(rp+rp1)
10093       do ix2=1,7
10094       do mx2=1,2
10095        z=.5d0+x1(ix2)*(mx2-1.5d0)
10096        bb0=-rp2*log(z)
10097       do ix3=1,7
10098       do mx3=1,2
10099        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
10100        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
10101      * +bb0*sin(phi)**2
10102        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
10103      * +bb0*sin(phi)**2
10104 
10105        v1icn=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,8)
10106        if(iqq.eq.1)then
10107         vpl=qglegc(xp/xpomr,xp,bb2,0.d0,icdp,icz,1)
10108         v1ic0=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,7)
10109         v1ic1=min(v1ic0,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,6))
10110         v1ic=min(v1ic1,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,5))
10111        elseif(iqq.eq.2)then
10112         vpl=qglegc(xp/xpomr,xp,bb2,0.d0,icdp,icz,0)
10113         v1ic0=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,15)
10114         v1ic1=min(v1ic0,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,14))
10115         v1ic=min(v1ic1,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,13))
10116        elseif(iqq.eq.3)then
10117         vpl=qglegc(xp/xpomr,xp,bb2,0.d0,icdp,icz,2)
10118         v1ic0=qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,7)
10119         v1ic1=min(v1ic0,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,6))
10120         v1ic=min(v1ic1,qgpini(xpomr*sy/xp,bb1,0.d0,0.d0,5))
10121        else
10122          vpl=0.d0
10123          v1ic0=0.d0
10124          v1ic1=0.d0
10125          v1ic=0.d0
10126          stop 'Should no happen in qgloolc !'
10127        endif
10128        fan1=fan1+a1(ix1)*a1(ix2)*a1(ix3)/z*rp2
10129      * *vpl*(v1ic*exp(-2.d0*v1icn)-v1ic1)
10130        fan0=fan0+a1(ix1)*a1(ix2)*a1(ix3)/z*rp2*vpl*(v1ic1-v1ic0)
10131       enddo
10132       enddo
10133       enddo
10134       enddo
10135       enddo
10136       enddo
10137       fan0=fan0/8.d0*pi*r3p/.0389d0/g3p**3
10138      **dlog(sy/sgap/max(1.d0,xp*sgap))
10139       fan1=fan1/8.d0*pi*r3p/.0389d0/g3p**3
10140      **dlog(sy/sgap/max(1.d0,xp*sgap))
10141 1     continue
10142       if(iqq.eq.1)then
10143        dleg=qglegc(sy,xp,bb,0.d0,icdp,icz,1)
10144       elseif(iqq.eq.2)then
10145        dleg=qglegc(sy,xp,bb,0.d0,icdp,icz,0)
10146       elseif(iqq.eq.3)then
10147        dleg=qglegc(sy,xp,bb,0.d0,icdp,icz,2)
10148       else
10149        dleg=0.d0
10150        stop 'Should no happen in qgloolc !'
10151       endif
10152       fan0=fan0+dleg
10153       fan1=fan1+dleg
10154       return
10155       end
10156 
10157 c------------------------------------------------------------------------
10158       double precision function qglscr(sy,xp,bb,vvx,icdp,icz,iqq)
10159 c-----------------------------------------------------------------------
10160 c vvx  = 1 - exp[-sum_j chi_targ(j) - sum_{i.ne.I} chi_proj(i)]
10161 c-----------------------------------------------------------------------
10162       implicit double precision (a-h,o-z)
10163       integer debug
10164       common /qgarr6/  pi,bm,amws
10165       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10166       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10167       common /qgarr18/ alm,qt0,qtf,betp,dgqq
10168       common /qgarr26/ factk,fqscal
10169       common /qgarr43/ moniou
10170       common /qgdebug/  debug
10171       common /arr3/   x1(7),a1(7)
10172 
10173       qglscr=0.d0
10174       if(sy.le.sgap*max(1.d0,xp*sgap))goto 1
10175 
10176       do ix1=1,7
10177       do mx1=1,2
10178        xpomr1=min(xp,1.d0/sgap)/(sy/sgap/max(1.d0,xp*sgap))
10179      * **(.5d0+x1(ix1)*(mx1-1.5d0))
10180        rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
10181        rp1=alfp*log(xpomr1*sy/xp)*4.d0*.0389d0
10182        rp2=rp*rp1/(rp+rp1)
10183        do ix2=1,7
10184        do mx2=1,2
10185         z=.5d0+x1(ix2)*(mx2-1.5d0)
10186         bb0=-rp2*log(z)
10187        do ix3=1,7
10188        do mx3=1,2
10189         phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
10190         bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
10191      *  +bb0*sin(phi)**2
10192         bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
10193      *  +bb0*sin(phi)**2
10194 
10195         vicn=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,8)
10196         vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
10197         if(iqq.eq.1)then
10198          vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,9)
10199          vi=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,5)
10200         elseif(iqq.eq.2)then
10201          vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,10)
10202          vi=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,13)
10203         elseif(iqq.eq.3)then
10204          vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,11)
10205          vi=qgpini(xpomr1*sy/xp,bb1,0.d0,0.d0,5)
10206         else
10207          vpl=0.d0
10208          vi=0.d0
10209          stop 'Should no happen in qglscr !'
10210         endif
10211 
10212         dpx=vpl*vi*exp(-2.d0*vicn)
10213      *  *((1.d0-vvx)**2*exp(-2.d0*vpf)-1.d0)
10214         qglscr=qglscr+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
10215        enddo
10216        enddo
10217        enddo
10218        enddo
10219       enddo
10220       enddo
10221       qglscr=qglscr/8.d0*pi*r3p/.0389d0/g3p**3
10222      **dlog(sy/sgap/max(1.d0,xp*sgap))
10223 1     continue
10224       if(iqq.eq.1)then
10225        qglscr=qglscr+qglegc(sy,xp,bb,0.d0,icdp,icz,3)
10226       elseif(iqq.eq.2)then
10227        qglscr=qglscr+qglegc(sy,xp,bb,0.d0,icdp,icz,5)
10228       elseif(iqq.eq.3)then
10229        qglscr=qglscr+qglegc(sy,xp,bb,0.d0,icdp,icz,7)
10230       endif
10231       return
10232       end
10233 
10234 c------------------------------------------------------------------------
10235       double precision function qglh(sy,xp,bb,vvx,icdp,icz,iqq)
10236 c-----------------------------------------------------------------------
10237       implicit double precision (a-h,o-z)
10238       integer debug
10239       common /qgarr6/  pi,bm,amws
10240       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10241       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10242       common /qgarr18/ alm,qt0,qtf,betp,dgqq
10243       common /qgarr19/ ahl(3)
10244       common /qgarr26/ factk,fqscal
10245       common /qgarr43/ moniou
10246       common /qgdebug/    debug
10247       common /arr3/     x1(7),a1(7)
10248 
10249       qglh=0.d0
10250       if(sy.le.max(1.d0,xp*sgap))goto 1
10251 
10252       do ix1=1,7
10253       do mx1=1,2
10254        xpomr1=min(xp,1.d0/sgap)/(sy/max(1.d0,xp*sgap))
10255      * **(.5d0+x1(ix1)*(mx1-1.5d0))
10256        rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
10257        rp1=alfp*log(xpomr1*sy/xp)*4.d0*.0389d0
10258        rp2=rp*rp1/(rp+rp1)
10259        do ix2=1,7
10260        do mx2=1,2
10261         z=.5d0+x1(ix2)*(mx2-1.5d0)
10262         bb0=-rp2*log(z)
10263        do ix3=1,7
10264        do mx3=1,2
10265         phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
10266         bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
10267      *  +bb0*sin(phi)**2
10268         bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
10269      *  +bb0*sin(phi)**2
10270 
10271         vi=qgppdi(xp/xpomr1/sy,iqq)
10272         vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
10273         vpl=qglegc(xp/xpomr1,xp,bb2,vvx,icdp,icz,10)
10274 
10275         dpx=vpl*vi*((1.d0-vvx)**2*exp(-2.d0*vpf)-1.d0)
10276      *  *(xpomr1/xp)**dels*exp(bb2/rp)*rp
10277         qglh=qglh+a1(ix1)*a1(ix2)*a1(ix3)*dpx
10278        enddo
10279        enddo
10280        enddo
10281        enddo
10282       enddo
10283       enddo
10284       qglh=qglh/8.d0*pi*r3p/.0389d0/g3p**2*dlog(sy/max(1.d0,xp*sgap))
10285      */fp(icz)/cd(icdp,icz)/qgppdi(1.d0/sy,iqq)
10286 
10287 1     qglh=qglh+1.d0
10288       return
10289       end
10290 
10291 c------------------------------------------------------------------------
10292       double precision function qgcutp(sy,xp,xm,bb,vvx
10293      *,icdp,icdt,icz,iqq)
10294 c-----------------------------------------------------------------------
10295 c qgcutp - unintegrated cut Pomeron eikonal
10296 c sy         - Pomeron mass squared,
10297 c xp,xm      - Pomeron light cone momenta,
10298 c b          - squared impact parameter,
10299 c vvx        - relative strenth of nuclear screening corrections,
10300 c icdp, icdt - proj. and targ. diffractive eigenstates,
10301 c icz        - hadron class
10302 c iqq=1 - total,
10303 c iqq=2 - soft contribution,
10304 c iqq=3  - (soft+gg+gq+qq) contribution
10305 c iqq=4  - (soft+gg+qq) contribution
10306 c-----------------------------------------------------------------------
10307       implicit double precision (a-h,o-z)
10308       integer debug
10309       common /qgarr6/  pi,bm,amws
10310       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10311       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10312       common /qgarr18/ alm,qt0,qtf,betp,dgqq
10313       common /qgarr19/ ahl(3)
10314       common /qgarr25/ ahv(3)
10315       common /qgarr26/ factk,fqscal
10316       common /qgarr43/ moniou
10317       common /qgdebug/  debug
10318       common /arr3/   x1(7),a1(7)
10319 
10320       qgcutp=0.d0
10321       if(sy.le.max(1.d0,xp*sgap)*max(1.d0,xm*sgap))goto 2
10322 
10323       do ix1=1,7
10324       do mx1=1,2
10325        xpomr1=xp/max(1.d0,xp*sgap)/(sy/max(1.d0,xp*sgap)
10326      * /max(1.d0,xm*sgap))**(.5+x1(ix1)*(mx1-1.5))
10327        rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
10328        rp2=(rq(icdt,2)+alfp*log(xpomr1*sy/xp/xm))*4.d0*.0389d0
10329        rp=rp1*rp2/(rp1+rp2)
10330       do ib1=1,7
10331       do mb1=1,2
10332        z=.5d0+x1(ib1)*(mb1-1.5d0)
10333        bb0=-rp*dlog(z)
10334       do ib2=1,7
10335       do mb2=1,2
10336        phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
10337        bb1=(dsqrt(bb)*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2
10338      * +bb0*sin(phi)**2
10339        bb2=(dsqrt(bb)*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2
10340      * +bb0*sin(phi)**2
10341 
10342        vpf0=qgfani(1.d0/xpomr1,bb1,vvx,0.d0,0.d0,icdp,icz,1)
10343        vtf0=qgfani(xpomr1*sy/xp/xm,bb2,vvx,0.d0,0.d0,icdt,2,1)
10344        n=1
10345 1      n=n+1
10346        vpf=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*exp(-vtf0)
10347      * ,0.d0,0.d0,icdp,icz,1)
10348        vtf=qgfani(xpomr1*sy/xp/xm,bb2,1.d0-(1.d0-vvx)*exp(-vpf0)
10349      * ,0.d0,0.d0,icdt,2,1)
10350        if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.le.50)
10351      * then
10352         vpf0=vpf
10353         vtf0=vtf
10354         goto 1
10355        endif
10356 
10357        if(iqq.eq.1)then
10358         vplt=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,1)
10359         vtlt=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,1)
10360         vpltloop0=min(vplt,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,4))
10361         vpltloop=min(vpltloop0,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,3))
10362         vtltloop0=min(vtlt,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,4))
10363         vtltloop=min(vtltloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
10364      *  ,icdt,2,3))
10365         vpltscr=min(vpltloop,qglegc(xp/xpomr1,xp,bb1
10366      *  ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,9))
10367         vtltscr=min(vtltloop,qglegc(xpomr1*sy/xp,xm,bb2
10368      *  ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,9))
10369 
10370         dpx=(vpltscr*vtltloop+vtltscr*vpltloop)
10371      *  *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
10372      *  +vplt*(vtltloop-vtltloop0)+vtlt*(vpltloop-vpltloop0)
10373        elseif(iqq.eq.2)then
10374         vpls=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,0)
10375         vtls=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,0)
10376         vplsloop0=min(vpls,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,6))
10377         vplsloop=min(vplsloop0,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,5))
10378         vtlsloop0=min(vtls,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,6))
10379         vtlsloop=min(vtlsloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
10380      *  ,icdt,2,5))
10381         vplsscr=min(vplsloop,qglegc(xp/xpomr1,xp,bb1
10382      *  ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,10))
10383         vtlsscr=min(vtlsloop,qglegc(xpomr1*sy/xp,xm,bb2
10384      *  ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,10))
10385 
10386         dpx=(vplsscr*vtlsloop+vtlsscr*vplsloop)
10387      *  *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
10388      *  +vpls*(vtlsloop-vtlsloop0)+vtls*(vplsloop-vplsloop0)
10389        elseif(iqq.eq.3)then
10390         vplq=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,2)
10391         vtlt=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,1)
10392         vplqloop0=min(vplq,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,8))
10393         vplqloop=min(vplqloop0
10394      *  ,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,7))
10395         vtltloop0=min(vtlt,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,4))
10396         vtltloop=min(vtltloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
10397      *  ,icdt,2,3))
10398         vplqscr=min(vplqloop,qglegc(xp/xpomr1,xp,bb1
10399      *  ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,11))
10400         vtltscr=min(vtltloop,qglegc(xpomr1*sy/xp,xm,bb2
10401      *  ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,9))
10402 
10403         dpx=(vplqscr*vtltloop+vtltscr*vplqloop)
10404      *  *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
10405      *  +vplq*(vtltloop-vtltloop0)+vtlt*(vplqloop-vplqloop0)
10406        elseif(iqq.eq.4)then
10407         vplq=qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,2)
10408         vtlq=qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,2)
10409         vplqloop0=min(vplq,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,8))
10410         vplqloop=min(vplqloop0
10411      *  ,qglegc(xp/xpomr1,xp,bb1,0.d0,icdp,icz,7))
10412         vtlqloop0=min(vtlq,qglegc(xpomr1*sy/xp,xm,bb2,0.d0,icdt,2,8))
10413         vtlqloop=min(vtlqloop0,qglegc(xpomr1*sy/xp,xm,bb2,0.d0
10414      *  ,icdt,2,7))
10415         vplqscr=min(vplqloop,qglegc(xp/xpomr1,xp,bb1
10416      *  ,1.d0-(1.d0-vvx)*exp(-vtf),icdp,icz,11))
10417         vtlqscr=min(vtlqloop,qglegc(xpomr1*sy/xp,xm,bb2
10418      *  ,1.d0-(1.d0-vvx)*exp(-vpf),icdt,2,11))
10419 
10420         dpx=(vplqscr*vtlqloop+vtlqscr*vplqloop)
10421      *  *((1.d0-vvx)**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
10422      *  +vplq*(vtlqloop-vtlqloop0)+vtlq*(vplqloop-vplqloop0)
10423        else
10424         dpx=0.d0
10425        endif
10426        qgcutp=qgcutp+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
10427       enddo
10428       enddo
10429       enddo
10430       enddo
10431       enddo
10432       enddo
10433       qgcutp=qgcutp/16.d0*(r3p*pi/.0389d0)/g3p**3
10434      **dlog(sy/max(1.d0,xp*sgap)/max(1.d0,xm*sgap))
10435 
10436 2     continue
10437       rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy/xp/xm))
10438       vs=sy**dels*fp(icz)*fp(2)*sigs/rp
10439      **exp(-bb/rp/4.d0/.0389d0)*cd(icdp,icz)*cd(icdt,2)
10440       vgg=qgpsh(sy,xp,xm,bb,icdp,icdt,icz,0)
10441       vqq=qgpomc(sy,xp,xm,bb,0.d0,icdp,icdt,icz,5)
10442       vqg=qgpsh(sy,xp,xm,bb,icdp,icdt,icz,1)
10443      */dsqrt(xp)*(1.d0-xp)**(ahv(icz)-ahl(icz))
10444       vgq=qgpsh(sy,xp,xm,bb,icdp,icdt,icz,2)
10445      */dsqrt(xm)*(1.d0-xm)**(ahv(2)-ahl(2))
10446       if(iqq.eq.1)then
10447        qgcutp=qgcutp+vs+vgg+vqg+vgq+vqq
10448       elseif(iqq.eq.2)then
10449        qgcutp=qgcutp+vs
10450       elseif(iqq.eq.3)then
10451        qgcutp=qgcutp+vs+vgg+vgq+vqq
10452       elseif(iqq.eq.4)then
10453        qgcutp=qgcutp+vs+vgg+vqq
10454       endif
10455       return
10456       end
10457 
10458 c=============================================================================
10459       double precision function qgpsh(sy,xpp,xpm,bb,icdp,icdt,icz,iqq)
10460 c-----------------------------------------------------------------------------
10461 c qgpsh - unintegrated semihard Pomeron eikonal
10462 c sy         - Pomeron mass squared,
10463 c xpp, xpm   - Pomeron LC momenta,
10464 c b          - impact parameter,
10465 c icdp, icdt - proj. and targ. diffractive eigenstates,
10466 c icz        - hadron class,
10467 c iqq        - type of the hard interaction (0-gg, 1-q_vg, 2-gq_v)
10468 c-----------------------------------------------------------------------------
10469       implicit double precision (a-h,o-z)
10470       integer debug
10471       common /qgarr6/  pi,bm,amws
10472       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10473       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10474       common /qgarr18/ alm,qt0,qtf,betp,dgqq
10475       common /qgarr26/ factk,fqscal
10476       common /qgarr43/ moniou
10477       common /arr3/   x1(7),a1(7)
10478       common /qgdebug/  debug
10479 
10480       if(debug.ge.3)write (moniou,201)sy,xpp,xpm,b,vvx0,icdp,icdt
10481      *,icz,iqq
10482       qgpsh=0.d0
10483       s2min=4.d0*fqscal*qt0               !energy threshold for hard interaction
10484       if(s2min/sy.ge.1.d0)then
10485        if(debug.ge.4)write (moniou,202)qgpsh
10486        return
10487       endif
10488 
10489       if(iqq.ne.2)then
10490        icv=icz
10491        icq=2
10492        xp=xpp
10493        xm=xpm
10494        icdv=icdp
10495        icdq=icdt
10496       else
10497        icv=2
10498        icq=icz
10499        xp=xpm
10500        xm=xpp
10501        icdq=icdp
10502        icdv=icdt
10503       endif
10504 
10505       xmin=(s2min/sy)**(delh-dels)
10506       do i=1,7
10507       do m=1,2
10508        z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
10509      * **(1.d0/(delh-dels))
10510        ww=z1*sy
10511        sjqq=qgjit(qt0,qt0,ww,2,2)
10512        sjqg=qgjit(qt0,qt0,ww,1,2)
10513        sjgg=qgjit(qt0,qt0,ww,1,1)
10514 
10515        if(iqq.eq.0)then                                !gg-Pomeron
10516         st2=0.d0
10517         do j=1,7
10518         do k=1,2
10519          xx=.5d0*(1.d0+x1(j)*(2*k-3))
10520          xph=z1**xx
10521          xmh=z1/xph
10522 
10523          glu1=qgppdi(xph,0)
10524          sea1=qgppdi(xph,1)
10525          glu2=qgppdi(xmh,0)
10526          sea2=qgppdi(xmh,1)
10527          st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
10528      *   +sea1*sea2*sjqq)
10529         enddo
10530         enddo
10531         rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xpp*xpm*z1)
10532         qgpsh=qgpsh-a1(i)*dlog(z1)/z1**delh*st2
10533      *  *exp(-bb/rh/4.d0/.0389d0)/rh
10534 
10535        else                                !qg-Pomeron
10536         xmh=z1
10537         glu=qgppdi(xmh,0)
10538         sea=qgppdi(xmh,1)
10539         rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xm*xmh)
10540 
10541         fst=(glu*sjqg+sea*sjqq)
10542      *  *(qggrv(xp,qt0,icv,1)+qggrv(xp,qt0,icv,2))/dsqrt(xp)
10543      *  *exp(-bb/rh/4.d0/.0389d0)/rh
10544         qgpsh=qgpsh+a1(i)/z1**delh*fst
10545        endif
10546       enddo
10547       enddo
10548       qgpsh=qgpsh*(1.d0-xmin)/(delh-dels)
10549       if(iqq.eq.0)then
10550        qgpsh=qgpsh*rr**2*fp(icz)*fp(2)*factk/2.d0*pi
10551      * *cd(icdp,icz)*cd(icdt,2)
10552       else
10553        qgpsh=qgpsh*rr*fp(icq)*factk/4.d0
10554      * *cd(icdp,icz)*cd(icdt,2)
10555       endif
10556       if(debug.ge.4)write (moniou,202)qgpsh
10557 
10558 201   format(2x,'qgpsh - unintegrated semihard Pomeron eikonal:'
10559      */4x,'sy=',e10.3,2x,'xpp=',e10.3,2x,'xpm=',e10.3,2x,'b=',e10.3
10560      */4x,'vvx0=',e10.3,2x,'icdp=',i1,2x,'icdt=',i1,2x,'icz=',i1
10561      *,2x,'iqq=',i1)
10562 202   format(2x,'qgpsh=',e10.3)
10563       return
10564       end
10565 
10566 c------------------------------------------------------------------------
10567       double precision function qglegc(sy,xp,bb,vvx,icdp,icz,iqq)
10568 c-----------------------------------------------------------------------
10569 c qglegc - interpolation of cut Pomeron leg eikonal
10570 c sy   - Pomeron mass squared,
10571 c xp   - Pomeron LC momentum,
10572 c bb   - squared impact parameter,
10573 c vvx - relative strenth of screening corrections (0<vvx<1),
10574 c icdp - diffractive eigenstate for the hadron,
10575 c icz  - hadron class
10576 c iqq=0  - soft Pomeron,
10577 c iqq=1  - total Pomeron,
10578 c iqq=2  - (soft+g)-Pomeron,
10579 c iqq=3  - total loop,
10580 c iqq=4  - total loop with single Pomeron end,
10581 c iqq=5  - soft loop,
10582 c iqq=6  - soft loop with single Pomeron end,
10583 c iqq=7  - (soft+g)-loop,
10584 c iqq=8  - (soft+g)-loop with single Pomeron end,
10585 c iqq=9  - total screened,
10586 c iqq=10 - soft screened,
10587 c iqq=11 - (soft+g)-screened
10588 c iqq=12 - g-distribution,
10589 c iqq=13 - q-distribution
10590 c-----------------------------------------------------------------------
10591       implicit double precision (a-h,o-z)
10592       integer debug
10593       dimension wk(3),wj(3),wi(3),wz(3)
10594       common /qgarr6/  pi,bm,amws
10595       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10596       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10597       common /qgarr18/ alm,qt0,qtf,betp,dgqq
10598       common /qgarr19/ ahl(3)
10599       common /qgarr20/ spmax
10600       common /qgarr25/ ahv(3)
10601       common /qgarr26/ factk,fqscal
10602       common /qgarr35/ qlegc0(51,10,11,6,8),qlegc(51,10,11,11,30)
10603       common /qgarr43/ moniou
10604       common /qgdebug/  debug
10605 
10606       if(debug.ge.3)write (moniou,201)sy,xp,bb,vvx,icdp,icz,iqq
10607 
10608       qglegc=0.d0
10609       clegm=0.d0
10610       rp=(rq(icdp,icz)+alfp*log(max(1.d0,sy/xp)))*4.d0*.0389d0
10611       z=exp(-bb/rp)
10612       if(iqq.eq.0.or.iqq.le.11.and.sy.le.sgap*max(1.d0,xp*sgap)
10613      *  .or.iqq.gt.11.and.sy.le.max(1.d0,xp*sgap))then
10614        if(iqq.le.11)then
10615         qglegc=sy**dels*fp(icz)*sigs*g3p/rp*4.d0*.0389d0*z*cd(icdp,icz)
10616        else
10617         qglegc=qgppdi(1.d0/sy,iqq-12)
10618        endif
10619        if(debug.ge.4)write (moniou,202)qglegc
10620        return
10621       endif
10622 
10623       if(z.gt..2d0)then
10624        zz=5.d0*z+6.d0
10625       else
10626        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
10627       endif
10628       jz=min(9,int(zz))
10629       jz=max(1,jz)
10630       if(zz.lt.1.d0)then
10631        wz(2)=zz-jz
10632        wz(1)=1.d0-wz(2)
10633        izmax=2
10634       else
10635        if(jz.eq.6)jz=5
10636        wz(2)=zz-jz
10637        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
10638        wz(1)=1.d0-wz(2)+wz(3)
10639        wz(2)=wz(2)-2.d0*wz(3)
10640        izmax=3
10641       endif
10642 
10643       if(iqq.le.11)then
10644        yl=max(0.d0,dlog(sy/xp/sgap**2)/dlog(spmax/sgap**2))*50.d0+1.d0
10645       else
10646        yl=max(0.d0,dlog(sy/xp/sgap)/dlog(spmax/sgap))*50.d0+1.d0
10647       endif
10648       k=max(1,int(yl))
10649       k=min(k,49)
10650       wk(2)=yl-k
10651       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
10652       wk(1)=1.d0-wk(2)+wk(3)
10653       wk(2)=wk(2)-2.d0*wk(3)
10654       iymax=3
10655 
10656       if(xp.lt..2d0)then
10657        if(iqq.le.11)then
10658         xl=6.d0-5.d0*log(5.d0*xp)/log(5.d0*xp*sgap/sy)
10659        elseif(sy.gt.1.01d0*xp*sgap)then
10660         xl=6.d0-5.d0*log(5.d0*xp)/log(xp*sgap/sy)
10661        else
10662         xl=1.d0
10663        endif
10664       else
10665        xl=5.d0*xp+5.d0
10666       endif
10667       i=min(8,int(xl))
10668       i=max(1,i)
10669       if(i.eq.5)i=4
10670       wi(2)=xl-i
10671       wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
10672       wi(1)=1.d0-wi(2)+wi(3)
10673       wi(2)=wi(2)-2.d0*wi(3)
10674       ixmax=3
10675 
10676       if(iqq.lt.9)then
10677        do k1=1,iymax
10678         k2=k+k1-1
10679        do i1=1,ixmax
10680         i2=i+i1-1
10681        do l1=1,izmax
10682         l2=jz+l1-1
10683         qglegc=qglegc+qlegc0(k2,i2,l2,icdp+2*(icz-1),iqq)
10684      *  *wk(k1)*wi(i1)*wz(l1)
10685        enddo
10686        enddo
10687        enddo
10688        if(zz.lt.1.d0)then
10689         do k1=1,iymax
10690          k2=k+k1-1
10691         do i1=1,ixmax
10692          i2=i+i1-1
10693          clegm=clegm+qlegc0(k2,i2,1,icdp+2*(icz-1),iqq)*wk(k1)*wi(i1)
10694         enddo
10695         enddo
10696         qglegc=min(qglegc,clegm)
10697        endif
10698       else
10699        vl=max(1.d0,vvx*10.d0+1.d0)
10700        if(vl.lt.2.d0)then
10701         j=1
10702         wj(2)=vl-j
10703         wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
10704         wj(1)=1.d0-wj(2)+wj(3)
10705         wj(2)=wj(2)-2.d0*wj(3)
10706         ivmax=3
10707        else
10708         j=min(int(vl),10)
10709         wj(2)=vl-j
10710         wj(1)=1.d0-wj(2)
10711         ivmax=2
10712        endif
10713 
10714        do l1=1,izmax
10715         l2=jz+l1-1
10716        do j1=1,ivmax
10717         j2=j+j1-1
10718        do i1=1,ixmax
10719         i2=i+i1-1
10720        do k1=1,iymax
10721         k2=k+k1-1
10722         qglegc=qglegc+qlegc(k2,i2,j2,l2,icdp+2*(icz-1)+6*(iqq-9))
10723      *  *wk(k1)*wi(i1)*wz(l1)*wj(j1)
10724        enddo
10725        enddo
10726        enddo
10727        enddo
10728        if(zz.lt.1.d0)then
10729         do j1=1,ivmax
10730          j2=j+j1-1
10731         do i1=1,ixmax
10732          i2=i+i1-1
10733         do k1=1,iymax
10734          k2=k+k1-1
10735          clegm=clegm+qlegc(k2,i2,j2,1,icdp+2*(icz-1)+6*(iqq-9))
10736      *   *wk(k1)*wi(i1)*wj(j1)
10737         enddo
10738         enddo
10739         enddo
10740         qglegc=min(qglegc,clegm)
10741        endif
10742       endif
10743       if(iqq.le.11)then
10744        qglegc=exp(qglegc)*qgls(sy,xp,bb,icdp,icz)
10745       else
10746        qglegc=exp(qglegc)*qgppdi(1.d0/sy,iqq-12)
10747       endif
10748       if(debug.ge.4)write (moniou,202)qglegc
10749 
10750 201   format(2x,'qglegc - interpolation of Pomeron leg eikonal:'
10751      */4x,'sy=',e10.3,2x,'xp=',e10.3,2x,'b^2=',e10.3,2x,'vvx=',e10.3
10752      *,2x,'icdp=',i1,2x,'icz=',i1,2x,'iqq=',i1)
10753 202   format(2x,'qglegc=',e10.3)
10754       return
10755       end
10756 
10757 c=============================================================================
10758       double precision function qgpomc(sy,xp,xm,bb,vvx
10759      *,icdp,icdt,icz,iqq)
10760 c-----------------------------------------------------------------------
10761 c qgpomc - unintegrated cut Pomeron eikonal
10762 c sy         - Pomeron mass squared,
10763 c xp,xm      - Pomeron light cone momenta,
10764 c bb         - squared impact parameter,
10765 c vvx        - relative strenth of nuclear screening corrections,
10766 c icdp, icdt - proj. and targ. diffractive eigenstates,
10767 c icz        - hadron class
10768 c iqq=1 - total,
10769 c iqq=2 - soft contribution,
10770 c iqq=3 - qg contribution
10771 c iqq=4 - gq contribution
10772 c iqq=5 - qq contribution
10773 c-----------------------------------------------------------------------
10774       implicit double precision (a-h,o-z)
10775       integer debug
10776       dimension wk(3),wi(3),wj(3),wz(3),wm(3)
10777       common /qgarr6/  pi,bm,amws
10778       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
10779       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
10780       common /qgarr18/ alm,qt0,qtf,betp,dgqq
10781       common /qgarr19/ ahl(3)
10782       common /qgarr20/ spmax
10783       common /qgarr25/ ahv(3)
10784       common /qgarr26/ factk,fqscal
10785       common /qgarr38/ qpomc(11,100,11,11,48)
10786       common /qgarr43/ moniou
10787       common /qgdebug/  debug
10788 
10789       if(debug.ge.3)write (moniou,201)sy,xp,xm,bb,vvx
10790      *,icdp,icdt,icz,iqq
10791 
10792       qgpomc=0.d0
10793       pomm=0.d0
10794       if(iqq.eq.5)then                          !qq contribution
10795        s2min=4.d0*fqscal*qt0
10796        if(sy.gt.1.001d0*s2min.and.xp.lt..99d0.and.xm.lt..99d0)then
10797         sj=qgjit(qt0,qt0,sy,2,2)
10798         qgpomc=sj*factk*(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))
10799      *  *(qggrv(xm,qt0,2,1)+qggrv(xm,qt0,2,2))/xp/xm
10800      *  *(1.d0-xp)**(ahv(icz)-ahl(icz))*(1.d0-xm)**(ahv(2)-ahl(2))
10801      *  *exp(-bb/(4.d0*.0389d0*(rq(icdp,icz)+rq(icdt,2))))
10802      *  /(8.d0*pi*(rq(icdp,icz)+rq(icdt,2)))*cd(icdp,icz)*cd(icdt,2)
10803        endif
10804        if(debug.ge.4)write (moniou,202)qgpomc
10805        return
10806       endif
10807 
10808       rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy/xp/xm))*4.d0*.0389d0
10809       z=exp(-bb/rp)
10810       if(sy.le.max(1.d0,xp*sgap)*max(1.d0,xm*sgap)*1.01d0)then
10811        qgpomc=sy**dels*fp(icz)*fp(2)*sigs*z/rp
10812      * *4.d0*.0389d0*cd(icdp,icz)*cd(icdt,2)
10813        return
10814       endif
10815 
10816       if(z.gt..2d0)then
10817        zz=5.d0*z+6.d0
10818       else
10819        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
10820       endif
10821       jz=min(9,int(zz))
10822       jz=max(1,jz)
10823       if(zz.lt.1.d0)then
10824        wz(2)=zz-jz
10825        wz(1)=1.d0-wz(2)
10826        izmax=2
10827       else
10828        if(jz.eq.6)jz=5
10829        wz(2)=zz-jz
10830        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
10831        wz(1)=1.d0-wz(2)+wz(3)
10832        wz(2)=wz(2)-2.d0*wz(3)
10833        izmax=3
10834       endif
10835 
10836       yl=max(0.d0,dlog(sy/xp/xm/sgap**2)
10837      */dlog(spmax/sgap**2))*10.d0+1.d0
10838       k=max(1,int(yl))
10839       k=min(k,9)
10840       wk(2)=yl-k
10841       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
10842       wk(1)=1.d0-wk(2)+wk(3)
10843       wk(2)=wk(2)-2.d0*wk(3)
10844       iymax=3
10845 
10846       if(xp.lt..2d0)then
10847        xl1=6.d0-5.d0*log(5.d0*xp)/log(5.d0*sgap*xp*xm/sy)
10848       else
10849        xl1=5.d0*xp+5.d0
10850       endif
10851       i=min(8,int(xl1))
10852       i=max(1,i)
10853       if(i.eq.5)i=4
10854       wi(2)=xl1-i
10855       wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
10856       wi(1)=1.d0-wi(2)+wi(3)
10857       wi(2)=wi(2)-2.d0*wi(3)
10858       ix1max=3
10859 
10860       if(sgap/sy*xm.gt..99d0)then
10861        j=1
10862        wj(1)=1.d0
10863        ix2max=1
10864       else
10865        if(xm.lt..2d0)then
10866         xl2=6.d0-5.d0*log(5.d0*xm)/log(sgap/sy*xm)
10867        else
10868         xl2=5.d0*xm+5.d0
10869        endif
10870        j=min(8,int(xl2))
10871        j=max(1,j)
10872        if(j.eq.5)j=4
10873        wj(2)=xl2-j
10874        wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
10875        wj(1)=1.d0-wj(2)+wj(3)
10876        wj(2)=wj(2)-2.d0*wj(3)
10877        ix2max=3
10878       endif
10879 
10880       ml=icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1)
10881       if(vvx.eq.0.d0)then                     !hadron-proton collision
10882        do l1=1,izmax
10883         l2=jz+l1-1
10884        do j1=1,ix2max
10885         j2=j+j1-2
10886        do i1=1,ix1max
10887         i2=i+i1-1
10888        do k1=1,iymax
10889         k2=k+k1-1
10890         qgpomc=qgpomc+qpomc(k2,i2+10*j2,l2,1,ml)
10891      *  *wk(k1)*wi(i1)*wj(j1)*wz(l1)
10892        enddo
10893        enddo
10894        enddo
10895        enddo
10896        if(zz.lt.1.d0)then
10897         do j1=1,ix2max
10898          j2=j+j1-2
10899         do i1=1,ix1max
10900          i2=i+i1-1
10901         do k1=1,iymax
10902          k2=k+k1-1
10903          pomm=pomm+qpomc(k2,i2+10*j2,1,1,ml)*wk(k1)*wi(i1)*wj(j1)
10904         enddo
10905         enddo
10906         enddo
10907         qgpomc=min(qgpomc,pomm)
10908        endif
10909 
10910       else                                    !hA (AA) collision
10911        vl=max(1.d0,vvx*10.d0+1.d0)
10912        if(vl.lt.2.d0)then
10913         m=1
10914         wm(2)=vl-m
10915         wm(3)=wm(2)*(wm(2)-1.d0)*.5d0
10916         wm(1)=1.d0-wm(2)+wm(3)
10917         wm(2)=wm(2)-2.d0*wm(3)
10918         ivmax=3
10919        else
10920         m=min(int(vl),10)
10921         wm(2)=vl-m
10922         wm(1)=1.d0-wm(2)
10923         ivmax=2
10924        endif
10925 
10926        do m1=1,ivmax
10927         m2=m+m1-1
10928        do l1=1,izmax
10929         l2=jz+l1-1
10930        do j1=1,ix2max
10931         j2=j+j1-2
10932        do i1=1,ix1max
10933         i2=i+i1-1
10934        do k1=1,iymax
10935         k2=k+k1-1
10936         qgpomc=qgpomc+qpomc(k2,i2+10*j2,l2,m2,ml)
10937      *  *wk(k1)*wi(i1)*wj(j1)*wz(l1)*wm(m1)
10938        enddo
10939        enddo
10940        enddo
10941        enddo
10942        enddo
10943        if(zz.lt.1.d0)then
10944         do m1=1,ivmax
10945          m2=m+m1-1
10946         do j1=1,ix2max
10947          j2=j+j1-2
10948         do i1=1,ix1max
10949          i2=i+i1-1
10950         do k1=1,iymax
10951          k2=k+k1-1
10952          pomm=pomm+qpomc(k2,i2+10*j2,1,m2,ml)
10953      *   *wk(k1)*wi(i1)*wj(j1)*wm(m1)
10954         enddo
10955         enddo
10956         enddo
10957         enddo
10958         qgpomc=min(qgpomc,pomm)
10959        endif
10960       endif
10961       qgpomc=exp(qgpomc)*z
10962       if(debug.ge.4)write (moniou,202)qgpomc
10963 
10964 201   format(2x,'qgpomc - unintegrated cut Pomeron eikonal:'
10965      */4x,'sy=',e10.3,2x,'xp=',e10.3,2x,'xm=',e10.3,2x,'b^2=',e10.3
10966      */4x,'vvx=',e10.3,2x,'icdp=',i1,2x,'icdt=',i1,2x,'icz=',i1
10967      *,2x,'iqq=',i1)
10968 202   format(2x,'qgpomc=',e10.3)
10969       return
10970       end
10971 
10972 c=============================================================================
10973       subroutine qgsha(nbpom,ncola,ncolb,iret)
10974 c-----------------------------------------------------------------------------
10975 c qgsha - inelastic interaction (energy sharing and particle production)
10976 c nbpom - number of Pomeron blocks (nucleon(hadron)-nucleon collisions),
10977 c ncola - number of inel.-wounded proj. nucleons,
10978 c ncolb - number of inel.-wounded targ. nucleons
10979 c-----------------------------------------------------------------------------
10980       implicit double precision (a-h,o-z)
10981       integer debug
10982       parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900
10983      *,legmax=900,njmax=50000)
10984       dimension wppr0(iapmax),wmtg0(iapmax),wppr1(iapmax),wmtg1(iapmax)
10985      *,wppr2(iapmax),wmtg2(iapmax),izp(iapmax),izt(iapmax)
10986      *,ila(iapmax),ilb(iapmax),lva(iapmax),lvb(iapmax)
10987      *,lqa0(iapmax),lqb0(iapmax),ncola(iapmax),ncolb(iapmax)
10988      *,ncola0(iapmax),ncolb0(iapmax)
10989      *,xpomp0(npnmax,iapmax),xpomt0(npnmax,iapmax)
10990      *,xpopin0(npmax,npbmax),xpomin0(npmax,npbmax)
10991       common /qgarr1/  ia(2),icz,icp
10992       common /qgarr2/  scm,wp0,wm0
10993       common /qgarr6/  pi,bm,amws
10994       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
10995       common /qgarr9/  iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
10996      *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
10997      *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
10998      *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
10999      *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
11000      *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
11001      *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
11002      *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
11003       common /qgarr11/ b10
11004       common /qgarr12/ nsp
11005       common /qgarr13/ nsf,iaf(iapmax)
11006       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
11007       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
11008       common /qgarr18/ alm,qt0,qtf,betp,dgqq
11009       common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
11010      *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
11011      *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
11012      *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
11013      *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
11014      *,bpomin(npmax,npbmax)
11015       common /qgarr26/ factk,fqscal
11016       common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
11017       common /qgarr40/ xppr(npnmax,iapmax),xmtg(npnmax,iapmax)
11018       common /qgarr43/ moniou
11019       common /qgdebug/  debug
11020       external qgran
11021 
11022       if(debug.ge.1)write (moniou,201)nbpom             !so161205
11023       nsp0=nsp
11024 
11025       do j=1,ia(1)
11026        if(lqa(j).ne.0)then
11027         do i=1,lqa(j)
11028          if(idnpi(i,j).ne.0)xpomp0(i,j)=xpompr(i,j)
11029         enddo
11030        endif
11031       enddo
11032       do j=1,ia(2)
11033        if(lqb(j).ne.0)then
11034         do i=1,lqb(j)
11035          if(idnti(i,j).ne.0)xpomt0(i,j)=xpomtg(i,j)
11036         enddo
11037        endif
11038       enddo
11039       if(nbpom.ne.0)then
11040        do nb=1,nbpom                            !loop over collisions
11041         if(npomin(nb).ne.0)then
11042          do np=1,npomin(nb)         !loop over interm. Pomerons in the collision
11043           xpopin0(np,nb)=xpopin(np,nb)
11044           xpomin0(np,nb)=xpomin(np,nb)
11045          enddo
11046         endif
11047        enddo
11048       endif
11049       iret=0
11050       nret=0
11051 
11052 1     nsp=nsp0
11053       nj=0
11054 
11055       if(iret.ne.0)then             !rejection during energy-sharing
11056        nret=nret+1
11057        if(nret.gt.100)return        !too many rejections -> redo configuration
11058       endif
11059 
11060       do j=1,ia(1)
11061        if(lqa(j).ne.0)then
11062         do i=1,lqa(j)
11063          if(idnpi(i,j).ne.0)xpompr(i,j)=xpomp0(i,j)
11064         enddo
11065        endif
11066       enddo
11067       do j=1,ia(2)
11068        if(lqb(j).ne.0)then
11069         do i=1,lqb(j)
11070          if(idnti(i,j).ne.0)xpomtg(i,j)=xpomt0(i,j)
11071         enddo
11072        endif
11073       enddo
11074       if(nbpom.ne.0)then
11075        do nb=1,nbpom                            !loop over collisions
11076         if(npomin(nb).ne.0)then
11077          do np=1,npomin(nb)         !loop over interm. Pomerons in the collision
11078           xpopin(np,nb)=xpopin0(np,nb)
11079           xpomin(np,nb)=xpomin0(np,nb)
11080          enddo
11081         endif
11082        enddo
11083       endif
11084 
11085 c-------------------------------------------------
11086 c initial nucleon (hadron) types
11087       if(ia(1).ne.1)then
11088        do i=1,ia(1)
11089         izp(i)=int(2.5d0+qgran(b10))   !i-th projectile nucleon type
11090        enddo
11091       else
11092        izp(1)=icp                      !projectile hadron type
11093       endif
11094       if(ia(2).ne.1)then
11095        do i=1,ia(2)
11096         izt(i)=int(2.5d0+qgran(b10))   !i-th target nucleon type
11097        enddo
11098       else
11099        izt(1)=2                        !target proton
11100       endif
11101 
11102       do i=1,ia(1)
11103        lqa0(i)=lqa(i)
11104        lva(i)=0
11105        ncola0(i)=ncola(i)
11106       enddo
11107       do i=1,ia(2)
11108        lqb0(i)=lqb(i)
11109        lvb(i)=0
11110        ncolb0(i)=ncolb(i)
11111       enddo
11112 
11113 c-------------------------------------------------
11114 c energy-momentum sharing between Pomerons
11115       if(nbpom.ne.0)then
11116        if(debug.ge.1)write (moniou,202)
11117        call qgprox(0)        !initial x-configuration
11118        gbl0=qgweix(nbpom)    !log-weight for the initial x-configuration
11119        nrej=0
11120        nchange=0
11121        gbnorm=.1d0
11122        gbhmax=-1000.d0
11123 
11124 2      continue
11125        call qgprox(1)        !proposed x-configuration
11126        gbl=qgweix(nbpom)     !log-weight for the proposed x-configuration
11127        gbh=gbl-gbl0-gbnorm   !log of acceptance probability
11128        gbhmax=max(gbhmax,gbh)
11129 
11130        if(debug.ge.5)write (moniou,203)gbh,nrej,nchange
11131        if(gbh.lt.-50.d0.or.qgran(b10).gt.exp(gbh))then
11132         nrej=nrej+1
11133         if(nrej.gt.100)then               !too many rejections
11134          nrej=0
11135          nchange=nchange+1
11136          gbnorm=gbnorm+gbhmax+.5d0        !new normalization of acceptance
11137          gbhmax=-1000.d0
11138          if(debug.ge.4)write (moniou,204)nchange
11139         endif
11140         goto 2                            !rejection
11141        endif
11142       endif
11143 
11144 c-------------------------------------------------
11145 c leading remnant LC momenta
11146       if(debug.ge.1)write (moniou,205)
11147       do i=1,ia(1)                        !loop over proj. nucleons
11148        wppr0(i)=wp0
11149        wppr1(i)=0.d0
11150        wppr2(i)=0.d0
11151        if(lqa(i).ne.0)then
11152         do l=1,lqa(i)                     !loop over constituent partons
11153          wppr0(i)=wppr0(i)-wp0*xppr(l,i)  !subtract Pomeron LC momentum
11154          if(wppr0(i).lt.0.d0)then
11155           wppr0(i)=0.d0
11156          endif
11157         enddo
11158        endif
11159       enddo
11160       do i=1,ia(2)                        !loop over targ. nucleons
11161        wmtg0(i)=wm0
11162        wmtg1(i)=0.d0
11163        wmtg2(i)=0.d0
11164        if(lqb(i).ne.0)then
11165         do l=1,lqb(i)                     !loop over constituent partons
11166          wmtg0(i)=wmtg0(i)-wm0*xmtg(l,i)  !subtract Pomeron LC momentum
11167          if(wmtg0(i).lt.-1.d-15)stop'w^-<0!!!'
11168          wmtg0(i)=max(0.d0,wmtg0(i))
11169         enddo
11170        endif
11171       enddo
11172 
11173 c-------------------------------------------------
11174 c momentum conservation (correction for 3p-vertexes)
11175       if(debug.ge.1)write (moniou,206)
11176       if(nbpom.ne.0)then
11177        do nb=1,nbpom                            !loop over collisions
11178         ip=ias(nb)                              !proj. index
11179         it=ibs(nb)                              !targ. index
11180         if(nqs(nb).ne.0)then
11181          do np=1,nqs(nb)             !loop over single Pomerons in the collision
11182           lnp=nnpr(np,nb)                       !proj. constituent parton index
11183           lnt=nntg(np,nb)                       !targ. constituent parton index
11184           wppr1(ip)=wppr1(ip)+xppr(lnp,ip)*wp0  !count Pomeron LC momentum
11185           wmtg1(it)=wmtg1(it)+xmtg(lnt,it)*wm0  !count Pomeron LC momentum
11186          enddo
11187         endif
11188         if(npomin(nb).ne.0)then
11189          do np=1,npomin(nb)         !loop over interm. Pomerons in the collision
11190           xpp=xpopin(np,nb)
11191           xpm=xpomin(np,nb)
11192           if(xpp*xpm*scm.gt.1.d0)then
11193            wppr2(ip)=wppr2(ip)+xpp*wp0          !count Pomeron LC momentum
11194            wmtg2(it)=wmtg2(it)+xpm*wm0          !count Pomeron LC momentum
11195           else
11196            xpopin(np,nb)=0.d0
11197            xpomin(np,nb)=0.d0
11198           endif
11199          enddo
11200         endif
11201         if(npompr(nb).ne.0)then
11202          do np=1,npompr(nb)       !loop over proj. leg Pomerons in the collision
11203           ipp=ilpr(np,nb)                       !proj. index
11204           lnp=lnpr(np,nb)                       !proj. constituent parton index
11205           xpp=xppr(lnp,ipp)
11206           xpm=xpompr(lnp,ipp)
11207           if(xpp*xpm*scm.gt.1.d0)then
11208            wppr1(ipp)=wppr1(ipp)+xpp*wp0        !count Pomeron LC momentum
11209            wmtg2(it)=wmtg2(it)+xpm*wm0          !count Pomeron LC momentum
11210           else
11211            xppr(lnp,ipp)=0.d0
11212            xpompr(lnp,ipp)=0.d0
11213           endif
11214          enddo
11215         endif
11216         if(npomtg(nb).ne.0)then
11217          do np=1,npomtg(nb)       !loop over targ. leg Pomerons in the collision
11218           itt=iltg(np,nb)                       !targ. index
11219           lnt=lntg(np,nb)                       !targ. constituent parton index
11220           xpp=xpomtg(lnt,itt)
11221           xpm=xmtg(lnt,itt)
11222           if(xpp*xpm*scm.gt.1.d0)then
11223            wppr2(ip)=wppr2(ip)+xpp*wp0                !count Pomeron LC momentum
11224            wmtg1(itt)=wmtg1(itt)+xpm*wm0        !count Pomeron LC momentum
11225           else
11226            xmtg(lnt,itt)=0.d0
11227            xpomtg(lnt,itt)=0.d0
11228           endif
11229          enddo
11230         endif
11231        enddo
11232       endif
11233 
11234       do ip=1,ia(1)
11235        if(wppr1(ip)+wppr2(ip).ne.0.d0)then
11236         if(lqa(ip).ne.0)then
11237          do i=1,lqa(ip)
11238           xppr(i,ip)=xppr(i,ip)*(wp0-wppr0(ip)) !renorm. for const. partons
11239      *    /(wppr1(ip)+wppr2(ip))
11240          enddo
11241 
11242          do nb=1,nbpom
11243           if(ias(nb).eq.ip.and.npomtg(nb)+npomin(nb).ne.0)then
11244            if(npomin(nb).ne.0)then
11245             do np=1,npomin(nb)
11246              xpopin(np,nb)=xpopin(np,nb)*(wp0-wppr0(ip))
11247      *       /(wppr1(ip)+wppr2(ip))
11248             enddo
11249            endif
11250            if(npomtg(nb).ne.0)then
11251             do np=1,npomtg(nb)
11252              itt=iltg(np,nb)
11253              lnt=lntg(np,nb)
11254              xpomtg(lnt,itt)=xpomtg(lnt,itt)*(wp0-wppr0(ip))
11255      *       /(wppr1(ip)+wppr2(ip))
11256             enddo
11257            endif
11258           endif
11259          enddo
11260 
11261         elseif(wppr2(ip).gt.wp0)then
11262          wpt=wp0/sgap/2.d0*4.d0**qgran(b10)
11263          do nb=1,nbpom
11264           if(ias(nb).eq.ip.and.npomtg(nb)+npomin(nb).ne.0)then
11265            if(npomin(nb).ne.0)then
11266             do np=1,npomin(nb)
11267              xpopin(np,nb)=xpopin(np,nb)*wpt/wppr2(ip)
11268             enddo
11269            endif
11270            if(npomtg(nb).ne.0)then
11271             do np=1,npomtg(nb)
11272              itt=iltg(np,nb)
11273              lnt=lntg(np,nb)
11274              xpomtg(lnt,itt)=xpomtg(lnt,itt)*wpt/wppr2(ip)
11275             enddo
11276            endif
11277           endif
11278          enddo
11279          wppr0(ip)=wp0-wpt
11280         else
11281          wppr0(ip)=wp0-wppr2(ip)
11282         endif
11283        endif
11284       enddo
11285 
11286       do it=1,ia(2)
11287        if(wmtg1(it)+wmtg2(it).ne.0.d0)then
11288         if(lqb(it).ne.0)then
11289          do i=1,lqb(it)
11290           xmtg(i,it)=xmtg(i,it)*(wm0-wmtg0(it))/(wmtg1(it)+wmtg2(it))
11291          enddo
11292 
11293          do nb=1,nbpom
11294           if(ibs(nb).eq.it.and.npompr(nb)+npomin(nb).ne.0)then
11295            if(npomin(nb).ne.0)then
11296             do np=1,npomin(nb)
11297              xpomin(np,nb)=xpomin(np,nb)*(wm0-wmtg0(it))
11298      *       /(wmtg1(it)+wmtg2(it))
11299             enddo
11300            endif
11301            if(npompr(nb).ne.0)then
11302             do np=1,npompr(nb)
11303              ipp=ilpr(np,nb)
11304              lnp=lnpr(np,nb)
11305              xpompr(lnp,ipp)=xpompr(lnp,ipp)*(wm0-wmtg0(it))
11306      *       /(wmtg1(it)+wmtg2(it))
11307             enddo
11308            endif
11309           endif
11310          enddo
11311 
11312         elseif(wmtg2(it).gt.wm0)then
11313          wmt=wm0/sgap/2.d0*4.d0**qgran(b10)
11314          do nb=1,nbpom
11315           if(ibs(nb).eq.it.and.npompr(nb)+npomin(nb).ne.0)then
11316            if(npomin(nb).ne.0)then
11317             do np=1,npomin(nb)
11318              xpomin(np,nb)=xpomin(np,nb)*wmt/wmtg2(it)
11319             enddo
11320            endif
11321            if(npompr(nb).ne.0)then
11322             do np=1,npompr(nb)
11323              ipp=ilpr(np,nb)
11324              lnp=lnpr(np,nb)
11325              xpompr(lnp,ipp)=xpompr(lnp,ipp)*wmt/wmtg2(it)
11326             enddo
11327            endif
11328           endif
11329          enddo
11330          wmtg0(it)=wm0-wmt
11331         else
11332          wmtg0(it)=wm0-wmtg2(it)
11333         endif
11334        endif
11335       enddo
11336 
11337 c-------------------------------------------------
11338 c treatment of low mass diffraction
11339       if(debug.ge.1)write (moniou,207)
11340       do ip=1,ia(1)                        !loop over proj. nucleons
11341        if(iwp(ip).eq.2)then                !diffraction dissociation
11342         it=iprcn(ip)
11343         if(debug.ge.2)write (moniou,208)ip,it
11344         if(iwt(it).eq.2)then
11345          call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-2,-2,iret)
11346         elseif(iwt(it).eq.-1)then
11347          call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-2,0,iret)
11348         elseif(iwt(it).gt.0)then
11349          call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-2,-1,iret)
11350         else
11351          stop'wrong connection for diffraction'
11352         endif
11353         if(iret.eq.1)goto 1
11354        endif
11355       enddo
11356 
11357       do it=1,ia(2)                        !loop over targ. nucleons
11358        if(iwt(it).eq.2)then                !diffraction dissociation
11359         ip=itgcn(it)
11360         if(debug.ge.2)write (moniou,209)it,ip
11361         if(iwp(ip).eq.-1)then
11362          call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),0,-2,iret)
11363         elseif(iwp(ip).gt.0.and.iwp(ip).ne.2)then
11364          call qgdifr(wppr0(ip),wmtg0(it),izp(ip),izt(it),-1,-2,iret)
11365         endif
11366         if(iret.eq.1)goto 1
11367        endif
11368       enddo
11369 
11370 c-------------------------------------------------
11371 c particle production for all cut Pomerons
11372       s2min=4.d0*fqscal*qt0       !threshold energy for a hard process
11373       if(nbpom.ne.0)then
11374        if(debug.ge.1)write (moniou,210)
11375        do npb=1,nbpom                            !loop over collisions
11376         ip=ias(npb)                              !proj. index
11377         it=ibs(npb)                              !targ. index
11378         icdp=iddp(ip)                            !proj. diffr. eigenstate
11379         icdt=iddt(it)                            !targ. diffr. eigenstate
11380         bbp=bbpom(npb)                           !b^2 between proj. and targ.
11381         vvx=vvxpom(npb)                          !nuclear screening factor
11382         if(debug.ge.1)write (moniou,211)npb,ip,it,bbp,vvx,nqs(npb)
11383      *  ,npomin(npb),npompr(npb),npomtg(npb)
11384 
11385         if(npomin(npb).ne.0)then
11386          do n=1,npomin(npb)                      !loop over interm. Pomerons
11387           wpi=xpopin(n,npb)*wp0                  !LC+ for the Pomeron
11388           wmi=xpomin(n,npb)*wm0                  !LC- for the Pomeron
11389           if(debug.ge.2)write (moniou,212)n,wpi,wmi
11390           if(wpi*wmi.ne.0.d0)then
11391            ic11=0
11392            ic12=0
11393            ic21=0
11394            ic22=0
11395            call qgstr(wpi,wmi,wppr0(ip),wmtg0(it)
11396      *     ,ic11,ic12,ic22,ic21,0,0)             !string hadronization
11397           endif
11398          enddo
11399         endif
11400 
11401         if(nqs(npb).ne.0)then
11402          do n=1,nqs(npb)                         !loop over single Pomerons
11403           lnp=nnpr(n,npb)                        !index for proj. constituent
11404           lnt=nntg(n,npb)                        !index for targ. constituent
11405           lqa0(ip)=lqa0(ip)-1
11406           lqb0(it)=lqb0(it)-1
11407           xpi=xppr(lnp,ip)
11408           xmi=xmtg(lnt,it)
11409           wpi=wp0*xpi                            !LC+ for the Pomeron
11410           wmi=wm0*xmi                            !LC- for the Pomeron
11411           sy=wpi*wmi
11412           wtot=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,1) !total
11413           wsoft=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,2)!soft interaction
11414           wqg=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,3)  !qg-hard interaction
11415           wgq=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,4)  !gq-hard interaction
11416           wqq=qgpomc(sy,xpi,xmi,bbp,vvx,icdp,icdt,icz,5)  !qq-hard interaction
11417           aks=qgran(b10)*wtot
11418           if(debug.ge.2)write (moniou,213)n,wpi,wmi
11419 
11420           if(aks.lt.wsoft.or.sy.lt.2.d0*s2min)then !soft string hadronization
11421            if(lqa0(ip).eq.0.and.lva(ip).eq.0)then
11422             call qgixxd(izp(ip),ic11,ic12,icz)
11423            else
11424             ic11=0
11425             ic12=0
11426            endif
11427            if(lqb0(it).eq.0.and.lvb(it).eq.0)then
11428             call qgixxd(izt(it),ic21,ic22,2)
11429            else
11430             ic21=0
11431             ic22=0
11432            endif
11433            call qgstr(wpi,wmi,wppr0(ip),wmtg0(it),ic11,ic12,ic22,ic21
11434      *     ,1,1)
11435           else            !QCD evolution and hadronization for semi-hard Pomeron
11436            if(lva(ip).eq.0.and.lvb(it).eq.0.and.aks.lt.wsoft+wqq)then
11437             iqq=3
11438             lva(ip)=1
11439             lvb(it)=1
11440            elseif(lva(ip).eq.0.and.aks.gt.wqg)then
11441             iqq=1
11442             lva(ip)=1
11443            elseif(lvb(it).eq.0.and.aks.gt.wgq)then
11444             iqq=2
11445             lvb(it)=1
11446            else
11447             iqq=0
11448            endif
11449 
11450            call qghot(wpi,wmi,dsqrt(bbp),vvx,nva,nvb,izp(ip),izt(it)
11451      *     ,icdp,icdt,icz,iqq,0)            !QCD evolution + jet hadronization
11452            if(iqq.eq.1.or.iqq.eq.3)ila(ip)=nva
11453            if(iqq.eq.2.or.iqq.eq.3)ilb(it)=nvb
11454           endif
11455          enddo
11456         endif
11457 
11458         if(npompr(npb).ne.0)then
11459          do l=1,npompr(npb)                 !loop over proj. leg Pomerons
11460           ipp=ilpr(l,npb)                  !proj. index
11461           lnp=lnpr(l,npb)                  !index for proj. constituent
11462           bbpr=bpompr(lnp,ipp)             !b^2 for the Pomeron
11463           vvxp=vvxpr(lnp,ipp)              !screening factor
11464           lqa0(ipp)=lqa0(ipp)-1
11465           xpi=xppr(lnp,ipp)
11466           xmi=xpompr(lnp,ipp)
11467           wpi=wp0*xpi                      !LC+ for the Pomeron
11468           wmi=wm0*xmi                      !LC- for the Pomeron
11469           sy=wpi*wmi
11470           if(sy.ne.0.d0)then
11471            wtot=qglegc(sy,xpi,bbpr,vvxp,iddp(ipp),icz,9)   !total
11472            wsoft=qglegc(sy,xpi,bbpr,vvxp,iddp(ipp),icz,10) !soft interaction
11473            wqg=qglegc(sy,xpi,bbpr,vvxp,iddp(ipp),icz,11)   !qg-hard interaction
11474           else
11475            wsoft=1.d0
11476            wtot=1.d0
11477            wqg=0.d0
11478           endif
11479           aks=qgran(b10)*wtot
11480           if(debug.ge.2)write (moniou,214)l,wpi,wmi
11481 
11482           if(aks.le.wsoft.or.sy.lt.2.d0*s2min)then  !soft string hadronization
11483            if(lqa0(ipp).eq.0.and.lva(ipp).eq.0.and.sy.ne.0.d0)then
11484             call qgixxd(izp(ipp),ic11,ic12,icz)
11485            else
11486             ic11=0
11487             ic12=0
11488            endif
11489            ic21=0
11490            ic22=0
11491            call qgstr(wpi,wmi,wppr0(ipp),wmtg0(it),ic11,ic12,ic22,ic21
11492      *     ,1,0)
11493 
11494           else        !QCD evolution and hadronization for semi-hard Pomeron
11495            if(lva(ipp).eq.0.and.aks.gt.wqg)then
11496             iqq=1
11497             lva(ipp)=1
11498            else
11499             iqq=0
11500            endif
11501 
11502            call qghot(wpi,wmi,dsqrt(bbpr),vvxp,nva,nvb,izp(ipp),izt(it)
11503      *     ,iddp(ipp),icdt,icz,iqq,1)         !QCD evolution + jet hadronization
11504            if(iqq.eq.1)ila(ipp)=nva
11505           endif
11506           call qglead(wppr0(ipp),wmtg0(it),lqa(ipp)+1-iwp(ipp)
11507      *    ,lqb(it)+1-iwt(it),lqa0(ipp)+ncola0(ipp),lqb0(it)+ncolb0(it)
11508      *    ,lva(ipp),lvb(it),izp(ipp),izt(it),ila(ipp),ilb(it),iret)  !remnants
11509           if(iret.ne.0)goto 1
11510          enddo
11511         endif
11512 
11513         if(npomtg(npb).ne.0)then
11514          do l=1,npomtg(npb)                !loop over targ. leg Pomerons
11515           itt=iltg(l,npb)                  !targ. index
11516           lnt=lntg(l,npb)                  !index for targ. constituent
11517           bbtg=bpomtg(lnt,itt)             !b^2 for the Pomeron
11518           vvxt=vvxtg(lnt,itt)              !screening factor
11519           lqb0(itt)=lqb0(itt)-1
11520           xmi=xmtg(lnt,itt)
11521           wmi=wm0*xmi                      !LC- for the Pomeron
11522           wpi=wp0*xpomtg(lnt,itt)          !LC+ for the Pomeron
11523           sy=wpi*wmi
11524           if(sy.ne.0.d0)then
11525            wtot=qglegc(sy,xmi,bbtg,vvxt,iddt(itt),2,9)  !tot
11526            wsoft=qglegc(sy,xmi,bbtg,vvxt,iddt(itt),2,10)!soft interaction
11527            wqg=qglegc(sy,xmi,bbtg,vvxt,iddt(itt),2,11)  !qg-hard interaction
11528           else
11529            wtot=1.d0
11530            wsoft=1.d0
11531            wqg=0.d0
11532           endif
11533           aks=qgran(b10)*wtot
11534           if(debug.ge.2)write (moniou,215)l,wpi,wmi
11535 
11536           if(aks.le.wsoft.or.sy.lt.2.d0*s2min)then  !soft string hadronization
11537            ic11=0
11538            ic12=0
11539            if(lqb0(itt).eq.0.and.lvb(itt).eq.0.and.sy.ne.0.d0)then
11540             call qgixxd(izt(itt),ic21,ic22,2)
11541            else
11542             ic21=0
11543             ic22=0
11544            endif
11545            call qgstr(wpi,wmi,wppr0(ip),wmtg0(itt),ic11,ic12,ic22,ic21
11546      *     ,0,1)
11547 
11548           else         !QCD evolution and hadronization for semi-hard Pomeron
11549            if(lvb(itt).eq.0.and.aks.gt.wqg)then
11550             iqq=2
11551             lvb(itt)=1
11552            else
11553             iqq=0
11554            endif
11555 
11556            call qghot(wpi,wmi,dsqrt(bbtg),vvxt,nva,nvb,izp(ip),izt(itt)
11557      *     ,icdp,iddt(itt),icz,iqq,2)         !QCD evolution + jet hadronization
11558            if(iqq.eq.2)ilb(itt)=nvb
11559           endif
11560           call qglead(wppr0(ip),wmtg0(itt),lqa(ip)+1-iwp(ip),lqb(itt)
11561      *    +1-iwt(itt),lqa0(ip)+ncola0(ip),lqb0(itt)+ncolb0(itt)
11562      *    ,lva(ip),lvb(itt),izp(ip),izt(itt),ila(ip),ilb(itt),iret) !remnants
11563           if(iret.ne.0)goto 1
11564          enddo
11565         endif
11566         ncola0(ip)=ncola0(ip)-1
11567         ncolb0(it)=ncolb0(it)-1
11568         call qglead(wppr0(ip),wmtg0(it),lqa(ip)+1-iwp(ip),lqb(it)
11569      *  +1-iwt(it),lqa0(ip)+ncola0(ip),lqb0(it)+ncolb0(it)
11570      *  ,lva(ip),lvb(it),izp(ip),izt(it),ila(ip),ilb(it),iret) !remnants
11571         if(iret.ne.0)goto 1
11572        enddo                                           !end of collision loop
11573       endif
11574 
11575       if(nj.ne.0)then                   !arrangement of parton color connections
11576        if(debug.ge.1)write (moniou,216)nj
11577        call qgjarr(jfl)
11578        if(jfl.eq.0)then
11579         iret=1
11580         goto 1
11581        endif
11582        if(debug.ge.1)write (moniou,217)
11583        call qgxjet                      !jet hadronization
11584       endif
11585       if(debug.ge.1)write (moniou,218)
11586 
11587 201   format(2x,'qgsha - inelastic interaction, N of Pomeron blocks:'
11588      *,i4)
11589 202   format(2x,'qgsha: energy-momentum sharing between Pomerons')
11590 203   format(2x,'qgsha: log of acceptance probability - ',e10.3
11591      */4x,'N of rejections - ',i4,2x,'N of renorm. - ',i3)
11592 204   format(2x,'qgsha:  new normalization of acceptance,'
11593      *,' N of renorm. - ',i3)
11594 205   format(2x,'qgsha: leading remnant LC momenta')
11595 206   format(2x,'qgsha: momentum conservation '
11596      *,'(correction for 3p-vertexes)')
11597 207   format(2x,'qgsha: treatment of low mass diffraction')
11598 208   format(2x,'qgsha: diffraction of ',i3,'-th proj. nucleon,'
11599      *,' recoil of ',i3,'-th targ. nucleon')
11600 209   format(2x,'qgsha: diffraction of ',i3,'-th targ. nucleon,'
11601      *,' recoil of ',i3,'-th proj. nucleon')
11602 210   format(2x,'qgsha: particle production for all cut Pomerons')
11603 211   format(2x,'qgsha: ',i4,'-th collision,  proj. index - ',i3,2x
11604      *,'targ. index - ',i3
11605      */4x,'b^2=',e10.3,2x,'vvx=',e10.3,2x,'N of single Pomerons - ',i3
11606      *,2x,' N of interm. Pomerons - ',i3
11607      */4x,'N of proj. legs - ',i3,2x,'N of targ. legs - ',i3)
11608 212   format(2x,'qgsha: particle production for '
11609      *,i3,'-th interm. Pomeron'
11610      */4x,'light cone momenta for the Pomeron:',2e10.3)
11611 213   format(2x,'qgsha: particle production for '
11612      *,i3,'-th single Pomeron'
11613      */4x,'light cone momenta for the Pomeron:',2e10.3)
11614 214   format(2x,'qgsha: particle production for '
11615      *,i3,'-th proj. leg Pomeron'
11616      */4x,'light cone momenta for the Pomeron:',2e10.3)
11617 215   format(2x,'qgsha: particle production for '
11618      *,i3,'-th targ. leg Pomeron'
11619      */4x,'light cone momenta for the Pomeron:',2e10.3)
11620 216   format(2x,'qgsha: arrangement of color connections for '
11621      *,i5,' final partons')
11622 217   format(2x,'qgsha: jet hadronization')
11623 218   format(2x,'qgsha - end')
11624       return
11625       end
11626 
11627 c=============================================================================
11628       subroutine qgprox(imode)
11629 c-------------------------------------------------------------------------
11630 c qgprox - propose Pomeron end LC momenta
11631 c imod = 0 - to define normalization
11632 c imod = 1 - propose values according to x^delf * (1 - sum_i x_i)^ahl
11633 c-------------------------------------------------------------------------
11634       implicit double precision (a-h,o-z)
11635       integer debug
11636       parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
11637       common /qgarr1/  ia(2),icz,icp
11638       common /qgarr2/  scm,wp0,wm0
11639       common /qgarr6/  pi,bm,amws
11640       common /qgarr9/  iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
11641      *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
11642      *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
11643      *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
11644      *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
11645      *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
11646      *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
11647      *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
11648       common /qgarr11/ b10
11649       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
11650       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
11651       common /qgarr19/ ahl(3)
11652       common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
11653      *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
11654      *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
11655      *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
11656      *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
11657      *,bpomin(npmax,npbmax)
11658       common /qgarr40/ xppr(npnmax,iapmax),xmtg(npnmax,iapmax)
11659       common /qgarr43/ moniou
11660       common /qgdebug/  debug
11661       external qgran
11662 
11663       if(debug.ge.3)write (moniou,201)imode
11664 
11665       delf=dels
11666       if(imode.eq.0)then                    !0-configuration (for normalization)
11667        do ip=1,ia(1)                        !loop over proj. nucleons
11668         if(lqa(ip).ne.0)then
11669          do n=1,lqa(ip)                     !loop over proj. constituents
11670           if(idnpi(n,ip).eq.0)then
11671            xppr(n,ip)=1.d0/wp0              !LC+ for single Pomeron
11672           else
11673            xppr(n,ip)=1.d0/xpompr(n,ip)/scm !LC+ for leg Pomeron
11674           endif
11675           enddo
11676         endif
11677        enddo
11678        do it=1,ia(2)                        !loop over targ. nucleons
11679         if(lqb(it).ne.0)then
11680          do n=1,lqb(it)                     !loop over targ. constituents
11681           if(idnti(n,it).eq.0)then
11682            xmtg(n,it)=1.d0/wm0              !LC- for single Pomeron
11683           else
11684            xmtg(n,it)=1.d0/xpomtg(n,it)/scm !LC- for leg Pomeron
11685           endif
11686          enddo
11687         endif
11688        enddo
11689 
11690       else                                  !proposed configuration
11691        do ip=1,ia(1)                        !loop over proj. nucleons
11692         if(lqa(ip).ne.0)then
11693          xpt=1.d0
11694          do n=1,lqa(ip)                     !loop over proj. constituents
11695           nrej=0
11696           alfl=ahl(icz)+(lqa(ip)-n)*(1.d0+delf)
11697 c          if(icz.eq.2)alfl=alfl-float(lqa(ip)-1)/lqa(ip)  !baryon "junction"
11698           gb0=(1.d0-.11d0**(1.d0/(1.d0+delf)))**alfl
11699      *    *exp(alfl*(1.d0+delf)*.11d0)*2.d0
11700 1         continue
11701 c proposal functions are chosen depending on the parameters
11702 c to assure an efficient procedure
11703           if(delf.ge.0.d0.and.alfl.ge.0.d0
11704      *    .or.delf.lt.0.d0.and.alfl.le.0.d0)then
11705            up=1.d0-qgran(b10)**(1.d0/(1.d0+delf))
11706            if(1.d0-up.lt.1.d-20)goto 1
11707            tp=1.d0-up**(1.d0/(1.d0+alfl))
11708            gb=(tp/(1.d0-up))**delf
11709           elseif(delf.lt.0.d0.and.alfl.gt.0.d0)then
11710            up=-log(1.d0-qgran(b10)*(1.d0-exp(-alfl*(1.d0+delf))))
11711      *     /alfl/(1.d0+delf)
11712            tp=up**(1.d0/(1.d0+delf))
11713            gb=(1.d0-tp)**alfl*exp(alfl*(1.d0+delf)*up)/gb0
11714           else
11715            tp=1.d0-qgran(b10)**(1.d0/(1.d0+alfl))
11716            gb=tp**delf
11717           endif
11718           if(qgran(b10).gt.gb)then
11719            nrej=nrej+1
11720            goto 1
11721           endif
11722           xppr(n,ip)=tp*xpt                 !proposed LC+ for the constituent
11723           xpt=xpt-xppr(n,ip)                !LC+ of the remnant
11724           enddo
11725         endif
11726        enddo
11727 
11728        do it=1,ia(2)                        !loop over targ. nucleons
11729         if(lqb(it).ne.0)then
11730          xmt=1.d0
11731          do n=1,lqb(it)                     !loop over targ. constituents
11732           nrej=0
11733           alfl=ahl(2)+(lqb(it)-n)*(1.d0+delf)
11734 c     *    -float(lqb(it)-1)/lqb(it)                       !baryon "junction"
11735           gb0=(1.d0-.11d0**(1.d0/(1.d0+delf)))**alfl
11736      *    *exp(alfl*(1.d0+delf)*.11d0)*2.d0
11737 2         continue
11738           if(delf.ge.0.d0.and.alfl.ge.0.d0
11739      *    .or.delf.lt.0.d0.and.alfl.le.0.d0)then
11740            up=1.d0-qgran(b10)**(1.d0/(1.d0+delf))
11741            if(1.d0-up.lt.1.d-20)goto 2
11742            tp=1.d0-up**(1.d0/(1.d0+alfl))
11743            gb=(tp/(1.d0-up))**delf
11744           elseif(delf.lt.0.d0.and.alfl.gt.0.d0)then
11745            up=-log(1.d0-qgran(b10)*(1.d0-exp(-alfl*(1.d0+delf))))
11746      *     /alfl/(1.d0+delf)
11747            tp=up**(1.d0/(1.d0+delf))
11748            gb=(1.d0-tp)**alfl*exp(alfl*(1.d0+delf)*up)/gb0
11749           else
11750            tp=1.d0-qgran(b10)**(1.d0/(1.d0+alfl))
11751            gb=tp**delf
11752           endif
11753           if(qgran(b10).gt.gb)then
11754            nrej=nrej+1
11755            goto 2
11756           endif
11757           if(qgran(b10).gt.gb)goto 2
11758           xmtg(n,it)=tp*xmt                 !proposed LC- for the constituent
11759           xmt=xmt-xmtg(n,it)                !LC- of the remnant
11760           enddo
11761         endif
11762        enddo
11763       endif
11764       if(debug.ge.4)write (moniou,202)
11765 
11766 201   format(2x,'qgprox - propose Pomeron end LC momenta, imode=',i2)
11767 202   format(2x,'qgprox - end')
11768       return
11769       end
11770 
11771 c=============================================================================
11772       double precision function qgweix(nbpom)
11773 c-------------------------------------------------------------------------
11774 c qgweix - log-weight of x-configuration
11775 c imod = 0 - to define normalization
11776 c imod = 1 - propose values according to x^delf * (1 - sum_i x_i)^ahl
11777 c-------------------------------------------------------------------------
11778       implicit double precision (a-h,o-z)
11779       integer debug
11780       parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
11781       common /qgarr1/  ia(2),icz,icp
11782       common /qgarr2/  scm,wp0,wm0
11783       common /qgarr6/  pi,bm,amws
11784       common /qgarr9/  iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
11785      *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
11786      *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
11787      *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
11788      *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
11789      *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
11790      *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
11791      *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
11792       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
11793       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
11794       common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
11795      *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
11796      *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
11797      *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
11798      *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
11799      *,bpomin(npmax,npbmax)
11800       common /qgarr40/ xppr(npnmax,iapmax),xmtg(npnmax,iapmax)
11801       common /qgarr43/ moniou
11802       common /qgdebug/  debug
11803 
11804       if(debug.ge.3)write (moniou,201)nbpom
11805 
11806       delf=dels
11807       qgweix=0.d0
11808       do npb=1,nbpom                              !loop over collisions
11809        ip=ias(npb)                                !proj. index
11810        it=ibs(npb)                                !targ. index
11811        icdp=iddp(ip)                              !proj. diffr. eigenstate
11812        icdt=iddt(it)                              !targ. diffr. eigenstate
11813        bbp=bbpom(npb)                             !b^2 between proj. and targ.
11814        vvx=vvxpom(npb)                            !nuclear screening factor
11815        if(nqs(npb).ne.0)then
11816         do n=1,nqs(npb)                           !loop over single Pomerons
11817          lnp=nnpr(n,npb)                          !proj. constituent index
11818          lnt=nntg(n,npb)                          !targ. constituent index
11819          xpp=xppr(lnp,ip)                         !LC+ for the Pomeron
11820          xpm=xmtg(lnt,it)                         !LC- for the Pomeron
11821          qgweix=qgweix+dlog(qgpomc(scm*xpp*xpm,xpp,xpm,bbp,vvx
11822      *   ,icdp,icdt,icz,1)/(xpp*xpm)**delf)       !add single Pomeron contrib.
11823         enddo
11824        endif
11825        if(npompr(npb).ne.0)then
11826         do l=1,npompr(npb)                         !loop over proj. leg Pomerons
11827          ipp=ilpr(l,npb)                          !proj. index
11828          lnp=lnpr(l,npb)                          !proj. constituent index
11829          xpp=xppr(lnp,ipp)                        !LC+ for the Pomeron
11830          xpomr=1.d0/xpompr(lnp,ipp)/scm           !LC+ for the 3P vertex
11831          vvxp=vvxpr(lnp,ipp)                      !screening factor
11832          bbpr=bpompr(lnp,ipp)                          !b^2 for the Pomeron
11833          qgweix=qgweix+dlog(qglegc(xpp/xpomr,xpp,bbpr,vvxp
11834      *   ,iddp(ipp),icz,9)/xpp**delf)             !add leg Pomeron contrib.
11835         enddo
11836        endif
11837        if(npomtg(npb).ne.0)then
11838         do l=1,npomtg(npb)                        !loop over targ. leg Pomerons
11839          itt=iltg(l,npb)                          !targ. index
11840          lnt=lntg(l,npb)                          !targ. constituent index
11841          xpm=xmtg(lnt,itt)                        !LC- for the Pomeron
11842          xpomr=xpomtg(lnt,itt)                    !LC+ for the 3P vertex
11843          vvxt=vvxtg(lnt,itt)                      !screening factor
11844          bbtg=bpomtg(lnt,itt)                          !b^2 for the Pomeron
11845          qgweix=qgweix+dlog(qglegc(xpomr*scm*xpm,xpm,bbtg,vvxt
11846      *   ,iddt(itt),2,9)/xpm**delf)               !add leg Pomeron contrib.
11847         enddo
11848        endif
11849       enddo
11850       if(debug.ge.4)write (moniou,202)qgweix
11851 
11852 201   format(2x,'qgweix - log-weight of x-configuration,'
11853      *,' N of collisions - ',i4)
11854 202   format(2x,'qgweix=',e10.3)
11855       return
11856       end
11857 
11858 c=============================================================================
11859       subroutine qghot(wpp,wpm,b,vvx,nva,nvb,izp,izt,icdp,icdt,icz,iqq
11860      *,jpt)
11861 c---------------------------------------------------------------------------
11862 c qghot - semi-hard process
11863 c wpp,wpm   - LC momenta for the constituent partons,
11864 c b         - impact parameter for the semi-hard Pomeron,
11865 c izp, izt  - types of proj. and targ. remnants,
11866 c icdp,icdt - proj. and targ.  diffractive eigenstates,
11867 c iqq - type of the semi-hard process: 0 - gg, 1 - q_vg, 2 - gq_v, 3 - q_vq_v
11868 c jpt=0 - single Pomeron,
11869 c jpt=1 - proj. leg Pomeron,
11870 c jpt=2 - targ. leg Pomeron
11871 c---------------------------------------------------------------------------
11872       implicit double precision (a-h,o-z)
11873       integer debug
11874       character*2 tyq
11875       parameter(njmax=50000)
11876       dimension ept(4),ep3(4),ey(3),ebal(4),
11877      *qmin(2),wp(2),iqc(2),iqp(2),nqc(2),ncc(2,2),
11878      *qv1(30,50),zv1(30,50),qm1(30,50),iqv1(30,50),
11879      *ldau1(30,49),lpar1(30,50),
11880      *qv2(30,50),zv2(30,50),qm2(30,50),iqv2(30,50),
11881      *ldau2(30,49),lpar2(30,50)
11882       parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
11883       common /qgarr2/  scm,wp0,wm0
11884       common /qgarr6/  pi,bm,amws
11885       common /qgarr8/  wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
11886       common /qgarr10/ am(7),ammu
11887       common /qgarr11/ b10
11888       common /qgarr12/ nsp
11889       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
11890       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
11891       common /qgarr18/ alm,qt0,qtf,betp,dgqq
11892       common /qgarr26/ factk,fqscal
11893       common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
11894       common /qgarr42/ tyq(16)
11895       common /qgarr43/ moniou
11896       common /qgarr51/ epsxmn
11897       common /qgdebug/ debug
11898       external qgran
11899 
11900       if(debug.ge.1)write (moniou,201)iqq,wpp,wpm,izp,izt,icdp,icdt
11901      *,icz,jpt,nj
11902 
11903       wwgg=0.d0
11904       wwqg=0.d0
11905       wwgq=0.d0
11906       wwqq=0.d0
11907       wpi=0.d0
11908       wmi=0.d0
11909       sjqg=0.d0
11910       sjqq=0.d0
11911       sea1=0.d0
11912       sea2=0.d0
11913       glu1=0.d0
11914       glu2=0.d0
11915       nj0=nj                       !store number of final partons
11916       nsp0=nsp                     !store number of final particles
11917 
11918 1     sy=wpp*wpm  !energy squared for semi-hard inter. (including preevolution)
11919       nj=nj0
11920       nsp=nsp0
11921       s2min=4.d0*fqscal*qt0       !threshold energy
11922       if(sy.lt.s2min)stop'qghot: sy<s2min!!!'
11923 
11924       if(iqq.eq.3)then             !q_vq_v-ladder
11925        wpi=wpp                     !LC+ for the hard interaction
11926        wmi=wpm                     !LC- for the hard interaction
11927       else
11928 
11929 c-------------------------------------------------
11930 c normalization of acceptance
11931        xmin=s2min/sy
11932        iq=(iqq+1)/2+1              !auxilliary type of parton (1 - g, 2 - q(q~))
11933        sj=qgjit(qt0,qt0,sy,1,iq)   !inclusive parton-parton cross-sections
11934        if(iqq.eq.0)then
11935         gb0=-dlog(xmin)*(1.d0-dsqrt(xmin))**(2.d0*betp)*sj
11936        else
11937         gb0=(1.d0-xmin)**betp*sj
11938        endif
11939        if(jpt.eq.0)then            !single Pomeron
11940         if(iqq.eq.0)then
11941          rp0=(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(scm/s2min))
11942      *   *4.d0*.0389d0
11943          gb0=gb0/(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(scm/sy))
11944      *   *exp(-b*b/rp0)
11945         elseif(iqq.eq.1)then
11946          rp0=(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wpp*wm0/s2min))
11947      *   *4.d0*.0389d0
11948          gb0=gb0/(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wm0/wpm))
11949      *   *exp(-b*b/rp0)
11950         elseif(iqq.eq.2)then
11951          rp0=(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wpm*wp0/s2min))
11952      *   *4.d0*.0389d0
11953          gb0=gb0/(rq(icdp,icz)+rq(icdt,2)+alfp*dlog(wp0/wpp))
11954      *   *exp(-b*b/rp0)
11955         endif
11956        elseif(jpt.eq.1)then        !proj. leg Pomeron
11957         if(iqq.eq.0)then
11958          rp0=(rq(icdp,icz)+alfp*dlog(wp0*wpm/s2min))*4.d0*.0389d0
11959          gb0=gb0/(rq(icdp,icz)+alfp*dlog(wp0/wpp))*exp(-b*b/rp0)
11960         elseif(iqq.eq.1)then
11961          rp0=(rq(icdp,icz)+alfp*dlog(sy/s2min))*4.d0*.0389d0
11962          gb0=gb0/rq(icdp,icz)*exp(-b*b/rp0)
11963         endif
11964        elseif(jpt.eq.2)then        !targ. leg Pomeron
11965         if(iqq.eq.0)then
11966          rp0=(rq(icdt,2)+alfp*dlog(wm0*wpp/s2min))*4.d0*.0389d0
11967          gb0=gb0/(rq(icdt,2)+alfp*dlog(wm0/wpm))*exp(-b*b/rp0)
11968         elseif(iqq.eq.2)then
11969          rp0=(rq(icdt,2)+alfp*dlog(sy/s2min))*4.d0*.0389d0
11970          gb0=gb0/rq(icdt,2)*exp(-b*b/rp0)
11971         endif
11972        endif
11973 
11974 c-------------------------------------------------
11975 c sharing of LC momenta between soft preevolution and hard ladder
11976 2      zpm=(1.d0-qgran(b10)*(1.d0-xmin**(delh-dels)))
11977      * **(1.d0/(delh-dels))
11978        sjqq=qgjit(qt0,qt0,zpm*sy,2,2)  !inclusive qq cross-section
11979        sjqg=qgjit(qt0,qt0,zpm*sy,1,2)  !inclusive qg cross-section
11980        sjgg=qgjit(qt0,qt0,zpm*sy,1,1)  !inclusive gg cross-section
11981 
11982        if(iqq.eq.0)then              !gg-ladder
11983         xp=zpm**qgran(b10)           !LC+ momentum share
11984         xm=zpm/xp                    !LC- momentum share
11985         wpi=wpp*xp                   !LC+ for the hard interaction
11986         wmi=wpm*xm                   !LC- for the hard interaction
11987         if(jpt.eq.0)then             !single Pomeron
11988          rp1=(rq(icdp,icz)+alfp*dlog(wp0/wpi))*4.d0*.0389d0
11989          rp2=(rq(icdt,2)+alfp*dlog(wm0/wmi))*4.d0*.0389d0
11990          rp=rp1*rp2/(rp1+rp2)
11991          z=qgran(b10)
11992          phi=pi*qgran(b10)
11993          b0=dsqrt(-rp*dlog(z))
11994          bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
11995          bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
11996 
11997          xpomr=wpi/wp0
11998          if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
11999           vvx1=0.d0
12000          else
12001           v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
12002           v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
12003           nn=0
12004 21        nn=nn+1
12005           vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
12006           vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
12007           v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
12008           v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
12009           if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
12010      *    .and.nn.lt.100)then
12011            v1pnu0=v1pnu
12012            v1tnu0=v1tnu
12013            goto 21
12014           endif
12015           vvx1=1.d0-exp(-v1tnu)*(1.d0-vvx)
12016          endif
12017 
12018          xpomr=wm0/wmi/scm
12019          if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
12020           vvx2=0.d0
12021          else
12022           v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
12023           v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
12024           nn=0
12025 22        nn=nn+1
12026           vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
12027           vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
12028           v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
12029           v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
12030           if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
12031      *    .and.nn.lt.100)then
12032            v1pnu0=v1pnu
12033            v1tnu0=v1tnu
12034            goto 22
12035           endif
12036           vvx2=1.d0-exp(-v1pnu)*(1.d0-vvx)
12037          endif
12038 
12039          glu1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,12) !upper gluon PDF
12040          sea1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,13) !upper quark PDF
12041          glu2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,12)   !lower gluon PDF
12042          sea2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,13)   !lower quark PDF
12043         elseif(jpt.eq.1)then                         !proj. leg Pomeron
12044          rp1=(rq(icdp,icz)+alfp*dlog(wp0/wpi))*4.d0*.0389d0
12045          rp2=-alfp*dlog(xm)*4.d0*.0389d0
12046          rp=rp1*rp2/(rp1+rp2)
12047          z=qgran(b10)
12048          phi=pi*qgran(b10)
12049          b0=dsqrt(-rp*dlog(z))
12050          bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
12051          bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
12052 
12053          glu1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx,icdp,icz,12) !upper gluon PDF
12054          sea1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx,icdp,icz,13) !upper quark PDF
12055          glu2=qgppdi(xm,0)
12056          sea2=qgppdi(xm,1)
12057         elseif(jpt.eq.2)then                         !proj. leg Pomeron
12058          rp1=(rq(icdt,2)+alfp*dlog(wm0/wmi))*4.d0*.0389d0
12059          rp2=-alfp*dlog(xp)*4.d0*.0389d0
12060          rp=rp1*rp2/(rp1+rp2)
12061          z=qgran(b10)
12062          phi=pi*qgran(b10)
12063          b0=dsqrt(-rp*dlog(z))
12064          bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
12065          bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
12066 
12067          glu1=qglegc(1.d0/xm,wpm/wm0,bb1,vvx,icdt,2,12) !upper gluon PDF
12068          sea1=qglegc(1.d0/xm,wpm/wm0,bb1,vvx,icdt,2,13) !upper quark PDF
12069          glu2=qgppdi(xp,0)
12070          sea2=qgppdi(xp,1)
12071         endif
12072         wwgg=glu1*glu2*sjgg
12073         wwqg=sea1*glu2*sjqg
12074         wwgq=glu1*sea2*sjqg
12075         wwqq=sea1*sea2*sjqq
12076         gbyj=-dlog(zpm)*(wwgg+wwqg+wwgq+wwqq)
12077         if(jpt.eq.0)then
12078          rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(zpm*sy/scm)
12079         elseif(jpt.eq.1)then
12080          rh=rq(icdp,icz)-alfp*dlog(wpp/wp0*zpm)
12081         elseif(jpt.eq.2)then
12082          rh=rq(icdt,2)-alfp*dlog(wpm/wm0*zpm)
12083         else
12084          rh=0.d0
12085          stop 'Should not happen in qghot'
12086         endif
12087         gbyj=gbyj/rh*exp(-b*b/(4.d0*.0389d0*rh))
12088 
12089        else                          !q_vg-(gq_v-)ladder
12090         if(iqq.eq.1)then             !q_vg-ladder
12091          wpi=wpp
12092          wmi=wpm*zpm
12093          xm=zpm
12094          if(jpt.eq.0)then            !single Pomeron
12095           rp1=rq(icdp,icz)*4.d0*.0389d0
12096           rp2=(rq(icdt,2)+alfp*dlog(wm0/wmi))*4.d0*.0389d0
12097           rp=rp1*rp2/(rp1+rp2)
12098           z=qgran(b10)
12099           phi=pi*qgran(b10)
12100           b0=dsqrt(-rp*dlog(z))
12101           bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
12102           bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
12103 
12104           xpomr=wm0/wmi/scm
12105           if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
12106            vvx2=0.d0
12107           else
12108            v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
12109            v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
12110            nn=0
12111 23         nn=nn+1
12112            vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
12113            vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
12114            v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
12115            v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
12116            if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
12117      *     .and.nn.lt.100)then
12118             v1pnu0=v1pnu
12119             v1tnu0=v1tnu
12120             goto 23
12121            endif
12122            vvx2=1.d0-exp(-v1pnu)*(1.d0-vvx)
12123           endif
12124 
12125           glu2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,12) !upper gluon PDF
12126           sea2=qglegc(1.d0/xm,wpm/wm0,bb2,vvx2,icdt,2,13) !upper quark PDF
12127           wwqg=glu2*sjqg
12128           wwqq=sea2*sjqq
12129          else                        !leg Pomeron
12130           wwqg=qgppdi(xm,0)*sjqg
12131           wwqq=qgppdi(xm,1)*sjqq
12132          endif
12133         elseif(iqq.eq.2)then         !gq_v-ladder
12134          wpi=wpp*zpm
12135          wmi=wpm
12136          xp=zpm
12137          if(jpt.eq.0)then            !single Pomeron
12138           rp1=(rq(icdp,icz)+alfp*dlog(wp0/wpi))*4.d0*.0389d0
12139           rp2=rq(icdt,2)*4.d0*.0389d0
12140           rp=rp1*rp2/(rp1+rp2)
12141           z=qgran(b10)
12142           phi=pi*qgran(b10)
12143           b0=dsqrt(-rp*dlog(z))
12144           bb1=(b*rp1/(rp1+rp2)+b0*cos(phi))**2+(b0*sin(phi))**2
12145           bb2=(b*rp2/(rp1+rp2)-b0*cos(phi))**2+(b0*sin(phi))**2
12146 
12147           xpomr=wpi/wp0
12148           if(xpomr*sgap.ge.1.d0.or.xpomr*scm.le.sgap)then
12149            vvx1=0.d0
12150           else
12151            v1pnu0=qgfani(1.d0/xpomr,bb1,vvx,0.d0,0.d0,icdp,icz,1)
12152            v1tnu0=qgfani(xpomr*scm,bb2,vvx,0.d0,0.d0,icdt,2,1)
12153            nn=0
12154 24         nn=nn+1
12155            vvxt=1.d0-exp(-v1pnu0)*(1.d0-vvx)
12156            vvxp=1.d0-exp(-v1tnu0)*(1.d0-vvx)
12157            v1pnu=qgfani(1.d0/xpomr,bb1,vvxp,0.d0,0.d0,icdp,icz,1)
12158            v1tnu=qgfani(xpomr*scm,bb2,vvxt,0.d0,0.d0,icdt,2,1)
12159            if((abs(v1pnu0-v1pnu).gt.1.d-1.or.abs(v1tnu0-v1tnu).gt.1.d-1)
12160      *     .and.nn.lt.100)then
12161             v1pnu0=v1pnu
12162             v1tnu0=v1tnu
12163             goto 24
12164            endif
12165            vvx1=1.d0-exp(-v1tnu)*(1.d0-vvx)
12166           endif
12167 
12168           glu1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,12) !upper gluon PDF
12169           sea1=qglegc(1.d0/xp,wpp/wp0,bb1,vvx1,icdp,icz,13) !upper quark PDF
12170           wwqg=glu1*sjqg
12171           wwqq=sea1*sjqq
12172          else                        !leg Pomeron
12173           wwqg=qgppdi(xp,0)*sjqg
12174           wwqq=qgppdi(xp,1)*sjqq
12175          endif
12176         endif
12177         gbyj=wwqg+wwqq
12178         if(jpt.eq.0)then
12179          if(iqq.eq.1)then
12180           rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(wpm/wm0*zpm)
12181          else
12182           rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(wpp/wp0*zpm)
12183          endif
12184         elseif(jpt.eq.1)then
12185          rh=rq(icdp,icz)-alfp*dlog(zpm)
12186         elseif(jpt.eq.2)then
12187          rh=rq(icdt,2)-alfp*dlog(zpm)
12188         else
12189          rh=0.d0
12190          stop 'Should not happen in qghot'
12191         endif
12192         gbyj=gbyj/rh*exp(-b*b/(4.d0*.0389d0*rh))
12193        endif
12194 
12195        gbyj=gbyj/gb0/zpm**delh
12196        if(qgran(b10).gt.gbyj)goto 2
12197       endif
12198       if(debug.ge.2)write (moniou,202)wpi*wmi
12199 
12200 11    wpi1=wpi
12201       wmi1=wmi
12202       wpq=0.d0
12203       wmq=0.d0
12204       nj=nj0                     !initialization for the number of final partons
12205       rrr=qgran(b10)
12206       jqq=0                                  !gg-ladder
12207       if(iqq.eq.1.or.iqq.eq.2)then
12208        if(rrr.lt.wwqq/(wwqg+wwqq))jqq=1      !q_vq_s-laddder
12209       elseif(iqq.eq.0)then
12210        if(rrr.lt.wwqg/(wwgg+wwqg+wwgq+wwqq))then
12211         jqq=1                                !q_sg-ladder
12212        elseif(rrr.lt.(wwqg+wwgq)/(wwgg+wwqg+wwgq+wwqq))then
12213         jqq=2                                !gq_s-ladder
12214        elseif(rrr.lt.(wwqg+wwgq+wwqq)/(wwgg+wwqg+wwgq+wwqq))then
12215         jqq=3                                !q_sq_s-ladder
12216        endif
12217       endif
12218 
12219 c-------------------------------------------------
12220 c parton types for the ladder legs and for the leading jets
12221 c iqc(1) - flavor for the upper quark (0 in case of gluon),
12222 c iqc(2) - the same for the lower one
12223       if(iqq.ne.0.and.iqq.ne.2)then          !q_v from the proj.
12224        call qgvdef(izp,ic1,ic2,icz)          !leading state flavor
12225        iqc(1)=ic1                            !upper leg parton
12226        nj=nj+1
12227        if(nj.gt.njmax)stop'increase njmax!!!'
12228        nva=nj
12229        iqj(nj)=ic2                           !leading jet parton
12230        ncc(1,1)=nj                           !color connection with leading jet
12231        ncc(2,1)=0
12232       else                                   !g(q_s) from the proj.
12233        nj=nj+1
12234        if(nj.gt.njmax)stop'increase njmax!!!'
12235        if(qgran(b10).lt.dc(2))then
12236         iqj(nj)=-4
12237        else
12238         iqj(nj)=-int(2.d0*qgran(b10)+1.d0)
12239        endif
12240        iqj(nj+1)=-iqj(nj)
12241        wp1=wpp-wpi
12242        wp2=wp1*qgran(b10)
12243        wp1=wp1-wp2
12244        eqj(1,nj)=.5d0*wp1
12245        eqj(2,nj)=eqj(1,nj)
12246        eqj(3,nj)=0.d0
12247        eqj(4,nj)=0.d0
12248        eqj(1,nj+1)=.5d0*wp2
12249        eqj(2,nj+1)=eqj(1,nj+1)
12250        eqj(3,nj+1)=0.d0
12251        eqj(4,nj+1)=0.d0
12252        if(jqq.eq.0.or.iqq.eq.0.and.jqq.eq.2)then
12253         iqc(1)=0
12254         ncc(1,1)=nj
12255         ncc(2,1)=nj+1
12256         nj=nj+1
12257         if(nj.gt.njmax)stop'increase njmax!!!'
12258        else
12259         if(qgran(b10).lt..3333d0)then
12260          iqc(1)=3*(2.d0*int(.5d0+qgran(b10))-1.d0)
12261         else
12262          iqc(1)=int(2.d0*qgran(b10)+1.d0)
12263      *   *(2.d0*int(.5d0+qgran(b10))-1.d0)
12264         endif
12265 12      zg=xp+qgran(b10)*(1.d0-xp)           !gluon splitting into qq~
12266         if(qgran(b10).gt.zg**dels*((1.d0-xp/zg)/ (1.d0-xp))**betp)
12267      *  goto 12
12268         xg=xp/zg
12269         wpq0=wpp*(xg-xp)
12270         wmq=1.d0/wpq0
12271         wmi1=wmi1-wmq
12272         if(wmi1*wpi1.le.s2min)goto 11
12273         nj=nj+2
12274         if(nj.gt.njmax)stop'increase njmax!!!'
12275         iqj(nj)=-iqc(1)
12276         if(iabs(iqc(1)).eq.3)iqj(nj)=iqj(nj)*4/3
12277         eqj(1,nj)=.5d0*wmq
12278         eqj(2,nj)=-.5d0*wmq
12279         eqj(3,nj)=0.d0
12280         eqj(4,nj)=0.d0
12281         if(iqc(1).gt.0)then
12282          ncj(1,nj)=nj-1
12283          ncj(1,nj-1)=nj
12284          ncj(2,nj)=0
12285          ncj(2,nj-1)=0
12286          ncc(1,1)=nj-2
12287          ncc(2,1)=0
12288         else
12289          ncj(1,nj)=nj-2
12290          ncj(1,nj-2)=nj
12291          ncj(2,nj)=0
12292          ncj(2,nj-2)=0
12293          ncc(1,1)=nj-1
12294          ncc(2,1)=0
12295         endif
12296        endif
12297       endif
12298 
12299       if((iqq-2)*(iqq-3)*(iqq-4).eq.0)then     !q_v from the targ.
12300        call qgvdef(izt,ic1,ic2,2)              !leading state flavor
12301        iqc(2)=ic1                              !lower leg parton
12302        nj=nj+1
12303        if(nj.gt.njmax)stop'increase njmax!!!'
12304        nvb=nj
12305        iqj(nj)=ic2
12306        ncc(1,2)=nj
12307        ncc(2,2)=0
12308       else
12309        nj=nj+1
12310        if(nj.gt.njmax)stop'increase njmax!!!'
12311        if(qgran(b10).lt.dc(2))then
12312         iqj(nj)=-4
12313        else
12314         iqj(nj)=-int(2.d0*qgran(b10)+1.d0)
12315        endif
12316        iqj(nj+1)=-iqj(nj)
12317        wm1=wpm-wmi
12318        wm2=wm1*qgran(b10)
12319        wm1=wm1-wm2
12320        eqj(1,nj)=.5d0*wm1
12321        eqj(2,nj)=-eqj(1,nj)
12322        eqj(3,nj)=0.d0
12323        eqj(4,nj)=0.d0
12324        eqj(1,nj+1)=.5d0*wm2
12325        eqj(2,nj+1)=-eqj(1,nj+1)
12326        eqj(3,nj+1)=0.d0
12327        eqj(4,nj+1)=0.d0
12328        if(jqq.eq.0.or.iqq.eq.0.and.jqq.eq.1)then
12329         iqc(2)=0
12330         ncc(1,2)=nj
12331         ncc(2,2)=nj+1
12332         nj=nj+1
12333         if(nj.gt.njmax)stop'increase njmax!!!'
12334        else
12335         if(qgran(b10).lt..3333d0)then
12336          iqc(2)=3*(2.d0*int(.5d0+qgran(b10))-1.d0)
12337         else
12338          iqc(2)=int(2.d0*qgran(b10)+1.d0)
12339      *   *(2.d0*int(.5d0+qgran(b10))-1.d0)
12340         endif
12341 14      zg=xm+qgran(b10)*(1.d0-xm)           !gluon splitting into qq~
12342         if(qgran(b10).gt.zg**dels*((1.d0-xm/zg)/ (1.d0-xm))**betp)
12343      *  goto 14
12344         xg=xm/zg
12345         wmq0=wpm*(xg-xm)
12346         wpq=1.d0/wmq0
12347         wpi1=wpi1-wpq
12348         if(wmi1*wpi1.le.s2min)goto 11
12349         nj=nj+2
12350         if(nj.gt.njmax)stop'increase njmax!!!'
12351         iqj(nj)=-iqc(2)
12352         if(iabs(iqc(2)).eq.3)iqj(nj)=iqj(nj)*4/3
12353         eqj(1,nj)=.5d0*wpq
12354         eqj(2,nj)=.5d0*wpq
12355         eqj(3,nj)=0.d0
12356         eqj(4,nj)=0.d0
12357         if(iqc(2).gt.0)then
12358          ncj(1,nj)=nj-1
12359          ncj(1,nj-1)=nj
12360          ncj(2,nj)=0
12361          ncj(2,nj-1)=0
12362          ncc(1,2)=nj-2
12363          ncc(2,2)=0
12364         else
12365          ncj(1,nj)=nj-2
12366          ncj(1,nj-2)=nj
12367          ncj(2,nj)=0
12368          ncj(2,nj-2)=0
12369          ncc(1,2)=nj-1
12370          ncc(2,2)=0
12371         endif
12372        endif
12373       endif
12374 
12375       if(jqq.ne.0)then
12376        if(iqq.ne.0.or.iqq.eq.0.and.jqq.eq.3)then
12377         sjqq1=qgjit(qt0,qt0,wpi1*wmi1,2,2)
12378         gbs=sjqq1/sjqq
12379        else
12380         sjqg1=qgjit(qt0,qt0,wpi1*wmi1,1,2)
12381         gbs=sjqg1/sjqg
12382        endif
12383        if(qgran(b10).gt.gbs)goto 11
12384       endif
12385       wpi=wpi1
12386       wmi=wmi1
12387 
12388       ept(1)=.5d0*(wpi+wmi)      !ladder 4-momentum
12389       ept(2)=.5d0*(wpi-wmi)
12390       ept(3)=0.d0
12391       ept(4)=0.d0
12392       qmin(1)=qt0                !q^2 cutoff for the upper leg
12393       qmin(2)=qt0                !q^2 cutoff for the downer leg
12394       qminn=max(qmin(1),qmin(2)) !overall q^2 cutoff
12395       si=qgnrm(ept)
12396       jini=1
12397       jj=int(1.5d0+qgran(b10)) !1st parton at upper (jj=1) or downer (jj=2) leg
12398 
12399 3     continue
12400 
12401       aaa=qgnrm(ept)             !ladder mass squared
12402       if(debug.ge.3)write (moniou,203)si,iqc,ept,aaa
12403 
12404       pt2=ept(3)**2+ept(4)**2
12405       pt=dsqrt(pt2)
12406       ww=si+pt2
12407 
12408       iqp(1)=min(1,iabs(iqc(1)))+1
12409       iqp(2)=min(1,iabs(iqc(2)))+1
12410       wp(1)=ept(1)+ept(2)                 !LC+ for the ladder
12411       wp(2)=ept(1)-ept(2)                 !LC- for the ladder
12412       s2min=4.d0*fqscal*qminn   !minimal energy squared for 2-parton production
12413       if(jini.eq.1)then                   !general ladder
12414        sj=qgjit(qmin(jj),qmin(3-jj),si,iqp(jj),iqp(3-jj))   !total ladder contribution
12415        sj1=qgjit1(qmin(3-jj),qmin(jj),si,iqp(3-jj),iqp(jj)) !one-way ordered
12416        sjb=qgbit(qmin(1),qmin(2),si,iqp(1),iqp(2))          !born contribution
12417        aks=qgran(b10)
12418        if(aks.lt.sjb/sj)then
12419         goto 6      !born process sampled
12420        elseif(aks.lt.sj1/sj)then       !change to one-way ordered ladder
12421         jj=3-jj
12422         sj=sj1
12423         jini=0
12424        endif
12425       else                                !one-way ordered ladder
12426        sj=qgjit1(qmin(jj),qmin(3-jj),si,iqp(jj),iqp(3-jj)) !one-way ordered
12427        sjb=qgbit(qmin(1),qmin(2),si,iqp(1),iqp(2))         !born contribution
12428        if(qgran(b10).lt.sjb/sj)goto 6      !born process sampled
12429       endif
12430       wwmin=(s2min+qmin(jj)+pt2-2.d0*pt*dsqrt(qmin(jj)*epsxmn))
12431      */(1.d0-epsxmn)           !minimal energy squared for 3-parton production
12432 
12433       if(debug.ge.3)write (moniou,204)s2min,wwmin,sj,sjb
12434 
12435       if(ww.lt.1.1d0*wwmin)goto 6         !energy too low -> born process
12436 
12437       xxx=pt*dsqrt(qmin(jj))/ww
12438       xmin=(s2min+qmin(jj)+pt2)/ww
12439       xmin=xmin-2.d0*xxx*(xxx+dsqrt(xxx**2+1.d0-xmin))
12440 
12441       xmax=1.d0-epsxmn
12442       if(debug.ge.3)write (moniou,205)xmin,xmax
12443 
12444       qqmax=(pt*dsqrt(epsxmn)+dsqrt(max(0.d0,pt2*epsxmn
12445      *+(1.d0+4.d0*fqscal)*(xmax*ww-pt2))))/(1.d0+4.d0*fqscal)
12446       qqmin=qmin(jj)        !minimal parton virtuality in the current rung
12447       if(debug.ge.3)write (moniou,206)qqmin,qqmax
12448 
12449       qm0=qqmin
12450       xm0=xmax
12451       s2max=xm0*ww
12452 
12453       if(jini.eq.1)then
12454        sj0=qgjit(qm0,qmin(3-jj),s2max,1,iqp(3-jj))*qgfap(xm0,iqp(jj),1)
12455      * +qgjit(qm0,qmin(3-jj),s2max,2,iqp(3-jj))*qgfap(xm0,iqp(jj),2)
12456       else
12457        sj0=qgjit1(qm0,qmin(3-jj),s2max,1,iqp(3-jj))
12458      * *qgfap(xm0,iqp(jj),1)
12459      * +qgjit1(qm0,qmin(3-jj),s2max,2,iqp(3-jj))*qgfap(xm0,iqp(jj),2)
12460       endif
12461 
12462       gb0=sj0*qm0*qgalf(qm0/alm)*qgsudx(qm0,iqp(jj)) *4.5d0  !normal. of accept.
12463       if(xm0.le..5d0)then
12464        gb0=gb0*xm0**(1.d0-delh)
12465       else
12466        gb0=gb0*(1.d0-xm0)*2.d0**delh
12467       endif
12468       if(debug.ge.3)write (moniou,208)xm0,xmin,xmax,gb0
12469 
12470       xmin2=max(.5d0,xmin)
12471       xmin1=xmin**delh
12472       xmax1=min(xmax,.5d0)**delh
12473       if(xmin.ge..5d0)then                             !choose proposal function
12474        djl=1.d0
12475       elseif(xmax.lt..5d0)then
12476        djl=0.d0
12477       else
12478        djl=1.d0/(1.d0+((2.d0*xmin)**delh-1.d0)/delh
12479      * /dlog(2.d0*(1.d0-xmax)))
12480       endif
12481 
12482 c-------------------------------------------------
12483 c propose x, q^2
12484 4     continue
12485       if(qgran(b10).gt.djl)then
12486        x=(xmin1+qgran(b10)*(xmax1-xmin1))**(1.d0/delh) !parton LC share
12487       else
12488        x=1.d0-(1.d0-xmin2)*((1.d0-xmax)/(1.d0-xmin2))**qgran(b10)
12489       endif
12490       qq=qqmin/(1.d0+qgran(b10)*(qqmin/qqmax-1.d0))    !parton virtuality
12491       qt2=qq*(1.d0-x)                                  !parton p_t^2
12492       if(debug.ge.4)write (moniou,209)qq,qqmin,qqmax,x,qt2
12493 
12494       if(qq.gt.qminn)then                  !update virtuality cutoff
12495        qmin2=qq
12496       else
12497        qmin2=qminn
12498       endif
12499       qt=dsqrt(qt2)
12500       call qgcs(c,s)
12501       ep3(3)=qt*c                          !final parton p_x, p_y
12502       ep3(4)=qt*s
12503       pt2new=(ept(3)-ep3(3))**2+(ept(4)-ep3(4))**2!p_t^2 for the remained ladder
12504       s2min2=max(s2min,4.d0*fqscal*qmin2)  !new ladder kinematic limit
12505       s2=x*ww-qt2*x/(1.d0-x)-pt2new        !mass squared for the remained ladder
12506       if(s2.lt.s2min2)goto 4           !ladder mass below threshold -> rejection
12507 
12508       if(jini.eq.1)then                    !weights for g- and q-legs
12509        sj1=qgjit(qq,qmin(3-jj),s2,1,iqp(3-jj))*qgfap(x,iqp(jj),1)
12510        sj2=qgjit(qq,qmin(3-jj),s2,2,iqp(3-jj))*qgfap(x,iqp(jj),2)
12511       else
12512        sj1=qgjit1(qq,qmin(3-jj),s2,1,iqp(3-jj))*qgfap(x,iqp(jj),1)
12513        sj2=qgjit1(qq,qmin(3-jj),s2,2,iqp(3-jj))*qgfap(x,iqp(jj),2)
12514       endif
12515       gb7=(sj1+sj2)*qgalf(qq/alm)*qq*qgsudx(qq,iqp(jj))/gb0  /2.d0
12516                                !acceptance probability for x and q**2 simulation
12517       if(x.le..5d0)then
12518        gb7=gb7*x**(1.d0-delh)
12519       else
12520        gb7=gb7*(1.d0-x)*2.d0**delh
12521       endif
12522       if(debug.ge.4)write (moniou,210)gb7,s2,sj1,sj2,jj,jini
12523       if(qgran(b10).gt.gb7)goto 4          !rejection
12524 
12525 c-------------------------------------------------
12526 c define color flow for the emitted jet; perform final state emission
12527       nqc(2)=0
12528       if(qgran(b10).lt.sj1/(sj1+sj2))then         !new gluon-leg ladder
12529        if(iqc(jj).eq.0)then                       !g -> gg
12530         jt=1
12531         jq=int(1.5d0+qgran(b10))
12532         nqc(1)=ncc(jq,jj)                         !color connection for the jet
12533         nqc(2)=0
12534        else                                       !q -> qg
12535         jt=2
12536         if(iqc(jj).gt.0)then                      !orientation of color flow
12537          jq=1
12538         else
12539          jq=2
12540         endif
12541         nqc(1)=0
12542         ncc(jq,jj)=ncc(1,jj)                      !color connection for the jet
12543        endif
12544        iq1=iqc(jj)                                !jet flavor (type)
12545        iqc(jj)=0                                  !new ladder leg flavor (type)
12546 
12547       else                                        !new quark-leg ladder
12548        if(iqc(jj).ne.0)then                       !q -> gq
12549         iq1=0
12550         jt=3
12551         if(iqc(jj).gt.0)then                      !orientation of color flow
12552          jq=1
12553         else
12554          jq=2
12555         endif
12556         nqc(1)=ncc(1,jj)                          !color connection for the jet
12557         nqc(2)=0
12558 
12559        else                                       !g -> qq~
12560         jq=int(1.5d0+qgran(b10))                  !orientation of color flow
12561         iq1=int(3.d0*qgran(b10)+1.d0)*(3-2*jq)    !jet flavor (type)
12562         iqc(jj)=-iq1                              !new ladder leg flavor (type)
12563         jt=4
12564         nqc(1)=ncc(jq,jj)                         !color connections for the jet
12565         ncc(1,jj)=ncc(3-jq,jj)
12566        endif
12567       endif
12568       if(debug.ge.3)write (moniou,211)jt
12569 
12570       call qgcjet(qt2,iq1,qv1,zv1,qm1,iqv1,ldau1,lpar1,jq) !final state emission
12571       si=x*ww-(qt2+qm1(1,1))*x/(1.d0-x)-pt2new  !mass squared for the new ladder
12572       if(si.gt.s2min2)then
12573        iq=min(1,iabs(iqc(jj)))+1
12574        if(jini.eq.1)then
12575         gb=qgjit(qq,qmin(3-jj),si,iq,iqp(3-jj))
12576      *  /qgjit(qq,qmin(3-jj),s2,iq,iqp(3-jj))
12577        else
12578         gb=qgjit1(qq,qmin(3-jj),si,iq,iqp(3-jj))
12579      *  /qgjit1(qq,qmin(3-jj),s2,iq,iqp(3-jj))
12580        endif
12581        if(qgran(b10).gt.gb)goto 1        !jet mass correction for the acceptance
12582       else                                        !below threshold -> rejection
12583        goto 1
12584       endif
12585 
12586       wp3=wp(jj)*(1.d0-x)
12587       wm3=(qt2+qm1(1,1))/wp3
12588       ep3(1)=.5d0*(wp3+wm3)                       !jet 4-momentum
12589       ep3(2)=.5d0*(wp3-wm3)*(3-2*jj)
12590       call qgrec(ep3,nqc,qv1,zv1,qm1,iqv1,ldau1,lpar1,jq)
12591                                !reconstruction of 4-momenta of all final partons
12592 c-------------------------------------------------
12593 c define color connections for the new ladder
12594       if(jt.eq.1)then
12595        if(ncc(1,jj).eq.0.and.ncc(2,jj).eq.0)ncc(3-jq,jj)=nqc(1)
12596        ncc(jq,jj)=nqc(2)
12597       elseif(jt.eq.2)then
12598        ncc(3-jq,jj)=nqc(1)
12599       elseif(jt.eq.3)then
12600        ncc(1,jj)=nqc(2)
12601       elseif(jt.eq.4.and.ncc(1,jj).eq.0.and.ncc(2,jj).eq.0)then
12602        ncc(1,jj)=nqc(1)
12603       endif
12604 
12605       if(iabs(iq1).eq.3)then
12606        iqqq=8+iq1/3*4
12607       else
12608        iqqq=8+iq1
12609       endif
12610       if(debug.ge.3)write (moniou,212)tyq(iqqq),qt2,ep3
12611       do i=1,4
12612        ept(i)=ept(i)-ep3(i)                       !new ladder 4-momentum
12613       enddo
12614       qmin(jj)=qq                                 !new virtuality cutoffs
12615       qminn=qmin2
12616       goto 3                                      !consider next parton emission
12617 
12618 c------------------------------------------------
12619 c born process - last parton pair production in the ladder
12620 6     continue
12621       if(debug.ge.2)write (moniou,214)si,qminn,iqc
12622       tmin=qminn*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qminn*fqscal/si)))
12623       qtmin=tmin*(1.d0-tmin/si)
12624       if(iqc(1).ne.0.or.iqc(2).ne.0)then
12625        gb0=tmin**2*qgalf(qtmin/fqscal/alm)**2
12626      * *qgfbor(si,tmin,iqc(1),iqc(2),1)    *1.1d0
12627       else
12628        gb0=.25d0*si**2*qgalf(qtmin/fqscal/alm)**2
12629      * *qgfbor(si,.5d0*si,iqc(1),iqc(2),1)
12630       endif
12631       gb0=gb0*qgsudx(qtmin/fqscal,iqp(1))*qgsudx(qtmin/fqscal,iqp(2))
12632                                                     !normalization of acceptance
12633       if(debug.ge.3)write (moniou,215)gb0
12634 
12635 7     q2=tmin/(1.d0-qgran(b10)*(1.d0-2.d0*tmin/si))   !proposed q^2
12636       z=q2/si                                         !parton LC momentum share
12637       qt2=q2*(1.d0-z)                                 !parton p_t^2
12638       if(qgran(b10).lt..5d0)then
12639        jm=2
12640        tq=si-q2
12641       else
12642        jm=1
12643        tq=q2
12644       endif
12645       gb=q2**2*qgalf(qt2/fqscal/alm)**2*qgfbor(si,tq,iqc(1),iqc(2),1)
12646      **qgsudx(qt2/fqscal,iqp(1))*qgsudx(qt2/fqscal,iqp(2))/gb0
12647                                                       !acceptance probabilty
12648       if(debug.ge.4)write (moniou,216)gb,q2,z,qt2
12649       if(qgran(b10).gt.gb)goto 7                      !rejection
12650 
12651 c-------------------------------------------------
12652 c define color connections for the 1st emitted jet
12653       nqc(2)=0
12654       if(iqc(1).eq.0.and.iqc(2).eq.0)then             !gg-process
12655        jq=int(1.5d0+qgran(b10))                       !orientation of color flow
12656        nqc(1)=ncc(jq,jm)
12657 
12658        if(qgran(b10).lt..5d0)then
12659         jt=1                                          !gg -> gg
12660         nqc(2)=0
12661         njc1=ncc(3-jq,jm)                         !color connections for 1st jet
12662         njc2=ncc(jq,3-jm)
12663         if(ncc(1,1).eq.0.and.ncc(2,1).eq.0)then
12664          if(jm.eq.1)nqc(1)=njc2
12665         else
12666          if(iqj(njc1).ne.0)then
12667           ncj(1,njc1)=njc2
12668          else
12669           ncj(jq,njc1)=njc2
12670          endif
12671          if(iqj(njc2).ne.0)then
12672           ncj(1,njc2)=njc1
12673          else
12674           ncj(3-jq,njc2)=njc1
12675          endif
12676         endif
12677        else                                 !gg -> gg (inverse color connection)
12678         jt=2
12679         nqc(2)=ncc(3-jq,3-jm)
12680        endif
12681 
12682       elseif(iqc(1)*iqc(2).eq.0)then                  !qg -> qg
12683        if(iqc(1)+iqc(2).gt.0)then                     !orientation of color flow
12684         jq=1
12685        else
12686         jq=2
12687        endif
12688        if(qgran(b10).lt..5d0)then
12689         if(iqc(jm).eq.0)then
12690          jt=3
12691          nqc(1)=ncc(jq,jm)
12692          nqc(2)=0
12693          njc1=ncc(3-jq,jm)
12694          njc2=ncc(1,3-jm)
12695          if(ncc(1,jm).eq.0.and.ncc(2,jm).eq.0)then
12696           nqc(1)=njc2
12697          else
12698           if(iqj(njc1).ne.0)then
12699            ncj(1,njc1)=njc2
12700           else
12701            ncj(jq,njc1)=njc2
12702           endif
12703           if(iqj(njc2).ne.0)then
12704            ncj(1,njc2)=njc1
12705           else
12706            ncj(3-jq,njc2)=njc1
12707           endif
12708          endif
12709         else
12710          jt=4
12711          nqc(1)=0
12712          njc1=ncc(1,jm)
12713          njc2=ncc(3-jq,3-jm)
12714          if(njc2.ne.0)then
12715           if(iqj(njc1).ne.0)then
12716            ncj(1,njc1)=njc2
12717           else
12718            ncj(3-jq,njc1)=njc2
12719           endif
12720           if(iqj(njc2).ne.0)then
12721            ncj(1,njc2)=njc1
12722           else
12723            ncj(jq,njc2)=njc1
12724           endif
12725          endif
12726         endif
12727        else
12728         if(iqc(jm).eq.0)then
12729          jt=5
12730          nqc(2)=ncc(3-jq,jm)
12731          nqc(1)=ncc(1,3-jm)
12732         else
12733          jt=6
12734          nqc(1)=ncc(jq,3-jm)
12735         endif
12736        endif
12737 
12738       elseif(iqc(1)*iqc(2).gt.0)then                  !qq (q~q~) -> qq (q~q~)
12739        jt=7
12740        if(iqc(1).gt.0)then
12741         jq=1
12742        else
12743         jq=2
12744        endif
12745        nqc(1)=ncc(1,3-jm)
12746       else                                            !qq~ -> qq~
12747        jt=8
12748        if(iqc(jm).gt.0)then
12749         jq=1
12750        else
12751         jq=2
12752        endif
12753        nqc(1)=0
12754        njc1=ncc(1,jm)
12755        njc2=ncc(1,3-jm)
12756        if(iqj(njc1).ne.0)then
12757         ncj(1,njc1)=njc2
12758        else
12759         ncj(3-jq,njc1)=njc2
12760        endif
12761        if(iqj(njc2).ne.0)then
12762         ncj(1,njc2)=njc1
12763        else
12764         ncj(jq,njc2)=njc1
12765        endif
12766       endif
12767       if(jt.ne.8)then
12768        jq2=jq
12769       else
12770        jq2=3-jq
12771       endif
12772       if(debug.ge.3)write (moniou,211)jt
12773       call qgcjet(qt2,iqc(jm),qv1,zv1,qm1,iqv1,ldau1,lpar1,jq)!final state emis.
12774       call qgcjet(qt2,iqc(3-jm),qv2,zv2,qm2,iqv2,ldau2,lpar2,jq2)
12775       amt1=qt2+qm1(1,1)
12776       amt2=qt2+qm2(1,1)
12777       if(dsqrt(si).gt.dsqrt(amt1)+dsqrt(amt2))then
12778        z=qgtwd(si,amt1,amt2)
12779       else
12780        if(debug.ge.4)write (moniou,217)dsqrt(si),dsqrt(amt1),dsqrt(amt2)
12781        goto 1                                      !below threshold -> rejection
12782       endif
12783 
12784       call qgdeft(si,ept,ey)
12785       wp3=z*dsqrt(si)
12786       wm3=(qt2+qm1(1,1))/wp3
12787       ep3(1)=.5d0*(wp3+wm3)                        !1st jet 4-momentum
12788       ep3(2)=.5d0*(wp3-wm3)
12789       qt=dsqrt(qt2)
12790       call qgcs(c,s)
12791       ep3(3)=qt*c
12792       ep3(4)=qt*s
12793 
12794       call qgtran(ep3,ey,1)
12795       call qgrec(ep3,nqc,qv1,zv1,qm1,iqv1,ldau1,lpar1,jq)
12796                                !reconstruction of 4-momenta of all final partons
12797       if(iabs(iqc(jm)).eq.3)then
12798        iqqq=8+iqc(jm)/3*4
12799       else
12800        iqqq=8+iqc(jm)
12801       endif
12802       if(debug.ge.3)write (moniou,212)tyq(iqqq),qt2,ep3
12803 
12804       wp3=(1.d0-z)*dsqrt(si)
12805       wm3=(qt2+qm2(1,1))/wp3
12806       ep3(1)=.5d0*(wp3+wm3)                        !2nd jet 4-momentum
12807       ep3(2)=.5d0*(wp3-wm3)
12808       ep3(3)=-qt*c
12809       ep3(4)=-qt*s
12810       call qgtran(ep3,ey,1)
12811 
12812 c-------------------------------------------------
12813 c define color connections for the 2nd emitted jet
12814       if(jt.eq.1)then
12815        nqc(1)=nqc(2)
12816        if(ncc(1,3-jm).eq.0.and.ncc(2,3-jm).eq.0)then
12817         nqc(2)=ncc(3-jq,jm)
12818        else
12819         nqc(2)=ncc(3-jq,3-jm)
12820        endif
12821       elseif(jt.eq.2)then
12822        if(ncc(1,1).eq.0.and.ncc(2,1).eq.0)then
12823         if(jm.eq.1)then
12824          nqc(2)=nqc(1)
12825          nqc(1)=ncc(jq,3-jm)
12826         else
12827          nqc(1)=nqc(2)
12828          nqc(2)=ncc(3-jq,jm)
12829         endif
12830        else
12831         nqc(2)=ncc(3-jq,jm)
12832         nqc(1)=ncc(jq,3-jm)
12833        endif
12834       elseif(jt.eq.3)then
12835        nqc(1)=nqc(2)
12836       elseif(jt.eq.4)then
12837        nqc(2)=nqc(1)
12838        if(ncc(1,1).eq.0.and.ncc(2,1).eq.0)then
12839         nqc(1)=ncc(1,jm)
12840        else
12841         nqc(1)=ncc(jq,3-jm)
12842        endif
12843       elseif(jt.eq.5)then
12844        if(ncc(1,jm).eq.0.and.ncc(2,jm).eq.0)then
12845         nqc(1)=nqc(2)
12846        else
12847         nqc(1)=ncc(jq,jm)
12848        endif
12849       elseif(jt.eq.6)then
12850        if(ncc(1,3-jm).eq.0.and.ncc(2,3-jm).eq.0)then
12851         nqc(2)=nqc(1)
12852        else
12853         nqc(2)=ncc(3-jq,3-jm)
12854        endif
12855        nqc(1)=ncc(1,jm)
12856       elseif(jt.eq.7)then
12857        nqc(1)=ncc(1,jm)
12858       endif
12859       call qgrec(ep3,nqc,qv2,zv2,qm2,iqv2,ldau2,lpar2,jq2)
12860                                !reconstruction of 4-momenta of all final partons
12861       if(iabs(iqc(3-jm)).eq.3)then
12862        iqqq=8+iqc(3-jm)/3*4
12863       else
12864        iqqq=8+iqc(3-jm)
12865       endif
12866       if(debug.ge.3)write (moniou,212)tyq(iqqq),qt2,ep3
12867 
12868       ebal(1)=.5d0*(wpp+wpm)                          !balans of 4-momentum
12869       ebal(2)=.5d0*(wpp-wpm)
12870       ebal(3)=0.d0
12871       ebal(4)=0.d0
12872       do i=nj0+1,nj
12873        if(iqq.eq.0.or.iqq.eq.1.and.i.ne.nva.or.iqq.eq.2
12874      * .and.i.ne.nvb.or.iqq.eq.3.and.i.ne.nva.and.i.ne.nvb)then
12875         do j=1,4
12876          ebal(j)=ebal(j)-eqj(j,i)
12877         enddo
12878        endif
12879       enddo
12880       if(debug.ge.2)write (moniou,218)nj
12881       if(debug.ge.5)write (moniou,219)ebal
12882       if(debug.ge.1)write (moniou,220)
12883 
12884 201   format(2x,'qghot - semihard interaction:'/
12885      *4x,'type of the interaction - ',i2/
12886      *4x,'initial light cone momenta - ',2e10.3/
12887      *4x,'remnant types - ',2i3,2x,'diffr. eigenstates - ',2i2/
12888      *4x,'proj. class - ',i2,2x,'Pomeron type - ',i2/
12889      *4x,'initial number of final partons - ',i4)
12890 202   format(2x,'qghot: mass squared for parton ladder - ',e10.3)
12891 203   format(2x,'qghot: ',' mass squared for the laddder:',e10.3/
12892      *4x,'ladder end flavors:',2i3/4x,'ladder 5-momentum: ',5e10.3)
12893 204   format(2x,'qghot: kinematic bounds s2min=',e10.3,
12894      *2x,'wwmin=',e10.3/4x,'jet cross section sj=',e10.3,
12895      *2x,'born cross section sjb=',e10.3)
12896 205   format(2x,'qghot: xmin=',e10.3,2x,'xmax=',e10.3)
12897 206   format(2x,'qghot: qqmin=',e10.3,2x,'qqmax=',e10.3)
12898 208   format(2x,'qghot: xm0=',e10.3,2x,'xmin=',e10.3,2x,
12899      *'xmax=',e10.3,2x,'gb0=',e10.3)
12900 209   format(2x,'qghot: qq=',e10.3,2x,'qqmin=',e10.3,2x,
12901      *'qqmax=',e10.3,2x,'x=',e10.3,2x,'qt2=',e10.3)
12902 210   format(2x,'qghot: gb7=',e10.3,2x,'s2=',e10.3,2x,'sj1=',e10.3
12903      *,2x,'sj2=',e10.3,2x,'jj=',i2,2x,'jini=',i2)
12904 211   format(2x,'qghot: colour connection jt=:',i1)
12905 212   format(2x,'qghot: new jet flavor:',a2,
12906      *' pt squared for the jet:',e10.3/4x,'jet 4-momentum:',4e10.3)
12907 214   format(2x,'qghot - highest virtuality subprocess in the ladder:'/
12908      *4x,'mass squared for the process:',e10.3/4x,'q^2-cutoff:',e10.3
12909      *,2x,'iqc=',2i3)
12910 215   format(2x,'qghot - normalization of acceptance:',' gb0=',e10.3)
12911 216   format(2x,'qghot - acceptance probabilty:'/
12912      *4x,'gb=',e10.3,2x,'q2=',e10.3,2x,'z=',e10.3,2x,'qt2=',e10.3)
12913 217   format(2x,'qghot: ecm=',e10.3,2x,'mt1=',e10.3,2x,'mt2=',e10.3)
12914 218   format(2x,'qghot: total number of jets - ',i4)
12915 219   format(2x,'qghot: 4-momentum balans - ',4e10.3)
12916 220   format(2x,'qghot - end')
12917       return
12918       end
12919 
12920 c------------------------------------------------------------------------
12921       function npgen(vv,npmin,npmax)
12922 c-----------------------------------------------------------------------
12923 c npgen -  Poisson distribution
12924 c vv    - average number
12925 c npmin - minimal number
12926 c npmax - maximal number
12927 c-----------------------------------------------------------------------
12928       implicit double precision (a-h,o-z)
12929       integer debug
12930       common /qgarr11/ b10
12931       common /qgarr43/ moniou
12932       common /qgdebug/  debug
12933       EXTERNAL qgran
12934 
12935       if(npmin.eq.0)then
12936        aks=qgran(b10)
12937        vvn=exp(-vv)
12938        do n=1,npmax
12939          aks=aks-vvn
12940         if(aks.lt.0.d0)goto 1
12941          vvn=vvn*vv/dble(n)
12942        enddo
12943       elseif(npmin.eq.1)then
12944        aks=qgran(b10)*(1.d0-exp(-vv))
12945        vvn=exp(-vv)
12946        do n=1,npmax
12947          vvn=vvn*vv/dble(n)
12948          aks=aks-vvn
12949         if(aks.lt.0.d0)goto 2
12950        enddo
12951       elseif(npmin.eq.2)then
12952        aks=qgran(b10)*(1.d0-exp(-vv)*(1.d0+vv))
12953        vvn=vv*exp(-vv)
12954        do n=2,npmax
12955          vvn=vvn*vv/dble(n)
12956          aks=aks-vvn
12957         if(aks.lt.0.d0)goto 2
12958        enddo
12959       else
12960        stop'npgen'
12961       endif
12962 1     n=n-1
12963 2     npgen=n
12964       return
12965       end
12966 
12967 c=============================================================================
12968       subroutine qglead(wppr0,wmtg0,lqa,lqb,lqa0,lqb0,lva,lvb
12969      *,izp,izt,ila,ilb,iret)
12970 c-------------------------------------------------------------------------
12971 c qglead-treatment of leading hadron states
12972 c-------------------------------------------------------------------------
12973       implicit double precision (a-h,o-z)
12974       integer debug
12975       parameter(njmax=50000)
12976       common /qgdebug/ debug
12977       common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
12978 
12979       iret=0
12980       if(lqa0.eq.0.and.lqb0.eq.0)then
12981        if(lva.eq.0.and.lvb.eq.0)then
12982         call qgdifr(wppr0,wmtg0,izp,izt,lqa,lqb,iret)
12983        elseif(lva.eq.0)then
12984         call qgdifr(wppr0,wmtg0,izp,izt,lqa,-1,iret)
12985        elseif(lvb.eq.0)then
12986         call qgdifr(wppr0,wmtg0,izp,izt,-1,lqb,iret)
12987        endif
12988        if(lva.eq.1)then
12989         eqj(1,ila)=.5d0*wppr0
12990         eqj(2,ila)=eqj(1,ila)
12991         eqj(3,ila)=0.d0
12992         eqj(4,ila)=0.d0
12993        endif
12994        if(lvb.eq.1)then
12995         eqj(1,ilb)=.5d0*wmtg0
12996         eqj(2,ilb)=-eqj(1,ilb)
12997         eqj(3,ilb)=0.d0
12998         eqj(4,ilb)=0.d0
12999        endif
13000       elseif(lqa0.eq.0)then
13001        if(lva.eq.0)then
13002         call qgdifr(wppr0,wmtg0,izp,izt,lqa,-1,iret)
13003        else
13004         eqj(1,ila)=.5d0*wppr0
13005         eqj(2,ila)=eqj(1,ila)
13006         eqj(3,ila)=0.d0
13007         eqj(4,ila)=0.d0
13008        endif
13009       elseif(lqb0.eq.0)then
13010        if(lvb.eq.0)then
13011         call qgdifr(wppr0,wmtg0,izp,izt,-1,lqb,iret)
13012        else
13013         eqj(1,ilb)=.5d0*wmtg0
13014         eqj(2,ilb)=-eqj(1,ilb)
13015         eqj(3,ilb)=0.d0
13016         eqj(4,ilb)=0.d0
13017        endif
13018       endif
13019       return
13020       end
13021 
13022 c=============================================================================
13023       double precision function qgbit(qi,qj,s,m,l)
13024 c------------------------------------------------------------------------
13025 c qgbit - born cross-section interpolation
13026 c qi,qj - effective momentum cutoffs for the scattering,
13027 c s - total c.m. energy squared for the scattering,
13028 c m - parton type at current end of the ladder (1 - g, 2 - q)
13029 c l - parton type at opposite end of the ladder (1 - g, 2 - q)
13030 c------------------------------------------------------------------------
13031       implicit double precision (a-h,o-z)
13032       integer debug
13033       dimension wi(3),wk(3)
13034       common /qgarr18/ alm,qt0,qtf,betp,dgqq
13035       common /qgarr20/ spmax
13036       common /qgarr26/ factk,fqscal
13037       common /qgarr31/ csj(40,160)
13038       common /qgarr43/ moniou
13039       common /qgdebug/  debug
13040 
13041       if(debug.ge.2)write (moniou,201)qi,qj,s,m,l
13042       qgbit=0.d0
13043       qq=max(qi,qj)
13044       s2min=qq*4.d0*fqscal
13045       if(s.le..99d0*s2min)then
13046        if(debug.ge.3)write (moniou,202)qgbit
13047        return
13048       endif
13049 
13050       tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
13051       ml=40*(m-1)+80*(l-1)
13052       qli=dlog(qq)/dlog(spmax/4.d0/fqscal)*39.d0+1.d0
13053       sl=dlog(s/s2min)/dlog(spmax/s2min)*39.d0+1.d0
13054       i=min(38,int(qli))
13055       k=min(38,int(sl))
13056 
13057       wk(2)=sl-k
13058       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
13059       wk(1)=1.d0-wk(2)+wk(3)
13060       wk(2)=wk(2)-2.d0*wk(3)
13061       wi(2)=qli-i
13062       wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
13063       wi(1)=1.d0-wi(2)+wi(3)
13064       wi(2)=wi(2)-2.d0*wi(3)
13065       do k1=1,3
13066        k2=k+k1-1+ml
13067       do i1=1,3
13068        qgbit=qgbit+csj(i+i1-1,k2)*wi(i1)*wk(k1)
13069       enddo
13070       enddo
13071       qgbit=exp(qgbit)*(1.d0/tmin-2.d0/s)
13072       if(qi.lt.qq)qgbit=qgbit*qgsudx(qq,m)/qgsudx(qi,m)
13073       if(qj.lt.qq)qgbit=qgbit*qgsudx(qq,l)/qgsudx(qj,l)
13074 
13075       if(debug.ge.3)write (moniou,202)qgbit
13076 201   format(2x,'qgbit: qi=',e10.3,2x,'qj=',e10.3
13077      *,2x,'s= ',e10.3,2x,'m= ',i1,2x,'l= ',i1)
13078 202   format(2x,'qgbit=',e10.3)
13079       return
13080       end
13081 
13082 c=============================================================================
13083       double precision function qgfbor(s,t,iq1,iq2,n)
13084 c---------------------------------------------------------------------------
13085 c qgfbor - integrand for the born cross-section (matrix element squared)
13086 c s - total c.m. energy squared for the scattering,
13087 c t - invariant variable for the scattering abs[(p1-p3)**2],
13088 c iq1 - parton type at current end of the ladder (0 - g, 1,2 - q)
13089 c iq2 - parton type at opposite end of the ladder (0 - g, 1,2 - q)
13090 c---------------------------------------------------------------------------
13091       implicit double precision (a-h,o-z)
13092       integer debug
13093       common /qgarr18/ alm,qt0,qtf,betp,dgqq
13094       common /qgarr43/ moniou
13095       common /qgdebug/  debug
13096 
13097       if(debug.ge.2)write (moniou,201)s,t,iq1,iq2
13098 
13099       u=s-t
13100 c... initialize
13101       qgfbor=0.0
13102       if(n.eq.1)then
13103        if(iq1.eq.0.and.iq2.eq.0)then        !gluon-gluon
13104         qgfbor=(3.d0-t*u/s**2+s*u/t**2+s*t/u**2)*4.5d0
13105        elseif(iq1*iq2.eq.0)then             !gluon-quark
13106         qgfbor=(s**2+u**2)/t**2+(s/u+u/s)/2.25d0
13107        elseif(iq1.eq.iq2)then               !quark-quark (same flavor)
13108         qgfbor=((s**2+u**2)/t**2+(s**2+t**2)/u**2)/2.25d0
13109      *  -s**2/t/u/3.375d0
13110        elseif(iq1+iq2.eq.0)then             !quark-antiquark (same flavor)
13111         qgfbor=((s**2+u**2)/t**2+(u**2+t**2)/s**2)/2.25d0
13112      *  +u**2/t/s/3.375d0
13113        else                                 !quark-antiquark (different flavors)
13114         qgfbor=(s**2+u**2)/t**2/2.25d0
13115        endif
13116       elseif(n.eq.2)then
13117        if(iq1.eq.0.and.iq2.eq.0)then        !gluon-gluon->quark-antiquark
13118         qgfbor=.5d0*(t/u+u/t)-1.125d0*(t*t+u*u)/s**2
13119        elseif(iq1+iq2.eq.0)then             !quark-antiquark->quark-antiquark
13120         qgfbor=(t*t+u*u)/s**2/1.125d0       !(different flavor)
13121        else
13122         qgfbor=0.d0
13123        endif
13124       elseif(n.eq.3)then
13125        if(iq1.ne.0.and.iq1+iq2.eq.0)then    !quark-antiquark->gluon-gluon
13126         qgfbor=32.d0/27.d0*(t/u+u/t)-(t*t+u*u)/s**2/.375d0
13127        else
13128         qgfbor=0.d0
13129        endif
13130       endif
13131 
13132       if(debug.ge.2)write (moniou,202)qgfbor
13133 201   format(2x,'qgfbor - hard scattering matrix element squared:'/
13134      *4x,'s=',e10.3,2x,'|t|=',e10.3,2x,'iq1=',i1,2x,'iq2=',i1)
13135 202   format(2x,'qgfbor=',e10.3)
13136       return
13137       end
13138 
13139 c=============================================================================
13140       double precision function qgborn(qi,qj,s,iq1,iq2)
13141 c-----------------------------------------------------------------------------
13142 c qgborn - hard 2->2 parton scattering born cross-section
13143 c s is the c.m. energy square for the scattering process,
13144 c iq1 - parton type at current end of the ladder (0 - g, 1,2 etc. - q)
13145 c iq2 - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q)
13146 c-----------------------------------------------------------------------------
13147       implicit double precision (a-h,o-z)
13148       integer debug
13149       common /qgarr6/  pi,bm,amws
13150       common /qgarr18/ alm,qt0,qtf,betp,dgqq
13151       common /qgarr26/ factk,fqscal
13152       common /qgarr43/ moniou
13153       common /qgdebug/  debug
13154       common /arr3/  x1(7),a1(7)
13155 
13156       if(debug.ge.2)write (moniou,201)qi,qj,s,iq1,iq2
13157 
13158       qgborn=0.d0
13159       qq=max(qi,qj)
13160       tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
13161       do i=1,7
13162       do m=1,2
13163        t=2.d0*tmin/(1.d0+2.d0*tmin/s-x1(i)*(2*m-3)*(1.d0-2.d0*tmin/s))
13164        qt=t*(1.d0-t/s)
13165 
13166        fb=0.d0
13167        do n=1,3
13168         fb=fb+qgfbor(s,t,iq1,iq2,n)+qgfbor(s,s-t,iq1,iq2,n)
13169        enddo
13170        fb=fb*qgsudx(qt/fqscal,iabs(iq1)+1)
13171      * *qgsudx(qt/fqscal,iabs(iq2)+1)
13172 
13173        qgborn=qgborn+a1(i)*fb*qgalf(qt/fqscal/alm)**2*t**2
13174       enddo
13175       enddo
13176       qgborn=qgborn*2.d0*pi**3/s**2
13177 
13178       qgborn=qgborn/qgsudx(qi,iabs(iq1)+1)/qgsudx(qj,iabs(iq2)+1)
13179       if(iq1.eq.iq2)qgborn=qgborn*.5d0
13180 
13181       if(debug.ge.3)write (moniou,202)qgborn
13182 201   format(2x,'qgborn: qi=',e10.3,2x,'qj=',e10.3,2x,
13183      *'s= ',e10.3,2x,'iq1= ',i1,2x,'iq2= ',i1)
13184 202   format(2x,'qgborn=',e10.3)
13185       return
13186       end
13187 
13188 c=============================================================================
13189       subroutine qgcjet(qq,iq1,qv,zv,qm,iqv,ldau,lpar,jq)
13190 c-----------------------------------------------------------------------------
13191 c final state emission process (all branchings as well as parton masses
13192 c are determined)
13193 c qq - maximal effective momentum transfer for the first branching
13194 c iq1 - initial jet flavour (0 - for gluon)
13195 c qv(i,j) - effective momentum for the branching of the parton in i-th row
13196 c on j-th level (0 - in case of no branching)  - to be determined
13197 c zv(i,j) - z-value for the branching of the parton in i-th row
13198 c on j-th level - to be determined
13199 c qm(i,j) - mass squared for the parton in i-th row
13200 c on j-th level - to be determined
13201 c iqv(i,j) - flavour for the parton in i-th row on j-th level
13202 c - to be determined
13203 c ldau(i,j) - first daughter row for the branching of the parton in i-th row
13204 c on j-th level - to be determined
13205 c lpar(i,j) - the parent row for the parton in i-th row
13206 c on j-th level - to be determined
13207 c-----------------------------------------------------------------------------
13208       implicit double precision (a-h,o-z)
13209       integer debug
13210       dimension qmax(30,50),iqm(2),lnv(50),
13211      *qv(30,50),zv(30,50),qm(30,50),iqv(30,50),
13212      *ldau(30,49),lpar(30,50)
13213       common /qgarr11/ b10
13214       common /qgarr18/ alm,qt0,qtf,betp,dgqq
13215       common /qgarr43/ moniou
13216       common /qgdebug/  debug
13217       EXTERNAL qgran
13218 
13219       if(debug.ge.2)write (moniou,201)qq,iq1,jq
13220 
13221       do i=2,20
13222        lnv(i)=0
13223       enddo
13224       lnv(1)=1
13225       qmax(1,1)=qq
13226       iqv(1,1)=iq1
13227       nlev=1
13228       nrow=1
13229 
13230 2     qlmax=dlog(qmax(nrow,nlev)/qtf/16.d0)
13231       iq=min(1,iabs(iqv(nrow,nlev)))+1
13232 
13233       if(qgran(b10).gt.qgsudi(qlmax,iq))then
13234        q=qgqint(qlmax,qgran(b10),iq)
13235        z=qgzsim(q,iq)
13236        ll=lnv(nlev+1)+1
13237        ldau(nrow,nlev)=ll
13238        lpar(ll,nlev+1)=nrow
13239        lpar(ll+1,nlev+1)=nrow
13240        lnv(nlev+1)=ll+1
13241 
13242        if(iq.ne.1)then
13243         if((3-2*jq)*iqv(nrow,nlev).gt.0)then
13244          iqm(1)=0
13245          iqm(2)=iqv(nrow,nlev)
13246         else
13247          iqm(2)=0
13248          iqm(1)=iqv(nrow,nlev)
13249          z=1.d0-z
13250         endif
13251        else
13252         wg=qgfap(z,1,1)
13253         wg=wg/(wg+qgfap(z,1,2))
13254         if(qgran(b10).lt.wg)then
13255          iqm(1)=0
13256          iqm(2)=0
13257         else
13258          iqm(1)=int(3.d0*qgran(b10)+1.d0)*(3-2*jq)
13259          iqm(2)=-iqm(1)
13260         endif
13261         if(qgran(b10).lt..5d0)z=1.d0-z
13262        endif
13263        qv(nrow,nlev)=q
13264        zv(nrow,nlev)=z
13265        nrow=ll
13266        nlev=nlev+1
13267        qmax(nrow,nlev)=q*z**2
13268        qmax(nrow+1,nlev)=q*(1.d0-z)**2
13269        iqv(nrow,nlev)=iqm(1)
13270        iqv(nrow+1,nlev)=iqm(2)
13271        if(debug.ge.3)write (moniou,203)nlev,nrow,q,z
13272        goto 2
13273       else
13274        qv(nrow,nlev)=0.d0
13275        zv(nrow,nlev)=0.d0
13276        qm(nrow,nlev)=0.d0
13277        if(debug.ge.3)write (moniou,204)nlev,nrow
13278       endif
13279 
13280 3     continue
13281       if(nlev.eq.1)then
13282        if(debug.ge.3)write (moniou,202)
13283        return
13284       endif
13285 
13286       lprow=lpar(nrow,nlev)
13287       if(ldau(lprow,nlev-1).eq.nrow)then
13288        nrow=nrow+1
13289        goto 2
13290       else
13291        z=zv(lprow,nlev-1)
13292        qm(lprow,nlev-1)=z*(1.d0-z)*qv(lprow,nlev-1)
13293      * +qm(nrow-1,nlev)/z+qm(nrow,nlev)/(1.d0-z)
13294        nrow=lprow
13295        nlev=nlev-1
13296        if(debug.ge.3)write (moniou,205)nlev,nrow,qm(lprow,nlev)
13297        goto 3
13298       endif
13299 
13300 201   format(2x,'qgcjet: qq=',e10.3,2x,'iq1= ',i1,2x,'jq=',i1)
13301 202   format(2x,'qgcjet - end')
13302 203   format(2x,'qgcjet: new branching at level nlev=',i2,' nrow=',i2
13303      */4x,' effective momentum q=',e10.3,2x,' z=',e10.3)
13304 204   format(2x,'qgcjet: new final jet at level nlev=',i2,' nrow=',i2)
13305 205   format(2x,'qgcjet: jet mass at level nlev=',i2,' nrow=',i2
13306      *,' - qm=',e10.3)
13307       end
13308 
13309 c===========================================================================
13310       subroutine qgcs(c,s)
13311 c---------------------------------------------------------------------------
13312 c c,s - cos and sin generation for uniformly distributed angle 0<fi<2*pi
13313 c---------------------------------------------------------------------------
13314       implicit double precision (a-h,o-z)
13315       integer debug
13316       common /qgarr11/ b10
13317       common /qgarr43/ moniou
13318       common /qgdebug/  debug
13319       EXTERNAL qgran
13320 
13321       if(debug.ge.2)write (moniou,201)
13322 1     s1=2.d0*qgran(b10)-1.d0
13323       s2=2.d0*qgran(b10)-1.d0
13324       s3=s1*s1+s2*s2
13325       if(s3.gt.1.d0)goto 1
13326       s3=dsqrt(s3)
13327       c=s1/s3
13328       s=s2/s3
13329 
13330       if(debug.ge.3)write (moniou,202)c,s
13331 201   format(2x,'qgcs - cos(fi) and sin(fi) are generated',
13332      *' (0<fi<2*pi)')
13333 202   format(2x,'qgcs: c=',e10.3,2x,'s=',e10.3)
13334       return
13335       end
13336 
13337 c===========================================================================
13338       subroutine qgdeft(s,ep,ey)
13339 c---------------------------------------------------------------------------
13340 c determination of the parameters for the lorentz transform to the rest frame
13341 c system for 4-vector ep
13342 c---------------------------------------------------------------------------
13343       implicit double precision (a-h,o-z)
13344       integer debug
13345       dimension ey(3),ep(4)
13346       common /qgarr43/ moniou
13347       common /qgdebug/  debug
13348 
13349       if(debug.ge.2)write (moniou,201)ep,s
13350 
13351       do i=1,3
13352        if(ep(i+1).eq.0.d0)then
13353         ey(i)=1.d0
13354        else
13355         wp=ep(1)+ep(i+1)
13356         wm=ep(1)-ep(i+1)
13357         if(wm/wp.lt.1.d-8)then
13358          ww=s
13359          do l=1,3
13360           if(l.ne.i)ww=ww+ep(l+1)**2
13361          enddo
13362          wm=ww/wp
13363         endif
13364         ey(i)=dsqrt(wm/wp)
13365         ep(1)=wp*ey(i)
13366         ep(i+1)=0.d0
13367        endif
13368       enddo
13369 
13370       if(debug.ge.3)write (moniou,202)ey
13371 201   format(2x,'qgdeft - lorentz boost parameters:'
13372      */4x,'4-vector ep=',4e10.3/4x,'4-vector squared s=',e10.3)
13373 202   format(2x,'qgdeft: lorentz boost parameters ey(i)=',2x,3e10.3)
13374       return
13375       end
13376 
13377 c=============================================================================
13378       subroutine qgdefr(ep,s0x,c0x,s0,c0)
13379 c-----------------------------------------------------------------------------
13380 c determination of the parameters the spacial rotation to the lab. system
13381 c for 4-vector ep
13382 c-----------------------------------------------------------------------------
13383       implicit double precision (a-h,o-z)
13384       integer debug
13385       dimension ep(4)
13386       common /qgarr43/ moniou
13387       common /qgdebug/  debug
13388 
13389       if(debug.ge.2)write (moniou,201)ep
13390 
13391 c transverse momentum square for the current parton (ep)
13392       pt2=ep(3)**2+ep(4)**2
13393       if(pt2.ne.0.d0)then
13394        pt=dsqrt(pt2)
13395 c system rotation to get pt=0 - euler angles are determined (c0x = cos theta,
13396 c s0x = sin theta, c0 = cos phi, s0 = sin phi)
13397        c0x=ep(3)/pt
13398        s0x=ep(4)/pt
13399 c total momentum for the gluon
13400        pl=dsqrt(pt2+ep(2)**2)
13401        s0=pt/pl
13402        c0=ep(2)/pl
13403       else
13404        c0x=1.d0
13405        s0x=0.d0
13406        pl=abs(ep(2))
13407        s0=0.d0
13408        c0=ep(2)/pl
13409       endif
13410       ep(2)=pl
13411       ep(3)=0.d0
13412       ep(4)=0.d0
13413 
13414       if(debug.ge.3)write (moniou,202)s0x,c0x,s0,c0,ep
13415 201   format(2x,'qgdefr - spacial rotation parameters'/4x,
13416      *'4-vector ep=',2x,4(e10.3,1x))
13417 202   format(2x,'qgdefr: spacial rotation parameters'/
13418      *4x,'s0x=',e10.3,2x,'c0x=',e10.3,2x,'s0=',e10.3,2x,'c0=',e10.3/
13419      *4x,'rotated 4-vector ep=',4(e10.3,1x))
13420       return
13421       end
13422 
13423 c=============================================================================
13424       double precision function qgfap(x,j,l)
13425 c------------------------------------------------------------------------
13426 c qgfap - altarelli-parisi function (multiplied by x)
13427 c x - light cone momentum share value,
13428 c j - type of the parent parton (1-g,2-q)
13429 c l - type of the daughter parton (1-g,2-q)
13430 c------------------------------------------------------------------------
13431       implicit double precision (a-h,o-z)
13432       integer debug
13433       common /qgarr43/ moniou
13434       common /qgdebug/  debug
13435 
13436       if(debug.ge.2)write (moniou,201)x,j,l
13437 
13438       if(j.eq.1)then
13439        if(l.eq.1)then
13440         qgfap=((1.d0-x)/x+x/(1.d0-x)+x*(1.d0-x))*6.d0
13441        else
13442         qgfap=(x**2+(1.d0-x)**2)*3.d0
13443        endif
13444       else
13445        if(l.eq.1)then
13446         qgfap=(1.d0+(1.d0-x)**2)/x/.75d0
13447        else
13448         qgfap=(x**2+1.d0)/(1.d0-x)/.75d0
13449        endif
13450       endif
13451 
13452       if(debug.ge.3)write (moniou,202)qgfap
13453 201   format(2x,'qgfap - altarelli-parisi function:'
13454      *,2x,'x=',e10.3,2x,'j=',i1,2x,'l=',i1)
13455 202   format(2x,'qgfap=',e10.3)
13456       return
13457       end
13458 
13459 c=============================================================================
13460       subroutine qggea(ia,xa,jj)
13461 c-----------------------------------------------------------------------------
13462 c qggea - nuclear configuration simulation (nucleons positions)
13463 c ia - number of nucleons to be considered
13464 c-----------------------------------------------------------------------------
13465       implicit double precision (a-h,o-z)
13466       integer debug
13467       parameter(iapmax=208)
13468       dimension xa(iapmax,3)
13469       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
13470      *,cr1(2),cr2(2),cr3(2)
13471       common /qgarr6/  pi,bm,amws
13472       common /qgarr11/ b10
13473       common /qgarr43/ moniou
13474       common /qgdebug/  debug
13475       EXTERNAL qgran
13476 
13477       if(debug.ge.2)write (moniou,201)jj,ia
13478 
13479       if(ia.ge.10)then
13480        do i=1,ia
13481 1       zuk=qgran(b10)*cr1(jj)-1.d0
13482 c        if(zuk)2,2,3
13483         if(zuk.le.0.d0)then
13484          tt=rnuc(jj)/wsnuc(jj)*(qgran(b10)**.3333d0-1.d0)
13485          goto 6
13486         else
13487          if(zuk.gt.cr2(jj))goto 4
13488          tt=-dlog(qgran(b10))
13489          goto 6
13490 4        if(zuk.gt.cr3(jj))goto 5
13491          tt=-dlog(qgran(b10))-dlog(qgran(b10))
13492          goto 6
13493 5        tt=-dlog(qgran(b10))-dlog(qgran(b10))-dlog(qgran(b10))
13494         endif
13495 6       rim=tt*wsnuc(jj)+rnuc(jj)
13496         if(qgran(b10).gt.(1.d0+wbnuc(jj)*rim**2/rnuc(jj)**2)
13497      *  /(1.d0+exp(-abs(tt))))goto 1
13498         z=rim*(2.d0*qgran(b10)-1.d0)
13499         rim=dsqrt(rim*rim-z*z)
13500         xa(i,3)=z
13501         call qgcs(c,s)
13502         xa(i,1)=rim*c
13503         xa(i,2)=rim*s
13504        enddo
13505       else
13506        do l=1,3
13507         summ=0.d0
13508         do i=1,ia-1
13509          j=ia-i
13510          aks=rnuc(jj)*(qgran(b10)+qgran(b10)+qgran(b10)-1.5d0)
13511          k=j+1
13512          xa(k,l)=summ-aks*sqrt(float(j)/k)
13513          summ=summ+aks/sqrt(float(j*k))
13514         enddo
13515         xa(1,l)=summ
13516        enddo
13517       endif
13518 
13519       if(debug.ge.3)then
13520        write (moniou,203)
13521        do i=1,ia
13522         write (moniou,204)i,(xa(i,l),l=1,3)
13523        enddo
13524        write (moniou,202)
13525       endif
13526 201   format(2x,'qggea - configuration of the nucleus ',i1,';',2x,
13527      *'coordinates for ',i2,' nucleons')
13528 202   format(2x,'qggea - end')
13529 203   format(2x,'qggea:  positions of the nucleons')
13530 204   format(2x,'qggea: ',i2,' - ',3(e10.3,1x))
13531       return
13532       end
13533 
13534 c=============================================================================
13535       double precision function qgapi(x,j,l)
13536 c-----------------------------------------------------------------------------
13537 c qgapi - integrated altarelli-parisi function
13538 c x - light cone momentum share value,
13539 c j - type of initial parton (1 - g, 2 - q)
13540 c l - type of final parton (1 - g, 2 - q)
13541 c-----------------------------------------------------------------------------
13542       implicit double precision (a-h,o-z)
13543       integer debug
13544       common /qgarr43/ moniou
13545       common /qgdebug/  debug
13546 
13547       if(debug.ge.2)write (moniou,201)x,j,l
13548 
13549       if(j.eq.1)then
13550        if(l.eq.1)then
13551         qgapi=6.d0*(dlog(x/(1.d0-x))-x**3/3.d0+x**2/2.d0-2.d0*x)
13552        else
13553         qgapi=3.d0*(x+x**3/1.5d0-x*x)
13554        endif
13555       else
13556        if(l.eq.1)then
13557         qgapi=(dlog(x)-x+.25d0*x*x)/.375d0
13558        else
13559         z=1.d0-x
13560         qgapi=-(dlog(z)-z+.25d0*z*z)/.375d0
13561        endif
13562       endif
13563 
13564       if(debug.ge.2)write (moniou,202)qgapi
13565 201   format(2x,'qgapi: x=',e10.3,2x,'j= ',i1,2x,'l= ',i1)
13566 202   format(2x,'qgapi=',e10.3)
13567       return
13568       end
13569 
13570 c=============================================================================
13571       subroutine qgjarr(jfl)
13572 c-----------------------------------------------------------------------------
13573 c final jets rearrangement according to their colour connections
13574 c-----------------------------------------------------------------------------
13575       implicit double precision (a-h,o-z)
13576       integer debug
13577       parameter(njmax=50000)
13578       dimension mark(njmax),ept(4)
13579       common /qgarr10/ am(7),ammu
13580       common /qgarr36/ epjet(4,njmax),ipjet(njmax),njtot
13581       common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
13582       common /qgarr43/ moniou
13583       common /qgdebug/  debug
13584 
13585       if(debug.ge.2)write (moniou,201)nj
13586       if(debug.ge.2.and.nj.ne.0)then
13587        do i=1,nj
13588         write (moniou,203)i,iqj(i),(eqj(l,i),l=1,4)
13589         if(iqj(i).eq.0)then
13590          write (moniou,204)ncj(1,i),ncj(2,i)
13591         else
13592          ncdum=0
13593          write (moniou,204)ncj(1,i),ncdum
13594         endif
13595        enddo
13596       endif
13597 
13598       njpar=0
13599       jfl=0
13600       do i=1,nj
13601        mark(i)=1
13602       enddo
13603       njtot=0
13604 
13605 2     continue
13606       do ij=1,nj
13607        if(mark(ij).ne.0.and.iqj(ij).ne.0)goto 4
13608       enddo
13609 4     continue
13610 
13611       jfirst=1
13612       if(iabs(iqj(ij)).le.2)then
13613        am1=am(1)
13614       elseif(iabs(iqj(ij)).eq.4)then
13615        am1=am(3)
13616       else
13617        am1=am(2)
13618       endif
13619       do i=1,4
13620        ept(i)=0.d0
13621       enddo
13622 
13623 6     mark(ij)=0
13624       njtot=njtot+1
13625       ipjet(njtot)=iqj(ij)
13626       do i=1,4
13627        ept(i)=ept(i)+eqj(i,ij)
13628        epjet(i,njtot)=eqj(i,ij)
13629       enddo
13630 
13631       if(iqj(ij).ne.0)then
13632        if(jfirst.ne.1)then
13633         if(iabs(iqj(ij)).le.2)then
13634          am2=am(1)
13635         elseif(iabs(iqj(ij)).eq.4)then
13636          am2=am(3)
13637         else
13638          am2=am(2)
13639         endif
13640         amj=(am1+am2)**2
13641         if(amj.gt.qgnrm(ept))then
13642          if(debug.ge.3)write (moniou,202)jfl
13643          return
13644         endif
13645 
13646         if(njtot.lt.nj)then
13647          goto 2
13648         else
13649          jfl=1
13650          nj=0
13651          if(debug.ge.3)write (moniou,202)jfl
13652          return
13653         endif
13654        else
13655         jfirst=0
13656         njpar=ij
13657         ij=ncj(1,ij)
13658         goto 6
13659        endif
13660       else
13661        if(ncj(1,ij).eq.njpar)then
13662         njdau=ncj(2,ij)
13663        else
13664         njdau=ncj(1,ij)
13665        endif
13666        njpar=ij
13667        ij=njdau
13668        goto 6
13669       endif
13670 
13671 201   format(2x,'qgjarr: total number of jets nj=',i4)
13672 202   format(2x,'qgjarr - end,jfl=',i2)
13673 203   format(2x,'qgjarr: ij=',i3,2x,'iqj=',i2,2x,'eqj=',4e10.3)
13674 204   format(2x,'qgjarr: ncj=',2i3)
13675       end
13676 
13677 c=============================================================================
13678       double precision function qgjet(q1,q2,s,s2min,j,l)
13679 c-----------------------------------------------------------------------------
13680 c qgjet - inclusive hard cross-section calculation (one more run is added
13681 c to the ladder) - for any ordering
13682 c q1 - effective momentum cutoff for current end of the ladder,
13683 c q2 - effective momentum cutoff for opposide end of the ladder,
13684 c s - total c.m. energy squared for the ladder,
13685 c s2min - minimal c.m. energy squared for born process (above q1 and q2)
13686 c j - parton type at current end of the ladder (1 - g, 2 - q)
13687 c l - parton type at opposite end of the ladder (1 - g, 2 - q)
13688 c-----------------------------------------------------------------------------
13689       implicit double precision (a-h,o-z)
13690       integer debug
13691       common /qgarr6/  pi,bm,amws
13692       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
13693       common /qgarr18/ alm,qt0,qtf,betp,dgqq
13694       common /qgarr26/ factk,fqscal
13695       common /qgarr43/ moniou
13696       common /qgarr51/ epsxmn
13697       common /qgdebug/  debug
13698       common /arr3/   x1(7),a1(7)
13699 
13700       if(debug.ge.2)write (moniou,201)s,q1,q2,s2min,j,l
13701 
13702       qgjet=0.d0
13703       qmax=s/4.d0/fqscal*(1.d0-epsxmn)
13704       qmin=q1
13705       if(debug.ge.3)write (moniou,203)qmin,qmax
13706 
13707       if(qmax.gt.qmin)then
13708 c numerical integration over transverse momentum square;
13709 c gaussian integration is used
13710        do i=1,7
13711        do m=1,2
13712         qi=2.d0*qmin/(1.d0+qmin/qmax+(2*m-3)*x1(i)*(1.d0-qmin/qmax))
13713         zmax=(1.d0-epsxmn)**delh
13714         zmin=(max(4.d0*fqscal*qi,s2min)/s)**delh
13715         fsj=0.d0
13716         if(debug.ge.3)write (moniou,204)qi,zmin,zmax
13717 
13718         if(zmax.gt.zmin)then
13719          do i1=1,7
13720          do m1=1,2
13721           z=(.5d0*(zmax+zmin+(2*m1-3)*x1(i1)*(zmax-zmin)))**(1.d0/delh)
13722           s2=z*s
13723 
13724           sj=0.d0
13725           do k=1,2
13726            sj=sj+qgjit(qi,q2,s2,k,l)*qgfap(z,j,k)*z
13727           enddo
13728           fsj=fsj+a1(i1)*sj/z**delh
13729          enddo
13730          enddo
13731          fsj=fsj*(zmax-zmin)
13732         endif
13733         qgjet=qgjet+a1(i)*fsj*qi*qgsudx(qi,j)*qgalf(qi/alm)
13734        enddo
13735        enddo
13736        qgjet=qgjet*(1.d0/qmin-1.d0/qmax)/qgsudx(q1,j)/delh/4.d0
13737       endif
13738 
13739       if(debug.ge.3)write (moniou,202)qgjet
13740 201   format(2x,'qgjet - unordered ladder cross section:'
13741      */4x,'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,'s2min=',
13742      *e10.3,2x,'j=',i1,2x,'l=',i1)
13743 202   format(2x,'qgjet=',e10.3)
13744 203   format(2x,'qgjet:',2x,'qmin=',e10.3,2x,'qmax=',e10.3)
13745 204   format(2x,'qgjet:',2x,'qi=',e10.3,2x,'zmin=',e10.3
13746      *,2x,'zmax=',e10.3)
13747       return
13748       end
13749 
13750 c=============================================================================
13751       double precision function qgjet1(q1,q2,s,s2min,j,l)
13752 c-----------------------------------------------------------------------------
13753 c qgjet1 - inclusive hard cross-section calculation (one more run is added
13754 c to the ladder) - for strict ordering
13755 c q1 - effective momentum cutoff for current end of the ladder,
13756 c q2 - effective momentum cutoff for opposide end of the ladder,
13757 c s - total c.m. energy squared for the ladder,
13758 c s2min - minimal c.m. energy squared for born process (above q1 and q2)
13759 c j - parton type at current end of the ladder (1 - g, 2 - q)
13760 c l - parton type at opposite end of the ladder (1 - g, 2 - q)
13761 c-----------------------------------------------------------------------------
13762       implicit double precision (a-h,o-z)
13763       integer debug
13764       common /qgarr6/  pi,bm,amws
13765       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
13766       common /qgarr18/ alm,qt0,qtf,betp,dgqq
13767       common /qgarr26/ factk,fqscal
13768       common /qgarr43/ moniou
13769       common /qgarr51/ epsxmn
13770       common /qgdebug/  debug
13771       common /arr3/   x1(7),a1(7)
13772 
13773       if(debug.ge.2)write (moniou,201)s,q1,q2,s2min,j,l
13774 
13775       qgjet1=0.d0
13776       qmax=s/4.d0/fqscal*(1.d0-epsxmn)
13777       qmin=q1
13778       if(debug.ge.3)write (moniou,203)qmin,qmax
13779 
13780       if(qmax.gt.qmin)then
13781 c numerical integration over transverse momentum square;
13782 c gaussian integration is used
13783        do i=1,7
13784        do m=1,2
13785         qi=2.d0*qmin/(1.d0+qmin/qmax+(2*m-3)*x1(i)*(1.d0-qmin/qmax))
13786         zmax=(1.d0-epsxmn)**delh
13787         zmin=(max(4.d0*fqscal*qi,s2min)/s)**delh
13788         fsj=0.d0
13789         if(debug.ge.3)write (moniou,204)qi,zmin,zmax
13790 
13791         if(zmax.gt.zmin)then
13792          do i1=1,7
13793          do m1=1,2
13794           z=(.5d0*(zmax+zmin+(2*m1-3)*x1(i1)*(zmax-zmin)))**(1.d0/delh)
13795           s2=z*s
13796 
13797           sj=0.d0
13798           do k=1,2
13799            sj=sj+qgjit1(qi,q2,s2,k,l)*qgfap(z,j,k)*z
13800           enddo
13801           fsj=fsj+a1(i1)*sj/z**delh
13802          enddo
13803          enddo
13804          fsj=fsj*(zmax-zmin)
13805         endif
13806         qgjet1=qgjet1+a1(i)*fsj*qi*qgsudx(qi,j)*qgalf(qi/alm)
13807        enddo
13808        enddo
13809        qgjet1=qgjet1*(1.d0/qmin-1.d0/qmax)/qgsudx(q1,j)/delh/4.d0
13810       endif
13811 
13812       if(debug.ge.3)write (moniou,202)qgjet1
13813 201   format(2x,'qgjet1 - strictly ordered ladder cross section:'
13814      */4x,'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,'s2min=',
13815      *e10.3,2x,'j=',i1,2x,'l=',i1)
13816 202   format(2x,'qgjet1=',e10.3)
13817 203   format(2x,'qgjet1:',2x,'qmin=',e10.3,2x,'qmax=',e10.3)
13818 204   format(2x,'qgjet1:',2x,'qi=',e10.3,2x,'zmin=',e10.3
13819      *,2x,'zmax=',e10.3)
13820       return
13821       end
13822 
13823 c=============================================================================
13824       double precision function qgjit(q1,q2,s,m,l)
13825 c-----------------------------------------------------------------------------
13826 c qgjit - inclusive hard cross-section interpolation - for any ordering
13827 c in the ladder
13828 c q1 - effective momentum cutoff for current end of the ladder,
13829 c q2 - effective momentum cutoff for opposide end of the ladder,
13830 c s - total c.m. energy squared for the ladder,
13831 c m - parton type at current end of the ladder (1 - g, 2 - q)
13832 c l - parton type at opposite end of the ladder (1 - g, 2 - q)
13833 c-----------------------------------------------------------------------------
13834       implicit double precision (a-h,o-z)
13835       integer debug
13836       dimension wi(3),wj(3),wk(3)
13837       common /qgarr18/ alm,qt0,qtf,betp,dgqq
13838       common /qgarr20/ spmax
13839       common /qgarr26/ factk,fqscal
13840       common /qgarr29/ csj(40,40,160)
13841       common /qgarr43/ moniou
13842       common /qgdebug/  debug
13843 
13844       if(debug.ge.2)write (moniou,201)s,q1,q2,m,l
13845 
13846       qgjit=0.d0
13847       qq=max(q1,q2)
13848       s2min=qq*4.d0*fqscal
13849       if(s.le..99d0*s2min)then
13850        if(debug.ge.3)write (moniou,202)qgjit
13851        return
13852       endif
13853 
13854       if(q1.le.q2)then
13855        qi=q1
13856        qj=q2
13857        ml=40*(m-1)+80*(l-1)
13858       else
13859        qi=q2
13860        qj=q1
13861        ml=40*(l-1)+80*(m-1)
13862       endif
13863 
13864       tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
13865       qli=dlog(qi)/dlog(spmax/4.d0/fqscal)*39.d0+1.d0
13866       if(qi.lt..99d0*spmax/4.d0/fqscal)then
13867        qlj=dlog(qj/qi)/dlog(spmax/4.d0/fqscal/qi)*39.d0+1.d0
13868       else
13869        qlj=1.d0
13870       endif
13871       sl=dlog(s/s2min)/dlog(spmax/s2min)*39.d0+1.d0
13872       i=min(38,int(qli))
13873       j=min(38,int(qlj))
13874       k=min(38,int(sl))
13875 
13876       wk(2)=sl-k
13877       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
13878       wk(1)=1.d0-wk(2)+wk(3)
13879       wk(2)=wk(2)-2.d0*wk(3)
13880       wi(2)=qli-i
13881       wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
13882       wi(1)=1.d0-wi(2)+wi(3)
13883       wi(2)=wi(2)-2.d0*wi(3)
13884       wj(2)=qlj-j
13885       wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
13886       wj(1)=1.d0-wj(2)+wj(3)
13887       wj(2)=wj(2)-2.d0*wj(3)
13888       do k1=1,3
13889        k2=k+k1-1+ml
13890       do i1=1,3
13891       do j1=1,3
13892        qgjit=qgjit+csj(i+i1-1,j+j1-1,k2)*wi(i1)*wj(j1)*wk(k1)
13893       enddo
13894       enddo
13895       enddo
13896       qgjit=exp(qgjit)*(1.d0/tmin-2.d0/s)
13897 
13898       if(debug.ge.3)write (moniou,202)qgjit
13899 201   format(2x,'qgjit - unordered ladder cross section interpol.:'/4x,
13900      *'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,2x,'m=',i1,2x,'l=',i1)
13901 202   format(2x,'qgjit=',e10.3)
13902       return
13903       end
13904 
13905 c=============================================================================
13906       double precision function qgjit1(q1,q2,s,m,l)
13907 c-----------------------------------------------------------------------------
13908 c qgjit1 - inclusive hard cross-section interpolation - for strict ordering
13909 c in the ladder
13910 c q1 - effective momentum cutoff for current end of the ladder,
13911 c q2 - effective momentum cutoff for opposide end of the ladder,
13912 c s - total c.m. energy squared for the ladder,
13913 c m - parton type at current end of the ladder (1 - g, 2 - q)
13914 c l - parton type at opposite end of the ladder (1 - g, 2 - q)
13915 c-----------------------------------------------------------------------------
13916       implicit double precision (a-h,o-z)
13917       integer debug
13918       dimension wi(3),wj(3),wk(3)
13919       common /qgarr18/ alm,qt0,qtf,betp,dgqq
13920       common /qgarr20/ spmax
13921       common /qgarr26/ factk,fqscal
13922       common /qgarr30/ csj(40,40,160)
13923       common /qgarr43/ moniou
13924       common /qgdebug/  debug
13925 
13926       if(debug.ge.2)write (moniou,201)s,q1,q2,m,l
13927 
13928       qgjit1=0.d0
13929       qq=max(q1,q2)
13930       s2min=qq*4.d0*fqscal
13931       if(s.le.s2min)then
13932        if(debug.ge.3)write (moniou,202)qgjit1
13933        return
13934       endif
13935 
13936       tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/s)))
13937       ml=40*(m-1)+80*(l-1)
13938       qli=dlog(q1)/dlog(spmax/4.d0/fqscal)*39.d0+1.d0
13939       if(q1.lt..99d0*spmax/4.d0/fqscal)then
13940        qlj=dlog(qq/q1)/dlog(spmax/4.d0/fqscal/q1)*39.d0+1.d0
13941       else
13942        qlj=1.d0
13943       endif
13944       sl=dlog(s/s2min)/dlog(spmax/s2min)*39.d0+1.d0
13945       i=min(38,int(qli))
13946       j=min(38,int(qlj))
13947       k=min(38,int(sl))
13948       wk(2)=sl-k
13949       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
13950       wk(1)=1.d0-wk(2)+wk(3)
13951       wk(2)=wk(2)-2.d0*wk(3)
13952       wi(2)=qli-i
13953       wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
13954       wi(1)=1.d0-wi(2)+wi(3)
13955       wi(2)=wi(2)-2.d0*wi(3)
13956       wj(2)=qlj-j
13957       wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
13958       wj(1)=1.d0-wj(2)+wj(3)
13959       wj(2)=wj(2)-2.d0*wj(3)
13960 
13961       do k1=1,3
13962        k2=k+k1-1+ml
13963       do i1=1,3
13964       do j1=1,3
13965        qgjit1=qgjit1+csj(i+i1-1,j+j1-1,k2)*wi(i1)*wj(j1)*wk(k1)
13966       enddo
13967       enddo
13968       enddo
13969       qgjit1=exp(qgjit1)*(1.d0/tmin-2.d0/s)
13970       if(q2.lt.q1)qgjit1=qgjit1*qgsudx(q1,l)/qgsudx(q2,l)
13971 
13972       if(debug.ge.3)write (moniou,202)qgjit1
13973 201   format(2x,'qgjit1 - ordered ladder cross section interpol.:'/4x,
13974      *'s=',e10.3,2x,'q1=',e10.3,2x,'q2=',e10.3,2x,2x,'m=',i1,2x,'l=',i1)
13975 202   format(2x,'qgjit1=',e10.3)
13976       return
13977       end
13978 
13979 c=============================================================================
13980       double precision function qglam(s,a,b)
13981 c-----------------------------------------------------------------------------
13982 c kinematical function for two particle decay - maximal pt-value
13983 c a - first particle mass squared,
13984 c b - second particle mass squared,
13985 c s - two particle invariant mass
13986 c-----------------------------------------------------------------------------
13987       implicit double precision (a-h,o-z)
13988       integer debug
13989       common /qgarr43/ moniou
13990       common /qgdebug/  debug
13991 
13992       if(debug.ge.2)write (moniou,201)s,a,b
13993 
13994       qglam=max(0.d0,.25d0/s*(s+a-b)**2-a)
13995 
13996       if(debug.ge.3)write (moniou,202)qglam
13997 201   format(2x,'qglam - kinematical function s=',e10.3,2x,'a='
13998      *,e10.3,2x,'b=',e10.3)
13999 202   format(2x,'qglam=',e10.3)
14000       return
14001       end
14002 
14003 c=============================================================================
14004       double precision function qgnrm(ep)
14005 c-----------------------------------------------------------------------------
14006 c 4-vector squared calculation
14007 c-----------------------------------------------------------------------------
14008       implicit double precision (a-h,o-z)
14009       integer debug
14010       dimension ep(4)
14011       common /qgarr43/ moniou
14012       common /qgdebug/  debug
14013 
14014       if(debug.ge.2)write (moniou,201)ep
14015       qgnrm=(ep(1)-ep(2))*(ep(1)+ep(2))-ep(3)**2-ep(4)**2
14016 
14017       if(debug.ge.3)write (moniou,202)qgnrm
14018 201   format(2x,'qgnrm - 4-vector squared for ','ep=',4(e10.3,1x))
14019 202   format(2x,'qgnrm=',e10.3)
14020       return
14021       end
14022 
14023 c===========================================================================
14024       subroutine qgrec(ep,nqc,qv,zv,qm,iqv,ldau,lpar,jq)
14025 c---------------------------------------------------------------------------
14026 c jet reconstructuring procedure - 4-momenta for all final jets are determ.
14027 c ep(i) - jet 4-momentum
14028 c---------------------------------------------------------------------------
14029 c qv(i,j) - effective momentum for the branching of the parton in i-th row
14030 c on j-th level (0 - in case of no branching)
14031 c zv(i,j) - z-value for the branching of the parton in i-th row
14032 c on j-th level
14033 c qm(i,j) - mass squared for the parton in i-th row
14034 c on j-th level
14035 c iqv(i,j) - flavours for the parton in i-th row on j-th level
14036 c ldau(i,j) - first daughter row for the branching of the parton in i-th row
14037 c on j-th level
14038 c lpar(i,j) - the parent row for the parton in i-th row on j-th level
14039 c----------------------------------------------------------------------------
14040       implicit double precision (a-h,o-z)
14041       integer debug
14042       parameter(njmax=50000)
14043       dimension ep(4),ep3(4),epv(4,30,50),nqc(2),ncc(2,30,50),
14044      *qv(30,50),zv(30,50),qm(30,50),iqv(30,50),
14045      *ldau(30,49),lpar(30,50)
14046 c eqj(i,nj) - 4-momentum for the final jet nj
14047 c iqj(nj) - flavour for the final jet nj
14048 c ncj(m,nj) - colour connections for the final jet nj
14049       common /qgarr37/ eqj(4,njmax),iqj(njmax),ncj(2,njmax),nj
14050       common /qgarr43/ moniou
14051       common /qgdebug/  debug
14052 
14053       if(debug.ge.2)write (moniou,201)jq,ep,iqv(1,1),nqc
14054 
14055       do i=1,4
14056        epv(i,1,1)=ep(i)
14057       enddo
14058       ncc(1,1,1)=nqc(1)
14059       if(iqv(1,1).eq.0)ncc(2,1,1)=nqc(2)
14060       nlev=1
14061       nrow=1
14062 
14063 2     continue
14064       if(qv(nrow,nlev).eq.0.d0)then
14065        nj=nj+1
14066        do i=1,4
14067         eqj(i,nj)=epv(i,nrow,nlev)
14068        enddo
14069        iqj(nj)=iqv(nrow,nlev)
14070        if(iabs(iqj(nj)).eq.3)iqj(nj)=iqj(nj)*4/3
14071 
14072        if(iqj(nj).ne.0)then
14073         njc=ncc(1,nrow,nlev)
14074         if(njc.ne.0)then
14075          ncj(1,nj)=njc
14076          iqc=iqj(njc)
14077          if(iqc.ne.0)then
14078           ncj(1,njc)=nj
14079          else
14080           if(iqj(nj).gt.0)then
14081            ncj(2,njc)=nj
14082           else
14083            ncj(1,njc)=nj
14084           endif
14085          endif
14086         else
14087          ncc(1,nrow,nlev)=nj
14088         endif
14089        else
14090 
14091         do m=1,2
14092          if(jq.eq.1)then
14093           m1=m
14094          else
14095           m1=3-m
14096          endif
14097          njc=ncc(m1,nrow,nlev)
14098          if(njc.ne.0)then
14099           ncj(m,nj)=njc
14100           iqc=iqj(njc)
14101           if(iqc.ne.0)then
14102            ncj(1,njc)=nj
14103           else
14104            ncj(3-m,njc)=nj
14105           endif
14106          else
14107           ncc(m1,nrow,nlev)=nj
14108          endif
14109         enddo
14110        endif
14111        if(debug.ge.3)write (moniou,204)
14112      * nj,nlev,nrow,iqj(nj),(eqj(i,nj),i=1,4)
14113 
14114       else
14115        do i=1,4
14116          ep3(i)=epv(i,nrow,nlev)
14117        enddo
14118        call qgdefr(ep3,s0x,c0x,s0,c0)
14119        z=zv(nrow,nlev)
14120        qt2=(z*(1.d0-z))**2*qv(nrow,nlev)
14121        ldrow=ldau(nrow,nlev)
14122 
14123        wp0=ep3(1)+ep3(2)
14124        wpi=z*wp0
14125        wmi=(qt2+qm(ldrow,nlev+1))/wpi
14126        ep3(1)=.5d0*(wpi+wmi)
14127        ep3(2)=.5d0*(wpi-wmi)
14128        qt=dsqrt(qt2)
14129        call qgcs(c,s)
14130        ep3(3)=qt*c
14131        ep3(4)=qt*s
14132        call qgrota(ep3,s0x,c0x,s0,c0)
14133        do i=1,4
14134         epv(i,ldrow,nlev+1)=ep3(i)
14135        enddo
14136        if(debug.ge.3)write (moniou,206)nlev+1,ldrow,ep3
14137 
14138        wpi=(1.d0-z)*wp0
14139        wmi=(qt2+qm(ldrow+1,nlev+1))/wpi
14140        ep3(1)=.5d0*(wpi+wmi)
14141        ep3(2)=.5d0*(wpi-wmi)
14142        ep3(3)=-qt*c
14143        ep3(4)=-qt*s
14144        call qgrota(ep3,s0x,c0x,s0,c0)
14145        do i=1,4
14146         epv(i,ldrow+1,nlev+1)=ep3(i)
14147        enddo
14148        if(debug.ge.3)write (moniou,206)nlev+1,ldrow+1,ep3
14149 
14150        if(iqv(nrow,nlev).eq.0)then
14151         if(iqv(ldrow,nlev+1).ne.0)then
14152          ncc(1,ldrow,nlev+1)=ncc(1,nrow,nlev)
14153          ncc(1,ldrow+1,nlev+1)=ncc(2,nrow,nlev)
14154         else
14155          ncc(1,ldrow,nlev+1)=ncc(1,nrow,nlev)
14156          ncc(2,ldrow,nlev+1)=0
14157          ncc(1,ldrow+1,nlev+1)=0
14158          ncc(2,ldrow+1,nlev+1)=ncc(2,nrow,nlev)
14159         endif
14160        else
14161         if(iqv(ldrow,nlev+1).eq.0)then
14162          ncc(1,ldrow,nlev+1)=ncc(1,nrow,nlev)
14163          ncc(2,ldrow,nlev+1)=0
14164          ncc(1,ldrow+1,nlev+1)=0
14165         else
14166          ncc(1,ldrow,nlev+1)=0
14167          ncc(1,ldrow+1,nlev+1)=0
14168          ncc(2,ldrow+1,nlev+1)=ncc(1,nrow,nlev)
14169         endif
14170        endif
14171 
14172        nrow=ldrow
14173        nlev=nlev+1
14174        goto 2
14175       endif
14176 
14177 8     continue
14178       if(nlev.eq.1)then
14179        if(nqc(1).eq.0)nqc(1)=ncc(1,1,1)
14180        if(iqv(1,1).eq.0.and.nqc(2).eq.0)nqc(2)=ncc(2,1,1)
14181        if(debug.ge.3)write (moniou,202)
14182        return
14183       endif
14184 
14185       lprow=lpar(nrow,nlev)
14186       if(ldau(lprow,nlev-1).eq.nrow)then
14187        if(iqv(nrow,nlev).eq.0)then
14188         if(ncc(1,lprow,nlev-1).eq.0)ncc(1,lprow,nlev-1)=ncc(1,nrow,nlev)
14189         ncc(1,nrow+1,nlev)=ncc(2,nrow,nlev)
14190        else
14191         if(iqv(lprow,nlev-1).eq.0)then
14192          if(ncc(1,lprow,nlev-1).eq.0)
14193      *   ncc(1,lprow,nlev-1)=ncc(1,nrow,nlev)
14194         else
14195          ncc(1,nrow+1,nlev)=ncc(1,nrow,nlev)
14196         endif
14197        endif
14198        nrow=nrow+1
14199        goto 2
14200       else
14201        if(iqv(nrow,nlev).eq.0)then
14202         if(iqv(lprow,nlev-1).eq.0)then
14203          if(ncc(2,lprow,nlev-1).eq.0)
14204      *   ncc(2,lprow,nlev-1)=ncc(2,nrow,nlev)
14205         else
14206          if(ncc(1,lprow,nlev-1).eq.0)
14207      *   ncc(1,lprow,nlev-1)=ncc(2,nrow,nlev)
14208         endif
14209        else
14210         if(iqv(lprow,nlev-1).eq.0.and.ncc(2,lprow,nlev-1).eq.0)
14211      *  ncc(2,lprow,nlev-1)=ncc(1,nrow,nlev)
14212        endif
14213        nrow=lprow
14214        nlev=nlev-1
14215        goto 8
14216       endif
14217 
14218 201   format(2x,'qgrec - jet reconstructuring: jq=',i1
14219      */4x,'jet 4-momentum ep=',4(e10.3,1x)
14220      */4x,'jet flavor: ',i2,2x,'colour connections: ',2i3)
14221 202   format(2x,'qgrec - end')
14222 204   format(2x,'qgrec: ',i3,'-th final jet at level nlev=',i2,' nrow='
14223      *,i2/4x,'jet flavor: ',i3,2x,'jet 4-momentum:',4(e10.3,1x))
14224 206   format(2x,'qgrec: jet at level nlev='
14225      *,i2,' nrow=',i2/4x,'jet 4-momentum:',4(e10.3,1x))
14226       end
14227 
14228 c=============================================================================
14229       double precision function qgroot(qlmax,g,j)
14230 c-----------------------------------------------------------------------------
14231 c qgroot - effective momentum tabulation for given set of random number
14232 c values and maximal effective momentum qmax values - according to the
14233 c probability of branching: (1 - timelike sudakov formfactor)
14234 c qlmax - ln qmax/16/qtf,
14235 c g - dzeta number (some function of ksi)
14236 c j - type of the parton (1-g,2-q)
14237 c------------------------------------------------------------------------
14238       implicit double precision (a-h,o-z)
14239       integer debug
14240       common /qgarr43/ moniou
14241       common /qgdebug/  debug
14242 
14243       if(debug.ge.2)write (moniou,201)qlmax,g,j
14244 
14245       ql0=0.d0
14246       ql1=qlmax
14247       f0=-g
14248       f1=1.d0-g
14249       sud0=-dlog(qgsudi(qlmax,j))
14250 
14251 1     ql2=ql1-(ql1-ql0)*f1/(f1-f0)
14252       if(ql2.lt.0.d0)then
14253        ql2=0.d0
14254        f2=-g
14255       elseif(ql2.gt.qlmax)then
14256        ql2=qlmax
14257        f2=1.d0-g
14258       else
14259        f2=-dlog(qgsudi(ql2,j))/sud0-g
14260       endif
14261       if(abs(f2).gt.1.d-3)then
14262        if(f1*f2.lt.0.d0)then
14263         ql0=ql1
14264         f0=f1
14265        endif
14266        ql1=ql2
14267        f1=f2
14268        goto 1
14269       else
14270        qgroot=ql2
14271       endif
14272 
14273       if(debug.ge.3)write (moniou,202)qgroot
14274 201   format(2x,'qgqint - branching momentum tabulation:'
14275      */4x,'qlmax=',e10.3,2x,'g=',e10.3,2x,'j=',i1)
14276 202   format(2x,'qgroot=',e10.3)
14277       return
14278       end
14279 
14280 c=============================================================================
14281       subroutine qgrota(ep,s0x,c0x,s0,c0)
14282 c-----------------------------------------------------------------------------
14283 c spacial rotation to the lab. system for 4-vector ep
14284 c-----------------------------------------------------------------------------
14285       implicit double precision (a-h,o-z)
14286       integer debug
14287       dimension ep(4),ep1(3)
14288       common /qgarr43/ moniou
14289       common /qgdebug/  debug
14290 
14291       if(debug.ge.2)write (moniou,201)ep,s0x,c0x,s0,c0
14292 
14293       ep1(3)=ep(4)
14294       ep1(2)=ep(2)*s0+ep(3)*c0
14295       ep1(1)=ep(2)*c0-ep(3)*s0
14296       ep(2)=ep1(1)
14297       ep(4)=ep1(2)*s0x+ep1(3)*c0x
14298       ep(3)=ep1(2)*c0x-ep1(3)*s0x
14299 
14300       if(debug.ge.3)write (moniou,202)ep
14301 201   format(2x,'qgrota - spacial rotation:'/4x,'4-vector ep=',4(e10.3
14302      *,1x)/4x,'s0x=',e10.3,'c0x=',e10.3,2x,'s0=',e10.3,'c0=',e10.3)
14303 202   format(2x,'qgrota: rotated 4-vector ep=',2x,4e10.3)
14304       return
14305       end
14306 
14307 c=============================================================================
14308       double precision function qgqint(qlmax,g,j)
14309 c-----------------------------------------------------------------------------
14310 c qgqint - effective momentum interpolation for given random number g
14311 c and maximal effective momentum qmax
14312 c qlmax - ln qmax/16/qtf,
14313 c g - random number (0<g<1)
14314 c j - type of the parton (1-g,2-q)
14315 c-----------------------------------------------------------------------------
14316       implicit double precision (a-h,o-z)
14317       integer debug
14318       dimension wi(3),wk(3)
14319       common /qgarr18/ alm,qt0,qtf,betp,dgqq
14320       common /qgarr34/ qrt(10,101,2)
14321       common /qgarr43/ moniou
14322       common /qgdebug/  debug
14323 
14324       if(debug.ge.2)write (moniou,201)qlmax,g,j
14325 
14326       qli=qlmax/1.38629d0
14327       sud0=1.d0/qgsudi(qlmax,j)
14328       sl=100.d0*dlog(1.d0-g*(1.d0-sud0))/dlog(sud0)
14329       i=int(qli)
14330       k=int(sl)
14331       if(k.gt.98)k=98
14332       wk(2)=sl-k
14333       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
14334       wk(1)=1.d0-wk(2)+wk(3)
14335       wk(2)=wk(2)-2.d0*wk(3)
14336       qgqint=0.d0
14337       if(i.gt.7)i=7
14338       wi(2)=qli-i
14339       wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
14340       wi(1)=1.d0-wi(2)+wi(3)
14341       wi(2)=wi(2)-2.d0*wi(3)
14342       do k1=1,3
14343       do i1=1,3
14344        qgqint=qgqint+qrt(i+i1,k+k1,j)*wi(i1)*wk(k1)
14345       enddo
14346       enddo
14347       if(qgqint.le.0.d0)qgqint=0.d0
14348       qgqint=16.d0*qtf*exp(qgqint)
14349 
14350       if(debug.ge.3)write (moniou,202)qgqint
14351 201   format(2x,'qgqint - branching momentum interpolation:'
14352      */4x,'qlmax=',e10.3,2x,'g=',e10.3,2x,'j=',i1)
14353 202   format(2x,'qgqint=',e10.3)
14354       return
14355       end
14356 
14357 c=============================================================================
14358       double precision function qgalf(qq)
14359 c-----------------------------------------------------------------------------
14360 c qgalf - alpha_s(qq)/2/pi
14361 c-----------------------------------------------------------------------------
14362       implicit double precision (a-h,o-z)
14363       integer debug
14364       common /qgarr43/ moniou
14365       common /qgdebug/  debug
14366 
14367       qgalf=2.d0/9.d0/dlog(qq)
14368       return
14369       end
14370 
14371 c=============================================================================
14372       subroutine qgtran(ep,ey,jj)
14373 c-----------------------------------------------------------------------------
14374 c lorentz transform according to parameters ey ( determining lorentz shift
14375 c along the z,x,y-axis respectively (ey(1),ey(2),ey(3)))
14376 c-----------------------------------------------------------------------------
14377       implicit double precision (a-h,o-z)
14378       integer debug
14379       dimension ey(3),ep(4)
14380       common /qgarr43/ moniou
14381       common /qgdebug/  debug
14382 
14383       if(debug.ge.2)write (moniou,201)ep,ey
14384 
14385       if(jj.eq.1)then
14386 c lorentz transform to lab. system according to 1/ey(i) parameters
14387        do i=1,3
14388         if(ey(4-i).ne.1.d0)then
14389          wp=(ep(1)+ep(5-i))/ey(4-i)
14390          wm=(ep(1)-ep(5-i))*ey(4-i)
14391          ep(1)=.5d0*(wp+wm)
14392          ep(5-i)=.5d0*(wp-wm)
14393         endif
14394        enddo
14395       else
14396 c lorentz transform to lab. system according to ey(i) parameters
14397        do i=1,3
14398         if(ey(i).ne.1.d0)then
14399          wp=(ep(1)+ep(i+1))*ey(i)
14400          wm=(ep(1)-ep(i+1))/ey(i)
14401          ep(1)=.5d0*(wp+wm)
14402          ep(i+1)=.5d0*(wp-wm)
14403         endif
14404        enddo
14405       endif
14406 
14407       if(debug.ge.3)write (moniou,202)ep
14408 201   format(2x,'qgtran - lorentz boost for 4-vector'/4x,'ep='
14409      *,2x,4(e10.3,1x)/4x,'boost parameters ey=',3e10.3)
14410 202   format(2x,'qgtran: transformed 4-vector ep=',2x,4(e10.3,1x))
14411       return
14412       end
14413 
14414 c=============================================================================
14415       double precision function qgsudi(qlmax,j)
14416 c-----------------------------------------------------------------------------
14417 c qgsudi - timelike sudakov formfactor interpolation
14418 c qlmax - ln qmax/16/qtf,
14419 c j - type of the parton (1-g,2-q)
14420 c-----------------------------------------------------------------------------
14421       implicit double precision (a-h,o-z)
14422       integer debug
14423       dimension wk(3)
14424       common /qgarr33/ fsud(10,2)
14425       common /qgarr43/ moniou
14426       common /qgdebug/  debug
14427 
14428       if(debug.ge.2)write (moniou,201)j,qlmax
14429 
14430       ql=qlmax/1.38629d0
14431       if(ql.le.0.d0)then
14432        qgsudi=1.d0
14433       else
14434        k=int(ql)
14435        if(k.gt.7)k=7
14436        wk(2)=ql-k
14437        wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
14438        wk(1)=1.d0-wk(2)+wk(3)
14439        wk(2)=wk(2)-2.d0*wk(3)
14440 
14441        qgsudi=0.d0
14442        do k1=1,3
14443         qgsudi=qgsudi+fsud(k+k1,j)*wk(k1)
14444        enddo
14445        if(qgsudi.le.0.d0)qgsudi=0.d0
14446        qgsudi=exp(-qgsudi)
14447       endif
14448 
14449       if(debug.ge.3)write (moniou,202)qgsudi
14450 201   format(2x,'qgsudi - spacelike form factor interpolation:'
14451      */4x,'parton type j=',i1,2x,'momentum logarithm qlmax=',e10.3)
14452 202   format(2x,'qgsudi=',e10.3)
14453       return
14454       end
14455 
14456 c=============================================================================
14457       double precision function qgsudx(q,j)
14458 c-----------------------------------------------------------------------------
14459 c qgsudx - spacelike sudakov formfactor
14460 c q - maximal value of the effective momentum,
14461 c j - type of parton (1 - g, 2 - q)
14462 c-----------------------------------------------------------------------------
14463       implicit double precision (a-h,o-z)
14464       integer debug
14465       common /qgarr18/ alm,qt0,qtf,betp,dgqq
14466       common /qgarr43/ moniou
14467       common /qgarr51/ epsxmn
14468       common /qgdebug/  debug
14469 
14470       if(debug.ge.2)write (moniou,201)j,q
14471 
14472       if(q.gt.1.d0)then
14473        qgsudx=dlog(dlog(q/alm)/dlog(1.d0/alm))*(.75d0+dlog(epsxmn))
14474        if(j.eq.1)then
14475         qgsudx=exp(qgsudx/.75d0)
14476        else
14477         qgsudx=exp(qgsudx*16.d0/27.d0)
14478        endif
14479       else
14480        qgsudx=1.d0
14481       endif
14482 
14483       if(debug.ge.3)write (moniou,202)qgsudx
14484 201   format(2x,'qgsudx - spacelike form factor: parton type j='
14485      *,i1,2x,'momentum q=',e10.3)
14486 202   format(2x,'qgsudx=',e10.3)
14487       return
14488       end
14489 
14490 c=============================================================================
14491       double precision function qgsudt(qmax,j)
14492 c-----------------------------------------------------------------------------
14493 c qgsudt - timelike sudakov formfactor
14494 c qmax - maximal value of the effective momentum,
14495 c j - type of parton (1 - g, 2 - q)
14496 c-----------------------------------------------------------------------------
14497       implicit double precision (a-h,o-z)
14498       integer debug
14499       common /qgarr18/ alm,qt0,qtf,betp,dgqq
14500       common/arr3/x1(7),a1(7)
14501       common /qgarr43/ moniou
14502       common /qgdebug/  debug
14503 
14504       if(debug.ge.2)write (moniou,201)j,qmax
14505 
14506       qgsudt=0.d0
14507       qlmax=dlog(dlog(qmax/16.d0/alm))
14508       qfl=dlog(dlog(qtf/alm))
14509 c numerical integration over transverse momentum square;
14510 c gaussian integration is used
14511       do i=1,7
14512       do m=1,2
14513        qtl=.5d0*(qlmax+qfl+(2*m-3)*x1(i)*(qlmax-qfl))
14514        qt=alm*exp(exp(qtl))
14515        if(qt.ge.qmax/16.d0)qt=qmax/16.0001d0
14516        zmin=.5d0-dsqrt((.25d0-dsqrt(qt/qmax)))
14517        zmax=1.d0-zmin
14518 
14519        if(j.eq.1)then
14520         ap=(qgapi(zmax,1,1)-qgapi(zmin,1,1)+
14521      *  qgapi(zmax,1,2)-qgapi(zmin,1,2))*.5d0
14522        else
14523         ap=qgapi(zmax,2,1)-qgapi(zmin,2,1)
14524        endif
14525        qgsudt=qgsudt+a1(i)*ap
14526       enddo
14527       enddo
14528       qgsudt=qgsudt*(qlmax-qfl)/9.d0
14529 
14530       if(debug.ge.3)write (moniou,202)qgsudt
14531 201   format(2x,'qgsudt - timelike form factor: parton type j='
14532      *,i1,2x,'momentum qmax=',e10.3)
14533 202   format(2x,'qgsudt=',e10.3)
14534       return
14535       end
14536 
14537 c=============================================================================
14538       double precision function qgtwd(s,a,b)
14539 c-----------------------------------------------------------------------------
14540 c kinematical function for two particle decay - light cone momentum share
14541 c for the particle of mass squared a,
14542 c b - partner's mass squared,
14543 c s - two particle invariant mass
14544 c-----------------------------------------------------------------------------
14545       implicit double precision (a-h,o-z)
14546       integer debug
14547       common /qgarr43/ moniou
14548       common /qgdebug/  debug
14549 
14550       if(debug.ge.2)write (moniou,201)s,a,b
14551 
14552       x=.5d0*(1.d0+(a-b)/s)
14553       dx=x-dsqrt(a/s)
14554       if(dx.gt.0.d0)then
14555        x=x+dsqrt(dx)*dsqrt(x+dsqrt(a/s))
14556       else
14557        x=dsqrt(a/s)
14558       endif
14559       qgtwd=x
14560 
14561       if(debug.ge.3)write (moniou,202)qgtwd
14562 201   format(2x,'qgtwd: s=',e10.3,2x,'a=',e10.3,2x,'b=',e10.3)
14563 202   format(2x,'qgtwd=',e10.3)
14564       return
14565       end
14566 
14567 c=============================================================================
14568       subroutine qgvdef(ich,ic1,ic2,icz)
14569 c-----------------------------------------------------------------------------
14570 c determination of valence quark flavour -
14571 c for valence quark hard scattering
14572 c-----------------------------------------------------------------------------
14573       implicit double precision (a-h,o-z)
14574       integer debug
14575       common /qgarr11/ b10
14576       common /qgarr43/ moniou
14577       common /qgdebug/  debug
14578       EXTERNAL qgran
14579 
14580       if(debug.ge.2)write (moniou,201)ich,icz
14581 
14582       is=iabs(ich)/ich
14583       if(icz.eq.1)then
14584        ic1=ich*(1-3*int(.5d0+qgran(b10)))
14585        ic2=-ic1-ich
14586       elseif(icz.eq.2)then
14587        if(qgran(b10).gt..33333d0.or.ich.lt.0)then
14588         ic1=ich-is
14589         ic2=3*is
14590        else
14591         ic1=4*is-ich
14592         ic2=ich+4*is
14593        endif
14594       elseif(icz.eq.3)then
14595        ic1=ich-3*is
14596        ic2=-4*is
14597       elseif(icz.eq.4)then
14598        ic1=ich-9*is
14599        ic2=5*is
14600       endif
14601 
14602       if(debug.ge.3)write (moniou,202)ic1,ic2
14603 201   format(2x,'qgvdef: hadron type ich=',i2,' auxilliary type icz='
14604      *,i1)
14605 202   format(2x,'qgvdef-end: parton flavors ic1=',i2,
14606      *'ic2=',i2)
14607       return
14608       end
14609 
14610 c=============================================================================
14611       double precision function qgzsim(qq,j)
14612 c-----------------------------------------------------------------------------
14613 c qgzsim - light cone momentum share simulation (for the timelike
14614 c branching)
14615 c qq - effective momentum value,
14616 c j - type of the parent parton (1-g,2-q)
14617 c-----------------------------------------------------------------------------
14618       implicit double precision (a-h,o-z)
14619       integer debug
14620       common /qgarr11/ b10
14621       common /qgarr18/ alm,qt0,qtf,betp,dgqq
14622       common /qgarr43/ moniou
14623       common /qgdebug/  debug
14624       EXTERNAL qgran
14625 
14626       if(debug.ge.2)write (moniou,201)qq,j
14627 
14628       zmin=.5d0-dsqrt(.25d0-dsqrt(qtf/qq))
14629       qlf=dlog(qtf/alm)
14630 1     continue
14631       if(j.eq.1)then
14632        qgzsim=.5d0*(2.d0*zmin)**qgran(b10)
14633        gb=qgzsim*(qgfap(qgzsim,1,1)+qgfap(qgzsim,1,2))/7.5d0
14634       else
14635        qgzsim=zmin*((1.d0-zmin)/zmin)**qgran(b10)
14636        gb=qgzsim*qgfap(qgzsim,2,1)*.375d0
14637       endif
14638       qt=qq*(qgzsim*(1.d0-qgzsim))**2
14639       gb=gb/dlog(qt/alm)*qlf
14640       if(debug.ge.3)write (moniou,203)qt,gb
14641       if(qgran(b10).gt.gb)goto 1
14642 
14643       if(debug.ge.3)write (moniou,202)qgzsim
14644 201   format(2x,'qgzsim - z-share simulation: qq=',e10.3,2x,'j=',i1)
14645 202   format(2x,'qgzsim=',e10.3)
14646 203   format(2x,'qgzsim: qt=',e10.3,2x,'gb=',e10.3)
14647       return
14648       end
14649 
14650 c===========================================================================
14651       subroutine qgixxd(ich,ic1,ic2,icz)
14652 c---------------------------------------------------------------------------
14653 c determination of parton flavours for valence quark soft interaction
14654 c (charge exchange)
14655 c---------------------------------------------------------------------------
14656       implicit double precision (a-h,o-z)
14657       integer debug
14658       common /qgarr8/  wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
14659       common /qgarr11/ b10
14660       common /qgarr43/ moniou
14661       common /qgdebug/  debug
14662       EXTERNAL qgran
14663 
14664       if(debug.ge.2)write (moniou,201)ich,icz
14665 
14666       is=iabs(ich)/ich
14667       if(icz.eq.1)then                      !pion
14668        ic1=ich*(1-3*int(.5d0+qgran(b10)))
14669        if(qgran(b10).lt.dc(2))then
14670         ic2=-4*ic1/iabs(ic1)
14671         if(iabs(ic1).eq.1)then
14672          ich1=-5*is
14673         else
14674          ich1=4*is
14675         endif
14676        else
14677         ich1=ich*int(.5d0+qgran(b10))
14678         ic2=-ic1*iabs(ich1)-(ich+ic1)*iabs(ich-ich1)
14679        endif
14680       elseif(icz.eq.2)then
14681 c valence quark type simulation ( for proton )
14682        ic1=int(1.3333d0+qgran(b10))
14683 c leading nucleon type simulation ( flavors combinatorics )
14684        if(ic1.eq.1)then
14685         ich1=int(qgran(b10)+.5d0)+2
14686         ic2=1-ich1
14687        elseif(qgran(b10).lt..5d0)then
14688         ich1=2
14689         ic2=-2
14690        else
14691         ich1=7                   !uuu
14692         ic2=-1
14693        endif
14694        if(iabs(ich).eq.3)then    !neutron
14695         ic1=3-ic1
14696         ic2=-3-ic2
14697         if(ich1.eq.7)then
14698          ich1=8                  !ddd
14699         else
14700          ich1=5-ich1
14701         endif
14702        endif
14703        if(ich.lt.0)then
14704         ic1=-ic1
14705         ic2=-ic2
14706         ich1=-ich1
14707        endif
14708       elseif(icz.eq.3)then
14709        ic1=ich-3*is
14710        ic2=-is*int(1.5d0+qgran(b10))
14711        ich1=3*is-ic2
14712       elseif(icz.eq.4)then
14713        ic1=ich-9*is
14714        ic2=is*int(1.5d0+qgran(b10))
14715        ich1=9*is-ic2
14716       elseif(icz.eq.5)then
14717        ic1=is*int(1.5d0+qgran(b10))
14718        ic2=-ic1
14719        ich1=ich
14720       else
14721        ich1=0
14722        stop 'Should not happen in qgixxd !'
14723       endif
14724       ich=ich1
14725 
14726       if(debug.ge.3)write (moniou,202)ic1,ic2,ich
14727 201   format(2x,'qgixxd: hadron type ich=',i2,' auxilliary type icz='
14728      *,i1)
14729 202   format(2x,'qgixxd-end: parton flavors ic1=',i2,' ic2='
14730      *,i2,'new hadron type ich=',i2)
14731       return
14732       end
14733 
14734 c=============================================================================
14735       subroutine qgdifr(wppr,wmtg,izp,izt,jexpr,jextg,iret)
14736 c-----------------------------------------------------------------------------
14737 c qgdifr - treatment of diffraction dissociation / leading hadron states
14738 c wppr - LC momentum for projectile remnant;
14739 c wptg - LC momentum for target remnant;
14740 c izp  - projectile remnant type;
14741 c izt  - target remnant type;
14742 c jexpr/jextg = -2 - low mass diffraction;
14743 c             = -1 - more collisions to follow;
14744 c             =  0 - no excitation;
14745 c             >  0 - low mass excitation
14746 c-----------------------------------------------------------------------------
14747       implicit double precision (a-h,o-z)
14748       integer debug
14749       dimension ey(3),ep(4)
14750       common /qgarr1/  ia(2),icz,icp
14751       common /qgarr2/  scm,wp0,wm0
14752       common /qgarr6/  pi,bm,amws
14753       common /qgarr8/  wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
14754       common /qgarr10/ am(7),ammu
14755       common /qgarr11/ b10
14756       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
14757       common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
14758       common /qgarr43/ moniou
14759       common /qgdebug/  debug
14760       EXTERNAL qgran
14761 
14762       if(debug.ge.2)write (moniou,201)izp,izt,wppr,wmtg
14763 
14764       iret=0
14765       jexip=0
14766       jexit=0
14767       ddmin1=0.d0
14768       ddmax1=0.d0
14769 c check if remnants are excited to low mass states
14770       if(jexpr.eq.-2.or.jexpr.gt.0.and.qgran(b10)
14771      *.lt.1.d0-(1.d0-wex(icz))**dble(jexpr).and.iabs(izp).lt.7)jexip=1
14772       if(jextg.eq.-2.or.jextg.gt.0.and.qgran(b10)
14773      *.lt.1.d0-(1.d0-wex(2))**dble(jextg).and.iabs(izt).lt.7)jexit=1
14774 c add low mass excitations if no particles produced before
14775       if(wppr.ge.wp0.and.jexpr.gt.0.and.jexip.eq.0.and.iabs(izp).lt.7)
14776      *jexip=1
14777       if(wmtg.ge.wm0.and.jextg.gt.0.and.jexit.eq.0.and.iabs(izt).lt.7)
14778      *jexit=1
14779 
14780       sd0=wppr*wmtg                          !energy squared available
14781       if(jextg.eq.-1)then                    !more collisions to follow
14782        dmass2=0.d0
14783        ddmin2=0.d0
14784       elseif(jexit.eq.0)then                 !no excitation
14785        if(iabs(izt).eq.7.or.iabs(izt).eq.8)then  !delta++/-
14786         dmass2=dmmin(2)
14787        else
14788         dmass2=am(2)
14789        endif
14790        ddmin2=dmass2
14791       else                                   !low mass excitation
14792        ddmin2=dmmin(2)
14793        if(jextg.eq.-2)ddmin2=dmres(2)        !low mass diffraction
14794       endif
14795       if(jexpr.eq.-1)then                    !more collisions to follow
14796        dmass1=0.d0
14797       elseif(jexip.eq.0)then                 !no excitation
14798        if(iabs(izp).eq.7.or.iabs(izp).eq.8)then  !delta++/-
14799         dmass1=dmmin(2)
14800        elseif(izp.eq.0)then                      !rho0
14801         dmass1=dmmin(1)
14802         izp=-10
14803        else
14804         dmass1=am(icz)
14805        endif
14806       else                                   !low mass excitation
14807        ddmin1=dmmin(icz)
14808        if(jexpr.eq.-2)ddmin1=dmres(icz)        !low mass diffraction
14809        ddmax1=dsqrt(sd0)-ddmin2
14810       endif
14811 
14812 
14813 c determine mass for projectile excited remnant
14814       if(jexip.eq.1)then
14815        if(jexpr.ne.-2)then                   !low mass excitation (dM/M^2)
14816         if(ddmax1.gt.ddmin1)then
14817          dmass1=ddmin1/(1.d0-qgran(b10)*(1.d0-ddmin1/ddmax1))
14818         else
14819          dmass1=ddmin1
14820         endif
14821        else                                  !low mass diffraction (res. + PPR)
14822         ddmin=dmmin(icz)+am(1)
14823         ddmax=min(ddmax1,dmres(icz)+.5d0*wdres(icz))
14824         ddmax=max(ddmax,ddmin)
14825         wres=1.d0/(1.d0+.5d0*(1.d0+2.d0*dmres(icz)/wdres(icz))
14826      *  *(1.d0-(dmres(icz)+.5d0*wdres(icz))
14827      *  /max(ddmax1,dmres(icz)+.5d0*wdres(icz)))
14828      *  /(.25d0*pi+atan(2.d0*(dmres(icz)-ddmin)/wdres(icz))))
14829         if(qgran(b10).gt.wres)then           !PPR contribution
14830          dmass1=ddmax/(1.d0-qgran(b10)*(1.d0-ddmax/ddmax1))
14831         else                                 !resonance contribution
14832          dmass1=dmres(icz)+.5d0*wdres(icz)
14833      *   *tan(atan(2.d0*(ddmax-dmres(icz))/wdres(icz))
14834      *   -qgran(b10)*(atan(2.d0*(ddmax-dmres(icz))/wdres(icz))
14835      *   +atan(2.d0*(dmres(icz)-ddmin)/wdres(icz))))
14836          jexip=0
14837          izp=izp+10*izp/iabs(izp)
14838         endif
14839        endif
14840       endif
14841 
14842 c determine mass for target excited remnant
14843       if(jexit.eq.1)then
14844        ddmax2=dsqrt(sd0)-dmass1
14845        if(jextg.ne.-2)then                   !low mass excitation (dM/M^2)
14846         if(ddmax2.gt.ddmin2)then
14847          dmass2=ddmin2/(1.d0-qgran(b10)*(1.d0-ddmin2/ddmax2))
14848         else                                  !low mass diffraction
14849          dmass2=ddmin2
14850         endif
14851        else                                  !low mass diffraction (res. + PPR)
14852         ddmin=dmmin(2)+am(1)
14853         ddmax=min(ddmax2,dmres(2)+.5d0*wdres(2))
14854         ddmax=max(ddmax,ddmin)
14855         wres=1.d0/(1.d0+.5d0*(1.d0+2.d0*dmres(2)/wdres(2))
14856      *  *(1.d0-(dmres(2)+.5d0*wdres(2))/max(ddmax2,dmres(2)+.5d0
14857      *  *wdres(2)))/(.25d0*pi+atan(2.d0*(dmres(2)-ddmin)/wdres(2))))
14858         if(qgran(b10).gt.wres)then           !PPR contribution
14859          dmass2=ddmax/(1.d0-qgran(b10)*(1.d0-ddmax/ddmax2))
14860         else                                 !resonance contribution
14861          dmass2=dmres(2)+.5d0*wdres(2)*tan(atan(2.d0*(ddmax-dmres(2))
14862      *   /wdres(2))-qgran(b10)*(atan(2.d0*(ddmax-dmres(2))/wdres(2))
14863      *   +atan(2.d0*(dmres(2)-ddmin)/wdres(2))))
14864          izt=izt+10*izt/iabs(izt)
14865          jexit=0
14866         endif
14867        endif
14868       endif
14869 
14870       wpp=wppr
14871       wpm=wmtg
14872       if(sd0.lt.(dmass1+dmass2)**2)then
14873        iret=1
14874        return
14875       endif
14876       dmass1=dmass1**2
14877       dmass2=dmass2**2
14878 
14879       if(jexpr.ne.-1.and.jextg.ne.-1)then
14880        ptmax=max(0.d0,qglam(sd0,dmass1,dmass2))
14881        if(jexpr.eq.-2.or.jextg.eq.-2)then
14882         ptmean=ptdif
14883        else
14884         ptmean=ptndi*dsqrt(dble(max(jexpr,jextg)))
14885        endif
14886        if(ptmax.lt.ptmean**2)then
14887 1       pti=ptmax*qgran(b10)
14888         if(qgran(b10).gt.exp(-dsqrt(pti)/ptmean))goto 1
14889        else
14890 2       pti=(ptmean*dlog(qgran(b10)*qgran(b10)))**2
14891         if(pti.gt.ptmax)goto 2
14892        endif
14893       else
14894        pti=0.d0
14895       endif
14896       amt1=dmass1+pti
14897       amt2=dmass2+pti
14898       wpd1=wpp*qgtwd(sd0,amt1,amt2)
14899       if(wpd1.gt.0.d0)then
14900        wmd1=amt1/wpd1
14901       else
14902        wmd1=0.d0
14903       endif
14904       wmd2=wpm-wmd1
14905       if(wmd2.gt.0.d0)then
14906        wpd2=amt2/wmd2
14907       else
14908        wpd2=0.d0
14909       endif
14910       pt=dsqrt(pti)
14911       call qgcs(c,s)
14912 
14913       if(jexpr.eq.-1)then
14914        wppr=wpd1
14915        if(wmd1.ne.0.d0)stop'wmd1.ne.0!!!'
14916       else
14917        ep(1)=.5d0*(wpd1+wmd1)
14918        ep(2)=.5d0*(wpd1-wmd1)
14919        ep(3)=pt*c
14920        ep(4)=pt*s
14921        wppr=0.d0
14922        if(jexip.eq.0)then
14923         call qgreg(ep,izp)
14924        else
14925         is=0
14926         if(izp.ne.0)is=iabs(izp)/izp
14927         if(icz.eq.1)then
14928          if(iabs(izp).ge.4)then
14929           ic2=-4*is
14930           ic1=izp-3*is
14931          elseif(izp.ne.0)then
14932           ic1=izp*(1-3*int(.5d0+qgran(b10)))
14933           ic2=-izp-ic1
14934          else
14935           ic1=int(1.5d0+qgran(b10))*(2*int(.5d0+qgran(b10))-1)
14936           ic2=-ic1
14937          endif
14938         elseif(icz.eq.2)then
14939          if(qgran(b10).gt..33333d0)then
14940           ic1=3*is
14941           ic2=izp-is
14942          else
14943           ic1=izp+4*is
14944           ic2=4*is-izp
14945          endif
14946         elseif(icz.eq.3)then
14947          ic1=-4*is
14948          ic2=izp-3*is
14949         endif
14950         call qgdeft(dmass1,ep,ey)
14951         call qggene(dsqrt(dmass1),dsqrt(dmass1),ey
14952      *  ,0.d0,1.d0,0.d0,1.d0,ic1,ic2)
14953        endif
14954       endif
14955 
14956       if(jextg.eq.-1)then
14957        wmtg=wmd2
14958        if(wpd2.ne.0.d0)stop'wpd2.ne.0!!!'
14959       else
14960        ep(1)=.5d0*(wpd2+wmd2)
14961        ep(2)=.5d0*(wpd2-wmd2)
14962        ep(3)=-pt*c
14963        ep(4)=-pt*s
14964        wmtg=0.d0
14965        if(jexit.eq.0)then
14966         call qgreg(ep,izt)
14967        else
14968         is=iabs(izt)/izt
14969         if(qgran(b10).gt..33333d0)then
14970          ic1=3*is
14971          ic2=izt-is
14972         else
14973          ic1=izt+4*is
14974          ic2=4*is-izt
14975         endif
14976         call qgdeft(dmass2,ep,ey)
14977         call qggene(dsqrt(dmass2),dsqrt(dmass2),ey
14978      *  ,0.d0,1.d0,0.d0,1.d0,ic2,ic1)
14979        endif
14980       endif
14981 
14982       if(debug.ge.3)write (moniou,202)
14983 201   format(2x,'qgdifr - leading clusters hadronization:'
14984      */4x,'cluster types izp=',i2,2x,
14985      *'izt=',i2/4x,'available light cone momenta: wppr=',e10.3,
14986      *' wmtg=',e10.3)
14987 202   format(2x,'qgdifr - end')
14988       return
14989       end
14990 
14991 c=============================================================================
14992       subroutine qgfau(b,gz)
14993 c-----------------------------------------------------------------------------
14994 c integrands for hadron-hadron and hadron-nucleus cross-sections calculation
14995 c-----------------------------------------------------------------------------
14996       implicit double precision (a-h,o-z)
14997       integer debug
14998       parameter(iapmax=208)
14999       dimension gz(3),gz0(5)
15000       common /qgarr1/  ia(2),icz,icp
15001       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
15002       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
15003      *,cr1(2),cr2(2),cr3(2)
15004       common /qgarr43/ moniou
15005       common /qgdebug/  debug
15006 
15007       if(debug.ge.2)write (moniou,201)b
15008 
15009       do l=1,3
15010        gz(l)=0.d0
15011       enddo
15012 
15013       ab=float(ia(2))
15014       do iddp1=1,2
15015       do iddp2=1,2
15016        call qgfz(b,gz0,iddp1,iddp2)
15017        if(iddp1.eq.iddp2)gz(1)=gz(1)+(1.d0-gz0(1)*anorm)**ab
15018      * *cc(iddp1,icz)
15019        do l=2,3
15020         gz(l)=gz(l)+(1.d0-gz0(l-1)*anorm)**ab
15021      *  *cc(iddp1,icz)*cc(iddp2,icz)
15022        enddo
15023       enddo
15024       enddo
15025 
15026       gz(3)=gz(2)-gz(3)
15027       gz(2)=gz(1)-gz(2)
15028       gz(1)=1.d0-gz(1)
15029 
15030       if(debug.ge.2)write (moniou,203)gz
15031       if(debug.ge.3)write (moniou,202)
15032 201   format(2x,'qgfau - integrands for hadron-hadron and hadron'
15033      *,'-nucleus cross-sections calculation'/4x,'b=',e10.3)
15034 202   format(2x,'qgfau - end')
15035 203   format(2x,'qgfau: gz=',3e10.3)
15036       return
15037       end
15038 
15039 c=============================================================================
15040       subroutine qgfrag(sa,na,rc)
15041 c-----------------------------------------------------------------------------
15042 c connected nucleon clasters extraction - used for the nuclear spectator part
15043 c multifragmentation
15044 c-----------------------------------------------------------------------------
15045       implicit double precision (a-h,o-z)
15046       integer debug
15047       parameter(iapmax=208)
15048       dimension sa(iapmax,3)
15049       common /qgarr13/ nsf,iaf(iapmax)
15050       common /qgarr43/ moniou
15051       common /qgdebug/  debug
15052 
15053       if(debug.ge.2)write (moniou,201)na
15054       if(debug.ge.3)then
15055        write (moniou,203)
15056        do i=1,na
15057         write (moniou,204)(sa(i,l),l=1,3)
15058        enddo
15059       endif
15060 
15061       ni=1
15062       ng=1
15063       j=0
15064 1     j=j+1
15065       j1=ni+1
15066 
15067       do 4 i=j1,na
15068        ri=0.d0
15069        do m=1,3
15070         ri=ri+(sa(j,m)-sa(i,m))**2
15071        enddo
15072        if(ri.gt.rc)goto 4
15073 
15074        ni=ni+1
15075        ng=ng+1
15076        if(i.eq.ni)goto 4
15077        do m=1,3
15078         s0=sa(ni,m)
15079         sa(ni,m)=sa(i,m)
15080         sa(i,m)=s0
15081        enddo
15082 4     continue
15083 
15084       if(j.lt.ni.and.na-ni.gt.0)goto 1
15085       nsf=nsf+1
15086       iaf(nsf)=ng
15087       if(debug.ge.3)write (moniou,206)nsf,iaf(nsf)
15088 
15089       ng=1
15090       j=ni
15091       ni=ni+1
15092       if(na.eq.ni)then
15093        nsf=nsf+1
15094        iaf(nsf)=1
15095        if(debug.ge.3)write (moniou,206)nsf,iaf(nsf)
15096       elseif(na.gt.ni)then
15097        goto 1
15098       endif
15099 
15100       if(debug.ge.3)write (moniou,202)
15101 201   format(2x,'qgfrag-multifragmentation: nucleus mass number: na='
15102      *,i2)
15103 202   format(2x,'qgfrag - end')
15104 203   format(2x,'nucleons coordinates:')
15105 204   format(2x,3e10.3)
15106 206   format(2x,'qgfrag: fragment n',i2,2x,'fragment mass - ',i2)
15107       return
15108       end
15109 
15110 c=============================================================================
15111       subroutine qgfrgm(ns,xa)
15112 c-----------------------------------------------------------------------------
15113 c fragmentation of the spectator part of the nucleus
15114 c xa - array for spectator nucleons positions
15115 c ns - total number of spectators
15116 c-----------------------------------------------------------------------------
15117       implicit double precision (a-h,o-z)
15118       parameter(iapmax=208)
15119       dimension xa(iapmax,3)
15120       integer debug
15121       common /qgarr1/  ia(2),icz,icp
15122       common /qgarr3/  rmin,emax,eev
15123       common /qgarr11/ b10
15124 c nsf - number of secondary fragments;
15125 c iaf(i) - mass of the i-th fragment
15126       common /qgarr13/ nsf,iaf(iapmax)
15127       common /qgarr43/ moniou
15128       common /qgdebug/  debug
15129       EXTERNAL qgran
15130 
15131       if(debug.ge.2)write (moniou,201)ns
15132 
15133       nsf=0
15134       if(ns.eq.0)then                  !no fragments
15135        return
15136       elseif(ns.eq.1)then              !single spectator nucleon recorded
15137        nsf=nsf+1
15138        iaf(nsf)=1
15139        if(debug.ge.3)write (moniou,205)
15140        return
15141       endif
15142 
15143       eex=0.d0                         !excitation energy for spectator part
15144            !sum of excitations due to wounded nucleons (including diffractive)
15145       do i=1,ia(1)-ns
15146 c partial excitation according to f(e) ~ 1/sqrt(e) * exp(-e/(2*<e>))
15147        eex=eex+(qgran(b10)+qgran(b10)+qgran(b10)+
15148      * qgran(b10)+qgran(b10)-2.5d0)**2*2.4d0
15149       enddo
15150       if(debug.ge.3)write (moniou,203)eex
15151 
15152       if(eex/ns.gt.emax)then    !if eex>emax -> multifragmentation
15153        call qgfrag(xa,ns,rmin)  !multifragmentation (percolation algorithm)
15154       else                      !otherwise eveporation
15155        nf=npgen(eex/eev,0,ns-1) !number of eveporated nucleons (mean=eex/eev)
15156        nsf=nsf+1
15157        iaf(nsf)=ns-nf           !recording of the fragment produced
15158        if(debug.ge.3)write (moniou,206)iaf(nsf)
15159 
15160        nal=nf/4                 !number of evapotared alphas (taken as nf/4)
15161        if(nal.ne.0)then
15162         do i=1,nal              !recording the evaporated alphas
15163          nsf=nsf+1
15164          iaf(nsf)=4
15165         enddo
15166        endif
15167        nf=nf-4*nal
15168 
15169        if(nf.ne.0)then
15170         do i=1,nf               !recording the evaporated nucleons
15171          nsf=nsf+1
15172          iaf(nsf)=1
15173         enddo
15174        endif
15175        if(debug.ge.3)write (moniou,204)nf,nal
15176       endif
15177 c6     continue
15178 
15179       if(debug.ge.3)write (moniou,202)
15180 201   format(2x,'qgfrgm: number of spectators: ns=',i2)
15181 202   format(2x,'qgfrgm - end')
15182 203   format(2x,'qgfrgm: excitation energy: eex=',e10.3)
15183 204   format(2x,'qgfrgm - evaporation: number of nucleons nf='
15184      *,i2,'number of alphas nal=',i2)
15185 205   format(2x,'qgfrgm - single spectator')
15186 206   format(2x,'qgfrgm - evaporation: mass number of the fragment:',i2)
15187       return
15188       end
15189 
15190 c=============================================================================
15191       subroutine qggau(gz)
15192 c-----------------------------------------------------------------------------
15193 c impact parameter integration for impact parameters <bm -
15194 c for hadron-hadron and hadron-nucleus cross-sections calculation
15195 c-----------------------------------------------------------------------------
15196       implicit double precision (a-h,o-z)
15197       integer debug
15198       dimension gz(3),gz0(3)
15199       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
15200      *,cr1(2),cr2(2),cr3(2)
15201       common /qgarr6/  pi,bm,amws
15202       common /arr3/   x1(7),a1(7)
15203       common /qgarr43/ moniou
15204       common /qgdebug/  debug
15205 
15206       if(debug.ge.2)write (moniou,201)
15207 
15208       do i=1,3
15209        gz(i)=0.d0
15210       enddo
15211       do i=1,7
15212       do m=1,2
15213        b=bm*dsqrt(.5d0+x1(i)*(m-1.5d0))
15214        call qgfau(b,gz0)
15215        do l=1,3
15216         gz(l)=gz(l)+gz0(l)*a1(i)
15217        enddo
15218       enddo
15219       enddo
15220 
15221       do l=1,3
15222        gz(l)=gz(l)*bm**2*pi*.5d0
15223       enddo
15224 
15225       if(debug.ge.3)write (moniou,202)
15226 201   format(2x,'qggau - nuclear cross-sections calculation')
15227 202   format(2x,'qggau - end')
15228       return
15229       end
15230 
15231 c=============================================================================
15232       subroutine qggau1(gz)
15233 c-----------------------------------------------------------------------------
15234 c impact parameter integration for impact parameters >bm -
15235 c for hadron-hadron and hadron-nucleus cross-sections calculation
15236 c-----------------------------------------------------------------------------
15237       implicit double precision (a-h,o-z)
15238       integer debug
15239       dimension gz(3),gz0(3)
15240       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
15241      *,cr1(2),cr2(2),cr3(2)
15242       common /qgarr6/  pi,bm,amws
15243       common /qgarr43/ moniou
15244       common /arr3/   x1(7),a1(7)
15245       common /qgdebug/  debug
15246 
15247       if(debug.ge.2)write (moniou,201)
15248 
15249       do i=1,7
15250       do m=1,2
15251        b=bm-wsnuc(2)*dlog(.5d0+x1(i)*(m-1.5d0))
15252        call qgfau(b,gz0)
15253        do l=1,3
15254         gz(l)=gz(l)+gz0(l)*a1(i)*exp((b-bm)/wsnuc(2))*b*pi*wsnuc(2)
15255        enddo
15256       enddo
15257       enddo
15258 
15259       if(debug.ge.3)write (moniou,202)
15260 201   format(2x,'qggau1 - nuclear cross-sections calculation')
15261 202   format(2x,'qggau1 - end')
15262       return
15263       end
15264 
15265 c=============================================================================
15266       double precision function qganrm(rnuc,wsnuc,wbnuc)
15267 c-----------------------------------------------------------------------------
15268 c impact parameter integration for impact parameters <bm -
15269 c for hadron-hadron and hadron-nucleus cross-sections calculation
15270 c-----------------------------------------------------------------------------
15271       implicit double precision (a-h,o-z)
15272       integer debug
15273       common /qgarr6/  pi,bm,amws
15274       common /arr3/   x1(7),a1(7)
15275       common /qgarr43/ moniou
15276       common /qgdebug/  debug
15277 
15278       if(debug.ge.2)write (moniou,201)
15279 
15280       qganrm=0.d0
15281       do i=1,7
15282       do m=1,2
15283        r=rnuc*(.5d0+x1(i)*(m-1.5d0))**(1.d0/3.d0)
15284        quq=(r-rnuc)/wsnuc
15285        if(quq.lt.1.d80)qganrm=qganrm+a1(i)/(1.d0+exp(quq))
15286      * *(1.d0+wbnuc*(r/rnuc)**2)
15287       enddo
15288       enddo
15289       qganrm=qganrm*rnuc**3*pi/1.5d0
15290 
15291       dnrm=0.d0
15292       do i=1,7
15293       do m=1,2
15294        t=.5d0+x1(i)*(m-1.5d0)
15295        r=rnuc-wsnuc*log(t)
15296        dnrm=dnrm+a1(i)/(1.d0+t)*r*r
15297      * *(1.d0+wbnuc*(r/rnuc)**2)
15298       enddo
15299       enddo
15300       qganrm=1.d0/(qganrm+dnrm*2.d0*pi*wsnuc)
15301 
15302       if(debug.ge.3)write (moniou,202)qganrm
15303 201   format(2x,'qganrm - nuclear density normalization')
15304 202   format(2x,'qganrm=',e10.3)
15305       return
15306       end
15307 
15308 c=============================================================================
15309       subroutine qggene(wp0,wm0,ey0,s0x,c0x,s0,c0,ic1,ic2)
15310 c-----------------------------------------------------------------------------
15311 c to simulate the fragmentation of the string into secondary hadrons
15312 c the algorithm conserves energy-momentum;
15313 c wp0, wm0 are initial longitudinal momenta ( e+p, e-p ) of the quarks
15314 c at the ends of the string; ic1, ic2 - their types
15315 c the following partons types are used: 1 - u, -1 - U, 2 - d, -2 - D,
15316 c 3 - ud, -3 - UD, 4 - s, -4 - S, 6 - uu, -6 - UU, 7 - dd, -7 - DD,
15317 c 8 - us, -8 - US
15318 c-----------------------------------------------------------------------------
15319       implicit double precision (a-h,o-z)
15320       integer debug
15321       character *2 tyq
15322       dimension wp(2),ic(2),ept(4),ep(4),ey(3),ey0(3)
15323 c wp(1), wp(2) - current longitudinal momenta of the partons at the string
15324 c ends, ic(1), ic(2) - their types
15325       common /qgarr8/  wwm,bep,ben,bek,bec,dc(5),deta,almpt,ptdif
15326      *,ptndi
15327       common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
15328       common /qgarr11/ b10
15329       common /qgarr19/ ahl(3)
15330       common /qgarr28/ arr(5)
15331       common /qgarr42/ tyq(16)
15332       common /qgarr43/ moniou
15333       common /qgdebug/  debug
15334       external qgran
15335 
15336       if(debug.ge.2)write (moniou,201)tyq(8+ic1),tyq(8+ic2)
15337      *,wp0,wm0,ey0,s0x,c0x,s0,c0
15338 
15339       ww=wp0*wm0                              !mass squared for the string
15340       ept(1)=.5d0*(wp0+wm0)                   !4-momentum for the string
15341       ept(2)=.5d0*(wp0-wm0)
15342       ept(3)=0.d0
15343       ept(4)=0.d0
15344 
15345       if(iabs(ic1).eq.5.or.iabs(ic2).eq.5.or.iabs(ic1).gt.8
15346      *.or.iabs(ic2).gt.8)stop'qggene: problem with parton types'
15347 
15348       ic(1)=ic1                               !parton types at string ends
15349       ic(2)=ic2
15350 
15351 1     sww=dsqrt(ww)
15352       call qgdeft(ww,ept,ey)                  !boost to c.m.  for the string
15353       j=int(2.d0*qgran(b10))+1                !choose string end to start
15354 
15355       if(debug.ge.3)then
15356        iqt=8+ic(j)
15357        write (moniou,203)j,tyq(iqt),ww
15358       endif
15359 
15360       iab=iabs(ic(j))
15361       is=ic(j)/iab
15362       if(iab.eq.8)then
15363        iab=6
15364       elseif(iab.gt.5)then
15365        iab=3
15366       endif
15367       iaj=iabs(ic(3-j))
15368       if(iaj.eq.8)then
15369        iaj=6
15370       elseif(iaj.gt.5)then
15371        iaj=3
15372       endif
15373       if(iab.eq.5)stop'no charm anymore!'
15374 
15375       if(iaj.eq.3)then
15376        restm=amn
15377       elseif(iaj.eq.4)then
15378        restm=amk
15379       elseif(iaj.eq.5)then
15380        stop'no charm anymore!'
15381       elseif(iaj.eq.6)then
15382        restm=amlam
15383       else
15384        restm=am0
15385       endif
15386 
15387       if(iab.le.2.and.sww.gt.restm+2.d0*am0+wwm
15388      *.or.iab.eq.3.and.sww.gt.restm+am0+amn+wwm
15389      *.or.iab.eq.4.and.sww.gt.restm+am0+amk+wwm
15390      *.or.iab.eq.6.and.sww.gt.restm+am0+amlam+wwm)then !more than 2 particles
15391        if(iab.le.2)then                                !light quark string end
15392         if(iab.eq.2.and.iabs(ic(3-j)).ne.7
15393      *  .and.sww.gt.restm+2.d0*amlam.and.qgran(b10).lt.dc(1)*dc(2))then
15394 c lambda generation
15395          restm=(restm+amlam)**2
15396          bet=ben
15397          ami=amlam**2
15398          alf=almpt-arr(2)+arr(1)-arr(3)
15399          blf=1.d0-arr(2)-arr(3)
15400          ic0=6*is                                      !(anti-)lambda
15401          ic(j)=-8*is                                   !US(us)
15402         elseif(sww.gt.restm+2.d0*amn.and.qgran(b10).lt.dc(1))then
15403 c nucleon generation
15404          restm=(restm+amn)**2
15405          bet=ben
15406          ami=amn**2
15407          alf=almpt-arr(2)
15408          blf=1.d0-arr(1)-arr(2)
15409          ic0=ic(j)+is
15410          ic(j)=-3*is
15411         elseif(sww.gt.restm+2.d0*amk.and.qgran(b10).lt.dc(2))then
15412 c kaon generation
15413          restm=(restm+amk)**2
15414          bet=bek
15415          ami=amk**2
15416          alf=almpt-arr(3)
15417          blf=1.d0-arr(1)-arr(3)
15418          ic0=ic(j)+3*is
15419          ic(j)=4*is
15420         elseif(sww.gt.restm+ameta+am0.and.qgran(b10).lt.deta)then
15421 c eta generation
15422          restm=(restm+am0)**2
15423          bet=bek
15424          ami=ameta**2
15425          alf=almpt-arr(1)
15426          blf=1.d0-2.d0*arr(1)
15427          ic0=10
15428         else
15429 c pion generation
15430          restm=(restm+am0)**2
15431          bet=bep
15432          ami=am0**2
15433          alf=almpt-arr(1)
15434          blf=1.d0-2.d0*arr(1)
15435          if(qgran(b10).lt..3333d0)then
15436           ic0=0
15437          else
15438           ic0=3*is-2*ic(j)
15439           ic(j)=3*is-ic(j)
15440          endif
15441         endif
15442 
15443        elseif(iab.eq.3)then
15444         if(sww.gt.restm+amk+amlam.and.qgran(b10).lt.dc(4)
15445      *  .and.iabs(ic(j)).eq.3)then
15446 c lambda generation
15447          restm=(restm+amk)**2
15448          bet=bek
15449          ami=amlam**2
15450          alf=almpt-arr(3)
15451          blf=1.d0-arr(2)-arr(3)
15452          ic0=6*is
15453          ic(j)=-4*is
15454         else
15455 c nucleon generation
15456          restm=(restm+am0)**2
15457          bet=ben
15458          ami=amn**2
15459          alf=almpt-arr(1)
15460          blf=1.d0-arr(1)-arr(2)
15461          if(iabs(ic(j)).eq.3)then
15462           ic0=is*int(2.5d0+qgran(b10))
15463           ic(j)=is-ic0
15464          else
15465           ic0=ic(j)-4*is
15466           ic(j)=ic0-4*is
15467          endif
15468         endif
15469 
15470        elseif(iab.eq.4)then
15471         if(sww.gt.restm+amn+amlam.and.qgran(b10).lt.dc(1))then
15472 c lambda generation
15473          restm=(restm+amn)**2
15474          bet=ben
15475          ami=amlam**2
15476          alf=almpt-arr(2)
15477          blf=1.d0-arr(2)-arr(3)
15478          ic0=6*is
15479          ic(j)=-3*is
15480         else
15481 c kaon generation
15482          restm=(restm+am0)**2
15483          bet=bep
15484          ami=amk**2
15485          alf=almpt-arr(1)
15486          blf=1.d0-arr(1)-arr(3)
15487          ic(j)=is*int(1.5d0+qgran(b10))
15488          ic0=-3*is-ic(j)
15489         endif
15490 
15491        elseif(iab.eq.6)then
15492 c lambda generation
15493         restm=(restm+am0)**2
15494         bet=bep
15495         ami=amlam**2
15496         alf=almpt-arr(1)
15497         blf=1.d0-arr(2)-arr(3)
15498         ic0=6*is
15499         ic(j)=-2*is
15500        endif
15501 
15502        ptmax=qglam(ww,restm,ami)
15503        if(ptmax.lt.0.)ptmax=0.
15504 
15505        if(ptmax.lt.bet**2)then
15506 2       pti=ptmax*qgran(b10)
15507         if(qgran(b10).gt.exp(-dsqrt(pti)/bet))goto 2
15508        else
15509 3       pti=(bet*dlog(qgran(b10)*qgran(b10)))**2
15510         if(pti.gt.ptmax)goto 3
15511        endif
15512 
15513        amt=ami+pti
15514        restm1=restm+pti
15515        zmin=1.d0-qgtwd(ww,restm1,amt)
15516        zmax=qgtwd(ww,amt,restm1)
15517 
15518        z1=(1.d0-zmax)**alf
15519        z2=(1.d0-zmin)**alf
15520 4      z=1.-(z1+(z2-z1)*qgran(b10))**(1./alf)
15521        if(qgran(b10).gt.(z/zmax)**blf)goto 4
15522        wp(j)=z*sww
15523        wp(3-j)=amt/wp(j)
15524        ep(1)=.5d0*(wp(1)+wp(2))
15525        ep(2)=.5d0*(wp(1)-wp(2))
15526        pti=dsqrt(pti)
15527        call qgcs(c,s)
15528        ep(3)=pti*c
15529        ep(4)=pti*s
15530        ept(1)=sww-ep(1)
15531        do i=2,4
15532         ept(i)=-ep(i)
15533        enddo
15534        ww=qgnrm(ept)
15535        if(ww.lt.restm)goto 4
15536 
15537        call qgtran(ep,ey,1)
15538        call qgtran(ept,ey,1)
15539        if(s0x.ne.0.d0.or.s0.ne.0.d0)then
15540         call qgrota(ep,s0x,c0x,s0,c0)
15541        endif
15542        if(ey0(1)*ey0(2)*ey0(3).ne.1.d0)then
15543         call qgtran(ep,ey0,1)
15544        endif
15545        call qgreg(ep,ic0)
15546 
15547       else
15548        ami2=restm**2
15549        bet=bep
15550        if(iab.eq.6.or.iaj.eq.6)then
15551         if(iab.eq.6)then
15552          ami=amlam**2
15553          ic(j)=6*is
15554          if(iaj.eq.6)then
15555           ic(3-j)=-6*is
15556          elseif(iaj.eq.4)then
15557           ic(3-j)=-5*is
15558          elseif(iaj.le.2)then
15559           ic(3-j)=2*is-ic(3-j)
15560          else
15561           if(iabs(ic(3-j)).eq.3)then
15562            ic(3-j)=-3*is
15563           elseif(iabs(ic(3-j)).eq.6)then
15564            ic(3-j)=-2*is
15565           else
15566            stop'wrong parton types'
15567           endif
15568          endif
15569         elseif(iab.eq.4)then
15570          ami=amk**2
15571          ic(j)=-5*is
15572          ic(3-j)=6*is
15573         elseif(iab.le.2)then
15574          ami=am0**2
15575          ic(j)=2*is-ic(j)
15576          ic(3-j)=6*is
15577         else
15578          ami=amn**2
15579          ic(3-j)=-6*is
15580          if(iabs(ic(j)).eq.3)then
15581           ic(j)=3*is
15582          elseif(iabs(ic(j)).eq.6)then
15583           ic(j)=2*is
15584          else
15585           stop'wrong parton types'
15586          endif
15587         endif
15588 
15589        elseif(iab.le.2.and.iaj.le.2)then
15590         if(sww.gt.2.d0*amk.and.qgran(b10).lt.dc(2))then
15591          bet=bek
15592          ami=amk**2
15593          ami2=ami
15594          ic(j)=ic(j)+3*is
15595          ic(3-j)=ic(3-j)-3*is
15596         else
15597          ami=am0**2
15598          ic0=-ic(1)-ic(2)
15599          if(ic0.ne.0)then
15600           ic(j)=ic0*int(.5d0+qgran(b10))
15601           ic(3-j)=ic0-ic(j)
15602          else
15603           if(qgran(b10).lt..2d0)then
15604            ic(j)=0
15605            ic(3-j)=0
15606           else
15607            ic(j)=3*is-2*ic(j)
15608            ic(3-j)=-ic(j)
15609           endif
15610          endif
15611         endif
15612 
15613        elseif(iab.eq.3.or.iaj.eq.3)then
15614         if(iab.eq.3)then
15615          ami=amn**2
15616          if(iabs(ic(j)).eq.3)then
15617           if(iaj.eq.3)then
15618            if(iabs(ic(3-j)).eq.3)then
15619             if(sww.gt.2.d0*amlam.and.qgran(b10).lt.dc(4))then
15620              bet=bek
15621              ami=amlam**2
15622              ami2=ami
15623              ic(j)=6*is
15624              ic(3-j)=-6*is
15625             else
15626              ic(j)=is*int(2.5d0+qgran(b10))
15627              ic(3-j)=-ic(j)
15628             endif
15629            else
15630             ic(3-j)=ic(3-j)+4*is
15631             ic(j)=5*is+ic(3-j)
15632            endif
15633           elseif(iaj.lt.3)then
15634            if(sww.gt.amlam+amk.and.qgran(b10).lt.dc(4))then
15635             bet=bek
15636             ami=amlam**2
15637             ami2=amk**2
15638             ic(j)=6*is
15639             ic(3-j)=ic(3-j)+3*is
15640            else
15641             if(qgran(b10).lt..3333d0)then
15642              ic(j)=ic(3-j)+is
15643              ic(3-j)=0
15644             else
15645              ic(j)=is*(4-iaj)
15646              ic(3-j)=is*(3-2*iaj)
15647             endif
15648            endif
15649           elseif(iaj.eq.4)then
15650            ic(j)=is*int(2.5d0+qgran(b10))
15651            ic(3-j)=-ic(j)-2*is
15652           endif
15653          else
15654           if(iabs(ic(3-j)).gt.4)stop'qggene: problem with parton types'
15655           ic(j)=ic(j)-4*is
15656           ic0=ic(j)-4*is
15657           if(iaj.eq.3)then
15658            ic(3-j)=ic0-is
15659           elseif(iaj.lt.3)then
15660            ic(3-j)=-ic(3-j)-ic0
15661           elseif(iaj.eq.4)then
15662            ic(3-j)=ic0-3*is
15663           endif
15664          endif
15665         else
15666          if(iabs(ic(3-j)).eq.3)then
15667           if(iab.lt.3)then
15668            if(sww.gt.amlam+amk.and.qgran(b10).lt.dc(4))then
15669             bet=bek
15670             ami2=amlam**2
15671             ami=amk**2
15672             ic(j)=ic(j)+3*is
15673             ic(3-j)=6*is
15674            else
15675             ami=am0**2
15676             if(qgran(b10).lt..3333d0)then
15677              ic(3-j)=ic(j)+is
15678              ic(j)=0
15679             else
15680              ic(3-j)=is*(4-iab)
15681              ic(j)=is*(3-2*iab)
15682             endif
15683            endif
15684           elseif(iab.eq.4)then
15685            ami=amk**2
15686            ic(3-j)=is*int(2.5d0+qgran(b10))
15687            ic(j)=-ic(3-j)-2*is
15688           endif
15689          else
15690           ic(3-j)=ic(3-j)-4*is
15691           ic0=ic(3-j)-4*is
15692           if(iab.lt.3)then
15693            ami=am0**2
15694            ic(j)=-ic0-ic(j)
15695           elseif(iab.eq.4)then
15696            ami=amk**2
15697            ic(j)=ic0-3*is
15698           endif
15699          endif
15700         endif
15701        elseif(iab.eq.4.or.iaj.eq.4)then
15702         if(iab.eq.4)then
15703          ami=amk**2
15704          if(iaj.eq.4)then
15705           ic(j)=-is*int(4.5d0+qgran(b10))
15706           ic(3-j)=-ic(j)
15707          else
15708           ic0=ic(3-j)+int(.6667d0+qgran(b10))*(-3*is-2*ic(3-j))
15709           ic(j)=ic0-3*is
15710           ic(3-j)=ic0-ic(3-j)
15711          endif
15712         else
15713          ami=am0**2
15714          ic0=ic(j)+int(.6667d0+qgran(b10))*(3*is-2*ic(j))
15715          ic(j)=ic0-ic(j)
15716          ic(3-j)=ic0+3*is
15717         endif
15718        endif
15719 
15720        ptmax=qglam(ww,ami2,ami)
15721        if(ptmax.lt.0.)ptmax=0.
15722        if(ptmax.lt.bet**2)then
15723 5       pti=ptmax*qgran(b10)
15724         if(qgran(b10).gt.exp(-dsqrt(pti)/bet))goto 5
15725        else
15726 6       pti=(bet*dlog(qgran(b10)*qgran(b10)))**2
15727         if(pti.gt.ptmax)goto 6
15728        endif
15729        amt1=ami+pti
15730        amt2=ami2+pti
15731        z=qgtwd(ww,amt1,amt2)
15732        wp(j)=z*sww
15733        wp(3-j)=amt1/wp(j)
15734        ep(1)=.5d0*(wp(1)+wp(2))
15735        ep(2)=.5d0*(wp(1)-wp(2))
15736        pti=dsqrt(pti)
15737        call qgcs(c,s)
15738        ep(3)=pti*c
15739        ep(4)=pti*s
15740        ept(1)=sww-ep(1)
15741        do i=2,4
15742         ept(i)=-ep(i)
15743        enddo
15744        call qgtran(ep,ey,1)
15745        call qgtran(ept,ey,1)
15746        if(s0x.ne.0.d0.or.s0.ne.0.d0)then
15747         call qgrota(ep,s0x,c0x,s0,c0)
15748         call qgrota(ept,s0x,c0x,s0,c0)
15749        endif
15750        if(ey0(1)*ey0(2)*ey0(3).ne.1.d0)then
15751         call qgtran(ep,ey0,1)
15752         call qgtran(ept,ey0,1)
15753        endif
15754 
15755        call qgreg(ep,ic(j))
15756        call qgreg(ept,ic(3-j))
15757        if(debug.ge.3)write (moniou,202)
15758        return
15759       endif
15760       goto 1
15761 
15762 201   format(2x,'qggene: parton flavors at the ends of the string:'
15763      *,2x,a2,2x,a2/4x,'light cone momenta of the string: ',e10.3
15764      *,2x,e10.3/4x,'ey0=',3e10.3/4x,'s0x=',e10.3,2x,'c0x=',e10.3
15765      *,2x,'s0=',e10.3,2x,'c0=',e10.3)
15766 202   format(2x,'qggene - end')
15767 203   format(2x,'qggene: current parton flavor at the end '
15768      *,i1,' of the string: ',a2/4x,' string mass: ',e10.3)
15769       end
15770 
15771 c=============================================================================
15772       subroutine qgxjet
15773 c-----------------------------------------------------------------------------
15774 c procedure for jet hadronization
15775 c-----------------------------------------------------------------------------
15776       implicit double precision (a-h,o-z)
15777       integer debug
15778       parameter(njmax=50000)
15779       dimension ep(4),ept(4),ept1(4),ey(3)
15780      *,epj(4,2,2*njmax),ipj(2,2*njmax)
15781       common /qgarr8/  wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
15782       common /qgarr10/ am(7),ammu
15783       common /qgarr11/ b10
15784       common /qgarr36/ epjet(4,njmax),ipjet(njmax),njtot
15785       common /qgarr43/ moniou
15786       common /qgdebug/  debug
15787       external qgran
15788 
15789       if(debug.ge.2)write (moniou,201)njtot
15790 201   format(2x,'qgxjet: total number of jets njtot=',i4)
15791 
15792       nj0=1
15793       njet0=0
15794       nrej=0
15795 
15796 1     njet=njet0
15797       do i=1,4
15798        ept(i)=epjet(i,nj0)
15799        epj(i,1,njet+1)=ept(i)
15800       enddo
15801       iq1=ipjet(nj0)
15802       ipj(1,njet+1)=iq1
15803 
15804       if(iabs(iq1).le.2)then
15805        am1=am(1)
15806        if(iq1.gt.0)then
15807         jq=1
15808        else
15809         jq=2
15810        endif
15811       elseif(iabs(iq1).eq.4)then
15812        am1=am(3)
15813        if(iq1.gt.0)then
15814         jq=1
15815        else
15816         jq=2
15817        endif
15818       else
15819        am1=am(2)
15820        if(iq1.gt.0)then
15821         jq=2
15822        else
15823         jq=1
15824        endif
15825       endif
15826 
15827       ij=nj0
15828 2     ij=ij+1
15829       njet=njet+1
15830       iq2=ipjet(ij)
15831 
15832       if(iq2.eq.0)then
15833        aks=qgran(b10)
15834        do i=1,4
15835         epi=epjet(i,ij)*aks
15836         epj(i,2,njet)=epi
15837         ept(i)=ept(i)+epi
15838        enddo
15839        if(qgran(b10).lt.dc(2))then
15840         ipj(2,njet)=4*(2*jq-3)
15841         amj=am(3)
15842        else
15843         ipj(2,njet)=int(1.5d0+qgran(b10))*(2*jq-3)
15844         amj=am(1)
15845        endif
15846 
15847        if(qgnrm(ept).gt.(am1+amj)**2)then
15848         if(debug.ge.3)write (moniou,211)njet,ipj(1,njet),ipj(2,njet)
15849      *  ,qgnrm(ept),ept
15850 
15851         ipj(1,njet+1)=-ipj(2,njet)
15852         do i=1,4
15853          ept(i)=epjet(i,ij)-epj(i,2,njet)
15854          epj(i,1,njet+1)=ept(i)
15855         enddo
15856         am1=amj
15857         goto 2
15858        elseif(nrej.lt.100000)then
15859         nrej=nrej+1
15860         goto 1
15861        else
15862 3       continue
15863         do i=1,4
15864          ept(i)=epjet(i,ij)+epjet(i,ij-1)+epjet(i,ij+1)
15865          ep(i)=epjet(i,ij-1)
15866          ept1(i)=ept(i)
15867         enddo
15868         ww=qgnrm(ept1)
15869         if(ww.le.0.)then
15870          if(ij.gt.nj0+1)then
15871           ij=ij-1
15872           goto 3
15873          else
15874           ij=ij+1
15875           goto 3
15876          endif
15877         endif
15878         ipjet(ij)=ipjet(ij+1)
15879         sww=sqrt(ww)
15880         call qgdeft(ww,ept1,ey)
15881         call qgtran(ep,ey,-1)
15882         call qgdefr(ep,s0x,c0x,s0,c0)
15883         ep(1)=.5d0*sww
15884         ep(2)=.5d0*sww
15885         ep(3)=0.d0
15886         ep(4)=0.d0
15887         call qgrota(ep,s0x,c0x,s0,c0)
15888         call qgtran(ep,ey,1)
15889         do i=1,4
15890          epjet(i,ij-1)=ep(i)
15891          epjet(i,ij)=ept(i)-ep(i)
15892         enddo
15893 
15894         if(njtot.gt.ij+1)then
15895          do j=ij+1,njtot-1
15896           ipjet(j)=ipjet(j+1)
15897          do i=1,4
15898           epjet(i,j)=epjet(i,j+1)
15899          enddo
15900          enddo
15901         endif
15902         nrej=0
15903         njtot=njtot-1
15904         goto 1
15905        endif
15906 
15907       else
15908        ipj(2,njet)=iq2
15909        do i=1,4
15910         epi=epjet(i,ij)
15911         epj(i,2,njet)=epi
15912         ept(i)=ept(i)+epi
15913        enddo
15914 
15915        if(iabs(iq2).le.2)then
15916         am2=am(1)
15917        elseif(iabs(iq2).eq.4)then
15918         am2=am(3)
15919        else
15920         am2=am(2)
15921        endif
15922 
15923        if(qgnrm(ept).gt.(am1+am2)**2)then
15924         if(debug.ge.3)write (moniou,211)njet,ipj(1,njet),ipj(2,njet)
15925      *  ,qgnrm(ept),ept
15926 
15927         nj0=ij+1
15928         njet0=njet
15929         nrej=0
15930         if(ij.lt.njtot)then
15931          goto 1
15932         else
15933          goto 5
15934         endif
15935        elseif(nrej.lt.100000)then
15936         nrej=nrej+1
15937         goto 1
15938        else
15939 4       continue
15940         do i=1,4
15941          ept(i)=epjet(i,ij)+epjet(i,ij-1)+epjet(i,ij-2)
15942          ep(i)=epjet(i,ij-2)
15943          ept1(i)=ept(i)
15944         enddo
15945         ww=qgnrm(ept1)
15946         if(ww.lt.0.d0)then
15947          ij=ij-1
15948          goto 4
15949         endif
15950         ipjet(ij-1)=ipjet(ij)
15951         sww=sqrt(ww)
15952         call qgdeft(ww,ept1,ey)
15953         call qgtran(ep,ey,-1)
15954         call qgdefr(ep,s0x,c0x,s0,c0)
15955         ep(1)=.5d0*sww
15956         ep(2)=.5d0*sww
15957         ep(3)=0.d0
15958         ep(4)=0.d0
15959         call qgrota(ep,s0x,c0x,s0,c0)
15960         call qgtran(ep,ey,1)
15961         do i=1,4
15962          epjet(i,ij-2)=ep(i)
15963          epjet(i,ij-1)=ept(i)-ep(i)
15964         enddo
15965 
15966         if(ij.lt.njtot)then
15967          do j=ij,njtot-1
15968           ipjet(j)=ipjet(j+1)
15969          do i=1,4
15970           epjet(i,j)=epjet(i,j+1)
15971          enddo
15972          enddo
15973         endif
15974 
15975         nrej=0
15976         njtot=njtot-1
15977         goto 1
15978        endif
15979       endif
15980 
15981 5     continue
15982       do ij=1,njet
15983        do i=1,4
15984         ep(i)=epj(i,1,ij)
15985         ept(i)=ep(i)+epj(i,2,ij)
15986        enddo
15987 c invariant mass squared for the jet
15988        ww=qgnrm(ept)
15989 
15990        if(debug.ge.3)write (moniou,208)
15991      * ij,njet,ww,ipj(1,ij),ipj(2,ij)
15992 
15993        sww=dsqrt(ww)
15994        call qgdeft(ww,ept,ey)
15995        call qgtran(ep,ey,-1)
15996        call qgdefr(ep,s0x,c0x,s0,c0)
15997        call qggene(sww,sww,ey,s0x,c0x,s0,c0,ipj(1,ij),ipj(2,ij))
15998       enddo
15999 
16000       if(debug.ge.3)write (moniou,202)
16001 202   format(2x,'qgxjet - end')
16002 208   format(2x,'qgxjet: ij=',i2,2x,'njet=',i3,2x,'ww=',e10.3
16003      *,2x,'ic=',2i3)
16004 211   format(2x,'qgxjet: njet=',i3,2x,'ic=',2i2,2x,'mass=',e10.3
16005      *,2x,'ep=',4e10.3)
16006       return
16007       end
16008 
16009 c=============================================================================
16010       double precision function qgrot(b,s)
16011 c-----------------------------------------------------------------------------
16012 c convolution of nuclear profile functions (axial angle integration)
16013 c-----------------------------------------------------------------------------
16014       implicit double precision (a-h,o-z)
16015       integer debug
16016       common /arr8/  x2(4),a2
16017       common /qgarr43/ moniou
16018       common /qgdebug/  debug
16019 
16020       if(debug.ge.2)write (moniou,201)b,s
16021 
16022       qgrot=0.d0
16023       do i=1,4
16024        sb1=b**2+s**2-2.*b*s*(2.*x2(i)-1.)
16025        sb2=b**2+s**2-2.*b*s*(1.-2.*x2(i))
16026        qgrot=qgrot+(qgt(sb1)+qgt(sb2))
16027       enddo
16028       qgrot=qgrot*a2
16029 
16030       if(debug.ge.2)write (moniou,202)qgrot
16031 201   format(2x,'qgrot - axial angle integration of the ',
16032      *'nuclear profile function'/4x,
16033      *'impact parameter b=',e10.3,2x,'nucleon coordinate s=',e10.3)
16034 202   format(2x,'qgrot=',e10.3)
16035       return
16036       end
16037 
16038 c=============================================================================
16039       subroutine qgstr(wpi0,wmi0,wp0,wm0,ic10,ic120,ic210,ic20,jp,jt)
16040 c-----------------------------------------------------------------------------
16041 c fragmentation process for the pomeron ( quarks and antiquarks types at the
16042 c ends of the two strings are determined, energy-momentum is shared
16043 c between them and strings fragmentation is simulated )
16044 c-----------------------------------------------------------------------------
16045       implicit double precision (a-h,o-z)
16046       integer debug
16047       dimension ey(3)
16048       common /qgarr6/  pi,bm,amws
16049       common /qgarr8/  wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
16050       common /qgarr10/ am(7),ammu
16051       common /qgarr11/ b10
16052       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
16053       common /qgarr43/ moniou
16054       common /qgdebug/  debug
16055       EXTERNAL qgran
16056 
16057       if(debug.ge.2)write (moniou,201)wpi0,wmi0,wp0,wm0
16058 
16059       do i=1,3
16060        ey(i)=1.d0
16061       enddo
16062       wpi=wpi0
16063       wmi=wmi0
16064 c quark-antiquark types (1 - u, 2 - d, -1 - u~, -2 - d~); s- and d- quarks are
16065 c taken into consideration at the fragmentation step
16066       if(ic10.eq.0)then
16067        if(qgran(b10).lt.dc(2))then
16068         ic1=4
16069         ic12=-4
16070        else
16071         ic1=int(1.5+qgran(b10))
16072         ic12=-ic1
16073        endif
16074       elseif(ic10.gt.0)then
16075        ic1=ic10
16076        ic12=ic120
16077       else
16078        ic1=ic120
16079        ic12=ic10
16080       endif
16081 
16082       if(ic20.eq.0)then
16083        if(qgran(b10).lt.dc(2))then
16084         ic2=4
16085         ic21=-4
16086        else
16087         ic2=int(1.5+qgran(b10))
16088         ic21=-ic2
16089        endif
16090       elseif(ic20.gt.0)then
16091        ic2=ic20
16092        ic21=ic210
16093       else
16094        ic2=ic210
16095        ic21=ic20
16096       endif
16097 
16098 c longitudinal momenta for the strings
16099       if(jp.eq.0)then
16100        wp1=wpi*cos(pi*qgran(b10))**2
16101       else
16102 1      xp=.5d0*qgran(b10)**2
16103        if(qgran(b10).gt.(2.d0*(1.d0-xp))**(-.5d0))goto 1
16104        wp1=wpi*xp
16105        if(qgran(b10).lt..5d0)wp1=wpi-wp1
16106       endif
16107       if(jt.eq.0)then
16108        wm1=wmi*cos(pi*qgran(b10))**2
16109       else
16110 2      xm=.5d0*qgran(b10)**2
16111        if(qgran(b10).gt.(2.d0*(1.d0-xm))**(-.5d0))goto 2
16112        wm1=wmi*xm
16113        if(qgran(b10).lt..5d0)wm1=wmi-wm1
16114       endif
16115       wpi=wpi-wp1
16116       wmi=wmi-wm1
16117 c string masses
16118       sm1=wp1*wm1
16119       sm2=wpi*wmi
16120 
16121 c mass thresholds
16122       if(iabs(ic1).le.2)then
16123        am1=am(1)
16124       elseif(iabs(ic1).eq.3)then
16125        am1=am(2)
16126       elseif(iabs(ic1).eq.4)then
16127        am1=am(3)
16128       else
16129        am1=0.d0
16130        stop 'should not happen in qgstr 1 !'
16131       endif
16132       if(iabs(ic2).le.2)then
16133        am2=am(1)
16134       elseif(iabs(ic2).eq.3)then
16135        am2=am(2)
16136       elseif(iabs(ic2).eq.4)then
16137        am2=am(3)
16138       else
16139        am2=0.d0
16140        stop 'should not happen in qgstr 2 !'
16141       endif
16142       if(iabs(ic12).le.2)then
16143        am12=am(1)
16144       elseif(iabs(ic12).eq.3)then
16145        am12=am(2)
16146       elseif(iabs(ic12).eq.4)then
16147        am12=am(3)
16148       else
16149        am12=0.d0
16150        stop 'should not happen in qgstr 3 !'
16151       endif
16152       if(iabs(ic21).le.2)then
16153        am21=am(1)
16154       elseif(iabs(ic21).eq.3)then
16155        am21=am(2)
16156       elseif(iabs(ic21).eq.4)then
16157        am21=am(3)
16158       else
16159        am21=0.d0
16160        stop 'should not happen in qgstr 4 !'
16161       endif
16162 
16163 c too short strings are neglected (energy is given to partner string
16164 c or to the hadron (nucleon) to which the pomeron is connected)
16165       if(sm1.gt.am1+am21.and.sm2.gt.am2+am12)then
16166 c strings fragmentation is simulated - gener
16167        call qggene(wp1,wm1,ey,0.d0,1.d0,0.d0,1.d0,ic1,ic21)
16168        call qggene(wpi,wmi,ey,0.d0,1.d0,0.d0,1.d0,ic12,ic2)
16169       elseif((wpi+wp1)*(wmi+wm1).gt.am1+am21)then
16170        call qggene(wp1+wpi,wm1+wmi,ey,0.d0,1.d0,0.d0,1.d0,ic1,ic21)
16171       elseif((wpi+wp1)*(wmi+wm1).gt.am2+am12)then
16172        call qggene(wp1+wpi,wm1+wmi,ey,0.d0,1.d0,0.d0,1.d0,ic12,ic2)
16173       else
16174        wp0=wp0+wp1+wpi
16175        wm0=wm0+wm1+wmi
16176       endif
16177 
16178       if(debug.ge.3)write (moniou,202)wp0,wm0
16179 201   format(2x,'qgstr: wpi0=',e10.3,2x,'wmi0=',e10.3
16180      *,2x,'wp0=',e10.3,2x,'wm0=',e10.3)
16181 202   format(2x,'qgstr - returned light cone momenta:'
16182      *,2x,'wp0=',e10.3,2x,'wm0=',e10.3)
16183       return
16184       end
16185 
16186 c===========================================================================
16187       double precision function qgt(b)
16188 c---------------------------------------------------------------------------
16189 c nuclear profile function value at impact parameter squared b
16190 c---------------------------------------------------------------------------
16191       implicit double precision (a-h,o-z)
16192       integer debug
16193       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
16194      *,cr1(2),cr2(2),cr3(2)
16195       common /qgarr6/  pi,bm,amws
16196       common /arr3/   x1(7),a1(7)
16197       common /qgarr43/ moniou
16198       common /qgdebug/  debug
16199 
16200       if(debug.ge.2)write (moniou,201)b
16201 
16202       qgt=0.
16203       zm=rnuc(2)**2-b
16204       if(zm.gt.4.*b)then
16205        zm=dsqrt(zm)
16206       else
16207        zm=2.*dsqrt(b)
16208       endif
16209 
16210       do i=1,7
16211       do m=1,2
16212        z1=zm*(.5d0+x1(i)*(m-1.5d0))
16213        r=dsqrt(b+z1**2)
16214        quq=(r-rnuc(2))/wsnuc(2)
16215        if (quq.lt.85.)qgt=qgt+a1(i)/(1.+exp(quq))
16216      * *(1.d0+wbnuc(2)*(r/rnuc(2))**2)
16217       enddo
16218       enddo
16219       qgt=qgt*zm*0.5d0
16220 
16221       dt=0.
16222       do i=1,7
16223       do m=1,2
16224        z1=zm-wsnuc(2)*log(.5d0+x1(i)*(m-1.5d0))
16225        r=dsqrt(b+z1**2)
16226        quq=(r-rnuc(2)-z1+zm)/wsnuc(2)
16227        if (quq.lt.85.)dt=dt+a1(i)/(exp((zm-z1)/wsnuc(2))+exp(quq))
16228      * *(1.d0+wbnuc(2)*(r/rnuc(2))**2)
16229       enddo
16230       enddo
16231       qgt=qgt+dt*wsnuc(2)/2.d0
16232 
16233       if(debug.ge.3)write (moniou,202)qgt
16234 201   format(2x,'qgt - nuclear profile function value at impact'
16235      *,' parameter squared b=',e10.3)
16236 202   format(2x,'qgt=',e10.3)
16237       return
16238       end
16239 
16240 c=============================================================================
16241       block data qgdata
16242 c-----------------------------------------------------------------------------
16243 c constants for numerical integration (gaussian weights)
16244 c-----------------------------------------------------------------------------
16245       implicit double precision (a-h,o-z)
16246       common /arr1/ trnuc(56),twsnuc(56),twbnuc(56)
16247       common /arr3/ x1(7),a1(7)
16248       common /arr4/ x4(2),a4(2)
16249       common /arr5/ x5(2),a5(2)
16250       common /arr8/ x2(4),a2
16251       common /arr9/ x9(3),a9(3)
16252       data x1/.9862838d0,.9284349d0,.8272013d0,.6872929d0,.5152486d0,
16253      *.3191124d0,.1080549d0/
16254       data a1/.03511946d0,.08015809d0,.1215186d0,.1572032d0,
16255      *.1855384d0,.2051985d0,.2152639d0/
16256       data x2/.00960736d0,.0842652d0,.222215d0,.402455d0/
16257       data a2/.392699d0/
16258       data x4/ 0.339981,0.861136/
16259       data a4/ 0.652145,0.347855/
16260       data x5/.585786d0,3.41421d0/
16261       data a5/.853553d0,.146447d0/
16262       data x9/.93247d0,.661209d0,.238619d0/
16263       data a9/.171324d0,.360762d0,.467914d0/
16264       data trnuc/0.69d0,1.71d0,1.53d0,1.37d0,1.37d0,2.09d0,1.95d0
16265      *,1.95d0,2.06d0,1.76d0,1.67d0,1.74d0,1.66d0,2.57d0,2.334d0
16266      *,2.608d0,2.201d0,2.331d0,2.58d0,2.791d0,2.791d0,2.782d0,2.74d0
16267      *,3.192d0,3.22d0,3.05d0,3.07d0,3.34d0,3.338d0,3.252d0
16268      *,3.369d0,3.244d0,3.244d0,3.313d0,3.476d0,3.54d0,3.554d0
16269      *,3.554d0,3.743d0,3.73d0,3.744d0,3.759d0,3.774d0,3.788d0
16270      *,3.802d0,3.815d0,3.829d0,3.843d0,3.855d0,3.941d0
16271      *,3.94d0,3.984d0,4.d0,4.074d0,3.89d0,4.111d0/
16272       data twsnuc/0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0
16273      *,0.55d0,0.55d0,0.56d0,0.56d0,0.5052d0,0.498d0,0.513d0
16274      *,0.55d0,0.55d0,0.567d0,0.698d0,0.698d0,0.549d0,0.55d0
16275      *,0.604d0,0.58d0,0.523d0,0.519d0,0.58d0,0.547d0,0.553d0
16276      *,0.582d0,0.55d0,0.55d0,0.7d0,0.599d0,0.507d0,0.588d0
16277      *,0.588d0,0.585d0,0.62d0,0.55d0,0.55d0,0.55d0,0.55d0
16278      *,0.55d0,0.55d0,0.55d0,0.588d0,0.588d0
16279      *,0.566d0,0.505d0,0.542d0,0.557d0,0.536d0,0.567d0,0.558d0/
16280       data twbnuc/0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0
16281      *,0.d0,0.d0,0.d0,0.d0,-0.18d0,0.139d0,-0.051d0,0.d0,0.d0
16282      *,0.d0,-0.168d0,0.d0,0.d0,0.d0,-0.249d0,-0.236d0,0.d0,0.d0
16283      *,0.233d0,-0.203d0,-0.078d0,-0.173d0,0.d0,0.d0,0.d0,-0.1d0
16284      *,0.d0,-0.13d0,-0.13d0,-0.201d0,-0.19d0,0.d0,0.d0,0.d0,0.d0
16285      *,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0
16286      *,0.d0,0.d0/
16287       end
16288 
16289 c-----------------------------------------------------------------------
16290       real function qggamfun(x)
16291 c-----------------------------------------------------------------------
16292 c     gamma fctn
16293 c-----------------------------------------------------------------------
16294       dimension c(13)
16295       data c
16296      1/ 0.00053 96989 58808, 0.00261 93072 82746, 0.02044 96308 23590,
16297      2  0.07309 48364 14370, 0.27964 36915 78538, 0.55338 76923 85769,
16298      3  0.99999 99999 99998,-0.00083 27247 08684, 0.00469 86580 79622,
16299      4  0.02252 38347 47260,-0.17044 79328 74746,-0.05681 03350 86194,
16300      5  1.13060 33572 86556/
16301       qggamfun=0
16302       z=x
16303       if(x .gt. 0.0) goto1
16304       if(x .eq. aint(x)) goto5
16305       z=1.0-z
16306     1 f=1.0/z
16307       if(z .le. 1.0) goto4
16308       f=1.0
16309     2 continue
16310       if(z .lt. 2.0) goto3
16311       z=z-1.0
16312       f=f*z
16313       goto2
16314     3 z=z-1.0
16315     4 qggamfun=
16316      1 f*((((((c(1)*z+c(2))*z+c(3))*z+c(4))*z+c(5))*z+c(6))*z+c(7))/
16317      2   ((((((c(8)*z+c(9))*z+c(10))*z+c(11))*z+c(12))*z+c(13))*z+1.0)
16318       if(x .gt. 0.0) return
16319       qggamfun=3.141592653589793/(sin(3.141592653589793*x)*qggamfun)
16320       return
16321     5 write(*,10)x
16322    10 format(1x,'argument of gamma fctn = ',e20.5)
16323       stop
16324       end
16325 
16326 c-------------------------------------------------------------------------------
16327       subroutine qgcrossc(niter,gtot,gprod,gabs,gdd,gqel,gcoh)
16328 c-------------------------------------------------------------------------------
16329 c nucleus-nucleus (nucleus-hydrogen) interaction cross sections
16330 c gtot  - total cross section
16331 c gprod - production cross section (projectile diffraction included)
16332 c gabs  - cut pomerons cross section
16333 c gdd   - projectile diffraction cross section
16334 c gqel  - quasielastic (projectile nucleon knock-out) cross section
16335 c gcoh  - coherent (elastic with respect to the projectile) cross section
16336 c (target diffraction is not treated explicitely and contributes to
16337 c gdd, gqel, gcoh).
16338 c-------------------------------------------------------------------------------
16339       implicit double precision (a-h,o-z)
16340       parameter(iapmax=208)
16341       dimension wabs(28),wdd(28),wqel(28),wcoh(28)
16342      *,wprod(28),b0(28),ai(28),xa(iapmax,3),xb(iapmax,3)
16343       common /qgarr1/  ia(2),icz,icp
16344       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
16345      *,cr1(2),cr2(2),cr3(2)
16346       common /qgarr6/  pi,bm,amws
16347       common /qgarr11/ b10
16348       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
16349       common /arr3/   x1(7),a1(7)
16350       EXTERNAL qgran
16351 
16352       e1=exp(-1.d0)
16353 
16354       do i=1,7
16355        b0(15-i)=bm*sqrt((1.d0+x1(i))/2.d0)
16356        b0(i)=bm*sqrt((1.d0-x1(i))/2.d0)
16357        ai(i)=a1(i)*bm**2*5.d0*pi
16358        ai(15-i)=ai(i)
16359       enddo
16360 
16361       do i=1,7
16362        tp=(1.d0+x1(i))/2.d0
16363        tm=(1.d0-x1(i))/2.d0
16364        b0(14+i)=bm-log(tp)*max(wsnuc(1),wsnuc(2))
16365        b0(29-i)=bm-log(tm)*max(wsnuc(1),wsnuc(2))
16366        ai(14+i)=a1(i)*b0(14+i)/tp*10.d0*max(wsnuc(1),wsnuc(2))*pi
16367        ai(29-i)=a1(i)*b0(29-i)/tm*10.d0*max(wsnuc(1),wsnuc(2))*pi
16368       enddo
16369 
16370       do i=1,28
16371        wabs(i)=0.
16372        wdd(i)=0.
16373        wqel(i)=0.
16374        wcoh(i)=0.
16375       enddo
16376 
16377       do nc=1,niter
16378        do i=1,ia(2)
16379         iddt(i)=1+int(qgran(b10)+cc(2,2))
16380        enddo
16381 
16382        if(ia(1).eq.1)then
16383         xa(1,1)=0.d0
16384         xa(1,2)=0.d0
16385         xa(1,3)=0.d0
16386        else
16387         call qggea(ia(1),xa,1)
16388        endif
16389        if(ia(2).eq.1)then
16390         xb(1,1)=0.d0
16391         xb(1,2)=0.d0
16392         xb(1,3)=0.d0
16393        else
16394         call qggea(ia(2),xb,2)
16395        endif
16396 
16397        do i=1,28
16398         call qggcr(b0(i),gabs,gdd,gqel,gcoh,xa,xb,ia(1))
16399         wabs(i)=wabs(i)+gabs
16400         wdd(i)=wdd(i)+gdd
16401         wqel(i)=wqel(i)+gqel
16402         wcoh(i)=wcoh(i)+gcoh
16403        enddo
16404       enddo
16405 
16406       gabs=0.
16407       gdd=0.
16408       gqel=0.
16409       gcoh=0.
16410       do i=1,28
16411        wabs(i)=wabs(i)/niter
16412        wdd(i)=wdd(i)/niter
16413        wqel(i)=wqel(i)/niter
16414        wcoh(i)=wcoh(i)/niter
16415        wprod(i)=wabs(i)+wdd(i)
16416        gabs=gabs+ai(i)*wabs(i)
16417        gdd=gdd+ai(i)*wdd(i)
16418        gqel=gqel+ai(i)*wqel(i)
16419        gcoh=gcoh+ai(i)*wcoh(i)
16420       enddo
16421       gprod=gabs+gdd
16422       gtot=gprod+gqel+gcoh
16423       return
16424       end
16425 
16426 c-------------------------------------------------------------------------------
16427       subroutine qggcr(b,gabs,gdd,gqel,gcoh,xa,xb,ia)
16428 c-------------------------------------------------------------------------------
16429       implicit double precision (a-h,o-z)
16430       parameter(iapmax=208)
16431       dimension xa(iapmax,3),xb(iapmax,3),vabs(2)
16432 
16433       gabs=1.
16434       gdd=1.
16435       gqel=1.
16436       gcoh=1.
16437       do n=1,ia
16438        call qgv(xa(n,1)+b,xa(n,2),xb,vin,vdd,vabs)
16439        gabs=gabs*(vdd-vin+1.d0)          !prod_n^A [sum_i c_i exp(-2chi_i(n))]
16440        gdd=gdd*(1.-vin)                  !prod_n^A [sum_i c_i exp(-chi_i(n))]^2
16441        gqel=gqel*(2.d0*dsqrt(1.d0-vin)-1.d0)
16442                                        !prod_n^A [sum_i c_i exp(-chi_i(n)) - 1]
16443        gcoh=gcoh*dsqrt(1.d0-vin)
16444       enddo
16445       gcoh=1.-2.*gcoh+gqel
16446       gqel=gdd-gqel
16447       gdd=gabs-gdd
16448       gabs=1.-gabs
16449       return
16450       end
16451 
16452 c-------------------------------------------------------------------------------
16453       double precision function qgsect(e0n,icz,iap,iat)
16454 c-------------------------------------------------------------------------------
16455 c qgsect - hadron-nucleus (hadron-nucleus) particle production cross section
16456 c e0n - lab. energy per projectile nucleon (hadron),
16457 c icz - hadron class,
16458 c iap - projectile mass number (1=<iap<=iapmax),
16459 c iat - target mass number     (1=<iat<=iapmax)
16460 c-------------------------------------------------------------------------------
16461       implicit double precision (a-h,o-z)
16462       integer debug
16463       dimension wk(3),wa(3),wb(3)
16464       common /qgarr47/ gsect(10,5,6)
16465       common /qgarr48/ qgsasect(10,6,6)
16466       common /qgarr43/ moniou
16467       common /qgdebug/    debug
16468 
16469       if(debug.ge.3)write (moniou,201)e0n,icz,iap,iat
16470       qgsect=0.d0
16471       ye=dlog10(e0n)
16472       if(ye.lt.1.d0)ye=1.d0
16473       je=int(ye)
16474       if(je.gt.8)je=8
16475 
16476       wk(2)=ye-je
16477       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
16478       wk(1)=1.d0-wk(2)+wk(3)
16479       wk(2)=wk(2)-2.d0*wk(3)
16480 
16481       yb=iat
16482       yb=dlog(yb)/1.38629d0+1.d0
16483       jb=min(int(yb),2)
16484       wb(2)=yb-jb
16485       wb(3)=wb(2)*(wb(2)-1.d0)*.5d0
16486       wb(1)=1.d0-wb(2)+wb(3)
16487       wb(2)=wb(2)-2.d0*wb(3)
16488 
16489       if(iap.eq.1)then
16490        if(iat.eq.14)then
16491         do i=1,3
16492          qgsect=qgsect+gsect(je+i-1,icz,5)*wk(i)
16493         enddo
16494        elseif(iat.eq.40)then
16495         do i=1,3
16496          qgsect=qgsect+gsect(je+i-1,icz,6)*wk(i)
16497         enddo
16498        else
16499         do i=1,3
16500         do l=1,3
16501          qgsect=qgsect+gsect(je+i-1,icz,jb+l-1)*wk(i)*wb(l)
16502         enddo
16503         enddo
16504        endif
16505       else
16506        ya=iap
16507        ya=dlog(ya/2.d0)/.69315d0+1.d0
16508        ja=min(int(ya),4)
16509        wa(2)=ya-ja
16510        wa(3)=wa(2)*(wa(2)-1.d0)*.5d0
16511        wa(1)=1.d0-wa(2)+wa(3)
16512        wa(2)=wa(2)-2.d0*wa(3)
16513        if(iat.eq.14)then
16514         do i=1,3
16515         do m=1,3
16516          qgsect=qgsect+qgsasect(je+i-1,ja+m-1,5)*wk(i)*wa(m)
16517         enddo
16518         enddo
16519        elseif(iat.eq.40)then
16520         do i=1,3
16521         do m=1,3
16522          qgsect=qgsect+qgsasect(je+i-1,ja+m-1,6)*wk(i)*wa(m)
16523         enddo
16524         enddo
16525        else
16526         do i=1,3
16527         do m=1,3
16528         do l=1,3
16529          qgsect=qgsect+qgsasect(je+i-1,ja+m-1,jb+l-1)*wk(i)*wa(m)*wb(l)
16530         enddo
16531         enddo
16532         enddo
16533        endif
16534       endif
16535       qgsect=exp(qgsect)
16536       if(debug.ge.4)write (moniou,202)
16537 
16538 201   format(2x,'qgsect - nucleus-nucleus production cross section'
16539      */4x,'lab. energy per nucleon - ',e10.3,2x,'hadron class - ',i2
16540      */4x,'proj. mass N - ',i3,2x,'targ. mass N - ',i3)
16541 202   format(2x,'qgsect=',e10.3)
16542       return
16543       end
16544 
16545 c=============================================================================
16546       subroutine qgreg(ep0,ic)
16547 c-----------------------------------------------------------------------
16548 c qgreg - registration of produced hadron
16549 c ep0 - 4-momentum,
16550 c ic  - hadron type
16551 c-----------------------------------------------------------------------
16552       implicit double precision (a-h,o-z)
16553       integer debug
16554       parameter(nptmax=95000)
16555       dimension ep(4),ep0(4),ep1(4),ep2(4),ep3(4)
16556       common /qgarr4/  ey0(3)
16557       common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
16558       common /qgarr11/ b10
16559       common /qgarr12/ nsh
16560       common /qgarr14/ esp(4,nptmax),ich(nptmax)
16561       common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
16562       common /qgarr43/ moniou
16563       common /qgdebug/  debug
16564       external qgran
16565 
16566       if(debug.ge.3)write (moniou,201)ic,ep0,nsh
16567       nsh=nsh+1
16568       
16569       nstprev = nsh
16570 
16571       if(nsh.gt.nptmax)stop'increase nptmax!!!'
16572       iab=iabs(ic)
16573       do i=1,4
16574        ep(i)=ep0(i)
16575       enddo
16576       
16577 c       call qgtran(ep,ey0,1)
16578       
16579       if(iab.eq.7.or.iab.eq.8)then         !delta++(-)
16580        call qgdec2(ep,ep1,ep2,dmmin(2)**2,amn**2,am0**2)
16581        ich(nsh)=ic-5*ic/iab
16582        do i=1,4
16583         esp(i,nsh)=ep1(i)
16584         ep(i)=ep2(i)
16585        enddo
16586        nsh=nsh+1
16587        ich(nsh)=15*ic/iab-2*ic
16588 
16589 ctp      elseif(iab.eq.-10)then                   !rho0 -> pi+ + pi-
16590 ctp       call qgdec2(ep,ep1,ep2,dmmin(1)**2,am0**2,am0**2)
16591 ctp       ich(nsh)=2*int(.5d0+qgran(b10))-1
16592 ctp       do i=1,4
16593 ctp        esp(i,nsh)=ep1(i)
16594 ctp        ep(i)=ep2(i)
16595 ctp       enddo
16596 ctp       nsh=nsh+1
16597 ctp       ich(nsh)=-ich(nsh-1)
16598 
16599       elseif(iab.eq.11)then                  !pi* -> rho + pi
16600        am2=qgnrm(ep)
16601        call qgdec2(ep,ep1,ep2,am2,dmmin(1)**2,am0**2)
16602 ctp       call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
16603        if(qgran(b10).lt..5d0)then  !rho0 + pi+/-
16604         ich(nsh)=-10
16605         ich(nsh+1)=ic/iab
16606 ctp        ich(nsh+1)=2*int(.5d0+qgran(b10))-1
16607 ctp        ich(nsh+2)=-ich(nsh+1)
16608         do i=1,4
16609           esp(i,nsh)=ep1(i)
16610           ep(i)=ep2(i)
16611         enddo
16612         nsh=nsh+1
16613        else      !rho+/- + pi0 -> pi+/- + 2 pi0
16614         call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
16615         ich(nsh)=0
16616         ich(nsh+1)=ic/iab
16617         ich(nsh+2)=0
16618         do i=1,4
16619           esp(i,nsh)=ep2(i)
16620           esp(i,nsh+1)=ep3(i)
16621         enddo
16622         nsh=nsh+2
16623        endif
16624 ctp       do i=1,4
16625 ctp        esp(i,nsh)=ep2(i)
16626 ctp        esp(i,nsh+1)=ep3(i)
16627 ctp       enddo
16628 ctp       nsh=nsh+2
16629 
16630       elseif(iab.eq.12.or.iab.eq.13)then       !N*
16631        am2=qgnrm(ep)
16632        if(6.d0*qgran(b10).lt.1.d0)then         !delta + pi
16633         call qgdec2(ep,ep1,ep2,am2,dmmin(2)**2,am0**2)
16634         call qgdec2(ep1,ep3,ep,dmmin(2)**2,amn**2,am0**2)
16635         ich(nsh)=2*ic-25*ic/iab
16636         ich(nsh+1)=ic-10*ic/iab
16637         ich(nsh+2)=-ich(nsh)
16638         do i=1,4
16639          esp(i,nsh)=ep2(i)
16640          esp(i,nsh+1)=ep3(i)
16641         enddo
16642         nsh=nsh+2
16643        else                                    !N + pi
16644         call qgdec2(ep,ep1,ep2,am2,amn**2,am0**2)
16645         do i=1,4
16646          esp(i,nsh)=ep1(i)
16647          ep(i)=ep2(i)
16648         enddo
16649         if(qgran(b10).lt..4d0)then
16650          ich(nsh)=ic-10*ic/iab
16651          ich(nsh+1)=0
16652         else
16653          ich(nsh)=15*ic/iab-ic
16654          ich(nsh+1)=25*ic/iab-2*ic
16655         endif
16656         nsh=nsh+1
16657        endif
16658 
16659       elseif(iab.eq.14.or.iab.eq.15)then       !K1
16660        am2=qgnrm(ep)
16661        if(dsqrt(am2).gt.dmmin(1)+amk)then      !rho + K
16662         call qgdec2(ep,ep1,ep2,am2,dmmin(1)**2,amk**2)
16663 ctp        call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
16664         if(3.d0*qgran(b10).lt.1.d0)then  !rho0
16665          ich(nsh)=ic-10*ic/iab
16666          ich(nsh+1)=-10
16667 c         ich(nsh+1)=2*int(.5d0+qgran(b10))-1
16668 c         ich(nsh+2)=-ich(nsh+1)
16669          do i=1,4
16670            esp(i,nsh)=ep2(i)
16671            ep(i)=ep1(i)
16672          enddo
16673          nsh=nsh+1
16674         else                             !rho+/-
16675          call qgdec2(ep1,ep3,ep,dmmin(1)**2,am0**2,am0**2)
16676          ich(nsh)=19*ic/iab-ic
16677          ich(nsh+1)=29*ic/iab-2*ic
16678          ich(nsh+2)=0
16679          do i=1,4
16680           esp(i,nsh)=ep2(i)
16681           esp(i,nsh+1)=ep3(i)
16682          enddo
16683          nsh=nsh+2
16684         endif
16685        else                                    !K* + pi
16686         call qgdec2(ep,ep1,ep2,am2,dmmin(3)**2,am0**2)
16687         call qgdec2(ep1,ep3,ep,dmmin(3)**2,amk**2,am0**2)
16688         if(3.d0*qgran(b10).lt.1.d0)then
16689          ich(nsh)=0
16690          if(3.d0*qgran(b10).lt.1.d0)then
16691           ich(nsh+1)=ic-10*ic/iab
16692           ich(nsh+2)=0
16693          else
16694           ich(nsh+1)=19*ic/iab-ic
16695           ich(nsh+2)=29*ic/iab-2*ic
16696          endif
16697         else
16698          ich(nsh)=29*ic/iab-2*ic
16699          if(3.d0*qgran(b10).lt.1.d0)then
16700           ich(nsh+1)=19*ic/iab-ic
16701           ich(nsh+2)=0
16702          else
16703           ich(nsh+1)=ic-10*ic/iab
16704           ich(nsh+2)=2*ic-29*ic/iab
16705          endif
16706         endif
16707         do i=1,4
16708          esp(i,nsh)=ep2(i)
16709          esp(i,nsh+1)=ep3(i)
16710         enddo
16711         nsh=nsh+2
16712        endif
16713 ctp       do i=1,4
16714 ctp        esp(i,nsh)=ep2(i)
16715 ctp        esp(i,nsh+1)=ep3(i)
16716 ctp       enddo
16717 ctp       nsh=nsh+2
16718 
16719       elseif(iab.eq.5)then                     !K0,K0~
16720        ich(nsh)=10*int(.5d0+qgran(b10))-5
16721 
16722 c      elseif(iab.eq.6)then                !lambda decay (switch on in CONEX!)
16723 c       ic2=-ic/iab*int(.64d0+qgran(b10))
16724 c       ic1=3*ic/iab+ic2
16725 c       call qgdec2(ep,ep1,ep2,amlam**2,amn**2,am0**2)
16726 c       do i=1,4
16727 c        esp(i,nsh)=ep1(i)
16728 c        ep(i)=ep2(i)
16729 c       enddo
16730 c       ich(nsh)=ic1
16731 c       ich(nsh+1)=ic2
16732 c       nsh=nsh+1
16733 
16734       else
16735        ich(nsh)=ic
16736       endif
16737 
16738       do i=1,4
16739        esp(i,nsh)=ep(i)
16740       enddo
16741 
16742       do n=nstprev,nsh
16743         do i=1,4
16744           ep(i)=esp(i,n)
16745         enddo
16746         call qgtran(ep,ey0,1)
16747         do i=1,4
16748           esp(i,n)=ep(i)
16749         enddo
16750       enddo
16751 
16752       if(debug.ge.4)write (moniou,202)
16753 
16754 201   format(2x,'qgreg: ic=',i2,2x,'c.m. 4-momentum:',2x,4(e10.3,1x)/
16755      * 4x,'number of particles in the storage: ',i5)
16756 202   format(2x,'qgreg - end')
16757       return
16758       end
16759 
16760 c-----------------------------------------------------------------------------
16761       subroutine qgdec2(ep,ep1,ep2,ww,a,b)
16762 c two particle decay
16763       implicit double precision (a-h,o-z)
16764       integer debug
16765       dimension ep(4),ep1(4),ep2(4),ey(3)
16766       common /qgarr11/ b10
16767       common /qgarr43/ moniou
16768       common /qgdebug/  debug
16769       EXTERNAL qgran
16770 
16771       if(debug.ge.2)write (moniou,201)ep,ww,a,b
16772 201   format(2x,'qgdec2: 4-momentum:',2x,4(e10.3,1x)
16773      */4x,'ww=',e10.3,2x,'a=',e10.3,2x,'b=',e10.3)
16774 
16775       pl=qglam(ww,a,b)
16776       ep1(1)=dsqrt(pl+a)
16777       ep2(1)=dsqrt(pl+b)
16778       pl=dsqrt(pl)
16779       cosz=2.d0*qgran(b10)-1.d0
16780       pt=pl*dsqrt(1.d0-cosz**2)
16781       ep1(2)=pl*cosz
16782       call qgcs(c,s)
16783       ep1(3)=pt*c
16784       ep1(4)=pt*s
16785       do i=2,4
16786        ep2(i)=-ep1(i)
16787       enddo
16788       call qgdeft(ww,ep,ey)
16789       call qgtran(ep1,ey,1)
16790       call qgtran(ep2,ey,1)
16791       if(debug.ge.3)write (moniou,203)
16792 203   format(2x,'qgdec2 - end')
16793       return
16794       end
16795 
16796 c------------------------------------------------------------------------
16797       double precision function qggrv(x,qqs,icq,iq)
16798 c------------------------------------------------------------------------
16799 c qggrv - GRV structure functions
16800 c------------------------------------------------------------------------
16801       implicit double precision (a-h,o-z)
16802       common /qgarr18/ alm,qt0,qtf,betp,dgqq
16803       common /qgarr25/ ahv(3)
16804 
16805       qggrv=0.
16806       if(x.gt..99999d0.and.(qqs.ne.qt0.or.iq.ne.1.and.iq.ne.2))return
16807 
16808       if(icq.eq.2)then
16809        sq=dlog(dlog(qqs/.232d0**2)/dlog(.23d0/.232d0**2))
16810        if(iq.eq.0)then                                 !gluon
16811         alg=.524d0
16812         betg=1.088d0
16813         aag=1.742d0-.93d0*sq
16814         bbg=-.399d0*sq**2
16815         ag=7.486d0-2.185d0*sq
16816         bg=16.69d0-22.74d0*sq+5.779d0*sq*sq
16817         cg=-25.59d0+29.71d0*sq-7.296d0*sq*sq
16818         dg=2.792d0+2.215d0*sq+.422d0*sq*sq-.104d0*sq*sq*sq
16819         eg=.807d0+2.005d0*sq
16820         eeg=3.841d0+.361d0*sq
16821         qggrv=(1.d0-x)**dg*(x**aag*(ag+bg*x+cg*x**2)*log(1.d0/x)**bbg
16822      *  +sq**alg*exp(-eg+sqrt(eeg*sq**betg*log(1.d0/x))))
16823        elseif(iq.eq.1.or.iq.eq.2)then                  !u_v or d_v
16824         aau=.59d0-.024d0*sq
16825         bbu=.131d0+.063d0*sq
16826         auu=2.284d0+.802d0*sq+.055d0*sq*sq
16827         au=-.449d0-.138d0*sq-.076d0*sq*sq
16828         bu=.213d0+2.669d0*sq-.728d0*sq*sq
16829         cu=8.854d0-9.135d0*sq+1.979d0*sq*sq
16830         du=2.997d0+.753d0*sq-.076d0*sq*sq
16831         uv=auu*x**aau*(1.d0+au*x**bbu+bu*x+cu*x**1.5d0)
16832         if(qqs.ne.qt0)uv=uv*(1.d0-x)**du
16833 
16834         aad=.376d0
16835         bbd=.486d0+.062d0*sq
16836         add=.371d0+.083d0*sq+.039d0*sq*sq
16837         ad=-.509d0+3.31d0*sq-1.248d0*sq*sq
16838         bd=12.41d0-10.52d0*sq+2.267d0*sq*sq
16839         ccd=6.373d0-6.208d0*sq+1.418d0*sq*sq
16840         dd=3.691d0+.799d0*sq-.071d0*sq*sq
16841         dv=add*x**aad*(1.d0+ad*x**bbd+bd*x+ccd*x**1.5d0)
16842         if(qqs.ne.qt0)then
16843          dv=dv*(1.d0-x)**dd
16844         elseif(x.gt..99999d0)then
16845          dv=0.d0
16846         else
16847          dv=dv*(1.d0-x)**(dd-ahv(2))
16848         endif
16849         if(iq.eq.1)then                              !u_v
16850          qggrv=uv
16851         elseif(iq.eq.2)then                          !d_v
16852          qggrv=dv
16853         endif
16854 
16855        elseif(iq.eq.-3)then                           !s_sea
16856         als=.914
16857         bets=.577
16858         aas=1.798-.596*sq
16859         as=-5.548+3.669*sqrt(sq)-.616*sq
16860         bs=18.92-16.73*sqrt(sq)+5.168*sq
16861         ds=6.379-.35*sq+.142*sq*sq
16862         es=3.981+1.638*sq
16863         ees=6.402
16864         qggrv=(1.-x)**ds*sq**als/log(1./x)**aas*(1.+as*sqrt(x)
16865      *  +bs*x)*exp(-es+sqrt(ees*sq**bets*log(1./x)))
16866        elseif(iabs(iq).lt.3)then                      !u_sea or d_sea
16867         aadel=.409-.005*sq
16868         bbdel=.799+.071*sq
16869         addel=.082+.014*sq+.008*sq*sq
16870         adel=-38.07+36.13*sq-.656*sq*sq
16871         bdel=90.31-74.15*sq+7.645*sq*sq
16872         ccdel=0.
16873         ddel=7.486+1.217*sq-.159*sq*sq
16874         delv=addel*x**aadel*(1.-x)**ddel
16875      *  *(1.+adel*x**bbdel+bdel*x+ccdel*x**1.5)
16876 
16877         alud=1.451
16878         betud=.271
16879         aaud=.41-.232*sq
16880         bbud=.534-.457*sq
16881         aud=.89-.14*sq
16882         bud=-.981
16883         cud=.32+.683*sq
16884         dud=4.752+1.164*sq+.286*sq*sq
16885         eud=4.119+1.713*sq
16886         eeud=.682+2.978*sq
16887         udsea=(1.-x)**dud*(x**aaud*(aud+bud*x+cud*x**2)
16888      *  *log(1./x)**bbud+sq**alud*exp(-eud+sqrt(eeud*sq**betud
16889      *  *log(1./x))))
16890 
16891         if(iq.eq.-1)then                           !u_sea
16892          qggrv=(udsea-delv)/2.
16893         elseif(iq.eq.-2)then                       !d_sea
16894          qggrv=(udsea+delv)/2.
16895         endif
16896        else
16897         qggrv=0.
16898        endif
16899 
16900       elseif(icq.eq.1.or.icq.eq.3)then
16901        sq=dlog(dlog(qqs/.204d0**2)/dlog(.26d0/.204d0**2))
16902        if(iq.eq.1.or.iq.eq.2)then
16903         aapi=.517-.02*sq
16904         api=-.037-.578*sq
16905         bpi=.241+.251*sq
16906         dpi=.383+.624*sq
16907         anorm=1.212+.498*sq+.009*sq**2
16908         qggrv=.5*anorm*x**aapi*(1.+api*sqrt(x)+bpi*x)
16909         if(qqs.ne.qt0)qggrv=qggrv*(1.d0-x)**dpi
16910        elseif(iq.eq.0)then
16911           alfpi=.504
16912           betpi=.226
16913           aapi=2.251-1.339*sqrt(sq)
16914           api=2.668-1.265*sq+.156*sq**2
16915           bbpi=0.
16916           bpi=-1.839+.386*sq
16917           cpi=-1.014+.92*sq-.101*sq**2
16918           dpi=-.077+1.466*sq
16919           epi=1.245+1.833*sq
16920           eppi=.51+3.844*sq
16921           qggrv=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
16922      *    log(1./x)**bbpi+sq**alfpi*
16923      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
16924         elseif(iq.eq.-3)then
16925           alfpi=.823
16926           betpi=.65
16927           aapi=1.036-.709*sq
16928           api=-1.245+.713*sq
16929           bpi=5.58-1.281*sq
16930           dpi=2.746-.191*sq
16931           epi=5.101+1.294*sq
16932           eppi=4.854-.437*sq
16933           qggrv=sq**alfpi/log(1./x)**aapi*(1.-x)**dpi*
16934      *    (1.+api*sqrt(x)+bpi*x)*
16935      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x)))
16936         elseif(iabs(iq).lt.3)then
16937           alfpi=1.147
16938           betpi=1.241
16939           aapi=.309-.134*sqrt(sq)
16940           api=.219-.054*sq
16941           bbpi=.893-.264*sqrt(sq)
16942           bpi=-.593+.24*sq
16943           cpi=1.1-.452*sq
16944           dpi=3.526+.491*sq
16945           epi=4.521+1.583*sq
16946           eppi=3.102
16947           qggrv=(1.-x)**dpi*(x**aapi*(api+bpi*sqrt(x)+cpi*x)*
16948      *    log(1./x)**bbpi+sq**alfpi*
16949      *    exp(-epi+sqrt(eppi*sq**betpi*log(1./x))))
16950         else
16951           qggrv=0.
16952         endif
16953       else
16954        qggrv=0.
16955       endif
16956       return
16957       end
16958 
16959 c------------------------------------------------------------------------
16960       double precision function qgev(q1,qj,qq,xx,j,l)
16961 c------------------------------------------------------------------------
16962 c qgev - PDF evolution
16963 c-----------------------------------------------------------------------
16964       implicit double precision (a-h,o-z)
16965       common /qgarr18/ alm,qt0,qtf,betp,dgqq
16966       common /qgarr51/ epsxmn
16967       common /arr3/   x1(7),a1(7)
16968 
16969       qgev=0.d0
16970       zmax=1.d0-epsxmn
16971       zmin=xx/zmax
16972       if(zmin.ge.zmax)return
16973 
16974       if(qj.eq.qq)then
16975        do i1=1,7
16976        do m1=1,2
16977         qi=q1*(qq/q1)**(.5d0+x1(i1)*(m1-1.5d0))
16978 
16979         fz1=0.d0
16980         fz2=0.d0
16981         fz3=0.d0
16982         zmin1=max(.2d0,zmin)
16983         zmax1=min(.2d0,zmax)
16984         zmax1=min(5.d0*xx,zmax1)
16985         zmax2=min(zmin1,zmax)
16986         zmin2=max(zmax1,zmin)
16987 
16988         if(zmax1.gt.zmin)then
16989          do i=1,7
16990          do m=1,2
16991           z=xx+(zmin-xx)*((zmax1-xx)/(zmin-xx))**(.5d0+(m-1.5d0)*x1(i))
16992           do k=1,2
16993            if(j.ne.3.or.k.ne.1)then
16994             fz1=fz1+a1(i)*qgevi(q1,qi,xx/z,j,k)*qgfap(z,k,l)*(1.d0-xx/z)
16995            endif
16996           enddo
16997          enddo
16998          enddo
16999          fz1=fz1*dlog((zmax1-xx)/(zmin-xx))
17000         endif
17001         if(zmin1.lt.zmax)then
17002          do i=1,7
17003          do m=1,2
17004           z=1.d0-(1.d0-zmax)*((1.d0-zmin1)/(1.d0-zmax))
17005      *    **(.5d0+x1(i)*(m-1.5d0))
17006           do k=1,2
17007            if(j.ne.3.or.k.ne.1)then
17008             fz2=fz2+a1(i)*qgevi(q1,qi,xx/z,j,k)*qgfap(z,k,l)
17009      *      *(1.d0/z-1.d0)
17010            endif
17011           enddo
17012          enddo
17013          enddo
17014          fz2=fz2*dlog((1.d0-zmin1)/(1.d0-zmax))
17015         endif
17016         if(zmax2.gt.zmin2)then
17017          do i=1,7
17018          do m=1,2
17019           z=zmin2*(zmax2/zmin2)**(.5d0+x1(i)*(m-1.5d0))
17020           do k=1,2
17021            if(j.ne.3.or.k.ne.1)then
17022             fz3=fz3+a1(i)*qgevi(q1,qi,xx/z,j,k)*qgfap(z,k,l)
17023            endif
17024           enddo
17025          enddo
17026          enddo
17027          fz3=fz3*dlog(zmax2/zmin2)
17028         endif
17029         qgev=qgev+a1(i1)*(fz1+fz2+fz3)/qgsudx(qi,l)*qgalf(qi/alm)
17030        enddo
17031        enddo
17032        qgev=qgev*dlog(qq/q1)/4.d0*qgsudx(qq,l)
17033 
17034       else
17035        fz1=0.d0
17036        fz2=0.d0
17037        fz3=0.d0
17038        zmin1=max(.2d0,zmin)
17039        zmax1=min(.2d0,zmax)
17040        zmax1=min(5.d0*xx,zmax1)
17041        zmax2=min(zmin1,zmax)
17042        zmin2=max(zmax1,zmin)
17043 
17044        if(zmax1.gt.zmin)then
17045         do i=1,7
17046         do m=1,2
17047          z=xx+(zmin-xx)*((zmax1-xx)/(zmin-xx))**(.5d0+(m-1.5d0)*x1(i))
17048          do k=1,2
17049           if(j.ne.3)then
17050            fz1=fz1+a1(i)*qgevi(q1,qj,xx/z,j,k)*qgevi(qj,qq,z,k,l)
17051      *     *(1.d0-xx/z)
17052           elseif(k.ne.1)then
17053            fz1=fz1+a1(i)*qgevi(q1,qj,xx/z,3,2)*qgevi(qj,qq,z,3,2)
17054      *     *(1.d0-xx/z)
17055           endif
17056          enddo
17057         enddo
17058         enddo
17059         fz1=fz1*dlog((zmax1-xx)/(zmin-xx))
17060        endif
17061        if(zmin1.lt.zmax)then
17062         do i=1,7
17063         do m=1,2
17064          z=1.d0-(1.d0-zmax)*((1.d0-zmin1)/(1.d0-zmax))
17065      *   **(.5d0+x1(i)*(m-1.5d0))
17066          do k=1,2
17067           if(j.ne.3)then
17068            fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,j,k)*qgevi(qj,qq,z,k,l)
17069      *     *(1.d0/z-1.d0)
17070           elseif(k.ne.1)then
17071            fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,3,2)*qgevi(qj,qq,z,3,2)
17072      *     *(1.d0/z-1.d0)
17073           endif
17074          enddo
17075         enddo
17076         enddo
17077         fz2=fz2*dlog((1.d0-zmin1)/(1.d0-zmax))
17078        endif
17079        if(zmax2.gt.zmin2)then
17080         do i=1,7
17081         do m=1,2
17082          z=zmin2*(zmax2/zmin2)**(.5d0+x1(i)*(m-1.5d0))
17083          do k=1,2
17084           if(j.ne.3)then
17085            fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,j,k)*qgevi(qj,qq,z,k,l)
17086           elseif(k.ne.1)then
17087            fz2=fz2+a1(i)*qgevi(q1,qj,xx/z,3,2)*qgevi(qj,qq,z,3,2)
17088           endif
17089          enddo
17090         enddo
17091         enddo
17092         fz3=fz3*dlog(zmax2/zmin2)
17093        endif
17094        qgev=(fz1+fz2+fz3)/2.d0
17095       endif
17096       return
17097       end
17098 
17099 c------------------------------------------------------------------------
17100       double precision function qgevi(q1,qq,xx,m,l)
17101 c------------------------------------------------------------------------
17102 c qgevi - PDF evolution - interpolation
17103 c-----------------------------------------------------------------------
17104       implicit double precision (a-h,o-z)
17105       dimension wi(3),wj(3),wk(3)
17106       common /qgarr18/ alm,qt0,qtf,betp,dgqq
17107       common /qgarr20/ spmax
17108       common /qgarr51/ epsxmn
17109       common /qgarr52/ evk(40,40,100,3,2)
17110 
17111       qgevi=0.d0
17112       if(q1.ge..9999d0*spmax)goto 1
17113 
17114       if(xx.le..1d0)then
17115        yx=37.d0-dlog(.1d0/xx)/dlog(.1d0*spmax)*36.d0
17116        k=max(1,int(yx))
17117        k=min(k,35)
17118       elseif(xx.le..9d0)then
17119        yx=(xx-.1d0)*40.d0+37.d0
17120        k=max(37,int(yx))
17121        k=min(k,67)
17122       else
17123        yx=dlog(10.d0*(1.d0-xx))/log(10.d0*epsxmn)*31.d0+69.d0
17124        k=max(69,int(yx))
17125        k=min(k,98)
17126       endif
17127       wk(2)=yx-k
17128       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
17129       wk(1)=1.d0-wk(2)+wk(3)
17130       wk(2)=wk(2)-2.d0*wk(3)
17131 
17132       qli=log(q1)/dlog(spmax)*39.d0+1.d0
17133       qlj=log(qq/q1)/dlog(spmax/q1)*39.d0+1.d0
17134       i=max(1,int(1.0001d0*qli))
17135       i=min(i,38)
17136       wi(2)=qli-i
17137       wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
17138       wi(1)=1.d0-wi(2)+wi(3)
17139       wi(2)=wi(2)-2.d0*wi(3)
17140 
17141       j=max(1,int(1.0001d0*qlj))
17142       j=min(j,38)
17143       wj(2)=qlj-j
17144       wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
17145       wj(1)=1.d0-wj(2)+wj(3)
17146       wj(2)=wj(2)-2.d0*wj(3)
17147 
17148       do i1=1,3
17149       do j1=1,3
17150       do k1=1,3
17151        k2=k+k1-1
17152        qgevi=qgevi+evk(i+i1-1,j+j1-1,k2,m,l)*wi(i1)*wj(j1)*wk(k1)
17153       enddo
17154       enddo
17155       enddo
17156 1     qgevi=exp(qgevi)*qgfap(xx,m,l)
17157       if(m.eq.1.and.l.eq.1.or.m.ne.1.and.l.ne.1)then
17158        qgevi=qgevi/4.5d0/qgsudx(q1,m)*qgsudx(qq,m)
17159      * *dlog(dlog(qq/alm)/dlog(q1/alm))
17160       else
17161        qgevi=qgevi*.3d0/(dlog(epsxmn)+.75d0)
17162      * *(qgsudx(qq,1)/qgsudx(q1,1)-qgsudx(qq,2)/qgsudx(q1,2))
17163       endif
17164       return
17165       end
17166 
17167 c------------------------------------------------------------------------
17168       double precision function qgpdf(xx,qq,icz,jj)
17169 c-----------------------------------------------------------------------
17170 c qgpdf - parton distribution function for proton
17171 c qq  - virtuality scale,
17172 c xx  - light cone x,
17173 c icz - hadron type,
17174 c jj  - parton type (0 - gluon, 1 - u_v, 2 - d_v, -1 - q_sea)
17175 c-----------------------------------------------------------------------
17176       implicit double precision (a-h,o-z)
17177       common /qgarr6/  pi,bm,amws
17178       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
17179       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
17180       common /qgarr18/ alm,qt0,qtf,betp,dgqq
17181       common /qgarr25/ ahv(3)
17182       common /qgarr51/ epsxmn
17183       common /arr3/   x1(7),a1(7)
17184 
17185       if(jj.eq.0)then
17186        qgpdf=qggpdf(xx,icz)
17187       elseif(jj.eq.1.or.jj.eq.2)then
17188        qgpdf=qggrv(xx,qt0,icz,jj)*(1.d0-xx)**ahv(icz)
17189       else
17190        qgpdf=qgspdf(xx,icz)
17191       endif
17192       qgpdf=qgpdf*qgsudx(qq,iabs(jj)+1)/qgsudx(qt0,iabs(jj)+1)
17193 
17194       xmin=xx/(1.d0-epsxmn)
17195       if(xmin.lt.1.d0.and.qq.gt.qt0)then
17196        dpd1=0.d0
17197        dpd2=0.d0
17198        xm=max(xmin,.3d0)
17199        do i=1,7         !numerical integration over zx
17200        do m=1,2
17201         zx=1.d0-(1.d0-xm)*(.5d0+(m-1.5d0)*x1(i))**.25d0
17202         z=xx/zx
17203 
17204         gl=qggpdf(zx,icz)
17205         uv=qggrv(zx,qt0,icz,1)*(1.d0-zx)**ahv(icz)
17206         dv=qggrv(zx,qt0,icz,2)*(1.d0-zx)**ahv(icz)
17207         sea=qgspdf(zx,icz)
17208         if(jj.eq.0)then
17209          fz=qgevi(qt0,qq,z,1,1)*gl+qgevi(qt0,qq,z,2,1)*(uv+dv+sea)
17210         elseif(jj.eq.1)then
17211          fz=qgevi(qt0,qq,z,3,2)*uv
17212         elseif(jj.eq.2)then
17213          fz=qgevi(qt0,qq,z,3,2)*dv
17214         else
17215          akns=qgevi(qt0,qq,z,3,2)              !nonsinglet contribution
17216          aks=(qgevi(qt0,qq,z,2,2)-akns)        !singlet contribution
17217          fz=(qgevi(qt0,qq,z,1,2)*gl+aks*(uv+dv+sea)+akns*sea)
17218         endif
17219         dpd1=dpd1+a1(i)*fz/zx**2/(1.d0-zx)**3
17220        enddo
17221        enddo
17222        dpd1=dpd1*(1.d0-xm)**4/8.d0*xx
17223 
17224        if(xm.gt.xmin)then
17225         do i=1,7         !numerical integration
17226         do m=1,2
17227          zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))**(.5d0-(m-1.5d0)*x1(i))
17228          z=xx/zx
17229 
17230          gl=qggpdf(zx,icz)
17231          uv=qggrv(zx,qt0,icz,1)*(1.d0-zx)**ahv(icz)
17232          dv=qggrv(zx,qt0,icz,2)*(1.d0-zx)**ahv(icz)
17233          sea=qgspdf(zx,icz)
17234          if(jj.eq.0)then
17235           fz=qgevi(qt0,qq,z,1,1)*gl+qgevi(qt0,qq,z,2,1)*(uv+dv+sea)
17236          elseif(jj.eq.1)then
17237           fz=qgevi(qt0,qq,z,3,2)*uv
17238          elseif(jj.eq.2)then
17239           fz=qgevi(qt0,qq,z,3,2)*dv
17240          else
17241           akns=qgevi(qt0,qq,z,3,2)              !nonsinglet contribution
17242           aks=(qgevi(qt0,qq,z,2,2)-akns)        !singlet contribution
17243           fz=(qgevi(qt0,qq,z,1,2)*gl+aks*(uv+dv+sea)+akns*sea)
17244          endif
17245          dpd2=dpd2+a1(i)*fz*(1.d0-xx/zx)/zx
17246         enddo
17247         enddo
17248         dpd2=dpd2*dlog((xm-xx)/(xmin-xx))*.5d0*xx
17249        endif
17250        qgpdf=qgpdf+dpd2+dpd1
17251       endif
17252       return
17253       end
17254 
17255 c------------------------------------------------------------------------
17256       double precision function qgpdfd(xx,xpomr,qq,icz)
17257 c-----------------------------------------------------------------------
17258 c qgpdfd - diffractive sf f2_d^(3)
17259 c qq    - virtuality scale,
17260 c xx    - parton light cone x,
17261 c xpomr - pomeron lc x,
17262 c icz   - hadron type
17263 c-----------------------------------------------------------------------
17264       implicit double precision (a-h,o-z)
17265       common /qgarr6/  pi,bm,amws
17266       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
17267       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
17268       common /qgarr18/ alm,qt0,qtf,betp,dgqq
17269       common /qgarr25/ ahv(3)
17270       common /qgarr51/ epsxmn
17271       common /arr3/   x1(7),a1(7)
17272 
17273       qgpdfd=(qgdpdf(xx,xpomr,icz,1)+qgdpdf(xx,xpomr,icz,2))
17274      **qgsudx(qq,2)/qgsudx(qt0,2)
17275       xmin=xx/(1.d0-epsxmn)
17276       if(xmin.lt.xpomr.and.qq.gt.qt0)then
17277        dpd1=0.d0
17278        dpd2=0.d0
17279        xm=max(xmin,.3d0)
17280        if(xm.lt.xpomr)then
17281         do i=1,7         !numerical integration over zx
17282         do m=1,2
17283          zx=1.d0-(1.d0-xm)*(1.d0-(.5d0+(m-1.5d0)*x1(i))
17284      *   *(1.d0-((1.d0-xpomr)/(1.d0-xm))**4))**.25d0
17285          z=xx/zx
17286 
17287          glu=(qgdgdf(zx,xpomr,icz,1)+qgdgdf(zx,xpomr,icz,2))/4.5d0
17288          sea=qgdpdf(zx,xpomr,icz,1)+qgdpdf(zx,xpomr,icz,2)
17289          fz=qgevi(qt0,qq,z,1,2)*glu+qgevi(qt0,qq,z,2,2)*sea
17290          dpd1=dpd1+a1(i)*fz/zx**2/(1.d0-zx)**3
17291         enddo
17292         enddo
17293         dpd1=dpd1*((1.d0-xm)**4-(1.d0-xpomr)**4)/8.d0*xx
17294        endif
17295 
17296        xm=min(xm,xpomr)
17297        if(xm.gt.xmin)then
17298         do i=1,7         !numerical integration
17299         do m=1,2
17300          zx=xx+(xm-xx)*((xmin-xx)/(xm-xx))**(.5d0-(m-1.5d0)*x1(i))
17301          z=xx/zx
17302 
17303          glu=(qgdgdf(zx,xpomr,icz,1)+qgdgdf(zx,xpomr,icz,2))/4.5d0
17304          sea=qgdpdf(zx,xpomr,icz,1)+qgdpdf(zx,xpomr,icz,2)
17305          fz=qgevi(qt0,qq,z,1,2)*glu+qgevi(qt0,qq,z,2,2)*sea
17306          dpd2=dpd2+a1(i)*fz*(1.d0-xx/zx)/zx
17307         enddo
17308         enddo
17309         dpd2=dpd2*dlog((xm-xx)/(xmin-xx))*.5d0*xx
17310        endif
17311        qgpdfd=qgpdfd+dpd2+dpd1
17312       endif
17313       return
17314       end
17315 
17316 c------------------------------------------------------------------------
17317       double precision function qgf2c(xx,qq,icz)
17318 c-----------------------------------------------------------------------
17319 c qgf2c - c-quark contribution to f2
17320 c qq  - virtuality scale,
17321 c xx  - light cone x,
17322 c icz - hadron type,
17323 c-----------------------------------------------------------------------
17324       implicit double precision (a-h,o-z)
17325       common /arr3/   x1(7),a1(7)
17326 
17327       qgf2c=0.d0
17328       qcmass=1.3d0
17329       s2min=4.*qcmass**2+qq
17330       xmin=s2min*xx/qq
17331 
17332       if(xmin.lt.1.d0)then
17333        do i=1,7          !numerical integration over z1
17334        do m=1,2
17335         z1=xmin**(.5d0+x1(i)*(m-1.5d0))
17336         sdc=qgdbor(qq,xx/z1,qcmass**2)
17337         glu=qgpdf(z1,s2min-qq,icz,0)
17338         qgf2c=qgf2c+a1(i)*sdc*glu
17339        enddo
17340        enddo
17341        qgf2c=-qgf2c*dlog(xmin)*.5d0
17342       endif
17343       return
17344       end
17345 
17346 c------------------------------------------------------------------------
17347       double precision function qgf2cd(xx,xpomr,qq,icz)
17348 c-----------------------------------------------------------------------
17349 c qgf2cd - c-quark contribution to diffractive sf
17350 c qq  - virtuality scale,
17351 c xx  - light cone x,
17352 c icz - hadron type,
17353 c-----------------------------------------------------------------------
17354       implicit double precision (a-h,o-z)
17355       common /arr3/   x1(7),a1(7)
17356 
17357       qgf2cd=0.d0
17358       qcmass=1.3d0
17359       s2min=4.*qcmass**2+qq
17360       xmin=s2min*xx/qq
17361 
17362       if(xmin.lt.xpomr)then
17363        do i=1,7          !numerical integration over z1
17364        do m=1,2
17365         z1=xpomr*(xmin/xpomr)**(.5d0+x1(i)*(m-1.5d0))
17366         sdc=qgdbor(qq,xx/z1,qcmass**2)
17367         glu=qgdgdf(z1,xpomr,icz,1)+qgdgdf(z1,xpomr,icz,2)
17368         qgf2cd=qgf2cd+a1(i)*sdc*glu
17369        enddo
17370        enddo
17371        qgf2cd=qgf2cd*dlog(xpomr/xmin)*.5d0
17372       endif
17373       return
17374       end
17375 
17376 c------------------------------------------------------------------------
17377       double precision function qgdbor(qq,zz,q2mass)
17378 c-----------------------------------------------------------------------
17379 c qgdbor - DIS c-quark cross-section
17380 c qq      - photon virtuality
17381 c s=2(pq) - s_true + qq,
17382 c-----------------------------------------------------------------------
17383       implicit double precision (a-h,o-z)
17384       common /qgarr18/ alm,qt0,qtf,betp,dgqq
17385 
17386       qgdbor=0.
17387       qtq=4.d0*q2mass*zz/qq/(1.d0-zz)
17388       if(qtq.ge.1.d0)return
17389       bet=dsqrt(1.d0-qtq)
17390 
17391       qgdbor=qgalf(4.d0*q2mass/alm)/2.25d0*zz
17392      **(dlog((1.d0+bet)/(1.d0-bet))*(1.d0-2.d0*zz*(1.d0-zz)
17393      *-8.d0*(zz*q2mass/qq)**2+4.d0*zz*(1.d0-3.d0*zz)*q2mass/qq)
17394      *+bet*(-1.d0-4.d0*zz*(1.d0-zz)*q2mass/qq+8.d0*zz*(1.d0-zz)))
17395       return
17396       end
17397 
17398 c=============================================================================
17399       double precision function qgjeto(qi,qj,s,iq1,iq2)
17400 c-----------------------------------------------------------------------------
17401 c qgjeto - hard 2->2 parton scattering born cross-section
17402 c s is the c.m. energy square for the scattering process,
17403 c iq1 - parton type at current end of the ladder (0 - g, 1,2 etc. - q)
17404 c iq2 - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q)
17405 c-----------------------------------------------------------------------------
17406       implicit double precision (a-h,o-z)
17407       integer debug
17408       common /qgarr6/  pi,bm,amws
17409       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
17410       common /qgarr18/ alm,qt0,qtf,betp,dgqq
17411       common /qgarr26/ factk,fqscal
17412       common /qgarr43/ moniou
17413       common /qgarr51/ epsxmn
17414       common /qgdebug/    debug
17415       common /arr3/     x1(7),a1(7)
17416 
17417       if(debug.ge.2)write (moniou,201)qi,qj,s,iq1,iq2
17418 
17419       qgjeto=0.d0
17420       qq=max(qi,qj)
17421 
17422       zmin=qq*fqscal*4.d0/s
17423       zmax=1.d0-epsxmn
17424       if(zmin.ge.zmax)return
17425 
17426       dpx1=0.d0
17427       zmin1=min(.2d0,1.d0-zmin)
17428       do i1=1,7
17429       do m1=1,2
17430        z=1.d0-epsxmn*(zmin1/epsxmn)**(.5d0+x1(i1)*(m1-1.5d0))
17431 
17432        si=z*s
17433        fb=qgjeti(qi,qj,si,z,1.d0,iq1,iq2,1)
17434        dpx1=dpx1+a1(i1)*fb*(1.d0-z)
17435       enddo
17436       enddo
17437       dpx1=dpx1*dlog(zmin1/epsxmn)
17438 
17439       dpx2=0.d0
17440       if(zmin.lt..8d0)then
17441        zmin1=zmin**(-delh)
17442        zmax1=.8d0**(-delh)
17443        do i1=1,7
17444        do m1=1,2
17445         z=(.5d0*(zmax1+zmin1+(zmax1-zmin1)*x1(i1)*(2*m1-3)))
17446      *  **(-1.d0/delh)
17447 
17448         si=z*s
17449         fb=qgjeti(qi,qj,si,z,1.d0,iq1,iq2,1)
17450         dpx2=dpx2+a1(i1)*fb*z**(1.d0+delh)
17451        enddo
17452        enddo
17453        dpx2=dpx2*(zmin1-zmax1)/delh
17454       endif
17455       qgjeto=(dpx1+dpx2)/qgsudx(qj,iabs(iq2)+1)*pi**3
17456 
17457       if(debug.ge.3)write (moniou,202)qgjeto
17458 201   format(2x,'qgjeto: qi=',e10.3,2x,'qj=',e10.3,2x,
17459      *'s= ',e10.3,2x,'iq1= ',i1,2x,'iq2= ',i1)
17460 202   format(2x,'qgjeto=',e10.3)
17461       return
17462       end
17463 
17464 c=============================================================================
17465       double precision function qgjett(qi,qj,s,iq1,iq2)
17466 c-----------------------------------------------------------------------------
17467 c qgjett - hard 2->2 parton scattering born cross-section
17468 c s is the c.m. energy square for the scattering process,
17469 c iq1 - parton type at current end of the ladder (0 - g, 1,2 etc. - q)
17470 c iq2 - parton type at opposite end of the ladder (0 - g, 1,2 etc. - q)
17471 c-----------------------------------------------------------------------------
17472       implicit double precision (a-h,o-z)
17473       integer debug
17474       common /qgarr6/  pi,bm,amws
17475       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
17476       common /qgarr18/ alm,qt0,qtf,betp,dgqq
17477       common /qgarr26/ factk,fqscal
17478       common /qgarr43/ moniou
17479       common /qgarr51/ epsxmn
17480       common /qgdebug/    debug
17481       common /arr3/     x1(7),a1(7)
17482 
17483       if(debug.ge.2)write (moniou,201)qi,qj,s,iq1,iq2
17484 
17485       qgjett=0.d0
17486       qq=max(qi,qj)
17487 
17488       zmin=qq*fqscal*4.d0/s
17489       zmax=(1.d0-epsxmn)**2
17490       if(zmin.ge.zmax)return
17491       zmin1=zmin**(-delh)
17492       zmax1=zmax**(-delh)
17493       do i1=1,7
17494       do m1=1,2
17495        z=(.5d0*(zmax1+zmin1+(zmax1-zmin1)*x1(i1)*(2*m1-3)))
17496      * **(-1.d0/delh)
17497 
17498        si=z*s
17499        fb1=0.d0
17500        zmin2=min(.2d0,1.d0-dsqrt(z))
17501        do i2=1,7
17502        do m2=1,2
17503         z1=1.d0-epsxmn*(zmin2/epsxmn)**(.5d0+x1(i2)*(m2-1.5d0))
17504         z2=z/z1
17505 
17506         fb1=fb1+a1(i2)*(qgjeti(qi,qj,si,z1,z2,iq1,iq2,2)
17507      *  +qgjeti(qi,qj,si,z2,z1,iq1,iq2,2))*(1.d0/z1-1.d0)
17508        enddo
17509        enddo
17510        fb1=fb1*dlog(zmin2/epsxmn)
17511 
17512        fb2=0.d0
17513        if(z.lt..64d0)then
17514         do i2=1,7
17515         do m2=1,2
17516          z1=.8d0*(dsqrt(z)/.8d0)**(.5d0+x1(i2)*(m2-1.5d0))
17517           z2=z/z1
17518 
17519          fb2=fb2+a1(i2)*(qgjeti(qi,qj,si,z1,z2,iq1,iq2,2)
17520      *   +qgjeti(qi,qj,si,z2,z1,iq1,iq2,2))
17521         enddo
17522         enddo
17523         fb2=fb2*dlog(.64d0/z)/2.d0
17524        endif
17525 
17526        qgjett=qgjett+a1(i1)*(fb1+fb2)*z**(1.d0+delh)
17527       enddo
17528       enddo
17529       qgjett=qgjett*(zmin1-zmax1)/delh*pi**3/2.d0
17530 
17531       if(debug.ge.3)write (moniou,202)qgjett
17532 201   format(2x,'qgjett: qi=',e10.3,2x,'qj=',e10.3,2x,
17533      *'s= ',e10.3,2x,'iq1= ',i1,2x,'iq2= ',i1)
17534 202   format(2x,'qgjett=',e10.3)
17535       return
17536       end
17537 
17538 c=============================================================================
17539       double precision function qgjeti(qi,qj,si,z1,z2,iq1,iq2,jj)
17540       implicit double precision (a-h,o-z)
17541       integer debug
17542       common /qgarr18/ alm,qt0,qtf,betp,dgqq
17543       common /qgarr26/ factk,fqscal
17544       common /qgarr43/ moniou
17545       common /qgarr51/ epsxmn
17546       common /qgdebug/    debug
17547       common /arr3/     x1(7),a1(7)
17548 
17549       qgjeti=0.d0
17550       qq=max(qi,qj)
17551       tmin=qq*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qq*fqscal/si)))
17552       if(tmin.ge.si/2.d0)return
17553       do i=1,7
17554       do m=1,2
17555        t=2.d0*tmin/(1.d0+2.d0*tmin/si
17556      *   -x1(i)*(2*m-3)*(1.d0-2.d0*tmin/si))
17557        qt=t*(1.d0-t/si)
17558 
17559        fb=0.d0
17560        if(jj.eq.1)then
17561         do iql=1,2
17562          iq=2*iql-2
17563          dfb=0.d0
17564          do n=1,3
17565           dfb=dfb+qgfbor(si,t,iq,iq2,n)+qgfbor(si,si-t,iq,iq2,n)
17566          enddo
17567          if(iq.eq.iq2)dfb=dfb/2.d0
17568          fb=fb+dfb*qgevi(qi,qt/fqscal,z1,iabs(iq1)+1,iql)
17569         enddo
17570         fb=fb*qgsudx(qt/fqscal,iabs(iq2)+1)
17571        else
17572         do iql=1,2
17573          iq=2*iql-2
17574         do iqr=1,2
17575          dfb=0.d0
17576          do n=1,3
17577           dfb=dfb+qgfbor(si,t,iq,iqr-1,n)+qgfbor(si,si-t,iq,iqr-1,n)
17578          enddo
17579          if(iq.eq.iqr-1)dfb=dfb/2.d0
17580          fb=fb+dfb*qgevi(qi,qt/fqscal,z1,iabs(iq1)+1,iql)
17581      *   *qgevi(qj,qt/fqscal,z2,iabs(iq2)+1,iqr)
17582         enddo
17583         enddo
17584        endif
17585 
17586        qgjeti=qgjeti+a1(i)*fb*qgalf(qt/fqscal/alm)**2*t**2
17587       enddo
17588       enddo
17589       qgjeti=qgjeti*(1.d0/tmin-2.d0/si)/si**2
17590       return
17591       end
17592 
17593 c=============================================================================
17594       double precision function qgptj(s,pt,y0,sigin)
17595       implicit double precision (a-h,o-z)
17596       integer debug
17597       common /qgarr6/  pi,bm,amws
17598       common /qgarr18/ alm,qt0,qtf,betp,dgqq
17599       common /qgarr26/ factk,fqscal
17600       common /qgarr43/ moniou
17601       common /qgarr51/ epsxmn
17602       common /qgdebug/    debug
17603       common /arr3/     x1(7),a1(7)
17604 
17605       qgptj=0.d0
17606       zmin=4.d0*pt**2/s
17607       xt=2.d0*pt*exp(y0)/dsqrt(s)
17608       zmax=min(1.d0,xt**2/(2.d0*xt-zmin))
17609       if(zmax.le.zmin)return
17610 
17611       qq=pt**2/fqscal
17612       do i1=1,7
17613       do m1=1,2
17614        z=zmax*(zmin/zmax)**(.5d0+x1(i1)*(m1-1.5d0))
17615        si=z*s
17616        t=2.d0*pt**2/(1.d0+dsqrt(max(0.d0,1.d0-zmin/z)))
17617 
17618        xmax=min(1.d0,xt/(1.d0+dsqrt(max(0.d0,1.d0-zmin/z))))
17619        xmin=max(z,xmax*exp(-2.d0*y0))
17620        do i2=1,7
17621        do m2=1,2
17622         xp=xmax*(xmin/xmax)**(.5d0+x1(i2)*(m2-1.5d0))
17623         xm=z/xp
17624 
17625         glu1=qgpdf(xp,qq,2,0)
17626         glu2=qgpdf(xm,qq,2,0)
17627         seav2=qgpdf(xm,qq,2,-1)+qgpdf(xm,qq,2,1)+qgpdf(xm,qq,2,2)
17628 
17629         qgptj=qgptj+a1(i1)*a1(i2)*(qgptjb(si,pt**2,t,1)*glu1*glu2
17630      *  +qgptjb(si,pt**2,t,2)*glu1*seav2)
17631      *  *dlog(xmax/xmin)/(1.d0-2.d0*t/si)
17632        enddo
17633        enddo
17634       enddo
17635       enddo
17636       qgptj=qgptj*dlog(zmax/zmin)*pi**3*.39d0/sigin  *2.  !2 jets
17637       return
17638       end
17639 
17640 c=============================================================================
17641       double precision function qgptjb(si,qt,t,jj)
17642       implicit double precision (a-h,o-z)
17643       integer debug
17644       common /qgarr18/ alm,qt0,qtf,betp,dgqq
17645       common /qgarr26/ factk,fqscal
17646       common /qgarr43/ moniou
17647       common /qgdebug/    debug
17648 
17649       if(jj.eq.1)then
17650        qgptjb=qgfbor(si,t,0,0,1)
17651       else       !if(jj.eq.2)then
17652        qgptjb=qgfbor(si,t,0,1,1)
17653       endif
17654       qgptjb=qgptjb*qgalf(qt/fqscal/alm)**2/si**2
17655       return
17656       end