qgsjet01.f

Go to the documentation of this file.

C from Sergey. Jul.2010;  typevt is the flag for NSD
C   only typevt part is added from the version above (KK)
C   name is changed from qgsjet01c.f to qgsjet01.f
C======================================================================C
C                                                                      C
C      QQQ         GGG       SSSS     JJJJJJJ    EEEEEEE    TTTTTTT    C
C     Q   Q       G   G     S    S          J    E             T       C
C    Q     Q     G          S               J    E             T       C
C    Q     Q     G   GGG     SSSS           J    EEEEE         T       C
C    Q   Q Q     G     G         S          J    E             T       C
C     Q   Q       G   G     S    S     J   J     E             T       C
C      QQQ QQ      GGG       SSSS       JJJ      EEEEEEE       T       C
C                                                                      C
C                                                                      C
C----------------------------------------------------------------------C
C                                                                      C
C                    QUARK - GLUON - STRING - MODEL                    C
C                                                                      C
C                HIGH ENERGY HADRON INTERACTION PROGRAM                C
C                                                                      C
C                                  BY                                  C
C                                                                      C
C                 N. N. KALMYKOV AND S. S. OSTAPCHENKO                 C
C                                                                      C
C               MOSCOW STATE UNIVERSITY,  MOSCOW, RUSSIA               C
C                      e-mail: serg@eas.npi.msu.su                     C
C----------------------------------------------------------------------C
C                 SUBROUTINE VERSION TO BE LINKED WITH                 C
C                             C O R S I K A                            C
C               KARLSRUHE  AIR SHOWER SIMULATION PROGRAM               C
C                          WITH MODIFICATIONS                          C
C                                  BY                                  C
C                      D. HECK  IK  FZK KARLSRUHE                      C
C----------------------------------------------------------------------C
C             last modification:  June 15, 2005                        C
C                        Version qgsjet01c.f                           C
C----------------------------------------------------------------------C
C  modifications are marked by cdh
C=======================================================================

      SUBROUTINE psaini
c Common initialization procedure
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
      CHARACTER *7 TY
      LOGICAL LCALC,LSECT
********************************************
      dimension eq(17),mij(17,17,4),nij(17,17,4),csjet(17,17,68),
     *cs1(17,17,68),gz0(2),gz1(3)
      COMMON /xsect/  gsect(10,5,4)
      COMMON /area1/  ia(2),icz,icp
      COMMON /area5/  rd(2),cr1(2),cr2(2),cr3(2)
********************************************
      COMMON /area6/  pi,bm,am
      COMMON /area7/  rp1
      COMMON /area10/ stmass,am0,amn,amk,amc,amlamc,amlam,ameta
      COMMON /area15/ fp(5),rq(5),cd(5)
      COMMON /area16/ cc(5)
      COMMON /area17/ del,rs,rs0,fs,alfp,rr,sh,delh
      COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
      COMMON /area19/ ahl(5)
********************************************
      COMMON /area22/ sjv0,fjs0(5,3)
********************************************
      COMMON /area23/ rjv(50)
      COMMON /area24/ rjs(50,5,10)
      COMMON /area27/ fp0(5)
      COMMON /area28/ arr(4)
      COMMON /area29/ cstot(17,17,68)
      COMMON /area30/ cs0(17,17,68)
      COMMON /area31/ csborn(17,68)
      COMMON /area32/ csq(17,2,2),csbq(17,2,2)
      COMMON /area33/ fsud(10,2)
      COMMON /area34/ qrt(10,101,2)
      COMMON /area35/ sjv(10,5),fjs(10,5,15)
      COMMON /area39/ jcalc
      COMMON /area40/ jdifr
      COMMON /area41/ ty(5)
      COMMON /area43/ moniou
      COMMON /debug/  debug
********************************************
      COMMON /area44/ gz(10,5,4),gzp(10,5,4)
c Auxiliary common blocks to calculate hadron-nucleus cross-sections
      COMMON /ar1/    anorm
      COMMON /ar2/    rrr,rrrm
********************************************
cdh 8/10/98
      COMMON /area48/ asect(10,6,4)
cdh 8/12/98
      COMMON /version/version
      SAVE
c-------------------------------------------------
        WRITE(moniou,100)
 100    FORMAT(' ',
     *           '====================================================',
     *     /,' ','|                                                  |',
     *     /,' ','|           QUARK GLUON STRING JET MODEL           |',
     *     /,' ','|                                                  |',
     *     /,' ','|         HADRONIC INTERACTION MONTE CARLO         |',
     *     /,' ','|                        BY                        |',
     *     /,' ','|        N.N. KALMYKOV AND S.S. OSTAPCHENKO        |',
     *     /,' ','|                                                  |',
     *     /,' ','|            e-mail: serg@eas.npi.msu.su           |',
     *     /,' ','|                                                  |',
     *     /,' ','| Publication to be cited when using this program: |',
     *     /,' ','| N.N. Kalmykov & S.S. Ostapchenko, A.I. Pavlov    |',
     *     /,' ','| Nucl. Phys. B (Proc. Suppl.) 52B (1997) 17       |',
     *     /,' ','|                                                  |',
     *     /,' ','| last modification:  June 15, 2005  by    D. Heck |',
     *     /,' ','|               (version qgsjet01c.f)              |',
     *     /,' ','====================================================',
     *     /)
        IF(debug.GE.1)WRITE (moniou,210)
210     FORMAT(2x,'PSAINI - MAIN INITIALIZATION PROCEDURE')
cdh
        version = 2001.3

c AHL(i) - parameter for the energy sharing procedure (govern leading hadronic state
c inelasticity for primary pion, nucleon, kaon, D-meson, Lambda_C correspondingly)
      ahl(1)=1.d0-2.d0*arr(1)
      ahl(2)=1.d0-arr(1)-arr(2)
      ahl(3)=1.d0-arr(1)-arr(3)
      ahl(4)=1.d0-arr(1)-arr(4)
      ahl(5)=ahl(2)+arr(1)-arr(4)

c-------------------------------------------------
c 1/CC(i) = C_i - shower enhancement coefficients for one vertex
c (C_ab=C_a*C_b) (i - ICZ)
      cc(2)=1.d0/dsqrt(cd(2))
      cc(1)=1.d0/cc(2)/cd(1)
      cc(3)=1.d0/cc(2)/cd(3)
      cc(4)=1.d0/cc(2)/cd(4)
      cc(5)=1.d0/cc(2)/cd(5)

c FP0(i) - vertex constant (FP_ij=FP0_i*FP0_j) for pomeron-hadron interaction (i - ICZ)
      fp0(2)=dsqrt(fp(2))
      fp0(1)=fp(1)/fp0(2)
      fp0(3)=fp(3)/fp0(2)
      fp0(4)=fp(4)/fp0(2)
      fp0(5)=fp(5)/fp0(2)

c SH - hard interaction effective squared (SH=pi*R_h^2, R_h^2=4/Q0^2)
      sh=4.d0/qt0*pi
c Auxiliary constants for the hard interaction
      aqt0=dlog(4.d0*qt0)
      qlog=dlog(qt0/alm)
      qll=dlog(qlog)

********************************************
      INQUIRE(file='QGSDAT01',exist=lcalc)
      IF(lcalc)then
        IF(debug.GE.1)WRITE (moniou,211)
211     FORMAT(2x,'PSAINI: HARD CROSS SECTION RATIOS READOUT FROM THE'
     *    ,' FILE QGSDAT01')
        OPEN(1,file='QGSDAT01',status='OLD')
        READ (1,*)csborn,cs0,cstot,csq,csbq,
     *  fsud,qrt,sjv,fjs,rjv,rjs,gz,gzp,gsect
        CLOSE(1)
      ELSE
********************************************

        IF(debug.GE.1)WRITE (moniou,201)
201     FORMAT(2x,'PSAINI: HARD CROSS SECTIONS CALCULATION')
c--------------------------------------------------
c Hard pomeron inclusive cross sections calculation
c--------------------------------------------------
c EQ(I) - energy squared tabulation (Q0^2, 4*Q0^2, ...)
      DO 1 i=1,17
1     eq(i)=qt0*4.d0**float(i-1)

      DO 2 i=1,17
c QI - effective momentum (Qt**2/(1-z)**2) cutoff for the Born process
      qi=eq(i)
c M, L define parton types (1-g, 2-q)
      DO 2 m=1,2
      DO 2 l=1,2
c K defines c.m. energy squared for the process (for current energy tabulation)
      DO 2 k=1,17
      k1=k+17*(m-1)+34*(l-1)
      IF(k.LE.i.OR.k.EQ.2)THEN
        csborn(i,k1)=0.d0
      ELSE
c SK - c.m. energy squared for the hard interaction
        sk=eq(k)
c CSBORN(I,K1) - Born cross-section (2->2 process) - procedure PSBORN
        csborn(i,k1)=psborn(qi,sk,m-1,l-1)
      ENDIF
2     CONTINUE

c Cross-sections initialization
      DO 3 i=1,17
      DO 3 j=1,17
      n=max(i,j)
      DO 3 m=1,2
      DO 3 l=1,2
      ml=m+2*l-2
      DO 3 k=1,17
      k1=k+17*(m-1)+34*(l-1)
      csjet(i,j,k1)=0.d0
      IF(k.LE.n.OR.k.EQ.2)THEN
        cstot(i,j,k1)=-80.d0
        cs0(i,j,k1)=-80.d0
        mij(i,j,ml)=k+1
        nij(i,j,ml)=k+1
      ELSE
        cstot(i,j,k1)=dlog(csborn(n,k1))
        cs0(i,j,k1)=cstot(i,j,k1)
      ENDIF
3     CONTINUE

c N-maximal number of ladder runs taken into account
      n=2
4     CONTINUE
        IF(debug.GE.2)WRITE (moniou,202)n,eq(mij(1,1,1)),eq(nij(1,1,1))
202     FORMAT(2x,'PSAINI: NUMBER OF LADDER RUNS TO BE CONSIDERED:',i2/
     *  4x,'MINIMAL MASSES SQUARED FOR THE UNORDERED AND STRICTLY',
     *  ' ORDERED LADDERS:'/4x,e10.3,3x,e10.3)
      DO 6 i=1,17
c QI - effective momentum cutoff for upper end of the ladder
      qi=eq(i)
      DO 6 j=1,17
c QJ - effective momentum cutoff for lower end of the ladder
      qj=eq(j)
c QQ - maximal effective momentum cutoff
      qq=max(qi,qj)
c S2MIN - minimal energy squared for 2->2 subprocess
      s2min=max(qq,4.d0*qt0)
      sm=dsqrt(qt0/s2min)
c SMIN - minimal energy squared for 2->3 subprocess
      smin=s2min*(1.d0+sm)/(1.d0-sm)

c M, L define parton types (1-g, 2-q)
      DO 6 m=1,2
      DO 6 l=1,2
      ml=m+2*l-2
c KMIN corresponds to minimal energy at which more runs are to be considered -
c stored in array NIJ(I,J,ML) - for strictly ordered ladder
      kmin=nij(i,j,ml)
      IF(kmin.LE.17)THEN
        DO 5 k=kmin,17
        sk=eq(k)
        IF(sk.LE.smin)THEN
          nij(i,j,ml)=nij(i,j,ml)+1
        ELSE
          k1=k+17*(m-1)+34*(l-1)
c CS1(I,J,K1) - cross-section for strictly ordered ladder (highest virtuality run
c is the lowest one) - procedure PSJET1
          cs1(i,j,k1)=psjet1(qi,qj,sk,s2min,m-1,l)
        ENDIF
5       CONTINUE
      ENDIF
6     CONTINUE

      DO 8 i=1,17
      DO 8 j=1,17
      DO 8 m=1,2
      DO 8 l=1,2
      ml=m+2*l-2
      kmin=nij(i,j,ml)
      IF(kmin.LE.17)THEN
        DO 7 k=kmin,17
        k1=k+17*(m-1)+34*(l-1)
c CSJ - cross-section for strictly ordered ladder (highest virtuality run is the
c lowest one) - Born contribution is added
        csj=cs1(i,j,k1)+csborn(max(i,j),k1)
        IF(debug.GE.2)WRITE (moniou,204)csj,exp(cs0(i,j,k1))
204     FORMAT(2x,'PSAINI: NEW AND OLD VALUES OF THE CONTRIBUTION',
     *  ' OF THE STRICTLY ORDERED LADDER:'/4x,e10.3,3x,e10.3)
        IF(csj.EQ.0.d0.OR.abs(1.d0-exp(cs0(i,j,k1))/csj).LT.1.d-2)THEN
          nij(i,j,ml)=nij(i,j,ml)+1
        ELSE
c CS0(I,J,K1) - cross-section logarithm for strictly ordered ladder
          cs0(i,j,k1)=dlog(csj)
        ENDIF
7       CONTINUE
      ENDIF
8     CONTINUE

      DO 10 i=1,17
      qi=eq(i)
      DO 10 j=1,17
      qj=eq(j)
      qq=max(qi,qj)
      s2min=max(qq,4.d0*qt0)
      sm=dsqrt(qt0/s2min)
c SMIN - minimal energy squared for 2->3 subprocess
      smin=s2min*(1.d0+sm)/(1.d0-sm)

      DO 10 m=1,2
      DO 10 l=1,2
      ml=m+2*l-2
c KMIN corresponds to minimal energy at which more runs are to be considered
c stored in array MIJ(I,J,ML) - for any ordering in the ladder
      kmin=mij(i,j,ml)
      IF(kmin.LE.17)THEN
        DO 9 k=kmin,17
        sk=eq(k)
        IF(sk.LE.smin)THEN
          mij(i,j,ml)=mij(i,j,ml)+1
        ELSE
          k1=k+17*(m-1)+34*(l-1)
c CS1(I,J,K1) - cross-section for any ordering in the ladder (highest virtuality
c run is somewhere in the middle; runs above and below it are strictly ordered
c towards highest effective momentum run) - procedure PSJET
          cs1(i,j,k1)=psjet(qi,qj,sk,s2min,m-1,l)
        ENDIF
9       CONTINUE
      ENDIF
10    CONTINUE

      DO 12 i=1,17
      DO 12 j=1,17
      DO 12 m=1,2
      DO 12 l=1,2
      ml=m+2*l-2
c KMIN corresponds to minimal energy at which more runs are to be considered
      kmin=mij(i,j,ml)
      IF(kmin.LE.17)THEN
        DO 11 k=kmin,17
        k1=k+17*(m-1)+34*(l-1)
        k2=k+17*(l-1)+34*(m-1)
        csj=cs1(i,j,k1)+exp(cs0(j,i,k2))
        IF(csj.EQ.0.d0.OR.abs(1.d0-exp(cstot(i,j,k1))/csj).LT.1.d-2)
     *  mij(i,j,ml)=mij(i,j,ml)+1
        IF(debug.GE.2)WRITE (moniou,203)csj,exp(cstot(i,j,k1))
203     FORMAT(2x,'PSAINI: NEW AND OLD VALUES OF THE UNORDERED LADDER',
     *  ' CROSS SECTION:'/4x,e10.3,3x,e10.3)
11      cstot(i,j,k1)=dlog(csj)
      ENDIF
12    CONTINUE

c One more run
      n=n+1
      DO 13 l=1,4
13    IF(mij(1,1,l).LE.17.OR.nij(1,1,l).LE.17)GOTO 4

c Logarithms of the Born cross-section are calculated - to be interpolated in the
c PSBINT procedure
      DO 14 i=1,17
      DO 14 k=1,17
      DO 14 m=1,2
      DO 14 l=1,2
      k1=k+17*(m-1)+34*(l-1)
      IF(k.LE.i.OR.k.EQ.2)THEN
        csborn(i,k1)=-80.d0
      ELSE
        csborn(i,k1)=dlog(csborn(i,k1))
      ENDIF
14    CONTINUE

c Total and Born hard cross-sections logarithms for minimal cutoff (QT0) - to be
c interpolated in the PSJINT0 procedure
      DO 15 m=1,2
      DO 15 l=1,2
      DO 15 k=1,17
      IF(k.LE.2)THEN
        csq(k,m,l)=-80.d0
        csbq(k,m,l)=-80.d0
      ELSE
        k1=k+17*(m-1)+34*(l-1)
        csbq(k,m,l)=csborn(1,k1)
        csq(k,m,l)=cstot(1,1,k1)
      ENDIF
15    CONTINUE

c-------------------------------------------------
c FSUD(K,M)=-ln(SUD) - timelike Sudakov formfactor logarithm - procedure
c PSUDT(QMAX,M-1), M=1 - g, M=2 - q
      DO 17 m=1,2
      fsud(1,m)=0.d0
      DO 17 k=2,10
c QMAX is the maximal effective momentum ( Qt**2/z**2/(1-z)**2 in case of the timelike
c evolution )
      qmax=qtf*4.d0**(1.d0+k)
17    fsud(k,m)=psudt(qmax,m-1)

c QRT(K,L,M) - effective momentum logarithm for timelike branching ( ln QQ/16/QTF )
c for given QMAX (defined by K, QLMAX = ln QMAX/16/QTF ) and a number
c of random number values (defined by L) - to be interpolated by the PSQINT
c procedure; M=1 - g, M=2 - q
      DO 18 m=1,2
      DO 18 k=1,10
      qlmax=1.38629d0*(k-1)
      qrt(k,1,m)=0.d0
      qrt(k,101,m)=qlmax
      DO 18 i=1,99
      IF(k.EQ.1)THEN
        qrt(k,i+1,m)=0.d0
      ELSE
        qrt(k,i+1,m)=psroot(qlmax,.01d0*i,m)
      ENDIF
18    CONTINUE
c-------------------------------------------------

        IF(debug.GE.2)WRITE (moniou,205)
205     FORMAT(2x,'PSAINI: PRETABULATION OF THE INTERACTION EIKONALS')
c-------------------------------------------------
************************************************************************
c-------------------------------------------------
c Interaction cross sections
c Factors for interaction eikonals calculation
c (convolution of the hard cross-sections with partons structure functions)
c - to be used in the PSPSFAZ procedure
c-------------------------------------------------
      ia(1)=1          
c-------------------------------------------------
      DO 21 ie=1,10
c Energy of the interaction (per nucleon)
      e0n=10.d0**ie
c-------------------------------------------------
c Energy dependent factors:
c WP0, WM0 - initial light cone momenta for the interaction (E+-p)
      s=2.d0*e0n*amn
c Y0 - total rapidity range for the interaction
      y0=dlog(s)

c Type of the incident hadron (icz = 1: pion, 2: nucleon, 3: kaon, etc
      DO 21 icz=1,5
c RS - soft pomeron elastic scattering slope (lambda_ab)
      rs=rq(icz)+alfp*y0
c RS0 - initial slope (sum of the pomeron-hadron vertices slopes squared - R_ab)
      rs0=rq(icz)
c FS - factor for pomeron eikonal calculation 
c                            (gamma_ab * s**del /lambda_ab * C_ab
      fs=fp(icz)*exp(y0*del)/rs*cd(icz)
c RP1 - factor for the impact parameter dependence of the eikonal ( in fm^2 )
      rp1=rs*4.d0*.0391d0/am**2
c Factor for cross-sections calculation ( in mb )
      g0=pi*rp1/cd(icz)*am**2*10.d0
c SJV - valence-valence cross-section (divided by 8*pi*lambda_ab)
      sjv(ie,icz)=pshard(s,icz)
      sjv0=sjv(ie,icz)

      DO 19 i=1,5
      DO 19 m=1,3
      z=.2d0*i
c Eikonals for gluon-gluon and valence-gluon semihard interactions
c (m=1 - gg, 2 - qg, 3 - gq);
c Z - impact parameter factor ( exp(-b**2/R_p) )
      m1=m+3*(icz-1)
      fjs(ie,i,m1)=dlog(psfsh(s,z,icz,m-1)/z)
      fjs0(i,m)=fjs(ie,i,m1)
19    CONTINUE  

      DO 20 iia=1,4
c Target mass number IA(2)
      ia(2)=4**(iia-1)
      IF(debug.GE.1)WRITE (moniou,206)e0n,ty(icz),ia(2)
206   FORMAT(2x,'PSAINI: INITIAL PARTICLE ENERGY:',e10.3,2x,
     *'ITS TYPE:',a7,2x,'TARGET MASS NUMBER:',i2)
c-------------------------------------------------
c Nuclear radii 
      IF(ia(2).GT.10)THEN
c RD - Wood-Saxon density radius (fit to the data of Murthy et al.)
        rd(2)=0.7d0*float(ia(2))**.446/am
      ELSE
c RD - gaussian density radius (for light nucleus)
        rd(2)=.9d0*float(ia(2))**.3333/am
      ENDIF
      
      IF(ia(2).EQ.1)THEN
c Hadron-proton interaction
c BM - impact parameter cutoff value
        bm=2.d0*dsqrt(rp1)
c XXFZ - impact parameter integration for the hadron-nucleon interaction eikonal;
c GZ0 - total and absorptive cross-sections (up to a factor); first parameter is
c used only in case of hadron-nucleus interaction (to make convolution with target
c nucleus profile function)
        CALL xxfz(0.d0,gz0)
        if (debug .ge.1) write (moniou,*)gz0
c GTOT - total cross-section
        gtot=g0*gz0(1)
c GABS - cut pomerons cross-section
        gabs=g0*gz0(2)*.5d0
c GD0 - cross-section for the cut between pomerons
        gd0=gtot-gabs
c GDP - projectile diffraction cross section
        gdp=(1.d0-cc(icz))*cc(2)*gd0
c GDT - target diffraction cross section
        gdt=(1.d0-cc(2))*cc(icz)*gd0
c  GDD - double diffractive cross section
        gdd=(1.d0-cc(icz))*(1.d0-cc(2))*gd0
c GIN - inelastic cross section
        gin=gabs+gdp+gdt+gdd
        gel=gd0*cc(icz)*cc(2)
c
        IF(debug.GE.1)WRITE (moniou,225)gtot,gin,gel,gdp,gdt,gdd
c
225     FORMAT(2x,'PSAINI: HADRON-PROTON CROSS SECTIONS:'/
     *  4x,'GTOT=',e10.3,2x,'GIN=',e10.3,2x,'GEL=',e10.3/4x,
     *  'GDIFR_PROJ=',e10.3,2x,'GDIFR_TARG=',e10.3,2x,
     *  'G_DOUBLE_DIFR',e10.3)
c GZ - probability to have target diffraction
        gz(ie,icz,iia)=gdt/gin
        gzp(ie,icz,iia)=(gdp+gdd)/gin   ! so00
C??????
        gsect(ie,icz,iia)=log(gin)
C??????
      ELSE

c Hadron-nucleus interaction
c BM - impact parameter cutoff value
        bm=rd(2)+dlog(29.d0)
c RRR - Wood-Saxon radius for the target nucleus
        rrr=rd(2)
c RRRM - auxiliary parameter for numerical integration
        rrrm=rrr+dlog(9.d0)
c ANORM - nuclear density normalization factor multiplied by RP1
        anorm=1.5d0/pi/rrr**3/(1.d0+(pi/rrr)**2)*rp1

c GAU(GZ) - cross sections calculation ( integration over impact parameters less than
c BM )
        CALL xxgau(gz1)
c GAU1(GZ) - cross sections calculation ( integration over impact 
c parameters greater than BM )
        CALL xxgau1(gz1)
c GIN - total inelastic cross section
        gin=gz1(1)+gz1(2)+gz1(3)
c
        IF(debug.GE.1)WRITE (moniou,224)
     *  gin*10.d0,gz1(1)*10.d0,gz1(2)*10.d0
c
224     FORMAT(2x,'PSAINI: HADRON-NUCLEUS CROSS SECTIONS:'/
     *  4x,'GIN=',e10.3,2x,'GDIFR_TARG=',e10.3,2x,
     *  'GDIFR_PROJ=',e10.3)
c GZ - probability to have target diffraction
        gz(ie,icz,iia)=gz1(1)/gin
        gzp(ie,icz,iia)=gz1(2)/gin   ! so00
C??????
        gin=gin*10.
        gsect(ie,icz,iia)=log(gin)
C??????
      ENDIF
20    CONTINUE
21    CONTINUE

c Rejection functions calculation - to be interpolated in the RJINT procedure
      DO 23 i=1,50
c Rapidity range tabulation for the hard interaction
      yj=aqt0+.5d0*i
c Rejection function for valence quark energy distribution
      rjv(i)=psrejv(exp(yj))

      DO 22 j=1,5
      DO 22 m=1,2
      z=.2d0*j
      DO 22 icz=1,5
c RS0 - initial slope (sum of the pomeron-hadron vertices slopes squared - R_ab)
      rs0=rq(icz)
      m1=m+2*(icz-1)
c Rejection function for semihard block energy distribution  (m=1 - gg,
c 2 - qg)
      rjs(i,j,m1)=psrejs(exp(yj),z,m-1)
22    CONTINUE
23    CONTINUE

        IF(debug.GE.1)WRITE (moniou,212)
212     FORMAT(2x,'PSAINI: HARD CROSS SECTIONS ARE WRITTEN TO THE FILE'
     *  ,' QGSDAT01')
        OPEN(1,file='QGSDAT01',status='unknown')
        WRITE (1,*)csborn,cs0,cstot,csq,csbq,
     *  fsud,qrt,sjv,fjs,rjv,rjs,gz,gzp,gsect
        CLOSE(1)
      ENDIF
************************************************************************

cdh 8/10/98
c Nuclear cross sections
      INQUIRE(file='SECTNU',exist=lcalc)
      IF(lcalc)then
        IF(debug.GE.1)WRITE (moniou,208)
208     FORMAT(2x,'PSAINI: NUCLEAR CROSS SECTIONS READOUT FROM THE FILE'
     *  ,' SECTNU')
        OPEN(2,file='SECTNU',status='OLD')
        READ (2,*)asect
        CLOSE(2)
      ELSE
cdh     NITER=1000          !NUMBER OF ITERATIONS
        niter=5000          !NUMBER OF ITERATIONS 
        DO ie=1,10
          e0n=10.d0**ie
        DO iia1=1,6
          iap=2**iia1
        DO iia2=1,4
          iat=4**(iia2-1)
          IF(debug.GE.1)WRITE (moniou,207)e0n,iap,iat
207       FORMAT(2x,'PSAINI: INITIAL NUCLEUS ENERGY:',e10.3,2x,
     *    'PROJECTILE MASS:',i2,2x,'TARGET MASS:',i2)
          CALL xxaini(e0n,2,iap,iat)
          CALL crossc_kk(niter,gtot,gprod,gabs,gdd,gqel,gcoh)
          IF(debug.GE.1)WRITE (moniou,209)
     *    gtot,gprod,gabs,gdd,gqel,gcoh
c         WRITE (*,*)GTOT,GPROD
209       FORMAT(2x,'GTOT',d10.3,'  GPROD',d10.3,' GABS',d10.3/2x,
     *    'GDD',d10.3,'  GQEL',d10.3,' GCOH',d10.3)
          asect(ie,iia1,iia2)=log(gprod)
        ENDDO
        ENDDO
        ENDDO
        OPEN(2,file='SECTNU',status='UNKNOWN')
        WRITE (2,*)asect
        CLOSE(2)
      ENDIF
cdh  end
      IF(debug.GE.3)WRITE (moniou,218)
218   FORMAT(2x,'PSAINI - END')
      RETURN
      END
C=======================================================================

        FUNCTION psapint(X,J,L)
c PSAPINT - integrated Altarelli-Parisi function
c X - light cone momentum share value,
c J - type of initial parton (0 - g, 1 - q)
c L - type of final parton (0 - g, 1 - q)
C-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)x,j,l
201     FORMAT(2x,'PSAPINT: X=',e10.3,2x,'J= ',i1,2x,'L= ',i1)
        IF(j.EQ.0)THEN
          IF(l.EQ.0)THEN
            psapint=6.d0*(dlog(x/(1.d0-x))-x**3/3.d0+x**2/2.d0-2.d0*x)
          ELSE
            psapint=3.d0*(x+x**3/1.5d0-x*x)
          ENDIF
        ELSE
          IF(l.EQ.0)THEN
            psapint=(dlog(x)-x+.25d0*x*x)/.375d0
          ELSE
            z=1.d0-x
            psapint=-(dlog(z)-z+.25d0*z*z)/.375d0
          ENDIF
        ENDIF
        IF(debug.GE.2)WRITE (moniou,202)psapint
202     FORMAT(2x,'PSAPINT=',e10.3)
        RETURN
        END
C=======================================================================

      SUBROUTINE psasetc
c Common model parameters setting
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
      CHARACTER*7 TY
      COMMON /area15/ fp(5),rq(5),cd(5)
      COMMON /area17/ del,rs,rs0,fs,alfp,rr,sh,delh
      COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
      COMMON /area25/ ahv(5)
      COMMON /area26/ factork
      COMMON /area41/ ty(5)
      COMMON /area43/ moniou
      COMMON /debug/  debug
      SAVE

        IF(debug.GE.1)WRITE (moniou,210)
210     FORMAT(2x,'PSASETC - COMMON MODEL PARAMETERS SETTING')

c Soft pomeron parameters:
c DEL - overcriticity,
c ALFP - trajectory slope;
c FP(i) - vertices for pomeron-hadrons interaction (gamma(i)*gamma(proton)),
c RQ(i) - vertices slopes (R(i)**2+R(proton)**2),
c CD(i) - shower enhancement coefficients
c (i=1,...5 - pion,proton,kaon,D-meson,Lambda_C ),
c (Kaidalov et al., Sov.J.Nucl.Phys.,1984 - proton and pion parameters)
      del=.07d0
      alfp=.21d0

      fp(1)=2.43d0
      rq(1)=2.4d0
      cd(1)=1.6d0

      fp(2)=3.64d0
      rq(2)=3.56d0
      cd(2)=1.5d0

      fp(3)=1.75d0
      rq(3)=2.d0
      cd(3)=1.7d0

      fp(4)=1.21d0
      rq(4)=1.78d0
      cd(4)=2.0d0

      fp(5)=2.43d0
      rq(5)=2.4d0
      cd(5)=2.0d0

c-------------------------------------------------
c Hard interaction parameters:
c ALM  - Lambda_QCD squared,
c QT0  - Q**2 cutoff,
c RR   - vertex constant square for soft pomeron interaction with the hard block (r**2),;
c BET  - gluon structure function parameter for the soft pomeron ((1-x)**BET),
c AMJ0 - jet mass,
c QTF  - Q**2 cutoff for the timelike evolution,
c FACTORK - K-factor value;
c DELH is not a parameter of the model; it is used only for energy sharing
c procedure - initially energy is shared according to s**DELH dependence
c for the hard interaction cross-section and then rejection is used according
c to real Sigma_hard(s) dependence.
      alm=.04d0
      rr=.35d0     !  produces 76 mbarn for p-pbar at Tevatron energies
cdh   RR=.53D0     !  produces 80 mbarn for p-pbar at Tevatron energies
      qt0=4.d0
      bet=1.d0
      delh=0.25d0
      amj0=0.d0
      qtf=.5d0
      factork=2.d0

c-------------------------------------------------
c Valence quark structure functions for the hard scattering
c (~1/sqrt(x)*(1-x)**AHV(i), i=1,...5 corresponds to pion, nucleon etc.)
      ahv(1)=1.5d0
      ahv(2)=2.5d0
      ahv(3)=2.d0
      ahv(4)=4.d0
      ahv(5)=5.d0
c Initial particle types
      ty(1)='pion   '
      ty(2)='nucleon'
      ty(3)='kaon   '
      ty(4)='D-meson'
      ty(5)='LambdaC'
      RETURN
      END
C=======================================================================

        FUNCTION psbint(QQ,S,M,L)
C PSBINT - Born cross-section interpolation
c QQ - effective momentum cutoff for the scattering,
c S - total c.m. energy squared for the scattering,
c M - parton type at current end of the ladder (1 - g, 2 - q)
c L - parton type at opposite end of the ladder (1 - g, 2 - q)
C-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension wi(3),wk(3)
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area31/ csj(17,68)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)qq,s,m,l
201     FORMAT(2x,'PSBINT: QQ=',e10.3,2x,'S= ',e10.3,2x,'M= ',i1,2x,
     *  'L= ',i1)
        psbint=0.d0
        IF(s.LE.max(4.d0*qt0,qq))THEN
        IF(debug.GE.3)WRITE (moniou,202)psbint
202     FORMAT(2x,'PSBINT=',e10.3)
          RETURN
        ENDIF

        ml=17*(m-1)+34*(l-1)
        qli=dlog(qq/qt0)/1.38629d0
        sl=dlog(s/qt0)/1.38629d0
        sql=sl-qli
        i=int(qli)
        k=int(sl)
        IF(i.GT.13)i=13

        IF(sql.GT.10.d0)THEN
          IF(k.GT.14)k=14
          wi(2)=qli-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)
          wk(2)=sl-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 1 i1=1,3
          DO 1 k1=1,3
1         psbint=psbint+csj(i+i1,k+k1+ml)*wi(i1)*wk(k1)
          psbint=exp(psbint)
        ELSEIF(sql.LT.1.d0.AND.i.NE.0)THEN
          sq=(s/qq-1.d0)/3.d0
          wi(2)=qli-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)

          DO 2 i1=1,3
          i2=i+i1
          k2=i2+1+ml
2         psbint=psbint+csj(i2,k2)*wi(i1)
          psbint=exp(psbint)*sq
        ELSEIF(k.EQ.1)THEN
          sq=(s/qt0/4.d0-1.d0)/3.d0
          wi(2)=qli
          wi(1)=1.d0-qli

          DO 3 i1=1,2
3         psbint=psbint+csj(i1,3+ml)*wi(i1)
          psbint=exp(psbint)*sq
        ELSEIF(k.LT.15)THEN
          kl=int(sql)
          IF(i+kl.GT.12)i=12-kl
          IF(i+kl.EQ.1)kl=2
          wi(2)=qli-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)
          wk(2)=sql-kl
          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 4 i1=1,3
          i2=i+i1
          DO 4 k1=1,3
          k2=i2+kl+k1-1+ml
4         psbint=psbint+csj(i2,k2)*wi(i1)*wk(k1)
          psbint=exp(psbint)

        ELSE
          k=15
          IF(i.GT.k-3)i=k-3
          wi(2)=qli-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)
          wk(2)=sl-k
          wk(1)=1.d0-wk(2)

          DO 5 i1=1,3
          DO 5 k1=1,2
5         psbint=psbint+csj(i+i1,k+k1+ml)*wi(i1)*wk(k1)
          psbint=exp(psbint)
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psbint
        RETURN
        END
C=======================================================================

        FUNCTION psborn(QQ,S,IQ1,IQ2)
c PSFBORN -hard 2->2 parton scattering Born cross-section
c S is the c.m. energy square for the scattering process,
c IQ1 - parton type at current end of the ladder (0 - g, 1,2 - q)
c IQ2 - parton type at opposite end of the ladder (0 - g, 1,2 - q)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area6/  pi,bm,am
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area26/ factork
        COMMON /area43/ moniou
        COMMON /debug/  debug
        COMMON /ar3/  x1(7),a1(7)
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)qq,s,iq1,iq2
201     FORMAT(2x,'PSBORN: QQ=',e10.3,2x,'S= ',e10.3,2x,'IQ1= ',i1,2x,
     *  'IQ2= ',i1)
        tmin=s*(.5d0-dsqrt(.25d0-qt0/s))
        tmin=max(tmin,s*qq/(s+qq))

        IF(iq1*iq2.EQ.0)THEN
          iq=iq2
        ELSE
          iq=2
        ENDIF

        psborn=0.d0
        DO 1 i=1,7
        DO 1 m=1,2
        t=2.d0*tmin/(1.d0+2.d0*tmin/s-x1(i)*(2*m-3)*(1.d0-2.d0*tmin/s))
        qt=t*(1.d0-t/s)
        fb=psfborn(s,t,iq1,iq)+psfborn(s,s-t,iq1,iq)
1       psborn=psborn+a1(i)*fb/dlog(qt/alm)**2*t**2
        psborn=psborn*(.5d0/tmin-1.d0/s)*factork*pi**3/2.25d0**2/s**2
        IF(iq1.EQ.0.AND.iq2.EQ.0)psborn=psborn*.5d0
        IF(debug.GE.3)WRITE (moniou,202)psborn
202     FORMAT(2x,'PSBORN=',e10.3)
        RETURN
        END
