Project CMSSW displayed by LXR CMSSW_15_0_X_2024-12-08-2300/​GeneratorInterface/​ReggeGribovPartonMCInterface/​src/​qgsjet-II-04.f	Source navigation Diff markup Identifier search General search
	Version: CMSSW_15_0_X_2024-12-09-2300 CMSSW_15_0_X_2024-12-08-2300 CMSSW_15_0_X_2024-12-06-2300 CMSSW_15_0_X_2024-12-05-2300 CMSSW_15_0_X_2024-12-04-2300 CMSSW_15_0_X_2024-12-03-2300 CMSSW_15_0_X_2024-12-02-2300 Revert   Change

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

 C======================================================================C
 C                                                                      C
 C     QQQ        GGG      SSSS    JJJJJJJ   EEEEEEE   TTTTTTT     I I  C
 C    Q   Q      G   G    S    S         J   E            T        I I  C
 C   Q     Q    G         S              J   E            T        I I  C
 C   Q     Q    G   GGG    SSSS          J   EEEEE        T    ==  I I  C
 C   Q   Q Q    G     G        S         J   E            T        I I  C
 C    Q   Q      G   G    S    S    J   J    E            T        I I  C
 C     QQQQQ      GGG      SSSS      JJJ     EEEEEEE      T        I I  C
 C                                                                      C
 C                                                                      C
 C----------------------------------------------------------------------C
 C                                                                      C
 C                  QUARK - GLUON - STRING - JET - II MODEL             C
 C                                                                      C
 C                HIGH ENERGY HADRON INTERACTION PROGRAM                C
 C                                                                      C
 C                                  BY                                  C
 C                                                                      C
 C                           S. OSTAPCHENKO                             C
 C                                                                      C
 C Institute for Physics, Norwegian University for Science & Tech       C
 C D.V. Skobeltsyn Institute of Nuclear Physics, Moscow State UniversityC
 C                  e-mail: sergei@tf.phys.ntnu.no                      C
 C----------------------------------------------------------------------C
 C         Publication to be cited when using this program:             C
 C         S. Ostapchenko, Phys. Rev. D 83 (2011) 014018                C
 C----------------------------------------------------------------------C
 C                        LIST OF MODIFICATIONS                         C
 C                                                                      C
 C (Any modification of this program has to be approved by the author)  C
 C                                                                      C
 C 24.01.2005 - beta-version completed (qgsjet-II-01)                   C
 C 12.04.2005 - final version (qgsjet-II-02)                            C
 C 12.12.2005 - technical update -  version II-03:                      C
 C    improved treatment of Pomeron cuts (all "net" cuts included);     C
 C    improved treatment of nuclear config. (more consistent diffr.);   C
 C    "baryon junction" mechanism included (motivated by RHIC data);    C
 C    better parameter calibration, e.g. including RHIC data            C
 C 21.02.2006 - some commons enlarged to avoid frequent rejects  D.H.   C
 C 26.04.2006 - reduce unnecessary looping in qgsha              D.H.   C
 C                                                                      C
 C 01.10.2010 - new version  (qgsjet-II-04, not released):              C
 C   treating all enhanced diagrams (incuding 'Pomeron loops');         C
 C   calibration to LHC data on multiparticle production;               C
 C   a number of cosmetic improvements,                                 C
 C   e.g. more efficient simulation procedure (a factor of ~10 win)     C
 C                                                                      C
 C 26.06.2012 - final version (qgsjet-II-04):                           C
 C additional parameter retuning applied                                C
 C (mainly to TOTEM data on total/elastic pp cross sections);           C
 C remnant treatment for pion-hadron/nucleus collisions improved        C
 C                                                                      C
 C                 last modification:  26.06.2012                       C
 C                 Version qgsjet-II-04 (for CONEX)                     C
 C                                                                      C
 C small corrections to adapt to CORSIKA : 25.07.2012 by T.Pierog       C
 C=======================================================================
 
 
 
 c=============================================================================
       subroutine qgset
 c-----------------------------------------------------------------------------
 c common model parameters setting
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       character*7 ty
       character*2 tyq
       parameter(iapmax=208)
       common /qgarr1/  ia(2),icz,icp
       common /qgarr2/  scm,wp0,wm0
       common /qgarr3/  rmin,emax,eev
       common /qgarr6/  pi,bm,amws
       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
       common /qgarr8/  wwm,be(4),dc(5),deta,almpt,ptdif,ptndi
       common /qgarr10/ am0,amn,amk,amc,amlamc,amlam,ameta,ammu
       common /qgarr11/ b10
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr19/ ahl(3)
       common /qgarr20/ spmax
       common /qgarr21/ dmmin(3),wex(3),dmres(3),wdres(3)
       common /qgarr28/ arr(5)
       common /qgarr26/ factk,fqscal
       common /qgarr41/ ty(6)
       common /qgarr42/ tyq(16)
       common /qgarr43/ moniou
       common /qgarr51/ epsxmn
       common /opt/     jopt
       common /qgdebug/ debug
       common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3)  !used to link with nexus
      *,bqgs,bmaxqgs,bmaxnex,bminnex
 
       moniou=6             !output channel for debugging
       debug=0              !debugging level
                            !(0 - no debugging, 1 - very geheral,
                            !2 - more detailed, 3 - all function calls,
                            !4 - all returned values, 5 - technical)
       if(debug.ge.1)write (moniou,210)
 
       bqgs=0.d0            !used to link with nexus
       bmaxqgs=0.d0         !used to link with nexus
       bmaxnex=-1.d0        !used to link with nexus
       bminnex=0.d0         !used to link with nexus
 
       jopt=1               !parameter option
 
       if(jopt.eq.1)then       !tunable parameters
 c soft Pomeron parameters
        dels=.165d0            !overcriticality
        alfp=.135d0            !trajectory slope
        sigs=1.01d0            !soft parton cross section
 c coupling to DGLAP
        qt0=3.d0               !q**2 cutoff
        betp=2.2d0             !gluon distribution hardness for soft Pomeron
        dgqq=.16d0             !sea quark/gluon relative weight
 c multi-Pomeron vertex parameters
        r3p=.0076d0            !triple-Pomeron coupling (/4/pi)
        g3p=.35d0              !factor for multu-Pomeron couplings
        sgap=exp(1.5d0)        !minimal rap-gap between 3P-vertices
 c Pomeron-hadron coupling
        rq(1,1)=1.d0           !pion: vertex slope for 1st diffr. eigenst.
        rq(2,1)=.15d0          !pion: vertex slope for 2nd diffr. eigenst.
        cd(1,1)=1.75d0         !pion: relat. strenth for 1st diffr. eigenst.
        rq(1,2)=2.52d0         !proton: vertex slope for 1st diffr. eigenst.
        rq(2,2)=.2d0           !proton: vertex slope for 2nd diffr. eigenst.
        cd(1,2)=1.58d0         !proton: relat. strenth for 1st diffr. eigenst.
        rq(1,3)=.75d0          !kaon: vertex slope for 1st diffr. eigenst.
        rq(2,3)=.15d0          !kaon: vertex slope for 2nd diffr. eigenst.
        cd(1,3)=1.75d0         !kaon: relat. strenth for 1st diffr. eigenst.
 
 c parameters for soft/hard fragmentation:
 
        qtf=.15d0              !q**2 cutoff for timelike cascades
        almpt=1.5d0            !string fragmentation parameter
        wwm=1.d0               !switching to 2-particle string decay (threshold)
 c leading state exponents
        ahl(1)=0.d0            !pion
        ahl(2)=1.3d0           !proton
        ahl(3)=-0.5            !kaon
 c remnant excitation probabilities
        wex(1)=.5d0            !pion
        wex(2)=.4d0            !proton
        wex(3)=.5d0            !kaon
 c dc(i) - relative probabilities for qq~(qqq~q~)-pair creation from vacuum
        dc(1)=.077d0           !udu~d~
        dc(2)=.08d0            !ss~
        dc(4)=.4d0             !ss~ (intrinsic)
 c be(i) - parameters for pt-distributions
        be(1)=.225d0           !uu~(dd~)
        be(2)=.43d0            !qqq~q~
        be(3)=.48d0            !ss~
        ptdif=.15d0            !diffractive momentum transfer
        ptndi=.19d0            !non-diffractive momentum transfer
 
 c parameters for nuclear spectator part fragmentation:
 
        rmin=3.35d0    !coupling radius squared (fm^2)
        emax=.11d0     !relative critical energy ( / <E_ex>, <E_ex>~12.5 MeV )
        eev=.25d0      !relative evaporation energy ( / <E_ex>, <E_ex>~12.5 MeV )
 
       else
        stop'wrong option!!!'
       endif
 
       do i=1,3         !relative strenth of 2nd diffr. eigenst. [2-CD(1,icz)]
        cd(2,i)=2.d0-cd(1,i)
       enddo
 
 !other parameters and constants:
 
       spmax=1.d11             !max energy squared for tabulations
       delh=0.25d0             !effective exponent for weighting (technical)
       epsxmn=.01d0            !pt-resolution scale (technical)
       alm=.04d0               !lambda_qcd squared
       factk=1.5d0             !k-factor value
       fqscal=4.d0             !factor for fact. scale (Mf^2=p_t^2/fqscal)
       deta=.11111d0           !ratio of etas production to all pions (1/9)
       dc(3)=.000d0            !to switch off charmed particles set to 0.000
       dc(5)=.0d0              !to switch off charmed particles set to 0.000
 c weigts for diffractive eigenstates
       cc(1,1)=.5d0            !pion
       cc(2,1)=.5d0
       cc(1,2)=.5d0            !proton
       cc(2,2)=.5d0
       cc(1,3)=.5d0            !kaon
       cc(2,3)=.5d0
 c auxiliary constants
       b10=.43876194d0         !initial value of the pseudorandom sequence
       pi=3.1416d0             !pi-value
       amws=.523d0             !diffusive radius for saxon-wood density
 c regge intercepts for the uu~, qqq~q~, us~, uc~ trajectories
       arr(1)=0.5d0            !qq~-trajectory
       arr(2)=-0.5d0           !qqq~q~-trajectory
       arr(3)=0.d0             !us~-trajectory
 c lowest resonance masses for low-mass excitations
       dmmin(1)=.76d0          !rho
       dmmin(2)=1.23d0         !delta
       dmmin(3)=.89d0          !K*
 c mass and width for resonance contribution to low mass diffraction
       dmres(1)=1.23d0         !pion
       dmres(2)=1.44d0         !proton
       dmres(3)=1.27d0         !kaon
       wdres(1)=.3d0           !pion
       wdres(2)=.3d0           !proton
       wdres(3)=.1d0           !kaon
 c proton, kaon, pion, d-meson, lambda, lambda_c, eta masses
       amn=0.93827999
       amk=.496d0
       am0=.14d0
       amc=1.868d0
       amlam=1.116d0
       amlamc=2.27d0
       ameta=.548d0
       ammu=.1057d0
 c initial particle classes
       ty(1)='pion   '
       ty(2)='nucleon'
       ty(3)='kaon   '
 c parton types
       tyq(1)='DD'
       tyq(2)='UU'
       tyq(3)='C '
       tyq(4)='S '
       tyq(5)='UD'
       tyq(6)='D '
       tyq(7)='U '
       tyq(8)='g '
       tyq(9)='u '
       tyq(10)='d '
       tyq(11)='ud'
       tyq(12)='s '
       tyq(13)='c '
       tyq(14)='uu'
       tyq(15)='dd'
       if(debug.ge.2)write (moniou,202)
 
 210   format(2x,'qgset - common model parameters setting')
 202   format(2x,'qgset - end')
       return
       end
 
 c=============================================================================
       subroutine qgaini( DATDIR )
 c-----------------------------------------------------------------------------
 c common initialization procedure
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       CHARACTER DATDIR*(132)
       real qggamfun
       integer debug
       character *7 ty
       logical lcalc
       parameter(iapmax=208)
       dimension mij(40,40,4),nij(40,40,4),cs1(40,40,160)
      *,evs(40,100,3,2),ixemax(40,3,2),gz0(5),gz1(3)
      *,qfan0(11,14),qfan2(11,11,3),fann(14)
       common /qgarr1/  ia(2),icz,icp
       common /qgarr2/  scm,wp0,wm0
       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
      *,cr1(2),cr2(2),cr3(2)
       common /qgarr6/  pi,bm,amws
       common /qgarr10/ am(7),ammu
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr19/ ahl(3)
       common /qgarr20/ spmax
       common /qgarr24/ qpomr(11,11,216,12,2)
       common /qgarr25/ ahv(3)
       common /qgarr26/ factk,fqscal
       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
       common /qgarr28/ arr(5)
       common /qgarr29/ cstot(40,40,160)
       common /qgarr30/ cs0(40,40,160)
       common /qgarr31/ csborn(40,160)
       common /qgarr33/ fsud(10,2)
       common /qgarr34/ qrt(10,101,2)
       common /qgarr35/ qlegc0(51,10,11,6,8),qlegc(51,10,11,11,30)
       common /qgarr38/ qpomc(11,100,11,11,48)
       common /qgarr39/ qpomi(51,11,15),qpomis(51,11,11,11,9)
       common /qgarr41/ ty(6)
       common /qgarr43/ moniou
       common /qgarr47/ gsect(10,5,6)
       common /qgarr48/ qgsasect(10,6,6)
       common /qgarr51/ epsxmn
       common /qgarr52/ evk(40,40,100,3,2)
 c auxiliary common blocks to calculate hadron-nucleus cross-sections
       common /arr1/   trnuc(56),twsnuc(56),twbnuc(56)
       common /arr3/   x1(7),a1(7)
       common /opt/    jopt
       common /qgdebug/debug
       character*500 fnIIdat,fnIIncs                        !used to link with nexus
       common /version/ version                             !used to link with nexus
       common/qgsIIfname/fnIIdat, fnIIncs, ifIIdat, ifIIncs !used to link with nexus
       common/qgsIInfname/ nfnIIdat, nfnIIncs               !used to link with nexus
       common/producetab/ producetables              !used to link with CRMC
       logical producetables
 
       if(debug.ge.1)write (moniou,210)
       version = 204
 
 c-------------------------------------------------
       write(*,100)
  100  format(' ',
      *           '====================================================',
      *     /,' ','|                                                  |',
      *     /,' ','|         QUARK GLUON STRING JET -II MODEL         |',
      *     /,' ','|                                                  |',
      *     /,' ','|         HADRONIC INTERACTION MONTE CARLO         |',
      *     /,' ','|                        BY                        |',
      *     /,' ','|                 S. OSTAPCHENKO                   |',
      *     /,' ','|                                                  |',
      *     /,' ','|             e-mail: sergei@tf.phys.ntnu.no       |',
      *     /,' ','|                                                  |',
      *     /,' ','|                   Version II-04                  |',
      *     /,' ','|                                                  |',
      *     /,' ','| Publication to be cited when using this program: |',
      *     /,' ','| S.Ostapchenko, PRD 83 (2011) 014018              |',
      *     /,' ','|                                                  |',
      *     /,' ','| last modification:  26.06.2012                   |',
      *     /,' ','|                                                  |',
      *     /,' ','| Any modification has to be approved by the author|',
      *     /,' ','====================================================',
      *     /)
 
 
 c-----------------------------------------------------------------------------
 c normalization of parton density in the soft pomeron
       rr=qggamfun(real(2.d0+betp-dels))/qggamfun(real(1.d0-dels))
      */qggamfun(real(1.d0+betp))/4.d0/pi
 
       ahv(1)=.383d0+.624d0*dlog(dlog(qt0/.204d0**2)
      */dlog(.26d0/.204d0**2))
       ahv(3)=ahv(1)
       sq=dlog(dlog(qt0/.232d0**2)/dlog(.23d0/.232d0**2))
       ahv(2)=2.997d0+.753d0*sq-.076d0*sq*sq
 c valence quark momentum share
       qnorm1=0.d0
       do i=1,7
       do m=1,2
        tp=1.d0-(.5d0+x1(i)*(m-1.5d0))**(2.d0/3.d0)
        xp=1.d0-tp**(1.d0/(1.d0+ahv(1)))
        qnorm1=qnorm1+a1(i)*(qggrv(xp,qt0,1,1)+qggrv(xp,qt0,1,2))
      * /dsqrt(1.d0-tp)
       enddo
       enddo
       qnorm1=qnorm1/(1.d0+ahv(1))/3.d0
       qnorm2=0.d0
       do i=1,7
       do m=1,2
        tp=1.d0-(.5d0+x1(i)*(m-1.5d0))**(2.d0/3.d0)
        xp=1.d0-tp**(1.d0/(1.d0+ahv(2)))
        qnorm2=qnorm2+a1(i)*(qggrv(xp,qt0,2,1)+qggrv(xp,qt0,2,2))
      * /dsqrt(1.d0-tp)
       enddo
       enddo
       qnorm2=qnorm2/(1.d0+ahv(2))/3.d0
 c fp(i) - pomeron vertex constant (i=icz)
       fp(2)=(1.d0-qnorm2)*(2.d0+ahl(2))*(1.d0+ahl(2))
 
       gnorm=0.d0
       seanrm=0.d0
       do i=1,7
       do m=1,2
        xxg=(.5d0+x1(i)*(m-1.5d0))**(1.d0/(1.d0-dels))
        gnorm=gnorm+a1(i)*qgftld(xxg,2)
        seanrm=seanrm+a1(i)*qgftle(xxg,2)
       enddo
       enddo
       gnorm=gnorm/(1.d0-dels)*fp(2)*rr*2.d0*pi
       seanrm=seanrm/(1.d0-dels)*fp(2)*rr*2.d0*pi
       if(debug.ge.1)write (moniou,*)'rr,fp,norm,qnorm2,gnorm,seanrm'
      *,rr,fp(2),qnorm2+gnorm+seanrm,qnorm2,gnorm,seanrm
 
       do icz=1,3,2
        fp(icz)=(1.d0-qnorm1)*(2.d0+ahl(icz))*(1.d0+ahl(icz))
        gnorm=0.d0
        seanrm=0.d0
        do i=1,7
        do m=1,2
         xxg=(.5d0+x1(i)*(m-1.5d0))**(1.d0/(1.d0-dels))
         gnorm=gnorm+a1(i)*qgftld(xxg,icz)
         seanrm=seanrm+a1(i)*qgftle(xxg,icz)
        enddo
        enddo
        gnorm=gnorm/(1.d0-dels)*fp(icz)*rr*2.d0*pi
        seanrm=seanrm/(1.d0-dels)*fp(icz)*rr*2.d0*pi
 
        if(debug.ge.1)write (moniou,*)'fp,norm,qnorm1,gnorm,seanrm'
      * ,fp(icz),qnorm1+gnorm+seanrm,qnorm1,gnorm,seanrm
       enddo
 
       do icz=1,3
        gsoft(icz)=fp(icz)*fp(2)*sigs*4.d0*.0389d0
      * *qggamfun(real(1.d0+dels))**2*qggamfun(real(1.d0+ahl(icz)))
      * *qggamfun(real(1.d0+ahl(2)))/qggamfun(real(2.d0+dels+ahl(icz)))
      * /qggamfun(real(2.d0+dels+ahl(2)))
       enddo
 
 c-----------------------------------------------------------------------------
 c reading cross sections from the file
       if(ifIIdat.ne.1)then
        inquire(file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
      *        ,exist=lcalc)
       else
        inquire(file=fnIIdat(1:nfnIIdat),exist=lcalc)       !used to link with nexus
       endif
       lzmaUse=0
       if(lcalc)then
          if(ifIIdat.ne.1)then
             open(1,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
      *           ,status='old')
          else                   !used to link with nexus
             if (LEN(fnIIdat).gt.6.and.
      *           fnIIdat(nfnIIdat-4:nfnIIdat) .eq. ".lzma") then
                lzmaUse=1
                call LzmaOpenFile(fnIIdat(1:nfnIIdat))
             else
                open(ifIIdat,file=fnIIdat(1:nfnIIdat),status='old')
             endif
          endif
 
        if (lzmaUse.ne.0) then
 
           if(debug.ge.0)write (moniou,214) 'qgsdat-II-04.lzma'
 
           call LzmaFillArray(csborn,size(csborn))
           call LzmaFillArray(cs0,size(cs0))
           call LzmaFillArray(cstot,size(cstot))
           call LzmaFillArray(evk,size(evk))
           call LzmaFillArray(qpomi,size(qpomi))
           call LzmaFillArray(qpomis,size(qpomis))
           call LzmaFillArray(qlegi,size(qlegi))
           call LzmaFillArray(qfanu,size(qfanu))
           call LzmaFillArray(qfanc,size(qfanc))
           call LzmaFillArray(qdfan,size(qdfan))
           call LzmaFillArray(qpomr,size(qpomr))
           call LzmaFillArray(gsect,size(gsect))
           call LzmaFillArray(qlegc0,size(qlegc0))
           call LzmaFillArray(qlegc,size(qlegc))
           call LzmaFillArray(qpomc,size(qpomc))
           call LzmaFillArray(fsud,size(fsud))
           call LzmaFillArray(qrt,size(qrt))
           call LzmaFillArray(qrev,size(qrev))
           call LzmaFillArray(fsud,size(fsud))
           call LzmaFillArray(qrt,size(qrt))
           call LzmaCloseFile()
        else
           if(debug.ge.0)write (moniou,214) 'qgsdat-II-04'
           read (1,*)csborn,cs0,cstot,evk,qpomi,qpomis,qlegi,qfanu,qfanc
      *         ,qdfan,qpomr,gsect,qlegc0,qlegc,qpomc,fsud,qrt,qrev,fsud,
      *         qrt
           close(1)
        endif
 
        if(debug.ge.0)write (moniou,*)'done'
        goto 10
       elseif(.not.producetables)then
         write(moniou,*) "Missing QGSDAT-II-04 file !"        
         write(moniou,*) "Please correct the defined path ",
      &"or force production ..."
         stop
       endif
 
 c--------------------------------------------------
 c qcd evolution and qcd ladder cross sections
 c--------------------------------------------------
       if(debug.ge.0)write (moniou,201)
       do i=1,40
       do m=1,3
       do k=1,2
        ixemax(i,m,k)=99
       do j=1,40
       do l=1,100
        evk(i,j,l,m,k)=0.d0
       enddo
       enddo
       enddo
       enddo
       enddo
 
       n=1
 1     n=n+1
       do m=1,3
       do k=1,2
        if(m.ne.3.or.k.ne.1)then
         do i=1,39
          if(ixemax(i,m,k).gt.0)then
           qi=spmax**((i-1)/39.d0)
           qq=qi*(spmax/qi)**(1.d0/39.d0)
           do l=1,99
            if(l.le.37)then
             xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
            elseif(l.le.69)then
             xx=.1d0+.8d0*(l-37.d0)/32.d0
            else
             xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
            endif
 
            ev=qgev(qi,qq,qq,xx,m,k)/qgfap(xx,m,k)
            if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
             evs(i,l,m,k)=dlog(1.d0+ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
      *      /dlog(dlog(qq/alm)/dlog(qi/alm)))
            else
             evs(i,l,m,k)=dlog(1.d0+ev/.3d0*(dlog(epsxmn)+.75d0)
      *      /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
            endif
           enddo
          endif
         enddo
        endif
       enddo
       enddo
 
       jec=0
       do m=1,3
       do k=1,2
        if(m.ne.3.or.k.ne.1)then
         do i=1,39
          if(ixemax(i,m,k).gt.0)then
           qi=spmax**((i-1)/39.d0)
           qq=qi*(spmax/qi)**(1.d0/39.d0)
           imx=ixemax(i,m,k)
           do l=imx,1,-1
            if(l.le.37)then
             xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
            elseif(l.le.69)then
             xx=.1d0+.8d0*(l-37.d0)/32.d0
            else
             xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
            endif
 
            if(abs(evs(i,l,m,k)-evk(i,2,l,m,k)).gt.1.d-3)then
             evk(i,2,l,m,k)=evs(i,l,m,k)
             jec=1
            elseif(ixemax(i,m,k).eq.l)then
             ixemax(i,m,k)=l-1
            endif
           enddo
          endif
         enddo
        endif
       enddo
       enddo
 
       do i=1,39
        qi=spmax**((i-1)/39.d0)
        qj=qi*(spmax/qi)**(1.d0/39.d0)
        qq=qi*(spmax/qi)**(2.d0/39.d0)
        do l=99,1,-1
         if(l.le.37)then
          xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
         elseif(l.le.69)then
          xx=.1d0+.8d0*(l-37.d0)/32.d0
         else
          xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
         endif
         do m=1,3
         do k=1,2
          if(m.ne.3.or.k.ne.1)then
           ev=(qgev(qi,qj,qq,xx,m,k)
      *    +qgevi(qi,qj,xx,m,k)*qgsudx(qq,k)/qgsudx(qj,k)
      *    +qgevi(qj,qq,xx,m,k)*qgsudx(qj,m)/qgsudx(qi,m))/qgfap(xx,m,k)
           if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
            evk(i,3,l,m,k)=dlog(ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
      *     /dlog(dlog(qq/alm)/dlog(qi/alm)))
           else
            evk(i,3,l,m,k)=dlog(ev/.3d0*(dlog(epsxmn)+.75d0)
      *     /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
           endif
          endif
         enddo
         enddo
        enddo
       enddo
       if(jec.ne.0)goto 1
 
       do i=1,39
        qi=spmax**((i-1)/39.d0)
       do j=4,40
        qj=qi*(spmax/qi)**((j-2)/39.d0)
        qq=qi*(spmax/qi)**((j-1)/39.d0)
        do l=99,1,-1
         if(l.le.37)then
          xx=.1d0/(.1d0*spmax)**((37.d0-l)/36.d0)
         elseif(l.le.69)then
          xx=.1d0+.8d0*(l-37.d0)/32.d0
         else
          xx=1.d0-.1d0*(10.d0*epsxmn)**((l-69.d0)/31.d0)
         endif
         do m=1,3
         do k=1,2
          if(m.ne.3.or.k.ne.1)then
           ev=(qgev(qi,qj,qq,xx,m,k)
      *    +qgevi(qi,qj,xx,m,k)*qgsudx(qq,k)/qgsudx(qj,k)
      *    +qgevi(qj,qq,xx,m,k)*qgsudx(qj,m)/qgsudx(qi,m))/qgfap(xx,m,k)
           if(m.eq.1.and.k.eq.1.or.m.ne.1.and.k.ne.1)then
            evk(i,j,l,m,k)=dlog(ev*4.5d0*qgsudx(qi,m)/qgsudx(qq,m)
      *     /dlog(dlog(qq/alm)/dlog(qi/alm)))
           else
            evk(i,j,l,m,k)=dlog(ev/.3d0*(dlog(epsxmn)+.75d0)
      *     /(qgsudx(qq,1)/qgsudx(qi,1)-qgsudx(qq,2)/qgsudx(qi,2)))
           endif
          endif
         enddo
         enddo
        enddo
       enddo
       enddo
 
 c--------------------------------------------------
 c qcd ladder cross sections
       do i=1,40
        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)  !q^2 cutoff for born process
        s2min=qi*4.d0*fqscal          !energy threshold for 2->2 subprocess
       do m=1,2                                !parton types (1-g, 2-q)
       do l=1,2                                !parton types (1-g, 2-q)
        l1=2*l-1
       do k=1,40
        sk=s2min*(spmax/s2min)**((k-1)/39.d0)  !c.m. energy squared
        k1=k+40*(m-1)+80*(l-1)
        csborn(i,k1)=dlog(qgborn(qi,qi,sk,m-1,l1-1)) !born cross-section (2->2)
        if(.not.(csborn(i,k1).ge.0.d0.or.csborn(i,k1).lt.0.d0))stop
       enddo
       enddo
       enddo
       enddo
 
       do i=1,40
        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
       do j=1,40
        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
        s2min=qj*4.d0*fqscal
        smin=s2min/(1.d0-epsxmn)
       do m=1,2
       do l=1,2
        l1=2*l-1
        ml=m+2*l-2
       do k=1,40
        sk=s2min*(spmax/s2min)**((k-1)/39.d0)
        k1=k+40*(m-1)+80*(l-1)
 
        tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
        sjtot=qgjett(qi,qj,sk,m-1,l-1)
        sjord1=qgjeto(qi,qj,sk,m-1,l-1)
        sjord2=qgjeto(qj,qi,sk,l-1,m-1)
        born=qgborn(qi,qj,sk,m-1,l1-1)
        if(k.eq.1.or.j.eq.40.or.i.eq.40.or.sk.le.smin)then
         cstot(i,j,k1)=dlog(born)
         cs0(i,j,k1)=cstot(i,j,k1)
        else
         cstot(i,j,k1)=dlog(born+(sjtot+sjord1+sjord2)
      *  /(1.d0/tmin-2.d0/sk))
         cs0(i,j,k1)=dlog(born+sjord1/(1.d0/tmin-2.d0/sk))
        endif
        if(.not.(cstot(i,j,k1).ge.0.d0.or.cstot(i,j,k1).lt.0.d0))stop
        if(.not.(cs0(i,j,k1).ge.0.d0.or.cs0(i,j,k1).lt.0.d0))stop
       enddo
       enddo
       enddo
       enddo
       enddo
       goto 3
 
 c--------------------------------------------------
 c alternative calculation (not used)
       do i=1,40
        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
       do j=1,40
        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
        s2min=qj*4.d0*fqscal
       do m=1,2
       do l=1,2
        l1=2*l-1
        ml=m+2*l-2
       do k=1,40
        sk=s2min*(spmax/s2min)**((k-1)/39.d0)
        k1=k+40*(m-1)+80*(l-1)
        cstot(i,j,k1)=dlog(qgborn(qi,qj,sk,m-1,l1-1))
        cs0(i,j,k1)=cstot(i,j,k1)
        mij(i,j,ml)=2
        nij(i,j,ml)=2
       enddo
       enddo
       enddo
       enddo
       enddo
 
       n=2                             !number of ladder rungs considered
 2     if(debug.ge.1)write (moniou,202)n,mij(1,1,1),nij(1,1,1)
       do i=1,39
        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)       !q^2 for upper parton
       do j=1,39
        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0) !q^2 for downer parton
        s2min=qj*4.d0*fqscal                !energy threshold for 2->2 subprocess
        smin=s2min/(1.d0-epsxmn)            !energy threshold for 2->3 subprocess
       do m=1,2                                     !parton types (1-g, 2-q)
       do l=1,2                                     !parton types (1-g, 2-q)
        l1=2*l-1
        ml=m+2*l-2
        kmin=nij(i,j,ml)                  !lowest energy bin for another rung
        if(kmin.le.40)then
         do k=kmin,40
          sk=s2min*(spmax/s2min)**((k-1)/39.d0)
          if(sk.le.smin)then
           nij(i,j,ml)=nij(i,j,ml)+1
          else
           k1=k+40*(m-1)+80*(l-1)
           tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
           cs1(i,j,k1)=dlog(qgjet1(qi,qj,sk,s2min,m,l)
      *    /(1.d0/tmin-2.d0/sk)+qgborn(qi,qj,sk,m-1,l1-1))
          endif
         enddo
        endif
       enddo
       enddo
       enddo
       enddo
 
       do i=1,39
        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
       do j=1,39
        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
        s2min=qj*4.d0*fqscal
       do m=1,2
       do l=1,2
        ml=m+2*l-2
        kmin=nij(i,j,ml)
        if(kmin.le.40)then
         do k=40,kmin,-1
          sk=s2min*(spmax/s2min)**((k-1)/39.d0)
          tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
          k1=k+40*(m-1)+80*(l-1)
          if(abs(cs1(i,j,k1)-cs0(i,j,k1)).gt.1.d-2)then
           cs0(i,j,k1)=cs1(i,j,k1)
          elseif(k.eq.nij(i,j,ml))then
           nij(i,j,ml)=nij(i,j,ml)+1
          endif
         enddo
        endif
       enddo
       enddo
       enddo
       enddo
 
       do i=1,39
        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
       do j=1,39
        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
        s2min=qj*4.d0*fqscal         !min energy squared for 2->2 subprocess
        smin=s2min/(1.d0-epsxmn)     !min energy squared for 2->3 subprocess
       do m=1,2
       do l=1,2
        ml=m+2*l-2
        kmin=mij(i,j,ml)             !min energy bin for more ladder rungs
        if(kmin.le.40)then
         do k=kmin,40
          sk=s2min*(spmax/s2min)**((k-1)/39.d0)
          if(sk.le.smin)then
           mij(i,j,ml)=mij(i,j,ml)+1
          else
           k1=k+40*(m-1)+80*(l-1)
           tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
           cs1(i,j,k1)=dlog((qgjet(qi,qj,sk,s2min,m,l)
      *    +qgjit1(qj,qi,sk,l,m))/(1.d0/tmin-2.d0/sk))
          endif
         enddo
        endif
       enddo
       enddo
       enddo
       enddo
 
 c--------------------------------------------------
 c check convergence
       do i=1,39
        qi=(spmax/4.d0/fqscal)**((i-1)/39.d0)
       do j=1,39
        qj=qi*(spmax/4.d0/fqscal/qi)**((j-1)/39.d0)
        s2min=qj*4.d0*fqscal
       do m=1,2
       do l=1,2
        ml=m+2*l-2
        kmin=mij(i,j,ml)             !min energy bin for more ladder rungs
        if(kmin.le.40)then
         do k=40,kmin,-1
          sk=s2min*(spmax/s2min)**((k-1)/39.d0)
          tmin=qj*fqscal/(.5d0+dsqrt(max(0.d0,.25d0-qj*fqscal/sk)))
          k1=k+40*(m-1)+80*(l-1)
          if(abs(cs1(i,j,k1)-cstot(i,j,k1)).gt.1.d-2)then
           cstot(i,j,k1)=cs1(i,j,k1)
          elseif(k.eq.mij(i,j,ml))then
           mij(i,j,ml)=mij(i,j,ml)+1
          endif
         enddo
        endif
       enddo
       enddo
       enddo
       enddo
 
       n=n+1                         !one more rung
       do i=1,39
       do j=1,39
       do l=1,4
        if(mij(i,j,l).le.40.or.nij(i,j,l).le.40)goto 2
       enddo
       enddo
       enddo
 
 3     if(debug.ge.2)write (moniou,205)
 c-------------------------------------------------
 c itermediate Pomeron
       if(debug.ge.1)write (moniou,210)
       s2min=4.d0*fqscal*qt0
       do iy=1,51
        sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
        rp=alfp*log(sy)*4.d0*.0389d0
       do iz=1,11
        if(iz.gt.6)then
         z=.2d0*(iz-6)
         b=sqrt(-log(z)*rp)
        else
         b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
         z=exp(-b*b/rp)
        endif
 
        qpomi(iy,iz,1)=dlog(qgpint(sy,b*b)
      * /sy**dels/sigs/z*rp/4.d0/.0389d0+1.d0)
       enddo
       enddo
 
 c-------------------------------------------------
 c loop contribution
       do iy=1,51
        sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
        rp=alfp*log(sy)*4.d0*.0389d0
       do iz=1,11
        if(iz.gt.6)then
         z=.2d0*(iz-6)
         b=sqrt(-log(z)*rp)
        else
         b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
         z=exp(-b*b/rp)
        endif
       do iqq=2,4
        qpomi(iy,iz,iqq)=qpomi(iy,iz,1)
       enddo
       enddo
       enddo
 
       do iy=2,51
        sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
        rp=alfp*log(sy)*4.d0*.0389d0
        do iz=1,11
        do iqq=2,4
         qpomi(iy,iz,iqq)=qpomi(iy-1,iz,iqq)
        enddo
        enddo
        n=0
 4      n=n+1
        nrep=0
        do iz=1,11
         if(iz.gt.6)then
          z=.2d0*(iz-6)
          b=sqrt(-log(z)*rp)
         else
          b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
          z=exp(-b*b/rp)
         endif
         call qgloop(sy,b*b,fann,1)
         do iqq=1,3
          if(fann(iqq).gt.0.d0)then
           qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
      *    /4.d0/.0389d0)
          elseif(iy.gt.2)then
           qfan0(iz,iqq)=min(2.d0*qpomi(iy-1,iz,iqq+1)
      *    -qpomi(iy-2,iz,iqq+1),qpomi(iy-1,iz,iqq+1))
          else
           stop'loop<0: iy=2'
          endif
          if(qfan0(iz,iqq).lt.-20.d0)then
           qfan0(iz,iqq)=-20.d0
          endif
          if(abs(qfan0(iz,iqq)-qpomi(iy,iz,iqq+1)).gt.1.d-3)nrep=1
         enddo
        enddo
        do iz=1,11
         if(iz.gt.6)then
          z=.2d0*(iz-6)
          b=sqrt(-log(z)*rp)
         else
          b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
          z=exp(-b*b/rp)
         endif
        do iqq=2,4
         qpomi(iy,iz,iqq)=qfan0(iz,iqq-1)
         if(.not.(qpomi(iy,iz,iqq).le.0.d0
      *  .or.qpomi(iy,iz,iqq).gt.0.d0))stop'qpom-nan'
        enddo
        enddo
        if(nrep.eq.1.and.n.lt.100)goto 4
       enddo
 
 c-------------------------------------------------
 c cut loops
       do iy=1,51
       do iz=1,11
        do iqq=5,7
         qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-3)
        enddo
        qpomi(iy,iz,8)=qpomi(iy,iz,2)
        do iqq=9,10
         qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-7)
         qpomi(iy,iz,iqq+2)=qpomi(iy,iz,iqq-7)
        enddo
        do iqq=13,15
         qpomi(iy,iz,iqq)=qpomi(iy,iz,iqq-11)
        enddo
       enddo
       enddo
 
       do iy=2,51
        sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
        rp=alfp*log(sy)*4.d0*.0389d0
        do iz=1,11
        do iqq=5,15
         qpomi(iy,iz,iqq)=qpomi(iy-1,iz,iqq)
        enddo
        enddo
        n=0
 5      n=n+1
        nrep=0
        do iz=1,11
         if(iz.gt.6)then
          z=.2d0*(iz-6)
          b=sqrt(-log(z)*rp)
         else
          b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
          z=exp(-b*b/rp)
         endif
         call qgloop(sy,b*b,fann,2)
         do iqq=4,14
          if(fann(iqq).gt.0.d0)then
           qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
      *    /4.d0/.0389d0)
          elseif(iy.gt.2)then
           qfan0(iz,iqq)=min(2.d0*qpomi(iy-1,iz,iqq+1)
      *    -qpomi(iy-2,iz,iqq+1),qpomi(iy-1,iz,iqq+1))
          else
           stop'loop<0: iy=2'
          endif
          if(qfan0(iz,iqq).lt.-20.d0)then
           qfan0(iz,iqq)=-20.d0
          endif
          if(abs(qfan0(iz,iqq)-qpomi(iy,iz,iqq+1)).gt.1.d-3)nrep=1
         enddo
        enddo
        do iz=1,11
         if(iz.gt.6)then
          z=.2d0*(iz-6)
          b=sqrt(-log(z)*rp)
         else
          b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
          z=exp(-b*b/rp)
         endif
        do iqq=5,15
         qpomi(iy,iz,iqq)=qfan0(iz,iqq-1)
         if(.not.(qpomi(iy,iz,iqq).le.0.d0
      *  .or.qpomi(iy,iz,iqq).gt.0.d0))stop'qpomi-nan'
        enddo
        enddo
        if(nrep.eq.1.and.n.lt.50)goto 5
       enddo
 
 c-------------------------------------------------
 c cut loops with proj/targ screening corrections
       do iv=1,11
        vvx=dble(iv-1)/10.d0
       do iv1=1,11
        vvxt=dble(iv1-1)/10.d0
 
        do iz=1,11
         do iqq=1,8
          qpomis(1,iz,iv,iv1,iqq)=0.d0
         enddo
         qpomis(1,iz,iv,iv1,1)=qpomi(1,iz,1)
         qpomis(1,iz,iv,iv1,4)=qpomi(1,iz,1)
        enddo
 
        do iy=2,51
         sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
         rp=alfp*log(sy)*4.d0*.0389d0
         do iz=1,11
         do iqq=1,8
          qpomis(iy,iz,iv,iv1,iqq)=qpomis(iy-1,iz,iv,iv1,iqq)
         enddo
         enddo
 
         n=0
 6       n=n+1
         nrep=0
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*(iz-6)
           b=sqrt(-log(z)*rp)
          else
           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
           z=exp(-b*b/rp)
          endif
          call qgloos(sy,b*b,vvx,vvxt,fann)
          vi=qgpini(sy,b*b,0.d0,0.d0,2)
          vic=min(vi,qgpini(sy,b*b,0.d0,0.d0,8))
          vicng=min(vic,qgpini(sy,b*b,0.d0,0.d0,11))
          do iqq=1,8
           if(fann(iqq).gt.0.d0)then
            if(iqq.eq.1.or.iqq.eq.4)then
             qfan0(iz,iqq)=dlog(fann(iqq)/z/sigs/sy**dels*rp/g3p**2
      *      /4.d0/.0389d0)
            elseif(iqq.eq.3)then
             qfan0(iz,iqq)=dlog(fann(iqq)/(.5d0*max(0.d0,1.d0
      *      -exp(-2.d0*vic)*(1.d0+2.d0*vic))+vicng*exp(-2.d0*vic)))
            elseif(iqq.gt.6)then
             qfan0(iz,iqq)=dlog(fann(iqq)*2.d0/((1.d0-exp(-vi))**2
      *      +(exp(2.d0*(vi-vic))-1.d0)*exp(-2.d0*vi)))
            else
             qfan0(iz,iqq)=dlog(fann(iqq)/(1.d0-exp(-vi)))
            endif
           elseif(iy.gt.2)then
            qfan0(iz,iqq)=min(2.d0*qpomis(iy-1,iz,iv,iv1,iqq)
      *     -qpomis(iy-2,iz,iv,iv1,iqq),qpomis(iy-1,iz,iv,iv1,iqq))
           else
            qfan0(iz,iqq)=qpomis(iy-1,iz,iv,iv1,iqq)
           endif
           if(iqq.gt.5)qfan0(iz,iqq)=min(qfan0(iz,iqq),qfan0(iz,iqq-1))
           qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
           if(abs(qfan0(iz,iqq)-qpomis(iy,iz,iv,iv1,iqq)).gt.1.d-3)
      *    nrep=1
          enddo
         enddo
 
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*(iz-6)
           b=sqrt(-log(z)*rp)
          else
           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
           z=exp(-b*b/rp)
          endif
          do iqq=1,8
           qpomis(iy,iz,iv,iv1,iqq)=qfan0(iz,iqq)
           if(iqq.eq.1.or.iqq.eq.4)then
            dpx=exp(qpomis(iy,iz,iv,iv1,iqq))*g3p**2*sigs
      *     *sy**dels*z/rp*4.d0*.0389d0
           else
            dpx=exp(qpomis(iy,iz,iv,iv1,iqq))
           endif
          enddo
         enddo
         if(nrep.eq.1.and.n.lt.50)goto 6
        enddo
       enddo
       enddo
 
 c-------------------------------------------------
 c integrated Pomeron leg eikonals
       if(debug.ge.1)write (moniou,212)
       do icz=1,3
       do icdp=1,2
        if(cd(icdp,icz).ne.0.d0)then
         do iy=1,51
          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*(iz-6)
           b=sqrt(-log(z)*rp)
          else
           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
           z=exp(-b*b/rp)
          endif
 
          qxl=qgleg(sy,b*b,icdp,icz)
          qlegi(iy,iz,icdp,icz,1)=log(qxl/z)
         enddo
         enddo
        endif
       enddo
       enddo
 
 c-------------------------------------------------
 c loop-legs
       do icz=1,3
       do icdp=1,2
        if(cd(icdp,icz).ne.0.d0)then
         do iy=1,51
          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*(iz-6)
           b=sqrt(-log(z)*rp)
          else
           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
           z=exp(-b*b/rp)
          endif
          if(iy.eq.1)then
           do iqq=2,7
            qlegi(iy,iz,icdp,icz,iqq)=qlegi(iy,iz,icdp,icz,1)
           enddo
          else
           call qglool(sy,b*b,icdp,icz,fann)
           do iqq=2,7
            if(fann(iqq-1).gt.0.d0)then
             qlegi(iy,iz,icdp,icz,iqq)=log(fann(iqq-1)/z)
            else
             qlegi(iy,iz,icdp,icz,iqq)=2.d0*qlegi(iy-1,iz,icdp,icz,iqq)
      *      -qlegi(iy-2,iz,icdp,icz,iqq)
            endif
            qlegi(iy,iz,icdp,icz,iqq)=max(qlegi(iy,iz,icdp,icz,iqq)
      *     ,-20.d0)
            if(.not.(qlegi(iy,iz,icdp,icz,iqq).le.0.d0
      *     .or.qlegi(iy,iz,icdp,icz,iqq).gt.0.d0))stop'leg-nan'
           enddo
          endif
         enddo
         enddo
        endif
       enddo
       enddo
 
 c-------------------------------------------------
 c uncut fan-contributions
       if(debug.ge.1)write (moniou,213)
       do icz=1,3
       do iv=1,11
        vvx=dble(iv-1)/10.d0
       do icdp=1,2
        if(cd(icdp,icz).ne.0.d0)then
         do iy=1,51
         do iz=1,11
         do iqq=1,2
          qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)=qlegi(iy,iz,icdp,icz,iqq+1)
         enddo
         enddo
         enddo
 
         do iy=2,51
          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
          rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
          do iz=1,11
          do iqq=1,2
           qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)
      *    =qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
          enddo
          enddo
 
          n=1
 7        n=n+1
          nrep=0
          do iz=1,11
           if(iz.gt.6)then
            z=.2d0*dble(iz-6)
            b=dsqrt(-dlog(z)*rp)
           else
            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
            z=dexp(-b*b/rp)
           endif
           call qgfan(sy,b*b,vvx,icdp,icz,fann)
           do iqq=1,2
            if(fann(iqq).gt.0.d0)then
             qfan0(iz,iqq)=dlog(fann(iqq)/z)
            else
             qfan0(iz,iqq)=min(qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
      *      ,2.d0*qfanu(iy-1,iz,iv,icdp+2*(icz-1),iqq)
      *      -qfanu(iy-2,iz,iv,icdp+2*(icz-1),iqq))
            endif
            qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
            if(abs(qfan0(iz,iqq)-qfanu(iy,iz,iv,icdp+2*(icz-1),iqq))
      *     .gt.1.d-3)nrep=1
           enddo
          enddo
 
          do iz=1,11
          do iqq=1,2
           qfanu(iy,iz,iv,icdp+2*(icz-1),iqq)=qfan0(iz,iqq)
          enddo
          enddo
          if(nrep.eq.1)goto 7
 
          do iz=1,11
          do iqq=1,2
           if(iz.gt.6)then
            z=.2d0*dble(iz-6)
            b=dsqrt(-dlog(z)*rp)
           else
            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
            z=dexp(-b*b/rp)
           endif
           if(.not.(qfanu(iy,iz,iv,icdp+2*(icz-1),iqq).le.0.d0
      *    .or.qfanu(iy,iz,iv,icdp+2*(icz-1),iqq).gt.0.d0))stop'fan-nn'
          enddo
          enddo
         enddo
        endif
       enddo
       enddo
       enddo
 
 c-------------------------------------------------
 c cut fan contributions
       if(debug.ge.1)write (moniou,215)
       do icz=1,3                                !hadron class
       do icdp=1,2                                 !diffractive eigenstate
        if(cd(icdp,icz).ne.0.d0)then
 c vvx,vvxp,vvxpl - screening corrections from targ. and nuclear proj. fans
         do iv=1,11
          vvx=dble(iv-1)/10.d0
         do iv1=1,1+5*(icz-1)*(3-icz)
          vvxp=dble(iv1-1)/5.d0
         do iv2=1,1+5*(icz-1)*(3-icz)
          vvxpl=vvx*dble(iv2-1)/5.d0
         do iy=1,51                                !initialization
         do iz=1,11
          do iqq=1,9
           qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp
      *    +2*(iqq-1))=qfanu(iy,iz,iv,icdp+2*(icz-1),1)
          enddo
         enddo
         enddo
 
         do iy=2,51
          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
          rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
          do iz=1,11
          do iqq=1,9
           qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp
      *    +2*(iqq-1))=qfanc(iy-1,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1
      *    +6*(iv2-1)),icdp+2*(iqq-1))
          enddo
          enddo
 
          n=1
 8        n=n+1                          !number of t-channel iterations
          nrep=0
          do iz=1,11
           if(iz.gt.6)then
            z=.2d0*dble(iz-6)
            b=dsqrt(-dlog(z)*rp)
           else
            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
            z=dexp(-b*b/rp)
           endif
           call qgfanc(sy,b*b,vvx,vvxp,vvxpl,icdp,icz,fann)
           fann(7)=min(fann(7),fann(8))
           do iqq=1,9
            if(fann(iqq).gt.0.d0)then
             qfan0(iz,iqq)=dlog(fann(iqq)/z)
            else
             qfan0(iz,iqq)=min(2.d0*qfanc(iy-1,iz,iv,icz
      *      +(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1))
      *      -qfanc(iy-2,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
      *      ,icdp+2*(iqq-1)),qfanc(iy-1,iz,iv,icz
      *      +(icz-1)*(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1)))
            endif
            qfan0(iz,iqq)=max(qfan0(iz,iqq),-20.d0)
           enddo
          enddo
 
          do iz=1,11
          do iqq=1,9
           if(abs(qfan0(iz,iqq)-qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)
      *    *(iv1+1+6*(iv2-1)),icdp+2*(iqq-1))).gt.1.d-3)nrep=1
           qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
      *    ,icdp+2*(iqq-1))=qfan0(iz,iqq)
          enddo
          enddo
          if(nrep.eq.1.and.n.lt.50)goto 8
 
          do iz=1,11
           if(iz.gt.6)then
            z=.2d0*dble(iz-6)
            b=dsqrt(-dlog(z)*rp)
           else
            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
            z=dexp(-b*b/rp)
           endif
          do iqq=1,9
           if(.not.(qfanc(iy,iz,iv,icz+(icz-1)*(3-icz)*(iv1+1+6*(iv2-1))
      *    ,icdp+2*(iqq-1)).le.0.d0.or.qfanc(iy,iz,iv,icz+(icz-1)
      *    *(3-icz)*(iv1+1+6*(iv2-1)),icdp+2*(iqq-1)).gt.0.d0))
      *    stop'fanc-nan'
          enddo
          enddo
         enddo
         enddo
         enddo
         enddo
        endif
       enddo
       enddo
 
 c-------------------------------------------------
 c zigzag fans
       do icz=1,3                                  !hadron class
       do icdp=1,2                                 !diffractive eigenstate
        if(cd(icdp,icz).ne.0.d0)then
         do iy=1,11
          sy=sgap**2*(spmax/sgap**2)**((iy-1)/10.d0)
          rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*dble(iz-6)
           bb=-dlog(z)*rp
          else
           bb=-rp*(dlog(0.2d0)+2.d0*dble(iz-7))
           z=dexp(-bb/rp)
          endif
         do iv=1,11
          vvxt0=dble(iv-1)/10.d0
         do iv1=1,6
          vvxt=vvxt0+(1.d0-vvxt0)*dble(iv1-1)/5.d0
         do iv2=1,1+5*(icz-1)*(3-icz)
          vvxpt=dble(iv2-1)/5.d0
         do iv3=1,1+5*(icz-1)*(3-icz)
          vvxp0=vvxpt*dble(iv3-1)/5.d0
         do iv4=1,1+5*(icz-1)*(3-icz)
          vvxpl=dble(iv4-1)/5.d0
 
          dfan=qgrev(sy,bb,vvxt0,vvxt,vvxpt,vvxp0,vvxpl,icdp,icz)
          if(dfan.gt.0.d0)then
           qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)
      *    *(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp)=dlog(dfan/z)
          else
           qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1
      *    +6*(iv3-1)+36*(iv4-1)),icdp)=2.d0*qrev(iy-1,iz,iv+11*(iv1-1)
      *    ,icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp)
      *    -qrev(iy-2,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1
      *    +6*(iv3-1)+36*(iv4-1)),icdp)
          endif
          qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)
      *   +36*(iv4-1)),icdp)=max(qrev(iy,iz,iv+11*(iv1-1),icz
      *   +(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp),-20.d0)
 
          if(.not.(qrev(iy,iz,iv+11*(iv1-1),icz+(icz-1)*(3-icz)
      *   *(iv2+1+6*(iv3-1)+36*(iv4-1)),icdp).le.0.d0.or.qrev(iy,iz
      *   ,iv+11*(iv1-1),icz+(icz-1)*(3-icz)*(iv2+1+6*(iv3-1)
      *   +36*(iv4-1)),icdp).gt.0.d0))stop'fanc-nan'
         enddo
         enddo
         enddo
         enddo
         enddo
         enddo
         enddo
        endif
       enddo
       enddo
 
 c-------------------------------------------------
 c diffractive fans
       icz=2
       do icdp=1,2
        if(cd(icdp,icz).ne.0.d0)then
         do iy=1,21
          xpomr=(1.d5/sgap**2)**(-dble(iy-1)/20.d0)/sgap**2
           rp=(rq(icdp,icz)-alfp*dlog(xpomr))*2.d0*.0389d0
          if(iy.gt.1)then
           do iy1=1,11
           do iz=1,11
           do iqq=1,3
            qdfan(iy,iy1,iz,icdp,iqq)=qdfan(iy-1,iy1,iz,icdp,iqq)
           enddo
           enddo
           enddo
          endif
 
          n=0
 9        n=n+1
          nrep=0
          do iy1=1,11
           xpomr1=(xpomr*sgap**2)**(dble(11-iy1)/10.d0)/sgap
          do iz=1,11
           if(iz.gt.6)then
            z=.2d0*dble(iz-6)
            b=dsqrt(-dlog(z)*rp)
           else
            b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
            z=dexp(-b*b/rp)
           endif
           call qgdfan(xpomr,xpomr1,b*b,icdp,fann,n)
           do iqq=1,3
            if(fann(iqq).gt.0.d0)then
             qfan2(iy1,iz,iqq)=dlog(fann(iqq)/z)
            else
             qfan2(iy1,iz,iqq)=qfan2(iy1-1,iz,iqq)
            endif
            if(n.gt.1.and.abs(qfan2(iy1,iz,iqq)
      *     -qdfan(iy,iy1,iz,icdp,iqq)).gt.1.d-3)nrep=1
           enddo
          enddo
          enddo
 
          do iy1=1,11
          do iz=1,11
          do iqq=1,3
           qdfan(iy,iy1,iz,icdp,iqq)=qfan2(iy1,iz,iqq)
          enddo
          enddo
          enddo
          if((n.eq.1.or.nrep.eq.1).and.iy.gt.1)goto 9
 
          do iy1=1,11
           xpomr1=(xpomr*sgap**2)**(dble(11-iy1)/10.d0)/sgap
           do iz=1,11
            if(iz.gt.6)then
             z=.2d0*dble(iz-6)
             b=dsqrt(-dlog(z)*rp)
            else
             b=dsqrt(-rp*(dlog(0.2d0)+2.d0*dble(iz-7)))
             z=dexp(-b*b/rp)
            endif
            do iqq=1,3
             if(iqq.ne.3)then
              dpx=dexp(qdfan(iy,iy1,iz,icdp,iqq))*z
             else
              dpx=dexp(qdfan(iy,iy1,iz,icdp,iqq))*z
      *       *dlog(xpomr1/xpomr/sgap)
             endif
             if(.not.(qdfan(iy,iy1,iz,icdp,iqq).le.0.d0
      *      .or.qdfan(iy,iy1,iz,icdp,iqq).gt.0.d0))stop'qdfan-nan'
            enddo
           enddo
          enddo
         enddo
        endif
       enddo
 
 c-------------------------------------------------
 c integrated Pomeron eikonals
       do icz=1,3
       do icdp=1,2
       do icdt=1,2
        if(cd(icdp,icz).ne.0.d0.and.cd(icdt,2).ne.0.d0)then
         do iy=1,11
          e0n=10.d0**iy
          sy=2.d0*e0n*am(2)+am(2)**2+am(icz)**2
          rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*(iz-6)
           b=sqrt(-log(z)*rp)
          else
           b=sqrt(-rp*(log(0.2d0)+2.d0*(iz-7)))
           z=exp(-b*b/rp)
          endif
 
          vsoft=gsoft(icz)*sy**dels/rp*cd(icdp,icz)*cd(icdt,2)
          vgg=qgfsh(sy,b*b,icdp,icdt,icz,0)
          vqg=qgfsh(sy,b*b,icdp,icdt,icz,1)
          vgq=qgfsh(sy,b*b,icdp,icdt,icz,2)
          vqq=qghard(sy,b*b,icdp,icdt,icz)
 
          qxp=vsoft*z+vgg+vqg+vgq+vqq
          do iv=1,6
           vvx=(iv-1)/5.d0
          do iv1=1,1+5*(icz-1)*(3-icz)
           vvxp=(iv1-1)/5.d0
          do iv2=1,6
           vvxt=(iv2-1)/5.d0
 
           v3p=qg3pom(sy,b,vvx,vvxp,vvxt,icdp,icdt,icz)
           v1p=qgpcut(sy,b,vvx,vvxp,vvxt,icdp,icdt,icz)
           qxp1=qxp+v3p
           qxpc=qxp+v1p
           if(qxp1.gt.0.d0)then
            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
      *     ,icdp+2*(icdt-1)+4*(icz-1),1)=log(qxp1/z)
           else
            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
      *     +4*(icz-1),1)=min(2.d0*qpomr(iy-1,iz,iv+6*(iv1-1)
      *     +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),1)-qpomr(iy-2,iz
      *     ,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),1)
      *     ,qpomr(iy-1,iz,iv+6*(iv1-1)+36*(iv2-1)
      *     ,icdp+2*(icdt-1)+4*(icz-1),1))
           endif
           if(qxpc.gt.0.d0)then
            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
      *     ,icdp+2*(icdt-1)+4*(icz-1),2)=log(qxpc/z)
           else
            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
      *     +4*(icz-1),2)=min(2.d0*qpomr(iy-1,iz,iv+6*(iv1-1)
      *     +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),2)-qpomr(iy-2,iz
      *     ,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),2)
      *     ,qpomr(iy-1,iz,iv+6*(iv1-1)+36*(iv2-1)
      *     ,icdp+2*(icdt-1)+4*(icz-1),2))
           endif
 
           do iqq=1,2
            qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
      *     +4*(icz-1),iqq)=max(qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1)
      *     ,icdp+2*(icdt-1)+4*(icz-1),iqq),-20.d0)
 
            if(.not.(qpomr(iy,iz,iv+6*(iv1-1)+36*(iv2-1),icdp+2*(icdt-1)
      *     +4*(icz-1),iqq).le.0.d0.or.qpomr(iy,iz,iv+6*(iv1-1)
      *     +36*(iv2-1),icdp+2*(icdt-1)+4*(icz-1),iqq).gt.0.d0))
      *     stop'qpomr-nan'
           enddo
          enddo
          enddo
          enddo
         enddo
         enddo
        endif
       enddo
       enddo
       enddo
 
 c-------------------------------------------------
 c interaction cross sections
       ia(1)=1
       do iy=1,10
        e0n=10.d0**iy                               !interaction energy
        scm=2.d0*e0n*am(2)+am(2)**2+am(icz)**2
 
        do iiz=1,3
         icz=iiz                                    !hadron class
         rp=(rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0389d0 !slope (in fm^2)
         g0=pi*rp*10.d0                  !factor for cross-sections (in mb)
 
         do iia=1,6
          if(iia.le.4)then
           ia(2)=4**(iia-1)                         !target mass number
          elseif(iia.eq.5)then
           ia(2)=14
          else
           ia(2)=40
          endif
          if(debug.ge.1)write (moniou,206)e0n,ty(icz),ia(2)
 c-------------------------------------------------
 c nuclear densities
          if(ia(2).lt.10)then                       !light nuclei - gaussian
           rnuc(2)=.9d0*float(ia(2))**.3333         !nuclear radius
           wsnuc(2)=amws                            !not used
           wbnuc(2)=0.d0                            !not used
          elseif(ia(2).le.56)then                   !3-parameter Fermi
           rnuc(2)=trnuc(ia(2))                     !nuclear radius
           wsnuc(2)=twsnuc(ia(2))                   !diffuseness
           wbnuc(2)=twbnuc(ia(2))                   !'wine-bottle' parameter
          else                                      !2-parameter Fermi
 c rnuc - wood-saxon density radius (fit to the data of murthy et al.)
           rnuc(2)=1.19d0*dble(ia(2))**(1.d0/3.d0)
      *    -1.38d0*dble(ia(2))**(-1.d0/3.d0)        !nuclear radius
           wsnuc(2)=amws                            !diffuseness
           wbnuc(2)=0.d0                            !not used
          endif
 
          if(ia(2).eq.1)then               !hadron-proton interaction
           call qgfz(0.d0,gz0,0,0)
           gtot=gz0(1)                     !total cross-section
           gin=(gz0(2)+gz0(3)+gz0(4))*.5d0 !inelastic cross section
           bel=gz0(5)                      !elastic scattering slope
           gel=gtot-gin                    !elastic cross section
           gdp=gz0(3)*.5d0     !projectile low mass diffr. (+double LMD)
           gdt=gz0(4)*.5d0                 !target low mass diffraction
           if(iy.le.10)gsect(iy,icz,iia)=log(gin)
 
           if(debug.ge.1)write (moniou,225)gtot,gin,gel,gdp,gdt,bel
          else                             !hadron-nucleus interaction
           bm=rnuc(2)+dlog(29.d0)*wsnuc(2) !for numerical integration
           anorm=qganrm(rnuc(2),wsnuc(2),wbnuc(2))*rp !density normalization
           call qggau(gz1)                 !integration over b<bm
           call qggau1(gz1)                !integration over b>bm
           gin=gz1(1)+gz1(2)+gz1(3)        !inelastic cross section
           if(iy.le.10)gsect(iy,icz,iia)=log(gin*10.d0)
 
           if(debug.ge.1)write (moniou,224)
      *    gin*10.d0,gz1(3)*10.d0,gz1(2)*10.d0
          endif
          if(.not.(gsect(iy,icz,iia).le.0.d0
      *   .or.gsect(iy,icz,iia).gt.0.d0))stop'qpomr-nan'
         enddo
        enddo
       enddo
 
 c-------------------------------------------------
 c cut Pomeron leg eikonals
       if(debug.ge.1)write (moniou,223)
       do icz=1,3                                    !hadron class
       do icdp=1,2
        if(cd(icdp,icz).ne.0.d0)then
         do iy=1,51
          sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*(iz-6)
           bb=-log(z)*rp                             !impact parameter^2
          else
           bb=-rp*(log(0.2d0)+2.d0*(iz-7))
           z=exp(-bb/rp)
          endif
         do ix=1,10
          if(ix.le.5)then
           xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0)     !Pomeron LC+ momentum
          else
           xp=.2d0*(ix-5)
          endif
          sys=xp*sy
 
          vs=qgls(sys,xp,bb,icdp,icz)
          vg=qglsh(sys,xp,bb,icdp,icz,0)
          if(xp.lt..99d0)then
           vq=qglsh(sys,xp,bb,icdp,icz,1)
      *    /dsqrt(xp)*(1.d0-xp)**(ahv(icz)-ahl(icz))
          else
           vq=0.d0
          endif
          qlegc0(iy,ix,iz,icdp+2*(icz-1),1)=dlog((vs+vg+vq)/vs)
          qlegc0(iy,ix,iz,icdp+2*(icz-1),2)=dlog((vs+vg)/vs)
         enddo
         enddo
         enddo
        endif
       enddo
       enddo
 
       do icz=1,3                                    !hadron class
       do icdp=1,2
        if(cd(icdp,icz).ne.0.d0)then
         do iy=1,51
          sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*(iz-6)
           bb=-log(z)*rp                             !impact parameter^2
          else
           bb=-rp*(log(0.2d0)+2.d0*(iz-7))
           z=exp(-bb/rp)
          endif
         do ix=1,10
          if(ix.le.5)then
           xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0)     !Pomeron LC+ momentum
          else
           xp=.2d0*(ix-5)
          endif
          sys=xp*sy
 
          do iqq=1,3
           call qgloolc(sys,xp,bb,icdp,icz,iqq,fann(2*iqq-1)
      *    ,fann(2*iqq))
          enddo
          do iqq=1,6
           if(fann(iqq).gt.0.d0)then
            qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
      *     =dlog(fann(iqq)/qgls(sys,xp,bb,icdp,icz))
           else
            qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
      *     =min(2.d0*qlegc0(iy-1,ix,iz,icdp+2*(icz-1),iqq+2)
      *     -qlegc0(iy-2,ix,iz,icdp+2*(icz-1),iqq+2)
      *     ,qlegc0(iy-1,ix,iz,icdp+2*(icz-1),iqq+2))
           endif
           qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2)
      *     =max(qlegc0(iy,ix,iz,icdp+2*(icz-1),iqq+2),-20.d0)
          enddo
         enddo
         enddo
         enddo
        endif
       enddo
       enddo
 
       do icz=1,3                                    !hadron class
       do icdp=1,2                                   !diffr. eigenstate
        if(cd(icdp,icz).ne.0.d0)then
         do iv=1,11
          vvx=dble(iv-1)/10.d0
          do iy=1,51                                 !initialization
          do ix=1,10
          do iz=1,11
           do iqq=1,3
            qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *     =qlegc0(iy,ix,iz,icdp+2*(icz-1),2*iqq+1)
           enddo
          enddo
          enddo
          enddo
 
          do iy=2,51
           sy=sgap**2*(spmax/sgap**2)**((iy-1)/50.d0)
           rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
 
           do ix=1,10
           do iz=1,11
           do iqq=1,3
            qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *     =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
           enddo
           enddo
           enddo
 
           n=1
 43        n=n+1                          !number of t-channel iterations
           nrep=0
           do iz=1,11
            if(iz.gt.6)then
             z=.2d0*(iz-6)
             bb=-log(z)*rp                           !impact parameter^2
            else
             bb=-rp*(log(0.2d0)+2.d0*(iz-7))
             z=exp(-bb/rp)
            endif
           do ix=1,10
            if(ix.le.5)then
             xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0)   !Pomeron LC+ momentum
            else
             xp=.2d0*(ix-5)
            endif
            sys=xp*sy
 
            do iqq=1,3
             fann(iqq)=qglscr(sys,xp,bb,vvx,icdp,icz,iqq)
             if(fann(iqq).gt.0.d0)then
              qfan2(ix,iz,iqq)=dlog(fann(iqq)/qgls(sys,xp,bb,icdp,icz))
             elseif(iy.gt.2)then
              qfan2(ix,iz,iqq)
      *       =min(2.d0*qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *       -qlegc(iy-2,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *       ,qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)))
             else
              qfan2(ix,iz,iqq)
      *       =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
             endif
             qfan2(ix,iz,iqq)=max(qfan2(ix,iz,iqq),-20.d0)
             if(abs(qfan2(ix,iz,iqq)-qlegc(iy,ix,iv,iz
      *      ,icdp+2*(icz-1)+6*(iqq-1))).gt.1.d-3)nrep=1
            enddo
           enddo
           enddo
 
           do iz=1,11
            if(iz.gt.6)then
             z=.2d0*(iz-6)
             bb=-log(z)*rp                           !impact parameter
            else
             bb=-rp*(log(0.2d0)+2.d0*(iz-7))
             z=exp(-bb/rp)
            endif
           do ix=1,10
            if(ix.le.5)then
             xp=.2d0*(5.d0*sgap/sy)**((6-ix)/5.d0)   !Pomeron LC+ momentum
            else
             xp=.2d0*(ix-5)
            endif
            sys=xp*sy
 
           do iqq=1,3
            qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))=qfan2(ix,iz,iqq)
 
            if(.not.(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).le.0.d0
      *     .or.qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).gt.0.d0))
      *     stop'qlegc-nan'
           enddo
           enddo
           enddo
           if(nrep.eq.1.and.n.lt.50)goto 43
          enddo
         enddo
        endif
       enddo
       enddo
 
 c soft pre-evolution
       do icz=1,3                                    !hadron class
       do icdp=1,2                                   !diffr. eigenstate
        if(cd(icdp,icz).ne.0.d0)then
         do iv=1,11
          vvx=dble(iv-1)/10.d0
         do iy=1,51
          sy=sgap*(spmax/sgap)**((iy-1)/50.d0)
          rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*(iz-6)
           bb=-log(z)*rp                             !impact parameter
          else
           bb=-rp*(log(0.2d0)+2.d0*(iz-7))
           z=exp(-bb/rp)
          endif
         do ix=1,10
          if(ix.le.5)then
           xp=.2d0*(sgap/sy)**((6-ix)/5.d0)          !Pomeron LC+ momentum
          else
           xp=.2d0*(ix-5)
          endif
          sys=xp*sy
 
          if(iy.eq.1)then
           qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+18)=0.d0
           qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+24)=0.d0
          else
           do iqq=4,5
            fann(iqq)=qglh(sys,xp,bb,vvx,icdp,icz,iqq-4)
            if(fann(iqq).gt.0.d0)then
             qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *      =dlog(fann(iqq))
            elseif(iy.gt.2)then
             qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *      =min(2.d0*qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *      -qlegc(iy-2,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *      ,qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)))
            else
             qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *      =qlegc(iy-1,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
            endif
            qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1))
      *     =max(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)),-20.d0)
 
            if(.not.(qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).le.0.d0
      *     .or.qlegc(iy,ix,iv,iz,icdp+2*(icz-1)+6*(iqq-1)).gt.0.d0))
      *     stop'qlegc-nan'
           enddo
          endif
         enddo
         enddo
         enddo
         enddo
        endif
       enddo
       enddo
 
 c-------------------------------------------------
 c cut Pomeron eikonals
       if(debug.ge.1)write (moniou,226)
       do icz=1,3                                    !proj. class
       do icdp=1,2
       do icdt=1,2
        if(cd(icdp,icz).ne.0.d0.and.cd(icdt,2).ne.0.d0)then
         do iy=1,11
          sy=sgap**2*(spmax/sgap**2)**((iy-1)/10.d0)
          rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
         do iz=1,11
          if(iz.gt.6)then
           z=.2d0*(iz-6)
           bb=-log(z)*rp                             !impact parameter^2
          else
           bb=-rp*(log(0.2d0)+2.d0*(iz-7))
           z=exp(-bb/rp)
          endif
         do iv=1,11
          vvx=(iv-1)/10.d0                           !relative scr. strenth
 
         do ix1=1,10
          if(ix1.le.5)then
           xp=.2d0*(5.d0*sgap/sy)**((6-ix1)/5.d0)    !Pomeron LC+ momentum
          else
           xp=.2d0*(ix1-5)
          endif
         do ix2=1,10
          if(ix2.le.5)then
           xm=.2d0*(sgap/sy/xp)**((6-ix2)/5.d0)      !Pomeron LC- momentum
          else
           xm=.2d0*(ix2-5)
          endif
          sys=xp*xm*sy
 
          do iqq=1,4
           vv=qgcutp(sys,xp,xm,bb,vvx,icdp,icdt,icz,iqq)
           if(vv.gt.0.d0)then
            qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
      *     +12*(iqq-1))=dlog(vv/z)
           elseif(iy.gt.2)then
            qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
      *     +12*(iqq-1))=min(2.d0*qpomc(iy-1,ix1+10*(ix2-1),iz,iv
      *     ,icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1))-qpomc(iy-2
      *     ,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)+12*(iqq-1))
      *     ,qpomc(iy-1,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
      *     +12*(iqq-1)))
           else
            qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
      *     +12*(iqq-1))=qpomc(iy-1,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)
      *     +4*(icz-1)+12*(iqq-1))
           endif
            qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz-1)
      *     +12*(iqq-1))=max(qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp
      *     +2*(icdt-1)+4*(icz-1)+12*(iqq-1)),-20.d0)
 
           if(.not.(qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp+2*(icdt-1)+4*(icz
      *    -1)+12*(iqq-1)).le.0.d0.or.qpomc(iy,ix1+10*(ix2-1),iz,iv,icdp
      *    +2*(icdt-1)+4*(icz-1)+12*(iqq-1)).gt.0.d0))stop'qpomc-nan'
          enddo
         enddo
         enddo
         enddo
         enddo
         enddo
        endif
       enddo
       enddo
       enddo
 
 c-----------------------------------------------------------------------------
 c timelike Sudakov formfactor
       if(debug.ge.1)write (moniou,221)
       do m=1,2                     !parton type (1-g, 2-q)
        fsud(1,m)=0.d0
       do k=2,10
        qmax=qtf*4.d0**(1.d0+k)     !effective virtuality (qt**2/z**2/(1-z)**2)
        fsud(k,m)=qgsudt(qmax,m)
       enddo
       enddo
 c-----------------------------------------------------------------------------
 c effective virtuality (used for inversion in timelike branching)
       if(debug.ge.1)write (moniou,222)
       do m=1,2                     !parton type (1-g, 2-q)
       do k=1,10
        qlmax=1.38629d0*(k-1)
        qrt(k,1,m)=0.d0
        qrt(k,101,m)=qlmax
       do i=1,99                    !bins in Sudakov formfactor
        if(k.eq.1)then
         qrt(k,i+1,m)=0.d0
        else
         qrt(k,i+1,m)=qgroot(qlmax,.01d0*i,m)
        endif
       enddo
       enddo
       enddo
 
 c-----------------------------------------------------------------------------
 c writing cross sections to the file
       if(debug.ge.1)write (moniou,220)
       if(ifIIdat.ne.1)then
        open(1,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'qgsdat-II-04'
      * ,status='unknown')
       else                                              !used to link with nexus
        open(ifIIdat,file=fnIIdat(1:nfnIIdat),status='unknown')
       endif
       write (1,*)csborn,cs0,cstot,evk,qpomi,qpomis,qlegi,qfanu,qfanc
      *,qdfan,qpomr,gsect,qlegc0,qlegc,qpomc,fsud,qrt,qrev,fsud,qrt
       close(1)
 
 10    continue
 c-----------------------------------------------------------------------------
 c nuclear cross sections
       if(ifIIncs.ne.2)then
        inquire(file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
      * ,exist=lcalc)
       else                                                  !ctp
        inquire(file=fnIIncs(1:nfnIIncs),exist=lcalc)
       endif
 
       if(lcalc)then
        if(debug.ge.0)write (moniou,207)
        if(ifIIncs.ne.2)then
         open(2,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
      *  ,status='old')
        else                                                  !ctp
         open(ifIIncs,file=fnIIncs(1:nfnIIncs),status='old')
        endif
        read (2,*)qgsasect
        close(2)
 
       elseif(.not.producetables)then
         write(moniou,*) "Missing sectnu-II-04 file !"        
         write(moniou,*) "Please correct the defined path ",
      &"or force production ..."
         stop
 
       else
        niter=5000                   !number of iterations
        do ie=1,10
         e0n=10.d0**ie               !interaction energy (per nucleon)
        do iia1=1,6
         iap=2**iia1                 !proj. mass number
        do iia2=1,6
         if(iia2.le.4)then
          iat=4**(iia2-1)            !targ. mass number
         elseif(iia2.eq.5)then
          iat=14
         else
          iat=40
         endif
         if(debug.ge.1)write (moniou,208)e0n,iap,iat
 
         call qgini(e0n,2,iap,iat)
         call qgcrossc(niter,gtot,gprod,gabs,gdd,gqel,gcoh)
         if(debug.ge.1)write (moniou,209)gtot,gprod,gabs,gdd,gqel,gcoh
         qgsasect(ie,iia1,iia2)=log(gprod)
        enddo
        enddo
        enddo
        if(ifIIncs.ne.2)then
         open(2,file=DATDIR(1:INDEX(DATDIR,' ')-1)//'sectnu-II-04'
      *  ,status='unknown')
        else                                                  !ctp
         open(ifIIncs,file=fnIIncs(1:nfnIIncs),status='unknown')
        endif
        write (2,*)qgsasect
        close(2)
       endif
 
       if(debug.ge.3)write (moniou,218)
 201   format(2x,'qgaini: hard cross sections calculation')
 202   format(2x,'qgaini: number of rungs considered:',i2
      */4x,'starting energy bin for ordered and general ladders:',3i4)
 205   format(2x,'qgaini: pretabulation of the interaction eikonals')
 206   format(2x,'qgaini: initial particle energy:',e10.3,2x
      *,'its type:',a7,2x,'target mass number:',i2)
 207   format(2x,'qgaini: nuclear cross sections readout from the file'
      *,' sectnu-II-04')
 208   format(2x,'qgaini: initial nucleus energy:',e10.3,2x
      *,'projectile mass:',i2,2x,'target mass:',i2)
 209   format(2x,'gtot',d10.3,'  gprod',d10.3,'  gabs',d10.3
      */2x,'gdd',d10.3,'  gqel',d10.3,' gcoh',d10.3)
 210   format(2x,'qgaini - main initialization procedure')
 212   format(2x,'qgaini: integrated Pomeron leg eikonals')
 213   format(2x,'qgaini: integrated fan contributions')
 214   format(2x,'qgaini: cross sections readout from the file: ', A,2x)
 c     *,' qgsdat-II-04')
 215   format(2x,'qgaini: integrated cut fan contributions')
 c216   format(2x,'qgaini: integrated cut Pomeron eikonals')
 218   format(2x,'qgaini - end')
 220   format(2x,'qgaini: cross sections are written to the file'
      *,' qgsdat-II-04')
 221   format(2x,'qgaini: timelike Sudakov formfactor')
 222   format(2x,'qgaini: effective virtuality for inversion')
 223   format(2x,'qgaini: cut Pomeron leg eikonals')
 224   format(2x,'qgaini: hadron-nucleus cross sections:'
      */4x,'gin=',e10.3,2x,'gdifr_targ=',e10.3,2x
      *,'gdifr_proj=',e10.3)
 225   format(2x,'qgaini: hadron-proton cross sections:'
      */4x,'gtot=',e10.3,2x,'gin=',e10.3,2x,'gel=',e10.3/4x
      *,'gdifrp=',e10.3,2x,'gdifrt=',e10.3,2x,'b_el=',e10.3,2x)
 226   format(2x,'qgaini: cut Pomeron eikonals (semi-hard)')
       return
       end
 
 c=============================================================================
       subroutine qgini(e0n,icp0,iap,iat)
 c-----------------------------------------------------------------------------
 c additional initialization procedure
 c e0n  - interaction energy (per hadron/nucleon),
 c icp0 - hadron type (+-1 - pi+-, +-2 - p(p~), +-3 - n(n~),
 c                     +-4 - K+-, +-5 - K_l/s),
 c iap  - projectile mass number (1 - for a hadron),
 c iat  - target mass number
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208)
       common /qgarr1/  ia(2),icz,icp
       common /qgarr2/  scm,wp0,wm0
       common /qgarr4/  ey0(3)
       common /qgarr5/  rnuc(2),wsnuc(2),wbnuc(2),anorm
      *,cr1(2),cr2(2),cr3(2)
       common /qgarr6/  pi,bm,amws
       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
       common /qgarr10/ am(7),ammu
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr43/ moniou
       common /arr1/    trnuc(56),twsnuc(56),twbnuc(56)
       common /qgdebug/ debug
       common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3)  !used to link with nexus
      *,bqgs,bmaxqgs,bmaxnex,bminnex
 
       if(debug.ge.1)write (moniou,201)icp0,iap,iat,e0n
       icp=icp0
       ia(1)=iap
       ia(2)=iat
 
       icz=iabs(icp)/2+1  !!!!!particle class (1 - pion, 2 - nucleon, 3 - kaon)
 
       scm=2.d0*e0n*am(2)+am(2)**2+am(icz)**2   !c.m. energy squared
       ey0(1)=dsqrt(scm)/(e0n+am(2)+dsqrt(e0n-am(icz))
      **dsqrt(e0n+am(icz)))                     !Lorentz boost to lab. frame
       ey0(2)=1.d0
       ey0(3)=1.d0
       wp0=dsqrt(scm)                           !initial LC+ mometum
       wm0=wp0                                  !initial LC- mometum
 
 c-------------------------------------------------
 c nuclear radii and weights for nuclear configurations - procedure qggea
       do i=1,2
        if(ia(i).lt.10.and.ia(i).ne.1)then      !gaussian density
         rnuc(i)=.9d0*float(ia(i))**.3333       !nuclear radius
         if(ia(i).eq.2)rnuc(i)=3.16d0
 c rnuc -> rnuc * a / (a-1) - to use van-hove method (in qggea)
         rnuc(i)=rnuc(i)*dsqrt(2.d0*ia(i)/(ia(i)-1.d0))
                            !rnuc -> rnuc*a/(a-1) - to use Van-Hove method
       elseif(ia(i).ne.1)then
         if(ia(i).le.56)then                    !3-parameter Fermi
          rnuc(i)=trnuc(ia(i))                  !nuclear radius
          wsnuc(i)=twsnuc(ia(i))                !diffuseness
          wbnuc(i)=twbnuc(ia(i))                !'wine-bottle' parameter
         else
          rnuc(i)=1.19*float(ia(i))**(1./3.)-1.38*float(ia(i))**(-1./3.)
          wsnuc(i)=amws                         !diffuseness
          wbnuc(i)=0.d0
         endif
         cr1(i)=1.d0+3.d0/rnuc(i)*wsnuc(i)+6.d0/(rnuc(i)/wsnuc(i))**2
      *  +6.d0/(rnuc(i)/wsnuc(i))**3
         cr2(i)=3.d0/rnuc(i)*wsnuc(i)
         cr3(i)=3.d0/rnuc(i)*wsnuc(i)+6.d0/(rnuc(i)/wsnuc(i))**2
        endif
       enddo
 
       if(ia(1).ne.1)then                              !primary nucleus
        bm=rnuc(1)+rnuc(2)+5.d0*max(wsnuc(1),wsnuc(2)) !b-cutoff
       elseif(ia(2).ne.1)then                          !hadron-nucleus
        bm=rnuc(2)+5.d0*wsnuc(2)                       !b-cutoff
       else                                            !hadron-proton
        bm=3.d0*dsqrt((rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0398d0)
       endif
 
       bmaxqgs=bm                                      !used to link with nexus
 
       if(debug.ge.3)write (moniou,202)
 201   format(2x,'qgini - miniinitialization: particle type icp0=',
      *i2,2x,'projectile mass number iap=',i2/4x,
      *'target mass number iat=',i2,' interaction energy e0n=',e10.3)
 202   format(2x,'qgini - end')
       return
       end
 
 c=============================================================================
       double precision function qgpint(sy,bb)
 c-----------------------------------------------------------------------------
 c qgpint - interm. Pomeron eikonal
 c sy  - pomeron mass squared,
 c bb  - impact parameter squared
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr6/  pi,bm,amws
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr26/ factk,fqscal
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       if(debug.ge.2)write (moniou,201)sy,bb
 
       qgpint=0.d0
       s2min=4.d0*fqscal*qt0
       xmin=s2min/sy
       if(xmin.ge.1.d0)return
 
       xmin=xmin**(delh-dels)
 c numerical integration over z1
       do i=1,7
       do m=1,2
        z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
      * **(1.d0/(delh-dels))
        ww=z1*sy
        sjqq=qgjit(qt0,qt0,ww,2,2)  !inclusive qq cross-section
        sjqg=qgjit(qt0,qt0,ww,1,2)  !inclusive qg cross-section
        sjgg=qgjit(qt0,qt0,ww,1,1)  !inclusive gg cross-section
 
        st2=0.d0
        do j=1,7
        do k=1,2
         xx=.5d0*(1.d0+x1(j)*(2*k-3))
         xp=z1**xx
         xm=z1/xp
         glu1=qgppdi(xp,0)
         sea1=qgppdi(xp,1)
         glu2=qgppdi(xm,0)
         sea2=qgppdi(xm,1)
         st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
      *  +sea1*sea2*sjqq)
        enddo
        enddo
        rh=-alfp*dlog(z1)
        qgpint=qgpint-a1(i)*dlog(z1)/z1**delh*st2
      * *exp(-bb/(4.d0*.0389d0*rh))/rh
       enddo
       enddo
       qgpint=qgpint*(1.d0-xmin)/(delh-dels)*factk*rr**2/2.d0*pi
 
       if(debug.ge.3)write (moniou,202)qgpint
 201   format(2x,'qgpint - interm. Pomeron eikonal:'
      */4x,'sy=',e10.3,2x,'bb=',e10.3)
 202   format(2x,'qgpint=',e10.3)
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgpini(sy,bb,vvx,vvxt,iqq)
 c-----------------------------------------------------------------------
 c qgpini - intermediate gg-Pomeron eikonal
 c sy   - pomeron mass squared,
 c bb   - impact parameter squared,
 c vvx  - total / projectile screening factor,
 c vvxt - target screening factor
 c vvx  - total/projectile screening factor:
 c vvx  = 0                                                    (iqq=1,...15)
 c vvx  = 1 - exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]  (iqq=16)
 c vvx  = 1 + exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]
 c          - exp[-2*sum_{i} chi_proj(i)-sum_j chi_targ(j)]
 c          - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]    (iqq=17 uncut)
 c vvx  = 1 - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]    (iqq=17,...19)
 c vvx  = 1 - exp[-sum_{i} chi_proj(i)]                        (iqq=20,...23)
 c vvxt - target screening factor:
 c vvxt = 0                                                    (iqq=1,...19)
 c vvxt = 1 - exp[-sum_j chi_targ(j)]                          (iqq=20,...23)
 c uncut eikonals:
 c iqq=0  - single soft Pomeron
 c iqq=1  - single Pomeron
 c iqq=2  - general loop contribution
 c iqq=3  - single Pomeron end on one side
 c iqq=4  - single Pomeron ends on both sides
 c cut eikonals:
 c iqq=5  - single cut Pomeron
 c iqq=6  - single cut Pomeron with single end
 c iqq=7  - single cut Pomeron with 2 single ends
 c iqq=8  - any cuts except the complete rap-gap
 c iqq=9  - single cut Pomeron end at one side
 c iqq=10 - single cut Pomeron end at one side and single Pomeron on the other
 c iqq=11 - no rap-gap at one side
 c iqq=12 - no rap-gap at one side and single Pomeron on the other
 c iqq=13 - single cut soft Pomeron
 c iqq=14 - single cut soft Pomeron with single end
 c iqq=15 - single cut soft Pomeron with 2 single ends
 c  with proj/targ screening corrections:
 c iqq=16 - single cut Pomeron
 c iqq=17 - uncut / cut end / loop sequence
 c iqq=18 - no rap-gap at the end
 c iqq=19 - single cut Pomeron end
 c iqq=20 - diffractive cut, Puu
 c iqq=21 - diffractive cut, Puu-Puc
 c iqq=22 - diffractive cut, Pcc
 c iqq=23 - diffractive cut, Pcc+Pcu
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension wk(3),wz(3),wi(3),wj(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr20/ spmax
       common /qgarr26/ factk,fqscal
       common /qgarr39/ qpomi(51,11,15),qpomis(51,11,11,11,9)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       qgpini=0.d0
       pinm=0.d0
       s2min=4.d0*fqscal*qt0
       rp=alfp*dlog(sy)*4.d0*.0389d0
       z=exp(-bb/rp)
       if(iqq.le.1.and.(sy.le.s2min.or.iqq.eq.0))goto 1
 
       yl=log(sy/sgap)/log(spmax/sgap)*50.d0+1.d0
       k=max(1,int(1.00001d0*yl-1.d0))
       k=min(k,49)
       wk(2)=yl-k
       if(yl.le.2.d0)then
        iymax=2
        wk(1)=1.d0-wk(2)
       else
        wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
        wk(1)=1.d0-wk(2)+wk(3)
        wk(2)=wk(2)-2.d0*wk(3)
        iymax=3
       endif
 
       if(z.gt..2d0)then
        zz=5.d0*z+6.d0
       else
        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
       endif
       jz=min(9,int(zz))
       jz=max(1,jz)
       if(zz.lt.1.d0)then
        wz(2)=zz-jz
        wz(1)=1.d0-wz(2)
        izmax=2
       else
        if(jz.eq.6)jz=5
        wz(2)=zz-jz
        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
        wz(1)=1.d0-wz(2)+wz(3)
        wz(2)=wz(2)-2.d0*wz(3)
        izmax=3
       endif
 
       if(iqq.le.15)then
        iqr=iqq
        if(sy.le.sgap**2.and.iqq.le.12)iqr=1
        do l1=1,izmax
         l2=jz+l1-1
        do k1=1,iymax
         k2=k+k1-1
         qgpini=qgpini+qpomi(k2,l2,iqr)*wk(k1)*wz(l1)
        enddo
        enddo
        if(zz.lt.1.d0)then
         do k1=1,iymax
          k2=k+k1-1
          pinm=pinm+qpomi(k2,1,iqr)*wk(k1)
         enddo
         qgpini=min(qgpini,pinm)
        endif
 
       else
        vi=vvx*10.d0+1.d0
        i=max(1,int(vi))
        i=min(i,9)
        wi(2)=vi-i
        wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
        wi(1)=1.d0-wi(2)+wi(3)
        wi(2)=wi(2)-2.d0*wi(3)
 
        if(iqq.le.19)then
         do i1=1,3
          i2=i+i1-1
         do l1=1,izmax
          l2=jz+l1-1
         do k1=1,iymax
          k2=k+k1-1
          qgpini=qgpini+qpomis(k2,l2,i2,1,iqq-15)*wk(k1)*wz(l1)*wi(i1)
         enddo
         enddo
         enddo
         if(zz.lt.1.d0)then
          do i1=1,3
           i2=i+i1-1
          do k1=1,iymax
           k2=k+k1-1
           pinm=pinm+qpomis(k2,1,i2,1,iqq-15)*wk(k1)*wi(i1)
          enddo
          enddo
          qgpini=min(qgpini,pinm)
         endif
 
        else
         vj=vvxt*10.d0+1.d0
         j=max(1,int(vj))
         j=min(j,9)
         wj(2)=vj-j
         wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
         wj(1)=1.d0-wj(2)+wj(3)
         wj(2)=wj(2)-2.d0*wj(3)
         jmax=3
 
         do j1=1,jmax
          j2=j+j1-1
         do i1=1,3
          i2=i+i1-1
         do l1=1,izmax
          l2=jz+l1-1
         do k1=1,iymax
          k2=k+k1-1
          qgpini=qgpini+qpomis(k2,l2,i2,j2,iqq-15)
      *   *wk(k1)*wz(l1)*wi(i1)*wj(j1)
         enddo
         enddo
         enddo
         enddo
         if(zz.lt.1.d0)then
          do j1=1,jmax
           j2=j+j1-1
          do i1=1,3
           i2=i+i1-1
          do k1=1,iymax
           k2=k+k1-1
           pinm=pinm+qpomis(k2,1,i2,j2,iqq-15)*wk(k1)*wi(i1)*wj(j1)
          enddo
          enddo
          enddo
          qgpini=min(qgpini,pinm)
         endif
        endif
       endif
 1     qgpini=exp(qgpini)
       if(iqq.le.16.or.iqq.eq.19)qgpini=qgpini
      **sy**dels*sigs*g3p**2*z/rp*4.d0*.0389d0
       return
       end
 
 c=============================================================================
       double precision function qgleg(sy,bb,icdp,icz)
 c-----------------------------------------------------------------------------
 c qgleg - integrated Pomeron leg eikonal
 c sy  - pomeron mass squared,
 c bb  - impact parameter squared,
 c icz - hadron class
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr25/ ahv(3)
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       if(debug.ge.2)write (moniou,201)sy,bb,icz
 
       qgleg=0.d0
       if(sy.lt.1.001d0)then
        tmin=1.d0
       else
        tmin=(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels)
       endif
       if(debug.ge.3)write (moniou,203)tmin
       do i1=1,7
       do m1=1,2
        tp=1.d0-(.5d0*(1.d0+tmin)+x1(i1)*(m1-1.5d0)*(1.d0-tmin))
      * **(1./(1.+dels))
        if(tp.gt.1.d-9)then
         xp=1.d0-tp**(1.d0/(1.d0+ahl(icz)))
        else
         xp=1.d0
        endif
 
        ws=qgls(xp*sy,xp,bb,icdp,icz)
        wg=qglsh(xp*sy,xp,bb,icdp,icz,0)
        wq=qglsh(xp*sy,xp,bb,icdp,icz,1)/dsqrt(xp)
      * *(1.d0-xp)**(ahv(icz)-ahl(icz))
 
        qgleg=qgleg+a1(i1)*(ws+wg+wq)/(1.d0-tp)**dels
       enddo
       enddo
       qgleg=qgleg/2.d0/(1.+ahl(icz))/(1.d0+dels)
 
       if(debug.ge.3)write (moniou,202)qgleg
 201   format(2x,'qgleg - Pomeron leg eikonal:'
      */4x,'s=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
 202   format(2x,'qgleg=',e10.3)
 203   format(2x,'qgleg:',2x,'tmin=',e10.3)
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qglegi(sy,bb,icdp,icz,iqq)
 c-----------------------------------------------------------------------
 c qglegi - integrated Pomeron leg eikonal
 c sy   - pomeron mass squared,
 c bb   - impact parameter squared,
 c icdp - diffractive state for the hadron,
 c icz  - hadron class
 c iqq=1 - single leg Pomeron
 c iqq=2 - all loops
 c iqq=3 - single Pomeron end
 c iqq=4 - single cut Pomeron
 c iqq=5 - single cut Pomeron with single Pomeron end
 c iqq=6 - single cut Pomeron end
 c iqq=7 - no rap-gap at the end
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension wk(3),wz(3)
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr20/ spmax
       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       qglegi=0.d0
       xlegm=0.d0
       rp=(rq(icdp,icz)+alfp*log(sy))*4.d0*.0389d0
       z=exp(-bb/rp)
       if(z.gt..2d0)then
        zz=5.d0*z+6.d0
       else
        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
       endif
       jz=min(9,int(zz))
       jz=max(1,jz)
       if(zz.lt.1.d0)then
        wz(2)=zz-jz
        wz(1)=1.d0-wz(2)
        izmax=2
       else
        if(jz.eq.6)jz=5
        wz(2)=zz-jz
        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
        wz(1)=1.d0-wz(2)+wz(3)
        wz(2)=wz(2)-2.d0*wz(3)
        izmax=3
       endif
 
       yl=log(sy/sgap)/log(spmax/sgap)*50.d0+1.d0
       k=max(1,int(yl))
       k=min(k,49)
       wk(2)=yl-k
       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
       wk(1)=1.d0-wk(2)+wk(3)
       wk(2)=wk(2)-2.d0*wk(3)
       iymax=3
 
       iqr=iqq
       if(sy.le.sgap**2)iqr=1
       do l1=1,izmax
        l2=jz+l1-1
       do k1=1,iymax
        k2=k+k1-1
        qglegi=qglegi+qlegi(k2,l2,icdp,icz,iqr)*wk(k1)*wz(l1)
       enddo
       enddo
       if(zz.lt.1.d0)then
        do k1=1,iymax
         k2=k+k1-1
         xlegm=xlegm+qlegi(k2,1,icdp,icz,iqr)*wk(k1)
        enddo
        qglegi=min(qglegi,xlegm)
       endif
       qglegi=exp(qglegi)*z
      **(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
       return
       end
 
 c=============================================================================
       double precision function qgls(sy,xp,bb,icdp,icz)
 c-----------------------------------------------------------------------------
 c qgls - soft pomeron leg eikonal
 c sy   - pomeron mass squared,
 c xp   - pomeron light cone momentum,
 c bb   - impact parameter squared,
 c icdp - diffractive state for the connected hadron,
 c icz  - hadron class
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       if(debug.ge.2)write (moniou,201)sy,bb,icz
 
       rp=rq(icdp,icz)+alfp*log(sy/xp)
       qgls=sy**dels*fp(icz)*g3p*sigs/rp*exp(-bb/(4.d0*.0389d0*rp))
      **cd(icdp,icz)
 
       if(debug.ge.3)write (moniou,202)qgls
 201   format(2x,'qgls - soft pomeron leg eikonal:'
      */4x,'sy=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
 202   format(2x,'qgls=',e10.3)
       return
       end
 
 c=============================================================================
       double precision function qglsh(sy,xp,bb,icdp,icz,iqq)
 c-----------------------------------------------------------------------------
 c qglsh - unintegrated Pomeron leg eikonal
 c sy  - pomeron mass squared,
 c xp  - light cone momentum share,
 c bb  - impact parameter squared,
 c icz - hadron class
 c iqq=0 - gluon/sea quark contribution,
 c iqq=1 - valence quark contribution
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr19/ ahl(3)
       common /qgarr25/ ahv(3)
       common /qgarr26/ factk,fqscal
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       if(debug.ge.2)write (moniou,201)sy,bb,icz
 
       qglsh=0.d0
       s2min=4.d0*fqscal*qt0
       if(sy.lt.1.001d0*s2min)return
 
       xmin=(s2min/sy)**(delh-dels)
 c numerical integration over zh
       do i1=1,7
       do m1=1,2
        zh=(.5d0*(1.d0+xmin-(2*m1-3)*x1(i1)*(1.d0-xmin)))
      * **(1.d0/(delh-dels))
        ww=zh*sy         !c.m. energy squared for hard interaction
        sjqq=qgjit(qt0,qt0,ww,2,2)
        sjqg=qgjit(qt0,qt0,ww,1,2)
        sjgg=qgjit(qt0,qt0,ww,1,1)
        if(debug.ge.3)write (moniou,203)ww,sjqq+sjqg+sjgg
 
        if(iqq.eq.0)then
         stg=0.d0
         do i2=1,7
         do m2=1,2
          xx=.5d0*(1.d0+x1(i2)*(2*m2-3))
          xph=zh**xx
          xmh=zh/xph
          glu1=qgppdi(xph,0)
          sea1=qgppdi(xph,1)
          glu2=qgppdi(xmh,0)
          sea2=qgppdi(xmh,1)
          rh=rq(icdp,icz)-alfp*dlog(zh*xp)
 
          stsum=(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
      *   +sea1*sea2*sjqq)*exp(-bb/(4.d0*.0389d0*rh))/rh
          stg=stg+a1(i2)*stsum
         enddo
         enddo
         qglsh=qglsh-a1(i1)*dlog(zh)/zh**delh*stg
 
        elseif(iqq.eq.1)then
         xmh=zh
         glu2=qgppdi(xmh,0)
         sea2=qgppdi(xmh,1)
         rh=rq(icdp,icz)-alfp*dlog(zh)
 
         stq=(glu2*sjqg+sea2*sjqq)*exp(-bb/(4.d0*.0389d0*rh))/rh
         qglsh=qglsh+a1(i1)/zh**delh*stq
      *  *(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))/dsqrt(xp)
        endif
       enddo
       enddo
       if(iqq.eq.0)then
        qglsh=qglsh*rr**2*(1.d0-xmin)/(delh-dels)*fp(icz)*g3p*factk
      * /2.d0*pi*cd(icdp,icz)
       elseif(iqq.eq.1)then
        qglsh=qglsh*rr*(1.d0-xmin)/(delh-dels)*g3p*factk/4.d0
      * *cd(icdp,icz)
       endif
 
       if(debug.ge.3)write (moniou,202)qglsh
 201   format(2x,'qglsh - unintegrated Pomeron leg eikonal:'
      */4x,'s=',e10.3,2x,'b^2=',e10.3,2x,'icz=',i1)
 202   format(2x,'qglsh=',e10.3)
 203   format(2x,'qglsh:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
       return
       end
 
 c------------------------------------------------------------------------
       subroutine qgloop(sy,bb,fann,jj)
 c-----------------------------------------------------------------------
 c qgloop - intermediate Pomeron eikonal with loops
 c sy   - pomeron mass squared,
 c bb   - impact parameter squared,
 c jj=1 - uncut loops (iqq=1,...3)
 c jj=2 - cut loops (iqq=4,...11)
 c iqq=1  - general loop contribution
 c iqq=2  - single Pomeron end on one side
 c iqq=3  - single Pomeron ends on both sides
 c iqq=4  - single cut Pomeron
 c iqq=5  - single cut Pomeron with single end
 c iqq=6  - single cut Pomeron with 2 single ends
 c iqq=7  - any cuts except the complete rap-gap
 c iqq=8  - single cut Pomeron at one side
 c iqq=9  - single cut Pomeron at one side and single Pomeron on the other
 c iqq=10 - no rap-gap at one side
 c iqq=11 - no rap-gap at one side and single Pomeron on the other
 c iqq=12 - single cut soft Pomeron
 c iqq=13 - single cut soft Pomeron with single end
 c iqq=14 - single cut soft Pomeron with 2 single ends
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension fann(14)
       common /qgarr6/  pi,bm,amws
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       do iqq=1,14
        fann(iqq)=0.d0
       enddo
       if(sy.le.sgap**2)goto 1
       do ix1=1,7
       do mx1=1,2
        xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
        rp=-alfp*log(xpomr)*4.d0*.0389d0
        rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
        rp2=rp*rp1/(rp+rp1)
       do ix2=1,7
       do mx2=1,2
        z=.5d0+x1(ix2)*(mx2-1.5d0)
        bb0=-rp2*log(z)
       do ix3=1,7
       do mx3=1,2
        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
 
        vi=qgpini(xpomr*sy,bb1,0.d0,0.d0,1)
        vit=min(vi,qgpini(xpomr*sy,bb1,0.d0,0.d0,2))
        v1i0=qgpini(1.d0/xpomr,bb2,0.d0,0.d0,4)
        v1i1=min(v1i0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,3))
        v1i=min(v1i1,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,2))
        if(jj.eq.1)then
         do iqq=1,3
          if(iqq.eq.1)then
           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
      *    +min(0.d0,1.d0-exp(-vit)-vit)*(1.d0-exp(-v1i))
          elseif(iqq.eq.2)then
           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
          elseif(iqq.eq.3)then
           dpx=vi*(v1i1-v1i0)
          else
           dpx=0.d0
          endif
          fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
         enddo
 
        else
         v1ic0=min(v1i0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,7))
         v1ic1=min(v1ic0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,6))
         v1ic=min(v1ic1,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,5))
         v1icn=min(v1i,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,8))
         vict=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
         victn=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
         victg=min(victn,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
         vict1=min(victg,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
 
         vis=min(vi,qgpini(xpomr*sy,bb1,0.d0,0.d0,0))
         v1ic0s=min(v1ic0,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,15))
         v1ic1s=min(v1ic0s,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,14))
         v1ics=min(v1ic1s,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,13))
         victs=min(vict,qgpini(xpomr*sy,bb1,0.d0,0.d0,13))
         do iqq=4,14
          if(iqq.eq.4)then
           dpx=vi*(v1ic*exp(-2.d0*v1icn)-v1ic1)
      *    +vict*(exp(-2.d0*victn)-1.d0)*v1ic*exp(-2.d0*v1icn)
          elseif(iqq.eq.5)then
           dpx=vi*(v1ic*exp(-2.d0*v1icn)-v1ic1)
          elseif(iqq.eq.6)then
           dpx=vi*(v1ic1-v1ic0)
          elseif(iqq.eq.7)then
           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
      *    +.5d0*min(0.d0,1.d0-exp(-vit)-vit)*(1.d0-exp(-2.d0*v1icn))
      *    +.5d0*min(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn)
      *    *max(0.d0,1.d0-exp(-v1i)-.5d0*(1.d0-exp(-2.d0*v1icn)))
          elseif(iqq.eq.8)then
           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
      *    +vict1*(exp(-2.d0*victn)-1.d0)*(1.d0-exp(-v1i))
          elseif(iqq.eq.9)then
           dpx=vi*(v1i1-v1i0)
      *    +vict1*(exp(-2.d0*victn)-1.d0)*v1i1
          elseif(iqq.eq.10)then
           dpx=vi*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
      *    +(.5d0*max(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn
      *    *exp(-2.d0*victn))+victg*(exp(-2.d0*victn)-1.d0))
      *    *(1.d0-exp(-v1i))
          elseif(iqq.eq.11)then
           dpx=vi*(v1i1-v1i0)
      *    +(.5d0*max(0.d0,1.d0-exp(-2.d0*victn)-2.d0*victn
      *    *exp(-2.d0*victn))+victg*(exp(-2.d0*victn)-1.d0))*v1i1
          elseif(iqq.eq.12)then
           dpx=vis*(v1ics*exp(-2.d0*v1icn)-v1ic1s)
      *    +victs*(exp(-2.d0*victn)-1.d0)*v1ics*exp(-2.d0*v1icn)
          elseif(iqq.eq.13)then
           dpx=vis*(v1ics*exp(-2.d0*v1icn)-v1ic1s)
          elseif(iqq.eq.14)then
           dpx=vis*(v1ic1s-v1ic0s)
          else
           dpx=0.d0
          endif
          fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
         enddo
        endif
       enddo
       enddo
       enddo
       enddo
       enddo
       enddo
 1     dpin=qgpini(sy,bb,0.d0,0.d0,1)
       do iqq=1,11
        fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
      * +dpin
       enddo
       dpins=min(dpin,qgpini(sy,bb,0.d0,0.d0,0))
       do iqq=12,14
        fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
      * +dpins
       enddo
       return
       end
 
 c------------------------------------------------------------------------
       subroutine qgloos(sy,bb,vvx,vvxt,fann)
 c-----------------------------------------------------------------------
 c qgloos - intermediate Pomeron eikonal with screening corrections
 c sy   - pomeron mass squared,
 c bb   - impact parameter squared,
 c vvx  - total/projectile screening factor:
 c vvx  = 1 - exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]  (iqq=1)
 c vvx  = 1 + exp[-2*sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]
 c          - exp[-2*sum_{i} chi_proj(i)-sum_j chi_targ(j)]
 c          - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]    (iqq=2 uncut)
 c vvx  = 1 - exp[-sum_{i} chi_proj(i)-2*sum_j chi_targ(j)]    (iqq=2,...4)
 c vvx  = 1 - exp[-sum_{i} chi_proj(i)]                        (iqq=5,...8)
 c vvxt - target screening factor:
 c vvxt = 0                                                    (iqq=1,...4)
 c vvxt = 1 - exp[-sum_j chi_targ(j)]                          (iqq=5,...8)
 c iqq=1  - single cut Pomeron
 c iqq=2  - uncut / cut end / loop sequence
 c iqq=3  - no rap-gap at the end
 c iqq=4  - single cut Pomeron end
 c iqq=5  - diffractive cut, Puu
 c iqq=6  - diffractive cut, Puu-Puc
 c iqq=7  - diffractive cut, Pcc
 c iqq=8  - diffractive cut, Pcc+Pcu
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension fann(14)
       common /qgarr6/  pi,bm,amws
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       do iqq=1,8
        fann(iqq)=0.d0
       enddo
       if(sy.le.sgap**2)goto 1
 
       do ix1=1,7
       do mx1=1,2
        xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
        rp=-alfp*log(xpomr)*4.d0*.0389d0
        rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
        rp2=rp*rp1/(rp+rp1)
       do ix2=1,7
       do mx2=1,2
        z=.5d0+x1(ix2)*(mx2-1.5d0)
        bb0=-rp2*log(z)
       do ix3=1,7
       do mx3=1,2
        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
 
        vit=qgpini(xpomr*sy,bb1,0.d0,0.d0,2)
        vicn=min(vit,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
        vicng=min(vicn,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
        vicpe=min(vicng,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
        vic1=min(vicpe,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
 
        viu=qgpini(1.d0/xpomr,bb2,0.d0,0.d0,2)
        v1icn=min(viu,qgpini(1.d0/xpomr,bb2,0.d0,0.d0,8))
        v1i=qgpini(1.d0/xpomr,bb2,vvx,0.d0,16)*exp(-2.d0*v1icn)
        vi=qgpini(1.d0/xpomr,bb2,vvx,0.d0,17)*(1.d0-exp(-viu))
        vduu=qgpini(1.d0/xpomr,bb2,vvx,vvxt,20)*(1.d0-exp(-viu))
        vduc=max(0.d0,vduu-qgpini(1.d0/xpomr,bb2,vvx,vvxt,21)
      * *(1.d0-exp(-viu)))
        vdcc=qgpini(1.d0/xpomr,bb2,vvx,vvxt,22)*((1.d0-exp(-viu))**2
      * +(exp(2.d0*(viu-v1icn))-1.d0)*exp(-2.d0*viu))/2.d0
        vdcu=max(0.d0,qgpini(1.d0/xpomr,bb2,vvx,vvxt,23)
      * *((1.d0-exp(-viu))**2+(exp(2.d0*(viu-v1icn))-1.d0)
      * *exp(-2.d0*viu))/2.d0-vdcc)
 
        do iqq=1,8
         if(iqq.eq.1)then       !single cut Pomeron
          dpx=-vvx*v1i*vic1*exp(-2.d0*vicn)
         elseif(iqq.eq.2)then   !uncut / cut end / loop sequence
          dpx=-(1.d0-exp(-vit))*vi*vvx
         elseif(iqq.eq.3)then   !no rap-gap at the end
          dpx=-(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
      *   +vicng*exp(-2.d0*vicn))*vi*vvx
         elseif(iqq.eq.4)then   !single cut Pomeron end
          dpx=-vicpe*exp(-2.d0*vicn)*vi*vvx
         elseif(iqq.eq.5)then   !Puu
          dpx=(1.d0-exp(-vit))
      *   *(vduu*((1.d0-vvx)*(1.d0-vvxt)*(1.d0-vvx*vvxt)-1.d0)
      *   -vdcu*(1.d0-vvx)**2*(1.d0-vvxt)*vvxt)
         elseif(iqq.eq.6)then   !Puu-Puc
          dpx=(1.d0-exp(-vit))
      *   *((vduu-vduc)*((1.d0-vvx)*(1.d0-vvxt)*(1.d0-vvx*vvxt)-1.d0)
      *   -(vdcc+vdcu)*(1.d0-vvx)**2*(1.d0-vvxt)*vvxt)
         elseif(iqq.eq.7)then   !Pcc
          dpx=.5d0*((1.d0-exp(-vit))**2
      *   +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
      *   *(vdcc*((1.d0-vvx)**2*(1.d0-vvxt)**2-1.d0)
      *   -vduc*(1.d0-vvx)*(1.d0-vvxt)**2*vvx)
         elseif(iqq.eq.8)then   !Pcc+Pcu
          dpx=.5d0*((1.d0-exp(-vit))**2
      *   +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
      *   *((vdcc+vdcu)*((1.d0-vvx)**2*(1.d0-vvxt)**2-1.d0)
      *   +(vduu-vduc)*(1.d0-vvx)*(1.d0-vvxt)**2*vvx)
         else
          dpx=0.d0
         endif
         fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
        enddo
       enddo
       enddo
       enddo
       enddo
       enddo
       enddo
 1     vit=qgpini(sy,bb,0.d0,0.d0,2)
       vicn=min(vit,qgpini(sy,bb,0.d0,0.d0,8))
       vicng=min(vicn,qgpini(sy,bb,0.d0,0.d0,11))
       vicpe=min(vicng,qgpini(sy,bb,0.d0,0.d0,9))
       vic1=min(vicpe,qgpini(sy,bb,0.d0,0.d0,5))
       do iqq=1,8
        fann(iqq)=fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
        if(iqq.eq.1)then
         fann(iqq)=fann(iqq)*exp(2.d0*vicn)+vic1
        elseif(iqq.eq.3)then
         fann(iqq)=fann(iqq)+vicng*exp(-2.d0*vicn)
      *  +.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
        elseif(iqq.eq.4)then
         fann(iqq)=fann(iqq)*exp(2.d0*vicn)+vicpe
        elseif(iqq.lt.7)then
         fann(iqq)=fann(iqq)+(1.d0-exp(-vit))
        else
         fann(iqq)=fann(iqq)+.5d0*((1.d0-exp(-vit))**2
      *  +(exp(2.d0*(vit-vicn))-1.d0)*exp(-2.d0*vit))
        endif
       enddo
       return
       end
 
 c------------------------------------------------------------------------
       subroutine qglool(sy,bb,icdp,icz,fann)
 c-----------------------------------------------------------------------
 c qglool - integrated Pomeron leg eikonal with loops
 c sy   - pomeron mass squared,
 c bb   - impact parameter squared,
 c icz  - hadron class
 c iqq=1 - all
 c iqq=2 - single Pomeron end
 c iqq=3 - single cut Pomeron
 c iqq=4 - single cut Pomeron with single Pomeron end
 c iqq=5 - single cut Pomeron end
 c iqq=6 - no rap-gap at the end
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension fann(14)
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       do iqq=1,6
        fann(iqq)=0.d0
       enddo
       if(sy.le.sgap**2)goto 1
 
       do ix1=1,7
       do mx1=1,2
        xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
        rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
        rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
        rp2=rp*rp1/(rp+rp1)
       do ix2=1,7
       do mx2=1,2
        z=.5d0+x1(ix2)*(mx2-1.5d0)
        bb0=-rp2*log(z)
       do ix3=1,7
       do mx3=1,2
        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
 
        vpl=qglegi(1.d0/xpomr,bb2,icdp,icz,1)
        v1i0=qgpini(xpomr*sy,bb1,0.d0,0.d0,4)
        v1i1=min(v1i0,qgpini(xpomr*sy,bb1,0.d0,0.d0,3))
        v1i=min(v1i1,qgpini(xpomr*sy,bb1,0.d0,0.d0,2))
        v1ic0=min(v1i0,qgpini(xpomr*sy,bb1,0.d0,0.d0,7))
        v1ic1=min(v1ic0,qgpini(xpomr*sy,bb1,0.d0,0.d0,6))
        v1ic=min(v1ic1,qgpini(xpomr*sy,bb1,0.d0,0.d0,5))
        v1icn=min(v1i,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
        vicn0=min(v1i1,qgpini(xpomr*sy,bb1,0.d0,0.d0,12))
        vicn=min(vicn0,qgpini(xpomr*sy,bb1,0.d0,0.d0,11))
        vic0=min(vicn0,qgpini(xpomr*sy,bb1,0.d0,0.d0,10))
        vic1=min(vic0,qgpini(xpomr*sy,bb1,0.d0,0.d0,9))
        vicn=min(vicn,v1icn)
        vic1=min(vicn,vic1)
        do iqq=1,6
         if(iqq.eq.1)then
          dpx=vpl*(min(0.d0,1.d0-exp(-v1i)-v1i)+v1i-v1i1)
         elseif(iqq.eq.2)then
          dpx=vpl*(v1i1-v1i0)
         elseif(iqq.eq.3)then
          dpx=vpl*(v1ic*exp(-2.d0*v1icn)-v1ic1)
         elseif(iqq.eq.4)then
          dpx=vpl*(v1ic1-v1ic0)
         elseif(iqq.eq.5)then
          dpx=vpl*(vic1*exp(-2.d0*v1icn)-vic0)
         elseif(iqq.eq.6)then
          dpx=vpl*(.5d0*max(0.d0,1.d0-exp(-2.d0*v1icn)-2.d0*v1icn
      *   *exp(-2.d0*v1icn))+vicn*exp(-2.d0*v1icn)-vicn0)
         else
          dpx=0.d0
         endif
         fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
        enddo
       enddo
       enddo
       enddo
       enddo
       enddo
       enddo
 1     dlool=qglegi(sy,bb,icdp,icz,1)
       do iqq=1,6
        fann(iqq)=(fann(iqq)*log(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
      * +dlool)/(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
       enddo
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgrev(sy,bb,vvxt0,vvxt,vvxpt,vvxp0
      *,vvxpl,icdp,icz)
 c-----------------------------------------------------------------------
 c qgrev - zigzag contribution
 c sy    - c.m. energy squared,
 c bb    - impact parameter squared,
 c icdp  - diffractive state for the projectile,
 c icz   - hadron class,
 c vvxt0 = 1 - exp[-sum_j chi^(3)_targ(j)]
 c vvxt  = 1 - exp[-sum_j chi_targ(j)]
 c vvxpt = 1 - exp[-sum_{i>I} chi^(6)_proj(i)]
 c vvxp0 = 1 - exp[-sum_{i>I} chi^(3)_proj(i)]
 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       qgrev=0.d0
       if(sy.lt..999d0*sgap**2)return
 
       do ix1=1,7
       do mx1=1,2
        xpomr=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
        rp=(rq(icdp,icz)-alfp*log(xpomr))*4.d0*.0389d0
        rp1=alfp*log(xpomr*sy)*4.d0*.0389d0
        rp2=rp*rp1/(rp+rp1)
       do ix2=1,7
       do mx2=1,2
        z=.5d0+x1(ix2)*(mx2-1.5d0)
        bb0=-rp2*log(z)
       do ix3=1,7
       do mx3=1,2
        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
 
        vvx=1.d0-(1.d0-vvxt)*(1.d0-vvxpl)
        vpf=qgfani(1.d0/xpomr,bb2,vvx,0.d0,0.d0,icdp,icz,1)
 
        viu=qgpini(xpomr*sy,bb1,0.d0,0.d0,2)
        viloop=(1.d0-exp(-viu))
        vim=2.d0*min(viu,qgpini(xpomr*sy,bb1,0.d0,0.d0,8))
 
        if(vvxt.eq.0.d0)then
         vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxpl)*exp(-vpf)
         vvxtin=0.d0
         vi=max(0.d0,qgpini(xpomr*sy,bb1,vvxpin,vvxtin,21)*viloop
      *  -qgpini(xpomr*sy,bb1,vvxpin,vvxtin,23)
      *  *(viloop**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0)
 
         dpx=vi*(1.d0-exp(-vpf))
        else
         vpf0=min(vpf,qgfani(1.d0/xpomr,bb2,vvx,vvxp0,vvxpl,icdp,icz,3))
         vpft=max(vpf,qgfani(1.d0/xpomr,bb2,vvx,vvxpt,vvxpl,icdp,icz,6))
         vvxpin=1.d0-(1.d0-vvxp0)*(1.d0-vvxpl)*exp(-vpf0)
         vvxtin=vvxt0
         vi=max(0.d0,qgpini(xpomr*sy,bb1,vvxpin,vvxtin,21)*viloop
      *  -qgpini(xpomr*sy,bb1,vvxpin,vvxtin,23)
      *  *(viloop**2+(exp(2.d0*viu-vim)-1.d0)*exp(-2.d0*viu))/2.d0)
         if(vvxpt.eq.1.d0)then
          dpx=vi*(1.d0-exp(-vpft))
         else
          dpx=vi*(1.d0-exp(-vpft)+((1.d0-vvxt)**2*(max(0.d0
      *   ,1.d0-exp(-vpft)*(1.d0+vpft))-max(0.d0,1.d0-exp(-vpf0)
      *   *(1.d0+vpf0))*(1.d0-vvxp0)/(1.d0-vvxpt))
      *   +vpft*((1.d0-vvxt)**2*exp(-vpft)-exp(-vpf0)*(1.d0-vvxpl)
      *   *(1.d0-vvxp0)/(1.d0-vvxpt)*(1.d0-vvxt0)**2)
      *   -vpf0*exp(-vpf0)*(1.d0-vvxp0)/(1.d0-vvxpt)*((1.d0-vvxt)**2
      *   -(1.d0-vvxpl)*(1.d0-vvxt0)**2))/(1.d0-(1.d0-vvxt)**2))
          if(dpx.le.0.d0)dpx=vi*(1.d0-exp(-vpft))
         endif
        endif
 
        qgrev=qgrev+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
       enddo
       enddo
       enddo
       enddo
       enddo
       enddo
       qgrev=qgrev/8.d0*pi*r3p/.0389d0/g3p**3
       if(.not.(qgrev.gt.0.d0.and.qgrev.lt.1.d10))stop'qgrev=NAN'
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgrevi(sy,bb,vvxt0,vvxt,vvxpt,vvxp0
      *,vvxpl,icdp,icz)
 c-----------------------------------------------------------------------
 c qgrevi - zigzag contribution (interpolation)
 c sy    - c.m. energy squared,
 c bb    - impact parameter squared,
 c icdp  - diffractive state for the projectile,
 c icz   - hadron class,
 c vvxt0 = 1 - exp[-sum_j chi^(3)_targ(j)]
 c vvxt  = 1 - exp[-sum_j chi_targ(j)
 c vvxpt = 1 - exp[-sum_{i>I} chi^(6)_proj(i)]
 c vvxp0 = 1 - exp[-sum_{i>I} chi^(3)_proj(i)]
 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension wk(3),wz(3),wj(3),wi(3),wm2(3),wm3(3),wm4(3)
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr20/ spmax
       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       qgrevi=0.d0
       revm=0.d0
       if(sy.le.sgap**2)return
 
       rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
       z=dexp(-bb/rp)
       if(z.gt..2d0)then
        zz=5.d0*z+6.d0
       else
        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
       endif
       jz=min(9,int(zz))
       jz=max(1,jz)
       if(zz.lt.1.d0)then
        wz(2)=zz-jz
        wz(1)=1.d0-wz(2)
        izmax=2
       else
        if(jz.eq.6)jz=5
        wz(2)=zz-jz
        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
        wz(1)=1.d0-wz(2)+wz(3)
        wz(2)=wz(2)-2.d0*wz(3)
        izmax=3
       endif
 
       yl=dlog(sy/sgap**2)/dlog(spmax/sgap**2)*10.d0+1.d0
       k=max(1,int(1.00001d0*yl-1.d0))
       k=min(k,9)
       wk(2)=yl-k
       if(yl.le.2.d0)then
        iymax=2
        wk(1)=1.d0-wk(2)
       else
        wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
        wk(1)=1.d0-wk(2)+wk(3)
        wk(2)=wk(2)-2.d0*wk(3)
        iymax=3
       endif
 
       if(vvxt0.gt..99d0)then
        j=11
        wj(1)=1.d0
        ivmax=1
        i=1
        wi(1)=1.d0
        iv1max=1
       else
        vl=max(1.d0,vvxt0*10.d0+1.d0)
        j=min(int(vl),9)
        wj(2)=vl-dble(j)
        wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
        wj(1)=1.d0-wj(2)+wj(3)
        wj(2)=wj(2)-2.d0*wj(3)
        ivmax=3
 
        vl1=max(1.d0,(vvxt-vvxt0)/(1.d0-vvxt0)*5.d0+1.d0)
        i=min(int(vl1),4)
        wi(2)=vl1-dble(i)
        wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
        wi(1)=1.d0-wi(2)+wi(3)
        wi(2)=wi(2)-2.d0*wi(3)
        iv1max=3
       endif
 
       if(icz.ne.2.or.vvxpt+vvxp0+vvxpl.eq.0.d0)then !hadron (no proj. nucl. corr.)
        ll=icz+(icz-1)*(3-icz)*2
        do i1=1,iv1max
         i2=i+i1-2
        do j1=1,ivmax
         j2=j+j1-1
        do l1=1,izmax
         l2=jz+l1-1
        do k1=1,iymax
         k2=k+k1-1
         qgrevi=qgrevi+qrev(k2,l2,j2+11*i2,ll,icdp)
      *  *wk(k1)*wz(l1)*wj(j1)*wi(i1)
        enddo
        enddo
        enddo
        enddo
        if(zz.lt.1.d0)then
         do i1=1,iv1max
          i2=i+i1-2
         do j1=1,ivmax
          j2=j+j1-1
         do k1=1,iymax
          k2=k+k1-1
          revm=revm+qrev(k2,1,j2+11*i2,ll,icdp)*wk(k1)*wj(j1)*wi(i1)
         enddo
         enddo
         enddo
         qgrevi=min(qgrevi,revm)
        endif
 
       else
        vm2=max(1.d0,vvxpt*5.d0+1.d0)
        m2=min(int(vm2),5)
        wm2(2)=vm2-dble(m2)
        wm2(1)=1.d0-wm2(2)
        im2max=2
 
        if(vvxpt.lt.1.d-2)then
         m3=1
         wm3(1)=1.d0
         im3max=1
        else
         vm3=max(1.d0,vvxp0/vvxpt*5.d0+1.d0)
         m3=min(int(vm3),5)
         wm3(2)=vm3-dble(m3)
         wm3(1)=1.d0-wm3(2)
         im3max=2
        endif
 
        vm4=max(1.d0,vvxpl*5.d0+1.d0)
        m4=min(int(vm4),5)
        wm4(2)=vm4-dble(m4)
        wm4(1)=1.d0-wm4(2)
        im4max=2
 
        do mn4=1,im4max
        do mn3=1,im3max
        do mn2=1,im2max
         mn=icz+m2+mn2+6*(m3+mn3-2)+36*(m4+mn4-2)
        do i1=1,iv1max
         i2=i+i1-2
        do j1=1,ivmax
         j2=j+j1-1
        do l1=1,izmax
         l2=jz+l1-1
        do k1=1,iymax
         k2=k+k1-1
         qgrevi=qgrevi+qrev(k2,l2,j2+11*i2,mn,icdp)
      *  *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wm2(mn2)*wm3(mn3)*wm4(mn4)
        enddo
        enddo
        enddo
        enddo
        enddo
        enddo
        enddo
        if(zz.lt.1.d0)then
         do mn4=1,im4max
         do mn3=1,im3max
         do mn2=1,im2max
          mn=icz+m2+mn2+6*(m3+mn3-2)+36*(m4+mn4-2)
         do i1=1,iv1max
          i2=i+i1-2
         do j1=1,ivmax
          j2=j+j1-1
         do k1=1,iymax
          k2=k+k1-1
          revm=revm+qrev(k2,1,j2+11*i2,mn,icdp)
      *   *wk(k1)*wj(j1)*wi(i1)*wm2(mn2)*wm3(mn3)*wm4(mn4)
         enddo
         enddo
         enddo
         enddo
         enddo
         enddo
         qgrevi=min(qgrevi,revm)
        endif
       endif
       qgrevi=dexp(qgrevi)*z*dlog(sy/sgap**2)
      **(1.d0-(1.d0-vvxt)**2)*(1.d0-vvxpt)
       return
       end
 
 c------------------------------------------------------------------------
       subroutine qgfan(sy,bb,vvx,icdp,icz,fann)
 c-----------------------------------------------------------------------
 c qgfan - integrated fan-contributions
 c sy    - c.m. energy squared,
 c bb    - impact parameter squared,
 c icdp  - diffractive state for the projectile,
 c icz   - hadron class
 c vvx  = 1 - exp[-sum_j chi_targ(j) - sum_{i<I} chi_proj(i)]
 c iqq=1  - general fan with loops
 c iqq=2  - general fan with single pomeron end
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension fann(14)
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       do iqq=1,2
        fann(iqq)=0.d0
       enddo
       if(sy.le.sgap**2)goto 1
 
       do ix1=1,7
       do mx1=1,2
        xpomr1=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
        rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
        rp1=alfp*log(xpomr1*sy)*4.d0*.0389d0
        rp2=rp*rp1/(rp+rp1)
        do ix2=1,7
        do mx2=1,2
         z=.5d0+x1(ix2)*(mx2-1.5d0)
         bb0=-rp2*log(z)
        do ix3=1,7
        do mx3=1,2
         phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
         bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      *  +bb0*sin(phi)**2
         bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      *  +bb0*sin(phi)**2
 
         vpf1=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,2)
         vpf=min(vpf1,qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1))
         v1i1=qgpini(xpomr1*sy,bb1,0.d0,0.d0,3)
         v1i=min(v1i1,qgpini(xpomr1*sy,bb1,0.d0,0.d0,2))
         do iqq=1,2
          if(iqq.eq.1)then
           dpx=(1.d0-exp(-v1i))*(min(0.d0,1.d0-exp(-vpf)-vpf)
      *    *(1.d0-vvx)-vpf*vvx)
          else
           dpx=v1i1*(min(0.d0,1.d0-exp(-vpf)-vpf)*(1.d0-vvx)-vpf*vvx)
          endif
          fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
         enddo
        enddo
        enddo
        enddo
        enddo
       enddo
       enddo
 1     continue
       do iqq=1,2
        fann(iqq)=(fann(iqq)*dlog(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
      * +qglegi(sy,bb,icdp,icz,iqq+1))
      * /(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
       enddo
       return
       end
 
 c------------------------------------------------------------------------
       subroutine qgfanc(sy,bb,vvx,vvxp,vvxpl,icdp,icz,fann)
 c-----------------------------------------------------------------------
 c qgfan - cut fan-contributions
 c sy    - c.m. energy squared,
 c bb    - impact parameter squared,
 c icdp  - diffractive state for the projectile,
 c icz   - hadron class,
 c vvx   = 1 - exp[-sum_j chi_targ(j) - sum_{i<I} chi_proj(i)]
 c vvxp  = 1 - exp[-sum_{i>I} chi^(3)_proj(i)] (iqq=1,2,3)
 c vvxp  = 1 - exp[-sum_{i>I} chi^(6)_proj(i)] (iqq=4)
 c vvxp  = 1 - exp[-sum_{i>I} chi_proj(i)]     (iqq=5-9)
 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
 c iqq=1 - cut handle fan
 c iqq=2 - no rap-gap at the end
 c iqq=3 - single cut Pomeron end
 c iqq=4 - total fan-like contribution
 c iqq=5 - leg-like cut
 c iqq=6 - leg-like cut with cut handle
 c iqq=7 - single Pomeron cut
 c iqq=8 - leg-like cut with single cut Pomeron end
 c iqq=9 - leg-like cut without a rap-gap at the end
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension fann(14)
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       do iqq=1,9
        fann(iqq)=0.d0
       enddo
       if(sy.le.sgap**2)goto 1
 
       if(vvx.gt..999d0)then
        vvxs=0.d0
       else
        vvxs=(1.d0-vvx)**2/(1.d0-vvxpl)
       endif
 
       do ix1=1,7
       do mx1=1,2
        xpomr1=(sy/sgap**2)**(-.5d0-x1(ix1)*(mx1-1.5d0))/sgap
        rp=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
        rp1=alfp*log(xpomr1*sy)*4.d0*.0389d0
        rp2=rp*rp1/(rp+rp1)
        do ix2=1,7
        do mx2=1,2
         z=.5d0+x1(ix2)*(mx2-1.5d0)
         bb0=-rp2*log(z)
        do ix3=1,7
        do mx3=1,2
         phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
         bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      *  +bb0*sin(phi)**2
         bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      *  +bb0*sin(phi)**2
 
         vi=qgpini(xpomr1*sy,bb1,0.d0,0.d0,2)
         vicn=min(vi,qgpini(xpomr1*sy,bb1,0.d0,0.d0,8))
         vicgap=min(vicn,qgpini(xpomr1*sy,bb1,0.d0,0.d0,11))
         vic1p=min(vicgap,qgpini(xpomr1*sy,bb1,0.d0,0.d0,9))
         vic1=min(vic1p,qgpini(xpomr1*sy,bb1,0.d0,0.d0,5))
 
         vpf=qgfani(1.d0/xpomr1,bb2,vvx,0.d0,0.d0,icdp,icz,1)
         vpfc0=min(vpf
      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,3))
         vpfct=max(vpf
      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,6))
         vpf1p=min(vpf
      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,7))
         vpf1p0=min(vpf1p
      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,8))
         vpfc1=min(vpf1p0
      *  ,qgfani(1.d0/xpomr1,bb2,vvx,vvxp,vvxpl,icdp,icz,9))
         do iqq=1,9
          if(iqq.eq.1)then      !cut handle
           dpx=(1.d0-exp(-vi))
      *    *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
      *    +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
          elseif(iqq.eq.2)then  !no rap-gap at the end
           dpx=(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
      *    +vicgap*exp(-2.d0*vicn))
      *    *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
      *    +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
          elseif(iqq.eq.3)then  !single cut Pomeron end
           dpx=vic1p*exp(-2.d0*vicn)
      *    *(vvxs*(min(0.d0,1.d0-exp(-vpfc0)-vpfc0)
      *    +vvxp*(exp(-vpfc0)-exp(-vpf)))+vpfc0*(vvxs-1.d0))
          elseif(iqq.eq.4)then  !total fan-like contribution
           dpx=(1.d0-exp(-vi))
      *    *((1.d0-vvxpl)*(min(0.d0,1.d0-exp(-vpfct)-vpfct)
      *    +vvxp*(exp(-vpfct)-exp(-vpf)))-vpfct*vvxpl)
          elseif(iqq.eq.5)then  !leg-like cut
           dpx=(1.d0-exp(-vi))*vpf1p
      *    *((1.d0-vvx)*(1.d0-vvxpl)*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
          elseif(iqq.eq.6)then  !leg-like cut with cut handle
           dpx=(1.d0-exp(-vi))
      *    *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
      *    -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
      *    *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
          elseif(iqq.eq.7)then  !single Pomeron cut
           dpx=vic1*exp(-2.d0*vicn)
      *    *vpfc1*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
          elseif(iqq.eq.8)then  !leg-like cut with single cut Pomeron end
           dpx=vic1p*exp(-2.d0*vicn)
      *    *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
      *    -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
      *    *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
          elseif(iqq.eq.9)then  !leg-like cut without a rap-gap at the end
           dpx=(.5d0*max(0.d0,1.d0-exp(-2.d0*vicn)*(1.d0+2.d0*vicn))
      *    +vicgap*exp(-2.d0*vicn))
      *    *(vpf1p0*((1.d0-vvx)**2*(1.d0-vvxp)**2*exp(-2.d0*vpf)-1.d0)
      *    -(vpf1p-vpf1p0)*vvxs*(1.d0-vvxp)*exp(-vpf)
      *    *(1.d0-(1.d0-vvxp)*(1.d0-vvxpl)*exp(-vpf)))
          else
           dpx=0.d0
          endif
          fann(iqq)=fann(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
         enddo
        enddo
        enddo
        enddo
        enddo
       enddo
       enddo
 1     continue
       dfan=qglegi(sy,bb,icdp,icz,2)
       dfangap=min(dfan,qglegi(sy,bb,icdp,icz,7))
       dfan1p=min(dfangap,qglegi(sy,bb,icdp,icz,6))
       dfanc1=min(dfan1p,qglegi(sy,bb,icdp,icz,4))
       do iqq=1,9
        fann(iqq)=fann(iqq)*dlog(sy/sgap**2)/8.d0*pi*r3p/.0389d0/g3p**3
        if(iqq.eq.2.or.iqq.eq.9)then
         fann(iqq)=fann(iqq)+dfangap
        elseif(iqq.eq.3.or.iqq.eq.8)then
         fann(iqq)=fann(iqq)+dfan1p
        elseif(iqq.eq.7)then
         fann(iqq)=fann(iqq)+dfanc1
        else
         fann(iqq)=fann(iqq)+dfan
        endif
        fann(iqq)=fann(iqq)
      * /(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
       enddo
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgfani(sy,bb,vvx,vvxp,vvxpl
      *,icdp,icz,iqq)
 c-----------------------------------------------------------------------
 c qgfani - integrated fan-contributions
 c sy   - c.m. energy squared,
 c bb   - impact parameter squared,
 c icdp - diffractive state for the projectile,
 c icz  - hadron class,
 c vvx   = 1 - exp[-sum_j chi_targ(j) - sum_{i<I} chi_proj(i)]
 c vvxp=vvxpl=0                                (iqq=1,2)
 c vvxp  = 1 - exp[-sum_{i>I} chi^(3)_proj(i)] (iqq=3,4,5)
 c vvxp  = 1 - exp[-sum_{i>I} chi^(6)_proj(i)] (iqq=6)
 c vvxp  = 1 - exp[-sum_{i>I} chi_proj(i)]     (iqq=7-11)
 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
 c uncut fans:
 c iqq=1  - general fan with loops
 c iqq=2  - general fan with single pomeron end
 c cut fans:
 c iqq=3  - cut handle fan
 c iqq=4  - no rap-gap at the end
 c iqq=5  - single cut Pomeron end
 c iqq=6  - total fan-like contribution
 c iqq=7  - leg-like cut
 c iqq=8  - leg-like cut with cut handle
 c iqq=9  - single Pomeron cut
 c iqq=10 - leg-like cut with single cut Pomeron end
 c iqq=11 - leg-like cut without a rap-gap at the end
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension wk(3),wz(3),wj(3),wi(3),wn(3)
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr20/ spmax
       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       qgfani=0.d0
       fanm=0.d0
 
       if(sy.le.sgap**2)then
        qgfani=qglegi(sy,bb,icdp,icz,1)
        return
       endif
 
       rp=(rq(icdp,icz)+alfp*dlog(sy))*4.d0*.0389d0
       z=dexp(-bb/rp)
       if(z.gt..2d0)then
        zz=5.d0*z+6.d0
       else
        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
       endif
       jz=min(9,int(zz))
       jz=max(1,jz)
       if(zz.lt.1.d0)then
        wz(2)=zz-jz
        wz(1)=1.d0-wz(2)
        izmax=2
       else
        if(jz.eq.6)jz=5
        wz(2)=zz-jz
        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
        wz(1)=1.d0-wz(2)+wz(3)
        wz(2)=wz(2)-2.d0*wz(3)
        izmax=3
       endif
 
       yl=dlog(sy/sgap)/dlog(spmax/sgap)*50.d0+1.d0
       k=max(1,int(1.00001d0*yl-1.d0))
       k=min(k,49)
       wk(2)=yl-k
       if(yl.le.2.d0)then
        iymax=2
        wk(1)=1.d0-wk(2)
       else
        wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
        wk(1)=1.d0-wk(2)+wk(3)
        wk(2)=wk(2)-2.d0*wk(3)
        iymax=3
       endif
 
       vl=max(1.d0,vvx*10.d0+1.d0)
       if(vvx.eq.0.d0)then
        ivmax=1
        j=1
        wj(1)=1.d0
       else
        j=min(int(vl),9)
        wj(2)=vl-dble(j)
        wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
        wj(1)=1.d0-wj(2)+wj(3)
        wj(2)=wj(2)-2.d0*wj(3)
        ivmax=3
       endif
 
       if(iqq.le.2)then
        ii=icdp+2*(icz-1)
        do j1=1,ivmax
         j2=j+j1-1
        do l1=1,izmax
         l2=jz+l1-1
        do k1=1,iymax
         k2=k+k1-1
         qgfani=qgfani+qfanu(k2,l2,j2,ii,iqq)
      *  *wk(k1)*wz(l1)*wj(j1)
        enddo
        enddo
        enddo
        if(zz.lt.1.d0)then
         do j1=1,ivmax
          j2=j+j1-1
         do k1=1,iymax
          k2=k+k1-1
          fanm=fanm+qfanu(k2,1,j2,ii,iqq)*wk(k1)*wj(j1)
         enddo
         enddo
         qgfani=min(qgfani,fanm)
        endif
 
       elseif(icz.ne.2.or.vvxp+vvxpl.eq.0.d0)then  !hadron (no proj. nucl. corr.)
        ii=icdp+2*(iqq-3)
        ll=icz+(icz-1)*(3-icz)*2
        do j1=1,ivmax
         j2=j+j1-1
        do l1=1,izmax
         l2=jz+l1-1
        do k1=1,iymax
         k2=k+k1-1
         qgfani=qgfani+qfanc(k2,l2,j2,ll,ii)*wk(k1)*wz(l1)*wj(j1)
        enddo
        enddo
        enddo
        if(zz.lt.1.d0)then
         do j1=1,ivmax
          j2=j+j1-1
         do k1=1,iymax
          k2=k+k1-1
          fanm=fanm+qfanc(k2,1,j2,ll,ii)*wk(k1)*wj(j1)
         enddo
         enddo
         qgfani=min(qgfani,fanm)
        endif
 
       else
        iv1max=2
        vl1=max(1.d0,vvxp*5.d0+1.d0)
        i=min(int(vl1),5)
        wi(2)=vl1-i
        wi(1)=1.d0-wi(2)
 
        if(vvx.lt..01d0)then                 !weak (no) screening
         iv2max=1
          n=1
         wn(1)=1.d0
        else                                    !nuclear effects
         iv2max=2
         vl2=max(1.d0,vvxpl/vvx*5.d0+1.d0)
         n=min(int(vl2),5)
         wn(2)=vl2-n
         wn(1)=1.d0-wn(2)
        endif
 
        ii=icdp+2*(iqq-3)
        do n1=1,iv2max
         n2=n+n1-2
        do i1=1,iv1max
         i2=i+i1+2
        do j1=1,ivmax
         j2=j+j1-1
        do l1=1,izmax
         l2=jz+l1-1
        do k1=1,iymax
         k2=k+k1-1
         qgfani=qgfani+qfanc(k2,l2,j2,i2+6*n2,ii)
      *  *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wn(n1)
        enddo
        enddo
        enddo
        enddo
        enddo
        if(zz.lt.1.d0)then
         do n1=1,iv2max
          n2=n+n1-2
         do i1=1,iv1max
          i2=i+i1+2
         do j1=1,ivmax
          j2=j+j1-1
         do k1=1,iymax
          k2=k+k1-1
          fanm=fanm+qfanc(k2,1,j2,i2+6*n2,ii)
      *   *wk(k1)*wj(j1)*wi(i1)*wn(n1)
         enddo
         enddo
         enddo
         enddo
         qgfani=min(qgfani,fanm)
        endif
       endif
       qgfani=dexp(qgfani)*z
      **(1.d0-(1.d0-(1.d0-1.d0/sy)**(1.+ahl(icz)))**(1.+dels))
       return
       end
 
 c------------------------------------------------------------------------
       subroutine qgdfan(xpomr,xpomr1,bb,icdp,fann,nn)
 c-----------------------------------------------------------------------
 c qgdfan - diffractive fans
 c xpomr - pomeron lc momentum,
 c xpomr1 - rapgap,
 c bb    - impact parameter squared,
 c icdp - diffractive state for the projectile,
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension fann(14),dps(3)
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       icz=2
       do iqq=1,3
        fann(iqq)=0.d0
       enddo
 
       rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
       rp1=alfp*log(xpomr1/xpomr)*4.d0*.0389d0
       rp2=rp*rp1/(rp+rp1)
       do ix2=1,7
       do mx2=1,2
        z=.5d0+x1(ix2)*(mx2-1.5d0)
        bb0=-rp2*log(z)
       do ix3=1,7
       do mx3=1,2
        phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
        bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
        bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      * +bb0*sin(phi)**2
 
        vpf=qgfani(1.d0/xpomr1,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
        v1i1=qgpini(xpomr1/xpomr,bb1,0.d0,0.d0,3)
        v1i=min(v1i1,qgpini(xpomr1/xpomr,bb1,0.d0,0.d0,2))
 
        do iqq=1,2
         if(iqq.eq.1)then
          dpx=(1.d0-exp(-v1i))*(1.d0-exp(-vpf))**2
         else
          dpx=v1i1*(1.d0-exp(-vpf))**2
         endif
         fann(iqq)=fann(iqq)+a1(ix2)*a1(ix3)*dpx/z*rp2
        enddo
       enddo
       enddo
       enddo
       enddo
 
       do ix1=1,7
       do mx1=1,2
        xpomr2=xpomr1*(xpomr/xpomr1*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))
        rp=(rq(icdp,icz)-alfp*log(xpomr2))*2.d0*.0389d0
        rp1=alfp*log(xpomr2/xpomr)*4.d0*.0389d0
        rp2=rp*rp1/(rp+rp1)
        do ix2=1,7
        do mx2=1,2
         z=.5d0+x1(ix2)*(mx2-1.5d0)
         bb0=-rp2*log(z)
        do ix3=1,7
        do mx3=1,2
         phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
         bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      *  +bb0*sin(phi)**2
         bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      *  +bb0*sin(phi)**2
 
         vpf=qgfani(1.d0/xpomr2,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
         v1i=qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,2)
         dpx=(1.d0-exp(-v1i))*(1.d0-exp(-vpf))**2/2.d0
         fann(3)=fann(3)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
        enddo
        enddo
        enddo
        enddo
       enddo
       enddo
       do iqq=1,3
        fann(iqq)=fann(iqq)*(r3p*pi/.0389d0)/g3p**3/8.d0
       enddo
 
       if(nn.gt.1.and.xpomr1/xpomr.gt.sgap**2)then
        do iqq=1,3
         dps(iqq)=0.d0
        enddo
        do ix1=1,7
        do mx1=1,2
         xpomr2=xpomr1/sgap*(xpomr/xpomr1*sgap**2)
      *  **(.5d0+x1(ix1)*(mx1-1.5d0))
         rp=(rq(icdp,icz)-alfp*log(xpomr2))*2.d0*.0389d0
         rp1=alfp*log(xpomr2/xpomr)*4.d0*.0389d0
         rp2=rp*rp1/(rp+rp1)
         do ix2=1,7
         do mx2=1,2
          z=.5d0+x1(ix2)*(mx2-1.5d0)
          bb0=-rp2*log(z)
         do ix3=1,7
         do mx3=1,2
          phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
           bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      *   +bb0*sin(phi)**2
          bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      *   +bb0*sin(phi)**2
 
          vpf=qgfani(1.d0/xpomr2,bb2,0.d0,0.d0,0.d0,icdp,icz,1)
          v1i1=qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,3)
          v1i=min(v1i1,qgpini(xpomr2/xpomr,bb1,0.d0,0.d0,2))
          vpdf=qgdfani(xpomr2,xpomr1,bb2,icdp,1)
          vpdfi=qgdfani(xpomr2,xpomr1,bb2,icdp,3)
          do iqq=1,3
           if(iqq.eq.1)then
            dpx=(1.d0-exp(-v1i))*vpdf*(exp(2.d0*(vpdfi-vpf))-1.d0)
           elseif(iqq.eq.2)then
            dpx=v1i1*vpdf*(exp(2.d0*(vpdfi-vpf))-1.d0)
           elseif(iqq.eq.3)then
            dpx=(1.d0-exp(-v1i))*((exp(2.d0*vpdfi)-1.d0)*exp(-2.d0*vpf)
      *     -2.d0*vpdfi)/2.d0/dlog(xpomr1/xpomr/sgap)
           endif
           dps(iqq)=dps(iqq)+a1(ix1)*a1(ix2)*a1(ix3)*dpx/z*rp2
          enddo
         enddo
         enddo
         enddo
         enddo
        enddo
        enddo
        do iqq=1,3
         fann(iqq)=fann(iqq)+dps(iqq)*dlog(xpomr1/xpomr/sgap**2)
      *  *(r3p*pi/.0389d0)/g3p**3/8.d0
        enddo
       endif
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgdfani(xpomr,xpomr1,bb,icdp,iqq)
 c-----------------------------------------------------------------------
 c qgfani - integrated fan-contributions
 c xpomr - pomeron lc momentum,
 c xpomr1 - rapgap,
 c bb    - impact parameter squared,
 c icdp - diffractive state for the projectile,
 c icz  - hadron class
 c iqq=1 - total unintegrated,
 c iqq=2 - single end unintegrated,
 c iqq=3 - total integrated
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension wk(3),wz(3),wj(3)
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr20/ spmax
       common /qgarr27/ qlegi(51,11,2,3,7),qfanu(51,11,11,6,2)
      *,qfanc(51,11,11,39,18),qdfan(21,11,11,2,3),qrev(11,11,66,219,2)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       qgdfani=0.d0
       dfanm=0.d0
       if(xpomr*sgap**2.gt.1.d0)return
 
       icz=2
       rp=(rq(icdp,icz)-alfp*dlog(xpomr))*2.d0*.0389d0
       z=dexp(-bb/rp)
       if(z.gt..2d0)then
        zz=5.d0*z+6.d0
       else
        zz=(-bb/rp-dlog(0.2d0))/2.d0+7.d0
       endif
       jz=min(9,int(zz))
       jz=max(1,jz)
       if(zz.lt.1.d0)then
        wz(2)=zz-jz
        wz(1)=1.d0-wz(2)
        izmax=2
       else
        if(jz.eq.6)jz=5
        wz(2)=zz-jz
        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
        wz(1)=1.d0-wz(2)+wz(3)
        wz(2)=wz(2)-2.d0*wz(3)
        izmax=3
       endif
 
       if(xpomr*sgap**2.gt..9999d0)then
        k=1
        j=1
        wk(1)=1.d0
        wj(1)=1.d0
        iymax=1
        iy1max=1
       else
        yl=-dlog(xpomr*sgap**2)/dlog(1.d5/sgap**2)*20.d0+1.d0
        k=max(1,int(1.00001d0*yl-1.d0))
        k=min(k,19)
        wk(2)=yl-k
        if(yl.le.2.d0)then
         iymax=2
         wk(1)=1.d0-wk(2)
        else
         wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
         wk(1)=1.d0-wk(2)+wk(3)
         wk(2)=wk(2)-2.d0*wk(3)
         iymax=3
        endif
 
        yl1=11.d0-dlog(xpomr1*sgap)/dlog(xpomr*sgap**2)*10.d0
        j=max(1,int(yl1))
        j=min(j,9)
        wj(2)=yl1-dble(j)
        wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
        wj(1)=1.d0-wj(2)+wj(3)
        wj(2)=wj(2)-2.d0*wj(3)
        iy1max=3
       endif
 
       do l1=1,izmax
        l2=jz+l1-1
       do j1=1,iy1max
        j2=j+j1-1
       do k1=1,iymax
        k2=k+k1-1
        qgdfani=qgdfani+qdfan(k2,j2,l2,icdp,iqq)
      * *wk(k1)*wz(l1)*wj(j1)
       enddo
       enddo
       enddo
       if(zz.lt.1.d0)then
        do j1=1,iy1max
         j2=j+j1-1
        do k1=1,iymax
         k2=k+k1-1
         dfanm=dfanm+qdfan(k2,j2,1,icdp,iqq)*wk(k1)*wj(j1)
        enddo
        enddo
        qgdfani=min(qgdfani,dfanm)
       endif
       qgdfani=dexp(qgdfani)*z
       if(iqq.eq.3)qgdfani=qgdfani*max(0.d0,dlog(xpomr1/xpomr/sgap))
       return
       end
 
 c=============================================================================
       double precision function qg3pom(sy,b,vvx,vvxp,vvxt
      *,icdp,icdt,icz)
 c-----------------------------------------------------------------------
 c qg3pom - integrated 3p-contributions to the interaction eikonal
 c sy   - pomeron mass squared,
 c b    - impact parameter,
 c icdp - diffractive state for the projectile,
 c icdt - diffractive state for the target,
 c icz  - hadron class
 c vvx  = 1 - exp[-sum_{j<J} chi_targ(j) - sum_{i<I} chi_proj(i)]
 c vvxp = 1 - exp[-sum_{i>I} chi_proj(i)]
 c vvxt = 1 - exp[-sum_{j>J} chi_targ(j)]
 c------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgdebug/  debug
       common /qgarr43/ moniou
       common /arr3/   x1(7),a1(7)
 
       qg3pom=0.d0
       if(sy.le.sgap**2)return
 
       do ix1=1,7
       do mx1=1,2
        xpomr1=(sy/sgap**2)**(-(.5+x1(ix1)*(mx1-1.5)))/sgap
        rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
        rp2=(rq(icdt,2)+alfp*log(xpomr1*sy))*4.d0*.0389d0
        rp=rp1*rp2/(rp1+rp2)
       do ib1=1,7
       do mb1=1,2
        z=.5d0+x1(ib1)*(mb1-1.5d0)
        bb0=-rp*dlog(z)
       do ib2=1,7
       do mb2=1,2
        phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
        bb1=(b*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
        bb2=(b*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
 
        v1p0=qglegi(1.d0/xpomr1,bb1,icdp,icz,1)
        v1t0=qglegi(xpomr1*sy,bb2,icdt,2,1)
        v1p1=min(v1p0,qglegi(1.d0/xpomr1,bb1,icdp,icz,3))
        v1t1=min(v1t0,qglegi(xpomr1*sy,bb2,icdt,2,3))
        v1p=min(v1p1,qglegi(1.d0/xpomr1,bb1,icdp,icz,2))
        v1t=min(v1t1,qglegi(xpomr1*sy,bb2,icdt,2,2))
 
        vpf0=min(v1p,qgfani(1.d0/xpomr1,bb1
      * ,1.d0-(1.d0-vvx)*(1.d0-vvxt),0.d0,0.d0,icdp,icz,1))
        vtf0=min(v1t,qgfani(xpomr1*sy,bb2
      * ,1.d0-(1.d0-vvx)*(1.d0-vvxp),0.d0,0.d0,icdt,2,1))
 
        n=1
 1      n=n+1
        vpf=qgfani(1.d0/xpomr1,bb1
      * ,1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf0),0.d0,0.d0,icdp,icz,1)
        vtf=qgfani(xpomr1*sy,bb2
      * ,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf0),0.d0,0.d0,icdt,2,1)
        if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.lt.100)
      * then
         vpf0=vpf
         vtf0=vtf
         goto 1
        endif
 
        dpx=(1.d0-vvx)*(min(0.d0,1.d0-exp(-vpf)-vpf)
      * *min(0.d0,1.d0-exp(-vtf)-vtf)
      * +vpf*min(0.d0,1.d0-exp(-vtf)-vtf)
      * +vtf*min(0.d0,1.d0-exp(-vpf)-vpf))-vvx*vpf*vtf
      * -.5d0*(vtf-v1t)*(min(0.d0,1.d0-exp(-vpf)-vpf)
      * *(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf)
      * -vpf*(1.d0-(1.d0-vvx)*(1.d0-vvxt)*exp(-vtf)))
      * -.5d0*(vpf-v1p)*(min(0.d0,1.d0-exp(-vtf)-vtf)
      * *(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)
      * -vtf*(1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)))
      * +.5d0*(v1t-v1t1)*v1p0+.5d0*(v1p-v1p1)*v1t0
        dpx=min(1.d0,dpx)
 
        qg3pom=qg3pom+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
       enddo
       enddo
       enddo
       enddo
       enddo
       enddo
       qg3pom=qg3pom/8.d0*log(sy/sgap**2)*(r3p*pi/.0389d0)/g3p**3
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgpcut(sy,b,vvx,vvxp,vvxt
      *,icdp,icdt,icz)
 c-----------------------------------------------------------------------
 c qglool - integrated Pomeron leg eikonal with loops
 c sy   - pomeron mass squared,
 c bb   - impact parameter squared,
 c vvx  = 1 - exp[-sum_{j<J} chi_targ(j) - sum_{i<I} chi_proj(i)]
 c vvxp = 1 - exp[-sum_{i>I} chi_proj(i)]
 c vvxt = 1 - exp[-sum_{j>J} chi_targ(j)]
 c icz  - hadron class
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       qgpcut=0.d0
       if(sy.le.sgap**2)return
 
       do ix1=1,7
       do mx1=1,2
        xpomr1=(sy/sgap**2)**(-(.5+x1(ix1)*(mx1-1.5)))/sgap
        rp1=(rq(icdp,icz)-alfp*log(xpomr1))*4.d0*.0389d0
        rp2=(rq(icdt,2)+alfp*log(xpomr1*sy))*4.d0*.0389d0
        rp=rp1*rp2/(rp1+rp2)
       do ib1=1,7
       do mb1=1,2
        z=.5d0+x1(ib1)*(mb1-1.5d0)
        bb0=-rp*dlog(z)
       do ib2=1,7
       do mb2=1,2
        phi=pi*(.5d0+x1(ib2)*(mb2-1.5d0))
        bb1=(b*rp1/(rp1+rp2)+dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
        bb2=(b*rp2/(rp1+rp2)-dsqrt(bb0)*cos(phi))**2+bb0*sin(phi)**2
 
        vpl=qglegi(1.d0/xpomr1,bb1,icdp,icz,1)
        vtl=qglegi(xpomr1*sy,bb2,icdt,2,1)
        vpf0=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
      * ,0.d0,0.d0,icdp,icz,1)
        vtf0=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)
      * ,0.d0,0.d0,icdt,2,1)
 
        n=1
 1      n=n+1
        vpf=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
      * *exp(-vtf0),0.d0,0.d0,icdp,icz,1)
        vtf=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf0)
      * ,0.d0,0.d0,icdt,2,1)
        if(abs(1.d0-vpf/vpf0)+abs(1.d0-vtf/vtf0).gt.1.d-2.and.n.lt.100)
      * then
         vpf0=vpf
         vtf0=vtf
         goto 1
        endif
 
        vpls=qgfani(1.d0/xpomr1,bb1,1.d0-(1.d0-vvx)*(1.d0-vvxt)
      * *exp(-vtf),vvxp,0.d0,icdp,icz,9)
        vtls=qgfani(xpomr1*sy,bb2,1.d0-(1.d0-vvx)*(1.d0-vvxp)*exp(-vpf)
      * ,vvxt,0.d0,icdt,2,9)
        vploop0=qglegi(1.d0/xpomr1,bb1,icdp,icz,5)
        vploop=min(vploop0,qglegi(1.d0/xpomr1,bb1,icdp,icz,4))
        vtloop0=qglegi(xpomr1*sy,bb2,icdt,2,5)
        vtloop=min(vtloop0,qglegi(xpomr1*sy,bb2,icdt,2,4))
 
        dpx=(vpls*vtloop+vtls*vploop)*(((1.d0-vvx)*(1.d0-vvxp)
      * *(1.d0-vvxt))**2*exp(-2.d0*vpf-2.d0*vtf)-1.d0)
      * +vpl*(vtloop-vtloop0)+vtl*(vploop-vploop0)
 
        qgpcut=qgpcut+a1(ib1)*a1(ib2)*a1(ix1)/z*rp*dpx
       enddo
       enddo
       enddo
       enddo
       enddo
       enddo
       qgpcut=qgpcut/16.d0*log(sy/sgap**2)*(r3p*pi/.0389d0)/g3p**3
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgpomi(sy,bb,vvx,vvxp,vvxt
      *,icdp,icdt,icz,iqq)
 c-----------------------------------------------------------------------
 c qgpomi - integrated  eikonal contributions
 c sy   - pomeron mass squared,
 c bb   - impact parameter squared,
 c icdp - diffractive state for the projectile,
 c icdt - diffractive state for the target,
 c icz  - projectile class
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension wk(3),wz(3),wi(3),wj(3),wm(3)
       common /qgarr10/ am(7),ammu
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr24/ qpomr(11,11,216,12,2)
       common /qgdebug/  debug
       common /qgarr43/ moniou
 
       qgpomi=0.d0
       pomm=0.d0
       if(cd(icdp,icz).eq.0.d0.or.cd(icdt,2).eq.0.d0)return
 
       rp=(rq(icdp,icz)+rq(icdt,2)+alfp*log(sy))*4.d0*.0389d0
       z=exp(-bb/rp)
       if(z.gt..2d0)then
        zz=5.d0*z+6.d0
       else
        zz=(-bb/rp-log(0.2d0))/2.d0+7.d0
       endif
       jz=min(9,int(zz))
       jz=max(1,jz)
       if(zz.lt.1.d0)then
        wz(2)=zz-jz
        wz(1)=1.d0-wz(2)
        izmax=2
       else
        if(jz.eq.6)jz=5
        wz(2)=zz-jz
        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
        wz(1)=1.d0-wz(2)+wz(3)
        wz(2)=wz(2)-2.d0*wz(3)
        izmax=3
       endif
 
       yl=dlog10((sy-am(2)**2-am(icz)**2)/2.d0/am(2))
       k=max(1,int(yl))
       k=min(k,9)
       wk(2)=yl-k
       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
       wk(1)=1.d0-wk(2)+wk(3)
       wk(2)=wk(2)-2.d0*wk(3)
 
       ml=icdp+2*(icdt-1)+4*(icz-1)
       if(vvx+vvxp+vvxt.eq.0.d0)then  !hadron-proton (no nucl. screening)
        do l1=1,izmax
         l2=jz+l1-1
        do k1=1,3
         k2=k+k1-1
         qgpomi=qgpomi+qpomr(k2,l2,1,ml,iqq)*wk(k1)*wz(l1)
        enddo
        enddo
        if(zz.lt.1.d0)then
         do k1=1,3
          k2=k+k1-1
          pomm=pomm+qpomr(k2,1,1,ml,iqq)*wk(k1)
         enddo
         qgpomi=min(qgpomi,pomm)
        endif
       else
        vl=max(1.d0,vvx*5.d0+1.d0)
        j=min(int(vl),4)
        wj(2)=vl-j
        wj(3)=wj(2)*(wj(2)-1.d0)*.5d0
        wj(1)=1.d0-wj(2)+wj(3)
        wj(2)=wj(2)-2.d0*wj(3)
 
        if(icz.ne.2.or.vvxp.eq.0.d0)then   !hadron-nucleus (no proj. nucl. scr.)
         i1max=1
         i=1
         wi(1)=1.d0
        else
         i1max=3
         vl1=max(1.d0,vvxp*5.d0+1.d0)
         i=min(int(vl1),4)
         wi(2)=vl1-i
         wi(3)=wi(2)*(wi(2)-1.d0)*.5d0
         wi(1)=1.d0-wi(2)+wi(3)
         wi(2)=wi(2)-2.d0*wi(3)
        endif
 
        vl2=max(1.d0,vvxt*5.d0+1.d0)
        m=min(int(vl2),4)
        wm(2)=vl2-m
        wm(3)=wm(2)*(wm(2)-1.d0)*.5d0
        wm(1)=1.d0-wm(2)+wm(3)
        wm(2)=wm(2)-2.d0*wm(3)
 
        do m1=1,3
         m2=m+m1-2
        do i1=1,i1max
         i2=i+i1-2
        do j1=1,3
         j2=j+j1-1
         mij=j2+6*i2+36*m2
        do l1=1,izmax
         l2=jz+l1-1
        do k1=1,3
         k2=k+k1-1
         qgpomi=qgpomi+qpomr(k2,l2,mij,ml,iqq)
      *  *wk(k1)*wz(l1)*wj(j1)*wi(i1)*wm(m1)
        enddo
        enddo
        enddo
        enddo
        enddo
        if(zz.lt.1.d0)then
         do m1=1,3
          m2=m+m1-2
         do i1=1,i1max
          i2=i+i1-2
         do j1=1,3
          j2=j+j1-1
          mij=j2+6*i2+36*m2
         do k1=1,3
          k2=k+k1-1
          pomm=pomm+qpomr(k2,1,mij,ml,iqq)*wk(k1)*wj(j1)*wi(i1)*wm(m1)
         enddo
         enddo
         enddo
         enddo
         qgpomi=min(qgpomi,pomm)
        endif
       endif
       qgpomi=exp(qgpomi)*z
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgppdi(xp,iqq)
 c-----------------------------------------------------------------------
 c qgppdi - parton distributions in the Pomeron
 c xp    - parton LC momentum share,
 c iqq=0 - gluon
 c iqq=1 - sea quark
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr20/ spmax
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
 c... initialize
       qgppdi=0.d0
       if(debug.ge.3)write (moniou,201)xp,iqq
       if(xp.ge..9999999d0)then
        qgppdi=0.d0
       else
        if(iqq.eq.0)then                             !gluon
         qgppdi=(1.d0-xp)**betp*(1.d0-dgqq)
        elseif(iqq.eq.1)then                         !quark
         qgppdi=qgftlf(xp)*dgqq
        endif
       endif
       if(debug.ge.4)write (moniou,202)qgppdi
 
 201   format(2x,'qgppdi - parton distr. in the Pomeron (interpol.):'
      */4x,'xp=',e10.3,2x,'iqq=',i1)
 202   format(2x,'qgppdi=',e10.3)
       return
       end
 
 c=============================================================================
       double precision function qgvpdf(x,icz)
 c-----------------------------------------------------------------------------
 c qgvpdf - valence quark structure function
 c x   - Feinman x,
 c icz - hadron class
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr6/  pi,bm,amws
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr25/ ahv(3)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       qgvpdf=(qggrv(x,qt0,icz,1)+qggrv(x,qt0,icz,2))*(1.d0-x)**ahv(icz)
       return
       end
 
 c=============================================================================
       double precision function qgspdf(x,icz)
 c-----------------------------------------------------------------------------
 c qgspdf - sea quark structure function
 c x   - Feinman x,
 c icz - hadron class
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208)
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       qgspdf=0.d0
       if(x*sgap.ge.1.d0)goto 1
 
       do icdp=1,2
        rp=(rq(icdp,icz)-alfp*log(x))*2.d0*.0389d0
        if(cd(icdp,icz).ne.0.d0)then
         dps=0.d0
         do ix=1,7
         do mx=1,2
          xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
         do ib=1,7
         do mb=1,2
          z=.5d0+x1(ib)*(mb-1.5d0)
          bb=-rp*log(z)
 
          v1p1=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,2)
          v1p=min(v1p1,qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1))
          dps=dps+a1(ix)*a1(ib)*(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
      *   *qgftlf(x/xpomr)*(xpomr/x)**dels/z
         enddo
         enddo
         enddo
         enddo
         qgspdf=qgspdf-dps*dlog(x*sgap)*rp/g3p**2*pi*rr*(r3p*pi/.0389d0)
      *  *dgqq*cc(icdp,icz)
        endif
       enddo
 
 1     qgspdf=qgspdf+4.*pi*rr*fp(icz)*qgftle(x,icz)/x**dels
       return
       end
 
 c=============================================================================
       double precision function qggpdf(x,icz)
 c-----------------------------------------------------------------------------
 c qggpdf - gluon structure function (xg(x,qt0))
 c x   - Feinman x,
 c icz - hadron class
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208)
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       qggpdf=0.d0
       if(x*sgap.ge.1.d0)goto 1
 
       do icdp=1,2
        rp=(rq(icdp,icz)-alfp*log(x))*2.d0*.0389d0
        if(cd(icdp,icz).ne.0.d0)then
         dps=0.d0
         do ix=1,7
         do mx=1,2
          xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
         do ib=1,7
         do mb=1,2
          z=.5d0+x1(ib)*(mb-1.5d0)
          bb=-rp*log(z)
 
          v1p1=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,2)
          v1p=min(v1p1,qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1))
          dps=dps+a1(ix)*a1(ib)*(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
      *   *(1.d0-x/xpomr)**betp*(xpomr/x)**dels/z
         enddo
         enddo
         enddo
         enddo
         qggpdf=qggpdf-dps*dlog(x*sgap)*rp/g3p**2*pi*rr*(r3p*pi/.0389d0)
      *  *(1.d0-dgqq)*cc(icdp,icz)
        endif
       enddo
 
 1     qggpdf=qggpdf+4.*pi*rr*fp(icz)*qgftld(x,icz)/x**dels
       return
       end
 
 c=============================================================================
       double precision function qgpdfb(x,bb,icz,jj)
 c-----------------------------------------------------------------------------
 c qgpdfb - b-dependent parton momentum distributions (xf(x,b,qt0))
 c x   - Feinman x,
 c icz - hadron class
 c jj=0 - g,
 c jj=1 - q
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208)
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       qgpdfb=0.d0
       if(x*sgap.lt.1.d0)then
        do icdp=1,2
         if(cd(icdp,icz).ne.0.d0)then
          dps=0.d0
          do ix=1,7
          do mx=1,2
           xpomr=(x*sgap)**(.5d0+x1(ix)*(mx-1.5d0))/sgap
           rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
           rp1=alfp*dlog(xpomr/x)*4.d0*.0389d0
           rp2=rp1*rp/(rp1+rp)
          do ix2=1,7
          do mx2=1,2
           bb0=-rp2*log(.5d0+x1(ix2)*(mx2-1.5d0))
          do ix3=1,7
          do mx3=1,2
           phi=pi*(.5d0+x1(ix3)*(mx3-1.5d0))
           bb1=(dsqrt(bb)*rp1/(rp+rp1)-dsqrt(bb0)*cos(phi))**2
      *    +bb0*sin(phi)**2
           bb2=(dsqrt(bb)*rp/(rp+rp1)+dsqrt(bb0)*cos(phi))**2
      *    +bb0*sin(phi)**2
 
           if(jj.eq.0)then
            v1i=(1.d0-x/xpomr)**betp*(1.d0-dgqq)
           else
            v1i=qgftlf(x/xpomr)*dgqq
           endif
           v1p1=qgfani(1.d0/xpomr,bb2,0.d0,0.d0,0.d0,icdp,icz,2)
           v1p=min(v1p1,qgfani(1.d0/xpomr,bb2,0.d0,0.d0,0.d0,icdp,icz,1))
 
           dps=dps+a1(ix)*a1(ix2)*a1(ix3)*v1i
      *    *(min(0.d0,1.d0-exp(-v1p)-v1p)+v1p-v1p1)
      *    *(xpomr/x)**dels*rp/(rp1+rp)*exp(bb2/rp-bb/(rp1+rp))
          enddo
          enddo
          enddo
          enddo
          enddo
          enddo
          qgpdfb=qgpdfb-dps*dlog(x*sgap)*pi*rr*r3p/g3p**2/.0389d0/2.d0
      *   *cc(icdp,icz)
         endif
        enddo
 
        do icdp=1,2
         rp=(rq(icdp,icz)-alfp*dlog(x))*4.d0*.0389d0
         if(jj.eq.0)then
          qgpdfb=qgpdfb+4.d0*rr*fp(icz)*qgftld(x,icz)/x**dels
      *   /rp*exp(-bb/rp)*cc(icdp,icz)
         else
          qgpdfb=qgpdfb+4.d0*rr*fp(icz)*qgftle(x,icz)/x**dels
      *   /rp*exp(-bb/rp)*cc(icdp,icz)
         endif
        enddo
       endif
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgpdfi(x,bb,icz,jj)
 c-----------------------------------------------------------------------
 c qgpdfi - b-dependent parton momentum distributions
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       dimension wk(3),wz(3)
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr20/ spmax
       common /qgarr53/ qpdfb(51,11,3,2)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       qgpdfi=0.d0
       rp=(rq(1,icz)-alfp*dlog(x))*4.d0*.0389d0
       if(rp.le.1.d-10)then
        z=1.d0
       else
        z=exp(-bb/rp)
       endif
       if(z.lt..2d0*exp(-10.d0))then
        izmax=2
        jz=1
        wz(2)=5.d0*z*exp(10.d0)
        wz(1)=1.d0-wz(2)
       else
        if(z.gt..2d0)then
         zz=5.d0*z+6.d0
        else
         zz=(-bb/rp-log(0.2d0))/2.d0+7.d0
        endif
        jz=min(9,int(zz))
        jz=max(2,jz)
        if(jz.eq.6)jz=5
        wz(2)=zz-jz
        wz(3)=wz(2)*(wz(2)-1.d0)*.5d0
        wz(1)=1.d0-wz(2)+wz(3)
        wz(2)=wz(2)-2.d0*wz(3)
        izmax=3
       endif
 
       yl=-dlog(x)/log(spmax)*50.d0+1.d0
       k=max(1,int(yl))
       k=min(k,49)
       wk(2)=yl-k
       wk(3)=wk(2)*(wk(2)-1.d0)*.5d0
       wk(1)=1.d0-wk(2)+wk(3)
       wk(2)=wk(2)-2.d0*wk(3)
 
       do j1=1,izmax
        j2=jz+j1-1
       do k1=1,3
        k2=k+k1-1
        qgpdfi=qgpdfi+qpdfb(k2,j2,icz,jj+1)*wk(k1)*wz(j1)
       enddo
       enddo
       qgpdfi=exp(qgpdfi)*z*4.d0*rr*fp(icz)/x**dels/rp
       if(jj.eq.0)then
        qgpdfi=qgpdfi*qgftld(x,icz)
       else
        qgpdfi=qgpdfi*qgftle(x,icz)
       endif
       return
       end
 
 c=============================================================================
       double precision function qgdgdf(x,xpomr,icz,jj)
 c-----------------------------------------------------------------------------
 c qgdgdf - diffractive gluon pdf xpomr*g_d^3(x,xpomr,qt0)
 c x   - Feinman x,
 c icz - hadron class
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208)
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       qgdgdf=0.d0
       do icdp=1,2
       if(cd(icdp,icz).ne.0.d0)then
        dps=0.d0
        if(jj.eq.1)then
         rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
         do ib=1,7
         do mb=1,2
          z=.5d0+x1(ib)*(mb-1.5d0)
          bb=-rp*log(z)
 
          v1p=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1)
          dps=dps+a1(ib)*(1.d0-exp(-v1p))**2/z
         enddo
         enddo
         dps=dps*rp*pi*rr*(r3p*pi/.0389d0)*cc(icdp,icz)/g3p**2
      *  *(1.d0-x/xpomr)**betp*(1.d0-dgqq)*(xpomr/x)**dels
 
        elseif(jj.eq.2.and.xpomr/x.gt.sgap)then
         do ix1=1,7
         do mx1=1,2
          xpomr1=(x/xpomr*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))*xpomr/sgap
          rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
          do ib=1,7
          do mb=1,2
           z=.5d0+x1(ib)*(mb-1.5d0)
           bb=-rp*log(z)
 
           vpf=qgfani(1.d0/xpomr1,bb,0.d0,0.d0,0.d0,icdp,icz,1)
           vpdf1=qgdfani(xpomr1,xpomr,bb,icdp,2)
           vpdf=min(vpdf1,qgdfani(xpomr1,xpomr,bb,icdp,1))
           vpdfi=qgdfani(xpomr1,xpomr,bb,icdp,3)
            dpx=vpdf*exp(2.d0*vpdfi-2.d0*vpf)-vpdf1
 
           dps=dps+a1(ix1)*a1(ib)*dpx/z*rp
      *    *(1.d0-x/xpomr1)**betp*(xpomr1/x)**dels
          enddo
          enddo
         enddo
         enddo
         dps=dps*rr*pi*(r3p*pi/.0389d0)*dlog(xpomr/x/sgap)/g3p**2
      *  *(1.d0-dgqq)*cc(icdp,icz)
        endif
        qgdgdf=qgdgdf+dps
       endif
       enddo
       return
       end
 
 c=============================================================================
       double precision function qgdpdf(x,xpomr,icz,jj)
 c-----------------------------------------------------------------------------
 c qgdpdf - diffractive structure function
 c x   - Feinman x,
 c icz - hadron class
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208)
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       qgdpdf=0.d0
       do icdp=1,2
       if(cd(icdp,icz).ne.0.d0)then
        dps=0.d0
        if(jj.eq.1)then
         rp=(rq(icdp,icz)-alfp*log(xpomr))*2.d0*.0389d0
         do ib=1,7
         do mb=1,2
          z=.5d0+x1(ib)*(mb-1.5d0)
          bb=-rp*log(z)
 
          v1p=qgfani(1.d0/xpomr,bb,0.d0,0.d0,0.d0,icdp,icz,1)
          dps=dps+a1(ib)*(1.d0-exp(-v1p))**2/z
         enddo
         enddo
         dps=dps*rp*pi*rr*(r3p*pi/.0389d0)*cc(icdp,icz)/g3p**2
      *  *qgftlf(x/xpomr)*dgqq*(xpomr/x)**dels
 
        elseif(jj.eq.2.and.xpomr/x.gt.sgap)then
         do ix1=1,7
         do mx1=1,2
          xpomr1=(x/xpomr*sgap)**(.5d0+x1(ix1)*(mx1-1.5d0))*xpomr/sgap
          rp=(rq(icdp,icz)-alfp*log(xpomr1))*2.d0*.0389d0
          do ib=1,7
          do mb=1,2
           z=.5d0+x1(ib)*(mb-1.5d0)
           bb=-rp*log(z)
 
           vpf=qgfani(1.d0/xpomr1,bb,0.d0,0.d0,0.d0,icdp,icz,1)
           vpdf1=qgdfani(xpomr1,xpomr,bb,icdp,2)
           vpdf=min(vpdf1,qgdfani(xpomr1,xpomr,bb,icdp,1))
           vpdfi=qgdfani(xpomr1,xpomr,bb,icdp,3)
            dpx=vpdf*exp(2.d0*vpdfi-2.d0*vpf)-vpdf1
 
           dps=dps+a1(ix1)*a1(ib)*dpx/z*rp
      *    *qgftlf(x/xpomr1)*(xpomr1/x)**dels
          enddo
          enddo
         enddo
         enddo
         dps=dps*rr*pi*(r3p*pi/.0389d0)*dlog(xpomr/x/sgap)/g3p**2
      *  *dgqq*cc(icdp,icz)
        endif
        qgdpdf=qgdpdf+dps
       endif
       enddo
       qgdpdf=qgdpdf/4.5d0
       return
       end
 
 c=============================================================================
       double precision function qgfsh(sy,bb,icdp,icdt,icz,iqq)
 c-----------------------------------------------------------------------------
 c qgfsh - semihard interaction eikonal
 c sy  - pomeron mass squared,
 c bb  - impact parameter squared,
 c icz - hadron class
 c iqq - type of the hard interaction (0-gg, 1-q_vg, 2-gq_v)
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr25/ ahv(3)
       common /qgarr26/ factk,fqscal
       common /arr3/   x1(7),a1(7)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       if(debug.ge.2)write (moniou,201)sy,bb,iqq,icz
 
       qgfsh=0.d0
       s2min=4.d0*fqscal*qt0
       xmin=s2min/sy
       if(xmin.ge.1.d0)return
       xmin=xmin**(delh-dels)
       if(iqq.eq.1)then
        icv=icz
        icq=2
       elseif(iqq.eq.2)then
        icv=2
        icq=icz
       endif
       if(debug.ge.3)write (moniou,205)xmin,iqq
 
 c numerical integration over z1
       do i=1,7
       do m=1,2
        z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
      * **(1.d0/(delh-dels))
        ww=z1*sy
        sjqq=qgjit(qt0,qt0,ww,2,2)
        sjqg=qgjit(qt0,qt0,ww,1,2)
        sjgg=qgjit(qt0,qt0,ww,1,1)
        if(debug.ge.3)write (moniou,203)ww,sjqq+sjqg+sjgg
 
        if(iqq.eq.0)then
         st2=0.d0
         do j=1,7
         do k=1,2
          xx=.5d0*(1.d0+x1(j)*(2*k-3))
          xp=z1**xx
          xm=z1/xp
          glu1=qgftld(xp,icz)
          sea1=qgftle(xp,icz)
          glu2=qgftld(xm,2)
          sea2=qgftle(xm,2)
          st2=st2+a1(j)*(glu1*glu2*sjgg+(glu1*sea2+glu2*sea1)*sjqg
      *   +sea1*sea2*sjqq)
         enddo
         enddo
         rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(z1)
         qgfsh=qgfsh-a1(i)*dlog(z1)/z1**delh*st2
      *  *exp(-bb/(4.d0*.0389d0*rh))/rh
 
        else
         st2=0.d0
         alh=.5d0+dels
         xam=z1**alh
 
         do j=1,7
         do k=1,2
          xp=(.5d0*(1.d0+xam+x1(j)*(2*k-3)*(1.d0-xam)))**(1.d0/alh)
          xm=z1/xp
          glu=qgftld(xm,icq)
          sea=qgftle(xm,icq)
          rh=rq(icdp,icz)+rq(icdt,2)-alfp*dlog(xm)
 
          fst=(glu*sjqg+sea*sjqq)*(1.d0-xp)**ahv(icv)
      *   *(qggrv(xp,qt0,icv,1)+qggrv(xp,qt0,icv,2))/dsqrt(xp)
      *   *exp(-bb/(4.d0*.0389d0*rh))/rh
          st2=st2+a1(j)*fst
         enddo
         enddo
         st2=st2*(1.d0-xam)/alh
         qgfsh=qgfsh+a1(i)/z1**delh*st2
        endif
       enddo
       enddo
 
       if(iqq.eq.0)then
        qgfsh=qgfsh*rr**2*(1.d0-xmin)/(delh-dels)*fp(icz)*fp(2)*factk
      * /2.d0*pi*cd(icdp,icz)*cd(icdt,2)
       else
        qgfsh=qgfsh*rr*fp(icq)*(1.d0-xmin)/(delh-dels)*factk/8.d0
      * *cd(icdp,icz)*cd(icdt,2)
       endif
 
       if(debug.ge.3)write (moniou,202)qgfsh
 201   format(2x,'qgfsh - semihard interaction eikonal:'
      */4x,'sy=',e10.3,2x,'bb=',e10.3,2x,'iqq=',i1,2x,'icz=',i1)
 202   format(2x,'qgfsh=',e10.3)
 203   format(2x,'qgfsh:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
 205   format(2x,'qgfsh:',2x,'xmin=',e10.3,2x,'iqq=',i3)
       return
       end
 
 c=============================================================================
       double precision function qgftld(z,icz)
 c-----------------------------------------------------------------------------
 c qgftld - auxilliary function for semihard eikonals calculation -
 c (proportional to gluon sf: g(z)*z^(1+dels)) -
 c integration over semihard block light cone momentum share x
 c z - x-cutoff from below,
 c icz - type of the hadron to which the semihard block is connected
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr19/ ahl(3)
       common /qgarr43/ moniou
       common /qgdebug/    debug
       common /arr3/     x1(7),a1(7)
 
       if(debug.ge.2)write (moniou,201)z,icz
 
       qgftld=0.d0
       xpmin=z**(1.d0+dels)
       do i1=1,7
       do m1=1,2
        tp=1.d0-(1.d0-xpmin)*(.5d0+x1(i1)*(m1-1.5d0))
      * **(1.d0/(1.d0+ahl(icz)))
        xp=tp**(1.d0/(1.d0+dels))
        qgftld=qgftld+a1(i1)*((1.d0-xp)/(1.d0-tp))**ahl(icz)
      * *(1.d0-z/xp)**betp
       enddo
       enddo
       qgftld=qgftld*.5d0*(1.d0-xpmin)**(ahl(icz)+1.d0)
      */(ahl(icz)+1.d0)/(1.d0+dels)*(1.d0-dgqq)
 
       if(debug.ge.3)write (moniou,202)qgftld
 201   format(2x,'qgftld:',2x,'z=',e10.3,2x,'icz=',i1)
 202   format(2x,'qgftld=',e10.3)
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgftle(z,icz)
 c-----------------------------------------------------------------------
 c qgftle - auxilliary function for semihard eikonals calculation
 c (proportional to sea quark sf: q_s(z)*z^(1+dels)) -
 c integration over semihard pomeron light cone momentum share x
 c z - light cone x of the quark,
 c icz - type of the hadron to which the semihard block is connected
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr19/ ahl(3)
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       if(debug.ge.2)write (moniou,201)z,icz
 
       qgftle=0.d0
       xpmin=z**(1.d0+dels)
       do i1=1,7
       do m1=1,2
        tp=1.d0-(1.d0-xpmin)*(.5d0+x1(i1)*(m1-1.5d0))
      * **(1.d0/(1.d0+ahl(icz)))
        xp=tp**(1.d0/(1.d0+dels))
        qgftle=qgftle+a1(i1)*((1.d0-xp)/(1.d0-tp))**ahl(icz)
      * *qgftlf(z/xp)
       enddo
       enddo
       qgftle=qgftle*.5d0*(1.d0-xpmin)**(ahl(icz)+1.d0)
      */(ahl(icz)+1.d0)/(1.d0+dels)*dgqq
 
       if(debug.ge.3)write (moniou,202)qgftle
 201   format(2x,'qgftle:',2x,'z=',e10.3,2x,'icz=',i1)
 202   format(2x,'qgftle=',e10.3)
       return
       end
 
 c------------------------------------------------------------------------
       double precision function qgftlf(zz)
 c-----------------------------------------------------------------------
 c qgftlf - auxilliary function for semihard eikonals calculation
 c zz - ratio of the quark and pomeron light cone x (zz=x_G/x_P)
 c integration over quark to gluon light cone momentum ratio (z=x/x_G):
 c qgftlf=int(dz) z^dels * (1-zz/z)^betp * P_qG(z)
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr43/ moniou
       common /qgdebug/  debug
       common /arr3/   x1(7),a1(7)
 
       if(debug.ge.2)write (moniou,201)zz
 201   format(2x,'qgftlf:',2x,'zz=',e10.3)
 
       qgftlf=0.d0
       zmin=zz**(1.d0+dels)
       do i=1,7
       do m=1,2
         z=(.5d0*(1.d0+zmin+(2*m-3)*x1(i)*(1.d0-zmin)))**(1.d0/
      *  (1.d0+dels))
         qgftlf=qgftlf+a1(i)*max(1.d-9,(1.d0-zz/z))**betp
      *  *(z**2+(1.d0-z)**2)
       enddo
       enddo
       qgftlf=qgftlf*1.5d0*(1.d0-zmin)/(1.d0+dels)   !1.5=naflav/2 at Q0
 
       if(debug.ge.3)write (moniou,202)qgftlf
 202   format(2x,'qgftlf=',e10.3)
       return
       end
 
 c=============================================================================
       subroutine qgfz(b,gz,iddp1,iddp2)
 c----------------------------------------------------------------------------
 c hadron-hadron and hadron-nucleus cross sections calculation
 c----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208)
       dimension gz(5),wt1(3),wt2(3)
       common /qgarr1/  ia(2),icz,icp
       common /qgarr2/  scm,wp0,wm0
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr43/ moniou
       common /arr3/   x1(7),a1(7)
       common /qgdebug/  debug
 
       if(debug.ge.2)write (moniou,201)b,iddp1,iddp2
       do l=1,5
        gz(l)=0.d0
       enddo
       rp=(rq(1,icz)+rq(1,2)+alfp*log(scm))*4.d0*.0389d0
       g0=0.d0
       if(ia(2).eq.1.and.iddp1.eq.0.and.iddp2.eq.0)then
        g0=pi*rp*10.d0                     !normalization factor (in mb)
        bm=2.d0*dsqrt(rp)                  !impact parameter for exp. fall-down
       endif
 
       do i1=1,7
       do m=1,2
        z=.5d0+x1(i1)*(m-1.5d0)
        bb1=rp*z
        bb2=rp*(1.d0-dlog(z))
 
        do l=1,3
         wt1(l)=0.d0
         wt2(l)=0.d0
        enddo
 
        if(ia(2).eq.1)then
         do idd1=1,2
         do idd2=1,2
          vv1=exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,idd1,idd2,icz,1))
          vv2=exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,idd1,idd2,icz,1))
 
          do l=1,2
           wt1(l)=wt1(l)+cc(idd1,icz)*cc(idd2,2)*vv1**l
           wt2(l)=wt2(l)+cc(idd1,icz)*cc(idd2,2)*vv2**l
          enddo
          do idd3=1,2
           wt1(3)=wt1(3)+cc(idd1,icz)*cc(idd2,2)*cc(idd3,icz)*vv1
      *    *exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,idd3,idd2,icz,1))
           wt2(3)=wt2(3)+cc(idd1,icz)*cc(idd2,2)*cc(idd3,icz)*vv2
      *    *exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,idd3,idd2,icz,1))
          enddo
         enddo
         enddo
         do l=1,2
          gz(l)=gz(l)+a1(i1)*((1.d0-wt1(l))+(1.d0-wt2(l))/z)
         enddo
         gz(3)=gz(3)+a1(i1)*((wt1(2)-wt1(3))+(wt2(2)-wt2(3))/z)
         gz(4)=gz(4)+a1(i1)*((wt1(3)-wt1(1)**2)+(wt2(3)-wt2(1)**2)/z)
         gz(5)=gz(5)+a1(i1)*((1.d0-wt1(1))*z+(1.d0-wt2(1))/z*(1.-log(z)))
 
        else
         do idd1=1,2
         do idd2=1,2
          vv1=exp(-qgpomi(scm,bb1,0.d0,0.d0,0.d0,iddp1,idd1,icz,1)
      *   -qgpomi(scm,bb1,0.d0,0.d0,0.d0,iddp2,idd2,icz,1))
          vv2=exp(-qgpomi(scm,bb2,0.d0,0.d0,0.d0,iddp1,idd1,icz,1)
      *   -qgpomi(scm,bb2,0.d0,0.d0,0.d0,iddp2,idd2,icz,1))
 
          if(idd1.eq.idd2)then
           wt1(1)=wt1(1)+cc(idd1,2)*vv1
           wt2(1)=wt2(1)+cc(idd1,2)*vv2
          endif
          wt1(2)=wt1(2)+cc(idd1,2)*cc(idd2,2)*vv1
          wt2(2)=wt2(2)+cc(idd1,2)*cc(idd2,2)*vv2
         enddo
         enddo
         cg1=qgrot(b,dsqrt(bb1))
         cg2=qgrot(b,dsqrt(bb2))
         do l=1,2
          gz(l)=gz(l)+a1(i1)*(cg1*(1.d0-wt1(l))+cg2*(1.d0-wt2(l))/z)
         enddo
        endif
       enddo
       enddo
       if(ia(2).eq.1.and.iddp1.eq.0.and.iddp2.eq.0)then     !hadron-proton
        do l=1,5
         gz(l)=gz(l)*g0
        enddo
        gz(5)=gz(5)/gz(1)*(rq(1,icz)+rq(1,2)+alfp*log(scm))*2.d0
       endif
 
       if(debug.ge.2)write (moniou,203)gz
       if(debug.ge.3)write (moniou,202)
 201   format(2x,'qgfz - hadronic cross-sections calculation'
      */4x,'b=',e10.3,2x,'iddp=',2i3)
 202   format(2x,'qgfz - end')
 203   format(2x,'qgfz: gz=',5e10.3)
       return
       end
 
 c=============================================================================
       double precision function qghard(sy,bb,icdp,icdt,icz)
 c-----------------------------------------------------------------------------
 c qghard - hard quark-quark interaction cross-section
 c s - energy squared for the interaction (hadron-hadron),
 c icz - type of the primaty hadron (nucleon)
 c----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       common /qgarr6/  pi,bm,amws
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr18/ alm,qt0,qtf,betp,dgqq
       common /qgarr25/ ahv(3)
       common /qgarr26/ factk,fqscal
       common /arr3/   x1(7),a1(7)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       if(debug.ge.2)write (moniou,201)sy,icz
 
       qghard=0.d0
       s2min=4.d0*fqscal*qt0
       xmin=s2min/sy
       if(xmin.ge.1.d0)return
       xmin=xmin**(delh+.5d0)
 
 c numerical integration over z1
       do i=1,7
       do m=1,2
        z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))
      * **(1.d0/(delh+.5d0))
 
        st2=0.d0
        do j=1,7
        do k=1,2
         xx=.5d0*(1.d0+x1(j)*(2*k-3))
         xp=z1**xx
         xm=z1/xp
         st2=st2+a1(j)*(1.d0-xp)**ahv(icz)*(1.d0-xm)**ahv(2)
      *  *(qggrv(xp,qt0,icz,1)+qggrv(xp,qt0,icz,2))
      *  *(qggrv(xm,qt0,2,1)+qggrv(xm,qt0,2,2))/dsqrt(z1)
        enddo
        enddo
        sj=qgjit(qt0,qt0,z1*sy,2,2)
        st2=-st2*dlog(z1)*sj
        if(debug.ge.3)write (moniou,203)z1*sy,sj
 
        qghard=qghard+a1(i)/z1**delh*st2
       enddo
       enddo
       qghard=qghard*(1.d0-xmin)/(.5d0+delh)*.25d0*factk
       rh=rq(icdp,icz)+rq(icdt,2)
       qghard=qghard/(8.d0*pi*rh)*exp(-bb/(4.d0*.0389d0*rh))
      **cd(icdp,icz)*cd(icdt,2)
 
       if(debug.ge.2)write (moniou,202)qghard
 201   format(2x,'qghard - hard quark-quark interaction eikonal:'
      */2x,'s=',e10.3,2x,'icz=',i1)
 202   format(2x,'qghard=',e10.3)
 203   format(2x,'qghard:',2x,'s_hard=',e10.3,2x,'sigma_hard=',e10.3)
       return
       end
 
 c=============================================================================
       subroutine qgbdef(bba,bbb,xxa,yya,xxb,yyb,xxp,yyp,jb)
 c-----------------------------------------------------------------------
 c qgbdef - defines coordinates (xxp,yyp) of a multi-pomeron vertex
 c------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
 
       xx=xxa-xxb
       yy=yya-yyb
       bb=xx**2+yy**2
       if(bb.lt.1.d-5)then
        xxp=xxb+dsqrt(bba)
        yyp=yyb
       elseif(abs(yy).lt.1.d-8)then
        xxp=(bba-bbb+xxb**2-xxa**2)/2.d0/(xxb-xxa)
        yyp=yyb+(2*jb-3)*dsqrt(max(0.d0,bbb-(xxb-xxp)**2))
       else
        bbd=bb+bbb-bba
        discr=max(0.d0,4.d0*bb*bbb-bbd**2)
        xxp=(xx*bbd+(2*jb-3)*abs(yy)*dsqrt(discr))/2.d0/bb
        yyp=(bbd-2.d0*xx*xxp)/2.d0/yy
        xxp=xxp+xxb
        yyp=yyp+yyb
       endif
       return
       end
 
 c=============================================================================
       subroutine qgv(x,y,xb,vin,vdd,vabs)
 c xxv - eikonal dependent factor for hadron-nucleus interaction
 c (used for total and diffractive hadron-nucleus cross-sections calculation)
 c----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208)
       dimension xb(iapmax,3),vabs(2)
       common /qgarr1/  ia(2),icz,icp
       common /qgarr2/  scm,wp0,wm0
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr43/ moniou
       common /qgdebug/  debug
 
       if(debug.ge.2)write (moniou,201)x,y
 
       vin=0.d0
       vdd=0.d0
       do iddp1=1,2
        dv=0.d0
        do m=1,ia(2)
         bb=(x-xb(m,1))**2+(y-xb(m,2))**2
         dv=dv+qgpomi(scm,bb,0.d0,0.d0,0.d0,iddp1,iddt(m),icz,1)
        enddo
        dv=exp(-dv)
        vabs(iddp1)=1.d0-dv**2       !1-exp(-2 * chi_i)
        vdd=vdd+cc(iddp1,icz)*dv**2  !sum_i cc(i) exp(-2 * chi_i)
        vin=vin+cc(iddp1,icz)*dv     !sum_i cc(i) exp(-chi_i)
       enddo
       vin=1.d0-vin**2               !1-sum_ij cc(i) cc(j) exp(-chi_i-chi_j)
       vdd=vdd+vin-1.d0
           !sum_i cc(i) exp(-2*chi_i) - sum_ij cc(i) cc(j) exp(-chi_i-chi_j)
 
       if(debug.ge.3)write (moniou,202)vin,vdd,vabs
 201   format(2x,'qgv - eikonal factor: nucleon coordinates x='
      *  ,e10.3,2x,'y=',e10.3)
 202   format(2x,'vin=',e10.3,2x,'vdd=',e10.3,2x,'vabs=',2e10.3)
       return
       end
 
 
 c=============================================================================
       subroutine qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt
      *  ,vvxpl,vvxtl,ip,it)
 c-----------------------------------------------------------------------
 c qgfdf - configuration of fan contributions (cut and uncut fans)
 c xxp, yyp -  coordinates of the multi-Pomeron vertex,
 c xpomr    - LC momentum share of the multi-Pomeron vertex,
 c ip       - proj. index,
 c it       - targ. index
 c vvx   = 1 - exp[-sum_{j<J} chi_targ(j) - sum_{i<I} chi_proj(i)]
 c vvxp  = 1 - exp[-sum_{i>I} chi_proj(i)]
 c vvxt  = 1 - exp[-sum_{j>J} chi_targ(j)]
 c vvxpl = 1 - exp[-sum_{i<I} chi_proj(i)]
 c vvxtl = 1 - exp[-sum_{j<J} chi_targ(j)]
 c------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208)
       dimension vpac(iapmax),vtac(iapmax)
       common /qgarr1/  ia(2),icz,icp
       common /qgarr2/  scm,wp0,wm0
       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr43/ moniou
       common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
      *,iconb(iapmax)
       common /qgdebug/   debug
 
       if(debug.ge.3)write (moniou,201)xxp,yyp,xpomr,ip,it
 
       vvx=0.d0
       vvxp=0.d0
       vvxt=0.d0
       vvxpl=0.d0
       vvxtl=0.d0
       if(scm.le.sgap**2)return
 
       sumup0=0.d0                      !proj. fans without targ. screening
       do ipp=1,ia(1)
        if(iconab(ipp,it).eq.0)then    !no connection
                                       !(nucleon too far from the vertex)
         vpac(ipp)=0.d0
        else
         bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
         vpac(ipp)=qgfani(1.d0/xpomr,bbp,1.d0-exp(-sumup0),0.d0,0.d0
      *  ,iddp(ipp),icz,1)
         sumup0=sumup0+vpac(ipp)
        endif
       enddo
 
       sumut0=0.d0                      !targ. fans without proj. screening
       do itt=1,ia(2)
        if(iconab(ip,itt).eq.0)then     !no connection
         vtac(itt)=0.d0
        else
         bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
         vtac(itt)=qgfani(xpomr*scm,bbt,1.d0-exp(-sumut0),0.d0,0.d0
      *  ,iddt(itt),2,1)
         sumut0=sumut0+vtac(itt)
        endif
       enddo
 
       nn=0
 1     nn=nn+1
       sumup=0.d0                       !proj. fans with targ. screening
       do ipp=1,ia(1)
        if(iconab(ipp,it).eq.0)then    !no connection
         vpac(ipp)=0.d0
        else
         bbp=(xa(ipp,1)+b-xxp)**2+(xa(ipp,2)-yyp)**2
         vpac(ipp)=qgfani(1.d0/xpomr,bbp,1.d0-exp(-sumup-sumut0)
      *  ,0.d0,0.d0,iddp(ipp),icz,1)
         sumup=sumup+vpac(ipp)
        endif
       enddo
 
       sumut=0.d0                      !targ. uncut fans with proj. screening
       do itt=1,ia(2)
        if(iconab(ip,itt).eq.0)then
         vtac(itt)=0.d0
        else
         bbt=(xb(itt,1)-xxp)**2+(xb(itt,2)-yyp)**2
         vtac(itt)=qgfani(xpomr*scm,bbt,1.d0-exp(-sumut-sumup0)
      *  ,0.d0,0.d0,iddt(itt),2,1)
         sumut=sumut+vtac(itt)
        endif
       enddo
 
       if((abs(sumup-sumup0).gt..01d0.or.abs(sumut-sumut0).gt..01d0)
      *.and.nn.lt.100)then
        sumup0=sumup
        sumut0=sumut
        goto 1
       endif
 
       if(ia(1).gt.1)then
        do ipp=1,ia(1)
         if(ipp.lt.ip)then
          vvxpl=vvxpl+vpac(ipp)
         elseif(ipp.gt.ip)then
          vvxp=vvxp+vpac(ipp)
         endif
        enddo
       endif
 
       if(ia(2).gt.1)then
        do itt=1,ia(2)
         if(itt.lt.it)then
          vvxtl=vvxtl+vtac(itt)
         elseif(itt.gt.it)then
          vvxt=vvxt+vtac(itt)
         endif
        enddo
       endif
       vvx=1.d0-exp(-vvxpl-vvxtl)
       vvxp=1.d0-exp(-vvxp)
       vvxpl=1.d0-exp(-vvxpl)
       vvxt=1.d0-exp(-vvxt)
       vvxtl=1.d0-exp(-vvxtl)
       if(debug.ge.4)write (moniou,202)
 
 201   format(2x,'qgfdf - configuration of fan contributions:'
      */2x,'xxp=',e10.3,2x,'yyp=',e10.3,2x,'xpomr=',e10.3
      *,2x,'ip=',i3,2x,'it=',i3)
 202   format(2x,'qgfdf - end')
       return
       end
 
 c=============================================================================
       subroutine qgconf
 c-----------------------------------------------------------------------------
 c interaction (cut Pomeron) configuration:
 c b - impact parameter,
 c xa(1-iap,3), xb(1-iat,3) - proj. and targ. nucleon coordinates,
 c iddp(1-iap), iddt(1-iat) - proj. and targ. nucleon diffractive eigenstates,
 c icona(1-iap) - connection for proj. nucleons (0 if too far from the target),
 c iconab(1-iap,1-iat) - connection for proj.-targ. nucleons (0 if too far from
 c each other),
 c nwp, nwt - numbers of wounded proj. and targ. nucleons (inelastic or diff.),
 c iwp(1-iap), iwt(1-iat) - indexes for wounded proj. and targ. nucleons
 c (0 - intact, 1 - inel., 2,3 - diffr., -1 - recoiled from diffraction),
 c ncola(1-iap), ncolb(1-iat) - index for inel.-wounded proj. and targ. nucleons,
 c nbpom  - total number of Pomeron blocks,
 c ias(k) (ibs(k)) - index of the proj. (targ.) nucleon for k-th Pomeron block,
 c bbpom(k) - squared impact parameter (between proj. and targ.) for k-th block,
 c vvxpom(k) - relative strenth of A-screening corrections for k-th block,
 c nqs(k) - number of single Pomerons in k-th block (without cut 3P-vertexes),
 c npompr(k) - number of proj. leg Pomerons in k-th block,
 c npomtg(k) - number of targ. leg Pomerons in k-th block,
 c npomin(k) - number of interm. Pomerons (between 2 3P-vertexes) in k-th block,
 c xpopin(n,k) - LC momentum of the upper 3P-vertex for n-th interm. Pomeron
 c in k-th block,
 c xpomin(n,k) - LC momentum of the lower 3P-vertex for n-th interm. Pomeron
 c in k-th block,
 c nnpr(i,k) - proj. participant index for i-th single Pomeron in k-th block,
 c nntg(i,k) - targ. participant index for i-th single Pomeron in k-th block,
 c ilpr(i,k) - proj. index for i-th proj. leg Pomeron in k-th block,
 c iltg(i,k) - proj. index for i-th targ. leg Pomeron in k-th block,
 c lnpr(i,k) - proj. participant index for i-th proj. leg Pomeron in k-th block,
 c lntg(i,k) - targ. participant index for i-th targ. leg Pomeron in k-th block,
 c lqa(ip) - number of cut Pomerons connected to ip-th proj. nucleon (hadron),
 c lqb(it) - number of cut Pomerons connected to it-th targ. nucleon (hadron),
 c nbpi(n,ip) - block index for n-th Pomeron connected to ip-th proj. nucleon,
 c nbti(n,it) - block index for n-th Pomeron connected to it-th targ. nucleon,
 c idnpi(n,ip) - type of n-th Pomeron (0 - single, 1 - leg) connected to ip-th
 c proj. nucleon,
 c idnti(n,it) - type of n-th Pomeron (0 - single, 1 - leg) connected to it-th
 c targ. nucleon,
 c nppi(n,ip) - index in the block of n-th Pomeron connected to ip-th proj.
 c nucleon (for single Pomerons),
 c npti(n,it) - index in the block of n-th Pomeron connected to it-th targ.
 c nucleon (for single Pomerons),
 c nlpi(n,ip) - index in the block of n-th Pomeron connected to ip-th proj.
 c nucleon (for leg Pomerons),
 c nlti(n,it) - index in the block of n-th Pomeron connected to it-th targ.
 c nucleon (for leg Pomerons),
 c iprcn(ip) - index of the recoiled targ. nucleon for ip-th proj. nucleon
 c (undergoing diffraction),
 c itgcn(it) - index of the recoiled proj. nucleon for it-th targ. nucleon
 c (undergoing diffraction),
 c bpompr(n,ip) - squared impact parameter for n-th leg Pomeron connected
 c to ip-th proj. nucleon,
 c bpomtg(n,it) - squared impact parameter for n-th leg Pomeron connected
 c to it-th targ. nucleon,
 c vvxpr(n,ip) - relative strenth of A-screening corrections for n-th leg
 c Pomeron connected to ip-th proj. nucleon,
 c vvxtg(n,it) - relative strenth of A-screening corrections for n-th leg
 c Pomeron connected to it-th targ. nucleon,
 c xpompr(n,ip) - LC momentum of the 3P-vertex for n-th leg Pomeron connected
 c to ip-th proj. nucleon,
 c xpomtg(n,it) - LC momentum of the 3P-vertex for n-th leg Pomeron connected
 c to it-th targ. nucleon
 c-----------------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900,legmax=900)
       dimension xas(iapmax,3),vabs(2),vabsi(2,iapmax),wdifi(iapmax)
      *,vpac(iapmax),vtac(iapmax),xpomip(npmax),xpomim(npmax)
      *,vvxim(npmax),bpomim(npmax),xpompi(legmax),xpomti(legmax)
      *,vvxpi(legmax),vvxti(legmax),bpompi(legmax),bpomti(legmax)
      *,ipompi(legmax),ipomti(legmax),ncola(iapmax),ncolb(iapmax)
      *,wdp(2,iapmax),wdt(2,iapmax),wabs(2,2),xrapmin(100),xrapmax(100)
       common /qgarr1/  ia(2),icz,icp
       common /qgarr2/  scm,wp0,wm0
       common /qgarr4/  ey0(3)
       common /qgarr6/  pi,bm,amws
       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
       common /qgarr9/  iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
      *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
      *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
      *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
      *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
      *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
      *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
      *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
       common /qgarr10/ am(7),ammu
       common /qgarr11/ b10
       common /qgarr12/ nsp
       common /qgarr13/ nsf,iaf(iapmax)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
      *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
      *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
      *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
      *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
      *,bpomin(npmax,npbmax)
       common /qgarr43/ moniou
       common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
      *,iconb(iapmax)
       common /qgarr55/ nwt,nwp       !N of wounded targ.(proj.) nucleons
       common /qgarr56/ nspec,nspect  !N of spectators targ.(proj.) nucleons
       common /qgdebug/  debug
       common /qgsIInex1/xan(iapmax,3),xbn(iapmax,3) !used to link with nexus
      *,bqgs,bmaxqgs,bmaxnex,bminnex
       common/jdiff/bdiff,jdiff     !for external use: impact parameter
                                    !for diffraction, diffraction type
 ctp from epos
       integer ng1evt,ng2evt,ikoevt
       real    rglevt,sglevt,eglevt,fglevt,typevt
       common/c2evt/ng1evt,ng2evt,rglevt,sglevt,eglevt,fglevt,ikoevt
      *,typevt            !in epos.inc
 
       external qgran
 
       if(debug.ge.1)write (moniou,201)
       nsp=0
       nsf=0
       nsp0=nsp
 
 c initialization
 1     continue
       do i=1,ia(1)
        iddp(i)=1+int(qgran(b10)+cc(2,icz)) !diffractive eigenstates for proj.
       enddo
       do i=1,ia(2)
        iddt(i)=1+int(qgran(b10)+cc(2,2))   !diffractive eigenstates for targ.
       enddo
 
 c-------------------------------------------------
 c squared impact parameter is sampled uniformly (b**2<bm**2)
       b=bm*dsqrt(qgran(b10))
       if(debug.ge.1)write (moniou,202)b
 
       if(bmaxnex.ge.0.d0)then              !used to link with nexus
        b1=bminnex
        b2=min(bm,bmaxnex)
        if(b1.gt.b2)stop'bmin > bmax in qgsjet'
        b=dsqrt(b1*b1+(b2*b2-b1*b1)*qgran(b10))
        bqgs=b
       endif
 
 c-------------------------------------------------
 c nuclear configurations
       if(debug.ge.1)write (moniou,203)
       if(ia(1).gt.1)then          !projectile nucleon coordinates
        call qggea(ia(1),xa,1)     !xa(n,i), i=1,2,3 - x,y,z for n-th nucleon
       else
        do i=1,3
         xa(1,i)=0.d0              !projectile hadron
        enddo
       endif
       if(ia(2).gt.1)then          !target nucleon coordinates
        call qggea(ia(2),xb,2)     !xb(n,i), i=1,2,3 - x,y,z for n-th nucleon
       else
        do i=1,3
         xb(1,i)=0.d0              !target proton
        enddo
       endif
 
 c-------------------------------------------------
 c check connections
       if(debug.ge.1)write (moniou,204)
       do it=1,ia(2)
        iconb(it)=0
       enddo
 
       do ip=1,ia(1)
        icdp=iddp(ip)
        icona(ip)=0
        do it=1,ia(2)
         icdt=iddt(it)
         bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
         vv1p=qgpomi(scm,bbp,0.d0,0.d0,0.d0,icdp,icdt,icz,1)
         if(vv1p.gt.1.d-3)then
          if(debug.ge.2)write (moniou,205)ip,it
          iconab(ip,it)=1
          icona(ip)=1
          iconb(it)=1
          if(debug.ge.2)write (moniou,206)ip
          if(debug.ge.2)write (moniou,207)it
         else
          iconab(ip,it)=0
         endif
        enddo
       enddo
 
       nrej=0
 2     nrej=nrej+1
       if(debug.ge.2)write (moniou,208)nrej
       if(nrej.gt.10)then
        if(debug.ge.1)write (moniou,209)
        goto 1
       endif
       nsp=nsp0
       nbpom=0
       nwp=0
       nwt=0
       do i=1,ia(1)
        lqa(i)=0
        iwp(i)=0
        ncola(i)=0
        wdp(1,i)=0.d0
        wdp(2,i)=0.d0
       enddo
       do i=1,ia(2)
        lqb(i)=0
        iwt(i)=0
        ncolb(i)=0
        wdt(1,i)=0.d0
        wdt(2,i)=0.d0
       enddo
       nqs(1)=0
       npomin(1)=0
       npompr(1)=0
       npomtg(1)=0
 
 c-------------------------------------------------
 c Pomeron configuration
       if(debug.ge.1)write (moniou,210)
       do 4 ip=1,ia(1)             !loop over all projectile nucleons
        if(debug.ge.2)write (moniou,211)ip
        if(icona(ip).eq.0)goto 4
        x=xa(ip,1)+b               !proj. x is shifted by the impact parameter b
        y=xa(ip,2)
        icdp=iddp(ip)              !diffr. eigenstate for ip
 
        do 3 it=1,ia(2)            !loop over all target nucleons
         if(debug.ge.2)write (moniou,212)it
         if(iconab(ip,it).eq.0)goto 3
         icdt=iddt(it)                         !diffr. eigenstate for it
         bbp=(x-xb(it,1))**2+(y-xb(it,2))**2   !distance squared between ip, it
 
 c calculate nuclear screening factors for "middle point" -> eikonals
         xpomr=1.d0/dsqrt(scm)
         xxp=.5d0*(x+xb(it,1))
         yyp=.5d0*(y+xb(it,2))
         call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
      *  ,ip,it)
         vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)        !total eikonal
         vv1p=min(vv,qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,2)) !1P-eikonal
         if(debug.ge.2)write (moniou,213)vv,vv1p
 
         if(qgran(b10).gt.1.d0-exp(-2.d0*vv))goto 3 !1.-exp(-2*vv) - probability
                                                    !for inelastic interaction
         iwt(it)=1
         iwp(ip)=1
         ncola(ip)=ncola(ip)+1                   !N of binary collisions for ip
         ncolb(it)=ncolb(it)+1                   !N of binary collisions for it
 
         n=npgen(2.d0*vv,1,50) !number of elem. inter. for (ip-it) collision
         nbpom=nbpom+1         !new Pomeron block
         if(nbpom.gt.npbmax)then
          goto 2
         endif
         ias(nbpom)=ip         !proj. index for current elementary interaction
         ibs(nbpom)=it         !targ. index for current elementary interaction
         bbpom(nbpom)=bbp      !distance squared between ip, it
         vvxpom(nbpom)=1.d0-(1.d0-vvx)*(1.d0-vvxp)*(1.d0-vvxt)
         if(debug.ge.2)write (moniou,214)nbpom,ip,it,n
 
         nqs(nbpom)=0
         npomin(nbpom)=0
         npompr(nbpom)=0
         npomtg(nbpom)=0
         do i=1,n
          if(qgran(b10).lt.vv1p/vv.or.scm.le.sgap**2)then  !single Pomeron
           if(debug.ge.2)write (moniou,215)i
           np=nqs(nbpom)+1
           if(np.gt.legmax)then
            goto 2
           endif
           nqs(nbpom)=np                  !update Pomeron number in the block
           l0=lqa(ip)+1
           if(l0.gt.npnmax)then
            goto 2
           endif
           lqa(ip)=l0                     !update number of connections for proj.
           nnpr(np,nbpom)=l0              !index for connected proj. participant
           nbpi(l0,ip)=nbpom
           idnpi(l0,ip)=0
           nppi(l0,ip)=np
           l0=lqb(it)+1
           if(l0.gt.npnmax)then
            goto 2
           endif
           lqb(it)=l0
           nntg(np,nbpom)=l0              !index for connected targ. participant
           nbti(l0,it)=nbpom
           idnti(l0,it)=0
           npti(l0,it)=np
 
          else                            !multi-Pomeron vertex
           if(debug.ge.2)write (moniou,219)
           call qg3pdf(vvxpi,vvxti,xpompi,xpomti,bpompi,bpomti,xpomip
      *    ,xpomim,vvxim,bpomim,npompi,npomti,npin,ipompi,ipomti
      *    ,wdp,wdt,ip,it,iret)
           if(iret.ne.0)goto 2
 
           if(npin.ne.0)then
            if(debug.ge.2)write (moniou,220)i,npin
            npomin(nbpom)=npomin(nbpom)+npin
            if(npomin(nbpom).gt.npmax)then
             goto 2
            endif
            do l=1,npin
             l1=npomin(nbpom)+l-npin
             xpopin(l1,nbpom)=xpomip(l)
             xpomin(l1,nbpom)=xpomim(l)
             vvxin(l1,nbpom)=vvxim(l)
             bpomin(l1,nbpom)=bpomim(l)
            enddo
           endif
           if(npompi.ne.0)then
            if(debug.ge.2)write (moniou,221)i,npompi
            do m=1,npompi
             np=npompr(nbpom)+1
             if(np.gt.legmax)then
              goto 2
             endif
             npompr(nbpom)=np
             ipp=ipompi(m)
             iwp(ipp)=1
             ilpr(np,nbpom)=ipp
             l0=lqa(ipp)+1
             if(l0.gt.npnmax)then
              goto 2
             endif
             lqa(ipp)=l0
             lnpr(np,nbpom)=l0
             nbpi(l0,ipp)=nbpom
             idnpi(l0,ipp)=1
             nlpi(l0,ipp)=np
             vvxpr(l0,ipp)=vvxpi(m)
             xpompr(l0,ipp)=1.d0/xpompi(m)/scm
             bpompr(l0,ipp)=bpompi(m)
            enddo
           endif
           if(npomti.ne.0)then
            if(debug.ge.2)write (moniou,222)i,npomti
            do m=1,npomti
             np=npomtg(nbpom)+1
             if(np.gt.legmax)then
              goto 2
             endif
             npomtg(nbpom)=np
             itt=ipomti(m)
             iwt(itt)=1
             iltg(np,nbpom)=itt
             l0=lqb(itt)+1
             if(l0.gt.npnmax)then
              goto 2
             endif
             lqb(itt)=l0
             lntg(np,nbpom)=l0
             nbti(l0,itt)=nbpom
             idnti(l0,itt)=1
             nlti(l0,itt)=np
             vvxtg(l0,itt)=vvxti(m)
             xpomtg(l0,itt)=xpomti(m)
             bpomtg(l0,itt)=bpomti(m)
            enddo
           endif
          endif
         enddo                   !end of Pomeron loop
 3      continue                 !end of it-loop
 4     continue                  !end of ip-loop
 
 c-------------------------------------------------
 c   diffraction (hadron-hadron case)
       if(ia(1).eq.1.and.ia(2).eq.1.and.iwp(1).eq.0.and.iwt(1).eq.0)then
        wel=0.d0
        winel=0.d0
        do icdp=1,2
        do icdt=1,2
         vv=qgpomi(scm,b*b,0.d0,0.d0,0.d0,icdp,icdt,icz,1)   !total eikonal
         wabs(icdp,icdt)=exp(-vv)
         wel=wel+cc(icdp,icz)*cc(icdt,2)*wabs(icdp,icdt)
         winel=winel+cc(icdp,icz)*cc(icdt,2)*wabs(icdp,icdt)**2
        enddo
        enddo
        if(qgran(b10).le.wel**2/winel)then
         if(debug.ge.1)write (moniou,231)
         goto 1
        endif
 
        wdifp=cc(1,icz)*cc(2,icz)*(cc(1,2)**2*(wabs(1,1)-wabs(2,1))**2
      * +cc(2,2)**2*(wabs(1,2)-wabs(2,2))**2+2.d0*cc(1,2)*cc(2,2)
      * *(wabs(1,1)-wabs(2,1))*(wabs(1,2)-wabs(2,2)))
        wdift=cc(1,2)*cc(2,2)*(cc(1,icz)**2*(wabs(1,1)-wabs(1,2))**2
      * +cc(2,icz)**2*(wabs(2,1)-wabs(2,2))**2+2.d0*cc(1,icz)*cc(2,icz)
      * *(wabs(1,1)-wabs(1,2))*(wabs(2,1)-wabs(2,2)))
        wdifd=cc(1,icz)*cc(2,icz)*cc(1,2)*cc(2,2)
      * *(wabs(1,1)+wabs(2,2)-wabs(1,2)-wabs(2,1))**2
        aks=(wdifp+wdift+wdifd)*qgran(b10)
        if(aks.lt.wdifp)then
         nwp=nwp+1
         iwp(1)=2
         iprcn(1)=1
         iwt(1)=-1
        elseif(aks.lt.wdifp+wdift)then
         nwt=nwt+1
         iwt(1)=2
         itgcn(1)=1
         iwp(1)=-1
        else
         nwp=nwp+1
         nwt=nwt+1
         iwp(1)=2
         iwt(1)=2
         iprcn(1)=1
         itgcn(1)=1
        endif
        goto 9
       endif
 
 c-------------------------------------------------
 c   diffraction (hadron-nucleus & nucleus-nucleus)
       do ip=1,ia(1)             !loop over all projectile nucleons
        x=xa(ip,1)+b             !proj. x is shifted by b
        y=xa(ip,2)
        if(iwp(ip).ne.0)then
         nwp=nwp+1               !one more wounded proj. nucleon
         if(lqa(ip).eq.0.and.(wdp(1,ip).ne.0.d0.or.wdp(2,ip).ne.0.d0))
      *  then
          icdps=iddp(ip)
          xpomr=1.d0/dsqrt(scm)
          do it=1,ia(2)
           if(iconab(ip,it).ne.0)then
             bbp=(x-xb(it,1))**2+(y-xb(it,2))**2
            xxp=.5d0*(x+xb(it,1))
            yyp=.5d0*(y+xb(it,2))
            icdt=iddt(it)
            do icdp=1,2
             iddp(ip)=icdp
             call qgfdf(xxp,yyp,xpomr,vpac,vtac
      *      ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
             vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)   !total eikonal
             wdp(icdp,ip)=wdp(icdp,ip)*exp(-vv)
            enddo
           endif
          enddo
          iddp(ip)=icdps
          wdifr=cc(1,icz)*cc(2,icz)*(wdp(1,ip)-wdp(2,ip))**2
      *   /(cc(1,icz)*wdp(1,ip)**2+cc(2,icz)*wdp(2,ip)**2)
          if(qgran(b10).lt.wdifr)iwp(ip)=3                     !LMD excitation
         endif
 
        elseif(icona(ip).ne.0)then
         if(debug.ge.2)write (moniou,223)ip
         vabs(1)=0.d0
         vabs(2)=0.d0
         icdps=iddp(ip)
         do it=1,ia(2)
           bbp=(x-xb(it,1))**2+(y-xb(it,2))**2
          icdt=iddt(it)
          do icdp=1,2
           if(iconab(ip,it).eq.0)then
            vabsi(icdp,it)=0.d0
           else
            iddp(ip)=icdp
            xpomr=1.d0/dsqrt(scm)
            xxp=.5d0*(x+xb(it,1))
            yyp=.5d0*(y+xb(it,2))
            call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
      *     ,ip,it)
            vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)   !total eikonal
            vabsi(icdp,it)=vv
            vabs(icdp)=vabs(icdp)+vv
           endif
          enddo
         enddo
         iddp(ip)=icdps
         wdifr=cc(1,icz)*cc(2,icz)*(exp(-vabs(1))-exp(-vabs(2)))**2
      *  /(cc(1,icz)*exp(-2.d0*vabs(1))+cc(2,icz)*exp(-2.d0*vabs(2)))
 
         if(qgran(b10).lt.wdifr)then       !projectile diffraction
          wdift=0.d0
          do it=1,ia(2)
           if(iwt(it).ne.-1)then
            wdifi(it)=cc(1,icz)*cc(2,icz)*(exp(-vabsi(1,it))
      *     -exp(-vabsi(2,it)))**2/(cc(1,icz)*exp(-2.d0*vabsi(1,it))
      *     +cc(2,icz)*exp(-2.d0*vabsi(2,it)))
            wdift=wdift+wdifi(it)
           else
            wdifi(it)=0.d0
           endif
          enddo
          if(wdift.ne.0.d0)then
           nwp=nwp+1
           iwp(ip)=2
           aks=qgran(b10)*wdift
           do it=1,ia(2)
            aks=aks-wdifi(it)
            if(aks.lt.0.d0)goto 5
           enddo
 5          continue
           iprcn(ip)=it
           if(iwt(it).eq.0)iwt(it)=-1
           if(debug.ge.2)write (moniou,224)ip,it
          endif
         endif
        endif
       enddo                            !end of ip-loop
 
       do 8 it=1,ia(2)                     !check target diffraction
        if(iwt(it).gt.0)then
         nwt=nwt+1                         !one more wounded targ. nucleon
         if(lqb(it).eq.0.and.(wdt(1,it).ne.0.d0.or.wdt(2,it).ne.0.d0))
      *  then
          icdts=iddt(it)
          xpomr=1.d0/dsqrt(scm)
          do ip=1,ia(1)
           if(iconab(ip,it).ne.0)then
            bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
            xxp=.5d0*(xa(ip,1)+b+xb(it,1))
            yyp=.5d0*(xa(ip,2)+xb(it,2))
            icdp=iddp(ip)
            do icdt=1,2
             iddt(it)=icdt
             call qgfdf(xxp,yyp,xpomr,vpac,vtac
      *      ,vvx,vvxp,vvxt,vvxpl,vvxtl,ip,it)
             vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)   !total eikonal
              wdt(icdt,it)=wdt(icdt,it)*exp(-vv)
            enddo
           endif
          enddo
          iddt(it)=icdts
          wdifr=cc(1,2)*cc(2,2)*(wdt(1,it)-wdt(2,it))**2
      *   /(cc(1,2)*wdt(1,it)**2+cc(2,2)*wdt(2,it)**2)
          if(qgran(b10).lt.wdifr)iwt(it)=3
         endif
 
        elseif(iconb(it).ne.0)then
         if(debug.ge.2)write (moniou,225)it
         vabs(1)=0.d0
         vabs(2)=0.d0
         icdts=iddt(it)
         do ip=1,ia(1)
          bbp=(xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-xb(it,2))**2
          icdp=iddp(ip)
          do icdt=1,2
           if(iconab(ip,it).eq.0)then
            vabsi(icdt,ip)=0.d0
           else
            iddt(it)=icdt
            xpomr=1.d0/dsqrt(scm)
            xxp=.5d0*(xa(ip,1)+b+xb(it,1))
            yyp=.5d0*(xa(ip,2)+xb(it,2))
            call qgfdf(xxp,yyp,xpomr,vpac,vtac,vvx,vvxp,vvxt,vvxpl,vvxtl
      *     ,ip,it)
            vv=qgpomi(scm,bbp,vvx,vvxp,vvxt,icdp,icdt,icz,1)   !total eikonal
            vabsi(icdt,ip)=vv
            vabs(icdt)=vabs(icdt)+vv
           endif
          enddo
         enddo
         iddt(it)=icdts
         wdifr=cc(1,2)*cc(2,2)*(exp(-vabs(1))-exp(-vabs(2)))**2
      *  /(cc(1,2)*exp(-2.d0*vabs(1))+cc(2,2)*exp(-2.d0*vabs(2)))
 
         if(qgran(b10).lt.wdifr)then       !target diffraction
          wdift=0.d0
          do ip=1,ia(1)
           if(iwp(ip).eq.-1)then
            wdifi(ip)=0.d0
           else
            if(iwp(ip).eq.2)then
             itt=iprcn(ip)
             if(itt.eq.it)goto 7
             if(iwt(itt).eq.2)then
              wdifi(ip)=0.d0
              goto 6
             endif
            endif
            wdifi(ip)=cc(1,2)*cc(2,2)*(exp(-vabsi(1,ip))
      *     -exp(-vabsi(2,ip)))**2/(cc(1,2)*exp(-2.d0*vabsi(1,ip))
      *     +cc(2,2)*exp(-2.d0*vabsi(2,ip)))
           endif
 6          wdift=wdift+wdifi(ip)
          enddo
          if(wdift.eq.0.d0)goto 8
          nwt=nwt+1
          iwt(it)=2
          aks=qgran(b10)*wdift
          do ip=1,ia(1)
           aks=aks-wdifi(ip)
           if(aks.lt.0.d0)goto 7
          enddo
 7         continue
          itgcn(it)=ip
          if(debug.ge.2)write (moniou,226)it,ip
          if(iwp(ip).eq.0)then
           iwp(ip)=-1
          elseif(iwp(ip).eq.2)then
           itt=iprcn(ip)
           iprcn(ip)=it
           if(itt.ne.it.and.iwt(itt).eq.-1)iwt(itt)=0
          endif
         endif
        endif
 8     continue
 
 c check diffractive cross sections (hadron-proton only)
 9     jdiff=0                             !non-diffractive
       if(ia(1).eq.1.and.ia(2).eq.1.and.(nwp.ne.0.or.nwt.ne.0)
      *.and.nqs(1).eq.0)then
        if(lqa(1).eq.0.and.lqb(1).eq.0)then
         if(nbpom.eq.0.or.npomin(1).eq.0)then
          if(iwp(1).ge.2.and.iwt(1).lt.2)then
           jdiff=6                         !SD(LM)-proj
          elseif(iwp(1).lt.2.and.iwt(1).ge.2)then
           jdiff=7                         !SD(LM)-targ
          elseif(iwp(1).ge.2.and.iwt(1).ge.2)then
           jdiff=8                         !DD(LM)
          else
           goto 12
          endif
         else
          if(iwp(1).lt.2.and.iwt(1).lt.2)then
           jdiff=9                         !CD(DPE)
          else
           jdiff=10                        !CD+LMD
          endif
         endif
        elseif(lqa(1).gt.0.and.lqb(1).eq.0.and.iwt(1).lt.2)then
         jdiff=1                          !SD(HM)-proj
        elseif(lqa(1).eq.0.and.lqb(1).gt.0.and.iwp(1).lt.2)then
         jdiff=2                          !SD(HM)-targ
        elseif(lqa(1).gt.0.and.lqb(1).eq.0.and.iwt(1).ge.2)then
         jdiff=3                          !DD(LHM)-proj
        elseif(lqa(1).eq.0.and.lqb(1).gt.0.and.iwp(1).ge.2)then
         jdiff=4                          !DD(LHM)-targ
 
        elseif(lqa(1).gt.0.and.lqb(1).gt.0)then
         if(npompr(1).eq.0)stop'problem with npompr!!!'
         xrapmax(1)=1.d0
         do i=1,npompr(1)
          xrapmax(1)=min(xrapmax(1),1.d0/xpompr(i,1)/scm)
         enddo
         if(npomtg(1).eq.0)stop'problem with npomtg!!!'
         xrapmin(1)=1.d0/scm
         do i=1,npomtg(1)
          xrapmin(1)=max(xrapmin(1),xpomtg(i,1))
         enddo
         if(xrapmin(1).gt..999d0*xrapmax(1))goto 12
         nraps=1
         irap=1
 11      if(nraps.gt.90)stop'nraps>90'
         if(npomin(1).gt.0)then
          do i=1,npomin(1)
           if(xpomin(i,1).lt..999d0*xrapmax(irap)
      *    .and.xpopin(i,1).gt.1.001d0*xrapmin(irap))then
            if(xpomin(i,1).lt.1.001d0*xrapmin(irap)
      *     .and.xpopin(i,1).gt..999d0*xrapmax(irap))then
             nraps=nraps-1
             if(nraps.eq.0)goto 12
             irap=irap-1
             goto 11
            elseif(xpopin(i,1).gt..999d0*xrapmax(irap))then
             xrapmax(irap)=xpomin(i,1)
             if(xrapmin(irap).gt..999d0*xrapmax(irap))then
              nraps=nraps-1
              if(nraps.eq.0)goto 12
              irap=irap-1
              goto 11
             endif
            elseif(xpomin(i,1).lt.1.001d0*xrapmin(irap))then
             xrapmin(irap)=xpopin(i,1)
             if(xrapmin(irap).gt..999d0*xrapmax(irap))then
              nraps=nraps-1
              if(nraps.eq.0)goto 12
              irap=irap-1
              goto 11
             endif
            else
             xrapmin(irap+1)=xrapmin(irap)
             xrapmin(irap)=xpopin(i,1)
             xrapmax(irap+1)=xpomin(i,1)
             if(xrapmin(irap).lt..999d0*xrapmax(irap)
      *      .and.xrapmin(irap+1).lt..999d0*xrapmax(irap+1))then
              irap=irap+1
              nraps=nraps+1
              goto 11
             elseif(xrapmin(irap).lt..999d0*xrapmax(irap))then
              goto 11
             elseif(xrapmin(irap+1).lt..999d0*xrapmax(irap+1))then
              xrapmin(irap)=xrapmin(irap+1)
              xrapmax(irap)=xrapmax(irap+1)
              goto 11
             else
              nraps=nraps-1
              if(nraps.eq.0)goto 12
              irap=irap-1
              goto 11
             endif
            endif
           endif
          enddo                           !end of npin-loop
         endif
         jdiff=5                          !DD(HM)
        endif
       endif                              !end of diffr. check
 12    bdiff=b
 
 ctp define collision type
       typevt=0                      !no interaction
       if(ia(1).eq.1.and.ia(2).eq.1.and.(nwp.gt.0.or.nwt.gt.0))then !only for h-h
        if(jdiff.eq.0)then                                  !ND (no rap-gaps)
         typevt=1
        elseif(jdiff.eq.8.or.jdiff.eq.10.or.
      *       (jdiff.gt.2.and.jdiff.lt.6))then !DD + (CD+LMD)
         typevt=2                           
        elseif(jdiff.eq.1.or.jdiff.eq.6)then                  !SD pro
         typevt=4  
        elseif(jdiff.eq.2.or.jdiff.eq.7)then                  !SD tar
         typevt=-4  
        elseif(jdiff.eq.9)then                                !CD
         typevt=3
        else
         stop'problem with typevt!'
        endif
       endif
 
 
 c form projectile spectator part
       if(debug.ge.1)write (moniou,227)
       nspec=0
       do ip=1,ia(1)
        if(iwp(ip).eq.0)then
         if(debug.ge.2)write (moniou,228)ip
         nspec=nspec+1
         do l=1,3
          xas(nspec,l)=xa(ip,l)
         enddo
        endif
       enddo
 
       nspect=0
       do it=1,ia(2)
        if(iwt(it).eq.0)nspect=nspect+1
       enddo
 
 c inelastic interaction: energy sharing and particle production
       if(nwp.ne.0.or.nwt.ne.0)then
        if(ia(1).eq.nspec.or.ia(2).eq.nspect)stop'ia(1)=nspec!!!'
        if(debug.ge.1)write (moniou,229)
 
        call qgsha(nbpom,ncola,ncolb,iret)
        if(iret.ne.0)goto 1
        if(nsp.le.nsp0+2)then
         if(debug.ge.1)write (moniou,230)
         goto 1
        endif
       else                                 !no interaction
        if(debug.ge.1)write (moniou,231)
        goto 1
       endif
       if(debug.ge.1)write (moniou,232)nsp
 
 c fragmentation of the projectile spectator part
       if(debug.ge.1)write (moniou,233)
       call qgfrgm(nspec,xas)
       if(debug.ge.1)write (moniou,234)nsf
       if(debug.ge.1)write (moniou,235)
 
 201   format(2x,'qgconf - configuration of the interaction')
 202   format(2x,'qgconf: impact parameter b=',e10.3,' fm')
 203   format(2x,'qgconf: nuclear configurations')
 204   format(2x,'qgconf: check connections')
 205   format(2x,'qgconf: ',i3,'-th proj. nucleon may interact with '
      *,i3,'-th target nucleon')
 206   format(2x,'qgconf: ',i3,'-th projectile nucleon may interact')
 207   format(2x,'qgconf: ',i3,'-th target nucleon may interact')
 208   format(2x,'qgconf: ',i3,'-th rejection,'
      *,' redo Pomeron configuration')
 209   format(2x,'qgconf: too many rejections,'
      *,' redo nuclear configuartions')
 210   format(2x,'qgconf: Pomeron configuration')
 211   format(2x,'qgconf: check ',i3,'-th projectile nucleon')
 212   format(2x,'qgconf: interaction with ',i3,'-th target nucleon?')
 213   format(2x,'qgconf: eikonals - total: ',e10.3,2x,'single: ',e10.3)
 214   format(2x,'qgconf: ',i4,'-th Pomeron block connected to ',i3
      *,'-th proj. nucleon and'/4x,i3,'-th targ. nucleon;'
      *,' number of element. processes in the block: ',i3)
 215   format(2x,'qgconf: ',i3
      *,'-th process in the block is single cut Pomeron')
 219   format(2x,'qgconf: configuration of multi-Pomeron vertexes')
 220   format(2x,'qgconf: ',i3,'-th process in the block contains '
      *,i3,' interm. Pomerons')
 221   format(2x,'qgconf: ',i3,'-th process in the block contains '
      *,i3,' proj. legs')
 222   format(2x,'qgconf: ',i3,'-th process in the block contains '
      *,i3,' targ. legs')
 223   format(2x,'qgconf: check diffraction for ',i3,'-th proj. nucleon')
 224   format(2x,'qgconf: diffr. of ',i3,'-th proj. nucleon,'
      *,' recoil of ',i3,'-th targ. nucleon')
 225   format(2x,'qgconf: check diffraction for ',i3,'-th targ. nucleon')
 226   format(2x,'qgconf: diffr. of ',i3,'-th targ. nucleon,'
      *,' recoil of ',i3,'-th proj. nucleon')
 227   format(2x,'qgconf: projectile spectator part')
 228   format(2x,'qgconf: ',i3,'-th proj. nucleon stays idle')
 229   format(2x,'qgconf: inelastic interaction: energy sharing'
      *,' and particle production')
 230   format(2x,'qgconf: no particle produced - rejection')
 231   format(2x,'qgconf: no interaction - rejection')
 232   format(2x,'qgconf: ',i5,' particles have been produced')
 233   format(2x,'qgconf: fragmentation of the proj. spectator part')
 234   format(2x,'qgconf: ',i3,' proj. fragments have been produced')
 235   format(2x,'qgconf - end')
       return
       end
 
 c=============================================================================
       subroutine qg3pdf(vvxpi,vvxti,xpompi,xpomti,bpompi,bpomti
      *,xpomip,xpomim,vvxim,bpomim,nppr,nptg,npin,ipompi,ipomti
      *,wdp,wdt,ip,it,iret)
 c-----------------------------------------------------------------------
 c qg3pdf - configuration for multi-Pomeron/diffractive contributions
 c ip,it - indexes of proj. and targ. nucleons for current collision
 c to determine:
 c nppr - number of proj. leg Pomerons in the process,
 c nptg - number of targ. leg Pomerons in the process,
 c npin - number of interm. Pomerons (between 2 3P-vertexes) in the process,
 c xpomip(i) - LC momentum of the upper 3P-vertex for i-th interm. Pomeron
 c in the process,
 c xpomim(i) - LC momentum of the lower 3P-vertex for i-th interm. Pomeron
 c in the process,
 c ipompi(i) - proj. index for i-th proj. leg Pomeron in the process,
 c ipomti(i) - proj. index for i-th targ. leg Pomeron in the process,
 c bpompi(i) - squared impact param. for i-th proj. leg Pomeron in the process,
 c bpomti(i) - squared impact param. for i-th targ. leg Pomeron in the process,
 c vvxpi(i) - relative strenth of scr. corrections for i-th proj. leg Pomeron,
 c vvxti(i) - relative strenth of scr. corrections for i-th targ. leg Pomeron,
 c xpompi(i) - LC momentum of the 3P-vertex for i-th proj. leg Pomeron,
 c xpomti(i) - LC momentum of the 3P-vertex for i-th targ. leg Pomeron
 c iret=1 - reject configuration
 c-----------------------------------------------------------------------
       implicit double precision (a-h,o-z)
       integer debug
       parameter(iapmax=208,npbmax=1000,npnmax=900,npmax=900
      *,levmax=20,legmax=900)
       dimension vpac(iapmax),vtac(iapmax)
      *,vpac0(iapmax),vtac0(iapmax),vpact(iapmax),vtact(iapmax)
      *,xpomip(npmax),xpomim(npmax),vvxim(npmax),bpomim(npmax)
      *,xpompi(legmax),xpomti(legmax)
      *,vvxpi(legmax),vvxti(legmax),bpompi(legmax),bpomti(legmax)
      *,ipompi(legmax),ipomti(legmax),ippr0(legmax),iptg0(legmax)
      *,nppm(levmax),ippm(legmax,levmax),ii(levmax),xpomm(levmax)
      *,wgpm(levmax),xxm(levmax),yym(levmax)
      *,itypr0(legmax),itytg0(legmax),itypm(legmax,levmax),vv(12)
      *,wdp(2,iapmax),wdt(2,iapmax)
       common /qgarr1/  ia(2),icz,icp
       common /qgarr2/  scm,wp0,wm0
       common /qgarr6/  pi,bm,amws
       common /qgarr7/  xa(iapmax,3),xb(iapmax,3),b
       common /qgarr9/  iwp(iapmax),iwt(iapmax),lqa(iapmax),lqb(iapmax)
      *,iprcn(iapmax),itgcn(iapmax),ias(npbmax),ibs(npbmax),nqs(npbmax)
      *,npompr(npbmax),npomtg(npbmax),npomin(npbmax),nnpr(npmax,npbmax)
      *,nntg(npmax,npbmax),ilpr(legmax,npbmax),iltg(legmax,npbmax)
      *,lnpr(legmax,npbmax),lntg(legmax,npbmax)
      *,nbpi(npnmax,iapmax),nbti(npnmax,iapmax),idnpi(npnmax,iapmax)
      *,idnti(npnmax,iapmax),nppi(npnmax,iapmax),npti(npnmax,iapmax)
      *,nlpi(npnmax,iapmax),nlti(npnmax,iapmax)
       common /qgarr11/ b10
       common /qgarr12/ nsp
       common /qgarr13/ nsf,iaf(iapmax)
       common /qgarr15/ fp(3),rq(2,3),cd(2,3),gsoft(3)
       common /qgarr16/ cc(2,3),iddp(iapmax),iddt(iapmax)
       common /qgarr17/ dels,alfp,sigs,rr,r3p,g3p,delh,sgap
       common /qgarr19/ ahl(3)
       common /qgarr23/ bbpom(npbmax),vvxpom(npbmax)
      *,bpompr(npnmax,iapmax),bpomtg(npnmax,iapmax)
      *,vvxpr(npnmax,iapmax),vvxtg(npnmax,iapmax)
      *,xpompr(npnmax,iapmax),xpomtg(npnmax,iapmax)
      *,xpopin(npmax,npbmax),xpomin(npmax,npbmax),vvxin(npmax,npbmax)
      *,bpomin(npmax,npbmax)
       common /qgarr43/ moniou
       common /qgarr46/ iconab(iapmax,iapmax),icona(iapmax)
      *,iconb(iapmax)
       common /qgdebug/  debug
       external qgran
 
       if(debug.ge.2)write (moniou,201)ip,it
 
       if(scm.le.sgap**2)stop'qg3pdf: scm<sgap**2!'
       iret=0
       vpacng=0.d0
       vtacng=0.d0
       vpacpe=0.d0
       vtacpe=0.d0
       vimp=0.d0
       viuc=0.d0
       viuu=0.d0
       vip=0.d0
       vicc=0.d0
       vicu=0.d0
 c normalization of rejection function
       xpomr=1.d0/dsqrt(scm)
       bpt=dsqrt((xa(ip,1)+b-xb(it,1))**2+(xa(ip,2)-