Functions/Subroutines
subroutine	psaini

function	psapint (X, J, L)

subroutine	psasetc

function	psbint (QQ, S, M, L)

function	psborn (QQ, S, IQ1, IQ2)

subroutine	pscajet (QQ, IQ1, QV, ZV, QM, IQV, LDAU, LPAR, JQ)

subroutine	psconf

subroutine	pscs (C, S)

subroutine	psdeftr (S, EP, EY)

subroutine	psdefrot (EP, S0X, C0X, S0, C0)

function	psdr (X, Y)

function	psfap (X, J, L)

function	psfaz (Z, FSOFT, FHARD, FSHARD)

function	psfborn (S, T, IQ1, IQ2)

function	psfsh (S, Z, ICZ, IQQ)

function	psftild (Z, ICZ)

subroutine	psgea (IA, XA, JJ)

function	psgint (Z)

function	pshard (S, ICZ)

subroutine	pshot (WP0, WM0, Z, IPC, EPC, IZP, IZT, ICZ, IQQ)

subroutine	psjdef (IPJ, IPJ1, EPJ, EPJ1, JFL)

function	psjet (Q1, Q2, S, S2MIN, J, L)

function	psjet1 (Q1, Q2, S, S2MIN, J, L)

function	psjint (Q1, Q2, S, M, L)

subroutine	psjint0 (S, SJ, SJB, M, L)

function	psjint1 (Q1, Q2, S, M, L)

function	pslam (S, A, B)

function	psnorm (EP)

subroutine	psrec (EP, QV, ZV, QM, IQV, LDAU, LPAR, IQJ, EQJ, JFL, JQ)

function	psrejs (S, Z, IQQ)

function	psrejv (S)

function	psrjint (YJ, Z0, IQQ)

function	psroot (QLMAX, G, J)

subroutine	psrotat (EP, S0X, C0X, S0, C0)

function	psqint (QLMAX, G, J)

subroutine	psshar (LS, NHP, NW, NT)

subroutine	pstrans (EP, EY)

subroutine	pstrans1 (EP, EY)

function	psudint (QLMAX, J)

function	psuds (Q, J)

function	psudt (QMAX, J)

function	psv (X, Y, XB, IB)

subroutine	psvdef (ICH, IC1, ICZ)

function	pszsim (QQ, J)

subroutine	ixxdef (ICH, IC1, IC2, ICZ)

function	ixxson (NS, AW, G)

subroutine	xxaini (E0N, ICP0, IAP, IAT)

subroutine	xxaset

subroutine	xxddfr (WP0, WM0, ICP, ICT)

subroutine	xxdec2 (EP, EP1, EP2, WW, A, B)

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

subroutine	xxdpr (WP0, WM0, ICP, ICT, LQ2)

subroutine	xxdtg (WP0, WM0, ICP, ICT, LQ1)

subroutine	xxfau (B, GZ)

subroutine	xxfrag (SA, NA, RC)

subroutine	xxfragm (NS, XA)

subroutine	xxfz (B, GZ)

subroutine	xxgau (GZ)

subroutine	xxgau1 (GZ)

subroutine	xxgener (WP0, WM0, EY0, S0X, C0X, S0, C0, IC1, IC2)

subroutine	xxjetsim

subroutine	xxreg (EP0, IC)

function	xxrot (S, B)

subroutine	xxstr (WPI0, WMI0, WP0, WM0, IC10, IC120, IC210, IC20)

function	xxt (B)

function	xxtwdec (S, A, B)

double precision function	gamfun_kk (Y)

subroutine	crossc_kk (NITER, GTOT, GPROD, GABS, GDD, GQEL, GCOH)

subroutine	gaucr (B, GABS, GDD, GQEL, GCOH, XA, XB, IA, NT)

double precision function	sectnu (E0N, IAP, IAT)

Function/Subroutine Documentation

◆ crossc_kk()

subroutine crossc_kk	(	NITER,
		GTOT,
		GPROD,
		GABS,
		GDD,
		GQEL,
		GCOH
	)

Definition at line 7352 of file qgsjet01.f.