C=======================================================================

        SUBROUTINE pscajet(QQ,IQ1,QV,ZV,QM,IQV,LDAU,LPAR,JQ)
c Final state emission process (all branchings as well as parton masses
c are determined)
C-----------------------------------------------------------------------
c QQ - maximal effective momentum transfer for the first branching
c IQ1, IQ2 - initial jet flavours in forward and backward direction
c (0 - for gluon)
c QV(i,j) - effective momentum for the branching of the parton in i-th row
c on j-th level (0 - in case of no branching)  - to be determined
c ZV(i,j) - Z-value for the branching of the parton in i-th row
c on j-th level - to be determined
c QM(i,j) - mass squared for the parton in i-th row
c on j-th level - to be determined
c IQV(i,j) - flavour for the parton in i-th row on j-th level 
c - to be determined
c LDAU(i,j) - first daughter row for the branching of the parton in i-th row
c on j-th level - to be determined
c LPAR(i,j) - the parent row for the parton in i-th row
c on j-th level - to be determined
    IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension qmax(30,50),iqm(2),lnv(50),
     *  qv(30,50),zv(30,50),qm(30,50),iqv(30,50),
     *  ldau(30,49),lpar(30,50)

        COMMON /area11/ b10
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area43/ moniou
        COMMON /debug/  debug

        SAVE
        EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)qq,iq1,jq
201     FORMAT(2x,'PSCAJET: QQ=',e10.3,2x,'IQ1= ',i1,2x,'JQ=',i1)

        DO 1 i=2,20
1   lnv(i)=0
        lnv(1)=1
        qmax(1,1)=qq
        iqv(1,1)=iq1
        nlev=1
        nrow=1

2        qlmax=dlog(qmax(nrow,nlev)/qtf/16.d0)
         iq=min(1,iabs(iqv(nrow,nlev)))+1

        IF(qsran(b10).GT.psudint(qlmax,iq))THEN
          q=psqint(qlmax,qsran(b10),iq)
          z=pszsim(q,iq)

          ll=lnv(nlev+1)+1
          ldau(nrow,nlev)=ll
          lpar(ll,nlev+1)=nrow
          lpar(ll+1,nlev+1)=nrow
          lnv(nlev+1)=ll+1

          IF(iq.NE.1)THEN
            IF((3-2*jq)*iqv(nrow,nlev).GT.0)THEN
              iqm(1)=0
              iqm(2)=iqv(nrow,nlev)
            ELSE
              iqm(2)=0
              iqm(1)=iqv(nrow,nlev)
              z=1.d0-z
            ENDIF
          ELSE
*********************************************************
            wg=psfap(z,0,0)
*********************************************************
            wg=wg/(wg+psfap(z,0,1))
            IF(qsran(b10).LT.wg)THEN
              iqm(1)=0
              iqm(2)=0
            ELSE
              iqm(1)=int(3.d0*qsran(b10)+1.d0)*(3-2*jq)
              iqm(2)=-iqm(1)
            ENDIF
            IF(qsran(b10).LT..5d0)z=1.d0-z
          ENDIF

          qv(nrow,nlev)=q
          zv(nrow,nlev)=z
        
          nrow=ll
          nlev=nlev+1
          qmax(nrow,nlev)=q*z**2
          qmax(nrow+1,nlev)=q*(1.d0-z)**2
          iqv(nrow,nlev)=iqm(1)
          iqv(nrow+1,nlev)=iqm(2)
        IF(debug.GE.3)WRITE (moniou,203)nlev,nrow,q,z
203     FORMAT(2x,'PSCAJET: NEW BRANCHING AT LEVEL NLEV=',i2,
     *  ' NROW=',i2/4x,' EFFECTIVE MOMENTUM Q=',e10.3,2x,' Z=',e10.3)
          GOTO 2
        ELSE

          qv(nrow,nlev)=0.d0
          zv(nrow,nlev)=0.d0
          qm(nrow,nlev)=amj0
        IF(debug.GE.3)WRITE (moniou,204)nlev,nrow
204     FORMAT(2x,'PSCAJET: NEW FINAL JET AT LEVEL NLEV=',i2,
     *  ' NROW=',i2)
        ENDIF

4       CONTINUE
      IF(nlev.EQ.1)THEN
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'PSCAJET - END')
        RETURN
      ENDIF
        lprow=lpar(nrow,nlev)

        IF(ldau(lprow,nlev-1).EQ.nrow)THEN
          nrow=nrow+1
          GOTO 2
        ELSE
          z=zv(lprow,nlev-1)
          qm(lprow,nlev-1)=z*(1.d0-z)*qv(lprow,nlev-1)
     *    +qm(nrow-1,nlev)/z+qm(nrow,nlev)/(1.d0-z)
          nrow=lprow
          nlev=nlev-1
        IF(debug.GE.3)WRITE (moniou,205)nlev,nrow,qm(lprow,nlev)
205     FORMAT(2x,'PSCAJET: JET MASS AT LEVEL NLEV=',i2,
     *  ' NROW=',i2,' - QM=',e10.3)
          GOTO 4
        ENDIF
        END
C=======================================================================

      SUBROUTINE psconf
c Simulation of the interaction configuration: impact parameter, nucleons positions,
c numbers of cut soft pomerons and semihard blocks, their connections.
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
c XA(56,3),XB(56,3) - arrays for projectile and target nucleons positions recording,
c FHARD(i) give the factors to the scattering amplitude due to
c valence quark-gluon (i=1),  gluon-valence quark (i=2) and
c valence quark-valence quark (i=3) interactions
cdh   DIMENSION XA(56,3),XB(56,3),FHARD(3)
      dimension xa(64,3),xb(64,3),fhard(3)
      COMMON /area1/  ia(2),icz,icp
      COMMON /area2/  s,y0,wp0,wm0
      COMMON /area6/  pi,bm,am
c Arrays for interaction configuration recording:
c LQA(i) (LQB(j)) - numbers of cut soft pomerons, connected to i-th projectile
c (j-th target) nucleon (hadron);
c LHA(i) (LHB(j)) - the same for hard pomerons numbers;
c IAS(k) (IBS(k)) - number (position in array) of the projectile (target) nucleon,
c connected to k-th block of soft pomerons;
c NQS(k) - number of soft pomerons in k-th block;
c IAH(k) (IBH(k)) - number (position in array) of the projectile (target) nucleon,
c connected to k-th hard pomeron;
c ZH(k) - impact parameter between the two nucleons connected to k-th hard pomeron
c (more exactly exp(-b**2/RP1));
c LVA(i)=1 if valence quark from i-th nucleon (i=1 for hadron) is involved into
c the hard interaction and LVA(i)=0 otherwise, LVB(j) - similar.
      COMMON /area9/  lqa(56),lqb(56),nqs(1000),ias(1000),ibs(1000),
     *                lha(56),lhb(56),zh(4000),iah(4000),ibh(4000),
     *                iqh(4000),lva(56),lvb(56)
      COMMON /area10/ stmass,am0,amn,amk,amc,amlamc,amlam,ameta
      COMMON /area11/ b10
c NSP - number of secondary particles
      COMMON /area12/ nsp
      COMMON /area16/ cc(5)
      COMMON /area40/ jdifr
      COMMON /area43/ moniou
**************************************************
      COMMON /area45/ gdt,gdp    !so00
**************************************************
      COMMON /area99/ nwt
      COMMON /debug/  debug

      dimension iwt(56)
      SAVE
      EXTERNAL qsran
      integer ng1evt,ng2evt,ikoevt
      real    rglevt,sglevt,eglevt,fglevt,typevt
      common/c2evt/ng1evt,ng2evt,rglevt,sglevt,eglevt,fglevt,ikoevt
     *,typevt            !in epos.inc   

        IF(debug.GE.1)WRITE (moniou,201)
201     FORMAT(2x,'PSCONF - CONFIGURATION OF THE INTERACTION')

100     nsp=0
        typevt=1          !NSD
        IF(ia(1).EQ.1)THEN
**************************************************
          IF(jdifr.EQ.1.AND.qsran(b10).LT.gdt)THEN
c Target diffraction
            IF(ia(2).NE.1)THEN
c ICT - partner target nucleon type (proton - 2 or neutron - 3)
              ict=int(2.5+qsran(b10))
            ELSE
c Target proton
              ict=2
            ENDIF
            wpi=wp0
            wmi=wm0
c              write (*,*)'difr'
            CALL xxdtg(wpi,wmi,icp,ict,0)
            typevt=3     !SD (low mass) 
            goto 21   !so00
          ELSEIF(abs(jdifr).EQ.1.AND.qsran(b10).LT.gdp)THEN  !so00
            IF(ia(2).NE.1)THEN  !so00
c ICT - partner target nucleon type (proton - 2 or neutron - 3)
              ict=int(2.5+qsran(b10))  !so00
            ELSE  !so00
c Target proton
              ict=2  !so00
            ENDIF  !so00
            IF(debug.GE.2)WRITE (moniou,206)  !so00
206         FORMAT(2x,'PROJECTILE HADRON DIFFRACTION')  !so00
            icp0=icp  !so00
            wpi=wp0  !so00
            wmi=wm0  !so00
            lq=0  !so00
            CALL xxdpr(wpi,wmi,icp0,ict,lq)  !so00
            typevt=3            !SD (low mass)   
            goto 21   !so00
          ENDIF
**************************************************
c For hadron projectile we have given position in transverse plane;
c initially primary hadron is positioned at (X,Y)=(0,0)
          DO 1 i=1,3
1          xa(1,i)=0.d0
      ENDIF

c-------------------------------------------------
c Inelastic interaction at B<BM (usual case)
c-------------------------------------------------
c NW - number of wounded nucleons in the primary (NW=1 for hadron);
c NT - number of target nucleons being in their active diffractive state;
c LS - number of cut soft pomeron blocks (froissarons);
c NHP - number of cut pomerons having hard block (referred below as hard blocks);
c NQS(k) - number of cut soft pomerons in k-th block;
c IAS(k) (IBS(k)) - number (position in array) of the projectile (target) nucleon,
c connected to k-th block of soft pomerons;
c IAH(k) (IBH(k)) - number 3(position in array) of the projectile (target) nucleon,
c connected to k-th hard pomeron;
c ZH(k) - impact parameter between the two nucleons connected to k-th hard pomeron
c (more exactly exp(-b**2/RP1));
c LQA(i) (LQB(j)) - total number of cut soft pomerons, connected to i-th projectile
c (j-th target) nucleon (hadron);
c LHA(i) (LHB(j)) - total number of cut hard blocks, connected to i-th projectile
c (j-th target) nucleon (hadron);
c LVA(i)=1 if valence quark from i-th nucleon (i=1 for hadron) is involved into
c the hard interaction and LVA(i)=0 otherwise, LVB(j) - similar.
c-------------------------------------------------
c Initialization
2         DO 3 i=1,ia(1)
          lha(i)=0
        lva(i)=0
3       lqa(i)=0
        DO 4 i=1,ia(2)
        lhb(i)=0
        lvb(i)=0
4       lqb(i)=0

c-------------------------------------------------
c The beginning
5       CONTINUE
**************************************************
        IF(ia(2).NE.1)THEN  !changed!!!!!!!!! dh 8/10/98
c For target nucleus number of target nucleons being in their active
c diffractive state is simulated (for each nucleon probability equals
c 1./C_n,  - shower enhancenment coefficient)
          nt=0
          DO 6 i=1,ia(2)
6         nt=nt+int(cc(2)+qsran(b10))
c In case of no active target nucleon the event is rejected
          IF(nt.EQ.0)GOTO 5
        IF(debug.GE.3)WRITE (moniou,203)nt
203     FORMAT(2x,'PSCONF: NUMBER OF ACTIVE TARGET NUCLEONS NT=',
     *  i2)
c PSGEA(NT,XB,2) - target nucleons positions simulation:
cdh       CALL PSGEA(NT,XB,2)  !changed!!!!!!!!!
          CALL psgea(ia(2),xb,2)  !changed!!!!!!!!! 25.03.99
c NT - number of target nucleons being in their active diffractive state;
c XB(i,n) - n-th nucleon coordinates (i=1,2,3 corresponds to x,y,z);
c parameter 2 means target
        ELSE                   !changed!!!!!!!!! dh 8/10/98
          nt=1                 !changed!!!!!!!!! dh 8/10/98
          xb(1,1)=0.d0         !changed!!!!!!!!! dh 8/10/98
          xb(1,2)=0.d0         !changed!!!!!!!!! dh 8/10/98
        ENDIF                  !changed!!!!!!!!! dh 8/10/98
**************************************************

c-------------------------------------------------
c Impact parameter  square is simulated uniformly (B**2<BM**2)
        b=bm*dsqrt(qsran(b10))
        IF(debug.GE.2)WRITE (moniou,204)b*am
204     FORMAT(2x,'PSCONF: IMPACT PARAMETER FOR THE INTERACTION:',
     *  e10.3,' FM')
c PSGEA(IA(1),XA,1) - projectile nucleons positions simulation:
c IA(1) - projectile nucleus mass number;
c XA(i,n) - n-th nucleon coordinates (i=1,2,3 corresponds to x,y,z);
c parameter 1 means projectile
        IF(ia(1).GT.1)CALL psgea(ia(1),xa,1)

        nw=0
        ls=0
        ns=0
        nhp=0
        DO 101 it = 1,nt
          iwt(it) = 0
 101    CONTINUE

c-------------------------------------------------
c Cycle over all projectile nucleons ( for projectile hadron we have only IN=1 )
        DO 14 in=1,ia(1)
        IF(debug.GE.2.AND.icz.EQ.2)WRITE (moniou,205)in
205     FORMAT(2x,'PSCONF: ',i2,'-TH PROJECTILE NUCLEON')
c Only nucleons in their active diffractive state are considered (for each nucleon
c probability equals 1./C_n, C_n = 1./CC(2) - shower enhancenment coefficient)
        IF(ia(1).NE.1.AND.qsran(b10).GT.cc(2))GOTO 12
c Projectile nucleons positions are shifted according the to impact parameter B
        x=xa(in,1)+b
        y=xa(in,2)

        iqs=0
        nw=nw+1
c-------------------------------------------------
c Cycle over all target nucleons in active state
        DO 11 m=1,nt
c Z - b-factor for pomeron eikonal calculation (exp(-R_ij/R_p))
        z=psdr(x-xb(m,1),y-xb(m,2))
c VV - eikonal for nucleon-nucleon (hadron-nucleon) interaction
c (sum of the soft and semihard eikonals)
        vv=2.d0*psfaz(z,fsoft,fhard,fshard)
        ev=exp(-vv)
c EH - eikonal contribution of valence quarks hard interactions
        eh=fhard(1)+fhard(2)+fhard(3)
c   eh=0.d0
        aks=qsran(b10)
c 1.-EXP(-VV)*(1.D0-2.D0*EH) is the probability for inelastic nucleon-nucleon
c (hadron-nucleon) interaction (for given nucleons positions)
        IF(aks.GT.1.d0-ev*(1.d0-2.d0*eh))GOTO 11
        IF(debug.GE.2)WRITE (moniou,208)m
208     FORMAT(2x,'PSCONF: INTERACTION WITH',i2,'-TH TARGET NUCLEON')
C  INCREMENT THE NUMBER IWT OF WOUNDED TARGET NUCLEONS
        iwt(m) = 1

c-------------------------------------------------
c IQV - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
        iqv=0

c 2*EH*EV = 2*EH*EXP(-VV) - probability for only valence quarks hard interactions
c (with no one soft or semihard)
        sum=2.d0*eh*ev

c-------------------------------------------------
        IF(aks.LT.sum)THEN
          aks1=eh*qsran(b10)
          IF(aks1.LT.fhard(1))THEN
c Rejection in case of valence quark already involved into the interaction
            IF(lva(nw).NE.0)GOTO 11
c LVA(NW)=1 - valence quark-gluon interaction
            lva(nw)=1
            iqv=1
          ELSEIF(aks1.LT.fhard(1)+fhard(2))THEN
c Rejection in case of valence quark already involved into the interaction
            IF(lvb(m).NE.0)GOTO 11
c LVB(M)=1 - gluon-valence quark interaction
            lvb(m)=1
            iqv=2
          ELSE
c Rejection in case of valence quarks already involved into the interaction
            IF(lva(nw)+lvb(m).NE.0)GOTO 11
c LVA(NW)=LVB(M)=1 - valence quark-valence quark interaction
            lva(nw)=1
            lvb(m)=1
            iqv=3
          ENDIF
          n=1
c LNH - number of new hard blocks (resulted from current nucleon-nucleon interaction)
          lnh=1
          GOTO 22
        ENDIF
c-------------------------------------------------

c LNH - number of new hard blocks - initialization
        lnh=0
c WH - probability to have semihard interaction
        wh=2.d0*fshard/vv
c N - number of cut pomerons (both soft ones and having hard blocks) for the
c nucleon-nucleon (hadron-nucleon) interaction - is determined according to Poisson
c with average value VV (twice the eikonal)
        DO 7 n=1,45
        ev=ev*vv/n
        sum=sum+ev
7       IF(aks.LT.sum)GOTO 8

c LNH - number of hard blocks for nucleon-nucleon (hadron-nucleon)
c interaction (according to WH probability)
8       DO 9 i=1,n
9       lnh=lnh+int(wh+qsran(b10))

c-------------------------------------------------
        aks1=.5d0*qsran(b10)
c EH is the probability to have valence quarks interactions in addition to the
c soft and semihard
        IF(aks1.LT.eh)THEN
          IF(aks1.LT.fhard(1))THEN
            IF(lva(nw).NE.0)GOTO 22
c Valence quark-gluon interaction
            lva(nw)=1
            iqv=1
          ELSEIF(aks1.LT.fhard(1)+fhard(2))THEN
            IF(lvb(m).NE.0)GOTO 22
c Gluon-valence quark interaction
            lvb(m)=1
            iqv=2
          ELSE
            IF(lva(nw)+lvb(m).NE.0)GOTO 22
c Valence quark-valence quark interaction
            lva(nw)=1
            lvb(m)=1
            iqv=3
          ENDIF
          n=n+1
          lnh=lnh+1
        ENDIF

22      iqs=1
        IF(lnh.NE.0)THEN
c-------------------------------------------------
c New hard blocks recording:
c LNH - number of new hard blocks,
c LHA(i) (LHB(j)) - total number of cut hard blocks, connected to i-th projectile
c (j-th target) nucleon (hadron);
c IAH(k) (IBH(k)) - number (position in array) of the projectile (target) nucleon,
c connected to k-th hard block;
c ZH(k) - factor exp(-R_ij/R_p) for k-th hard block;
c IQH(k) - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
c-------------------------------------------------
c N - number of cut soft pomerons
          n=n-lnh
          lha(nw)=lha(nw)+lnh
          lhb(m)=lhb(m)+lnh
          DO 10 i=1,lnh
          i1=nhp+i
          If (i1 .ge. 4000) then
            write(moniou,*)'psconf: I1 > 4000, index out of bounds'
            stop
          endif
          IF(i.EQ.1.AND.iqv.NE.0)THEN
            iqh(i1)=iqv
          ELSE
            iqh(i1)=0
          ENDIF
        IF(debug.GE.2)WRITE (moniou,209)i1,nw,m,iqh(i1)
209     FORMAT(2x,'PSCONF: ',i4,'-TH HARD BLOCK IS CONNECTED TO',1x,
     *  i2,'-TH PROJECTILE NUCLEON (HADRON) AND'/4x,i2,
     *  '-TH TARGET NUCLEON; TYPE OF THE SEMIHARD INTERACTION:',i1)
          zh(i1)=z
          iah(i1)=nw
10        ibh(i1)=m
c-------------------------------------------------
c NHP - total number of hard blocks
          nhp=nhp+lnh
        ENDIF

c-------------------------------------------------
        IF(n.GT.0)THEN
c One more block of soft pomerons; soft block characteristics recording
          ls=ls+1
          ias(ls)=nw
          ibs(ls)=m
          lqa(nw)=lqa(nw)+n
          lqb(m)=lqb(m)+n
          nqs(ls)=n
        IF(debug.GE.2)WRITE (moniou,210)ls,nw,m,n
210     FORMAT(2x,'PSCONF: ',i4,'-TH SOFT BLOCK IS CONNECTED TO',1x,
     *  i2,'-TH PROJECTILE NUCLEON (HADRON) AND'/4x,i2,
     *  '-TH TARGET NUCLEON; NUMBER OF POMERONS IN THE BLOCK NP=',
     *  i2)
        ENDIF
11      CONTINUE
c-------------------------------------------------

        IF(iqs.NE.0)GOTO 14
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c Projectile diffraction
c For each projectile nucleon (hadron) diffractive dissociation probability is
c (1.D0-CC(ICZ))*PSV(X,Y,XB,NT);
c XXV(X,Y,XB,NT) - nucleon-nucleus scattering eikonal factor
c ( (1-eikonal)**2 ) for given nucleons positions
c (For projectile hadron only in case of JPERI=0, otherwise it was considered
c before at any impact parameter )
        IF(jdifr.EQ.1 .AND. ia(1).NE. 1
     *  .AND.qsran(b10).LT.(1.d0-cc(icz))*psv(x,y,xb,nt))THEN
**************************************************
          IF(ia(2).NE.1)THEN
c ICT - partner target nucleon type (proton - 2 or neutron - 3)
            ict=int(2.5+qsran(b10))
          ELSE
c Target proton
            ict=2
          ENDIF
c Projectile nucleon 
          IF(debug.GE.2)WRITE(moniou,207)in
207       FORMAT(2x,i2,'-TH PROJECTILE NUCLEON DIFFRACTION')
          icp0=int(2.5+qsran(b10))
          wpi=wp0
          wmi=wm0
          IF(ia(2).EQ.1)THEN
            lq=0
          ELSE
            lq=1
          ENDIF
          CALL xxdpr(wpi,wmi,icp0,ict,lq)
          GOTO 14
        ENDIF
**************************************************
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c No interaction for projectile nucleon considered
        nw=nw-1
12      CONTINUE

c One more projectile spectator (noninteracting) nucleon (spectator positions
c are recorded to simulate nuclear fragmentation)
        ns=ns+1
        IF(ns.NE.in)THEN
          DO 13 l=1,3
13          xa(ns,l)=xa(in,l)
        ENDIF
14      CONTINUE

c In case of no one interacting (or D-diffracted) nucleon the event is
c rejected, new impact parameter is generated and all the procedure is
c repeated
      IF(ns.EQ.ia(1))THEN
        IF(debug.GE.3)WRITE (moniou,211)
211     FORMAT(2x,'PSCONF: NO ONE NUCLEON (HADRON) INTERACTS - ',
     *  'REJECTION')
         GOTO 5
      ENDIF
c-------------------------------------------------
cdh   if(nhp.gt.150)then            ! changed 18. Feb. 04
      if(nhp.gt.1500)then    
        WRITE (moniou,213)nhp
213     FORMAT(2x,'PSCONF: TOO GREAT NUMBER OF HARD POMERONS: NHP=',
     *  i5,' - REJECTION')
         GOTO 100
      endif   

      nwt = 0
C  number of interacting target nucleons
      DO 102 it = 1,nt
        nwt = nwt + iwt(it)
 102  CONTINUE

cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c Fragmentation of the spectator part of the nucleus
      CALL xxfragm(ns,xa)
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

c Inelastic interaction - energy sharing procedure
20      IF(nw.NE.0)CALL psshar(ls,nhp,nw,nt)
21      continue                     !so00
        IF(debug.GE.3)WRITE (moniou,212)
212     FORMAT(2x,'PSCONF - END')
        RETURN
c////////////////
        entry qgs1getdiffcode( jcode )
        jcode = jdiff
c//////////////
        END
C=======================================================================

       SUBROUTINE pscs(C,S)
c C,S - COS and SIN generation for uniformly distributed angle 0<fi<2*pi
c-----------------------------------------------------------------------
       IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
       COMMON /area11/ b10
       COMMON /area43/ moniou
       COMMON /debug/  debug
       SAVE
       EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)
201     FORMAT(2x,'PSCS - COS(FI) AND SIN(FI) ARE GENERATED',
     *  ' (0<FI<2*PI)')
1      s1=2.d0*qsran(b10)-1.d0
       s2=2.d0*qsran(b10)-1.d0
       s3=s1*s1+s2*s2
       IF(s3.GT.1.d0)GOTO 1
       s3=dsqrt(s3)
       c=s1/s3
       s=s2/s3
        IF(debug.GE.3)WRITE (moniou,202)c,s
202     FORMAT(2x,'PSCS: C=',e10.3,2x,'S=',e10.3)
       RETURN
       END
C=======================================================================

        SUBROUTINE psdeftr(S,EP,EY)
c Determination of the parameters for the Lorentz transform to the rest frame
c system for 4-vector EP
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ey(3),ep(4)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)ep,s
201     FORMAT(2x,'PSDEFTR - LORENTZ BOOST PARAMETERS:'/
     *  4x,'4-VECTOR EP=',4e10.3/4x,'4-VECTOR SQUARED S=',e10.3)
        DO 2 i=1,3
        IF(ep(i+1).EQ.0.d0)THEN
          ey(i)=1.d0
        ELSE
            wp=ep(1)+ep(i+1)
          wm=ep(1)-ep(i+1)
          IF(wm/wp.LT.1.d-8)THEN
            ww=s
            DO 1 l=1,3
1            IF(l.NE.i)ww=ww+ep(l+1)**2
            wm=ww/wp
          ENDIF
          ey(i)=dsqrt(wm/wp)
          ep(1)=wp*ey(i)
          ep(i+1)=0.d0
        ENDIF
2       CONTINUE
        IF(debug.GE.3)WRITE (moniou,202)ey
202     FORMAT(2x,'PSDEFTR: LORENTZ BOOST PARAMETERS EY(I)=',2x,3e10.3)
        RETURN
        END
C=======================================================================

        SUBROUTINE psdefrot(EP,S0X,C0X,S0,C0)
c Determination of the parameters the spacial rotation to the lab. system
c for 4-vector EP
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep(4)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)ep
201     FORMAT(2x,'PSDEFROT - SPACIAL ROTATION PARAMETERS'/4x,
     *  '4-VECTOR EP=',2x,4(e10.3,1x))
c Transverse momentum square for the current parton (EP)
        pt2=ep(3)**2+ep(4)**2
        IF(pt2.NE.0.d0)THEN
          pt=dsqrt(pt2)
c System rotation to get Pt=0 - Euler angles are determined (C0X = cos theta,
c S0X = sin theta, C0 = cos phi, S0 = sin phi)
          c0x=ep(3)/pt
          s0x=ep(4)/pt
c Total momentum for the gluon
          pl=dsqrt(pt2+ep(2)**2)
          s0=pt/pl
          c0=ep(2)/pl
        ELSE
          c0x=1.d0
          s0x=0.d0
          pl=abs(ep(2))
          s0=0.d0
          c0=ep(2)/pl
        ENDIF

        ep(2)=pl
        ep(3)=0.d0
        ep(4)=0.d0
        IF(debug.GE.3)WRITE (moniou,202)s0x,c0x,s0,c0,ep
202     FORMAT(2x,'PSDEFROT: SPACIAL ROTATION PARAMETERS'/
     *  4x,'S0X=',e10.3,2x,'C0X=',e10.3,2x,'S0=',e10.3,2x,'C0=',e10.3/
     *  4x,'ROTATED 4-VECTOR EP=',4(e10.3,1x))
        RETURN
        END
C=======================================================================

        FUNCTION psdr(X,Y)
c PSDR - impact parameter factor for eikonals calculation (exp(-Rij/Rp)=Z)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area7/  rp
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)x,y
201     FORMAT(2x,'PSDR: NUCLEON COORDINATES - X=',e10.3,2x,'Y=',e10.3)
        psdr=exp(-(x*x+y*y)/rp)
        IF(debug.GE.3)WRITE (moniou,202)psdr
202     FORMAT(2x,'PSDR=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psfap(X,J,L)
C PSFAP - Altarelli-Parisi function (multiplied by X)
c X - light cone momentum share value,
c J - type of the parent parton (0-g,1-q)
c L - type of the daughter parton (0-g,1-q)
C-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)x,j,l
201     FORMAT(2x,'PSFAP - ALTARELLI-PARISI FUNCTION:',2x,
     *  'X=',e10.3,2x,'J=',i1,2x,'L=',i1)
        IF(j.EQ.0)THEN
          IF(l.EQ.0)THEN
            psfap=((1.d0-x)/x+x/(1.d0-x)+x*(1.d0-x))*6.d0
          ELSE
            psfap=(x**2+(1.d0-x)**2)*3.d0
          ENDIF
        ELSE
          IF(l.EQ.0)THEN
            psfap=(1.d0+(1.d0-x)**2)/x/.75d0
          ELSE
            psfap=(x**2+1.d0)/(1.d0-x)/.75d0
          ENDIF
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psfap
202     FORMAT(2x,'PSFAP=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psfaz(Z,FSOFT,FHARD,FSHARD)
c Interaction eikonal for hadron-nucleon (nucleon-nucleon) scattering
c Z - impact parameter factor, Z=exp(-b**2/Rp),
c FSOFT - soft pomeron eikonal - to be determined,
c FSHARD - semihard interaction eikonal (gg) - to be determined,
c FHARD(k) - hard interaction eikonal (k=1 - qg, 2 - gq, 3 - qq) -
c to be determined,
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension fhard(3)
        COMMON /area17/ del,rs,rs0,fs,alf,rr,sh,delh
        COMMON /area22/ sjv,fjs(5,3)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)z
201     FORMAT(2x,'PSFAZ - HADRON-NUCLEON (NUCLEON-NUCLEON)',
     *  ' INTERACTION EIKONAL; Z=',e10.3)
        fsoft=fs*z
        fhard(3)=sjv*z**(rs/rs0)

        jz=int(5.d0*z)
        IF(jz.GT.3)jz=3
        wz=5.d0*z-jz

        DO 1 i=1,3
        IF(jz.EQ.0)THEN
          fsr=(exp(fjs(1,i))*wz+(exp(fjs(2,i))-2.d0*
     *    exp(fjs(1,i)))*wz*(wz-1.d0)*.5d0)*z
        ELSE
          fsr=exp(fjs(jz,i)+(fjs(jz+1,i)-fjs(jz,i))*wz
     *    +(fjs(jz+2,i)+fjs(jz,i)-2.d0*fjs(jz+1,i))
     *    *wz*(wz-1.d0)*.5d0)*z
        ENDIF
        IF(i.NE.1)THEN
          fhard(i-1)=fsr
        ELSE
          fshard=fsr
        ENDIF
1       CONTINUE

        psfaz=fsoft+fshard
        IF(debug.GE.3)WRITE (moniou,202)psfaz,fsoft,fshard,fhard
202     FORMAT(2x,'PSFAZ=',e10.3,2x,'FSOFT=',e10.3,2x,'FSHARD=',e10.3/4x
     *    ,'FHARD=',3e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psfborn(S,T,IQ1,IQ2)
c PSFBORN - integrand for the Born cross-section (matrix element squared)
c S - total c.m. energy squared for the scattering,
c T - invariant variable for the scattering abs[(p1-p3)**2],
c IQ1 - parton type at current end of the ladder (0 - g, 1,2 - q)
c IQ2 - parton type at opposite end of the ladder (0 - g, 1,2 - q)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,t,iq1,iq2
201     FORMAT(2x,'PSFBORN - HARD SCATTERING MATRIX ELEMENT SQUARED:'/
     *  4x,'S=',e10.3,2x,'|T|=',e10.3,2x,'IQ1=',i2,2x,'IQ2=',i2)
        u=s-t
        IF(iq1.EQ.0.AND.iq2.EQ.0)THEN
c Gluon-gluon
          psfborn=(3.d0-t*u/s**2+s*u/t**2+s*t/u**2)*4.5d0
        ELSEIF(iq1*iq2.EQ.0)THEN
c Gluon-quark
          psfborn=(s**2+u**2)/t**2+(s/u+u/s)/2.25d0
        ELSEIF(iq1.EQ.iq2)THEN
c Quark-quark (of the same flavor)
          psfborn=((s**2+u**2)/t**2+(s**2+t**2)/u**2)/2.25d0
     *    -s**2/t/u/3.375d0
        ELSEIF(iq1+iq2.EQ.0)THEN
c Quark-antiquark (of the same flavor)
          psfborn=((s**2+u**2)/t**2+(u**2+t**2)/s**2)/2.25d0
     *    -u**2/t/s/3.375d0
        ELSE
c Quark-quark (different flavors)
          psfborn=(s**2+u**2)/t**2/2.25d0
        ENDIF
        IF(debug.GE.2)WRITE (moniou,202)psfborn
202     FORMAT(2x,'PSFBORN=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psfsh(S,Z,ICZ,IQQ)
c PSFSH - semihard interaction eikonal
c S - energy squared for the interaction (hadron-hadron),
c ICZ - type of the primaty hadron (nucleon)
c Z - impact parameter factor, Z=exp(-b**2/Rp),
c IQQ - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area6/  pi,bm,am
        COMMON /area15/ fp(5),rq(5),cd(5)
        COMMON /area17/ del,rs,rs0,fs,alf,rr,sh,delh
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area19/ ahl(5)
        COMMON /area25/ ahv(5)
        COMMON /area27/ fp0(5)
        COMMON /ar3/    x1(7),a1(7)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,z,iqq,icz
201     FORMAT(2x,'PSFSH - SEMIHARD INTERACTION EIKONAL:'/
     *  4x,'S=',e10.3,2x,'Z=',e10.3,2x,'IQQ=',i1,2x,'ICZ=',i1)
        xmin=4.d0*qt0/s
        xmin=xmin**(delh-del)
        psfsh=0.d0
        IF(iqq.EQ.1)THEN
          icv=icz
          icq=2
        ELSEIF(iqq.EQ.2)THEN
          icv=2
          icq=icz
        ENDIF
        iq=(iqq+1)/2

c Numerical integration over Z1
        DO 3 i=1,7
        DO 3 m=1,2
        z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))**(1.d0/
     *  (delh-del))
c SJ is the DLA inclusive hard partonic (gluon-gluon) interaction
c cross-section (inclusive cut ladder cross section) for minimal
c 4-momentum transfer squre QT0 and c.m. energy square s_hard = exp YJ;
c SJB - Born cross-section
        CALL psjint0(z1*s,sj,sjb,iq,0)
c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic (gluon-gluon)
c interaction cross-section for minimal 4-momentum transfer square QT0 and
c c.m. energy square s_hard = exp YJ; SH=pi*R_hard**2 (R_hard**2=4/QT0)
        gy=2.d0*sh*psgint((sj-sjb)/sh*.5d0)+sjb
        IF(debug.GE.3)WRITE (moniou,203)z1*s,gy
203     FORMAT(2x,'PSFSH:',2x,'S_HARD=',e10.3,2x,'SIGMA_HARD=',e10.3)

        IF(iqq.EQ.0)THEN
          st2=0.d0
          DO 1 j=1,7
          DO 1 k=1,2
          xx=.5d0*(1.d0+x1(j)*(2*k-3))
1         st2=st2+a1(j)*psftild(z1**xx,icz)*
     *    psftild(z1**(1.d0-xx),2)

          rh=rs0-alf*dlog(z1)
          psfsh=psfsh-a1(i)*dlog(z1)*gy/z1**delh*z**(rs/rh)/rh*st2
        ELSE

          st2=0.d0
          DO 2 j=1,7
          DO 2 k=1,2
          xx=.5d0*(1.d0+x1(j)*(2*k-3))
          xam=z1**(del+.5d0)
          xa=(xam+(1.d0-xam)*xx)**(1.d0/(del+.5d0))
          rh=rs0+alf*dlog(xa/z1)
2         st2=st2+a1(j)*(1.d0-xa)**ahv(icv)*z**(rs/rh)/rh*
     *    psftild(z1/xa,icq)
          st2=st2*(1.d0-xam)

          psfsh=psfsh+a1(i)*gy/z1**delh*st2
        ENDIF
3       CONTINUE

        IF(iqq.EQ.0)THEN
          psfsh=psfsh*.125d0*rr*(1.d0-xmin)/(delh-del)*fp0(icz)*fp0(2)
     *    *cd(icz)
        ELSE
          psfsh=psfsh*dsqrt(rr)/16.d0*fp0(icq)*(1.d0-xmin)/(delh-del)/
     *    (del+.5d0)*gamfun_kk(ahv(icv)+1.5d0)
     *    /gamfun_kk(ahv(icv)+1.d0)/pi*cd(icz)
          IF(icz.EQ.2.OR.iqq.EQ.2)THEN
            psfsh=psfsh*3.d0
          ELSEIF((icz-1)*(icz-3)*(icz-5).EQ.0)THEN
            psfsh=psfsh*2.d0
          ENDIF
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psfsh
202     FORMAT(2x,'PSFSH=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psftild(Z,ICZ)
c PSFTILD - auxilliary function for semihard eikonals calculation -
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 /area17/ del,rs,rs0,fs,alfp,rr,sh,delh
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area19/ ahl(5)
        COMMON /ar3/  x1(7),a1(7)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)z,icz
201     FORMAT(2x,'PSFTILD:',2x,'Z=',e10.3,2x,'ICZ=',i1)
        psftild=0.
        DO 1 i=1,7
        DO 1 m=1,2
        xb=1.d0-(1.d0-z)*(.5d0*(1.d0+(2*m-3)*x1(i)))**(1.d0/
     *  (ahl(icz)+1.d0))
1       psftild=psftild+a1(i)*xb**del*(1.d0-z/xb)**bet
        psftild=psftild*.5d0*(1.d0-z)**(ahl(icz)+1.d0)/(ahl(icz)+1.d0)
        IF(debug.GE.3)WRITE (moniou,202)psftild
202     FORMAT(2x,'PSFTILD=',e10.3)
        RETURN
        END
C=======================================================================

      SUBROUTINE psgea(IA,XA,JJ)
c PSGEA - nuclear configuration simulation (nucleons positions)
c IA - number of nucleons to be considered
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
cdh   DIMENSION XA(56,3)
      dimension xa(64,3)
      COMMON /area5/  rd(2),ca1(2),ca2(2),ca3(2)
      COMMON /area11/ b10
      COMMON /area43/ moniou
      COMMON /debug/  debug
      SAVE
      EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)jj,ia
201     FORMAT(2x,'PSGEA - CONFIGURATION OF THE NUCLEUS ',i1,';',2x,
     *  'COORDINATES FOR ',i2,' NUCLEONS')
cdh     IF(JJ.EQ.2.OR.IA.GE.10)THEN
        IF(ia.GE.10)THEN !this line had been changed!!!!!!! dh 8/10/98
cdh
          DO 7 i=1,ia
1         zuk=qsran(b10)*ca1(jj)-1.d0
          IF(zuk)2,2,3
2         tt=rd(jj)*(qsran(b10)**.3333d0-1.d0)
          GOTO 6
3         IF(zuk.GT.ca2(jj))GOTO 4
          tt=-dlog(qsran(b10))
          GOTO 6
4         IF(zuk.GT.ca3(jj))GOTO 5
          tt=-dlog(qsran(b10))-dlog(qsran(b10))
          GOTO 6
5         tt=-dlog(qsran(b10))-dlog(qsran(b10))-dlog(qsran(b10))
6         IF(qsran(b10).GT.1.d0/(1.d0+exp(-abs(tt))))GOTO 1
          rim=tt+rd(jj)
          z=rim*(2.d0*qsran(b10)-1.d0)
          rim=dsqrt(rim*rim-z*z)
          xa(i,3)=z
          CALL pscs(c,s)
          xa(i,1)=rim*c
7         xa(i,2)=rim*s
        ELSE

          DO 9 l=1,3
          summ=0.d0
          DO 8 i=1,ia-1
          j=ia-i
          aks=rd(jj)*(qsran(b10)+qsran(b10)+qsran(b10)-1.5d0)
          k=j+1
          xa(k,l)=summ-aks*sqrt(float(j)/k)
8         summ=summ+aks/sqrt(float(j*k))
9         xa(1,l)=summ
        ENDIF
        IF(debug.GE.3)THEN
          WRITE (moniou,203)
          DO 206 i=1,ia
206       WRITE (moniou,204)i,(xa(i,l),l=1,3)
          WRITE (moniou,202)
        ENDIF
202     FORMAT(2x,'PSGEA - END')
203     FORMAT(2x,'PSGEA:  POSITIONS OF THE NUCLEONS')
204     FORMAT(2x,'PSGEA: ',i2,' - ',3(e10.3,1x))
        RETURN
        END
C=======================================================================

        FUNCTION psgint(Z)
c Auxiliary function for eikonal cross-sections calculation
c GINT = int(dt) [0<t<Z] (1-exp(-t))/t
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
      COMMON /ar3/  x1(7),a1(7)
      COMMON /area43/ moniou
      COMMON /debug/  debug
      SAVE

        f(z,x)=(1.-exp(-.5*z*(1.+x)))/(1.+x)

        IF(debug.GE.2)WRITE (moniou,201)z
201     FORMAT(2x,'PSGINT:',2x,'Z=',e10.3)
        psgint=0.
        DO 5 i=1,7
5       psgint=psgint+a1(i)*(f(z,x1(i))+f(z,-x1(i)))
        IF(debug.GE.3)WRITE (moniou,202)psgint
202     FORMAT(2x,'PSGINT=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION pshard(S,ICZ)
c PSHARD - 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 /ar3/    x1(7),a1(7)
        COMMON /area6/  pi,bm,am
        COMMON /area15/ fp(5),rq(5),cd(5)
        COMMON /area17/ del,rs,rs0,fs,alf,rr,sh,delh
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area19/ ahl(5)
        COMMON /area25/ ahv(5)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,icz
201     FORMAT(2x,'PSHARD - HARD QUARK-QUARK INTERACTION CROSS',
     *  ' SECTION:',
     *  2x,'S=',e10.3,2x,'ICZ=',i1)
        xmin=4.d0*qt0/s
        xmin=xmin**(delh+.5d0)
        pshard=0.d0

c Numerical integration over Z1
        DO 2 i=1,7
        DO 2 m=1,2
        z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))**(1.d0/
     *  (delh+.5d0))

        st2=0.d0
        DO 1 j=1,7
        DO 1 k=1,2
        xx=.5d0*(1.d0+x1(j)*(2*k-3))
        st2=st2+a1(j)*(1.d0-z1**xx)**ahv(icz)*
     *  (1.d0-z1**(1.d0-xx))**ahv(2)
1       CONTINUE

c SJ is the DLA inclusive hard partonic (gluon-gluon) interaction
c cross-section (inclusive cut ladder cross section) for minimal
c 4-momentum transfer squre QT0 and c.m. energy square s_hard = exp YJ;
c SJB - Born cross-section
        CALL psjint0(z1*s,sj,sjb,1,1)
c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic (quark-quark)
c interaction cross-section for minimal 4-momentum transfer square QT0 and
c c.m. energy square s_hard = exp YJ; SH=pi*R_hard**2 (R_hard**2=4/QT0)
        gy=2.d0*sh*psgint((sj-sjb)/sh*.5d0)+sjb

        IF(debug.GE.3)WRITE (moniou,203)z1*s,gy
203     FORMAT(2x,'PSHARD:',2x,'S_HARD=',e10.3,2x,'SIGMA_HARD=',e10.3)
        pshard=pshard-a1(i)*dlog(z1)*gy/z1**delh*st2
2       CONTINUE

        pshard=pshard*(1.d0-xmin)/(.5d0+delh)*.25d0
        pshard=pshard/(gamfun_kk(ahv(icz)+1.d0)*
     *    gamfun_kk(ahv(2)+1.d0)*pi)*
     *  gamfun_kk(ahv(icz)+1.5d0)*gamfun_kk(ahv(2)+1.5d0)

        IF(icz.EQ.2)THEN
          pshard=pshard*9.d0
        ELSEIF((icz-1)*(icz-3)*(icz-5).EQ.0)THEN
          pshard=pshard*6.d0
        ELSE
          pshard=pshard*3.d0
        ENDIF

c Hard cross-section is divided by Regge radius RS0 and multiplied by
c shower enhancement coefficient CD(ICZ) - to be used for the eikonal
c calculation
        pshard=pshard/(8.d0*pi*rs0)*cd(icz)
        IF(debug.GE.2)WRITE (moniou,202)pshard
202     FORMAT(2x,'PSHARD=',e10.3)
        RETURN
        END
C=======================================================================

        SUBROUTINE pshot(WP0,WM0,Z,IPC,EPC,IZP,IZT,ICZ,IQQ)
c Semihard jets production simulation (resulted from parton-parton
c interaction);
c WP0,WM0 - light cone momenta shares (E+-P_l) for the initial partons
c IZP, IZT - types for target and projectile nucleons (hadron)
c WPQ - light cone momenta for the soft preevolution - to be determined below
c IQQ - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        CHARACTER*2 TYQ
        dimension ep(4,2),ept(4),ept0(4),ep3(4),epj(4),epj1(4),ey(3),
     *  qmin(2),wp(2),iqc(2),iqp(2),
     *  ipc(2,2),epc(8,2),iqj(2),eqj(4,2),ipq(2,2),epq(8,2),
     *  ebal(4),
     *  qv1(30,50),zv1(30,50),qm1(30,50),iqv1(2,30,50),
     *  ldau1(30,49),lpar1(30,50),
     *  qv2(30,50),zv2(30,50),qm2(30,50),iqv2(2,30,50),
     *  ldau2(30,49),lpar2(30,50)
        COMMON /area6/  pi,bm,ammm
        COMMON /area8/  wwm,be(4),dc(5),deta,almpt
        COMMON /area10/ stmass,am(7)
        COMMON /area11/ b10
        COMMON /area17/ del,rs,rs0,fs,alf,rr,sh,delh
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area42/ tyq(15)
        COMMON /area43/ moniou
        COMMON /area46/ epjet(4,2,15000),ipjet(2,15000)
        COMMON /area47/ njtot
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran

        IF(debug.GE.1)WRITE (moniou,201)iqq,wp0,wm0
201     FORMAT(2x,'PSHOT - SEMIHARD INTERACTION SIMULATION:'/
     *  4x,'TYPE OF THE INTERACTION:',i2/
     *  4x,'INITIAL LIGHT CONE MOMENTA:',2e10.3)
c S - total energy squared for the semihard interaction (including preevolution)
        njtot0=njtot
        izp0=izp
        izt0=izt
        
301     s=wp0*wm0
        njtot=njtot0
        izp=izp0
        izt=izt0

        IF(iqq.EQ.3)THEN
c WPI,WMI - light cone momenta for the hard interaction
          wpi=wp0
          wmi=wm0
c PSJINT0(S,SJ,SJB,1,1) - cross-sections interpolation:
c SJ - inclusive hard quark-quark interaction
c cross-section (inclusive cut ladder cross section) for minimal
c 4-momentum transfer square QT0 and c.m. energy square s_hard = S;
c SJB - Born cross-section
          CALL psjint0(s,sj,sjb,1,1)
c GY= Sigma_hard_tot(YJ,QT0) - total hard quark-quark
c interaction cross-section for minimal 4-momentum transfer square QT0 and
c c.m. energy square s_hard = S
          gy=2.d0*sh*psgint((sj-sjb)/sh*.5d0)+sjb

        ELSE
c-------------------------------------------------
c Rejection function normalization
c-------------------------------------------------
c XMIN corresponds to minimal energy squared for the hard interaction - 4.D0*(QT0+AMJ0)
c AMJ0 - jet mass squared (could be put equal zero)
          xmin=4.d0*(qt0+amj0)/s
          xmin1=xmin**(delh-del)
c S - maximal available energy for the rejection function normalization
c Auxilliary type of parton (1 - gluon, 2 - (anti-)quark)
          iq=(iqq+1)/2
c Rejection function initialization (corresponding to maximal preevolution - minimal x):
c Ysoft = - ln x, (1-x)**bet is due to gluon structure function in the soft pomeron
          IF(iqq.EQ.0)THEN
             gb0=-dlog(xmin)*(1.d0-dsqrt(xmin))**(2.d0*bet)
          ELSE
             gb0=(1.d0-xmin)**bet
          ENDIF

c SJ0 is the inclusive hard (parton IQ - gluon) interaction
c cross-section (inclusive cut ladder cross section) for minimal
c 4-momentum transfer square QT0 and c.m. energy square s_hard = SI;
c SJB0 - Born cross-section
          CALL psjint0(s,sj,sjb,iq,0)
c GY= Sigma_hard_tot(YJ,QT0) - total hard  (parton IQ - gluon)
c interaction cross-section for minimal 4-momentum transfer square QT0 and
c c.m. energy square s_hard = SI
          gy0=2.d0*sh*psgint((sj-sjb)/sh*.5d0)+sjb
          gb0=gb0*gy0/s**delh/rs0*z
c-------------------------------------------------
c End of rejection function normalization
c-------------------------------------------------

c-------------------------------------------------
c The sharing of the light cone momenta between soft preevolution and
c hard interaction:
c ( first energy-momentum is shared according to
c f_hard(YJ)~ZPM**(DELH-DEL-1) and then rejected as
c W_rej ~Sigma_hard_tot(YJ) / exp(DELH*YJ)
c ZPM = s_hard / S
c YJ = ln s_hard - rapidity range for the hard parton-parton interaction;
c-------------------------------------------------
1         zpm=(xmin1+qsran(b10)*(1.d0-xmin1))**(1.d0/(delh-del))
c SJ is the DLA inclusive hard partonic (gluon-gluon) interaction
c cross-section (inclusive cut ladder cross section) for minimal
c 4-momentum transfer square QT0 and c.m. energy square s_hard = exp YJ;
c SJB - Born cross-section
          CALL psjint0(zpm*s,sj,sjb,iq,0)
          yj=dlog(zpm*s)
c RH - interaction radius due to soft preevolution
          rh=rs0-alf*dlog(zpm)

          IF(iqq.EQ.0)THEN
c XP, XM - light cone momunta shares for the hard interaction
            xp=zpm**qsran(b10)
            xm=zpm/xp
c Ysoft = - ln ZPM - part of rejection function,
c (1-XP)**bet*(1-XM)**bet is due to gluon structure function in the soft pomeron
            gbyj=-dlog(zpm)*((1.-xp)*(1.-xm))**bet
c WPI,WMI - light cone momenta for the hard interaction
            wpi=wp0*xp
            wmi=wm0*xm
          ELSE
            IF(iqq.EQ.1)THEN
              wpi=wp0
              wmi=wm0*zpm
            ELSE
              wpi=wp0*zpm
              wmi=wm0
            ENDIF
            gbyj=(1.d0-zpm)**bet
          ENDIF

c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic
c interaction cross-section for minimal 4-momentum transfer square QT0 and
c c.m. energy square s_hard = exp YJ
          gy=2.d0*sh*psgint((sj-sjb)/sh*.5d0)+sjb

c-------------------------------------------------
c GBYJ - rejection function for the YJ (ZPM) simulation:
c GBYJ ~  Sigma_hard_tot(YJ,QT0) / exp(DELH*YJ) * exp(-b**2/RH) / RH,
          gbyj=gbyj*gy*exp(-delh*yj)/gb0*z**(rs/rh)/rh
          IF(qsran(b10).GT.gbyj)GOTO 1
        ENDIF
c-------------------------------------------------
        s=wpi*wmi

        IF(debug.GE.2)WRITE (moniou,203)s
203     FORMAT(2x,'PSHOT: MASS SQUARED FOR THE HARD PARTON-PARTON',
     *  ' INTERACTION:',e10.3)

c In case of valence quark hard interaction the type of quark is determined by the
c procedure PSVDEF - flavor combinatorics (not good here); IQC(1) - flavor
c for the upper quark (0 in case of gluon),
c IQC(2) - the same for the lower one
        DO 302 i=1,8
        DO 302 m=1,2
302     epc(i,m)=0.d0

        IF((iqq-1)*(iqq-3).EQ.0)THEN
          CALL psvdef(izp,ic1,icz)
          iqc(1)=ic1
          ipc(1,1)=0
          ipc(2,1)=0
        ELSE
          iqc(1)=0
          ipc(1,1)=-int(2.d0*qsran(b10)+1.d0)
          ipc(2,1)=-ipc(1,1)
          wp1=wp0-wpi
          wp2=wp1*qsran(b10)
          wp1=wp1-wp2
          epc(1,1)=.5d0*wp1
          epc(2,1)=epc(1,1)
          epc(5,1)=.5d0*wp2
          epc(6,1)=epc(5,1)
        ENDIF
        
        IF((iqq-2)*(iqq-3).EQ.0)THEN
          CALL psvdef(izt,ic1,2)
          iqc(2)=ic1
          ipc(1,2)=0
          ipc(2,2)=0
        ELSE
          iqc(2)=0
          ipc(1,2)=-int(2.d0*qsran(b10)+1.d0)
          ipc(2,2)=-ipc(1,2)
          wm1=wm0-wmi
          wm2=wm1*qsran(b10)
          wm1=wm1-wm2
          epc(1,2)=.5d0*wm1
          epc(2,2)=-epc(1,2)
          epc(5,2)=.5d0*wm2
          epc(6,2)=-epc(5,2)
        ENDIF

        ept(1)=.5d0*(wpi+wmi)
        ept(2)=.5d0*(wpi-wmi)
        ept(3)=0.d0
        ept(4)=0.d0
c Minimal 4-momentum transfer squares above and below current ladder run
        qmin(1)=qt0
        qmin(2)=qt0
        DO 303 l=1,2
        DO 303 m=1,2
        ipq(l,m)=ipc(l,m)
        DO 303 i=1,4
303     epq(i+4*(l-1),m)=epc(i+4*(l-1),m)
c Minimal 4-momentum transfer square for gluon-gluon (virtual) interaction
          qminn=max(qmin(1),qmin(2))
          si=psnorm(ept)
      
5         CONTINUE
c 4-momentum squared (c.m. energy square for gluon-gluon (virtual)
c interaction)
        IF(debug.GE.2)WRITE (moniou,208)ilad, si,iqc,ept
208     FORMAT(2x,'PSHOT: ',i2,'-TH HARD LADDER;',
     *  ' MASS SQUARED FOR THE LADDDER:',e10.3/
     *  4x,'LADDER END FLAVORS:',2i3/4x,
     *  'LADDER 4-MOMENTUM: ',4e10.3)

        ebal(1)=.5*(wp0+wm0)-ept(1)
        ebal(2)=.5*(wp0-wm0)-ept(2)
        ebal(3)=0.d0-ept(3)
        ebal(4)=0.d0-ept(4)
        do 503 l=1,4
        do 501 m=1,2
        ebal(l)=ebal(l)-epq(l,m)
501     if(iqc(m).eq.0)   ebal(l)=ebal(l)-epq(l+4,m)
        if(njtot.ne.0)then
           do 502 i=1,njtot
           do 502 m=1,2
502        ebal(l)=ebal(l)-epjet(l,m,i)
        endif
503        continue
c            write (*,*)'ebal',ebal,si,njtot
            
          pt2=ept(3)**2+ept(4)**2
          pt=dsqrt(pt2)
          ww=si+pt2
          sww=dsqrt(ww)
          
          iqp(1)=min(1,iabs(iqc(1)))
          iqp(2)=min(1,iabs(iqc(2)))

c Longitudinal momenta for the interaction
          wp(1)=ept(1)+ept(2)
          wp(2)=ept(1)-ept(2)

          s2min=max(qminn,4.d0*(qt0+amj0))
c WWMIN is the minimal energy square needed for triple s-channel gluons
c production with transverse momentum squares q_t**2 above QMIN(JJ),QMINN
          wwmin=(s2min+(pt-dsqrt(qt0))**2+(qt0+amj0)*(dsqrt(s2min/qt0)-
     *    1.d0))/(1.d0-dsqrt(qt0/s2min))
c SJB/SJ is the probability for the last pair of gluons production
c (SJB is the Born cross-section and SJ is the inclusive interaction
c (cut ladder) cross-section)
          sj=psjint(qmin(1),qmin(2),si,iqp(1)+1,iqp(2)+1)
          sjb=psbint(qminn,si,iqp(1)+1,iqp(2)+1)
          
        IF(debug.GE.2)WRITE (moniou,251)s2min,wwmin,sj,sjb
251     FORMAT(2x,'PSHOT: KINEMATICAL BOUNDS S2MIN=',e10.3,
     *   2x,'WWMIN=',e10.3/4x,'JET CROSS SETION SJ=',e10.3,
     *   2x,'BORN CROSS SECTION SJB=',e10.3)
     
          IF(qsran(b10).LT.sjb/sj.
     *    or.ww.LT.1.2d0*wwmin)GOTO 12

          IF((sj-sjb)/sj.GT..1d0)THEN
            sj1=psjint1(qmin(1),qmin(2),si,iqp(1)+1,iqp(2)+1)
            sj2=psjint1(qmin(2),qmin(1),si,iqp(2)+1,iqp(1)+1)
            dsj=(sj2-sj1)/(sj-sjb)*.5d0
          ELSE
            dsj=0.d0
          ENDIF
c Current s-channel gluon is simulated either above the run (JJ=1) or
c below it (JJ=2)
          jj=int(1.5d0+dsj+qsran(b10))

          aq=-(si+amj0+2.d0*pt*dsqrt(qt0))/ww
          bq=(qt0+amj0)/ww
          cq=qt0/ww
          pq=-aq**2/3.d0+bq
          qq=aq**3/13.5d0-aq*bq/3.d0+cq
          pq=dsqrt(-pq/3.d0)
          cosq=-.5d0*qq/pq**3
          fq=atan(1.d0/cosq**2-1.d0)
          IF(cosq.LT.0.d0)fq=pi-fq
          fq=fq/3.d0

c XMIN is the minimal longitudinal momentum transfer share in current
c ladder run (corresponding to minimal 4-momentum transfer square QMIN(JJ))
          xmin=1.d0+aq/3.d0-2.d0*pq*cos(fq)
          xmax=1.d0+aq/3.d0-pq*(dsqrt(3.d0)*sin(fq)-cos(fq))
c QQMAX is the maximal 4-momentum transfer square in the current run
c (corresponding to X=XMIN and 4-momentum transfer at next simulation
c step to be equal QMAX)
          qqmax=qt0/(1.d0-xmax)**2
          qqmin=qt0/(1.d0-xmin)**2

          IF(qqmin.LT.s2min)THEN
            xmm=(si-s2min+amj0+2.d0*pt*dsqrt(qt0))/ww*.5d0
            xmin=1.d0-xmm-dsqrt(xmm*xmm-(qt0+amj0)/ww)
            qqmin=qt0/(1.d0-xmin)**2

            IF(qqmin.LT.qmin(jj))THEN
              qqmin=qmin(jj)
              xmm1=ww-2.d0*pt*dsqrt(qqmin)+qqmin
              xmm=(si-s2min+amj0)/xmm1*.5d0
              xmin=1.d0-xmm-dsqrt(xmm*xmm-amj0/xmm1)
            ENDIF
          ENDIF

*********************************************************
          xm0=max(.5d0,1.d0-dsqrt(qt0/qmin(jj)))
          IF(xm0.GT..95d0*xmax.OR.xm0.LT.1.05d0*xmin)
     *    xm0=.5d0*(xmax+xmin)
          qm0=qt0/(1.d0-xm0)**2
          s2max=xm0*ww

          sj0=psjint(qm0,qmin(3-jj),s2max,1,iqp(3-jj)+1)*
     *    psfap(xm0,iqp(jj),0)+
     *    psjint(qm0,qmin(3-jj),s2max,2,iqp(3-jj)+1)
     *    *psfap(xm0,iqp(jj),1)

          gb0=sj0*qm0/qlog*psuds(qm0,iqp(jj))*1.5d0
          IF(xm0.LE..5d0)THEN
            gb0=gb0*xm0**(1.d0-delh)
          ELSE
            gb0=gb0*(1.d0-xm0)*2.d0**delh
          ENDIF
c XMIN, XMAX are put into power DELH to simulate X value below
          xmin2=max(.5d0,xmin)
          xmin1=xmin**delh
          xmax1=min(xmax,.5d0)**delh
          IF(xmin.GE..5d0)THEN
            djl=1.d0 
          ELSEIF(xmax.LT..5d0)THEN
            djl=0.d0 
          ELSE
            djl=1.d0/(1.d0+((2.d0*xmin)**delh-1.d0)/delh/
     *      dlog(2.d0*(1.d0-xmax)))
          ENDIF

7         CONTINUE
c Simulation of the longitudinal momentum transfer share in current
c ladder run - from XMIN to XMAX according to dX * X**(DELH-1)
          IF(qsran(b10).GT.djl)THEN
            x=(xmin1+qsran(b10)*(xmax1-xmin1))**(1.d0/delh)
          ELSE
            x=1.d0-(1.d0-xmin2)*((1.d0-xmax)/(1.d0-xmin2))**qsran(b10)
          ENDIF
*********************************************************

c Effective momentum squared QQ in the ladder run is simulated
c first as dq**2/q**4 from QMIN(J) to QMAX
          qq=qqmin/(1.d0+qsran(b10)*(qqmin/qqmax-1.d0))
      
        IF(debug.GE.2)WRITE (moniou,253)qq,qqmin,qqmax
253     FORMAT(2x,'PSHOT: QQ=',e10.3,2x,'QQMIN=',e10.3,2x,
     *  'QQMAX=',e10.3)

          qt2=qq*(1.d0-x)**2
          IF(qt2.LT.qt0)GOTO 7

          IF(qq.GT.qminn)THEN
            qmin2=qq
          ELSE
            qmin2=qminn
          ENDIF

          qt=dsqrt(qt2)
          CALL pscs(ccos,ssin)
c EP3 is now 4-vector for s-channel gluon produced in current ladder run
          ep3(3)=qt*ccos
          ep3(4)=qt*ssin
          pt2=(ept(3)-ep3(3))**2+(ept(4)-ep3(4))**2
          s2min2=max(s2min,qmin2)

          zmin=(qt2+amj0)/ww/(1.d0-x)
c S2 is the maximal c.m. energy square for the parton-parton interaction
c in the next ladder run
          s2=x*(1.d0-zmin)*ww-pt2
c Rejection in case of too low WW2 (insufficient for elastic gluon-gluon
c scattering with transverse momentum square q_t**2 above QMIN2)
          IF(s2.LT.s2min2)GOTO 7

          sj1=psjint(qq,qmin(3-jj),s2,1,iqp(3-jj)+1)
     *    *psfap(x,iqp(jj),0)
          sj2=psjint(qq,qmin(3-jj),s2,2,iqp(3-jj)+1)
     *    *psfap(x,iqp(jj),1)

c GB7 is the rejection function for X and Q**2 simulation. It consists
c from factor
c Q**2/Qmin**2 * ln(Qmin**2/Lambda_qcd**2)/ln(Q**2/Lambda_qcd**2)
c from Q**2 simulation and factor SJ/(X*WW)**DELH * const from X simulation
          gb7=(sj1+sj2)/dlog(qt2/alm)*qq*psuds(qq,iqp(jj))/gb0

*********************************************************
          IF(x.LE..5d0)THEN
            gb7=gb7*x**(1.d0-delh)
          ELSE
            gb7=gb7*(1.d0-x)*2.d0**delh
          ENDIF
*********************************************************
          IF(qsran(b10).GT.gb7)GOTO 7

           IF(qsran(b10).LT.sj1/(sj1+sj2))THEN
             IF(iqc(jj).EQ.0)THEN
               jt=1
               jq=int(1.5d0+qsran(b10))
               iqj(1)=ipq(jq,jj)
               iqj(2)=0
               DO 31 i=1,4
               eqj(i,1)=epq(i+4*(jq-1),jj)
31            eqj(i,2)=0.d0
            ELSE
              jt=2
              IF(iqc(jj).GT.0)THEN
                jq=1
              ELSE
                jq=2
              ENDIF
              iqj(1)=0
              DO 32 i=1,4
32            eqj(i,1)=0.d0

              ipq(jq,jj)=ipq(1,jj)
              DO 135 i=1,4
135           epq(i+4*(jq-1),jj)=epq(i,jj)
            ENDIF
            iq1=iqc(jj)
            iqc(jj)=0
            
          ELSE
            IF(iqp(jj).NE.0)THEN
              iq1=0
              jt=3
              IF(iqc(jj).GT.0)THEN
                jq=1
              ELSE
                jq=2
              ENDIF
              iqj(1)=ipq(1,jj)
              iqj(2)=0
              DO 33 i=1,4
              eqj(i,1)=epq(i,jj)
33            eqj(i,2)=0.d0

            ELSE
              iq1=int(3.d0*qsran(b10)+1.d0)*(2*int(.5d0+qsran(b10))-1)
              iqc(jj)=-iq1
              jt=4
              IF(iq1.GT.0)THEN
                jq=1
              ELSE
                jq=2
              ENDIF
              iqj(1)=ipq(jq,jj)
              DO 34 i=1,4
34            eqj(i,1)=epq(i+4*(jq-1),jj)
            ENDIF
          ENDIF
          IF(debug.GE.3)WRITE (moniou,240)jt

          CALL pscajet(qt2,iq1,qv1,zv1,qm1,iqv1,
     *    ldau1,lpar1,jq)
          z=(qt2+qm1(1,1))/ww/(1.d0-x)
          si=x*(1.d0-z)*ww-pt2

          IF(si.GT.s2min2)THEN
            iq=min(1,iabs(iqc(jj)))+1
            gb=psjint(qq,qmin(3-jj),si,iq,iqp(3-jj)+1)/
     *      psjint(qq,qmin(3-jj),s2,iq,iqp(3-jj)+1)
            IF(qsran(b10).GT.gb)GOTO 301
          ELSE
            GOTO 301
          ENDIF

          wp3=wp(jj)*(1.d0-x)
          wm3=(qt2+qm1(1,1))/wp3
          ep3(1)=.5d0*(wp3+wm3)
          ep3(2)=.5d0*(wp3-wm3)*(3-2*jj)

          pt3=dsqrt(ep3(3)**2+ep3(4)**2)

          CALL psrec(ep3,qv1,zv1,qm1,iqv1,ldau1,lpar1,iqj,eqj,jfl,jq)
          IF(jfl.EQ.0)GOTO 301
      
          IF(jt.EQ.1)THEN
            ipq(jq,jj)=iqj(2)
            DO 35 i=1,4
35          epq(i+4*(jq-1),jj)=eqj(i,2)

            IF(ipc(jq,jj).EQ.0)THEN   
              ipc(jq,jj)=iqj(1)
              DO 36 i=1,4
36            epc(i+4*(jq-1),jj)=eqj(i,1)
            ENDIF

          ELSEIF(jt.EQ.2)THEN
            ipq(3-jq,jj)=iqj(1)
            DO 37 i=1,4
37          epq(i+4*(2-jq),jj)=eqj(i,1)

          ELSEIF(jt.EQ.3)THEN
            ipq(1,jj)=iqj(2)
            DO 38 i=1,4
38          epq(i,jj)=eqj(i,2)

            IF(ipc(jq,jj).EQ.0)THEN   
              ipc(jq,jj)=iqj(1)
              DO 39 i=1,4
39            epc(i+4*(jq-1),jj)=eqj(i,1)
            ENDIF
        
          ELSEIF(jt.EQ.4)THEN
            IF(ipc(jq,jj).EQ.0)THEN   
               ipc(jq,jj)=iqj(1)
               DO 40 i=1,4
40            epc(i+4*(jq-1),jj)=eqj(i,1)
            ENDIF
            IF(jq.EQ.1)THEN   
              ipq(1,jj)=ipq(2,jj)
              DO 30 i=1,4
30            epq(i,jj)=epq(i+4,jj)
            ENDIF
          ENDIF
      
          IF(iabs(iq1).EQ.3)THEN
            iqqq=8+iq1/3*4
          ELSE
            iqqq=8+iq1
          ENDIF
        IF(debug.GE.2)WRITE (moniou,209)tyq(iqqq),qt2,ep3
209     FORMAT(2x,'PSHOT: NEW JET FLAVOR:',a2,
     *  ' PT SQUARED FOR THE JET:',e10.3/
     *  4x,'JET 4-MOMENTUM:',4e10.3)
          DO 8 i=1,4
8         ept(i)=ept(i)-ep3(i)
c C.m. energy square, minimal  4-momentum transfer square and gluon 4-vector
c for the next ladder run
          qmin(jj)=qq
          qminn=qmin2
      
c Next simulation step will be considered for current ladder
          GOTO 5
C------------------------------------------------

C------------------------------------------------
c The last gluon pair production (elastic scattering) in the ladder
c is simulated
12        CONTINUE
          IF(debug.GE.2)WRITE (moniou,211)si
211     FORMAT(2x,'PSHOT: HIGHEST VIRTUALITY SUBPROCESS IN THE LADDER'/
     *  4x,'MASS SQUARED FOR THE PROCESS:',e10.3)

          xmin=qminn/(qminn+si)
          xmin1=.5d0-dsqrt(.25d0-(qt0+amj0)/si)
          xmin=max(xmin,xmin1)
          tmin=si*xmin

          IF(iqc(1).NE.0.OR.iqc(2).NE.0)THEN
            gb0=tmin**2/dlog(tmin*(1.d0-xmin)/alm)**2*
     *      psfborn(si,tmin,iqc(1),iqc(2))
          ELSE
            gb0=.25d0*si**2/dlog(tmin*(1.d0-xmin)/alm)**2*
     *      psfborn(si,.5d0*si,iqc(1),iqc(2))
          ENDIF

C------------------------------------------------
c 4-momentum transfer squared is simulated first as dq_t**2/q_t**4 from
c tmin to s/2
13        q2=tmin/(1.d0-qsran(b10)*(1.d0-2.d0*tmin/si))
          z=q2/si
          qt2=q2*(1.d0-z)
          IF(qsran(b10).LT..5d0)THEN
            jm=2
            tq=si-q2
          ELSE
            jm=1
            tq=q2
          ENDIF

          gb=q2**2/dlog(qt2/alm)**2/gb0*
     *    psfborn(si,tq,iqc(1),iqc(2))
          IF(debug.GE.3)WRITE (moniou,241)q2,gb
241     FORMAT(2x,'PSHOT: Q2=',e10.3,' GB=',e10.3)

          IF(qsran(b10).GT.gb)GOTO 13

          IF(iqc(1).EQ.0.AND.iqc(2).EQ.0)THEN
            jq=int(1.5d0+qsran(b10))
            iqj(1)=ipq(jq,jm)
            DO 51 i=1,4
51          eqj(i,1)=epq(i+4*(jq-1),jm)

            IF(qsran(b10).LT..5d0)THEN
              jt=1
              IF(ipq(3-jq,jm)*ipq(jq,3-jm).NE.0)THEN
                ipj=ipq(3-jq,jm)
                ipj1=ipq(jq,3-jm)
                IF(iabs(ipj).EQ.3)ipj=ipj*4/3
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                DO 52 i=1,4
                epj(i)=epq(i+4*(2-jq),jm)
52              epj1(i)=epq(i+4*(jq-1),3-jm)
                CALL psjdef(ipj,ipj1,epj,epj1,jfl)
                IF(jfl.EQ.0)GOTO 301
              ELSEIF(ipq(3-jq,jm).NE.0)THEN
                ipc(jq,3-jm)=ipq(3-jq,jm)
                DO 53 i=1,4
53              epc(i+4*(jq-1),3-jm)=epq(i+4*(2-jq),jm)
              ELSEIF(ipq(jq,3-jm).NE.0)THEN
                ipc(3-jq,jm)=ipq(jq,3-jm)
                DO 54 i=1,4
54              epc(i+4*(2-jq),jm)=epq(i+4*(jq-1),3-jm)
              ENDIF
          
              iqj(2)=0
              DO 55 i=1,4
55            eqj(i,2)=0.d0
        
            ELSE
              jt=2
              iqj(2)=ipq(3-jq,3-jm)
              DO 56 i=1,4
56            eqj(i,2)=epq(i+4*(2-jq),3-jm)
            ENDIF
              
          ELSEIF(iqc(1)*iqc(2).EQ.0)THEN
            IF(iqc(1)+iqc(2).GT.0)THEN
              jq=1
            ELSE
              jq=2
            ENDIF

            IF(qsran(b10).LT..5d0)THEN
              IF(iqc(jm).EQ.0)THEN
                jt=3
                iqj(1)=ipq(jq,jm)
                iqj(2)=0
                DO 57 i=1,4
                eqj(i,1)=epq(i+4*(jq-1),jm)
57              eqj(i,2)=0.d0

                IF(ipq(3-jq,jm)*ipq(1,3-jm).NE.0)THEN
                  ipj=ipq(3-jq,jm)
                  ipj1=ipq(1,3-jm)
                  IF(iabs(ipj).EQ.3)ipj=ipj*4/3
                  IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                  DO 58 i=1,4
                  epj(i)=epq(i+4*(2-jq),jm)
58                epj1(i)=epq(i,3-jm)
                  CALL psjdef(ipj,ipj1,epj,epj1,jfl)
                  IF(jfl.EQ.0)GOTO 301
                ELSEIF(ipq(3-jq,jm).NE.0)THEN
                  ipc(jq,3-jm)=ipq(3-jq,jm)
                  DO 59 i=1,4
59                epc(i+4*(jq-1),3-jm)=epq(i+4*(2-jq),jm)
                ELSEIF(ipq(1,3-jm).NE.0)THEN
                  ipc(3-jq,jm)=ipq(1,3-jm)
                  DO 60 i=1,4
60                epc(i+4*(2-jq),jm)=epq(i,3-jm)
                ENDIF
          
              ELSE
                jt=4
                iqj(1)=0
                DO 61 i=1,4
61              eqj(i,1)=0.d0

                IF(ipq(1,jm)*ipq(3-jq,3-jm).NE.0)THEN
                  ipj=ipq(1,jm)
                  ipj1=ipq(3-jq,3-jm)
                  IF(iabs(ipj).EQ.3)ipj=ipj*4/3
                  IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                  DO 62 i=1,4
                  epj(i)=epq(i,jm)
62                epj1(i)=epq(i+4*(2-jq),3-jm)
                  CALL psjdef(ipj,ipj1,epj,epj1,jfl)
                  IF(jfl.EQ.0)GOTO 301
                ELSEIF(ipq(3-jq,3-jm).NE.0)THEN
                  ipc(jq,jm)=ipq(3-jq,3-jm)
                  DO 63 i=1,4
63                epc(i+4*(jq-1),jm)=epq(i+4*(2-jq),3-jm)
                ELSEIF(ipq(1,jm).NE.0)THEN
                  ipc(3-jq,3-jm)=ipq(1,jm)
                  DO 64 i=1,4
64                epc(i+4*(2-jq),3-jm)=epq(i,jm)
                ENDIF
              ENDIF
            
            ELSE
              IF(iqc(jm).EQ.0)THEN
                jt=5
                iqj(2)=ipq(3-jq,jm)
                iqj(1)=ipq(1,3-jm)
                DO 65 i=1,4
                eqj(i,2)=epq(i+4*(2-jq),jm)
65              eqj(i,1)=epq(i,3-jm)
              ELSE
                jt=6
                iqj(1)=ipq(jq,3-jm)
                DO 66 i=1,4
66              eqj(i,1)=epq(i+4*(jq-1),3-jm)
              ENDIF
            ENDIF

          ELSEIF(iqc(1)*iqc(2).GT.0)THEN
            jt=7
            IF(iqc(1).GT.0)THEN
              jq=1
            ELSE
              jq=2
            ENDIF
            iqj(1)=ipq(1,3-jm)
            DO 67 i=1,4
67          eqj(i,1)=epq(i,3-jm)

          ELSE
            jt=8
            IF(iqc(jm).GT.0)THEN
              jq=1
            ELSE
              jq=2
            ENDIF
            iqj(1)=0
            DO 68 i=1,4
68          eqj(i,1)=0.d0

            IF(ipq(1,jm)*ipq(1,3-jm).NE.0)THEN
              ipj=ipq(1,jm)
              ipj1=ipq(1,3-jm)
              IF(iabs(ipj).EQ.3)ipj=ipj*4/3
              IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
              DO 69 i=1,4
              epj(i)=epq(i,jm)
69            epj1(i)=epq(i,3-jm)
              CALL psjdef(ipj,ipj1,epj,epj1,jfl)
              IF(jfl.EQ.0)GOTO 301
            ELSEIF(ipq(1,3-jm).NE.0)THEN
              ipc(jq,jm)=ipq(1,3-jm)
              DO 70 i=1,4
70            epc(i+4*(jq-1),jm)=epq(i,3-jm)
            ELSEIF(ipq(1,jm).NE.0)THEN
              ipc(3-jq,3-jm)=ipq(1,jm)
              DO 71 i=1,4
71            epc(i+4*(2-jq),3-jm)=epq(i,jm)
            ENDIF
          ENDIF
          IF(jt.NE.8)THEN
            jq2=jq
          ELSE
            jq2=3-jq
          ENDIF
          IF(debug.GE.3)WRITE (moniou,240)jt
240       FORMAT(2x,'PSHOT: COLOUR CONNECTION JT=:',i1)
                      
          CALL pscajet(qt2,iqc(jm),qv1,zv1,qm1,iqv1,
     *    ldau1,lpar1,jq)
          CALL pscajet(qt2,iqc(3-jm),qv2,zv2,qm2,iqv2,
     *    ldau2,lpar2,jq2)

          amt1=qt2+qm1(1,1)
          amt2=qt2+qm2(1,1)

          IF(dsqrt(si).GT.dsqrt(amt1)+dsqrt(amt2))THEN
            z=xxtwdec(si,amt1,amt2)
          ELSE
            GOTO 301
          ENDIF

          CALL psdeftr(si,ept,ey)

          wp3=z*dsqrt(si)
          wm3=(qt2+qm1(1,1))/wp3
          ep3(1)=.5d0*(wp3+wm3)
          ep3(2)=.5d0*(wp3-wm3)
          qt=dsqrt(qt2)
          CALL pscs(ccos,ssin)
c ep3 is now 4-vector for first s-channel gluon produced in the ladder run
          ep3(3)=qt*ccos
          ep3(4)=qt*ssin

          CALL pstrans(ep3,ey)
          pt3=dsqrt(ep3(3)**2+ep3(4)**2)

          CALL psrec(ep3,qv1,zv1,qm1,iqv1,ldau1,lpar1,iqj,eqj,jfl,jq)
          IF(jfl.EQ.0)GOTO 301
          
          if(iabs(iqc(jm)).eq.3)then
            iqqq=8+iqc(jm)/3*4
          else
            iqqq=8+iqc(jm)
          endif
          IF(debug.GE.2)WRITE (moniou,209)tyq(iqqq),qt2

          wp3=(1.d0-z)*dsqrt(si)
          wm3=(qt2+qm2(1,1))/wp3
          ep3(1)=.5d0*(wp3+wm3)
          ep3(2)=.5d0*(wp3-wm3)
          ep3(3)=-qt*ccos
          ep3(4)=-qt*ssin
          CALL pstrans(ep3,ey)
          pt3=dsqrt(ep3(3)**2+ep3(4)**2)

          IF(jt.EQ.1)THEN
            IF(ipc(jq,jm).EQ.0)THEN
              ipc(jq,jm)=iqj(1)
              DO 72 i=1,4
72            epc(i+4*(jq-1),jm)=eqj(i,1)
            ENDIF
            
            iqj(1)=iqj(2)
            iqj(2)=ipq(3-jq,3-jm)
            DO 73 i=1,4
            eqj(i,1)=eqj(i,2)
73          eqj(i,2)=epq(i+4*(2-jq),3-jm)

          ELSEIF(jt.EQ.2)THEN
            IF(ipc(jq,jm).EQ.0)THEN
              ipc(jq,jm)=iqj(1)
              DO 74 i=1,4
74            epc(i+4*(jq-1),jm)=eqj(i,1)
            ENDIF
            IF(ipc(3-jq,3-jm).EQ.0)THEN
              ipc(3-jq,3-jm)=iqj(2)
              DO 75 i=1,4
75            epc(i+4*(2-jq),3-jm)=eqj(i,2)
            ENDIF
            
            iqj(2)=ipq(3-jq,jm)
            iqj(1)=ipq(jq,3-jm)
            DO 76 i=1,4
            eqj(i,2)=epq(i+4*(2-jq),jm)
76          eqj(i,1)=epq(i+4*(jq-1),3-jm)

          ELSEIF(jt.EQ.3)THEN
            IF(ipc(jq,jm).EQ.0)THEN
              ipc(jq,jm)=iqj(1)
              DO 77 i=1,4
77            epc(i+4*(jq-1),jm)=eqj(i,1)
            ENDIF
            iqj(1)=iqj(2)
            DO 78 i=1,4
78          eqj(i,1)= eqj(i,2)

          ELSEIF(jt.EQ.4)THEN
            iqj(2)=iqj(1)
            iqj(1)=ipq(jq,3-jm)
            DO 79 i=1,4
            eqj(i,2)=eqj(i,1)
79          eqj(i,1)=epq(i+4*(jq-1),3-jm)

          ELSEIF(jt.EQ.5)THEN
            IF(ipc(3-jq,jm).EQ.0)THEN
              ipc(3-jq,jm)=iqj(2)
              DO 80 i=1,4
80            epc(i+4*(2-jq),jm)=eqj(i,2)
            ENDIF
            IF(ipc(jq,3-jm).EQ.0)THEN
              ipc(jq,3-jm)=iqj(1)
              DO 81 i=1,4
81            epc(i+4*(jq-1),3-jm)=eqj(i,1)
            ENDIF
            
            iqj(1)=ipq(jq,jm)
            DO 82 i=1,4
82          eqj(i,1)=epq(i+4*(jq-1),jm)

          ELSEIF(jt.EQ.6)THEN
            IF(ipc(jq,3-jm).EQ.0)THEN
              ipc(jq,3-jm)=iqj(1)
              DO 83 i=1,4
83            epc(i+4*(jq-1),3-jm)=eqj(i,1)
            ENDIF
            
            iqj(2)=ipq(3-jq,3-jm)
            iqj(1)=ipq(1,jm)
            DO 84 i=1,4
            eqj(i,2)=epq(i+4*(2-jq),3-jm)
84          eqj(i,1)=epq(i,jm)

          ELSEIF(jt.EQ.7)THEN
            IF(ipc(jq,3-jm).EQ.0)THEN
              ipc(jq,3-jm)=iqj(1)
              DO 85 i=1,4
85            epc(i+4*(jq-1),3-jm)=eqj(i,1)
            ENDIF
            iqj(1)=ipq(1,jm)
            DO 86 i=1,4
86          eqj(i,1)= epq(i,jm)
          ENDIF

          CALL psrec(ep3,qv2,zv2,qm2,iqv2,ldau2,lpar2,iqj,eqj,jfl,jq2)
          IF(jfl.EQ.0)GOTO 301

          if(iabs(iqc(3-jm)).eq.3)then
            iqqq=8+iqc(3-jm)/3*4
          else
            iqqq=8+iqc(3-jm)
          endif
          IF(debug.GE.2)WRITE (moniou,209)tyq(iqqq),qt2
          IF(debug.GE.2)WRITE (moniou,212)njtot
212       FORMAT(2x,'PSHOT: TOTAL NUMBER OF JETS:',i2)

          IF(jt.EQ.1)THEN
            IF(ipc(3-jq,3-jm).EQ.0)THEN
              ipc(3-jq,3-jm)=iqj(2)
              DO 87 i=1,4
87            epc(i+4*(2-jq),3-jm)=eqj(i,2)
            ENDIF
            
          ELSEIF(jt.EQ.2)THEN
            IF(ipc(3-jq,jm).EQ.0)THEN
              ipc(3-jq,jm)=iqj(2)
              DO 88 i=1,4
88            epc(i+4*(2-jq),jm)=eqj(i,2)
            ENDIF
            IF(ipc(jq,3-jm).EQ.0)THEN
              ipc(jq,3-jm)=iqj(1)
              DO 89 i=1,4
89            epc(i+4*(jq-1),3-jm)=eqj(i,1)
            ENDIF

          ELSEIF(jt.EQ.4)THEN
            IF(ipc(jq,3-jm).EQ.0)THEN
              ipc(jq,3-jm)=iqj(1)
              DO 90 i=1,4
90            epc(i+4*(jq-1),3-jm)=eqj(i,1)
            ENDIF

          ELSEIF(jt.EQ.5)THEN
            IF(ipc(jq,jm).EQ.0)THEN
              ipc(jq,jm)=iqj(1)
              DO 91 i=1,4
91            epc(i+4*(jq-1),jm)=eqj(i,1)
            ENDIF

          ELSEIF(jt.EQ.6)THEN
            IF(ipc(3-jq,3-jm).EQ.0)THEN
              ipc(3-jq,3-jm)=iqj(2)
              DO 92 i=1,4
92            epc(i+4*(2-jq),3-jm)=eqj(i,2)
            ENDIF
            IF(ipc(jq,jm).EQ.0)THEN
              ipc(jq,jm)=iqj(1)
              DO 93 i=1,4
93            epc(i+4*(jq-1),jm)=eqj(i,1)
            ENDIF

          ELSEIF(jt.EQ.7)THEN
            IF(ipc(jq,jm).EQ.0)THEN
              ipc(jq,jm)=iqj(1)
              DO 94 i=1,4
94            epc(i+4*(jq-1),jm)=eqj(i,1)
            ENDIF
          ENDIF
C------------------------------------------------

        IF(debug.GE.3)WRITE (moniou,217)
217     FORMAT(2x,'PSHOT - END')
        ebal(1)=.5*(wp0+wm0)
        ebal(2)=.5*(wp0-wm0)
        ebal(3)=0.d0
        ebal(4)=0.d0
        do 500 i=1,njtot
        do 500 m=1,2
        do 500 l=1,4
500        ebal(l)=ebal(l)-epjet(l,m,i)
c            write (*,*)'ebal',ebal
        RETURN
        END
C=======================================================================

        SUBROUTINE psjdef(IPJ,IPJ1,EPJ,EPJ1,JFL)
c Procedure for jet hadronization - each gluon is
c considered to be splitted into quark-antiquark pair and usual soft
c strings are assumed to be formed between quark and antiquark
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension epj(4),epj1(4),ept(4)
        COMMON /area10/ stmass,am(7)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        COMMON /area46/ epjet(4,2,15000),ipjet(2,15000)
        COMMON /area47/ njtot
        SAVE

c        if(ipj*ipj1.gt.0.and.iabs(ipj).ne.3.and.iabs(ipj).le.4.
c     *  and.iabs(ipj1).ne.3.and.iabs(ipj1).le.4.or.
c     *  ipj*ipj1.lt.0.and.(iabs(ipj).eq.3.or.iabs(ipj).gt.4.
c     *  or.iabs(ipj1).eq.3.or.iabs(ipj1).eq.4))then
c      write (*,*)'ipj,ipj1',ipj,ipj1
c           read (*,*)
c        endif

        IF(debug.GE.2)WRITE (moniou,201)ipj,ipj1,epj,epj1
201     FORMAT(2x,'PSJDEF: PARTON FLAVORS',
     *  ': IPJ=',i2,2x,'IPJ1=',i2/
     *  4x,'PARTON 4-MOMENTA:',2x,4(e10.3,1x))
        DO 1 i=1,4
1       ept(i)=epj(i)+epj1(i)

c Invariant mass squared for the jet
        ww=psnorm(ept)
c Minimal mass squared for the jet
        IF(iabs(ipj).LE.2)THEN
          am1=am(1)
        ELSEIF(iabs(ipj).EQ.4)THEN
          am1=am(3)
        ELSE
          am1=am(2)
        ENDIF
        IF(iabs(ipj1).LE.2)THEN
          am2=am(1)
        ELSEIF(iabs(ipj1).EQ.4)THEN
          am2=am(3)
        ELSE
          am2=am(2)
        ENDIF
        amj=(am1+am2)**2
        
        IF(amj.GT.ww)THEN
          jfl=0
          RETURN
        ELSE
          jfl=1
        ENDIF
        
        njtot=njtot+1        
        IF( njtot . gt. 15000 ) THEN
          WRITE(moniou,*)'PSJDEF: TOO MANY JETS'
          WRITE(moniou,*)'PSJDEF: NJTOT = ',njtot
          stop
        ENDIF
        ipjet(1,njtot)=ipj
        ipjet(2,njtot)=ipj1
        DO 2 i=1,4
        epjet(i,1,njtot)=epj(i)
2       epjet(i,2,njtot)=epj1(i)
        
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'PSJDEF - END')
        RETURN
        END