References a, d0, gaucr(), h, i, nc, o, pi, psgea(), qsran(), x1(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ gamfun_kk()

double precision function gamfun_kk ( double precision Y )

Definition at line 7293 of file qgsjet01.f.

References a, d, d0, h, i, n, o, pi, r, t, x, x1(), x2(), y, and z.

Referenced by psfsh(), and pshard().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ gaucr()

subroutine gaucr	(		B,
			GABS,
			GDD,
			GQEL,
			GCOH,
		dimension(64,3)	XA,
		dimension(64,3)	XB,
			IA,
			NT
	)

Definition at line 7467 of file qgsjet01.f.

References a, b, d0, h, n, o, psv(), and z.

Referenced by crossc_kk().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ ixxdef()

subroutine ixxdef	(	ICH,
		IC1,
		IC2,
		ICZ
	)

Definition at line 5343 of file qgsjet01.f.

References a, d0, h, is, o, qsran(), x, and z.

Referenced by psshar().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ ixxson()

function ixxson	(	NS,
		AW,
		G
	)

Definition at line 5406 of file qgsjet01.f.

References a, e10, g, h, i, j, o, x, and z.

Referenced by xxfragm().

 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

Here is the caller graph for this function:

◆ psaini()

subroutine psaini ( )

Definition at line 42 of file qgsjet01.f.

References a, crossc_kk(), d, d0, e10, h, i, j, m, n, o, pi, psborn(), psfsh(), pshard(), psjet(), psjet1(), psrejs(), psrejv(), psroot(), psudt(), x, xxaini(), xxfz(), xxgau(), xxgau1(), and z.

Referenced by qgs01init().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psapint()

function psapint	(	X,
		J,
		L
	)

Definition at line 613 of file qgsjet01.f.

References a, d0, e10, h, j, o, x, and z.

Referenced by psudt().

 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

Here is the caller graph for this function:

◆ psasetc()

subroutine psasetc ( )

Definition at line 647 of file qgsjet01.f.

References a, d0, h, o, x, and z.

Referenced by qgs01init().

 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

Here is the caller graph for this function:

◆ psbint()

function psbint	(	QQ,
		S,
		M,
		L
	)

Definition at line 738 of file qgsjet01.f.

References a, d0, e10, h, i, m, o, x, and z.

Referenced by pshot().

 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

Here is the caller graph for this function:

◆ psborn()

function psborn	(	QQ,
		S,
		IQ1,
		IQ2
	)

Definition at line 847 of file qgsjet01.f.

References a, d0, e10, h, i, m, o, pi, psfborn(), t, x, x1(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pscajet()

subroutine pscajet	(		QQ,
			IQ1,
		dimension(30,50)	QV,
		dimension(30,50)	ZV,
		dimension(30,50)	QM,
		dimension(30,50)	IQV,
		dimension(30,49)	LDAU,
		dimension(30,50)	LPAR,
			JQ
	)

Definition at line 890 of file qgsjet01.f.

References a, d0, e10, h, i, o, psfap(), psqint(), psudint(), pszsim(), qsran(), x, and z.

Referenced by pshot().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psconf()

subroutine psconf ( )

Definition at line 1019 of file qgsjet01.f.

References a, b, d0, e10, eh, h, i, m, n, o, pi, psdr(), psfaz(), psgea(), psshar(), psv(), qsran(), x, xxdpr(), xxdtg(), xxfragm(), y, and z.

Referenced by qgs01init().

 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//////////////

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pscs()

subroutine pscs	(	C,
		S
	)

Definition at line 1461 of file qgsjet01.f.

References a, c, d0, e10, h, o, qsran(), x, and z.

Referenced by psgea(), pshot(), psrec(), xxddfr(), xxdec2(), xxdec3(), xxdpr(), xxdtg(), and xxgener().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psdefrot()

subroutine psdefrot	(	dimension(4)	EP,
			S0X,
			C0X,
			S0,
			C0
	)

Definition at line 1525 of file qgsjet01.f.

References a, d0, e10, h, o, pt, x, and z.

Referenced by psrec(), and xxjetsim().

 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

Here is the caller graph for this function:

◆ psdeftr()

subroutine psdeftr	(		S,
		dimension(4)	EP,
		dimension(3)	EY
	)

Definition at line 1488 of file qgsjet01.f.

References a, d, d0, e10, h, i, o, x, and z.

Referenced by pshot(), xxdec2(), xxdec3(), xxdpr(), xxdtg(), xxgener(), and xxjetsim().

 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

Here is the caller graph for this function:

◆ psdr()

function psdr	(	X,
		Y
	)

Definition at line 1570 of file qgsjet01.f.

References a, e10, h, o, x, y, and z.

Referenced by psconf(), and psv().

 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

Here is the caller graph for this function:

◆ psfap()

function psfap	(	X,
		J,
		L
	)

Definition at line 1589 of file qgsjet01.f.

References a, d0, e10, h, j, o, x, and z.

Referenced by pscajet(), pshot(), psjet(), psjet1(), and pszsim().

 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

Here is the caller graph for this function:

◆ psfaz()

function psfaz	(		Z,
			FSOFT,
		dimension(3)	FHARD,
			FSHARD
	)

Definition at line 1623 of file qgsjet01.f.

References a, d0, e10, h, i, o, x, and z.

Referenced by psconf(), psv(), and xxfz().

 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

Here is the caller graph for this function:

◆ psfborn()

function psfborn	(	S,
		T,
		IQ1,
		IQ2
	)

Definition at line 1674 of file qgsjet01.f.

References a, d0, e10, h, o, t, x, and z.

Referenced by psborn(), and pshot().

 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

Here is the caller graph for this function:

◆ psfsh()

function psfsh	(	S,
		Z,
		ICZ,
		IQQ
	)

Definition at line 1716 of file qgsjet01.f.

References a, d0, e10, gamfun_kk(), h, i, j, m, o, pi, psftild(), psgint(), psjint0(), x, x1(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psftild()

function psftild	(	Z,
		ICZ
	)

Definition at line 1815 of file qgsjet01.f.

References a, d0, e10, h, i, m, o, x, x1(), and z.

Referenced by psfsh().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psgea()

subroutine psgea	(		IA,
		dimension(64,3)	XA,
			JJ
	)

Definition at line 1846 of file qgsjet01.f.

References a, c, d0, e10, h, i, j, o, pscs(), qsran(), x, and z.

Referenced by crossc_kk(), and psconf().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psgint()

function psgint ( Z )

Definition at line 1912 of file qgsjet01.f.

References a, e10, f, h, i, o, x, x1(), and z.

Referenced by psfsh(), pshard(), pshot(), psrejs(), and psrejv().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pshard()

function pshard	(	S,
		ICZ
	)

Definition at line 1936 of file qgsjet01.f.

References a, d0, e10, gamfun_kk(), h, i, j, m, o, pi, psgint(), psjint0(), x, x1(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pshot()

subroutine pshot	(		WP0,
			WM0,
			Z,
		dimension(2,2)	IPC,
		dimension(8,2)	EPC,
			IZP,
			IZT,
			ICZ,
			IQQ
	)

Definition at line 2014 of file qgsjet01.f.

References a, cos, d0, e10, h, i, m, o, pi, psbint(), pscajet(), pscs(), psdeftr(), psfap(), psfborn(), psgint(), psjdef(), psjint(), psjint0(), psjint1(), psnorm(), psrec(), pstrans(), psuds(), psvdef(), pt, qsran(), x, xxtwdec(), and z.

Referenced by psshar().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psjdef()

subroutine psjdef	(		IPJ,
			IPJ1,
		dimension(4)	EPJ,
		dimension(4)	EPJ1,
			JFL
	)

Definition at line 2991 of file qgsjet01.f.

References a, e10, h, i, o, psnorm(), x, and z.

Referenced by pshot(), psrec(), and psshar().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psjet()

function psjet	(	Q1,
		Q2,
		S,
		S2MIN,
		J,
		L
	)

Definition at line 3065 of file qgsjet01.f.

References a, cos, d0, e10, h, i, j, m, o, p, pi, psfap(), psjint(), psuds(), x, x1(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psjet1()

function psjet1	(	Q1,
		Q2,
		S,
		S2MIN,
		J,
		L
	)

Definition at line 3155 of file qgsjet01.f.

References a, cos, d0, e10, h, i, j, m, o, p, pi, psfap(), psjint1(), psuds(), x, x1(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psjint()

function psjint	(	Q1,
		Q2,
		S,
		M,
		L
	)

Definition at line 3246 of file qgsjet01.f.

References a, d0, e10, h, i, j, m, o, x, and z.

Referenced by pshot(), and psjet().

 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

Here is the caller graph for this function:

◆ psjint0()

subroutine psjint0	(	S,
		SJ,
		SJB,
		M,
		L
	)

Definition at line 3390 of file qgsjet01.f.

References a, d0, e10, h, m, o, x, and z.

Referenced by psfsh(), pshard(), pshot(), psrejs(), and psrejv().

 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

Here is the caller graph for this function:

◆ psjint1()

function psjint1	(	Q1,
		Q2,
		S,
		M,
		L
	)

Definition at line 3443 of file qgsjet01.f.

References a, d0, e10, h, i, j, m, o, x, and z.

Referenced by pshot(), and psjet1().

 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

Here is the caller graph for this function:

◆ pslam()

function pslam	(	S,
		A,
		B
	)

Definition at line 3589 of file qgsjet01.f.

References a, b, d0, e10, h, o, x, and z.

Referenced by xxddfr(), xxdec2(), xxdpr(), xxdtg(), and xxgener().

 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

Here is the caller graph for this function:

◆ psnorm()

function psnorm ( dimension(4) EP )

Definition at line 3611 of file qgsjet01.f.

References a, e10, h, i, o, x, and z.

Referenced by pshot(), psjdef(), xxgener(), and xxjetsim().

 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

Here is the caller graph for this function:

◆ psqint()

function psqint	(	QLMAX,
		G,
		J
	)

Definition at line 4134 of file qgsjet01.f.

References a, d0, e10, g, h, i, j, o, psudint(), x, and z.

Referenced by pscajet().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psrec()

subroutine psrec	(	dimension(4)	EP,
		dimension(30,50)	QV,
		dimension(30,50)	ZV,
		dimension(30,50)	QM,
		dimension(30,50)	IQV,
		dimension(30,49)	LDAU,
		dimension(30,50)	LPAR,
		dimension(2)	IQJ,
		dimension(4,2)	EQJ,
			JFL,
			JQ
	)

Definition at line 3633 of file qgsjet01.f.

References a, c, d0, e10, h, i, m, o, pscs(), psdefrot(), psjdef(), psrotat(), qsran(), x, and z.

Referenced by pshot().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psrejs()

function psrejs	(	S,
		Z,
		IQQ
	)

Definition at line 3884 of file qgsjet01.f.

References a, d0, e10, h, i, j, m, o, psgint(), psjint0(), x, x1(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psrejv()

function psrejv ( S )

Definition at line 3944 of file qgsjet01.f.

References a, d0, e10, h, o, psgint(), psjint0(), x, and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psrjint()

function psrjint	(	YJ,
		Z0,
		IQQ
	)

Definition at line 3977 of file qgsjet01.f.

References a, d, d0, e10, h, i, o, x, z, and z0.

Referenced by psshar().

 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

Here is the caller graph for this function:

◆ psroot()

function psroot	(	QLMAX,
		G,
		J
	)

Definition at line 4057 of file qgsjet01.f.

References a, d, d0, e10, g, h, j, o, psudint(), x, and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psrotat()

subroutine psrotat	(	dimension(4)	EP,
			S0X,
			C0X,
			S0,
			C0
	)

Definition at line 4106 of file qgsjet01.f.

References a, e10, h, o, x, and z.

Referenced by psrec(), and xxgener().

 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

Here is the caller graph for this function:

◆ psshar()

subroutine psshar	(	LS,
		NHP,
		NW,
		NT
	)

Definition at line 4182 of file qgsjet01.f.

References a, d0, e10, h, i, is, ixxdef(), j, o, pshot(), psjdef(), psrjint(), qsran(), x, xxddfr(), xxdpr(), xxdtg(), xxjetsim(), xxreg(), xxstr(), and z.

Referenced by psconf().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pstrans()

subroutine pstrans	(	dimension(4)	EP,
		dimension(3)	EY
	)

Definition at line 5041 of file qgsjet01.f.

References a, d0, e10, h, i, o, x, and z.

Referenced by pshot(), xxdec2(), xxdec3(), xxgener(), and xxreg().

 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

Here is the caller graph for this function:

◆ pstrans1()

subroutine pstrans1	(	dimension(4)	EP,
		dimension(3)	EY
	)

Definition at line 5071 of file qgsjet01.f.

References a, d0, e10, h, i, o, x, and z.

Referenced by xxjetsim().

 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

Here is the caller graph for this function:

◆ psudint()

function psudint	(	QLMAX,
		J
	)

Definition at line 5101 of file qgsjet01.f.

References a, d0, e10, h, j, o, x, and z.

Referenced by pscajet(), psqint(), and psroot().

 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

Here is the caller graph for this function:

◆ psuds()

function psuds	(	Q,
		J
	)

Definition at line 5142 of file qgsjet01.f.

References a, d0, e10, h, j, o, pi, x, and z.

Referenced by pshot(), psjet(), and psjet1().

 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

Here is the caller graph for this function:

◆ psudt()

function psudt	(	QMAX,
		J
	)

Definition at line 5178 of file qgsjet01.f.

References a, d0, e10, h, i, j, m, o, psapint(), x, x1(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psv()

function psv	(		X,
			Y,
		dimension(64,3)	XB,
			IB
	)

Definition at line 5223 of file qgsjet01.f.

References a, d0, e10, h, m, o, psdr(), psfaz(), x, y, and z.

Referenced by gaucr(), and psconf().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ psvdef()

subroutine psvdef	(	ICH,
		IC1,
		ICZ
	)

Definition at line 5259 of file qgsjet01.f.

References a, d0, h, is, o, qsran(), x, and z.

Referenced by pshot().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ pszsim()

function pszsim	(	QQ,
		J
	)

Definition at line 5301 of file qgsjet01.f.

References a, d0, e10, h, j, o, psfap(), qsran(), x, and z.

Referenced by pscajet().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ sectnu()

double precision function sectnu	(	E0N,
		IAP,
		IAT
	)

Definition at line 7496 of file qgsjet01.f.

References a, d0, h, i, m, o, and z.

 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

◆ xxaini()

subroutine xxaini	(	E0N,
		ICP0,
		IAP,
		IAT
	)

Definition at line 5435 of file qgsjet01.f.

References a, d0, e10, h, i, m, o, pi, x, and z.

Referenced by psaini(), and qgs01init().

 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

Here is the caller graph for this function:

◆ xxaset()

subroutine xxaset ( )

Definition at line 5572 of file qgsjet01.f.

References a, d0, h, o, pi, x, and z.

Referenced by qgs01init().

 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

Here is the caller graph for this function:

◆ xxddfr()

subroutine xxddfr	(	WP0,
		WM0,
		ICP,
		ICT
	)

Definition at line 5693 of file qgsjet01.f.

References a, c, d0, e10, h, i, is, o, pscs(), pslam(), pt, qsran(), x, xxgener(), xxreg(), xxtwdec(), and z.

Referenced by psshar().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxdec2()

subroutine xxdec2	(	dimension(4)	EP,
		dimension(4)	EP1,
		dimension(4)	EP2,
			WW,
			A,
			B
	)

Definition at line 5845 of file qgsjet01.f.

References a, b, c, d0, h, i, o, pscs(), psdeftr(), pslam(), pstrans(), pt, qsran(), x, and z.

Referenced by xxdec3().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxdec3()

subroutine xxdec3	(	dimension(4)	EP,
		dimension(4)	EP1,
		dimension(4)	EP2,
		dimension(4)	EP3,
			SWW,
			AM1,
			AM2,
			AM3
	)

Definition at line 5881 of file qgsjet01.f.

References a, c, d0, h, i, o, pscs(), psdeftr(), pstrans(), pt, qsran(), x, xxdec2(), and z.

 
 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

Here is the call graph for this function:

◆ xxdpr()

subroutine xxdpr	(	WP0,
		WM0,
		ICP,
		ICT,
		LQ2
	)

Definition at line 5930 of file qgsjet01.f.

References a, c, d0, e10, h, i, is, o, pscs(), psdeftr(), pslam(), pt, qsran(), x, xxgener(), xxreg(), xxtwdec(), and z.

Referenced by psconf(), and psshar().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxdtg()

subroutine xxdtg	(	WP0,
		WM0,
		ICP,
		ICT,
		LQ1
	)

Definition at line 6140 of file qgsjet01.f.

References a, d0, e10, h, i, is, o, pscs(), psdeftr(), pslam(), pt, qsran(), x, xxgener(), xxreg(), xxtwdec(), and z.

Referenced by psconf(), and psshar().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxfau()

subroutine xxfau	(		B,
		dimension(3)	GZ
	)

Definition at line 6270 of file qgsjet01.f.

References a, b, d0, h, o, x, xxfz(), and z.

Referenced by xxgau(), and xxgau1().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxfrag()

subroutine xxfrag	(	dimension(64,3)	SA,
			NA,
			RC
	)

Definition at line 6307 of file qgsjet01.f.

References a, d0, e10, h, i, j, m, ng, o, x, and z.

Referenced by xxfragm().

 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

Here is the caller graph for this function:

◆ xxfragm()

subroutine xxfragm	(		NS,
		dimension(64,3)	XA
	)

Definition at line 6368 of file qgsjet01.f.

References a, d0, e10, h, i, ixxson(), o, qsran(), x, xxfrag(), and z.

Referenced by psconf().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxfz()

subroutine xxfz	(		B,
		dimension(2)	GZ
	)

Definition at line 6456 of file qgsjet01.f.

References a, b, d0, h, m, o, psfaz(), x, x1(), xxrot(), and z.

Referenced by psaini(), and xxfau().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxgau()

subroutine xxgau ( dimension(3) GZ )

Definition at line 6512 of file qgsjet01.f.

References a, b, d0, h, i, m, o, pi, r, x, x1(), xxfau(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxgau1()

subroutine xxgau1 ( dimension(3) GZ )

Definition at line 6546 of file qgsjet01.f.

References a, b, d0, h, i, o, pi, r, x, xxfau(), and z.

Referenced by psaini().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxgener()

subroutine xxgener	(		WP0,
			WM0,
		dimension(3)	EY0,
			S0X,
			C0X,
			S0,
			C0,
			IC1,
			IC2
	)

Definition at line 6574 of file qgsjet01.f.

References a, c, d0, e10, h, i, is, j, o, pscs(), psdeftr(), pslam(), psnorm(), psrotat(), pstrans(), qsran(), x, xxreg(), xxtwdec(), and z.

Referenced by xxddfr(), xxdpr(), xxdtg(), xxjetsim(), and xxstr().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxjetsim()

subroutine xxjetsim ( )

Definition at line 7025 of file qgsjet01.f.

References a, h, i, o, psdefrot(), psdeftr(), psnorm(), pstrans1(), x, xxgener(), and z.

Referenced by psshar().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxreg()

subroutine xxreg	(	dimension(4)	EP0,
			IC
	)

Definition at line 7066 of file qgsjet01.f.

References a, e10, h, i, o, pstrans(), pt, x, and z.

Referenced by psshar(), xxddfr(), xxdpr(), xxdtg(), and xxgener().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxrot()

function xxrot	(	S,
		B
	)

Definition at line 7111 of file qgsjet01.f.

References a, b, e10, h, i, o, x, x2(), xxt(), and z.

Referenced by xxfz().

 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxstr()

subroutine xxstr	(	WPI0,
		WMI0,
		WP0,
		WM0,
		IC10,
		IC120,
		IC210,
		IC20
	)

Definition at line 7138 of file qgsjet01.f.

References a, cos, d0, e10, h, i, o, pi, qsran(), x, xxgener(), and z.

Referenced by psshar().

 **************************************************
 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

Here is the call graph for this function:

Here is the caller graph for this function:

◆ xxt()

function xxt ( B )

Definition at line 7217 of file qgsjet01.f.

References a, b, e10, h, i, o, pi, r, x, and z.

Referenced by xxrot().

 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

Here is the caller graph for this function:

◆ xxtwdec()

function xxtwdec	(	S,
		A,
		B
	)

Definition at line 7263 of file qgsjet01.f.

References a, b, d0, dx, e10, h, o, x, and z.

Referenced by pshot(), xxddfr(), xxdpr(), xxdtg(), and xxgener().

 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

Here is the caller graph for this function:

Functions/Subroutines

Function/Subroutine Documentation

◆ crossc_kk()

◆ gamfun_kk()

◆ gaucr()

◆ ixxdef()

◆ ixxson()

◆ psaini()

◆ psapint()

◆ psasetc()

◆ psbint()

◆ psborn()

◆ pscajet()

◆ psconf()

◆ pscs()

◆ psdefrot()

◆ psdeftr()

◆ psdr()

◆ psfap()

◆ psfaz()

◆ psfborn()

◆ psfsh()

◆ psftild()

◆ psgea()

◆ psgint()

◆ pshard()

◆ pshot()

◆ psjdef()

◆ psjet()

◆ psjet1()

◆ psjint()

◆ psjint0()

◆ psjint1()

◆ pslam()

◆ psnorm()

◆ psqint()

◆ psrec()

◆ psrejs()

◆ psrejv()

◆ psrjint()

◆ psroot()

◆ psrotat()

◆ psshar()

◆ pstrans()

◆ pstrans1()

◆ psudint()

◆ psuds()

◆ psudt()

◆ psv()

◆ psvdef()

◆ pszsim()

◆ sectnu()

◆ xxaini()

◆ xxaset()

◆ xxddfr()

◆ xxdec2()

◆ xxdec3()

◆ xxdpr()

◆ xxdtg()

◆ xxfau()

◆ xxfrag()

◆ xxfragm()

◆ xxfz()

◆ xxgau()

◆ xxgau1()

◆ xxgener()

◆ xxjetsim()

◆ xxreg()

◆ xxrot()

◆ xxstr()

◆ xxt()

◆ xxtwdec()