C=======================================================================

        FUNCTION psjet(Q1,Q2,S,S2MIN,J,L)
C PSJET - inclusive hard cross-section calculation (one more run is added
c to the ladder) - for any ordering
c Q1 - effective momentum cutoff for current end of the ladder,
c Q2 - effective momentum cutoff for opposide end of the ladder,
c S - total c.m. energy squared for the ladder,
c S2MIN - minimal c.m. energy squared for BORN process (above Q1 and Q2)
c J - parton type at current end of the ladder (0 - g, 1 - q)
c L - parton type at opposite end of the ladder (1 - g, 2 - q)
C-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area6/  pi,bm,am
        COMMON /area17/ del,rs,rs0,fs,alf,rr,sh,delh
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        common/ar3/x1(7),a1(7)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,q1,q2,s2min,j,l
201     FORMAT(2x,'PSJET - UNORDERED LADDER CROSS SECTION:'/
     *  4x,'S=',e10.3,2x,'Q1=',e10.3,2x,'Q2=',e10.3,2x,'S2MIN=',
     *  e10.3,2x,'J=',i1,2x,'L=',i1)
        psjet=0.d0

        p=dsqrt(1.d0-3.d0*qt0/s)
        cosf=(1.d0-18.d0*qt0/s)/p**3
        fi=atan(1.d0/cosf**2-1.d0)
        IF(cosf.LT.0.d0)fi=pi-fi
        fi=fi/3.d0
        zmax=(2.d0-p*(dsqrt(3.d0)*sin(fi)-cos(fi)))/3.d0
        zmin=(1.d0-p*cos(fi))/1.5d0

        IF(qt0/(1.d0-zmin)**2.LT.s2min)
     *  zmin=.5d0*(1.d0+s2min/s-dsqrt((1.d0-s2min/s)**2-4.d0*qt0/s))

***********************************************************
        IF(1.d0-zmin.LT.dsqrt(qt0/q1))THEN
          qmin=qt0/(1.d0-zmin)**2
        ELSE
          qmin=q1
        ENDIF

        qmax=qt0/(1.d0-zmax)**2
        sud0=psuds(qmin,j)
***********************************************************

        IF(debug.GE.3)WRITE (moniou,203)qmin,qmax
203     FORMAT(2x,'PSJET:',2x,'QMIN=',e10.3,2x,'QMAX=',e10.3)
        IF(qmax.GT.qmin)THEN

c Numerical integration over transverse momentum square;
c Gaussian integration is used
          DO 3 i=1,7
          DO 3 m=1,2
          qi=2.d0*qmin/(1.d0+qmin/qmax+(2*m-3)*x1(i)*(1.d0-qmin/qmax))

          zmax=(1.d0-dsqrt(qt0/qi))**delh
          zmin=((qi+max(qi,s2min))/(qi+s))**delh

          fsj=0.d0

        IF(debug.GE.3)WRITE (moniou,204)qi,zmin,zmax
204     FORMAT(2x,'PSJET:',2x,'QI=',e10.3,2x,'ZMIN=',e10.3,2x,
     *  'ZMAX=',e10.3)
          IF(zmax.GT.zmin)THEN
            DO 2 i1=1,7
            DO 2 m1=1,2
            z=(.5d0*(zmax+zmin+(2*m1-3)*x1(i1)*(zmax-zmin)))**
     *      (1.d0/delh)
            qt=qi*(1.d0-z)**2
            s2=z*s-qi*(1.d0-z)

            sj=0.d0
            DO 1 k=1,2
1           sj=sj+psjint(qi,q2,s2,k,l)*psfap(z,j,k-1)*z
2           fsj=fsj+a1(i1)*sj/dlog(qt/alm)/z**delh
            fsj=fsj*(zmax-zmin)
          ENDIF

3         psjet=psjet+a1(i)*fsj*qi*psuds(qi,j)
          psjet=psjet*(1.d0/qmin-1.d0/qmax)/sud0/delh/18.d0
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psjet
202     FORMAT(2x,'PSJET=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psjet1(Q1,Q2,S,S2MIN,J,L)
C PSJET1 - inclusive hard cross-section calculation (one more run is added
c to the ladder) - for strict ordering
c Q1 - effective momentum cutoff for current end of the ladder,
c Q2 - effective momentum cutoff for opposide end of the ladder,
c S - total c.m. energy squared for the ladder,
c S2MIN - minimal c.m. energy squared for BORN process (above Q1 and Q2)
c J - parton type at current end of the ladder (0 - g, 1 - q)
c L - parton type at opposite end of the ladder (1 - g, 2 - q)
C-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area6/  pi,bm,am
        COMMON /area17/ del,rs,rs0,fs,alf,rr,sh,delh
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        common/ar3/x1(7),a1(7)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,q1,q2,s2min,j,l
201     FORMAT(2x,'PSJET1 - STRICTLY ORDERED LADDER CROSS SECTION:'/
     *  4x,'S=',e10.3,2x,'Q1=',e10.3,2x,'Q2=',e10.3,2x,'S2MIN=',
     *  e10.3,2x,'J=',i1,2x,'L=',i1)
        psjet1=0.d0

        p=dsqrt(1.d0-3.d0*qt0/s)
        cosf=(1.d0-18.d0*qt0/s)/p**3
        fi=atan(1.d0/cosf**2-1.d0)
        IF(cosf.LT.0.d0)fi=pi-fi
        fi=fi/3.d0
        zmax=(2.d0-p*(dsqrt(3.d0)*sin(fi)-cos(fi)))/3.d0
        zmin=(1.d0-p*cos(fi))/1.5d0

        IF(qt0/(1.d0-zmin)**2.LT.s2min)
     *  zmin=.5d0*(1.d0+s2min/s-dsqrt((1.d0-s2min/s)**2-4.d0*qt0/s))

***********************************************************
        IF(1.d0-zmin.LT.dsqrt(qt0/q1))THEN
          qmin=qt0/(1.d0-zmin)**2
        ELSE
          qmin=q1
        ENDIF

        qmax=qt0/(1.d0-zmax)**2
        sud0=psuds(qmin,j)
***********************************************************

        IF(debug.GE.3)WRITE (moniou,203)qmin,qmax
203     FORMAT(2x,'PSJET1:',2x,'QMIN=',e10.3,2x,'QMAX=',e10.3)
        IF(qmax.GT.qmin)THEN

c Numerical integration over transverse momentum square;
c Gaussian integration is used
          DO 3 i=1,7
          DO 3 m=1,2
          qi=2.d0*qmin/(1.d0+qmin/qmax+(2*m-3)*x1(i)*(1.d0-qmin/qmax))

          zmax=(1.d0-dsqrt(qt0/qi))**delh
          zmin=((qi+max(qi,s2min))/(qi+s))**delh

          fsj=0.d0

        IF(debug.GE.3)WRITE (moniou,204)qi,zmin,zmax
204     FORMAT(2x,'PSJET1:',2x,'QI=',e10.3,2x,'ZMIN=',e10.3,2x,
     *  'ZMAX=',e10.3)
          IF(zmax.GT.zmin)THEN
            DO 2 i1=1,7
            DO 2 m1=1,2
            z=(.5d0*(zmax+zmin+(2*m1-3)*x1(i1)*(zmax-zmin)))**
     *      (1.d0/delh)
            qt=qi*(1.d0-z)**2
            s2=z*s-qi*(1.d0-z)

            sj=0.d0
            DO 1 k=1,2
1           sj=sj+psjint1(qi,q2,s2,k,l)*psfap(z,j,k-1)*z

2           fsj=fsj+a1(i1)*sj/dlog(qt/alm)/z**delh
            fsj=fsj*(zmax-zmin)
          ENDIF

3         psjet1=psjet1+a1(i)*fsj*qi*psuds(qi,j)
          psjet1=psjet1*(1.d0/qmin-1.d0/qmax)/sud0/delh/18.d0
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psjet1
202     FORMAT(2x,'PSJET1=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psjint(Q1,Q2,S,M,L)
C PSJINT - inclusive hard cross-section interpolation - for any ordering
c in the ladder
c Q1 - effective momentum cutoff for current end of the ladder,
c Q2 - effective momentum cutoff for opposide end of the ladder,
c S - total c.m. energy squared for the ladder,
c M - parton type at current end of the ladder (1 - g, 2 - q)
c L - parton type at opposite end of the ladder (1 - g, 2 - q)
C-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension wi(3),wj(3),wk(3)
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area29/ csj(17,17,68)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,q1,q2,m,l
201     FORMAT(2x,'PSJINT - UNORDERED LADDER CROSS SECTION INTERPOL.:'/
     *  4x,'S=',e10.3,2x,'Q1=',e10.3,2x,'Q2=',e10.3,2x,
     *  2x,'M=',i1,2x,'L=',i1)
        psjint=0.d0
        qq=max(q1,q2)
      IF(s.LE.max(4.d0*qt0,qq))THEN
        IF(debug.GE.3)WRITE (moniou,202)psjint
202     FORMAT(2x,'PSJINT=',e10.3)
        RETURN
      ENDIF

        ml=17*(m-1)+34*(l-1)
        qli=dlog(q1/qt0)/1.38629d0
        qlj=dlog(q2/qt0)/1.38629d0
        sl=dlog(s/qt0)/1.38629d0
        sql=sl-max(qli,qlj)
        i=int(qli)
        j=int(qlj)
        k=int(sl)
        IF(i.GT.13)i=13
        IF(j.GT.13)j=13
        
        IF(sql.GT.10.d0)THEN
          IF(k.GT.14)k=14
          IF(i.GT.k-3)i=k-3
          IF(j.GT.k-3)j=k-3
          wi(2)=qli-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)
          wj(2)=qlj-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)
          wk(2)=sl-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 1 i1=1,3
          DO 1 j1=1,3
          DO 1 k1=1,3
1         psjint=psjint+csj(i+i1,j+j1,k+k1+ml)*wi(i1)*wj(j1)*wk(k1)
          psjint=exp(psjint)
        ELSEIF(sql.LT.1.d0.AND.i+j.NE.0)THEN
          sq=(s/max(q1,q2)-1.d0)/3.d0
          wi(2)=qli-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)
          wj(2)=qlj-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)

          DO 2 i1=1,3
          i2=i+i1
          DO 2 j1=1,3
          j2=j+j1
          k2=max(i2,j2)+1+ml
2         psjint=psjint+csj(i2,j2,k2)*wi(i1)*wj(j1)
          psjint=exp(psjint)*sq
        ELSEIF(k.EQ.1)THEN
          sq=(s/qt0/4.d0-1.d0)/3.d0
          wi(2)=qli
          wi(1)=1.d0-qli
          wj(2)=qlj
          wj(1)=1.d0-qlj

          DO 3 i1=1,2
          DO 3 j1=1,2
3         psjint=psjint+csj(i1,j1,3+ml)*wi(i1)*wj(j1)
          psjint=exp(psjint)*sq
        ELSEIF(k.LT.15)THEN
          kl=int(sql)
          IF(i+kl.GT.12)i=12-kl
          IF(j+kl.GT.12)j=12-kl
          IF(i+j+kl.EQ.1)kl=2
          wi(2)=qli-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)
          wj(2)=qlj-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)
          wk(2)=sql-kl
          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 4 i1=1,3
          i2=i+i1
          DO 4 j1=1,3
          j2=j+j1
          DO 4 k1=1,3
          k2=max(i2,j2)+kl+k1-1+ml
4         psjint=psjint+csj(i2,j2,k2)*wi(i1)*wj(j1)*wk(k1)
          psjint=exp(psjint)
        ELSE
          k=15
          IF(i.GT.k-3)i=k-3
          IF(j.GT.k-3)j=k-3
          wi(2)=qli-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)
          wj(2)=qlj-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)
          wk(2)=sl-k
          wk(1)=1.d0-wk(2)
        
          DO 5 i1=1,3
          DO 5 j1=1,3
          DO 5 k1=1,2
5         psjint=psjint+csj(i+i1,j+j1,k+k1+ml)*wi(i1)*wj(j1)*wk(k1)
          psjint=exp(psjint)
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psjint
        RETURN
        END
C=======================================================================

        SUBROUTINE psjint0(S,SJ,SJB,M,L)
C PSJINT0 - inclusive hard cross-section interpolation - for minimal
c effective momentum cutoff in the ladder
c S - total c.m. energy squared for the ladder,
c SJ - inclusive jet cross-section,
c SJB - Born cross-section,
c M - parton type at current end of the ladder (0 - g, 1 - q)
c L - parton type at opposite end of the ladder (0 - g, 1 - q)
C-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension wk(3)
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area32/ csj(17,2,2),csb(17,2,2)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,m,l
201     FORMAT(2x,'PSJINT0 - HARD CROSS SECTION INTERPOLATION:'/
     *  4x,'S=',e10.3,2x,'M=',i1,2x,'L=',i1)
        sj=0.d0
        sjb=0.d0
      IF(s.LE.4.d0*qt0)THEN
        IF(debug.GE.3)WRITE (moniou,202)sj,sjb
202     FORMAT(2x,'PSJINT0: SJ=',e10.3,2x,'SJB=',e10.3)
        RETURN
      ENDIF

        sl=dlog(s/qt0)/1.38629d0
        k=int(sl)
        IF(k.EQ.1)THEN
          sq=(s/qt0/4.d0-1.d0)/3.d0
          sjb=exp(csb(3,m+1,l+1))*sq
          sj=exp(csj(3,m+1,l+1))*sq
        ELSE
          IF(k.GT.14)k=14
          wk(2)=sl-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 1 k1=1,3
          sj=sj+csj(k+k1,m+1,l+1)*wk(k1)
1         sjb=sjb+csb(k+k1,m+1,l+1)*wk(k1)
          sjb=exp(sjb)
          sj=exp(sj)
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)sj,sjb
        RETURN
        END
C=======================================================================

        FUNCTION psjint1(Q1,Q2,S,M,L)
C PSJINT1 - inclusive hard cross-section interpolation - for strict ordering
c in the ladder
c Q1 - effective momentum cutoff for current end of the ladder,
c Q2 - effective momentum cutoff for opposide end of the ladder,
c S - total c.m. energy squared for the ladder,
c M - parton type at current end of the ladder (1 - g, 2 - q)
c L - parton type at opposite end of the ladder (1 - g, 2 - q)
C-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension wi(3),wj(3),wk(3)
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area30/ csj(17,17,68)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,q1,q2,m,l
201     FORMAT(2x,'PSJINT1 - STRICTLY ORDERED LADDER CROSS SECTION',
     *  ' INTERPOLATION:'/
     *  4x,'S=',e10.3,2x,'Q1=',e10.3,2x,'Q2=',e10.3,2x,
     *  4x,'M=',i1,2x,'L=',i1)
        psjint1=0.d0
        qq=max(q1,q2)
      IF(s.LE.max(4.d0*qt0,qq))THEN
        IF(debug.GE.3)WRITE (moniou,202)psjint1
202     FORMAT(2x,'PSJINT1=',e10.3)
        RETURN
      ENDIF

        ml=17*(m-1)+34*(l-1)
        qli=dlog(q1/qt0)/1.38629d0
        qlj=dlog(q2/qt0)/1.38629d0
        sl=dlog(s/qt0)/1.38629d0
        sql=sl-max(qli,qlj)
        i=int(qli)
        j=int(qlj)
        k=int(sl)
        IF(i.GT.13)i=13
        IF(j.GT.13)j=13
        
        IF(sql.GT.10.d0)THEN
          IF(k.GT.14)k=14
          IF(i.GT.k-3)i=k-3
          IF(j.GT.k-3)j=k-3
          wi(2)=qli-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)
          wj(2)=qlj-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)
          wk(2)=sl-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 1 i1=1,3
          DO 1 j1=1,3
          DO 1 k1=1,3
1         psjint1=psjint1+csj(i+i1,j+j1,k+k1+ml)*wi(i1)*wj(j1)*wk(k1)
          psjint1=exp(psjint1)
        ELSEIF(sql.LT.1.d0.AND.i+j.NE.0)THEN
          sq=(s/max(q1,q2)-1.d0)/3.d0
          wi(2)=qli-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)
          wj(2)=qlj-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)
        
          DO 2 i1=1,3
          i2=i+i1
          DO 2 j1=1,3
          j2=j+j1
          k2=max(i2,j2)+1+ml
2         psjint1=psjint1+csj(i2,j2,k2)*wi(i1)*wj(j1)
          psjint1=exp(psjint1)*sq
        ELSEIF(k.EQ.1)THEN
          sq=(s/qt0/4.d0-1.d0)/3.d0
          wi(2)=qli
          wi(1)=1.d0-qli
          wj(2)=qlj
          wj(1)=1.d0-qlj

          DO 3 i1=1,2
          DO 3 j1=1,2
3         psjint1=psjint1+csj(i1,j1,3+ml)*wi(i1)*wj(j1)
          psjint1=exp(psjint1)*sq
        ELSEIF(k.LT.15)THEN
          kl=int(sql)
          IF(i+kl.GT.12)i=12-kl
          IF(j+kl.GT.12)j=12-kl
          IF(i+j+kl.EQ.1)kl=2
        
          wi(2)=qli-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)
          wj(2)=qlj-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)
          wk(2)=sql-kl
          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 4 i1=1,3
          i2=i+i1
          DO 4 j1=1,3
          j2=j+j1
          DO 4 k1=1,3
          k2=max(i2,j2)+kl+k1-1+ml
4         psjint1=psjint1+csj(i2,j2,k2)*wi(i1)*wj(j1)*wk(k1)
          psjint1=exp(psjint1)
        ELSE
          k=15
          IF(i.GT.k-3)i=k-3
          IF(j.GT.k-3)j=k-3
          wi(2)=qli-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)
          wj(2)=qlj-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)
          wk(2)=sl-k
          wk(1)=1.d0-wk(2)
        
          DO 5 i1=1,3
          DO 5 j1=1,3
          DO 5 k1=1,2
5         psjint1=psjint1+csj(i+i1,j+j1,k+k1+ml)*wi(i1)*wj(j1)*wk(k1)
          psjint1=exp(psjint1)
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psjint1
        RETURN
        END
C=======================================================================

       FUNCTION pslam(S,A,B)
c Kinematical function for two particle decay - maximal Pt-value
c A - first particle mass squared,
C B - second particle mass squared,
C S - two particle invariant mass
c-----------------------------------------------------------------------
       IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
       COMMON /area43/ moniou
       COMMON /debug/  debug
       SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,a,b
201     FORMAT(2x,'PSLAM - KINEMATICAL FUNCTION S=',e10.3,2x,'A=',
     *  e10.3,2x,'B=',e10.3)
       pslam=.25d0/s*(s+a-b)**2-a
        IF(debug.GE.3)WRITE (moniou,202)pslam
202     FORMAT(2x,'PSLAM=',e10.3)
       RETURN
       END
C=======================================================================

        FUNCTION psnorm(EP)
c 4-vector squared calculation
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep(4)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)ep
201     FORMAT(2x,'PSNORM - 4-VECTOR SQUARED FOR ',
     *  'EP=',4(e10.3,1x))
        psnorm=ep(1)**2
        DO 1 i=1,3
1       psnorm=psnorm-ep(i+1)**2
        IF(debug.GE.3)WRITE (moniou,202)psnorm
202     FORMAT(2x,'PSNORM=',e10.3)
        RETURN
        END
C=======================================================================

        SUBROUTINE psrec(EP,QV,ZV,QM,IQV,LDAU,LPAR,IQJ,EQJ,JFL,JQ)
c Jet reconstructuring procedure - 4-momenta for all final jets are determined
c EP(i) - jet 4-momentum
C-----------------------------------------------------------------------
c QV(i,j) - effective momentum for the branching of the parton in i-th row
c on j-th level (0 - in case of no branching)
c ZV(i,j) - Z-value for the branching of the parton in i-th row
c on j-th level
c QM(i,j) - mass squared for the parton in i-th row
c on j-th level
c IQV(i,j) - flavours for the parton in i-th row on j-th level
c LDAU(i,j) - first daughter row for the branching of the parton in i-th row
c on j-th level
c LPAR(i,j) - the parent row for the parton in i-th row on j-th level
C-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep(4),ep3(4),epv(4,30,50),
     *  qv(30,50),zv(30,50),qm(30,50),iqv(30,50),
     *  ldau(30,49),lpar(30,50),
     *  iqj(2),eqj(4,2),ipq(2,30,50),epq(8,30,50),
     *  epj(4),epj1(4)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)jq,ep,iqj
201     FORMAT(2x,'PSREC - JET RECONSTRUCTURING: JQ=',i1/
     *  4x,'JET 4-MOMENTUM EP=',4(e10.3,1x)/4x,'IQJ=',2i2)
        jfl = 1
        DO 1 i=1,4
        epv(i,1,1)=ep(i)
1       epq(i,1,1)=eqj(i,1)
        ipq(1,1,1)=iqj(1)

        IF(iqv(1,1).EQ.0)THEN
          DO 2 i=1,4
2         epq(i+4,1,1)=eqj(i,2)
          ipq(2,1,1)=iqj(2)
        ENDIF

        nlev=1
        nrow=1

3       CONTINUE

        IF(qv(nrow,nlev).EQ.0.d0)THEN
           ipj=iqv(nrow,nlev)
           IF(ipj.NE.0)THEN
             IF(epq(1,nrow,nlev).NE.0.d0)THEN
               IF(iabs(ipj).EQ.3)ipj=ipj*4/3
              DO 4 i=1,4
              epj(i)=epv(i,nrow,nlev)
4             epj1(i)=epq(i,nrow,nlev)
              ipj1=ipq(1,nrow,nlev)
              IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
              CALL psjdef(ipj,ipj1,epj,epj1,jfl)
        IF(debug.GE.3)WRITE (moniou,211)ipj,ipj1,jfl
211     FORMAT(2x,'PSREC - NEW STRING FLAVOURS: ',2i3,' JFL=',i1)
              IF(jfl.EQ.0)RETURN
            ELSE
              ipq(1,nrow,nlev)=ipj
              DO 5 i=1,4
5             epq(i,nrow,nlev)=epv(i,nrow,nlev)
        IF(debug.GE.3)WRITE (moniou,212)ipj,
     *  (epv(i,nrow,nlev),i=1,4),jfl
212     FORMAT(2x,'PSREC: NEW FINAL JET FLAVOR: ',i3,2x,
     *         'JET 4-MOMENTUM:', 4(e10.3,1x),' JFL=',i1)
            ENDIF
            
           ELSE
             ipj=int(2.d0*qsran(b10)+1.d0)*(3-2*jq)
            DO 6 i=1,4
6           epj(i)=.5d0*epv(i,nrow,nlev)
          
            DO 9 m=1,2
            IF(epq(1+4*(m-1),nrow,nlev).NE.0.d0)THEN
              DO 7 i=1,4
7             epj1(i)=epq(4*(m-1)+i,nrow,nlev)
              ipj1=ipq(m,nrow,nlev)
              IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
              CALL psjdef(ipj,ipj1,epj,epj1,jfl)
              IF(jfl.EQ.0)RETURN
            ELSE
              ipq(m,nrow,nlev)=ipj
              DO 8 i=1,4
8             epq(4*(m-1)+i,nrow,nlev)=epj(i)
            ENDIF
9           ipj=-ipj
          ENDIF

        IF(debug.GE.3)WRITE (moniou,204)nlev,nrow,iqv(nrow,nlev),
     *  (epv(i,nrow,nlev),i=1,4)
204     FORMAT(2x,'PSREC: FINAL JET AT LEVEL NLEV=',i2,
     *  ' NROW=',i2/4x,'JET FLAVOR: ',i3,2x,'JET 4-MOMENTUM:',
     *  4(e10.3,1x))
         ELSE

          DO 10 i=1,4
10        ep3(i)=epv(i,nrow,nlev)
          CALL psdefrot(ep3,s0x,c0x,s0,c0)
          z=zv(nrow,nlev)
          qt2=(z*(1.d0-z))**2*qv(nrow,nlev)
          ldrow=ldau(nrow,nlev)

          wp0=ep3(1)+ep3(2)
          wpi=z*wp0
          wmi=(qt2+qm(ldrow,nlev+1))/wpi
          ep3(1)=.5d0*(wpi+wmi)
          ep3(2)=.5d0*(wpi-wmi)
          qt=dsqrt(qt2)
          CALL pscs(c,s)
          ep3(3)=qt*c
          ep3(4)=qt*s
          CALL psrotat(ep3,s0x,c0x,s0,c0)

          DO 11 i=1,4
11        epv(i,ldrow,nlev+1)=ep3(i)
        IF(debug.GE.3)WRITE (moniou,206)nlev+1,ldrow,ep3
206     FORMAT(2x,'PSREC: JET AT LEVEL NLEV=',i2,
     *  ' NROW=',i2/4x,'JET 4-MOMENTUM:',4(e10.3,1x))

          wpi=(1.d0-z)*wp0
          wmi=(qt2+qm(ldrow+1,nlev+1))/wpi
          ep3(1)=.5d0*(wpi+wmi)
          ep3(2)=.5d0*(wpi-wmi)
          ep3(3)=-qt*c
          ep3(4)=-qt*s
          CALL psrotat(ep3,s0x,c0x,s0,c0)
        IF(debug.GE.3)WRITE (moniou,206)nlev+1,ldrow+1,ep3

          DO 12 i=1,4
12        epv(i,ldrow+1,nlev+1)=ep3(i)

          IF(iqv(nrow,nlev).EQ.0)THEN
            IF(iqv(ldrow,nlev+1).NE.0)THEN
              ipq(1,ldrow,nlev+1)=ipq(1,nrow,nlev)
              ipq(1,ldrow+1,nlev+1)=ipq(2,nrow,nlev)
              DO 13 i=1,4
              epq(i,ldrow,nlev+1)=epq(i,nrow,nlev)
13            epq(i,ldrow+1,nlev+1)=epq(i+4,nrow,nlev)
            ELSE
              ipq(1,ldrow,nlev+1)=ipq(1,nrow,nlev)
              ipq(2,ldrow,nlev+1)=0
              ipq(1,ldrow+1,nlev+1)=0
              ipq(2,ldrow+1,nlev+1)=ipq(2,nrow,nlev)
              DO 14 i=1,4
              epq(i,ldrow,nlev+1)=epq(i,nrow,nlev)
              epq(i+4,ldrow,nlev+1)=0.d0
              epq(i,ldrow+1,nlev+1)=0.d0
14            epq(i+4,ldrow+1,nlev+1)=epq(i+4,nrow,nlev)
            ENDIF
          ELSE
            IF(iqv(ldrow,nlev+1).EQ.0)THEN
              ipq(1,ldrow,nlev+1)=ipq(1,nrow,nlev)
              ipq(2,ldrow,nlev+1)=0
              ipq(1,ldrow+1,nlev+1)=0
              DO 15 i=1,4
              epq(i,ldrow,nlev+1)=epq(i,nrow,nlev)
              epq(i+4,ldrow,nlev+1)=0.d0
15            epq(i,ldrow+1,nlev+1)=0.d0
            ELSE
              ipq(1,ldrow,nlev+1)=0
              ipq(1,ldrow+1,nlev+1)=0
              ipq(2,ldrow+1,nlev+1)=ipq(1,nrow,nlev)
              DO 16 i=1,4
              epq(i,ldrow,nlev+1)=0.d0
              epq(i,ldrow+1,nlev+1)=0.d0
16            epq(i+4,ldrow+1,nlev+1)=epq(i,nrow,nlev)
            ENDIF
          ENDIF

          nrow=ldrow
          nlev=nlev+1
          GOTO 3
        ENDIF

17      CONTINUE
        IF(nlev.EQ.1)THEN
          iqj(1)=ipq(1,1,1)
          DO 18 i=1,4
18        eqj(i,1)=epq(i,1,1)
          IF(iqv(1,1).EQ.0)THEN
            iqj(2)=ipq(2,1,1)
            DO 19 i=1,4
19          eqj(i,2)=epq(i+4,1,1)
          ENDIF
        IF(debug.GE.3)WRITE (moniou,202)iqj
202     FORMAT(2x,'PSREC - END',2x,'iqj=',2i2)
        RETURN
      ENDIF

        lprow=lpar(nrow,nlev)

        IF(ldau(lprow,nlev-1).EQ.nrow)THEN
           IF(iqv(nrow,nlev).EQ.0)THEN
             IF(epq(1,lprow,nlev-1).EQ.0.d0)THEN
              ipq(1,lprow,nlev-1)=ipq(1,nrow,nlev)
              DO 20 i=1,4
20            epq(i,lprow,nlev-1)=epq(i,nrow,nlev)
            ENDIF
            ipq(1,nrow+1,nlev)=ipq(2,nrow,nlev)
            DO 21 i=1,4
21          epq(i,nrow+1,nlev)=epq(i+4,nrow,nlev)
          ELSE
            IF(iqv(lprow,nlev-1).EQ.0)THEN
              IF(epq(1,lprow,nlev-1).EQ.0.d0)THEN
                ipq(1,lprow,nlev-1)=ipq(1,nrow,nlev)
                DO 22 i=1,4
22              epq(i,lprow,nlev-1)=epq(i,nrow,nlev)
              ENDIF
            ELSE
              ipq(1,nrow+1,nlev)=ipq(1,nrow,nlev)
              DO 23 i=1,4
23            epq(i,nrow+1,nlev)=epq(i,nrow,nlev)
            ENDIF
          ENDIF
          nrow=nrow+1
          GOTO 3

        ELSE
          IF(iqv(nrow,nlev).EQ.0)THEN
            IF(iqv(lprow,nlev-1).EQ.0)THEN
              IF(epq(5,lprow,nlev-1).EQ.0.d0)THEN
                ipq(2,lprow,nlev-1)=ipq(2,nrow,nlev)
                DO 24 i=1,4
24              epq(i+4,lprow,nlev-1)=epq(i+4,nrow,nlev)
              ENDIF
            ELSE
              IF(epq(1,lprow,nlev-1).EQ.0.d0)THEN
                ipq(1,lprow,nlev-1)=ipq(2,nrow,nlev)
                DO 25 i=1,4
25              epq(i,lprow,nlev-1)=epq(i+4,nrow,nlev)
              ENDIF
            ENDIF
          ELSE
            IF(iqv(lprow,nlev-1).EQ.0.AND.
     *      epq(5,lprow,nlev-1).EQ.0.d0)THEN
                ipq(2,lprow,nlev-1)=ipq(1,nrow,nlev)
                DO 26 i=1,4
26              epq(i+4,lprow,nlev-1)=epq(i,nrow,nlev)
            ENDIF
          ENDIF

          nrow=lprow
          nlev=nlev-1
          GOTO 17
        ENDIF
        END
C=======================================================================

      FUNCTION psrejs(S,Z,IQQ)
c PSREJS - rejection function for the energy sharing for semihard
c interaction (Hi_semihard(S)/S**delh)
c S - energy squared for the semihard interaction,
c Z - impact parameter factor, Z=exp(-b**2/Rp),
c IQQ - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
      COMMON /area17/ del,rs,rs0,fs,alf,rr,sh,delh
      COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
      COMMON /ar3/    x1(7),a1(7)
      COMMON /area43/ moniou
      COMMON /debug/  debug
      SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,z,iqq
201     FORMAT(2x,'PSREJS - REJECTION FUNCTION TABULATION: '/
     *  4x,'S=',e10.3,2x,'Z=',e10.3,2x,'IQQ=',i1)
      xmin=4.d0*(qt0+amj0)/s
      xmin=xmin**(delh-del)
      psrejs=0.d0

c Numerical integration over Z1
      DO 2 i=1,7
      DO 2 m=1,2
      z1=(.5d0*(1.d0+xmin-(2*m-3)*x1(i)*(1.d0-xmin)))**(1.d0/
     *(delh-del))

c SJ is the inclusive hard partonic interaction
c cross-section (inclusive cut ladder cross section) for minimal
c 4-momentum transfer squre QT0 and c.m. energy square s_hard = exp YJ;
c SJB - Born cross-section
      yj=dlog(z1*s)
      CALL psjint0(z1*s,sj,sjb,iqq,0)
c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic
c interaction cross-section for minimal 4-momentum transfer square QT0 and
c c.m. energy square s_hard = exp YJ; SH=pi*R_hard**2 (R_hard**2=4/QT0)
      gy=2.d0*sh*psgint((sj-sjb)/sh*.5d0)+sjb
      rh=rs0-alf*dlog(z1)

      IF(iqq.NE.0)THEN
        psrejs=psrejs+a1(i)*gy/(z1*s)**delh*z**(rs0/rh)/rh*
     *  (1.d0-z1)*bet
      ELSE
        st2=0.d0
        DO 1 j=1,7
1       st2=st2+a1(j)*((1.d0-z1**(.5d0*(1.d0+x1(j))))*
     *  (1.d0-z1**(.5d0*(1.d0-x1(j)))))**bet

        psrejs=psrejs-a1(i)*dlog(z1)*gy/(z1*s)**delh*z**(rs0/rh)/rh*st2
      ENDIF
2     CONTINUE
      psrejs=dlog(psrejs*(1.d0-xmin)/z)
        IF(debug.GE.2)WRITE (moniou,202)psrejs
202     FORMAT(2x,'PSREJS=',e10.3)
      RETURN
      END
C=======================================================================

        FUNCTION psrejv(S)
c PSREJV - rejection function for the energy sharing for quark-quark hard
c interaction (sigma_hard(S)/S**delh)
c S - energy squared for the hard interaction
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area17/ del,rs,rs0,fs,alf,rr,sh,delh
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s
201     FORMAT(2x,'PSREJV - REJECTION FUNCTION TABULATION: ',
     *  'S=',e10.3)
c SJ is the inclusive hard QUARK-QUARK interaction
c cross-section (inclusive cut ladder cross section) for minimal
c 4-momentum transfer squre QT0 and c.m. energy square s;
c SJB - Born cross-section
        CALL psjint0(s,sj,sjb,1,1)

c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic (quark-quark)
c interaction cross-section for minimal 4-momentum transfer square QT0 and
c c.m. energy square s; SH=pi*R_hard**2 (R_hard**2=4/QT0)
        gy=2.d0*sh*psgint((sj-sjb)/sh*.5d0)+sjb
        psrejv=dlog(gy/s**delh)
        IF(debug.GE.3)WRITE (moniou,202)psrejv
202     FORMAT(2x,'PSREJV=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psrjint(YJ,Z0,IQQ)
c PSRJINT - Rejection function for the energy sharing (Hi_semih(S)/S**delh)
c YJ=ln S,
c Z0 - impact parameter factor, Z0=exp(-b**2/Rp),
c IQQ - type of hard interaction (0 - gg; 1 - qg, 2 - gq; 3 - qq)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension a(3)
        COMMON /area1/  ia(2),icz,icp
        COMMON /area17/ del,rs,rs0,fs,alf,rr,sh,delh
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area23/ rjv(50)
        COMMON /area24/ rjs(50,5,10)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)yj,z0,iqq
201     FORMAT(2x,'PSRJINT - REJECTION FUNCTION INTERPOLATION:'/
     *  4x,'YJ=',e10.3,2x,'Z0=',e10.3,2x,'IQQ=',i1)
        yy=(yj-aqt0)*2.d0
*       JY=INT(YY)
        jy=min(48,int(yy))       !  modified 15.oct.03 D.H.

        IF(iqq.EQ.3)THEN
          IF(jy.EQ.0)THEN
            psrjint=exp(rjv(1))*yy+(exp(rjv(2))-2.d0*
     *      exp(rjv(1)))*yy*(yy-1.d0)*.5d0
          ELSE
            psrjint=exp(rjv(jy)+(rjv(jy+1)-rjv(jy))*(yy-jy)
     *      +(rjv(jy+2)+rjv(jy)-2.d0*rjv(jy+1))*(yy-jy)*
     *      (yy-jy-1.d0)*.5d0)
          ENDIF
        ELSE
          z=z0**(rs/rs0)
          iq=(iqq+1)/2+1+2*(icz-1)
          jz=int(5.d0*z)
          IF(jz.GT.3)jz=3
          wz=5.d0*z-jz

          IF(jz.EQ.0)THEN
            i1=2
          ELSE
            i1=1
          ENDIF

          DO 1 i=i1,3
          j1=jz+i-1
          IF(jy.EQ.0)THEN
            a(i)=exp(rjs(1,j1,iq))*yy+(exp(rjs(2,j1,iq))-2.d0*
     *      exp(rjs(1,j1,iq)))*yy*(yy-1.d0)*.5d0
            IF(a(i).GT.0.d0)THEN
              a(i)=dlog(a(i))
            ELSE
              a(i)=-80.d0
            ENDIF
          ELSE
            a(i)=rjs(jy,j1,iq)+(rjs(jy+1,j1,iq)-
     *      rjs(jy,j1,iq))*(yy-jy)
     *      +(rjs(jy+2,j1,iq)+rjs(jy,j1,iq)-2.d0*
     *      rjs(jy+1,j1,iq))*(yy-jy)*(yy-jy-1.d0)*.5d0
          ENDIF
1         CONTINUE

          IF(jz.NE.0)THEN
            psrjint=exp(a(1)+(a(2)-a(1))*wz+(a(3)+a(1)-2.d0*a(2))*wz*
     *      (wz-1.d0)*.5d0)*z
          ELSE
            psrjint=(exp(a(2))*wz+(exp(a(3))-2.d0*exp(a(2)))*wz*
     *      (wz-1.d0)*.5d0)*z
            IF(psrjint.LE.0.d0)psrjint=1.d-10
          ENDIF
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psrjint
202     FORMAT(2x,'PSRJINT=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psroot(QLMAX,G,J)
c PSROOT - effective momentum tabulation for given set of random number
c values and maximal effective momentum QMAX values - according to the
c probability of branching: (1 - timelike Sudakov formfactor)
c QLMAX - ln QMAX/16/QTF,
c G - dzeta number (some function of ksi)
c J - type of the parton (1-g,2-q)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)qlmax,g,j
201     FORMAT(2x,'PSQINT - BRANCHING MOMENTUM TABULATION:'/
     *  4x,'QLMAX=',e10.3,2x,'G=',e10.3,2x,'J=',i1)
        ql0=0.d0
        ql1=qlmax
        f0=-g
        f1=1.d0-g
        sud0=-dlog(psudint(qlmax,j))

1       ql2=ql1-(ql1-ql0)*f1/(f1-f0)
        IF(ql2.LT.0.d0)THEN
          ql2=0.d0
          f2=-g
        ELSEIF(ql2.GT.qlmax)THEN
          ql2=qlmax
          f2=1.d0-g
        ELSE
          f2=-dlog(psudint(ql2,j))/sud0-g
        ENDIF

        IF(abs(f2).GT.1.d-3)THEN
          ql0=ql1
          ql1=ql2
          f0=f1
          f1=f2
          GOTO 1
        ELSE
          psroot=ql2
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psroot
202     FORMAT(2x,'PSROOT=',e10.3)
        RETURN
        END
C=======================================================================

        SUBROUTINE psrotat(EP,S0X,C0X,S0,C0)
c Spacial rotation to the lab. system for 4-vector EP
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep(4),ep1(3)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)ep,s0x,c0x,s0,c0
201     FORMAT(2x,'PSROTAT - SPACIAL ROTATION:'/4x,
     *  '4-VECTOR EP=',4(e10.3,1x)/4x,'S0X=',e10.3,'C0X=',e10.3,
     *  2x,'S0=',e10.3,'C0=',e10.3)
        ep1(3)=ep(4)
        ep1(2)=ep(2)*s0+ep(3)*c0
        ep1(1)=ep(2)*c0-ep(3)*s0

        ep(2)=ep1(1)
        ep(4)=ep1(2)*s0x+ep1(3)*c0x
        ep(3)=ep1(2)*c0x-ep1(3)*s0x
        IF(debug.GE.3)WRITE (moniou,202)ep
202     FORMAT(2x,'PSROTAT: ROTATED 4-VECTOR EP=',
     *  2x,4e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psqint(QLMAX,G,J)
c PSQINT - effective momentum interpolation for given random number G
c and maximal effective momentum QMAX
c QLMAX - ln QMAX/16/QTF,
c G - random number (0<G<1)
c J - type of the parton (1-g,2-q)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension wi(3),wk(3)
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area34/ qrt(10,101,2)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)qlmax,g,j
201     FORMAT(2x,'PSQINT - BRANCHING MOMENTUM INTERPOLATION:'/
     *  4x,'QLMAX=',e10.3,2x,'G=',e10.3,2x,'J=',i1)
        qli=qlmax/1.38629d0
        sud0=1.d0/psudint(qlmax,j)
        sl=100.d0*dlog(1.d0-g*(1.d0-sud0))/dlog(sud0)
        i=int(qli)
        k=int(sl)
        IF(k.GT.98)k=98
        wk(2)=sl-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)
        psqint=0.d0

        IF(i.GT.7)i=7
        wi(2)=qli-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)

        DO 1 k1=1,3
        DO 1 i1=1,3
1       psqint=psqint+qrt(i+i1,k+k1,j)*wi(i1)*wk(k1)
        IF(psqint.LE.0.d0)psqint=0.d0
        psqint=16.d0*qtf*exp(psqint)
        IF(debug.GE.3)WRITE (moniou,202)psqint
202     FORMAT(2x,'PSQINT=',e10.3)
        RETURN
        END
C=======================================================================

        SUBROUTINE psshar(LS,NHP,NW,NT)
c Inelastic interaction - energy sharing procedure:
c LS - total number of  cut soft pomeron blocks (froissarons),
c NHP - total number of hard pomerons,
c NW - number of interacting projectile nucleons (excluding diffracted),
c NT - number of target nucleons in active state
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
C D.H.  REAL*16 GBH,GBH0
        dimension wp(56),wm(56),wha(4000),whb(4000),lha0(56),
     *  lhb0(56),izp(56),izt(56),wp0h(56),wm0h(56),
     *  wpp(2),wmm(2),ep3(4),lqa0(56),lqb0(56),ipc(2,2),epc(8,2),
     *  ila(56),ilb(56),ela(4,56),elb(4,56),ep(4),ep1(4)
        COMMON /area1/  ia(2),icz,icp
        COMMON /area2/  s,y0,wp0,wm0
        COMMON /area9/  lqa(56),lqb(56),nqs(1000),ias(1000),ibs(1000),
     *                  lha(56),lhb(56),zh(4000),iah(4000),ibh(4000),
     *                  iqh(4000),lva(56),lvb(56)
        COMMON /area10/ stmass,am(7)
        COMMON /area11/ b10
        COMMON /area12/ nsh
        COMMON /area17/ del,rs,rs0,fs,alfp,rr,sh,delh
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area19/ ahl(5)
        COMMON /area20/ wppp
        COMMON /area25/ ahv(5)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        COMMON /area47/ njtot
        SAVE
        EXTERNAL qsran
        DATA xdiv /100.d0/

        IF(debug.GE.1)WRITE (moniou,201)nw,nt,nhp,ls
201     FORMAT(2x,'PSSHARE - ENERGY SHARING PROCEDURE'/
     *  4x,'NUMBER OF WOUNDED PROJECTILE NUCLEONS(HADRONS) NW=',i2/
     *  4x,'NUMBER OF TARGET NUCLEONS IN THE ACTIVE STATE NT=',i2/
     *  4x,'NUMBER OF SEMIHARD BLOCKS NHP=',i3/
     *  4x,'NUMBER OF SOFT POMERON BLOCKS LS=',i3)
        nsh1=nsh
        DO 101 i=1,nw
101     lqa0(i)=lqa(i)
        DO 102 i=1,nt
102     lqb0(i)=lqb(i)

100     nsh=nsh1
        njtot=0
        DO 103 i=1,nw
103     lqa(i)=lqa0(i)
        DO 104 i=1,nt
104     lqb(i)=lqb0(i)
c-------------------------------------------------
c Initial nucleons (hadrons) types recording
        IF(ia(1).NE.1)THEN
c IZP(i) - i-th projectile nucleons type (proton - 2, neutron - 3)
          DO 1 i=1,nw
1         izp(i)=int(2.5+qsran(b10))
        ELSE
c IZP(1)=ICP - projectile hadron type
          izp(1)=icp
        ENDIF
        IF(ia(2).NE.1)THEN
c IZT(j) - j-th target nucleon type (proton - 2 or neutron - 3)
          DO 2 i=1,nt
2         izt(i)=int(2.5+qsran(b10))
        ELSE
c Target proton
         izt(1)=2
        ENDIF
c-------------------------------------------------

c WREJ - parameter for energy sharing (to minimise rejection)
        wrej=.0001d0

3       CONTINUE

        IF(nhp.NE.0)THEN
        IF(debug.GE.3)WRITE (moniou,211)nhp
211     FORMAT(2x,'PSSHARE: NUMBER OF HARD POMERONS NHP=',i3)
c-------------------------------------------------
c-------------------------------------------------
c Rejection function initialization:
c-------------------------------------------------
c energy-momentum will be shared between pomerons
c according to s**DEL dependence for soft pomeron and
c according to s**DELH dependence for pomeron with hard block,
c then rejection is used according to real Sigma_hard(s) dependence.
c Rejection is expected to be minimal for the uniform energy
c distribution between pomerons ( s_hard = s / LHA(I) / LHB(J) )
          gbh0=.6d0
c NREJ - total number of rejections
          nrej=0
          nhp1=nhp

          DO 5 ih=1,nhp1
        IF(debug.GE.3)WRITE (moniou,212)ih
212     FORMAT(2x,'PSSHARE: GBH-INI; CONTRIBUTION FROM ',i3,
     *   '-TH HARD POMERON')
c-------------------------------------------------
c LHA(i) (LHB(j)) - total number of cut hard blocks, connected to i-th projectile
c (j-th target) nucleon (hadron);
c IAH(ih) (IBH(ih)) - number (position in array) of the projectile (target) nucleon,
c connected to ih-th hard block;
c ZH(ih) - factor exp(-R_ij/R_p) for ih-th hard block;
c IQH(ih) - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
          iqq=iqh(ih)
          z=zh(ih)
          i=iah(ih)
          j=ibh(ih)

c Uniform energy distribution between hard pomerons
          za=1.d0/lha(i)
          zb=1.d0/lhb(j)
c SI - c.m. energy squared for one hard block
          si=za*zb*s

          IF(si.LT.4.d0*(qt0+amj0))THEN
c-------------------------------------------------
c One hard pomeron is removed (the energy is insufficient to simulate
c great number of pomerons)
c-------------------------------------------------
            nhp=nhp-1
            lha(i)=lha(i)-1
            lhb(j)=lhb(j)-1

            IF(iqq.EQ.1)THEN
              lva(i)=0
            ELSEIF(iqq.EQ.2)THEN
              lvb(j)=0
            ELSEIF(iqq.EQ.3)THEN
              lva(i)=0
              lvb(j)=0
            ENDIF
c Rewriting of other hard pomerons characteristics
            IF(nhp.GE.ih)THEN
              DO 4 ih1=ih,nhp
              iqh(ih1)=iqh(ih1+1)
              zh(ih1)=zh(ih1+1)
              iah(ih1)=iah(ih1+1)
4             ibh(ih1)=ibh(ih1+1)
            ENDIF
c End of removing - event will be simulated from the very beginning
c-------------------------------------------------
            GOTO 3
          ENDIF

c Total rapidity for the interaction (for one hard block)
          yi=dlog(si)
          IF(yi.GT.17.d0)yi=17.d0
c Rejection function normalization (on maximal available energy)
          gbh0=gbh0/psrjint(yi,z,iqq)
          gbh0 = gbh0/xdiv
5         CONTINUE
        IF(debug.GE.3)WRITE (moniou,213)
213     FORMAT(2x,'PSSHARE: GBH-INI - END')
c-------------------------------------------------
c End of rejection function normalization
c-------------------------------------------------

c-------------------------------------------------
c LHA0(i), LHB0(j) arrays are used for energy sharing procedure
c (they define number of remained cut hard blocks connected to given nucleon from
c projectile or target respectively);
c WP, WM - arrays for the rest of light cone momenta (E+-P_l) for those
c nucleons (hadrons)
c Hard pomerons connected to valence quarks are excluded from LHA0(i), LHB0(j)
c (to be considered separetely)
6         DO 7 i=1,nw
          lha0(i)=lha(i)-lva(i)
7         wp(i)=wp0

          DO 8 i=1,nt
          lhb0(i)=lhb(i)-lvb(i)
8         wm(i)=wm0

c-------------------------------------------------
c Projectile valence quarks light cone momenta are choosen according to
c 1/sqrt(x) * x**delh * (1-x)**AHV(ICZ), ICZ is the type of the projectile
          DO 10 i=1,nw
          IF(lva(i).NE.0)THEN
9           xw=qsran(b10)**(1.d0/(.5d0+delh))
            IF(qsran(b10).GT.(1.d0-xw)**ahv(icz))GOTO 9
        IF(debug.GE.3)WRITE (moniou,214)i,xw
214     FORMAT(2x,'PSSHARE: ',i2,'-TH PROJ. NUCLEON (HADRON); LIGHT',
     *  ' CONE MOMENTUM SHARE XW=',e10.3)
c WP0H(i) -  valence quark light cone momentum for i-th projectile nucleon
            wp0h(i)=xw*wp(i)
c WP(i) - the remainder of the light cone momentum for i-th projectile nucleon
            wp(i)=wp(i)*(1.d0-xw)
          ENDIF
10        CONTINUE

c Target valence quarks light cone momenta are choosen according to
c 1/sqrt(x) * x**delh * (1-x)**AHV(2) (target nucleon)
          DO 12 i=1,nt
          IF(lvb(i).NE.0)THEN
11          xw=qsran(b10)**(1.d0/(.5d0+delh))
            IF(qsran(b10).GT.(1.d0-xw)**ahv(2))GOTO 11
        IF(debug.GE.3)WRITE (moniou,215)i,xw
215     FORMAT(2x,'PSSHARE: ',i2,'-TH TARGET NUCLEON (HADRON); LIGHT',
     *  ' CONE MOMENTUM SHARE XW=',e10.3)
c WM0H(i) -  valence quark light cone momentum for i-th target nucleon
            wm0h(i)=xw*wm(i)
c WM(i) - the remainder of the light cone momentum for i-th target nucleon
            wm(i)=wm(i)*(1.d0-xw)
          ENDIF
12        CONTINUE
c-------------------------------------------------

          gbh=gbh0
c-------------------------------------------------
c Cycle over all cut hard blocks
c-------------------------------------------------
          DO 18 ih=1,nhp1
c-------------------------------------------------
c IAH(ih) (IBH(ih)) - number (position in array) of the projectile (target) nucleon,
c connected to ih-th hard block;
c ZH(ih) - factor exp(-R_ij/R_p) for ih-th hard block;
c IQH(ih) - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
          iqq=iqh(ih)
          z=zh(ih)
          i=iah(ih)
          j=ibh(ih)

          IF((iqq-3)*(iqq-1).EQ.0)THEN
c WHA(ih) - light cone momentum (E+P_l) for ih-th hard block
c Read out of the valence quark light cone momentum
            wha(ih)=wp0h(i)
          ELSE
c LHA0(i) - number of remained cut hard blocks connected to i-th projectile nucleon
            lha0(i)=lha0(i)-1
c Energy is shared between pomerons according to s**DEL dependence for soft
c pomeron and according to s**DELH dependence for the hard block;
c AHL(ICZ) determines energetic spectrum of the leading hadronic state of
c type ICZ
            bpi=1.d0/(1.d0+ahl(icz)+
     *      (1.d0+delh)*lha0(i))
c            BPI=1.D0/(1.D0+AHL(ICZ)+(1.D0+DEL)*LQA(I)+
c     *      (1.D0+DELH)*LHA0(I))
15          xw=1.-qsran(b10)**bpi
c Rejection according to XW**DELH
            IF(qsran(b10).GT.xw**delh)GOTO 15
c WHA(ih) - light cone momentum (E+P_l) for ih-th hard block
            wha(ih)=wp(i)*xw
c WP(i) - the remainder of the light cone momentum for i-th projectile nucleon
            wp(i)=wp(i)*(1.d0-xw)
          ENDIF

          IF((iqq-3)*(iqq-2).EQ.0)THEN
c WHB(ih) - light cone momentum (E-P_l) for ih-th hard block
c Read out of the valence quark light cone momentum
            whb(ih)=wm0h(j)
          ELSE
c Energy is shared between pomerons - in the same way as above
            lhb0(j)=lhb0(j)-1
            bpi=1.d0/(1.d0+ahl(2)+(1.d0+delh)
     *      *lhb0(j))
c            BPI=1.D0/(1.D0+AHL(2)+(1.D0+DEL)*LQB(J)+(1.D0+DELH)
c     *      *LHB0(J))
16          xw=1.-qsran(b10)**bpi
            IF(qsran(b10).GT.xw**delh)GOTO 16
c WHB(ih) - light cone momentum (E-P_l) for ih-th hard block
            whb(ih)=wm(j)*xw
c WM(j) - the remainder of the light cone momentum for j-th target nucleon
            wm(j)=wm(j)*(1.d0-xw)
          ENDIF

c Invariant mass for ih-th hard block
          sw=wha(ih)*whb(ih)
          IF(sw.LT.4.d0*(qt0+amj0))THEN
c Rejection in case of insufficient mass
            nrej=nrej+1

            IF(nrej.GT.30)THEN
c-------------------------------------------------
c In case of great number of rejections number of hard blocks is put down
c-------------------------------------------------
c Number of remained hard blocks
              nhp=nhp-1
              lha(i)=lha(i)-1
              lhb(j)=lhb(j)-1

              IF(iqq.EQ.1)THEN
                lva(i)=0
              ELSEIF(iqq.EQ.2)THEN
                lvb(j)=0
              ELSEIF(iqq.EQ.3)THEN
                lva(i)=0
                lvb(j)=0
              ENDIF

              IF(nhp.GE.ih)THEN
                DO 17 ih1=ih,nhp
                iqh(ih1)=iqh(ih1+1)
                zh(ih1)=zh(ih1+1)
                iah(ih1)=iah(ih1+1)
17              ibh(ih1)=ibh(ih1+1)
              ENDIF
              GOTO 3
c-------------------------------------------------
c End of removing - event will be simulated from the very beginning
c-------------------------------------------------

            ELSE
              GOTO 6
            ENDIF
          ENDIF
        IF(debug.GE.3)WRITE (moniou,216)ih,wha(ih),whb(ih),wp(i),wm(j)
216     FORMAT(2x,'PSSHARE: ',i3,'-TH SEMIHARD BLOCK; LIGHT',
     *  ' CONE MOMENTA SHARES:',2e10.3/
     *  4x,'REMAINED LIGHT CONE MOMENTA:',2e10.3)

          yh=dlog(sw)
c PSRINT(YH,Z,IQQ) - phi_hard(s_hard) / s_hard ** DELH;
c YH = ln s_hard;
c Z - factor exp(-R_ij/R_p) for the hard block;
c IQQ - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
c Rejection function is multiplied by PSRINT(YH,Z,IQQ) for the ih-th block
          gbh=gbh*psrjint(yh,z,iqq)
          gbh = gbh * xdiv
18        CONTINUE
c End of the loop for rejection function determination
c-------------------------------------------------

c-------------------------------------------------
c Rejection procedure (due to the deviation of the  phi_hard(s_hard)
c dependence from pure powerlike  s_hard ** DELH law)
        IF(debug.GE.2)WRITE (moniou,217)1.d0-gbh,nhp
217     FORMAT(2x,'PSSHARE: REJECTION PROBABILITY:',e10.3,
     *  2x,'NUMBER OF SEMIHARD BLOCKS:',i3)
          IF(qsran(b10).GT.gbh)THEN
            nrej=nrej+1

            IF(nrej.GT.30)THEN
        IF(debug.GE.2)WRITE (moniou,218)
218     FORMAT(2x,'PSSHARE: MORE THAN 30 REJECTIONS - HARD POMERON',
     *  ' NUMBER IS PUT DOWN')
c-------------------------------------------------
c In case of great number of rejections number of hard blocks is put down
c LNH - number of hard blocks to be removed
c-------------------------------------------------
              lnh=1+nhp/20
              DO 19 ihp=nhp-lnh+1,nhp
              iih=iah(ihp)
              jih=ibh(ihp)
              iqq=iqh(ihp)

              IF(iqq.EQ.1)THEN
                lva(iih)=0
              ELSEIF(iqq.EQ.2)THEN
                lvb(jih)=0
              ELSEIF(iqq.EQ.3)THEN
                lva(iih)=0
                lvb(jih)=0
              ENDIF

              lha(iih)=lha(iih)-1
19            lhb(jih)=lhb(jih)-1

              nhp=nhp-lnh
              GOTO 3
c-------------------------------------------------
c End of removing - event will be simulated from the very beginning
c-------------------------------------------------
            ELSE
              GOTO 6
            ENDIF
          ENDIF

***********************************************************************
          DO 31 i=1,nw
31        lha0(i)=lha(i)
          DO 32 i=1,nt
32        lhb0(i)=lhb(i)
***********************************************************************

c-------------------------------------------------
c Particle production for all cut pomerons with hard blocks
c-------------------------------------------------
          DO 20 ih=1,nhp
          iqq=iqh(ih)
          z=zh(ih)
          i=iah(ih)
          j=ibh(ih)
***********************************************************************
          lha0(i)=lha0(i)-1
          lhb0(j)=lhb0(j)-1
***********************************************************************
c WPI, WMI - light cone momenta for current (ih-th) hard pomeron
          wpi=wha(ih)
          wmi=whb(ih)
        IF(debug.GE.2)WRITE (moniou,219)ih,iqq,wpi,wmi,wp(i),wm(j)
219     FORMAT(2x,'PSSHARE: ',i3,
     *  '-TH HARD BLOCK; TYPE OF THE INTERACTION:',i1/
     *  4x,'INITIAL LIGHT CONE MOMENTA:',2e10.3/
     *  4x,'REMAINED LIGHT CONE MOMENTA:',2e10.3)
c-------------------------------------------------
c PSHOT procedure is used for hard partonic interaction -
c initial jets simulation
          CALL pshot(wpi,wmi,z,ipc,epc,izp(i),izt(j),icz,iqq)
          IF(iqq.EQ.1.OR.iqq.EQ.3)THEN
            IF((iabs(izp(i)).GT.5.OR.iabs(izp(i)).EQ.3).AND.
     *      izp(i).GT.0.OR.iabs(izp(i)).NE.3.AND.
     *      iabs(izp(i)).LE.5.AND.izp(i).LT.0)THEN
              jq=1
            ELSE
              jq=2
            ENDIF       
            ila(i)=ipc(jq,1)
            DO 330 l=1,4
330         ela(l,i)=epc(l+4*(jq-1),1)
          ENDIF
          IF(iqq.EQ.2.OR.iqq.EQ.3)THEN
            IF((iabs(izt(j)).GT.5.OR.iabs(izt(j)).EQ.3).AND.
     *      izt(j).GT.0.OR.iabs(izt(j)).NE.3.AND.
     *      iabs(izt(j)).LE.5.AND.izt(j).LT.0)THEN
              jq=1
            ELSE
              jq=2
            ENDIF       
            ilb(j)=ipc(jq,2)
            DO 331 l=1,4
331         elb(l,j)=epc(l+4*(jq-1),2)
          ENDIF
          IF(iqq.EQ.3.AND.ila(i)+ilb(j).EQ.0)nias=j
c-------------------------------------------------
c          SW=WP(I)*WM(J)
c          IF(WP(I).LT.0.D0.OR.WM(J).LT.0.D0.OR.
c     *    SW.LT.(AM(ICZ)+AM(2))**2)THEN
c            NREJ=NREJ+1
c          write (*,*)'i,j,WP(I),WM(J),sw',i,j,WP(I),WM(J),sw
c            GOTO 100
c          ENDIF

c Leading hadronic state fragmentation is treated in the same way as low mass
c diffraction (exhitation mass is determined by secodary reggeon intercept
c dM**2~M**(-3))
          IF(lqa(i)+lha0(i).EQ.0.AND.lqb(j)+lhb0(j).EQ.0)THEN
            IF(lva(i).EQ.0.AND.lvb(j).EQ.0)THEN
              CALL xxddfr(wp(i),wm(j),izp(i),izt(j))
            ELSEIF(lva(i).EQ.0)THEN
              CALL xxdpr(wp(i),wm(j),izp(i),izt(j),1)
              IF(ilb(j).NE.0)THEN
                DO 341 l=1,4
341             ep1(l)=elb(l,j)
                ep(1)=.5d0*wm(j)
                ep(2)=-ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ilb(j)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izt(j),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
            ELSEIF(lvb(j).EQ.0)THEN
              CALL xxdtg(wp(i),wm(j),izp(i),izt(j),1)
              IF(ila(i).NE.0)THEN
                DO 342 l=1,4
342             ep1(l)=ela(l,i)
                ep(1)=.5d0*wp(i)
                ep(2)=ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ila(i)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izp(i),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
            ELSE
              IF(ila(i).NE.0)THEN
                DO 343 l=1,4
343             ep1(l)=ela(l,i)
                ep(1)=.5d0*wp(i)
                ep(2)=ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ila(i)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izp(i),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
              IF(ilb(j).NE.0)THEN
                DO 351 l=1,4
351             ep1(l)=elb(l,j)
                ep(1)=.5d0*wm(j)
                ep(2)=-ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ilb(j)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izt(j),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
            ENDIF
          ELSEIF(lqa(i)+lha0(i).EQ.0)THEN
            IF(lva(i).EQ.0)THEN
              CALL xxdpr(wp(i),wm(j),izp(i),izt(j),lqb(j)+lhb0(j))
            ELSE
              IF(ila(i).NE.0)THEN
                DO 344 l=1,4
344             ep1(l)=ela(l,i)
                ep(1)=.5d0*wp(i)
                ep(2)=ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ila(i)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izp(i),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
            ENDIF
          ELSEIF(lqb(j)+lhb0(j).EQ.0)THEN
            IF(lvb(j).EQ.0)THEN
              CALL xxdtg(wp(i),wm(j),izp(i),izt(j),lqa(i)+lha0(i))
            ELSE
              IF(ilb(j).NE.0)THEN
                DO 345 l=1,4
345             ep1(l)=elb(l,j)
                ep(1)=.5d0*wm(j)
                ep(2)=-ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ilb(j)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izt(j),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
            ENDIF
          ENDIF
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
20        CONTINUE
c-------------------------------------------------
c End of the hard blocks loop
c-------------------------------------------------

        ELSE
c-------------------------------------------------
c Initial light cone momenta initialization in case of no one cut hard block
          DO 21 i=1,nw
21        wp(i)=wp0
          DO 22 i=1,nt
22        wm(i)=wm0
        ENDIF

        IF(ls.NE.0)THEN
c-------------------------------------------------
c The loop for all cut froissarons (blocks of soft pomerons)
c-------------------------------------------------
          DO 28 is=1,ls
c NP=NQS(is) - number of cut pomerons in is-th block;
c IAS(is) (IBS(is)) - number (position in array) of the projectile (target) nucleon,
c connected to is-th block of soft pomerons;
c LQA(i) (LQB(j)) - total number of cut soft pomerons, connected to i-th projectile
c (j-th target) nucleon (hadron);
c WP(i) (WM(j)) - the remainder of the light cone momentum for i-th projectile
c (j-th target) nucleon (hadron);
c NP=NQS(is) - number of cut pomerons in is-th block;
c LQ1, LQ2 define the numbers of the remained cut pomerons  connected
c to given nucleons (hadrons)
          i=ias(is)
          j=ibs(is)
          lq1=lqa(i)
          lq2=lqb(j)
          wpn=wp(i)
          wmn=wm(j)
          np=nqs(is)
      IF(debug.GE.3)WRITE (moniou,222)is,i,j,np
222   FORMAT(2x,'PSSHARE: ',i3,'-TH SOFT POMERON BLOCK IS',
     *      ' CONNECTED TO ',i2,
     *      '-TH PROJECTILE NUCLEON'/4x,'(HADRON) AND ',i2,
     *      '-TH TARGET NUCLEON'/
     *      4x,'NUMBER OF CUT SOFT POMERONS IN THE BLOCK:',i2)
c-------------------------------------------------
c The loop for all cut pomerons in the block
          DO 27 ip=1,np

cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c High mass diffraction - probability WPPP
14        jpp=0
cdh       IF(LQ1.EQ.1.AND.WPN.EQ.WP0.AND.QSRAN(B10).LT.WPPP)THEN
          IF(lq1.EQ.1.AND.wpn.EQ.wp0.AND.qsran(b10).LT.wppp
     *    .AND.lvb(j).EQ.0)THEN    !!!!!!!!!!!!!!!!!!so-07.03.99
c In case of only one cut soft pomeron high mass diffraction is simulated with the
c probability WPPP/2 or triple pomeron contribution - also WPPP/2 to have AGK cancell.
c - only for projectile hadron (nucleons) (for target - neglected)
c YW is the branching point position (in rapidity)
            yw=1.d0+qsran(b10)*(y0-2.d0)
      IF(debug.GE.3)WRITE (moniou,223)yw
223   FORMAT(2x,'PSSHARE: TRIPLE POMERON CONTRIBUTION YW=',e10.3)
c Light cone momentum (E+P_l) for the diffractive state (which is just usual cut
c pomeron)
            xpw=exp(-yw)
            jpp=1
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

          ELSE
            lq1=lq1-1
c Energy-momentum is shared between pomerons according to s**DEL dependence for soft
c pomeron; AHL(ICZ) determines energy spectrum of leading hadronic
c state of type ICZ
            bpi=1.d0/(1.d0+ahl(icz)+(1.d0+del)*lq1)
23          xpw=1.-qsran(b10)**bpi
c Rejection according to XW**DEL
            IF(qsran(b10).GT.xpw**del)GOTO 23
          ENDIF

          lq2=lq2-1
c Energy-momentum is shared between pomerons according to s**DEL dependence for soft
c pomeron - similar to projectile case
          bpi=1.d0/(1.d0+ahl(2)+(1.d0+del)*lq2)
24        xmw=1.-qsran(b10)**bpi
c Rejection according to XW**DEL
          IF(qsran(b10).GT.xmw**del)GOTO 24
c-------------------------------------------------

cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c High mass diffraction is rejected in case of insufficient energy
         IF(jpp.EQ.1.AND.xpw*xmw*wpn*wmn.LT.2.72d0)THEN
            lq2=lq2+1
            GOTO 14
          ENDIF
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

c WPI is the light cone momentum (E+P_l) for the pomeron;
c WPN is the remainder of the light cone momentum for given nucleon (hadron)
          wpi=wpn*xpw
          wpn=wpn-wpi
          wmi=wmn*xmw
          wmn=wmn-wmi

************************************************************************
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
        IF(lq1.EQ.0.AND.lva(i).EQ.0)THEN
          CALL ixxdef(izp(i),ic11,ic12,icz)
        ELSE
          ic11=0
          ic12=0
        ENDIF
        IF(lq2.EQ.0.AND.lvb(j).EQ.0)THEN
          CALL ixxdef(izt(j),ic21,ic22,2)
        ELSE
          ic21=0
          ic22=0
        ENDIF

cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c Fragmentation process for the pomeron ( quarks and antiquarks types at the
c ends of the two strings are determined, energy-momentum is shared
c between them and strings fragmentation is simulated )
      IF(debug.GE.3)WRITE (moniou,224)ip,wpi,wmi
224   FORMAT(2x,'PSSHARE: ',i2,'-TH SOFT POMERON IN THE BLOCK'/
     *      4x,'LIGHT CONE MOMENTA FOR THE POMERON:',2e10.3)
          CALL xxstr(wpi,wmi,wpn,wmn,ic11,ic12,ic22,ic21)
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c Triple pomeron contribution simulation 
          IF(jpp.EQ.1)THEN
            IF(qsran(b10).LT..5d0)THEN
              sw=wpn*wmn
              IF(wpn.LT.0.d0.OR.wmn.LT.0.d0.OR.
     *        sw.LT.(am(icz)+am(2))**2)THEN
cdh
                if (debug.ge.1)
     *            write (*,*)'difr,i,j,WPn,WMn,sw,lq1,lq2',
     *                             i,j,wpn,wmn,sw,lq1,lq2
                nrej=nrej+1
                GOTO 100
              ENDIF
              typevt=3       !high mass diffraction

              IF(lq2.EQ.0)THEN
                CALL xxdtg(wpn,wmn,izp(i),izt(j),0)
              ELSE
                wp1=wpn
                wm1=am(icz)**2/wp1
                ep3(1)=.5d0*(wp1+wm1)
                ep3(2)=.5d0*(wp1-wm1)
                ep3(3)=0.d0
                ep3(4)=0.d0
                CALL xxreg(ep3,izp(i))
                wmn=wmn-wm1
                wpn=0.d0
              ENDIF
              GOTO 30
            ELSE

c Triple pomeron contribution simulation (both pomerons are cut)                
      IF(debug.GE.3)WRITE (moniou,225)
225   FORMAT(2x,'PSSHARE: TRIPLE POMERON CONRITRIBUTION WITH 3 CUT',
     *' POMERONS')
              wmm(1)=1.d0/wpi
              wmn=wmn-wmm(1)
c Light cone momentum (E-P_l) sharing for the two pomerons
              wmm(2)=wmm(1)*qsran(b10)
              wmm(1)=wmm(1)-wmm(2)
              lq1=2
              DO 26 l=1,2
              lq1=lq1-1
c Light cone momentum (E+P_l) sharing for the two pomerons
              bpi=(1.d0+del)*lq1+1.d0+ahl(icz)
              bpi=1.d0/bpi
25            xpw=1.-qsran(b10)**bpi
              IF(qsran(b10).GT.xpw**del)GOTO 25
              wpp(l)=wpn*xpw
              wpn=wpn*(1.d0-xpw)
c Fragmentation process for the pomerons
26            CALL xxstr(wpp(l),wmm(l),wpn,wmn,0,0,0,0)
              sw=wpn*wmn
              IF(wpn.LT.0.d0.OR.wmn.LT.0.d0.OR.
     *        sw.LT.(am(icz)+am(2))**2)THEN
                nrej=nrej+1
                GOTO 100
              ENDIF
            ENDIF
          ENDIF
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
27        CONTINUE
c End of the pomeron loop
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c          SW=WPN*WMN
c          IF(WPN.LT.0.D0.OR.WMN.LT.0.D0.OR.
c     *    SW.LT.(AM(ICZ)+AM(2))**2)THEN
c            NREJ=NREJ+1
c            GOTO 100
c          ENDIF

c Leading hadronic state fragmentation is treated in the same way as low mass
c diffraction (exhitation mass is determined by secodary reggeon intercept
c dM**2~M**(-3))
          IF(lq1.EQ.0.AND.lq2.EQ.0)THEN
            IF(lva(i).EQ.0.AND.lvb(j).EQ.0)THEN
              CALL xxddfr(wpn,wmn,izp(i),izt(j))
            ELSEIF(lva(i).EQ.0)THEN
              CALL xxdpr(wpn,wmn,izp(i),izt(j),1)
              IF(ilb(j).NE.0)THEN
                DO 346 l=1,4
346             ep1(l)=elb(l,j)
                ep(1)=.5d0*wmn
                ep(2)=-ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ilb(j)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izt(j),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
            ELSEIF(lvb(j).EQ.0)THEN
              CALL xxdtg(wpn,wmn,izp(i),izt(j),1)
              IF(ila(i).NE.0)THEN
                DO 347 l=1,4
347             ep1(l)=ela(l,i)
                ep(1)=.5d0*wpn
                ep(2)=ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ila(i)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izp(i),ipj1,ep,ep1,jfl)
               IF(jfl.EQ.0)GOTO 100
              ENDIF
            ELSE
              IF(ila(i).NE.0)THEN
                DO 348 l=1,4
348             ep1(l)=ela(l,i)
                ep(1)=.5d0*wpn
                ep(2)=ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ila(i)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izp(i),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
              IF(ilb(j).NE.0)THEN
                DO 349 l=1,4
349             ep1(l)=elb(l,j)
                ep(1)=.5d0*wmn
                ep(2)=-ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ilb(j)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izt(j),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
            ENDIF
            
          ELSEIF(lq1.EQ.0)THEN
            IF(lva(i).EQ.0)THEN
              CALL xxdpr(wpn,wmn,izp(i),izt(j),lq2)
            ELSE
              IF(ila(i).NE.0)THEN
                DO 350 l=1,4
350             ep1(l)=ela(l,i)
                ep(1)=.5d0*wpn
                ep(2)=ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ila(i)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izp(i),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
            ENDIF
            
          ELSEIF(lq2.EQ.0)THEN
            IF(lvb(j).EQ.0)THEN
              CALL xxdtg(wpn,wmn,izp(i),izt(j),lq1)
            ELSE
              IF(ilb(j).NE.0)THEN
                DO 352 l=1,4
352             ep1(l)=elb(l,j)
                ep(1)=.5d0*wmn
                ep(2)=-ep(1)
                ep(3)=0.d0
                ep(4)=0.d0
                ipj1=ilb(j)
                IF(iabs(ipj1).EQ.3)ipj1=ipj1*4/3
                CALL psjdef(izt(j),ipj1,ep,ep1,jfl)
                IF(jfl.EQ.0)GOTO 100
              ENDIF
            ENDIF
          ENDIF
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
c-------------------------------------------------
c The numbers of the remained cut pomerons connected to given nucleons (hadrons)
c as well as the rest of the longitudinal momenta for these nucleons are
c recorded
30        lqa(i)=lq1
          lqb(j)=lq2
          wp(i)=wpn
28        wm(j)=wmn
        ENDIF
c-------------------------------------------------
c End of the soft blocks loop
c-------------------------------------------------
        IF(ia(1).EQ.1.AND.lva(1).NE.0.AND.ila(1).EQ.0)THEN
          ep(1)=.5d0*wp(1)
          ep(2)=ep(1)
          ep(3)=0.d0
          ep(4)=0.d0
          ep1(1)=.5d0*wm(nias)
          ep1(2)=-ep1(1)
          ep1(3)=0.d0
          ep1(4)=0.d0
          CALL psjdef(izp(1),izt(nias),ep,ep1,jfl)
          IF(jfl.EQ.0)GOTO 100
        ENDIF
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
        CALL xxjetsim
************************************************************************
      IF(debug.GE.3)WRITE (moniou,227)
227   FORMAT(2x,'PSSHARE - END')
        RETURN
        END
C=======================================================================

      SUBROUTINE pstrans(EP,EY)
c Lorentz transform according to parameters EY ( determining Lorentz shift
c along the Z,X,Y-axis respectively (EY(1),EY(2),EY(3)))
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ey(3),ep(4)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)ep,ey
201     FORMAT(2x,'PSTRANS - LORENTZ BOOST FOR 4-VECTOR'/4x,'EP=',
     *  2x,4(e10.3,1x)/4x,'BOOST PARAMETERS EY=',3e10.3)
c Lorentz transform to lab. system according to 1/EY(i) parameters
        DO 1 i=1,3
        IF(ey(4-i).NE.1.d0)THEN
          wp=(ep(1)+ep(5-i))/ey(4-i)
          wm=(ep(1)-ep(5-i))*ey(4-i)
          ep(1)=.5d0*(wp+wm)
          ep(5-i)=.5d0*(wp-wm)
        ENDIF
1       CONTINUE
        IF(debug.GE.3)WRITE (moniou,202)ep
202     FORMAT(2x,'PSTRANS: TRANSFORMED 4-VECTOR EP=',
     *  2x,4(e10.3,1x))
        RETURN
        END
C=======================================================================

      SUBROUTINE pstrans1(EP,EY)
c Lorentz transform according to parameters EY ( determining Lorentz shift
c along the Z,X,Y-axis respectively (EY(1),EY(2),EY(3)))
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ey(3),ep(4)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)ep,ey
201     FORMAT(2x,'PSTRANS1 - LORENTZ BOOST FOR 4-VECTOR'/4x,'EP=',
     *  2x,4(e10.3,1x)/4x,'BOOST PARAMETERS EY=',3e10.3)
c Lorentz transform to lab. system according to 1/EY(i) parameters
          DO 2 i=1,3
          IF(ey(i).NE.1.d0)THEN
            wp=(ep(1)+ep(i+1))*ey(i)
            wm=(ep(1)-ep(i+1))/ey(i)
            ep(1)=.5d0*(wp+wm)
            ep(i+1)=.5d0*(wp-wm)
          ENDIF
2         CONTINUE
        IF(debug.GE.3)WRITE (moniou,202)ep
202     FORMAT(2x,'PSTRANS1: TRANSFORMED 4-VECTOR EP=',
     *  2x,4(e10.3,1x))
        RETURN
        END
C=======================================================================

        FUNCTION psudint(QLMAX,J)
c PSUDINT - timelike Sudakov formfactor interpolation
c QLMAX - ln QMAX/16/QTF,
c J - type of the parton (0-g,1-q)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension wk(3)
        COMMON /area33/ fsud(10,2)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)j,qlmax
201     FORMAT(2x,'PSUDINT - SPACELIKE FORM FACTOR INTERPOLATION:'/
     *  4x,'PARTON TYPE J=',
     *  i1,2x,'MOMENTUM LOGARITHM QLMAX=',e10.3)
        ql=qlmax/1.38629d0

        IF(ql.LE.0.d0)THEN
          psudint=1.d0
        ELSE
          k=int(ql)
          IF(k.GT.7)k=7
          wk(2)=ql-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)

          psudint=0.d0
          DO 1 k1=1,3
1         psudint=psudint+fsud(k+k1,j)*wk(k1)
          IF(psudint.LE.0.d0)psudint=0.d0
          psudint=exp(-psudint)
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psudint
202     FORMAT(2x,'PSUDINT=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psuds(Q,J)
c PSUDS - spacelike Sudakov formfactor
c Q - maximal value of the effective momentum,
c J - type of parton (0 - g, 1 - q)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area6/  pi,bm,am
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)j,q
201     FORMAT(2x,'PSUDS - SPACELIKE FORM FACTOR: PARTON TYPE J=',
     *  i1,2x,'MOMENTUM Q=',e10.3)
        IF(q.GT.qt0)THEN
          qlm=dlog(q/alm)
          psuds=(qlm*dlog(qlm/qlog)-dlog(q/qt0))/9.d0

          IF(j.EQ.0)THEN
            psuds=psuds*6.d0
          ELSE
            psuds=psuds/.375d0
          ENDIF
          psuds=exp(-psuds)

        ELSE
          psuds=1.d0
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)psuds
202     FORMAT(2x,'PSUDS=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psudt(QMAX,J)
c PSUDT - timelike Sudakov formfactor
c QMAX - maximal value of the effective momentum,
c J - type of parton (0 - g, 1 - q)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        common/ar3/x1(7),a1(7)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)j,qmax
201     FORMAT(2x,'PSUDT - TIMELIKE FORM FACTOR: PARTON TYPE J=',
     *  i1,2x,'MOMENTUM QMAX=',e10.3)
        psudt=0.d0
        qlmax=dlog(dlog(qmax/16.d0/alm))
        qfl=dlog(dlog(qtf/alm))

c Numerical integration over transverse momentum square;
c Gaussian integration is used
          DO 1 i=1,7
          DO 1 m=1,2
          qtl=.5d0*(qlmax+qfl+(2*m-3)*x1(i)*(qlmax-qfl))
          qt=alm*exp(exp(qtl))
          IF(qt.GE.qmax/16.d0)qt=qmax/16.0001d0
          zmin=.5d0-dsqrt((.25d0-dsqrt(qt/qmax)))
          zmax=1.d0-zmin
          IF(j.EQ.0)THEN
******************************************************
            ap=(psapint(zmax,0,0)-psapint(zmin,0,0)+
     *      psapint(zmax,0,1)-psapint(zmin,0,1))*.5d0
******************************************************
          ELSE
            ap=psapint(zmax,1,0)-psapint(zmin,1,0)
          ENDIF
1         psudt=psudt+a1(i)*ap
          psudt=psudt*(qlmax-qfl)/9.d0
        IF(debug.GE.3)WRITE (moniou,202)psudt
202     FORMAT(2x,'PSUDT=',e10.3)
        RETURN
        END
C=======================================================================

        FUNCTION psv(X,Y,XB,IB)
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
cdh     DIMENSION XB(56,3),FHARD(3)
        dimension xb(64,3),fhard(3)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)x,y,ib
201     FORMAT(2x,'PSV - EIKONAL FACTOR: NUCLEON COORDINATES X=',
     *  e10.3,2x,'Y=',e10.3/4x,'NUMBER OF ACTIVE TARGET NUCLEONS IB='
     *  ,i2)
        dv=0.d0
c????????????????????????????????????????????
        DO 1 m=1,ib
        z=psdr(x-xb(m,1),y-xb(m,2))
        dv=dv+psfaz(z,fsoft,fhard,fshard)+fhard(1)+fhard(2)+fhard(3)
1       CONTINUE
        psv=(1.d0-exp(-dv))**2

C       DH=1.D0
C       DO 1 M=1,IB
C       Z=PSDR(X-XB(M,1),Y-XB(M,2))
C       DV=DV+PSFAZ(Z,FSOFT,FHARD,FSHARD)
C 1     DH=DH*(1.D0-FHARD(1)-FHARD(2)-FHARD(3))
c????????????????????????????????????????????????
        IF(debug.GE.3)WRITE (moniou,202)psv
202     FORMAT(2x,'PSV=',e10.3)
        RETURN
        END
C=======================================================================

        SUBROUTINE psvdef(ICH,IC1,ICZ)
c Determination of valence quark flavour -
c for valence quark hard scattering
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area11/ b10
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)ich,icz
201     FORMAT(2x,'PSVDEF: HADRON TYPE ICH=',i2,' AUXILLIARY TYPE ICZ='
     *  ,i1)
     
        is=iabs(ich)/ich
        IF(icz.EQ.1)THEN
          ic1=ich*(1-3*int(.5+qsran(b10)))
          ich=-ic1-ich
        ELSEIF(icz.EQ.2)THEN
          IF(qsran(b10).GT..33333d0.OR.ich.LT.0)THEN
            ic1=ich-is
            ich=3*is
          ELSE
            ic1=4*is-ich
            ich=ich+4*is
          ENDIF
        ELSEIF(icz.EQ.3)THEN
          ic1=ich-3*is
          ich=-4*is
        ELSEIF(icz.EQ.4)THEN
          ic1=ich-9*is
          ich=5*is
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)ic1,ich
202     FORMAT(2x,'PSVDEF-END: QUARK FLAVOR IC1=',i2,
     *  'DIQUARK TYPE ICH=',i2)
        RETURN
        END
C=======================================================================

        FUNCTION pszsim(QQ,J)
c PSZSIM - light cone momentum share simulation (for the timelike
c branching)
c QQ - effective momentum value,
c J - type of the parent parton (0-g,1-q)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area11/ b10
        COMMON /area18/ alm,qt0,qlog,qll,aqt0,qtf,bet,amj0
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran


        IF(debug.GE.2)WRITE (moniou,201)qq,j
201     FORMAT(2x,'PSZSIM - Z-SHARE SIMULATION: QQ=',e10.3,2x,'J=',i1)
        zmin=.5d0-dsqrt(.25d0-dsqrt(qtf/qq))
        qlf=dlog(qtf/alm)

1       CONTINUE
        IF(j.EQ.1)THEN
          pszsim=.5d0*(2.d0*zmin)**qsran(b10)
******************************************************
          gb=pszsim*(psfap(pszsim,0,0)+psfap(pszsim,0,1))/7.5d0
******************************************************
        ELSE
          pszsim=zmin*((1.d0-zmin)/zmin)**qsran(b10)
          gb=pszsim*psfap(pszsim,1,0)*.375d0
        ENDIF
        qt=qq*(pszsim*(1.d0-pszsim))**2
        gb=gb/dlog(qt/alm)*qlf
        IF(debug.GE.3)WRITE (moniou,203)qt,gb
203     FORMAT(2x,'PSZSIM: QT=',e10.3,2x,'GB=',e10.3)
        IF(qsran(b10).GT.gb)GOTO 1
        IF(debug.GE.3)WRITE (moniou,202)pszsim
202     FORMAT(2x,'PSZSIM=',e10.3)
        RETURN
        END
C=======================================================================

        SUBROUTINE ixxdef(ICH,IC1,IC2,ICZ)
c Determination of parton flavours in forward and backward direction -
c for valence quark hard scattering
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area11/ b10
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)ich,icz
201     FORMAT(2x,'IXXDEF: HADRON TYPE ICH=',i2,' AUXILLIARY TYPE ICZ='
     *  ,i1)
        is=iabs(ich)/ich
        IF(icz.EQ.1)THEN
          ic1=ich*(1-3*int(.5+qsran(b10)))
          ich1=ich*int(.5d0+qsran(b10))
          ic2=-ic1*iabs(ich1)-(ich+ic1)*iabs(ich-ich1)

        ELSEIF(icz.EQ.2)THEN
c Valence quark type simulation ( for the proton )
          ic1=int(1.3333+qsran(b10))
c Leading nucleon type simulation ( flavors combinatorics )
          ich1=(2-ic1)*int(qsran(b10)+.5)+2
c The type of the parton at the end of the rest string ( after the
c leading nucleon ejection )
          ic2=(3-ich1)*(2-ic1)-2

          IF(iabs(ich).EQ.3)THEN
            ic1=3-ic1
            ic2=-3-ic2
            ich1=5-ich1
          ENDIF
          IF(ich.LT.0)THEN
            ic1=-ic1
            ic2=-ic2
            ich1=-ich1
          ENDIF

        ELSEIF(icz.EQ.3)THEN
          ic1=ich-3*is
          ic2=-is*int(1.5+qsran(b10))
          ich1=3*is-ic2
        ELSEIF(icz.EQ.4)THEN
          ic1=ich-9*is
          ic2=is*int(1.5+qsran(b10))
          ich1=9*is-ic2
        ELSEIF(icz.EQ.5)THEN
          ic1=is*int(1.5+qsran(b10))
          ic2=-ic1
          ich1=ich
        ENDIF

        ich=ich1
        IF(debug.GE.3)WRITE (moniou,202)ic1,ic2,ich
202     FORMAT(2x,'IXXDEF-END: PARTON FLAVORS IC1=',i2,' IC2=',i2,
     *  'NEW HADRON TYPE ICH=',i2)
        RETURN
        END
C=======================================================================

      FUNCTION ixxson(NS,AW,G)
c Poisson distribution:
c AW - average value,
c NS-1 - maximal allowed value,
c G - random number
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)ns-1,aw,g
201     FORMAT(2x,'IXXSON - POISSON DITR.: AVERAGE AW=',e10.3,
     *  ' MAXIMAL VALUE NS=',i2,' RANDOM NUMBER G=',e10.3)
      w=exp(-aw)
        summ=w
        DO 1 i=1,ns
        j = i
        IF(g.LT.summ)GOTO 2
        w=w*aw/i
1       summ=summ+w
2       ixxson=j-1
        IF(debug.GE.3)WRITE (moniou,202)ixxson
202     FORMAT(2x,'IXXSON=',i2)
        RETURN
        END
C=======================================================================

      SUBROUTINE xxaini(E0N,ICP0,IAP,IAT)
c Additional initialization procedure
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
******************************************************
      dimension wk(3),wa(3)
******************************************************
      COMMON /area1/  ia(2),icz,icp
      COMMON /area2/  s,y0,wp0,wm0
      COMMON /area4/  ey0(3)
      COMMON /area5/  rd(2),cr1(2),cr2(2),cr3(2)
      COMMON /area6/  pi,bm,am
      COMMON /area7/  rp1
      COMMON /area10/ stmass,am0,amn,amk,amc,amlamc,amlam,ameta
      COMMON /area15/ fp(5),rq(5),cd(5)
      COMMON /area17/ del,rs,rs0,fs,alfp,rr,sh,delh
      COMMON /area22/ sjv,fjs(5,3)
      COMMON /area35/  sjv0(10,5),fjs0(10,5,15)
      COMMON /area43/ moniou
******************************************************
      COMMON /area44/ gz(10,5,4),gzp(10,5,4)
      COMMON /area45/ gdt,gdp   !so00
******************************************************
      COMMON /debug/  debug
      SAVE

        IF(debug.GE.1)WRITE (moniou,201)icp0,iap,iat,e0n
201     FORMAT(2x,'XXAINI - MINIINITIALIZATION: PARTICLE TYPE ICP0=',
     *  i1,2x,'PROJECTILE MASS NUMBER IAP=',i2/4x,
     *  'TARGET MASS NUMBER IAT=',i2,' INTERACTION ENERGY E0N=',e10.3)
      icp=icp0
      ia(1)=iap
      ia(2)=iat
c ICZ - auxiliary type for the primary particle (1- pion, 2 - nucleon, 3 - kaon,
c 4 - D-meson, 5 - Lambda_C)
      IF(iabs(icp).LT.6)THEN
        icz=iabs(icp)/2+1
      ELSE
        icz=(iabs(icp)+1)/2
      ENDIF

c Energy dependent factors:
c WP0, WM0 - initial light cone momenta for the interaction (E+-p)
      s=2.d0*e0n*amn
      wp0=dsqrt(s)
      wm0=wp0
c Y0 - total rapidity range for the interaction
      y0=dlog(s)
c RS - soft pomeron elastic scattering slope (lambda_ab)
      rs=rq(icz)+alfp*y0
c RS0 - initial slope (sum of the pomeron-hadron vertices slopes squared - R_ab)
      rs0=rq(icz)
c FS - factor for pomeron eikonal calculation (gamma_ab * s**del /lambda_ab * C_ab
      fs=fp(icz)*exp(y0*del)/rs*cd(icz)
c RP1 - factor for the impact parameter dependence of the eikonal ( in fm^2 )
      rp1=rs*4.d0*.0391d0/am**2

      ey0(2)=1.d0
      ey0(3)=1.d0
      ey0(1)=dsqrt(amn/e0n/2.d0)

c-------------------------------------------------
c Nuclear radii and weights for nuclear configurations simulation - procedure GEA
      DO 1 i=1,2
c RD(I) - Wood-Saxon density radius (fit to the data of Murthy et al.)
      rd(i)=0.7d0*float(ia(i))**.446/am
      cr1(i)=1.d0+3.d0/rd(i)+6.d0/rd(i)**2+6.d0/rd(i)**3
      cr2(i)=3.d0/rd(i)
      cr3(i)=3.d0/rd(i)+6.d0/rd(i)**2
      IF(ia(i).LT.10.AND.ia(i).NE.1)THEN
c RD(I) - gaussian density radius (for light nucleus)
        rd(i)=.9d0*float(ia(i))**.3333/am
        IF(ia(i).EQ.2)rd(i)=3.16d0
c RD -> RD * A / (A-1) - to use Van Hove simulation method - procedure GEA
        rd(i)=rd(i)*dsqrt(2.d0*ia(i)/(ia(i)-1.))
      ENDIF
1     CONTINUE

      gdt=0.d0
c-------------------------------------------------
c Impact parameter cutoff setting
c-------------------------------------------------
      IF(ia(1).NE.1)THEN
c Primary nucleus:
c Impact parameter cutoff value ( only impact parameters less than BM are
c simulated; probability to have larger impact parameter is less than 1% )
        bm=rd(1)+rd(2)+5.d0
      ELSE
c Hadron-nucleus interaction
c BM - impact parameter cutoff value
        bm=rd(2)+5.d0
      ENDIF

      ye=dlog10(e0n)
      IF(ye.LT.1.d0)ye=1.d0
      je=int(ye)
      IF(je.GT.8)je=8

******************************************************
      wk(2)=ye-je
      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)

      sjv=sjv0(je,icz)*wk(1)+sjv0(je+1,icz)*wk(2)+sjv0(je+2,icz)*wk(3)

      DO 2 i=1,5
      DO 2 m=1,3
      m1=m+3*(icz-1)
2     fjs(i,m)=fjs0(je,i,m1)*wk(1)+fjs0(je+1,i,m1)*wk(2)+
     *fjs0(je+2,i,m1)*wk(3)

      gdt=0.d0
      gdp=0.d0  !so00
      IF(ia(1).EQ.1)THEN
        ya=ia(2)
        ya=dlog(ya)/1.38629d0+1.d0
        ja=min(int(ya),2)
        wa(2)=ya-ja
        wa(3)=wa(2)*(wa(2)-1.d0)*.5d0
        wa(1)=1.d0-wa(2)+wa(3)
        wa(2)=wa(2)-2.d0*wa(3)
        DO 3 i=1,3
        DO 3 m=1,3
        gdp=gdp+gzp(je+i-1,icz,ja+m-1)*wk(i)*wa(m)  !so00
3       gdt=gdt+gz(je+i-1,icz,ja+m-1)*wk(i)*wa(m)
      ENDIF
c        write (*,*)'gdt=',gdt
******************************************************

        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXAINI - END')
      RETURN
      END
C=======================================================================

      SUBROUTINE xxaset
c Particular model parameters setting
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
      CHARACTER *2 TYQ
      COMMON /area3/  rmin,emax,eev
      COMMON /area6/  pi,bm,am
      COMMON /area8/  wwm,be(4),dc(5),deta,almpt
      COMMON /area10/ stmass,am0,amn,amk,amc,amlamc,amlam,ameta
      COMMON /area11/ b10
      COMMON /area20/ wppp
      COMMON /area21/ dmmin(5)
      COMMON /area28/ arr(4)
      COMMON /area40/ jdifr
      COMMON /area42/ tyq(15)
      COMMON /area43/ moniou
      COMMON /debug/  debug
      SAVE

        IF(debug.GE.1)WRITE (moniou,201)
201     FORMAT(2x,'XXASET - HADRONIZATION PARAMETERS SETTING')
c Regge intercepts for the uu~, qqq~q~, us~, uc~ trajectories
      arr(1)=0.5d0
      arr(2)=-.5d0
      arr(3)=0.d0
      arr(4)=-2.d0
c WPPP - Triple pomeron interaction probability (for two cut pomerons and cut
c between them)
      wppp=0.4d0
c JDIFR - flag for the low mass diffraction (for JDIFR=0 not considered)
      jdifr=1   

c-------------------------------------------------
c Parameters for the soft fragmentation:
c DC(i) - relative probabilities for udu~d~(i=1), ss~(i=2), cc~(i=3)-pairs creation
c from the vacuum for the quark (u,d,u~,d~) fragmentation;
c ss~(i=4), cc~(i=5) - for the diquark (ud, u~d~) fragmentation
      dc(1)=.06d0
      dc(2)=.10d0
*     DC(3)=.0003D0     ! To switch off charmed particles set to 0.000
      dc(3)=.000d0
      dc(4)=.36d0
*     DC(5)=.01D0     ! To switch off charmed particles set to 0.000
      dc(5)=.0d0
cc  DETA - ratio of etas production density to all pions production density (1/9)
      deta=.11111d0
c WWM defines mass threshold for string to decay into three or more hadrons
c ( ajustable parameter for string fragmentation )
      wwm=.53d0
c BE(i) - parameter for Pt distribution (exponential) for uu~(dd~), ss~, qqq~q~,
c cc~ pairs respectively (for the soft fragmentation)
      be(1)=.22d0
      be(2)=.35d0
      be(3)=.29d0
      be(4)=.40d0
c ALMPT - parameter for the fragmentation functions (soft ones):
c ALMPT = 1 + 2 * alfa_R * <pt**2> (Kaidalov proposed 0.5 value for ALMPT-1,
c Sov.J.Nucl.Phys.,1987))
      almpt=1.7d0

c-------------------------------------------------
c Parameters for nuclear spectator part fragmentation:
c RMIN - coupling radius squared (fm^2),
c EMAX - relative critical energy ( divided per mean excitation energy (~12.5 Mev)),
c EEV - relative evaporation energy ( divided per mean excitation energy (~12.5 Mev))
      rmin=3.35d0
      emax=.11d0
      eev=.25d0

c-------------------------------------------------
c DMMIN(i) - minimal diffractive mass for low-mass diffraction for pion, nucleon,
c kaon, D-meson, Lambda_C corresp.
      dmmin(1)=.76d0
      dmmin(2)=1.24d0
      dmmin(3)=.89d0
      dmmin(4)=2.01d0
      dmmin(5)=2.45d0
c Proton, kaon, pion, D-meson, Lambda, Lambda_C, eta masses
      amn=.939d0
      amk=.496d0
      am0=.14d0
      amc=1.868d0
      amlam=1.116d0
      amlamc=2.27d0
      ameta=.548d0

c-------------------------------------------------
c B10 - initial value of the pseudorandom number,
c PI  - pi-number
c AM  - diffusive radius for the Saxon-Wood nuclear density parametrization
      b10=.43876194d0
      pi=3.1416d0
      am=.523d0

C STMASS - minimal string mass to produce secondary particles
      stmass=4.d0*am0**2
c Here and below all radii, distances and so on are divided by AM.
      rmin=rmin/am**2

      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.3)WRITE (moniou,202)
202     FORMAT(2x,'XXASET - END')
      RETURN
      END
C=======================================================================

        SUBROUTINE xxddfr(WP0,WM0,ICP,ICT)
c Double diffractive dissociation
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep3(4),ep1(4),ep2(4),ey(3)
        COMMON /area1/  ia(2),icz,icp0
        COMMON /area2/  s,y0,wp00,wm00
        COMMON /area8/  wwm,be(4),dc(5),deta,almpt
        COMMON /area10/ stmass,am(7)
        COMMON /area11/ b10
        COMMON /area21/ dmmin(5)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)icp,ict,wp0,wm0
201     FORMAT(2x,'XXDDFR - LEADING CLUSTERS HADRONIZATION:'
     *  /4x,'CLUSTER TYPES ICP=',i2,2x,
     *  'ICT=',i2/4x,'AVAILABLE LIGHT CONE MOMENTA: WP0=',e10.3,
     *  ' WM0=',e10.3)
        DO 100 i=1,3
100     ey(i)=1.d0

        sd0=wp0*wm0
        IF(sd0.LT.0.d0)sd0=0.d0
        ddmin1=dmmin(icz)
        ddmin2=dmmin(2)
        ddmax1=min(5.d0,dsqrt(sd0)-ddmin2)

        IF(ddmax1.LT.ddmin1)THEN
c Registration of too slow "leading" hadron if its energy is insufficient for
c diffractive exhitation
          IF(dsqrt(sd0).LT.am(icz)+am(2))THEN
            IF(wp0.GT.0.d0.AND.(am(icz)+am(2))**2/wp0.LT..5d0*wm00)THEN
              sd0=(am(icz)+am(2))**2
              wm0=sd0/wp0
            ELSE
        IF(debug.GE.3)WRITE (moniou,202)
              RETURN
            ENDIF
          ENDIF

          ep3(3)=0.d0
          ep3(4)=0.d0
          xw=xxtwdec(sd0,am(icz)**2,am(2)**2)
          wp1=xw*wp0
          wm1=am(icz)**2/wp1
          ep3(1)=.5d0*(wp1+wm1)
          ep3(2)=.5d0*(wp1-wm1)
          CALL xxreg(ep3,icp)
          wm2=wm0-wm1
          wp2=am(2)**2/wm2
          ep3(1)=.5d0*(wp2+wm2)
          ep3(2)=.5d0*(wp2-wm2)
          CALL xxreg(ep3,ict)
          wp0=0.d0
          wm0=0.d0
        IF(debug.GE.3)WRITE (moniou,202)
          RETURN
        ENDIF

        dmass1=(ddmin1/(1.d0-qsran(b10)*(1.d0-ddmin1/ddmax1)))**2
        ddmax2=min(5.d0,dsqrt(sd0)-dsqrt(dmass1))
        dmass2=(ddmin2/(1.d0-qsran(b10)*(1.d0-ddmin2/ddmax2)))**2

        wpd1=wp0*xxtwdec(sd0,dmass1,dmass2)
        wmd1=dmass1/wpd1
        wmd2=wm0-wmd1
        wpd2=dmass2/wmd2

        IF(icp.NE.0)is=iabs(icp)/icp
        IF(icz.EQ.5)THEN
          ich1=icp
          ich2=0
          amh1=am(5)**2
          amh2=am(1)**2

          ptmax=pslam(dmass1,amh1,amh2)
          IF(ptmax.LT.0.)ptmax=0.
          IF(ptmax.LT.be(4)**2)THEN
1           pti=ptmax*qsran(b10)
            IF(qsran(b10).GT.exp(-dsqrt(pti)/be(4)))GOTO 1
          ELSE
2           pti=(be(4)*dlog(qsran(b10)*qsran(b10)))**2
            IF(pti.GT.ptmax)GOTO 2
          ENDIF
          amt1=amh1+pti
          amt2=amh2+pti
          z=xxtwdec(dmass1,amt1,amt2)
          wp1=wpd1*z
          wm1=amt1/wp1
          ep3(1)=.5d0*(wp1+wm1)
          ep3(2)=.5d0*(wp1-wm1)
          pt=dsqrt(pti)
          CALL pscs(c,s)
          ep3(3)=pt*c
          ep3(4)=pt*s
          CALL xxreg(ep3,ich1)

          wp1=wpd1*(1.d0-z)
          wm1=amt2/wp1
          ep3(1)=.5d0*(wp1+wm1)
          ep3(2)=.5d0*(wp1-wm1)
          ep3(3)=-pt*c
          ep3(4)=-pt*s
          CALL xxreg(ep3,ich2)
          GOTO 3
        ENDIF

        IF(icz.EQ.1)THEN
          IF(icp.NE.0)THEN
            ic1=icp*(1-3*int(.5d0+qsran(b10)))
            ic2=-icp-ic1
          ELSE
            ic1=int(1.5d0+qsran(b10))*(2*int(.5d0+qsran(b10))-1)
            ic2=-ic1
          ENDIF
        ELSEIF(icz.EQ.2)THEN
          IF(qsran(b10).GT..33333d0)THEN
            ic1=3*is
            ic2=icp-is
          ELSE
            ic1=icp+4*is
            ic2=4*is-icp
          ENDIF
        ELSEIF(icz.EQ.3)THEN
          ic1=-4*is
          ic2=icp-3*is
        ELSEIF(icz.EQ.4)THEN
          ic1=5*is
          ic2=icp-9*is
        ENDIF
        CALL xxgener(wpd1,wmd1,ey,0.d0,1.d0,0.d0,1.d0,ic1,ic2)

3       CONTINUE
        is=iabs(ict)/ict
        IF(qsran(b10).GT..33333d0)THEN
          ic1=3*is
          ic2=ict-is
        ELSE
          ic1=ict+4*is
          ic2=4*is-ict
        ENDIF
        CALL xxgener(wpd2,wmd2,ey,0.d0,1.d0,0.d0,1.d0,ic2,ic1)
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXDDFR - END')
        RETURN
        END
C=======================================================================

        SUBROUTINE xxdec2(EP,EP1,EP2,WW,A,B)
c Two particle decay
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep(4),ep1(4),ep2(4),ey(3)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        COMMON /area11/ b10
        SAVE
        EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)
201     FORMAT(2x,'XXDEC2 - TWO PARTICLE DECAY')

        pl=pslam(ww,a,b)
        ep1(1)=dsqrt(pl+a)
        ep2(1)=dsqrt(pl+b)
        pl=dsqrt(pl)
        cosz=2.d0*qsran(b10)-1.d0
        pt=pl*dsqrt(1.d0-cosz**2)
        ep1(2)=pl*cosz
        CALL pscs(c,s)
        ep1(3)=pt*c
        ep1(4)=pt*s
        do 1 i=2,4
1       ep2(i)=-ep1(i)
        CALL psdeftr(ww,ep,ey)
        CALL pstrans(ep1,ey)
        CALL pstrans(ep2,ey)
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXDEC2 - END')
        RETURN
        END
C=======================================================================

        SUBROUTINE xxdec3(EP,EP1,EP2,EP3,SWW,AM1,AM2,AM3)

c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep(4),ep1(4),ep2(4),ep3(4),ept(4),ey(3)
        common/area11/b10
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)
201     FORMAT(2x,'XXDEC3 - THREE PARTICLE DECAY')
        am12=am1**2
        am23=(am2+am3)**2
        am32=(am2-am3)**2
        s23max=(sww-am1)**2
        emax=.25d0*(sww+(am12-am23)/sww)**2
        gb0=dsqrt((emax-am12)/emax*(1.d0-am23/s23max)
     *  *(1.d0-am32/s23max))
1       p1=qsran(b10)*(emax-am12)
        e1=dsqrt(p1+am12)
        s23=sww**2+am12-2.d0*e1*sww
        gb=dsqrt(p1*(1.d0-am23/s23)*(1.d0-am32/s23))/e1/gb0
        IF(qsran(b10).GT.gb)GOTO 1

        p1=dsqrt(p1)
        ep1(1)=e1
        cosz=2.d0*qsran(b10)-1.d0
        pt=p1*dsqrt(1.d0-cosz**2)
        ep1(2)=p1*cosz
        CALL pscs(c,s)
        ep1(3)=pt*c
        ep1(4)=pt*s
        do 2 i=2,4
2       ept(i)=-ep1(i)
        ept(1)=sww-ep1(1)
        CALL psdeftr(sww**2,ep,ey)
        CALL pstrans(ep1,ey)
        CALL pstrans(ept,ey)

        CALL xxdec2(ept,ep2,ep3,s23,am2**2,am3**2)
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXDEC3 - END')
        RETURN
        END
C=======================================================================

        SUBROUTINE xxdpr(WP0,WM0,ICP,ICT,LQ2)
c Projectile hadron dissociation
c Leading hadronic state hadronization
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep3(4),ep1(4),ep2(4),ey(3)
        COMMON /area1/  ia(2),icz,icp0
        COMMON /area2/  s,y0,wp00,wm00
        COMMON /area8/  wwm,be(4),dc(5),deta,almpt
        COMMON /area10/ stmass,am(7)
        COMMON /area11/ b10
        COMMON /area17/ del,rs,rs0,fs,alfp,rr,sh,delh
        COMMON /area21/ dmmin(5)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran


        IF(debug.GE.2)WRITE (moniou,201)icp,ict,wp0,wm0
201     FORMAT(2x,'XXDPR - LEADING (PROJECTILE) CLUSTER HADRONIZATION:'
     *  /4x,'CLUSTER TYPE ICP=',i2,2x,'TARGET TYPE ',
     *  'ICT=',i2/4x,'AVAILABLE LIGHT CONE MOMENTA: WP0=',e10.3,
     *  ' WM0=',e10.3)
        DO 100 i=1,3
100     ey(i)=1.d0

        sd0=wp0*wm0
        IF(sd0.LT.0.d0)sd0=0.d0
        ddmax=min(5.d0,dsqrt(sd0)-am(2))
        ddmin=dmmin(icz)

        IF(ddmax.LT.ddmin)THEN
c Registration of too slow "leading" hadron if its energy is insufficient for
c diffractive exhitation
          ep3(3)=0.d0
          ep3(4)=0.d0

          IF(lq2.NE.0)THEN
            wpi=wp0
            IF(am(icz)**2.GT.wpi*wm0)THEN
              IF(wpi.GT.0.d0.AND.am(icz)**2/wpi.LT..5d0*wm00)THEN
                wmi=am(icz)**2/wpi
                wm0=wmi
              ELSE
                RETURN
              ENDIF
cdh 2 lines added  in accordance with s. ostapchenko 17.9.99
            ELSE
              wmi=am(icz)**2/wpi
cdh
            ENDIF
            wm0=wm0-wmi
            wp0=0.d0
            ep3(1)=.5d0*(wpi+wmi)
            ep3(2)=.5d0*(wpi-wmi)
            CALL xxreg(ep3,icp)
        IF(debug.GE.3)WRITE (moniou,202)
            RETURN
          ELSE

            IF(dsqrt(sd0).LT.am(icz)+am(2))THEN
              IF(wp0.GT.0.d0.AND.(am(icz)+am(2))**2/wp0.LT..5d0*wm00)
     *        THEN
                sd0=(am(icz)+am(2))**2
                wm0=sd0/wp0
              ELSE
        IF(debug.GE.3)WRITE (moniou,202)
                RETURN
              ENDIF
            ENDIF
            xw=xxtwdec(sd0,am(icz)**2,am(2)**2)
            wp1=xw*wp0
            wm1=am(icz)**2/wp1
            ep3(1)=.5d0*(wp1+wm1)
            ep3(2)=.5d0*(wp1-wm1)
            CALL xxreg(ep3,icp)
            wm2=wm0-wm1
            wp2=am(2)**2/wm2
            ep3(1)=.5d0*(wp2+wm2)
            ep3(2)=.5d0*(wp2-wm2)
            CALL xxreg(ep3,ict)
            wp0=0.d0
            wm0=0.d0
          ENDIF
        IF(debug.GE.3)WRITE (moniou,202)
          RETURN
        ENDIF

        IF(icp.NE.0)is=iabs(icp)/icp

        dmass=ddmin**2/(1.d0-qsran(b10)*(1.d0-(ddmin/ddmax)))**2

        IF(lq2.NE.0)THEN
          wpd=wp0
          wmd=dmass/wpd
          wm0=wm0-wmd
          wp0=0.d0
        ELSE
        IF(icz.EQ.5)THEN
          wpd=wp0*xxtwdec(sd0,dmass,am(2)**2)
          wmd=dmass/wpd
          wm2=wm0-wmd
          wp2=am(2)**2/wm2
          ep3(1)=.5d0*(wp2+wm2)
          ep3(2)=.5d0*(wp2-wm2)
          ep3(3)=0.d0
          ep3(4)=0.d0
          CALL xxreg(ep3,ict)
        ELSE
          ptmax=pslam(sd0,dmass,am(2)**2)
          IF(ptmax.LT.0.)ptmax=0.
          pti=-1.d0/rs*dlog(1.d0-qsran(b10)*(1.d0-exp(-rs*ptmax)))

          amt1=dmass+pti
          amt2=am(2)**2+pti
          wpd=wp0*xxtwdec(sd0,amt1,amt2)
          wmd=amt1/wpd
          wm2=wm0-wmd
          wp2=amt2/wm2
          pt=dsqrt(pti)
          CALL pscs(ccos,ssin)
          ep3(3)=pt*ccos
          ep3(4)=pt*ssin
          ep3(1)=.5d0*(wp2+wm2)
          ep3(2)=.5d0*(wp2-wm2)
          CALL xxreg(ep3,ict)
          ep3(3)=-ep3(3)
          ep3(4)=-ep3(4)
          ep3(1)=.5d0*(wpd+wmd)
          ep3(2)=.5d0*(wpd-wmd)
          CALL psdeftr(dmass,ep3,ey)
          wpd=dsqrt(dmass)
          wmd=wpd
        ENDIF
          wp0=0.d0
          wm0=0.d0
        ENDIF

        IF(icz.EQ.5)THEN
          ich1=icp
          ich2=0
          amh1=am(5)**2
          amh2=am(1)**2

          ptmax=pslam(dmass,amh1,amh2)
          IF(ptmax.LT.0.)ptmax=0.
          IF(ptmax.LT.be(4)**2)THEN
1           pti=ptmax*qsran(b10)
            IF(qsran(b10).GT.exp(-dsqrt(pti)/be(4)))GOTO 1
          ELSE
2           pti=(be(4)*dlog(qsran(b10)*qsran(b10)))**2
            IF(pti.GT.ptmax)GOTO 2
          ENDIF
          amt1=amh1+pti
          amt2=amh2+pti
          z=xxtwdec(dmass,amt1,amt2)
          wp1=wpd*z
          wm1=amt1/wp1
          ep3(1)=.5d0*(wp1+wm1)
          ep3(2)=.5d0*(wp1-wm1)
          pt=dsqrt(pti)
          CALL pscs(c,s)
          ep3(3)=pt*c
          ep3(4)=pt*s
          CALL xxreg(ep3,ich1)

          wp1=wpd*(1.d0-z)
          wm1=amt2/wp1
          ep3(1)=.5d0*(wp1+wm1)
          ep3(2)=.5d0*(wp1-wm1)
          ep3(3)=-pt*c
          ep3(4)=-pt*s
          CALL xxreg(ep3,ich2)
        IF(debug.GE.3)WRITE (moniou,202)
          RETURN
        ENDIF

        IF(icz.EQ.1)THEN
          IF(icp.NE.0)THEN
            ic1=icp*(1-3*int(.5d0+qsran(b10)))
            ic2=-icp-ic1
          ELSE
            ic1=int(1.5d0+qsran(b10))*(2*int(.5d0+qsran(b10))-1)
            ic2=-ic1
          ENDIF
        ELSEIF(icz.EQ.2)THEN
          IF(qsran(b10).GT..33333d0)THEN
            ic1=3*is
            ic2=icp-is
          ELSE
            ic1=icp+4*is
            ic2=4*is-icp
          ENDIF
        ELSEIF(icz.EQ.3)THEN
          ic1=-4*is
          ic2=icp-3*is
        ELSEIF(icz.EQ.4)THEN
          ic1=5*is
          ic2=icp-9*is
        ENDIF
        CALL xxgener(wpd,wmd,ey,0.d0,1.d0,0.d0,1.d0,
     *  ic1,ic2)
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXDPR - END')
        RETURN
        END
C=======================================================================

        SUBROUTINE xxdtg(WP0,WM0,ICP,ICT,LQ1)
c Target nucleon dissociation 
c Leading hadronic state hadronization
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep3(4),ey(3)
        COMMON /area1/  ia(2),icz,icp0
        COMMON /area2/  s,y0,wp00,wm00
        COMMON /area10/ stmass,am(7)
        COMMON /area11/ b10
        COMMON /area17/ del,rs,rs0,fs,alfp,rr,sh,delh
        COMMON /area21/ dmmin(5)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran


        IF(debug.GE.2)WRITE (moniou,201)ict,icp,wp0,wm0
201     FORMAT(2x,'XXDTG - LEADING (TARGET) CLUSTER HADRONIZATION:'
     *  /4x,'CLUSTER TYPE ICT=',i2,2x,'PROJECTILE TYPE ',
     *  'ICP=',i2/4x,'AVAILABLE LIGHT CONE MOMENTA: WP0=',e10.3,
     *  ' WM0=',e10.3)
        DO 100 i=1,3
100     ey(i)=1.d0

        sd0=wp0*wm0
        IF(sd0.LT.0.d0)sd0=0.d0
        ddmin=dmmin(2)
        ddmax=min(5.d0,dsqrt(sd0)-am(icz))

        IF(ddmax.LT.ddmin)THEN
c Registration of too slow "leading" hadron if its energy is insufficient for
c diffractive exhitation
          ep3(3)=0.d0
          ep3(4)=0.d0

          IF(lq1.NE.0)THEN
            wmi=wm0
            IF( wp0.LE.0.d0.OR.am(2)**2.GT.wmi*wp0)RETURN
            wpi=am(2)**2/wmi
            wp0=wp0-wpi
            wm0=0.d0
            ep3(1)=.5d0*(wpi+wmi)
            ep3(2)=.5d0*(wpi-wmi)
            CALL xxreg(ep3,ict)
        IF(debug.GE.3)WRITE (moniou,202)
            RETURN
          ELSE

            IF(dsqrt(sd0).LT.am(icz)+am(2))THEN
              IF(wp0.GT.0.d0.AND.(am(icz)+am(2))**2/wp0.LT..5d0*wm00)
     *        THEN
                sd0=(am(icz)+am(2))**2
                wm0=sd0/wp0
              ELSE
        IF(debug.GE.3)WRITE (moniou,202)
                RETURN
              ENDIF
            ENDIF
            xw=xxtwdec(sd0,am(icz)**2,am(2)**2)
            wp1=xw*wp0
            wm1=am(icz)**2/wp1
            ep3(1)=.5d0*(wp1+wm1)
            ep3(2)=.5d0*(wp1-wm1)
            CALL xxreg(ep3,icp)
            wm2=wm0-wm1
            wp2=am(2)**2/wm2
            ep3(1)=.5d0*(wp2+wm2)
            ep3(2)=.5d0*(wp2-wm2)
            CALL xxreg(ep3,ict)
            wp0=0.d0
            wm0=0.d0
          ENDIF
        IF(debug.GE.3)WRITE (moniou,202)
          RETURN
        ENDIF

        dmass=(ddmin/(1.d0-qsran(b10)*(1.d0-ddmin/ddmax)))**2
        IF(lq1.NE.0)THEN
          wmd=wm0
          wpd=dmass/wmd
          wp0=wp0-wpd
          wm0=0.d0
        ELSE
          ptmax=pslam(sd0,dmass,am(icz)**2)
          IF(ptmax.LT.0.)ptmax=0.
          pti=-1.d0/rs*dlog(1.d0-qsran(b10)*(1.d0-exp(-rs*ptmax)))

          amt1=dmass+pti
          amt2=am(icz)**2+pti
          wmd=wm0*xxtwdec(sd0,amt1,amt2)
          wpd=amt1/wmd
          wp2=wp0-wpd
          wm2=amt2/wp2
          pt=dsqrt(pti)
          CALL pscs(ccos,ssin)
          ep3(3)=pt*ccos
          ep3(4)=pt*ssin
          ep3(1)=.5d0*(wp2+wm2)
          ep3(2)=.5d0*(wp2-wm2)
          CALL xxreg(ep3,icp)
          ep3(3)=-ep3(3)
          ep3(4)=-ep3(4)
          ep3(1)=.5d0*(wpd+wmd)
          ep3(2)=.5d0*(wpd-wmd)
          CALL psdeftr(dmass,ep3,ey)
          wpd=dsqrt(dmass)
          wmd=wpd
          wp0=0.d0
          wm0=0.d0
        ENDIF

        is=iabs(ict)/ict
        IF(qsran(b10).GT..33333d0)THEN
          ic1=3*is
          ic2=ict-is
        ELSE
          ic1=ict+4*is
          ic2=4*is-ict
        ENDIF
        CALL xxgener(wpd,wmd,ey,
     *  0.d0,1.d0,0.d0,1.d0,ic2,ic1)
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXDTG - END')
        RETURN
        END
C=======================================================================

        SUBROUTINE xxfau(B,GZ)
c Integrands for hadron-hadron and hadron-nucleus cross-sections calculation
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension gz(3),gz0(2)
        COMMON /area1/  ia(2),icz,icp
        COMMON /area16/ cc(5)
        COMMON /ar1/    anorm
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)
201     FORMAT(2x,'XXFAU - INTEGRANDS FOR HADRON-HADRON AND '
     *    ,'HADRON-NUCLEUS CROSS-SECTIONS CALCULATION')

        CALL xxfz(b,gz0)
        DO 1 l=1,2
1       gz0(l)=gz0(l)*cc(2)*anorm*.5d0

        ab=float(ia(2))

        gz1=(1.d0-gz0(1))**ab
        gz2=(1.d0-gz0(2))**ab
        gz3=(1.d0-cc(2)*gz0(2)-2.d0*(1.d0-cc(2))*gz0(1))**ab


        gz(1)=cc(icz)**2*(gz2-gz3)
        gz(2)=cc(icz)*(1.d0-cc(icz))*(1.d0+gz2-2.d0*gz1)
        gz(3)=cc(icz)*(1.d0-gz2)
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXFAU - END')
        RETURN
        END
C=======================================================================

         SUBROUTINE xxfrag(SA,NA,RC)
c Connected nucleon clasters extraction - used for the nuclear spectator part
c multifragmentation:
c-----------------------------------------------------------------------
         IMPLICIT DOUBLE PRECISION (a-h,o-z)
         INTEGER DEBUG
cdh      DIMENSION SA(56,3)
         dimension sa(64,3)
         COMMON /area13/ nsf,iaf(56)
         COMMON /area43/ moniou
         COMMON /debug/  debug
         SAVE

         IF(debug.GE.2)WRITE (moniou,201)na
201      FORMAT(2x,'XXFRAG-MULTIFRAGMENTATION: NUCLEUS MASS NUMBER: NA='
     *   ,i2)
         IF(debug.GE.3)THEN
           WRITE (moniou,203)
203        FORMAT(2x,'NUCLEONS COORDINATES:')
204        FORMAT(2x,3e10.3)
           DO 205 i=1,na
205        WRITE (moniou,204)(sa(i,l),l=1,3)
         ENDIF

         ni=1
         ng=1
         j=0
1        j=j+1
         j1=ni+1
         DO 4 i=j1,na
         ri=0.d0
         DO 2 m=1,3
2        ri=ri+(sa(j,m)-sa(i,m))**2
         IF(ri.GT.rc)GOTO 4
         ni=ni+1
         ng=ng+1
         IF(i.EQ.ni)GOTO 4
         DO 3 m=1,3
         s0=sa(ni,m)
         sa(ni,m)=sa(i,m)
3        sa(i,m)=s0
4        CONTINUE
         IF(j.LT.ni.AND.na-ni.GT.0)GOTO 1
         nsf=nsf+1
         iaf(nsf)=ng
         IF(debug.GE.3)WRITE (moniou,206)nsf,iaf(nsf)
206      FORMAT(2x,'XXFRAG: FRAGMENT N',i2,2x,'FRAGMENT MASS - ',i2)
         ng=1
         j=ni
         ni=ni+1
         IF(na-ni)6,5,1
5        nsf=nsf+1
         iaf(nsf)=1
         IF(debug.GE.3)WRITE (moniou,206)nsf,iaf(nsf)
6        CONTINUE
         IF(debug.GE.3)WRITE (moniou,202)
202      FORMAT(2x,'XXFRAG - END')
         RETURN
         END
C=======================================================================

      SUBROUTINE xxfragm(NS,XA)
c Fragmentation of the spectator part of the nucleus
c XA(56,3) - arrays for spectator nucleons positions
c NS - total number of spectators
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
cdh   DIMENSION XA(56,3)
      dimension xa(64,3)
      INTEGER DEBUG
      COMMON /area1/  ia(2),icz,icp
      COMMON /area3/  rmin,emax,eev
      COMMON /area11/ b10
c NSF - number of secondary fragments;
c IAF(i) - mass of the i-th fragment
      COMMON /area13/ nsf,iaf(56)
      COMMON /area43/ moniou
      COMMON /debug/  debug
      SAVE
      EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)ns
201     FORMAT(2x,'XXFRAGM: NUMBER OF SPECTATORS: NS=',i2)

        nsf=0

        IF(ns-1)6,1,2
c Single spectator nucleon is recorded
1     nsf=nsf+1
      iaf(nsf)=1
        IF(debug.GE.3)WRITE (moniou,205)
205     FORMAT(2x,'XXFRAGM - SINGLE SPECTATOR')
        GOTO 6
2       eex=0.d0
c EEX - spectator part excitation energy; calculated as the sum of excitations
c from all wounded nucleons ( including diffractively excited )
        DO 3 i=1,ia(1)-ns
c Partial excitation is simulated according to distribution f(E) ~ 1/sqrt(E)
c * exp(-E/(2*<E>)), for sqrt(E) we have then normal distribution
3     eex=eex+(qsran(b10)+qsran(b10)+qsran(b10)+
     *      qsran(b10)+qsran(b10)-2.5d0)**2*2.4d0
          IF(debug.GE.3)WRITE (moniou,203)eex
203     FORMAT(2x,'XXFRAGM: EXCITATION ENERGY: EEX=',e10.3)

c If the excitation energy per spectator is larger than EMAX
c multifragmentation takes place ( percolation algorithm is used for it )
        IF(eex/ns.GT.emax)THEN
c Multifragmentation
          CALL xxfrag(xa,ns,rmin)
        ELSE

c Otherwise average number of eveporated nucleons equals EEX/EEV, where
c EEV - mean excitation energy carried out by one nucleon
          nf=ixxson(ns,eex/eev,qsran(b10))
          nsf=nsf+1
c Recording of the fragment produced
          iaf(nsf)=ns-nf
          IF(debug.GE.3)WRITE (moniou,206)iaf(nsf)
206     FORMAT(2x,'XXFRAGM - EVAPORATION: MASS NUMBER OF THE FRAGMENT:'
     *  ,i2)

c Some part of excitation energy is carried out by alphas; we determine the
c number of alphas simply as NF/4
          nal=nf/4
          IF(nal.NE.0)THEN
c Recording of the evaporated alphas
            DO 4 i=1,nal
            nsf=nsf+1
4           iaf(nsf)=4
          ENDIF

          nf=nf-4*nal
          IF(nf.NE.0)THEN
c Recording of the evaporated nucleons
            DO 5 i=1,nf
            nsf=nsf+1
5           iaf(nsf)=1
          ENDIF
          IF(debug.GE.3)WRITE (moniou,204)nf,nal
204     FORMAT(2x,'XXFRAGM - EVAPORATION: NUMBER OF NUCLEONS NF=',i2,
     *  'NUMBER OF ALPHAS NAL=',i2)
        ENDIF
6       CONTINUE
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXFRAGM - END')
        RETURN
        END
C=======================================================================

        SUBROUTINE xxfz(B,GZ)
c Hadron-hadron and hadron-nucleus cross sections calculation
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension gz(2),fhard(3)
        COMMON /area1/  ia(2),icz,icp
        COMMON /area2/  s,y0,wp0,wm0
        COMMON /area7/  rp1
        COMMON /ar3/    x1(7),a1(7)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)
201     FORMAT(2x,'XXFZ - HADRONIC CROSS-SECTIONS CALCULATION')

        DO 1 l=1,2
1       gz(l)=0.d0
        e1=exp(-1.d0)

        DO 2 i1=1,7
        DO 2 m=1,2
        z=.5d0+x1(i1)*(m-1.5d0)
        s1=dsqrt(rp1*z)
        zv1=exp(-z)
        s2=dsqrt(rp1*(1.d0-dlog(z)))
        zv2=e1*z
C??????????
C       VV1=EXP(-PSFAZ(ZV1,FSOFT,FHARD,FSHARD))*(1.D0-FHARD(1)
C    *  -FHARD(2)-FHARD(3))
C       VV2=EXP(-PSFAZ(ZV2,FSOFT,FHARD,FSHARD))*(1.D0-FHARD(1)
C    *  -FHARD(2)-FHARD(3))

        vv1=exp(-psfaz(zv1,fsoft,fhard,fshard)-fhard(1)
     *  -fhard(2)-fhard(3))
        vv2=exp(-psfaz(zv2,fsoft,fhard,fshard)-fhard(1)
     *  -fhard(2)-fhard(3))
c???????????

        IF(ia(2).EQ.1)THEN
          cg1=1.d0
          cg2=1.d0
        ELSE
          cg1=xxrot(b,s1)
          cg2=xxrot(b,s2)
        ENDIF

        DO 2 l=1,2
2       gz(l)=gz(l)+ a1(i1)*(cg1*(1.d0-vv1**l)+cg2*(1.d0-vv2**l)/z)
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXFZ - END')
        RETURN
        END
C=======================================================================

      SUBROUTINE xxgau(GZ)
c Impact parameter integration for impact parameters <BM -
c for hadron-hadron and hadron-nucleus cross-sections calculation
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
      dimension gz(3),gz0(3)
      COMMON /area6/ pi,bm,am
      COMMON /ar3/   x1(7),a1(7)
      COMMON /ar2/   r,rm
      COMMON /area43/ moniou
      COMMON /debug/  debug
      SAVE

        IF(debug.GE.2)WRITE (moniou,201)
201     FORMAT(2x,'XXGAU - NUCLEAR CROSS-SECTIONS CALCULATION')

      DO 1 i=1,3
1     gz(i)=0.d0

      DO 2 i=1,7
      DO 2 m=1,2
      b=bm*dsqrt(.5d0+x1(i)*(m-1.5d0))
      CALL xxfau(b,gz0)
      DO 2 l=1,3
2     gz(l)=gz(l)+gz0(l)*a1(i)
      DO 3 l=1,3
3     gz(l)=gz(l)*(bm*am)**2*pi*.5d0
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXGAU - END')
      RETURN
      END
C=======================================================================

      SUBROUTINE xxgau1(GZ)
c Impact parameter integration for impact parameters >BM -
c for hadron-hadron and hadron-nucleus cross-sections calculation
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
      dimension gz(3),gz0(3)
      COMMON /area6/ pi,bm,am
      COMMON /ar5/   x5(2),a5(2)
      COMMON /ar2/   r,rm
      COMMON /area43/ moniou
      COMMON /debug/  debug
      SAVE

        IF(debug.GE.2)WRITE (moniou,201)
201     FORMAT(2x,'XXGAU1 - NUCLEAR CROSS-SECTIONS CALCULATION')

      DO 1 i=1,2
      b=bm+x5(i)
      CALL xxfau(b,gz0)
      DO 1 l=1,3
1     gz(l)=gz(l)+gz0(l)*a5(i)*exp(x5(i))*b*2.d0*pi*am*am
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXGAU1 - END')
      RETURN
      END
C=======================================================================

        SUBROUTINE xxgener(WP0,WM0,EY0,S0X,C0X,S0,C0,IC1,IC2)
c To simulate the fragmentation of the string into secondary hadrons
c The algorithm conserves energy-momentum;
c WP0, WM0 are initial longitudinal momenta ( E+p, E-p ) of the quarks
c at the ends of the string; IC1, IC2 - their types
c The following partons types are used: 1 - u, -1 - U, 2 - d, -2 - D,
c 3 - ud, -3 - UD, 4 - s, -4 - S, 5 - c, -5 - C,
c  6 - uu, 7 - dd, -6 - UU, -7 - DD
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        CHARACTER *2 TYQ
        dimension wp(2),ic(2),ept(4),ep(4),ey(3),ey0(3)
c WP(1), WP(2) - current longitudinal momenta of the partons at the string
c ends, IC(1), IC(2) - their types
        COMMON /area8/  wwm,bep,ben,bek,bec,dc(5),deta,almpt
        COMMON /area10/ stmass,am0,amn,amk,amc,amlamc,amlam,ameta
        COMMON /area11/ b10
        COMMON /area19/ ahl(5)
********************************************************
        COMMON /area21/ dmmin(5)
********************************************************
        COMMON /area28/ arr(4)
        COMMON /area42/ tyq(15)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)tyq(8+ic1),tyq(8+ic2),
     *  wp0,wm0,ey0,s0x,c0x,s0,c0
201     FORMAT(2x,'XXGENER: PARTON FLAVORS AT THE ENDS OF THE STRING:',
     *  2x,a2,2x,a2/4x,'LIGHT CONE MOMENTA OF THE STRING: ',e10.3,
     *  2x,e10.3/4x,'EY0=',3e10.3/4x,
     *  'S0X=',e10.3,2x,'C0X=',e10.3,2x,'S0=',e10.3,2x,'C0=',e10.3)

        ww=wp0*wm0
        ept(1)=.5d0*(wp0+wm0)
        ept(2)=.5d0*(wp0-wm0)
        ept(3)=0.d0
        ept(4)=0.d0
        ic(1)=ic1
        ic(2)=ic2

1     sww=dsqrt(ww)
      CALL psdeftr(ww,ept,ey)
      j=int(2.d0*qsran(b10))+1
      IF(debug.GE.3)THEN
        iqt=8+ic(j)
        WRITE (moniou,203)j,tyq(iqt),ww
203     FORMAT(2x,'XXGENER: CURRENT PARTON FLAVOR AT THE END ',i1,
     *  ' OF THE STRING: ',a2/4x,' STRING MASS: ',e10.3)
      ENDIF

      iab=iabs(ic(j))
      is=ic(j)/iab
      IF(iab.GT.5)iab=3
      iaj=iabs(ic(3-j))
      IF(iaj.GT.5)iaj=3
      IF(iaj.EQ.3)THEN
        restm=amn
      ELSEIF(iaj.EQ.4)THEN
          restm=amk
      ELSEIF(iaj.EQ.5)THEN
        restm=amc
      ELSE
        restm=am0
      ENDIF

      IF(iab.LE.2.AND.sww.GT.restm+2.d0*am0+wwm.OR.
     *iab.EQ.3.AND.sww.GT.restm+am0+amn+wwm.OR.
     *iab.EQ.4.AND.sww.GT.restm+am0+amk+wwm.OR.
     *iab.EQ.5.AND.sww.GT.restm+am0+amc+wwm)THEN

        IF(iab.LE.2)THEN
          IF(sww.GT.restm+2.d0*amc.AND.qsran(b10).LT.dc(3))THEN
c D-meson generation
            restm=(restm+amc)**2
            bet=bec
            ami=amc**2
            alf=almpt-arr(4)
            blf=ahl(4)
            ic0=ic(j)-9*is
            ic(j)=5*is
          ELSEIF(sww.GT.restm+2.d0*amn.AND.qsran(b10).LT.dc(1))THEN
c Nucleon generation
            restm=(restm+amn)**2
            bet=ben
            ami=amn**2
            alf=almpt-arr(2)
            blf=ahl(2)
            ic0=ic(j)+is
            ic(j)=-3*is
          ELSEIF(sww.GT.restm+2.d0*amk.AND.qsran(b10).LT.dc(2))THEN
c Kaon generation
            restm=(restm+amk)**2
            bet=bek
            ami=amk**2
            alf=almpt-arr(3)
            blf=ahl(3)
            ic0=ic(j)+3*is
            ic(j)=4*is
          ELSEIF(sww.GT.restm+ameta+am0.AND.qsran(b10).LT.deta)THEN
c Eta generation
            restm=(restm+am0)**2
            bet=bek
            ami=ameta**2
            alf=almpt-arr(1)
            blf=ahl(1)
            ic0=10
          ELSE
c Pion generation
            restm=(restm+am0)**2
            bet=bep
            ami=am0**2
            alf=almpt-arr(1)
            blf=ahl(1)

            IF(qsran(b10).LT..3333d0)THEN
              ic0=0
            ELSE
              ic0=3*is-2*ic(j)
              ic(j)=3*is-ic(j)
            ENDIF
          ENDIF

        ELSEIF(iab.EQ.3)THEN
          IF(sww.GT.restm+amc+amlamc.AND.qsran(b10).LT.dc(5).AND.
     *    iabs(ic(j)).EQ.3)THEN
c Lambda_C generation
            restm=(restm+amc)**2
            bet=bec
            ami=amlamc**2
            alf=almpt-arr(4)
            blf=ahl(5)
            ic0=9*is
            ic(j)=-5*is
          ELSEIF(sww.GT.restm+amk+amlam.AND.qsran(b10).LT.dc(4).AND.
     *    iabs(ic(j)).EQ.3)THEN
c Lambda generation
            restm=(restm+amk)**2
            bet=bek
            ami=amlam**2
            alf=almpt-arr(3)
            blf=ahl(2)+arr(1)-arr(3)
            ic0=6*is
            ic(j)=-4*is
          ELSE
c Nucleon generation
            restm=(restm+am0)**2
            bet=ben
            ami=amn**2
            alf=almpt-arr(1)
            blf=ahl(2)
            IF(iabs(ic(j)).EQ.3)THEN
              ic0=is*int(2.5d0+qsran(b10))
              ic(j)=is-ic0
            ELSE
              ic0=ic(j)-4*is
              ic(j)=ic0-4*is
            ENDIF
          ENDIF

        ELSEIF(iab.EQ.4)THEN
          IF(sww.GT.restm+amn+amlam.AND.qsran(b10).LT.dc(1))THEN
c Lambda generation
            restm=(restm+amn)**2
            bet=ben
            ami=amlam**2
            alf=almpt-arr(2)
            blf=ahl(2)+arr(1)-arr(3)
            ic0=6*is
            ic(j)=-3*is
          ELSE
c Kaon generation
            restm=(restm+am0)**2
            bet=bep
            ami=amk**2
            alf=almpt-arr(1)
            blf=ahl(3)
            ic(j)=is*int(1.5d0+qsran(b10))
            ic0=-3*is-ic(j)
          ENDIF

        ELSEIF(iab.EQ.5)THEN
          IF(sww.GT.restm+amn+amlamc.AND.qsran(b10).LT.dc(1))THEN
c Lambda_C generation
            restm=(restm+amn)**2
            bet=ben
            ami=amlamc**2
            alf=almpt-arr(2)
            blf=ahl(5)
            ic0=9*is
            ic(j)=-3*is
          ELSE
c D-meson generation
            restm=(restm+am0)**2
            bet=bep
            ami=amc**2
            alf=almpt-arr(1)
            blf=ahl(4)
            ic(j)=is*int(1.5d0+qsran(b10))
            ic0=9*is-ic(j)
          ENDIF
        ENDIF

********************************************************
        ptmax=pslam(ww,restm,ami)
        IF(ptmax.LT.0.)ptmax=0.

        IF(ptmax.LT.bet**2)THEN
2         pti=ptmax*qsran(b10)
          IF(qsran(b10).GT.exp(-dsqrt(pti)/bet))GOTO 2
        ELSE
3         pti=(bet*dlog(qsran(b10)*qsran(b10)))**2
          IF(pti.GT.ptmax)GOTO 3
        ENDIF

        amt=ami+pti
        restm1=restm+pti
********************************************************
c        ALF=ALF+2.*PTI

        zmin=dsqrt(amt/ww)
        zmax=xxtwdec(ww,amt,restm1)
        z1=(1.-zmax)**alf
        z2=(1.-zmin)**alf
4       z=1.-(z1+(z2-z1)*qsran(b10))**(1./alf)
        IF(qsran(b10).GT.(z/zmax)**blf)GOTO 4
        wp(j)=z*sww
        wp(3-j)=amt/wp(j)
        ep(1)=.5d0*(wp(1)+wp(2))
        ep(2)=.5d0*(wp(1)-wp(2))
        pti=dsqrt(pti)
        CALL pscs(c,s)
        ep(3)=pti*c
        ep(4)=pti*s

        ept(1)=sww-ep(1)
        DO 5 i=2,4
5       ept(i)=-ep(i)
        ww=psnorm(ept)
        IF(ww.LT.restm)GOTO 4

        CALL pstrans(ep,ey)
        CALL pstrans(ept,ey)

        IF(s0x.NE.0.d0.OR.s0.NE.0.d0)THEN
          CALL psrotat(ep,s0x,c0x,s0,c0)
        ENDIF
        
        IF(ey0(1)*ey0(2)*ey0(3).NE.1.d0)THEN
          CALL pstrans(ep,ey0)
        ENDIF
        CALL xxreg(ep,ic0)
      ELSE


        ami2=restm**2
        bet=bep
        IF(iab.LE.2.AND.iaj.LE.2)THEN
          ami=am0**2
          ic0=-ic(1)-ic(2)
          IF(ic0.NE.0)THEN
            ic(j)=ic0*int(.5d0+qsran(b10))
            ic(3-j)=ic0-ic(j)
          ELSE
            IF(qsran(b10).LT..2d0)THEN
              ic(j)=0
              ic(3-j)=0
            ELSE
              ic(j)=3*is-2*ic(j)
              ic(3-j)=-ic(j)
            ENDIF
          ENDIF

        ELSEIF(iab.EQ.3.OR.iaj.EQ.3)THEN
          IF(iab.EQ.3)THEN
            ami=amn**2
            IF(iabs(ic(j)).EQ.3)THEN
              IF(iaj.EQ.3)THEN
                IF(iabs(ic(3-j)).EQ.3)THEN
                  ic(j)=is*int(2.5d0+qsran(b10))
                  ic(3-j)=-ic(j)
            ELSE
                  ic(3-j)=ic(3-j)+4*is
                  ic(j)=5*is+ic(3-j)
            ENDIF
              ELSEIF(iaj.LT.3)THEN
                IF(qsran(b10).LT..3333d0)THEN
                  ic(j)=ic(3-j)+is
                  ic(3-j)=0
                ELSE
                  ic(j)=is*(4-iaj)
                  ic(3-j)=is*(3-2*iaj)
                ENDIF
              ELSEIF(iaj.EQ.4)THEN
                ic(j)=is*int(2.5d0+qsran(b10))
                ic(3-j)=-ic(j)-2*is
              ELSEIF(iaj.EQ.5)THEN
                ic(j)=is*int(2.5d0+qsran(b10))
                ic(3-j)=-ic(j)+10*is
              ENDIF
            ELSE
              ic(j)=ic(j)-4*is
              ic0=ic(j)-4*is
              IF(iaj.EQ.3)THEN
                ic(3-j)=ic0-is
              ELSEIF(iaj.LT.3)THEN
                ic(3-j)=-ic(3-j)-ic0
              ELSEIF(iaj.EQ.4)THEN
                ic(3-j)=ic0-3*is
              ELSEIF(iaj.EQ.5)THEN
                ic(3-j)=ic0+9*is
              ENDIF
            ENDIF
          ELSE
            IF(iabs(ic(3-j)).EQ.3)THEN
              IF(iab.LT.3)THEN
                ami=am0**2
                IF(qsran(b10).LT..3333d0)THEN
                  ic(3-j)=ic(j)+is
                  ic(j)=0
                ELSE
                  ic(3-j)=is*(4-iab)
                  ic(j)=is*(3-2*iab)
                ENDIF
              ELSEIF(iab.EQ.4)THEN
                ami=amk**2
                ic(3-j)=is*int(2.5d0+qsran(b10))
                ic(j)=-ic(3-j)-2*is
              ELSEIF(iab.EQ.5)THEN
                ami=amc**2
                ic(3-j)=is*int(2.5d0+qsran(b10))
                ic(j)=-ic(3-j)+10*is
              ENDIF
            ELSE
              ic(3-j)=ic(3-j)-4*is
              ic0=ic(3-j)-4*is
              IF(iab.LT.3)THEN
                ami=am0**2
                ic(j)=-ic0-ic(j)
              ELSEIF(iab.EQ.4)THEN
                ami=amk**2
                ic(j)=ic0-3*is
              ELSEIF(iab.EQ.5)THEN
                ami=amc**2
                ic(j)=ic0+9*is
              ENDIF
            ENDIF
          ENDIF

        ELSEIF(iab.EQ.4.OR.iaj.EQ.4)THEN

          IF(iab.EQ.4)THEN
            ami=amk**2

            IF(iaj.EQ.4)THEN
              ic(j)=-is*int(4.5d0+qsran(b10))
              ic(3-j)=-ic(j)
            ELSEIF(iaj.EQ.5)THEN
              ic(j)=-is*int(4.5d0+qsran(b10))
              ic(3-j)=-ic(j)-12*is
            ELSE
              ic0=ic(3-j)+int(.6667d0+qsran(b10))*(-3*is-2*ic(3-j))
              ic(j)=ic0-3*is
              ic(3-j)=ic0-ic(3-j)
            ENDIF
          ELSE
            IF(iab.LE.2)THEN
              ami=am0**2
              ic0=ic(j)+int(.6667d0+qsran(b10))*(3*is-2*ic(j))
              ic(j)=ic0-ic(j)
              ic(3-j)=ic0+3*is
            ELSEIF(iab.EQ.5)THEN
              ami=amc**2
              ic(3-j)=is*int(4.5d0+qsran(b10))
              ic(j)=-ic(3-j)+12*is
            ENDIF
          ENDIF

        ELSEIF(iab.EQ.5.OR.iaj.EQ.5)THEN

          IF(iab.EQ.5)THEN
            ami=amc**2

            IF(iaj.EQ.5)THEN
              ic(j)=is*int(7.5d0+qsran(b10))
              ic(3-j)=-ic(j)
            ELSE
              ic0=ic(3-j)+int(.6667d0+qsran(b10))*(-3*is-2*ic(3-j))
              ic(j)=ic0+9*is
              ic(3-j)=ic0-ic(3-j)
            ENDIF
          ELSE
            ami=am0**2
            ic0=ic(j)+int(.6667d0+qsran(b10))*(3*is-2*ic(j))
            ic(j)=ic0-ic(j)
            ic(3-j)=ic0-9*is
          ENDIF
        ENDIF

        ptmax=pslam(ww,ami2,ami)
        IF(ptmax.LT.0.)ptmax=0.
        IF(ptmax.LT.bet**2)THEN
6         pti=ptmax*qsran(b10)
          IF(qsran(b10).GT.exp(-dsqrt(pti)/bet))GOTO 6
        ELSE
7         pti=(bet*dlog(qsran(b10)*qsran(b10)))**2
          IF(pti.GT.ptmax)GOTO 7
        ENDIF

        amt1=ami+pti
        amt2=ami2+pti

        z=xxtwdec(ww,amt1,amt2)
        wp(j)=z*sww
        wp(3-j)=amt1/wp(j)
        ep(1)=.5d0*(wp(1)+wp(2))
        ep(2)=.5d0*(wp(1)-wp(2))
        pti=dsqrt(pti)
        CALL pscs(c,s)
        ep(3)=pti*c
        ep(4)=pti*s

        ept(1)=sww-ep(1)
        DO 8 i=2,4
8       ept(i)=-ep(i)

        CALL pstrans(ep,ey)
        CALL pstrans(ept,ey)

        IF(s0x.NE.0.d0.OR.s0.NE.0.d0)THEN
          CALL psrotat(ep,s0x,c0x,s0,c0)
          CALL psrotat(ept,s0x,c0x,s0,c0)
        ENDIF
        IF(ey0(1)*ey0(2)*ey0(3).NE.1.d0)THEN
          CALL pstrans(ep,ey0)
          CALL pstrans(ept,ey0)
        ENDIF
        
        CALL xxreg(ep,ic(j))
        CALL xxreg(ept,ic(3-j))
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXGENER - END')
        RETURN
      ENDIF
      GOTO 1
      END
C=======================================================================

        SUBROUTINE xxjetsim
c Procedure for jet hadronization - each gluon is
c considered to be splitted into quark-antiquark pair and usual soft
c strings are assumed to be formed between quark and antiquark
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep(4),ep1(4),ey(3)
        COMMON /area10/ stmass,am(7)
        COMMON /area11/ b10
        COMMON /area43/ moniou
        COMMON /debug/  debug
        COMMON /area46/ epjet(4,2,15000),ipjet(2,15000)
        COMMON /area47/ njtot
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)njtot
201     FORMAT(2x,'XXJETSIM: TOTAL NUMBER OF JETS NJTOT=',i4)
        IF(njtot.EQ.0)RETURN     
        DO 2 nj=1,njtot
        DO 1 i=1,4
        ep1(i)=epjet(i,1,nj)
1       ep(i)=ep1(i)+epjet(i,2,nj)
        pt3=dsqrt(ep1(3)**2+ep1(4)**2)
        pt4=dsqrt(epjet(3,2,nj)**2+epjet(4,2,nj)**2)

c Invariant mass square for the jet
        ww=psnorm(ep)
        sww=dsqrt(ww)
    
        CALL psdeftr(ww,ep,ey)
        CALL pstrans1(ep1,ey)
        CALL psdefrot(ep1,s0x,c0x,s0,c0)

2       CALL xxgener(sww,sww,ey,s0x,c0x,s0,c0,ipjet(1,nj),ipjet(2,nj))
        IF(debug.GE.3)WRITE (moniou,202)
202     FORMAT(2x,'XXJETSIM - END')
        RETURN
        END
C=======================================================================

        SUBROUTINE xxreg(EP0,IC)
c Registration of the produced hadron;
c EP - 4-momentum,
c IC - hadron type
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ep(4),ep0(4)
        COMMON /area4/  ey0(3)
        COMMON /area10/ stmass,am0,amn,amk,amc,amlamc,amlam,ameta
        COMMON /area11/ b10
        COMMON /area12/ nsh
        COMMON /area14/ esp(4,95000),ich(95000)
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)ic,ep0
201     FORMAT(2x,'XXREG: IC=',i2,2x,'C.M. 4-MOMENTUM:',2x,4(e10.3,1x))
         pt=dsqrt(ep0(3)**2+ep0(4)**2)
c         if(pt.gt.11.d0)write (MONIOU,*)'pt,ic,ep',pt,ic,ep0
c         if(pt.gt.11.d0)write (*,*)'pt,ic,ep',pt,ic,ep0

        nsh=nsh+1
        IF (nsh .GT. 95000) THEN
          WRITE(moniou,*)'XXREG: TOO MANY SECONDARY PARTICLES'
          WRITE(moniou,*)'XXREG: NSH = ',nsh
          stop
        ENDIF
        DO 4 i=1,4
4       ep(i)=ep0(i)
        CALL pstrans(ep,ey0)
        IF(debug.GE.3)WRITE (moniou,202)ep
202     FORMAT(2x,'XXREG: LAB. 4-MOMENTUM:',2x,4(e10.3,1x))

        ich(nsh)=ic
        DO 3 i=1,4
3       esp(i,nsh)=ep(i)

        IF(debug.GE.3)WRITE (moniou,203)
203     FORMAT(2x,'XXREG - END')
        RETURN
        END
C=======================================================================

        FUNCTION xxrot(S,B)
c Convolution of nuclear profile functions (axial angle integration)
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /ar8/  x2(4),a2
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)b
201     FORMAT(2x,'XXROT - AXIAL ANGLE INTEGRATION OF THE ',
     *  'NUCLEAR PROFILE FUNCTION'/4x,
     *  'IMPACT PARAMETER B=',e10.3,2x,'NUCLEON COORDINATE S=',e10.3)

        xxrot=0.
        DO 1 i=1,4
        sb1=b**2+s**2-2.*b*s*(2.*x2(i)-1.)
        sb2=b**2+s**2-2.*b*s*(1.-2.*x2(i))
1       xxrot=xxrot+(xxt(sb1)+xxt(sb2))
        xxrot=xxrot*a2
        IF(debug.GE.3)WRITE (moniou,202)xxrot
202     FORMAT(2x,'XXROT=',e10.3)
        RETURN
        END
C=======================================================================

        SUBROUTINE xxstr(WPI0,WMI0,WP0,WM0,IC10,IC120,IC210,IC20)
**************************************************
c Fragmentation process for the pomeron ( quarks and antiquarks types at the
c ends of the two strings are determined, energy-momentum is shared
c between them and strings fragmentation is simulated )
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        dimension ey(3)
        COMMON /area6/  pi,bm,ammm
        COMMON /area10/ stmass,am(7)
        COMMON /area11/ b10
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE
        EXTERNAL qsran

        IF(debug.GE.2)WRITE (moniou,201)wpi0,wmi0,wp0,wm0
201     FORMAT(2x,'XXSTR: WPI0=',e10.3,2x,'WMI0=',e10.3,2x,
     *  'WP0=',e10.3,2x,'WM0=',e10.3)
         DO 1 i=1,3
1        ey(i)=1.d0

         wpi=wpi0
         wmi=wmi0
c Quark-antiquark types (1 - u, 2 - d, -1 - u~, -2 - d~); s- and d- quarks are
c taken into consideration at the fragmentation step
**************************************************
        IF(ic10.EQ.0)THEN
          ic1=int(1.5+qsran(b10))
          ic12=-ic1
        ELSEIF(ic10.GT.0)THEN
          ic1=ic10
          ic12=ic120
        ELSE
          ic1=ic120
          ic12=ic10
        ENDIF
        IF(ic20.EQ.0)THEN
          ic2=int(1.5+qsran(b10))
          ic21=-ic2
        ELSEIF(ic20.gt.0)THEN
          ic2=ic20
          ic21=ic210
        ELSE
          ic2=ic210
          ic21=ic20
        ENDIF
**************************************************

c Longitudinal momenta for the strings
        wp1=wpi*cos(pi*qsran(b10))**2
        wm1=wmi*cos(pi*qsran(b10))**2
        wpi=wpi-wp1
        wmi=wmi-wm1
c String masses
        sm1=wp1*wm1
        sm2=wpi*wmi
c Too short strings are neglected (energy is given to partner string or to the hadron
c (nucleon) to which the pomeron is connected)
        IF(sm1.GT.stmass.AND.sm2.GT.stmass)THEN
c Strings fragmentation is simulated - GENER
          CALL xxgener(wp1,wm1,ey,0.d0,1.d0,0.d0,1.d0,ic1,ic21)
          CALL xxgener(wpi,wmi,ey,0.d0,1.d0,0.d0,1.d0,ic12,ic2)
        ELSEIF(sm1.GT.stmass)THEN
          CALL xxgener(wp1+wpi,wm1+wmi,ey,0.d0,1.d0,0.d0,1.d0,ic1,ic21)
        ELSEIF(sm2.GT.stmass)THEN
          CALL xxgener(wpi+wp1,wmi+wm1,ey,0.d0,1.d0,0.d0,1.d0,ic12,ic2)
        ELSE
          wp0=wp0+wp1+wpi
          wm0=wm0+wm1+wmi
        ENDIF
        IF(debug.GE.3)WRITE (moniou,202)wp0,wm0
202     FORMAT(2x,'XXSTR - RETURNED LIGHT CONE MOMENTA:',
     *  2x,'WP0=',e10.3,2x,'WM0=',e10.3)
        RETURN
        END
C=======================================================================

      FUNCTION xxt(B)
c Nuclear profile function value at impact parameter squared B
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      INTEGER DEBUG
      COMMON /area6/ pi,bm,am
      COMMON /ar2/   r,rm
      COMMON /ar5/   x5(2),a5(2)
      COMMON /ar9/   x9(3),a9(3)
      COMMON /area43/ moniou
      COMMON /debug/  debug
      SAVE

        IF(debug.GE.2)WRITE (moniou,201)b
201     FORMAT(2x,'XXT - NUCLEAR PROFILE FUNCTION VALUE AT IMPACT',
     *  ' PARAMETER SQUARED B=',e10.3)
      xxt=0.
      zm=rm**2-b
      IF(zm.GT.4.*b)THEN
        zm=dsqrt(zm)
      ELSE
        zm=2.*dsqrt(b)
      ENDIF

      DO 1 i=1,3
      z1=zm*(1.+x9(i))*0.5
      z2=zm*(1.-x9(i))*0.5
      quq=dsqrt(b+z1**2)-r
      IF (quq.LT.85.)xxt=xxt+a9(i)/(1.+exp(quq))
      quq=dsqrt(b+z2**2)-r
      IF (quq.LT.85.)xxt=xxt+a9(i)/(1.+exp(quq))
1     CONTINUE
      xxt=xxt*zm*0.5
      dt=0.
      DO 2 i=1,2
      z1=x5(i)+zm
      quq=dsqrt(b+z1**2)-r-x5(i)
      IF (quq.LT.85.)dt=dt+a5(i)/(exp(-x5(i))+exp(quq))
2     CONTINUE
      xxt=xxt+dt
      IF(debug.GE.3)WRITE (moniou,202)xxt
202   FORMAT(2x,'XXT=',e10.3)
      RETURN
      END
C=======================================================================

        FUNCTION xxtwdec(S,A,B)
c Kinematical function for two particle decay -
C light cone momentum share for
c the particle of mass squared A,
C B - partner's mass squared,
C S - two particle invariant mass
c-----------------------------------------------------------------------
        IMPLICIT DOUBLE PRECISION (a-h,o-z)
        INTEGER DEBUG
        COMMON /area43/ moniou
        COMMON /debug/  debug
        SAVE

        IF(debug.GE.2)WRITE (moniou,201)s,a,b
201     FORMAT(2x,'XXTWDEC: S=',e10.3,2x,'A=',e10.3,2x,'B=',e10.3)

        x=.5d0*(1.d0+(a-b)/s)
        dx=(x*x-a/s)
        IF(dx.GT.0.d0)THEN
          x=x+dsqrt(dx)
        ELSE
          x=dsqrt(a/s)
        ENDIF
        xxtwdec=x
        IF(debug.GE.3)WRITE (moniou,202)xxtwdec
202     FORMAT(2x,'XXTWDEC=',e10.3)
        RETURN
        END
C=======================================================================

      DOUBLE PRECISION FUNCTION gamfun_kk(Y)
C Gamma function : See Abramowitz, page 257, form. 6.4.40
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(a-h,o-z)
      double precision
     +     y,r,s,t,afspl,x,
     +     coef(10),pi,zerod,halfd,oned,twod,tend
      SAVE
C
      DATA coef/8.3333333333333334d-02,-2.7777777777777778d-03,
     .          7.9365079365079365d-04,-5.9523809523809524d-04,
     .          8.4175084175084175d-04,-1.9175269175269175d-03,
     .          6.4102564102564103d-03,-2.9550653594771242d-02,
     .          0.1796443723688306    ,-0.6962161084529506    /
      DATA pi/  3.141592653589793d0/
      DATA zerod/0.d0/,halfd/0.5d0/,oned/1.d0/,twod/2.d0/,tend/10.d0/
C
      x=y
      afspl=oned
      n=int(tend-y)
      DO 10 i=0,n
        afspl=afspl*x
        x=x+oned
10    CONTINUE
      r=(x-halfd)* log(x)-x+halfd* log(twod*pi)
      s=x
      t=zerod
      DO 20 i=1,10
        t=t+coef(i)/s
        s=s*x**2
20    CONTINUE
      gamfun_kk = exp(r+t)/afspl
      END
C=======================================================================

       BLOCK DATA psdata
c Constants for numerical integration (Gaussian weights)
c-----------------------------------------------------------------------
       IMPLICIT DOUBLE PRECISION (a-h,o-z)
       COMMON /ar3/ x1(7),a1(7)
       COMMON /ar5/ x5(2),a5(2)
       COMMON /ar8/ x2(4),a2
       COMMON /ar9/ x9(3),a9(3)

       DATA x1/.9862838d0,.9284349d0,.8272013d0,.6872929d0,.5152486d0,
     * .3191124d0,.1080549d0/
       DATA a1/.03511946d0,.08015809d0,.1215186d0,.1572032d0,
     * .1855384d0,.2051985d0,.2152639d0/
       DATA x2/.00960736d0,.0842652d0,.222215d0,.402455d0/
       DATA a2/.392699d0/
       DATA x5/.585786d0,3.41421d0/
       DATA a5/.853553d0,.146447d0/
       DATA x9/.93247d0,.661209d0,.238619d0/
       DATA a9/.171324d0,.360762d0,.467914d0/
       END

c following subroutine/function added 8/10/98 dh
C=======================================================================

      SUBROUTINE crossc_kk(NITER,GTOT,GPROD,GABS,GDD,GQEL,GCOH)
c Nucleus-nucleus (nucleus-hydrogen) interaction cross sections
c GTOT  - total cross section
c GPROD - production cross section (projectile diffraction included)
c GABS  - cut Pomerons cross section
c GDD   - projectile diffraction cross section
c GQEL  - quasielastic (projectile nucleon knock-out) cross section
c GCOH  - coherent (elastic with respect to the projectile) cross section
c (target diffraction is not treated explicitely and contributes to
c GDD, GQEL, GCOH).
c-------------------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
cdh   DIMENSION WABS(8),WDD(8),WQEL(8),WCOH(8),WTOT(8),
cdh  *WPROD(8),B0(8),XA(64,3),XB(64,3),AI(8)
      dimension wabs(20),wdd(20),wqel(20),wcoh(20),wtot(20),
     *wprod(20),b0(20),ai(20),xa(64,3),xb(64,3)
      COMMON /area1/  ia(2),icz,icp
      COMMON /area6/  pi,bm,am
      COMMON /area16/ cc(5)
      COMMON /ar3/    x1(7),a1(7)
      COMMON /ar5/    x5(2),a5(2)
      COMMON /ar9/    x9(3),a9(3)
      SAVE
      EXTERNAL qsran

      e1=exp(-1.d0)

cdh   DO I=1,3
cdh     B0(7-I)=BM*SQRT((1.+X9(I))/2.)
cdh     B0(I)=BM*SQRT((1.-X9(I))/2.)
cdh     AI(I)=A9(I)*(BM*AM)**2*5.*PI
cdh     AI(7-I)=AI(I)
      DO i=1,7
        b0(15-i)=bm*sqrt((1.+x1(i))/2.)
        b0(i)=bm*sqrt((1.-x1(i))/2.)
        ai(i)=a1(i)*(bm*am)**2*5.*pi
        ai(15-i)=ai(i)
      ENDDO

cdh   DO I=1,2
cdh     B0(6+I)=BM+X5(I)
cdh     AI(6+I)=A5(I)*B0(I)*EXP(X5(I))*20.*AM**2*PI
      DO i=1,3
        tp=(1.+x9(i))/2.
        tm=(1.-x9(i))/2.
        b0(14+i)=bm-log(tp)
        b0(21-i)=bm-log(tm)
        ai(14+i)=a9(i)*b0(14+i)/tp*10.*am**2*pi
        ai(21-i)=a9(i)*b0(21-i)/tm*10.*am**2*pi
      ENDDO

cdh   DO I=1,8
      DO i=1,20
        wabs(i)=0.
        wdd(i)=0.
        wqel(i)=0.
        wcoh(i)=0.
      ENDDO

      DO 1 nc=1,niter
        nt=0
        DO i=1,ia(2)
          nt=nt+int(qsran(b10)+cc(2))
        ENDDO
        IF(nt.EQ.0)GOTO 1
        IF(ia(1).EQ.1)THEN
          xa(1,1)=0.d0
          xa(1,2)=0.d0
          xa(1,3)=0.d0
        ELSE
          CALL psgea(ia(1),xa,1)
        ENDIF
        IF(ia(2).EQ.1)THEN
          xb(1,1)=0.d0
          xb(1,2)=0.d0
          xb(1,3)=0.d0
        ELSE
          CALL psgea(ia(2),xb,2)
        ENDIF

cdh     DO I=1,8
        DO i=1,20
          CALL gaucr(b0(i),gabs,gdd,gqel,gcoh,xa,xb,ia(1),nt)
          wabs(i)=wabs(i)+gabs
          wdd(i)=wdd(i)+gdd
          wqel(i)=wqel(i)+gqel
          wcoh(i)=wcoh(i)+gcoh
        ENDDO
1     CONTINUE

      gabs=0.
      gdd=0.
      gqel=0.
      gcoh=0.
cdh   DO I=1,8
      DO i=1,20
        wabs(i)=wabs(i)/niter
        wdd(i)=wdd(i)/niter
        wqel(i)=wqel(i)/niter
        wcoh(i)=wcoh(i)/niter
        wprod(i)=wabs(i)+wdd(i)
        wtot(i)=wprod(i)+wqel(i)+wcoh(i)
        gabs=gabs+ai(i)*wabs(i)
        gdd=gdd+ai(i)*wdd(i)
        gqel=gqel+ai(i)*wqel(i)
        gcoh=gcoh+ai(i)*wcoh(i)
      ENDDO
      gprod=gabs+gdd
      gtot=gprod+gqel+gcoh
      RETURN
      END

c following subroutine/function added 8/10/98 dh
C=======================================================================

      SUBROUTINE gaucr(B,GABS,GDD,GQEL,GCOH,XA,XB,IA,NT)
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      dimension xa(64,3),xb(64,3)
      COMMON /area15/ fp(5),rq(5),cd(5)
      COMMON /area16/ cc(5)
      SAVE

      gabs=1.
      gdd=1.
      gqel=1.
      gcoh=1.
      DO n=1,ia
        vv=1.d0-dsqrt(psv(xa(n,1)+b,xa(n,2),xb,nt))
        gabs=gabs*(1.-cc(2)*(1.-vv*vv))
        gdd=gdd*(1.-cc(2)*(1.-vv))**2
        gqel=gqel*(1.-2.d0*cc(2)*(1.-vv))
        gcoh=gcoh*(1.-cc(2)*(1.-vv))
      ENDDO
      gcoh=1.-2.*gcoh+gqel
      gqel=gdd-gqel
      gdd=gabs-gdd
      gabs=1.-gabs
      RETURN
      END

c following subroutine/function added 8/10/98 dh
C=======================================================================

      DOUBLE PRECISION FUNCTION sectnu(E0N,IAP,IAT)
c Nucleus-nucleus (nucleus-hydrogen) particle production cross section
c E0N - lab. energy per projectile nucleon,
c IAP - projectile mass number (2<IAP<64)
c IAT - target mass number     (1<IAT<64)
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (a-h,o-z)
      dimension wk(3),wa(3),wb(3)
      COMMON /area48/ asect(10,6,4)
      SAVE

      sectnu=0.d0
      ye=dlog10(e0n)
      IF(ye.LT.1.d0)ye=1.d0
      je=int(ye)
      IF(je.GT.8)je=8

      wk(2)=ye-je
      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)

      ya=iap
      ya=dlog(ya/2.d0)/.69315d0+1.d0
      ja=min(int(ya),4)
      wa(2)=ya-ja
      wa(3)=wa(2)*(wa(2)-1.d0)*.5d0
      wa(1)=1.d0-wa(2)+wa(3)
      wa(2)=wa(2)-2.d0*wa(3)

      yb=iat
      yb=dlog(yb)/1.38629d0+1.d0
      jb=min(int(yb),2)
      wb(2)=yb-jb
      wb(3)=wb(2)*(wb(2)-1.d0)*.5d0
      wb(1)=1.d0-wb(2)+wb(3)
      wb(2)=wb(2)-2.d0*wb(3)

      DO i=1,3
      DO m=1,3
      DO l=1,3
        sectnu=sectnu+asect(je+i-1,ja+m-1,jb+l-1)*wk(i)*wa(m)*wb(l)
      ENDDO
      ENDDO
      ENDDO
      sectnu=exp(sectnu)
      RETURN
      END