source: trunk/MagicSoft/Simulation/Corsika/Mmcs/QGSJET.f@ 12392

Last change on this file since 12392 was 286, checked in by harald, 25 years ago
This is the start point for further developments of the Magic Monte Carlo Simulation written by Jose Carlos Gonzales. Now it is under control of one CVS repository for the whole collaboration. Everyone should use this CVS repository for further developments.
File size: 230.9 KB
Line 
1
2C======================================================================C
3C C
4C QQQ GGG SSSS JJJJJJJ EEEEEEE TTTTTTT C
5C Q Q G G S S J E T C
6C Q Q G S J E T C
7C Q Q G GGG SSSS J EEEEE T C
8C Q Q Q G G S J E T C
9C Q Q G G S S J J E T C
10C QQQ QQ GGG SSSS JJJ EEEEEEE T C
11C C
12C C
13C----------------------------------------------------------------------C
14C C
15C QUARK - GLUON - STRING - MODEL C
16C C
17C HIGH ENERGY HADRON INTERACTION PROGRAM C
18C C
19C BY C
20C C
21C N. N. KALMYKOV AND S. S. OSTAPCHENKO C
22C C
23C MOSCOW STATE UNIVERSITY, MOSCOW, RUSSIA C
24C e-mail: serg@eas.npi.msu.su C
25C----------------------------------------------------------------------C
26C SUBROUTINE VERSION TO BE LINKED WITH C
27C C O R S I K A C
28C KARLSRUHE AIR SHOWER SIMULATION PROGRAM C
29C WITH MODIFICATIONS C
30C BY C
31C D. HECK IK3 FZK KARLSRUHE C
32C----------------------------------------------------------------------C
33C last modification: feb 21, 1997 C
34C----------------------------------------------------------------------C
35
36C=======================================================================
37
38 SUBROUTINE PSAINI
39c Common initialization procedure
40c-----------------------------------------------------------------------
41 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42 INTEGER DEBUG
43 CHARACTER *7 TY
44 LOGICAL LCALC,LSECT
45********************************************
46 DIMENSION EQ(17),MIJ(17,17,4),NIJ(17,17,4),CSJET(17,17,68),
47 *CS1(17,17,68),GZ0(2),GZ1(3)
48 COMMON /XSECT/ GSECT(10,5,4)
49 COMMON /AREA1/ IA(2),ICZ,ICP
50 COMMON /AREA5/ RD(2),CR1(2),CR2(2),CR3(2)
51********************************************
52 COMMON /AREA6/ PI,BM,AM
53 COMMON /AREA7/ RP1
54 COMMON /AREA10/ STMASS,AM0,AMN,AMK,AMC,AMLAMC,AMLAM,AMETA
55 COMMON /AREA15/ FP(5),RQ(5),CD(5)
56 COMMON /AREA16/ CC(5)
57 COMMON /AREA17/ DEL,RS,RS0,FS,ALFP,RR,SH,DELH
58 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
59 COMMON /AREA19/ AHL(5)
60********************************************
61 COMMON /AREA22/ SJV0,FJS0(5,3)
62********************************************
63 COMMON /AREA23/ RJV(50)
64 COMMON /AREA24/ RJS(50,5,10)
65 COMMON /AREA27/ FP0(5)
66 COMMON /AREA28/ ARR(4)
67 COMMON /AREA29/ CSTOT(17,17,68)
68 COMMON /AREA30/ CS0(17,17,68)
69 COMMON /AREA31/ CSBORN(17,68)
70 COMMON /AREA32/ CSQ(17,2,2),CSBQ(17,2,2)
71 COMMON /AREA33/ FSUD(10,2)
72 COMMON /AREA34/ QRT(10,101,2)
73 COMMON /AREA35/ SJV(10,5),FJS(10,5,15)
74 COMMON /AREA39/ JCALC
75 COMMON /AREA41/ TY(5)
76 COMMON /AREA43/ MONIOU
77 COMMON /DEBUG/ DEBUG
78********************************************
79 COMMON /AREA44/ GZ(10,5,4)
80c Auxiliary common blocks to calculate hadron-nucleus cross-sections
81 COMMON /AR1/ ANORM
82 COMMON /AR2/ RRR,RRRM
83********************************************
84
85c-------------------------------------------------
86 WRITE(MONIOU,100)
87 100 FORMAT(' ',
88 * '====================================================',
89 * /,' ','| |',
90 * /,' ','| QUARK GLUON STRING JET MODEL |',
91 * /,' ','| |',
92 * /,' ','| HADRONIC INTERACTION MONTE CARLO |',
93 * /,' ','| BY |',
94 * /,' ','| N.N. KALMYKOV AND S.S. OSTAPCHENKO |',
95 * /,' ','| |',
96 * /,' ','| e-mail: serg@eas.npi.msu.su |',
97 * /,' ','| |',
98 * /,' ','| last modification: feb. 21, 1997 by D. Heck |',
99 * /,' ','====================================================',
100 * /)
101 IF(DEBUG.GE.1)WRITE (MONIOU,210)
102210 FORMAT(2X,'PSAINI - MAIN INITIALIZATION PROCEDURE')
103
104c AHL(i) - parameter for the energy sharing procedure (govern leading hadronic state
105c inelasticity for primary pion, nucleon, kaon, D-meson, Lambda_C correspondingly)
106 AHL(1)=1.D0-2.D0*ARR(1)
107 AHL(2)=1.D0-ARR(1)-ARR(2)
108 AHL(3)=1.D0-ARR(1)-ARR(3)
109 AHL(4)=1.D0-ARR(1)-ARR(4)
110 AHL(5)=AHL(2)+ARR(1)-ARR(4)
111
112c-------------------------------------------------
113c 1/CC(i) = C_i - shower enhancement coefficients for one vertex
114c (C_ab=C_a*C_b) (i - ICZ)
115 CC(2)=1.D0/DSQRT(CD(2))
116 CC(1)=1.D0/CC(2)/CD(1)
117 CC(3)=1.D0/CC(2)/CD(3)
118 CC(4)=1.D0/CC(2)/CD(4)
119 CC(5)=1.D0/CC(2)/CD(5)
120
121c FP0(i) - vertex constant (FP_ij=FP0_i*FP0_j) for pomeron-hadron interaction (i - ICZ)
122 FP0(2)=DSQRT(FP(2))
123 FP0(1)=FP(1)/FP0(2)
124 FP0(3)=FP(3)/FP0(2)
125 FP0(4)=FP(4)/FP0(2)
126 FP0(5)=FP(5)/FP0(2)
127
128c SH - hard interaction effective squared (SH=pi*R_h>2, R_h>2=4/Q0>2)
129 SH=4.D0/QT0*PI
130c Auxiliary constants for the hard interaction
131 AQT0=DLOG(4.D0*QT0)
132 QLOG=DLOG(QT0/ALM)
133 QLL=DLOG(QLOG)
134
135********************************************
136 INQUIRE(FILE='QGSDATA4',EXIST=LCALC)
137 IF(LCALC)then
138 IF(DEBUG.GE.1)WRITE (MONIOU,211)
139211 FORMAT(2X,'PSAINI: HARD CROSS SECTION RATIOS READOUT FROM THE'
140 * ' FILE QGSDATA4')
141 OPEN(1,FILE='QGSDATA4',STATUS='OLD')
142 READ (1,*)CSBORN,CS0,CSTOT,CSQ,CSBQ,
143 * FSUD,QRT,SJV,FJS,RJV,RJS,GZ,GSECT
144 CLOSE(1)
145 ELSE
146********************************************
147
148 IF(DEBUG.GE.1)WRITE (MONIOU,201)
149201 FORMAT(2X,'PSAINI: HARD CROSS SECTIONS CALCULATION')
150c--------------------------------------------------
151c Hard pomeron inclusive cross sections calculation
152c--------------------------------------------------
153c EQ(I) - energy squared tabulation (Q0>2, 4*Q0>2, ...)
154 DO 1 I=1,17
1551 EQ(I)=QT0*4.D0**FLOAT(I-1)
156
157 DO 2 I=1,17
158c QI - effective momentum (Qt**2/(1-z)**2) cutoff for the Born process
159 QI=EQ(I)
160c M, L define parton types (1-g, 2-q)
161 DO 2 M=1,2
162 DO 2 L=1,2
163c K defines c.m. energy squared for the process (for current energy tabulation)
164 DO 2 K=1,17
165 K1=K+17*(M-1)+34*(L-1)
166 IF(K.LE.I.OR.K.EQ.2)THEN
167 CSBORN(I,K1)=0.D0
168 ELSE
169c SK - c.m. energy squared for the hard interaction
170 SK=EQ(K)
171c CSBORN(I,K1) - Born cross-section (2->2 process) - procedure PSBORN
172 CSBORN(I,K1)=PSBORN(QI,SK,M-1,L-1)
173 ENDIF
1742 CONTINUE
175
176c Cross-sections initialization
177 DO 3 I=1,17
178 DO 3 J=1,17
179 N=MAX(I,J)
180 DO 3 M=1,2
181 DO 3 L=1,2
182 ML=M+2*L-2
183 DO 3 K=1,17
184 K1=K+17*(M-1)+34*(L-1)
185 CSJET(I,J,K1)=0.D0
186 IF(K.LE.N.OR.K.EQ.2)THEN
187 CSTOT(I,J,K1)=-80.D0
188 CS0(I,J,K1)=-80.D0
189 MIJ(I,J,ML)=K+1
190 NIJ(I,J,ML)=K+1
191 ELSE
192 CSTOT(I,J,K1)=DLOG(CSBORN(N,K1))
193 CS0(I,J,K1)=CSTOT(I,J,K1)
194 ENDIF
1953 CONTINUE
196
197c N-maximal number of ladder runs taken into account
198 N=2
1994 CONTINUE
200 IF(DEBUG.GE.2)WRITE (MONIOU,202)N,EQ(MIJ(1,1,1)),EQ(NIJ(1,1,1))
201202 FORMAT(2X,'PSAINI: NUMBER OF LADDER RUNS TO BE CONSIDERED:',I2/
202 * 4X,'MINIMAL MASSES SQUARED FOR THE UNORDERED AND STRICTLY',
203 * ' ORDERED LADDERS:'/4X,E10.3,3X,E10.3)
204 DO 6 I=1,17
205c QI - effective momentum cutoff for upper end of the ladder
206 QI=EQ(I)
207 DO 6 J=1,17
208c QJ - effective momentum cutoff for lower end of the ladder
209 QJ=EQ(J)
210c QQ - maximal effective momentum cutoff
211 QQ=MAX(QI,QJ)
212c S2MIN - minimal energy squared for 2->2 subprocess
213 S2MIN=MAX(QQ,4.D0*QT0)
214 SM=DSQRT(QT0/S2MIN)
215c SMIN - minimal energy squared for 2->3 subprocess
216 SMIN=S2MIN*(1.D0+SM)/(1.D0-SM)
217
218c M, L define parton types (1-g, 2-q)
219 DO 6 M=1,2
220 DO 6 L=1,2
221 ML=M+2*L-2
222c KMIN corresponds to minimal energy at which more runs are to be considered -
223c stored in array NIJ(I,J,ML) - for strictly ordered ladder
224 KMIN=NIJ(I,J,ML)
225 IF(KMIN.LE.17)THEN
226 DO 5 K=KMIN,17
227 SK=EQ(K)
228 IF(SK.LE.SMIN)THEN
229 NIJ(I,J,ML)=NIJ(I,J,ML)+1
230 ELSE
231 K1=K+17*(M-1)+34*(L-1)
232c CS1(I,J,K1) - cross-section for strictly ordered ladder (highest virtuality run
233c is the lowest one) - procedure PSJET1
234 CS1(I,J,K1)=PSJET1(QI,QJ,SK,S2MIN,M-1,L)
235 ENDIF
2365 CONTINUE
237 ENDIF
2386 CONTINUE
239
240 DO 8 I=1,17
241 DO 8 J=1,17
242 DO 8 M=1,2
243 DO 8 L=1,2
244 ML=M+2*L-2
245 KMIN=NIJ(I,J,ML)
246 IF(KMIN.LE.17)THEN
247 DO 7 K=KMIN,17
248 K1=K+17*(M-1)+34*(L-1)
249c CSJ - cross-section for strictly ordered ladder (highest virtuality run is the
250c lowest one) - Born contribution is added
251 CSJ=CS1(I,J,K1)+CSBORN(MAX(I,J),K1)
252 IF(DEBUG.GE.2)WRITE (MONIOU,204)CSJ,EXP(CS0(I,J,K1))
253204 FORMAT(2X,'PSAINI: NEW AND OLD VALUES OF THE CONTRIBUTION',
254 * ' OF THE STRICTLY ORDERED LADDER:'/4X,E10.3,3X,E10.3)
255 IF(CSJ.EQ.0.D0.OR.ABS(1.D0-EXP(CS0(I,J,K1))/CSJ).LT.1.D-2)THEN
256 NIJ(I,J,ML)=NIJ(I,J,ML)+1
257 ELSE
258c CS0(I,J,K1) - cross-section logarithm for strictly ordered ladder
259 CS0(I,J,K1)=DLOG(CSJ)
260 ENDIF
2617 CONTINUE
262 ENDIF
2638 CONTINUE
264
265 DO 10 I=1,17
266 QI=EQ(I)
267 DO 10 J=1,17
268 QJ=EQ(J)
269 QQ=MAX(QI,QJ)
270 S2MIN=MAX(QQ,4.D0*QT0)
271 SM=DSQRT(QT0/S2MIN)
272c SMIN - minimal energy squared for 2->3 subprocess
273 SMIN=S2MIN*(1.D0+SM)/(1.D0-SM)
274
275 DO 10 M=1,2
276 DO 10 L=1,2
277 ML=M+2*L-2
278c KMIN corresponds to minimal energy at which more runs are to be considered
279c stored in array MIJ(I,J,ML) - for any ordering in the ladder
280 KMIN=MIJ(I,J,ML)
281 IF(KMIN.LE.17)THEN
282 DO 9 K=KMIN,17
283 SK=EQ(K)
284 IF(SK.LE.SMIN)THEN
285 MIJ(I,J,ML)=MIJ(I,J,ML)+1
286 ELSE
287 K1=K+17*(M-1)+34*(L-1)
288c CS1(I,J,K1) - cross-section for any ordering in the ladder (highest virtuality
289c run is somewhere in the middle; runs above and below it are strictly ordered
290c towards highest effective momentum run) - procedure PSJET
291 CS1(I,J,K1)=PSJET(QI,QJ,SK,S2MIN,M-1,L)
292 ENDIF
2939 CONTINUE
294 ENDIF
29510 CONTINUE
296
297 DO 12 I=1,17
298 DO 12 J=1,17
299 DO 12 M=1,2
300 DO 12 L=1,2
301 ML=M+2*L-2
302c KMIN corresponds to minimal energy at which more runs are to be considered
303 KMIN=MIJ(I,J,ML)
304 IF(KMIN.LE.17)THEN
305 DO 11 K=KMIN,17
306 K1=K+17*(M-1)+34*(L-1)
307 K2=K+17*(L-1)+34*(M-1)
308 CSJ=CS1(I,J,K1)+EXP(CS0(J,I,K2))
309 IF(CSJ.EQ.0.D0.OR.ABS(1.D0-EXP(CSTOT(I,J,K1))/CSJ).LT.1.D-2)
310 * MIJ(I,J,ML)=MIJ(I,J,ML)+1
311 IF(DEBUG.GE.2)WRITE (MONIOU,203)CSJ,EXP(CSTOT(I,J,K1))
312203 FORMAT(2X,'PSAINI: NEW AND OLD VALUES OF THE UNORDERED LADDER',
313 * ' CROSS SECTION:'/4X,E10.3,3X,E10.3)
31411 CSTOT(I,J,K1)=DLOG(CSJ)
315 ENDIF
31612 CONTINUE
317
318c One more run
319 N=N+1
320 DO 13 L=1,4
32113 IF(MIJ(1,1,L).LE.17.OR.NIJ(1,1,L).LE.17)GOTO 4
322
323c Logarithms of the Born cross-section are calculated - to be interpolated in the
324c PSBINT procedure
325 DO 14 I=1,17
326 DO 14 K=1,17
327 DO 14 M=1,2
328 DO 14 L=1,2
329 K1=K+17*(M-1)+34*(L-1)
330 IF(K.LE.I.OR.K.EQ.2)THEN
331 CSBORN(I,K1)=-80.D0
332 ELSE
333 CSBORN(I,K1)=DLOG(CSBORN(I,K1))
334 ENDIF
33514 CONTINUE
336
337c Total and Born hard cross-sections logarithms for minimal cutoff (QT0) - to be
338c interpolated in the PSJINT0 procedure
339 DO 15 M=1,2
340 DO 15 L=1,2
341 DO 15 K=1,17
342 IF(K.LE.2)THEN
343 CSQ(K,M,L)=-80.D0
344 CSBQ(K,M,L)=-80.D0
345 ELSE
346 K1=K+17*(M-1)+34*(L-1)
347 CSBQ(K,M,L)=CSBORN(1,K1)
348 CSQ(K,M,L)=CSTOT(1,1,K1)
349 ENDIF
35015 CONTINUE
351
352c-------------------------------------------------
353c FSUD(K,M)=-ln(SUD) - timelike Sudakov formfactor logarithm - procedure
354c PSUDT(QMAX,M-1), M=1 - g, M=2 - q
355 DO 17 M=1,2
356 FSUD(1,M)=0.D0
357 DO 17 K=2,10
358c QMAX is the maximal effective momentum ( Qt**2/z**2/(1-z)**2 in case of the timelike
359c evolution )
360 QMAX=QTF*4.D0**(1.D0+K)
36117 FSUD(K,M)=PSUDT(QMAX,M-1)
362
363c QRT(K,L,M) - effective momentum logarithm for timelike branching ( ln QQ/16/QTF )
364c for given QMAX (defined by K, QLMAX = ln QMAX/16/QTF ) and a number
365c of random number values (defined by L) - to be interpolated by the PSQINT
366c procedure; M=1 - g, M=2 - q
367 DO 18 M=1,2
368 DO 18 K=1,10
369 QLMAX=1.38629D0*(K-1)
370 QRT(K,1,M)=0.D0
371 QRT(K,101,M)=QLMAX
372 DO 18 I=1,99
373 IF(K.EQ.1)THEN
374 QRT(K,I+1,M)=0.D0
375 ELSE
376 QRT(K,I+1,M)=PSROOT(QLMAX,.01D0*I,M)
377 ENDIF
37818 CONTINUE
379c-------------------------------------------------
380
381 IF(DEBUG.GE.2)WRITE (MONIOU,205)
382205 FORMAT(2X,'PSAINI: PRETABULATION OF THE INTERACTION EIKONALS')
383c-------------------------------------------------
384************************************************************************
385c-------------------------------------------------
386c Interaction cross sections
387c Factors for interaction eikonals calculation
388c (convolution of the hard cross-sections with partons structure functions)
389c - to be used in the PSPSFAZ procedure
390c-------------------------------------------------
391 IA(1)=1
392c-------------------------------------------------
393 DO 21 IE=1,10
394c Energy of the interaction (per nucleon)
395 E0N=10.D0**IE
396c-------------------------------------------------
397c Energy dependent factors:
398c WP0, WM0 - initial light cone momenta for the interaction (E+-p)
399 S=2.D0*E0N*AMN
400c Y0 - total rapidity range for the interaction
401 Y0=DLOG(S)
402
403c Type of the incident hadron (icz = 1: pion, 2: nucleon, 3: kaon, etc
404 DO 21 ICZ=1,5
405c RS - soft pomeron elastic scattering slope (lambda_ab)
406 RS=RQ(ICZ)+ALFP*Y0
407c RS0 - initial slope (sum of the pomeron-hadron vertices slopes squared - R_ab)
408 RS0=RQ(ICZ)
409c FS - factor for pomeron eikonal calculation
410c (gamma_ab * s**del /lambda_ab * C_ab
411 FS=FP(ICZ)*EXP(Y0*DEL)/RS*CD(ICZ)
412c RP1 - factor for the impact parameter dependence of the eikonal ( in fm>2 )
413 RP1=RS*4.D0*.0391D0/AM**2
414c Factor for cross-sections calculation ( in mb )
415 G0=PI*RP1/CD(ICZ)*AM**2*10.D0
416c SJV - valence-valence cross-section (divided by 8*pi*lambda_ab)
417 SJV(IE,ICZ)=PSHARD(S,ICZ)
418 SJV0=SJV(IE,ICZ)
419
420 DO 19 I=1,5
421 DO 19 M=1,3
422 Z=.2D0*I
423c Eikonals for gluon-gluon and valence-gluon semihard interactions
424c (m=1 - gg, 2 - qg, 3 - gq);
425c Z - impact parameter factor ( exp(-b**2/R_p) )
426 M1=M+3*(ICZ-1)
427 FJS(IE,I,M1)=DLOG(PSFSH(S,Z,ICZ,M-1)/Z)
428 FJS0(I,M)=FJS(IE,I,M1)
42919 CONTINUE
430
431 DO 20 IIA=1,4
432c Target mass number IA(2)
433 IA(2)=4**(IIA-1)
434 IF(DEBUG.GE.1)WRITE (MONIOU,206)E0N,TY(ICZ),IA(2)
435206 FORMAT(2X,'PSAINI: INITIAL PARTICLE ENERGY:',E10.3,2X,
436 *'ITS TYPE:',A7,2X,'TARGET MASS NUMBER:',I2)
437c-------------------------------------------------
438c Nuclear radii
439 IF(IA(2).GT.10)THEN
440c RD - Wood-Saxon density radius (fit to the data of Murthy et al.)
441 RD(2)=0.7D0*FLOAT(IA(2))**.446/AM
442 ELSE
443c RD - gaussian density radius (for light nucleus)
444 RD(2)=.9D0*FLOAT(IA(2))**.3333/AM
445 ENDIF
446
447 IF(IA(2).EQ.1)THEN
448c Hadron-proton interaction
449c BM - impact parameter cutoff value
450 BM=2.D0*DSQRT(RP1)
451c XXFZ - impact parameter integration for the hadron-nucleon interaction eikonal;
452c GZ0 - total and absorptive cross-sections (up to a factor); first parameter is
453c used only in case of hadron-nucleus interaction (to make convolution with target
454c nucleus profile function)
455 CALL XXFZ(0.D0,GZ0)
456 write (*,*)gz0
457c GTOT - total cross-section
458 GTOT=G0*GZ0(1)
459c GABS - cut pomerons cross-section
460 GABS=G0*GZ0(2)*.5D0
461c GD0 - cross-section for the cut between pomerons
462 GD0=GTOT-GABS
463c GDP - projectile diffraction cross section
464 GDP=(1.D0-CC(ICZ))*CC(2)*GD0
465c GDT - target diffraction cross section
466 GDT=(1.D0-CC(2))*CC(ICZ)*GD0
467c GDD - double diffractive cross section
468 GDD=(1.D0-CC(ICZ))*(1.D0-CC(2))*GD0
469c GIN - inelastic cross section
470 GIN=GABS+GDP+GDT+GDD
471 GEL=GD0*CC(ICZ)*CC(2)
472c
473 IF(DEBUG.GE.1)WRITE (MONIOU,225)GTOT,GIN,GEL,GDP,GDT,GDD
474c
475225 FORMAT(2X,'PSAINI: HADRON-PROTON CROSS SECTIONS:'/
476 * 4X,'GTOT=',E10.3,2X,'GIN=',E10.3,2X,'GEL=',E10.3/4X,
477 * 'GDIFR_PROJ=',E10.3,2X,'GDIFR_TARG=',E10.3,2X,
478 * 'G_DOUBLE_DIFR',E10.3)
479c GZ - probability to have target diffraction
480 GZ(IE,ICZ,IIA)=GDT/GIN
481C??????
482 GSECT(IE,ICZ,IIA)=LOG(GIN)
483C??????
484 ELSE
485
486c Hadron-nucleus interaction
487c BM - impact parameter cutoff value
488 BM=RD(2)+DLOG(29.D0)
489c RRR - Wood-Saxon radius for the target nucleus
490 RRR=RD(2)
491c RRRM - auxiliary parameter for numerical integration
492 RRRM=RRR+DLOG(9.D0)
493c ANORM - nuclear density normalization factor multiplied by RP1
494 ANORM=1.5D0/PI/RRR**3/(1.D0+(PI/RRR)**2)*RP1
495
496c GAU(GZ) - cross sections calculation ( integration over impact parameters less than
497c BM )
498 CALL XXGAU(GZ1)
499c GAU1(GZ) - cross sections calculation ( integration over impact
500c parameters greater than BM )
501 CALL XXGAU1(GZ1)
502c GIN - total inelastic cross section
503 GIN=GZ1(1)+GZ1(2)+GZ1(3)
504c
505 IF(DEBUG.GE.1)WRITE (MONIOU,224)
506 * GIN*10.D0,GZ1(1)*10.D0,GZ1(2)*10.D0
507c
508224 FORMAT(2X,'PSAINI: HADRON-NUCLEUS CROSS SECTIONS:'/
509 * 4X,'GIN=',E10.3,2X,'GDIFR_TARG=',E10.3,2X,
510 * 'GDIFR_PROJ=',E10.3)
511c GZ - probability to have target diffraction
512 GZ(IE,ICZ,IIA)=GZ1(1)/GIN
513C??????
514 GIN=GIN*10.
515 GSECT(IE,ICZ,IIA)=LOG(GIN)
516C??????
517 ENDIF
51820 CONTINUE
51921 CONTINUE
520
521c Rejection functions calculation - to be interpolated in the RJINT procedure
522 DO 23 I=1,50
523c Rapidity range tabulation for the hard interaction
524 YJ=AQT0+.5D0*I
525c Rejection function for valence quark energy distribution
526 RJV(I)=PSREJV(EXP(YJ))
527
528 DO 22 J=1,5
529 DO 22 M=1,2
530 Z=.2D0*J
531 DO 22 ICZ=1,5
532c RS0 - initial slope (sum of the pomeron-hadron vertices slopes squared - R_ab)
533 RS0=RQ(ICZ)
534 M1=M+2*(ICZ-1)
535c Rejection function for semihard block energy distribution (m=1 - gg,
536c 2 - qg)
537 RJS(I,J,M1)=PSREJS(EXP(YJ),Z,M-1)
53822 CONTINUE
53923 CONTINUE
540
541 IF(DEBUG.GE.1)WRITE (MONIOU,212)
542212 FORMAT(2X,'PSAINI: HARD CROSS SECTIONS ARE WRITTEN TO THE FILE'
543 * ,' QGSDATA4')
544 OPEN(1,FILE='QGSDATA4',STATUS='unknown')
545 WRITE (1,*)CSBORN,CS0,CSTOT,CSQ,CSBQ,
546 * FSUD,QRT,SJV,FJS,RJV,RJS,GZ,GSECT
547 CLOSE(1)
548 ENDIF
549************************************************************************
550
551 IF(DEBUG.GE.3)WRITE (MONIOU,218)
552218 FORMAT(2X,'PSAINI - END')
553 RETURN
554 END
555C=======================================================================
556
557 FUNCTION PSAPINT(X,J,L)
558c PSAPINT - integrated Altarelli-Parisi function
559c X - light cone momentum share value,
560c J - type of initial parton (0 - g, 1 - q)
561c L - type of final parton (0 - g, 1 - q)
562C-----------------------------------------------------------------------
563 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
564 INTEGER DEBUG
565 COMMON /AREA43/ MONIOU
566 COMMON /DEBUG/ DEBUG
567 SAVE
568 IF(DEBUG.GE.2)WRITE (MONIOU,201)X,J,L
569201 FORMAT(2X,'PSAPINT: X=',E10.3,2X,'J= ',I1,2X,'L= ',I1)
570 IF(J.EQ.0)THEN
571 IF(L.EQ.0)THEN
572 PSAPINT=6.D0*(DLOG(X/(1.D0-X))-X**3/3.D0+X**2/2.D0-2.D0*X)
573 ELSE
574 PSAPINT=3.D0*(X+X**3/1.5D0-X*X)
575 ENDIF
576 ELSE
577 IF(L.EQ.0)THEN
578 PSAPINT=(DLOG(X)-X+.25D0*X*X)/.375D0
579 ELSE
580 Z=1.D0-X
581 PSAPINT=-(DLOG(Z)-Z+.25D0*Z*Z)/.375D0
582 ENDIF
583 ENDIF
584 IF(DEBUG.GE.2)WRITE (MONIOU,202)PSAPINT
585202 FORMAT(2X,'PSAPINT=',E10.3)
586 RETURN
587 END
588C=======================================================================
589
590 SUBROUTINE PSASET
591c Common model parameters setting
592c-----------------------------------------------------------------------
593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
594 INTEGER DEBUG
595 CHARACTER*7 TY
596 COMMON /AREA15/ FP(5),RQ(5),CD(5)
597 COMMON /AREA17/ DEL,RS,RS0,FS,ALFP,RR,SH,DELH
598 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
599 COMMON /AREA25/ AHV(5)
600 COMMON /AREA26/ FACTORK
601 COMMON /AREA41/ TY(5)
602 COMMON /AREA43/ MONIOU
603 COMMON /DEBUG/ DEBUG
604 IF(DEBUG.GE.1)WRITE (MONIOU,210)
605210 FORMAT(2X,'PSASET - COMMON MODEL PARAMETERS SETTING')
606
607c Soft pomeron parameters:
608c DEL - overcriticity,
609c ALFP - trajectory slope;
610c FP(i) - vertices for pomeron-hadrons interaction (gamma(i)*gamma(proton)),
611c RQ(i) - vertices slopes (R(i)**2+R(proton)**2),
612c CD(i) - shower enhancement coefficients
613c (i=1,...5 - pion,proton,kaon,D-meson,Lambda_C ),
614c (Kaidalov et al., Sov.J.Nucl.Phys.,1984 - proton and pion parameters)
615 DEL=.07D0
616 ALFP=.21D0
617
618 FP(1)=2.43D0
619 RQ(1)=2.4D0
620 CD(1)=1.6D0
621
622 FP(2)=3.64D0
623 RQ(2)=3.56D0
624 CD(2)=1.5D0
625
626 FP(3)=1.75D0
627 RQ(3)=2.D0
628 CD(3)=1.7D0
629
630 FP(4)=1.21D0
631 RQ(4)=1.78D0
632 CD(4)=2.0D0
633
634 FP(5)=2.43D0
635 RQ(5)=2.4D0
636 CD(5)=2.0D0
637
638c-------------------------------------------------
639c Hard interaction parameters:
640c ALM - Lambda_QCD squared,
641c QT0 - Q**2 cutoff,
642c RR - vertex constant square for soft pomeron interaction with the hard block (r**2),;
643c BET - gluon structure function parameter for the soft pomeron ((1-x)**BET),
644c AMJ0 - jet mass,
645c QTF - Q**2 cutoff for the timelike evolution,
646c FACTORK - K-factor value;
647c DELH is not a parameter of the model; it is used only for energy sharing
648c procedure - initially energy is shared according to s**DELH dependence
649c for the hard interaction cross-section and then rejection is used according
650c to real Sigma_hard(s) dependence.
651 ALM=.04D0
652 RR=.35D0
653 QT0=4.D0
654 BET=1.D0
655 DELH=0.25D0
656 AMJ0=0.D0
657 QTF=.5D0
658 FACTORK=2.D0
659
660c-------------------------------------------------
661c Valence quark structure functions for the hard scattering
662c (~1/sqrt(x)*(1-x)**AHV(i), i=1,...5 corresponds to pion, nucleon etc.)
663 AHV(1)=1.5D0
664 AHV(2)=2.5D0
665 AHV(3)=2.D0
666 AHV(4)=4.D0
667 AHV(5)=5.D0
668c Initial particle types
669 TY(1)='pion '
670 TY(2)='nucleon'
671 TY(3)='kaon '
672 TY(4)='D-meson'
673 TY(5)='LambdaC'
674 RETURN
675 END
676C=======================================================================
677
678 FUNCTION PSBINT(QQ,S,M,L)
679C PSBINT - Born cross-section interpolation
680c QQ - effective momentum cutoff for the scattering,
681c S - total c.m. energy squared for the scattering,
682c M - parton type at current end of the ladder (1 - g, 2 - q)
683c L - parton type at opposite end of the ladder (1 - g, 2 - q)
684C-----------------------------------------------------------------------
685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
686 INTEGER DEBUG
687 DIMENSION WI(3),WK(3)
688 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
689 COMMON /AREA31/ CSJ(17,68)
690 COMMON /AREA43/ MONIOU
691 COMMON /DEBUG/ DEBUG
692 SAVE
693 IF(DEBUG.GE.2)WRITE (MONIOU,201)QQ,S,M,L
694201 FORMAT(2X,'PSBINT: QQ=',E10.3,2X,'S= ',E10.3,2X,'M= ',I1,2X,
695 * 'L= ',I1)
696 PSBINT=0.D0
697 IF(S.LE.MAX(4.D0*QT0,QQ))THEN
698 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSBINT
699202 FORMAT(2X,'PSBINT=',E10.3)
700 RETURN
701 ENDIF
702
703 ML=17*(M-1)+34*(L-1)
704 QLI=DLOG(QQ/QT0)/1.38629d0
705 SL=DLOG(S/QT0)/1.38629d0
706 SQL=SL-QLI
707 I=INT(QLI)
708 K=INT(SL)
709 IF(I.GT.13)I=13
710
711 IF(SQL.GT.10.D0)THEN
712 IF(K.GT.14)K=14
713 WI(2)=QLI-I
714 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
715 WI(1)=1.D0-WI(2)+WI(3)
716 WI(2)=WI(2)-2.D0*WI(3)
717 WK(2)=SL-K
718 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
719 WK(1)=1.D0-WK(2)+WK(3)
720 WK(2)=WK(2)-2.D0*WK(3)
721
722 DO 1 I1=1,3
723 DO 1 K1=1,3
7241 PSBINT=PSBINT+CSJ(I+I1,K+K1+ML)*WI(I1)*WK(K1)
725 PSBINT=EXP(PSBINT)
726 ELSEIF(SQL.LT.1.D0.AND.I.NE.0)THEN
727 SQ=(S/QQ-1.D0)/3.D0
728 WI(2)=QLI-I
729 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
730 WI(1)=1.D0-WI(2)+WI(3)
731 WI(2)=WI(2)-2.D0*WI(3)
732
733 DO 2 I1=1,3
734 I2=I+I1
735 K2=I2+1+ML
7362 PSBINT=PSBINT+CSJ(I2,K2)*WI(I1)
737 PSBINT=EXP(PSBINT)*SQ
738 ELSEIF(K.EQ.1)THEN
739 SQ=(S/QT0/4.D0-1.D0)/3.D0
740 WI(2)=QLI
741 WI(1)=1.D0-QLI
742
743 DO 3 I1=1,2
7443 PSBINT=PSBINT+CSJ(I1,3+ML)*WI(I1)
745 PSBINT=EXP(PSBINT)*SQ
746 ELSEIF(K.LT.15)THEN
747 KL=INT(SQL)
748 IF(I+KL.GT.12)I=12-KL
749 IF(I+KL.EQ.1)KL=2
750 WI(2)=QLI-I
751 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
752 WI(1)=1.D0-WI(2)+WI(3)
753 WI(2)=WI(2)-2.D0*WI(3)
754 WK(2)=SQL-KL
755 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
756 WK(1)=1.D0-WK(2)+WK(3)
757 WK(2)=WK(2)-2.D0*WK(3)
758
759 DO 4 I1=1,3
760 I2=I+I1
761 DO 4 K1=1,3
762 K2=I2+KL+K1-1+ML
7634 PSBINT=PSBINT+CSJ(I2,K2)*WI(I1)*WK(K1)
764 PSBINT=EXP(PSBINT)
765
766 ELSE
767 K=15
768 IF(I.GT.K-3)I=K-3
769 WI(2)=QLI-I
770 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
771 WI(1)=1.D0-WI(2)+WI(3)
772 WI(2)=WI(2)-2.D0*WI(3)
773 WK(2)=SL-K
774 WK(1)=1.D0-WK(2)
775
776 DO 5 I1=1,3
777 DO 5 K1=1,2
7785 PSBINT=PSBINT+CSJ(I+I1,K+K1+ML)*WI(I1)*WK(K1)
779 PSBINT=EXP(PSBINT)
780 ENDIF
781 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSBINT
782 RETURN
783 END
784C=======================================================================
785
786 FUNCTION PSBORN(QQ,S,IQ1,IQ2)
787c PSFBORN -hard 2->2 parton scattering Born cross-section
788c S is the c.m. energy square for the scattering process,
789c IQ1 - parton type at current end of the ladder (0 - g, 1,2 - q)
790c IQ2 - parton type at opposite end of the ladder (0 - g, 1,2 - q)
791c-----------------------------------------------------------------------
792 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
793 INTEGER DEBUG
794 COMMON /AREA6/ PI,BM,AM
795 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
796 COMMON /AREA26/ FACTORK
797 COMMON /AREA43/ MONIOU
798 COMMON /DEBUG/ DEBUG
799 COMMON /AR3/ X1(7),A1(7)
800 SAVE
801
802 IF(DEBUG.GE.2)WRITE (MONIOU,201)QQ,S,IQ1,IQ2
803201 FORMAT(2X,'PSBORN: QQ=',E10.3,2X,'S= ',E10.3,2X,'IQ1= ',I1,2X,
804 * 'IQ2= ',I1)
805 TMIN=S*(.5D0-DSQRT(.25D0-QT0/S))
806 TMIN=MAX(TMIN,S*QQ/(S+QQ))
807
808 IF(IQ1*IQ2.EQ.0)THEN
809 IQ=IQ2
810 ELSE
811 IQ=2
812 ENDIF
813
814 PSBORN=0.D0
815 DO 1 I=1,7
816 DO 1 M=1,2
817 T=2.D0*TMIN/(1.D0+2.D0*TMIN/S-X1(I)*(2*M-3)*(1.D0-2.D0*TMIN/S))
818 QT=T*(1.D0-T/S)
819 FB=PSFBORN(S,T,IQ1,IQ)+PSFBORN(S,S-T,IQ1,IQ)
8201 PSBORN=PSBORN+A1(I)*FB/DLOG(QT/ALM)**2*T**2
821 PSBORN=PSBORN*(.5D0/TMIN-1.D0/S)*FACTORK*PI**3/2.25D0**2/S**2
822 IF(IQ1.EQ.0.AND.IQ2.EQ.0)PSBORN=PSBORN*.5D0
823 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSBORN
824202 FORMAT(2X,'PSBORN=',E10.3)
825 RETURN
826 END
827C=======================================================================
828
829 SUBROUTINE PSCAJET(QQ,IQ1,QV,ZV,QM,IQV,LDAU,LPAR,JQ)
830c Final state emission process (all branchings as well as parton masses
831c are determined)
832C-----------------------------------------------------------------------
833c QQ - maximal effective momentum transfer for the first branching
834c IQ1, IQ2 - initial jet flavours in forward and backward direction
835c (0 - for gluon)
836c QV(i,j) - effective momentum for the branching of the parton in i-th row
837c on j-th level (0 - in case of no branching) - to be determined
838c ZV(i,j) - Z-value for the branching of the parton in i-th row
839c on j-th level - to be determined
840c QM(i,j) - mass squared for the parton in i-th row
841c on j-th level - to be determined
842c IQV(i,j) - flavour for the parton in i-th row on j-th level
843c - to be determined
844c LDAU(i,j) - first daughter row for the branching of the parton in i-th row
845c on j-th level - to be determined
846c LPAR(i,j) - the parent row for the parton in i-th row
847c on j-th level - to be determined
848 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
849 INTEGER DEBUG
850 DIMENSION QMAX(30,50),IQM(2),LNV(50),
851 * QV(30,50),ZV(30,50),QM(30,50),IQV(30,50),
852 * LDAU(30,49),LPAR(30,50)
853
854 COMMON /AREA11/ B10
855 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
856 COMMON /AREA43/ MONIOU
857 COMMON /DEBUG/ DEBUG
858
859 IF(DEBUG.GE.2)WRITE (MONIOU,201)QQ,IQ1,JQ
860201 FORMAT(2X,'PSCAJET: QQ=',E10.3,2X,'IQ1= ',I1,2X,'JQ=',I1)
861
862 DO 1 I=2,20
8631 LNV(I)=0
864 LNV(1)=1
865 QMAX(1,1)=QQ
866 IQV(1,1)=IQ1
867 NLEV=1
868 NROW=1
869
8702 QLMAX=DLOG(QMAX(NROW,NLEV)/QTF/16.D0)
871 IQ=MIN(1,IABS(IQV(NROW,NLEV)))+1
872
873 IF(PSRAN(B10).GT.PSUDINT(QLMAX,IQ))THEN
874 Q=PSQINT(QLMAX,PSRAN(B10),IQ)
875 Z=PSZSIM(Q,IQ)
876
877 LL=LNV(NLEV+1)+1
878 LDAU(NROW,NLEV)=LL
879 LPAR(LL,NLEV+1)=NROW
880 LPAR(LL+1,NLEV+1)=NROW
881 LNV(NLEV+1)=LL+1
882
883 IF(IQ.NE.1)THEN
884 IF((3-2*JQ)*IQV(NROW,NLEV).GT.0)THEN
885 IQM(1)=0
886 IQM(2)=IQV(NROW,NLEV)
887 ELSE
888 IQM(2)=0
889 IQM(1)=IQV(NROW,NLEV)
890 Z=1.D0-Z
891 ENDIF
892 ELSE
893*********************************************************
894 WG=PSFAP(Z,0,0)
895*********************************************************
896 WG=WG/(WG+PSFAP(Z,0,1))
897 IF(PSRAN(B10).LT.WG)THEN
898 IQM(1)=0
899 IQM(2)=0
900 ELSE
901 IQM(1)=INT(3.D0*PSRAN(B10)+1.D0)*(3-2*JQ)
902 IQM(2)=-IQM(1)
903 ENDIF
904 IF(PSRAN(B10).LT..5D0)Z=1.D0-Z
905 ENDIF
906
907 QV(NROW,NLEV)=Q
908 ZV(NROW,NLEV)=Z
909
910 NROW=LL
911 NLEV=NLEV+1
912 QMAX(NROW,NLEV)=Q*Z**2
913 QMAX(NROW+1,NLEV)=Q*(1.D0-Z)**2
914 IQV(NROW,NLEV)=IQM(1)
915 IQV(NROW+1,NLEV)=IQM(2)
916 IF(DEBUG.GE.3)WRITE (MONIOU,203)NLEV,NROW,Q,Z
917203 FORMAT(2X,'PSCAJET: NEW BRANCHING AT LEVEL NLEV=',I2,
918 * ' NROW=',I2/4X,' EFFECTIVE MOMENTUM Q=',E10.3,2X,' Z=',E10.3)
919 GOTO 2
920 ELSE
921
922 QV(NROW,NLEV)=0.D0
923 ZV(NROW,NLEV)=0.D0
924 QM(NROW,NLEV)=AMJ0
925 IF(DEBUG.GE.3)WRITE (MONIOU,204)NLEV,NROW
926204 FORMAT(2X,'PSCAJET: NEW FINAL JET AT LEVEL NLEV=',I2,
927 * ' NROW=',I2)
928 ENDIF
929
9304 CONTINUE
931 IF(NLEV.EQ.1)THEN
932 IF(DEBUG.GE.3)WRITE (MONIOU,202)
933202 FORMAT(2X,'PSCAJET - END')
934 RETURN
935 ENDIF
936 LPROW=LPAR(NROW,NLEV)
937
938 IF(LDAU(LPROW,NLEV-1).EQ.NROW)THEN
939 NROW=NROW+1
940 GOTO 2
941 ELSE
942 Z=ZV(LPROW,NLEV-1)
943 QM(LPROW,NLEV-1)=Z*(1.D0-Z)*QV(LPROW,NLEV-1)
944 * +QM(NROW-1,NLEV)/Z+QM(NROW,NLEV)/(1.D0-Z)
945 NROW=LPROW
946 NLEV=NLEV-1
947 IF(DEBUG.GE.3)WRITE (MONIOU,205)NLEV,NROW,QM(LPROW,NLEV)
948205 FORMAT(2X,'PSCAJET: JET MASS AT LEVEL NLEV=',I2,
949 * ' NROW=',I2,' - QM=',E10.3)
950 GOTO 4
951 ENDIF
952 END
953C=======================================================================
954
955 SUBROUTINE PSCONF
956c Simulation of the interaction configuration: impact parameter, nucleons positions,
957c numbers of cut soft pomerons and semihard blocks, their connections.
958c-----------------------------------------------------------------------
959 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
960 INTEGER DEBUG
961c XA(56,3),XB(56,3) - arrays for projectile and target nucleons positions recording,
962c FHARD(i) give the factors to the scattering amplitude due to
963c valence quark-gluon (i=1), gluon-valence quark (i=2) and
964c valence quark-valence quark (i=3) interactions
965 DIMENSION XA(56,3),XB(56,3),FHARD(3)
966 COMMON /AREA1/ IA(2),ICZ,ICP
967 COMMON /AREA2/ S,Y0,WP0,WM0
968 COMMON /AREA6/ PI,BM,AM
969c Arrays for interaction configuration recording:
970c LQA(i) (LQB(j)) - numbers of cut soft pomerons, connected to i-th projectile
971c (j-th target) nucleon (hadron);
972c LHA(i) (LHB(j)) - the same for hard pomerons numbers;
973c IAS(k) (IBS(k)) - number (position in array) of the projectile (target) nucleon,
974c connected to k-th block of soft pomerons;
975c NQS(k) - number of soft pomerons in k-th block;
976c IAH(k) (IBH(k)) - number (position in array) of the projectile (target) nucleon,
977c connected to k-th hard pomeron;
978c ZH(k) - impact parameter between the two nucleons connected to k-th hard pomeron
979c (more exactly exp(-b**2/RP1));
980c LVA(i)=1 if valence quark from i-th nucleon (i=1 for hadron) is involved into
981c the hard interaction and LVA(i)=0 otherwise, LVB(j) - similar.
982 COMMON /AREA9/ LQA(56),LQB(56),NQS(1000),IAS(1000),IBS(1000),
983 * LHA(56),LHB(56),ZH(1000),IAH(1000),IBH(1000),
984 * IQH(1000),LVA(56),LVB(56)
985 COMMON /AREA11/ B10
986c NSP - number of secondary particles
987 COMMON /AREA12/ NSP
988 COMMON /AREA16/ CC(5)
989 COMMON /AREA40/ JDIFR
990 COMMON /AREA43/ MONIOU
991**************************************************
992 COMMON /AREA45/ GDT
993**************************************************
994 COMMON /AREA99/ NWT
995 COMMON /DEBUG/ DEBUG
996 SAVE
997 DIMENSION IWT(56)
998
999 IF(DEBUG.GE.1)WRITE (MONIOU,201)
1000201 FORMAT(2X,'PSCONF - CONFIGURATION OF THE INTERACTION')
1001
1002 NSP=0
1003
1004 IF(IA(1).EQ.1)THEN
1005**************************************************
1006 IF(JDIFR.EQ.1.AND.PSRAN(B10).LT.GDT)THEN
1007c Target diffraction
1008 IF(IA(2).NE.1)THEN
1009c ICT - partner target nucleon type (proton - 2 or neutron - 3)
1010 ICT=INT(2.5+PSRAN(B10))
1011 ELSE
1012c Target proton
1013 ICT=2
1014 ENDIF
1015 WPI=WP0
1016 WMI=WM0
1017c write (*,*)'difr'
1018 CALL XXDTG(WPI,WMI,ICP,ICT,0)
1019 RETURN
1020 ENDIF
1021**************************************************
1022c For hadron projectile we have given position in transverse plane;
1023c initially primary hadron is positioned at (X,Y)=(0,0)
1024 DO 1 I=1,3
10251 XA(1,I)=0.D0
1026 ENDIF
1027
1028c-------------------------------------------------
1029c Inelastic interaction at B<BM (usual case)
1030c-------------------------------------------------
1031c NW - number of wounded nucleons in the primary (NW=1 for hadron);
1032c NT - number of target nucleons being in their active diffractive state;
1033c LS - number of cut soft pomeron blocks (froissarons);
1034c NHP - number of cut pomerons having hard block (referred below as hard blocks);
1035c NQS(k) - number of cut soft pomerons in k-th block;
1036c IAS(k) (IBS(k)) - number (position in array) of the projectile (target) nucleon,
1037c connected to k-th block of soft pomerons;
1038c IAH(k) (IBH(k)) - number 3(position in array) of the projectile (target) nucleon,
1039c connected to k-th hard pomeron;
1040c ZH(k) - impact parameter between the two nucleons connected to k-th hard pomeron
1041c (more exactly exp(-b**2/RP1));
1042c LQA(i) (LQB(j)) - total number of cut soft pomerons, connected to i-th projectile
1043c (j-th target) nucleon (hadron);
1044c LHA(i) (LHB(j)) - total number of cut hard blocks, connected to i-th projectile
1045c (j-th target) nucleon (hadron);
1046c LVA(i)=1 if valence quark from i-th nucleon (i=1 for hadron) is involved into
1047c the hard interaction and LVA(i)=0 otherwise, LVB(j) - similar.
1048c-------------------------------------------------
1049c Initialization
10502 DO 3 I=1,IA(1)
1051 LHA(I)=0
1052 LVA(I)=0
10533 LQA(I)=0
1054 DO 4 I=1,IA(2)
1055 LHB(I)=0
1056 LVB(I)=0
10574 LQB(I)=0
1058
1059c-------------------------------------------------
1060c The beginning
10615 CONTINUE
1062**************************************************
1063 IF(IA(2).NE.1)THEN
1064c For target nucleus number of target nucleons being in their active
1065c diffractive state is simulated (for each nucleon probability equals
1066c 1./C_n, - shower enhancenment coefficient)
1067 NT=0
1068 DO 6 I=1,IA(2)
10696 NT=NT+INT(CC(2)+PSRAN(B10))
1070c In case of no active target nucleon the event is rejected
1071 IF(NT.EQ.0)GOTO 5
1072 IF(DEBUG.GE.3)WRITE (MONIOU,203)NT
1073203 FORMAT(2X,'PSCONF: NUMBER OF ACTIVE TARGET NUCLEONS NT=',
1074 * I2)
1075c PSGEA(NT,XB,2) - target nucleons positions simulation:
1076 CALL PSGEA(NT,XB,2)
1077c NT - number of target nucleons being in their active diffractive state;
1078c XB(i,n) - n-th nucleon coordinates (i=1,2,3 corresponds to x,y,z);
1079c parameter 2 means target
1080 ELSE
1081 NT=1
1082 XB(1,1)=0.D0
1083 XB(1,2)=0.D0
1084 ENDIF
1085**************************************************
1086
1087c-------------------------------------------------
1088c Impact parameter square is simulated uniformly (B**2<BM**2)
1089 B=BM*DSQRT(PSRAN(B10))
1090 IF(DEBUG.GE.2)WRITE (MONIOU,204)B*AM
1091204 FORMAT(2X,'PSCONF: IMPACT PARAMETER FOR THE INTERACTION:',
1092 * E10.3,' FM')
1093c PSGEA(IA(1),XA,1) - projectile nucleons positions simulation:
1094c IA(1) - projectile nucleus mass number;
1095c XA(i,n) - n-th nucleon coordinates (i=1,2,3 corresponds to x,y,z);
1096c parameter 1 means projectile
1097 IF(IA(1).GT.1)CALL PSGEA(IA(1),XA,1)
1098
1099 NW=0
1100 LS=0
1101 NS=0
1102 NHP=0
1103 DO 101 IT = 1,NT
1104 IWT(IT) = 0
1105 101 CONTINUE
1106
1107c-------------------------------------------------
1108c Cycle over all projectile nucleons ( for projectile hadron we have only IN=1 )
1109 DO 14 IN=1,IA(1)
1110 IF(DEBUG.GE.2.AND.ICZ.EQ.2)WRITE (MONIOU,205)IN
1111205 FORMAT(2X,'PSCONF: ',I2,'-TH PROJECTILE NUCLEON')
1112c Only nucleons in their active diffractive state are considered (for each nucleon
1113c probability equals 1./C_n, C_n = 1./CC(2) - shower enhancenment coefficient)
1114 IF(IA(1).NE.1.AND.PSRAN(B10).GT.CC(2))GOTO 12
1115c Projectile nucleons positions are shifted according the to impact parameter B
1116 X=XA(IN,1)+B
1117 Y=XA(IN,2)
1118
1119cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
1120c Projectile diffraction
1121c For each projectile nucleon (hadron) diffractive dissociation probability is
1122c (1.D0-CC(ICZ))*PSV(X,Y,XB,NT);
1123c XXV(X,Y,XB,NT) - nucleon-nucleus scattering eikonal factor
1124c ( (1-eikonal)**2 ) for given nucleons positions
1125c (For projectile hadron only in case of JPERI=0, otherwise it was considered
1126c before at any impact parameter )
1127 IF(JDIFR.EQ.1.
1128 * AND.PSRAN(B10).LT.(1.D0-CC(ICZ))*PSV(X,Y,XB,NT))THEN
1129**************************************************
1130 IF(IA(2).NE.1)THEN
1131c ICT - partner target nucleon type (proton - 2 or neutron - 3)
1132 ICT=INT(2.5+PSRAN(B10))
1133 ELSE
1134c Target proton
1135 ICT=2
1136 ENDIF
1137 IF(IA(1).EQ.1)THEN
1138c Projectile hadron
1139 IF(DEBUG.GE.2)WRITE (MONIOU,206)
1140206 FORMAT(2X,'PROJECTILE HADRON DIFFRACTION')
1141 ICP0=ICP
1142 ELSE
1143c Projectile nucleon
1144 IF(DEBUG.GE.2)WRITE(MONIOU,207)IN
1145207 FORMAT(2X,I2,'-TH PROJECTILE NUCLEON DIFFRACTION')
1146 ICP0=INT(2.5+PSRAN(B10))
1147 ENDIF
1148 WPI=WP0
1149 WMI=WM0
1150 IF(IA(2).EQ.1)THEN
1151 LQ=0
1152 ELSE
1153 LQ=1
1154 ENDIF
1155 CALL XXDPR(WPI,WMI,ICP0,ICT,LQ)
1156 GOTO 14
1157 ENDIF
1158**************************************************
1159cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
1160
1161 IQS=0
1162 NW=NW+1
1163c-------------------------------------------------
1164c Cycle over all target nucleons in active state
1165 DO 11 M=1,NT
1166c Z - b-factor for pomeron eikonal calculation (exp(-R_ij/R_p))
1167 Z=PSDR(X-XB(M,1),Y-XB(M,2))
1168c VV - eikonal for nucleon-nucleon (hadron-nucleon) interaction
1169c (sum of the soft and semihard eikonals)
1170 VV=2.D0*PSFAZ(Z,FSOFT,FHARD,FSHARD)
1171 EV=EXP(-VV)
1172c EH - eikonal contribution of valence quarks hard interactions
1173 EH=FHARD(1)+FHARD(2)+FHARD(3)
1174c eh=0.d0
1175 AKS=PSRAN(B10)
1176c 1.-EXP(-VV)*(1.D0-2.D0*EH) is the probability for inelastic nucleon-nucleon
1177c (hadron-nucleon) interaction (for given nucleons positions)
1178 IF(AKS.GT.1.D0-EV*(1.D0-2.D0*EH))GOTO 11
1179 IF(DEBUG.GE.2)WRITE (MONIOU,208)M
1180208 FORMAT(2X,'PSCONF: INTERACTION WITH',I2,'-TH TARGET NUCLEON')
1181C INCREMENT THE NUMBER IWT OF WOUNDED TARGET NUCLEONS
1182 IWT(M) = 1
1183
1184c-------------------------------------------------
1185c IQV - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
1186 IQV=0
1187
1188c 2*EH*EV = 2*EH*EXP(-VV) - probability for only valence quarks hard interactions
1189c (with no one soft or semihard)
1190 SUM=2.D0*EH*EV
1191
1192c-------------------------------------------------
1193 IF(AKS.LT.SUM)THEN
1194 AKS1=EH*PSRAN(B10)
1195 IF(AKS1.LT.FHARD(1))THEN
1196c Rejection in case of valence quark already involved into the interaction
1197 IF(LVA(NW).NE.0)GOTO 11
1198c LVA(NW)=1 - valence quark-gluon interaction
1199 LVA(NW)=1
1200 IQV=1
1201 ELSEIF(AKS1.LT.FHARD(1)+FHARD(2))THEN
1202c Rejection in case of valence quark already involved into the interaction
1203 IF(LVB(M).NE.0)GOTO 11
1204c LVB(M)=1 - gluon-valence quark interaction
1205 LVB(M)=1
1206 IQV=2
1207 ELSE
1208c Rejection in case of valence quarks already involved into the interaction
1209 IF(LVA(NW)+LVB(M).NE.0)GOTO 11
1210c LVA(NW)=LVB(M)=1 - valence quark-valence quark interaction
1211 LVA(NW)=1
1212 LVB(M)=1
1213 IQV=3
1214 ENDIF
1215 N=1
1216c LNH - number of new hard blocks (resulted from current nucleon-nucleon interaction)
1217 LNH=1
1218 GOTO 22
1219 ENDIF
1220c-------------------------------------------------
1221
1222c LNH - number of new hard blocks - initialization
1223 LNH=0
1224c WH - probability to have semihard interaction
1225 WH=2.D0*FSHARD/VV
1226c N - number of cut pomerons (both soft ones and having hard blocks) for the
1227c nucleon-nucleon (hadron-nucleon) interaction - is determined according to Poisson
1228c with average value VV (twice the eikonal)
1229 DO 7 N=1,45
1230 EV=EV*VV/N
1231 SUM=SUM+EV
12327 IF(AKS.LT.SUM)GOTO 8
1233
1234c LNH - number of hard blocks for nucleon-nucleon (hadron-nucleon)
1235c interaction (according to WH probability)
12368 DO 9 I=1,N
12379 LNH=LNH+INT(WH+PSRAN(B10))
1238
1239c-------------------------------------------------
1240 AKS1=.5D0*PSRAN(B10)
1241c EH is the probability to have valence quarks interactions in addition to the
1242c soft and semihard
1243 IF(AKS1.LT.EH)THEN
1244 IF(AKS1.LT.FHARD(1))THEN
1245 IF(LVA(NW).NE.0)GOTO 22
1246c Valence quark-gluon interaction
1247 LVA(NW)=1
1248 IQV=1
1249 ELSEIF(AKS1.LT.FHARD(1)+FHARD(2))THEN
1250 IF(LVB(M).NE.0)GOTO 22
1251c Gluon-valence quark interaction
1252 LVB(M)=1
1253 IQV=2
1254 ELSE
1255 IF(LVA(NW)+LVB(M).NE.0)GOTO 22
1256c Valence quark-valence quark interaction
1257 LVA(NW)=1
1258 LVB(M)=1
1259 IQV=3
1260 ENDIF
1261 N=N+1
1262 LNH=LNH+1
1263 ENDIF
1264
126522 IQS=1
1266 IF(LNH.NE.0)THEN
1267c-------------------------------------------------
1268c New hard blocks recording:
1269c LNH - number of new hard blocks,
1270c LHA(i) (LHB(j)) - total number of cut hard blocks, connected to i-th projectile
1271c (j-th target) nucleon (hadron);
1272c IAH(k) (IBH(k)) - number (position in array) of the projectile (target) nucleon,
1273c connected to k-th hard block;
1274c ZH(k) - factor exp(-R_ij/R_p) for k-th hard block;
1275c IQH(k) - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
1276c-------------------------------------------------
1277c N - number of cut soft pomerons
1278 N=N-LNH
1279 LHA(NW)=LHA(NW)+LNH
1280 LHB(M)=LHB(M)+LNH
1281 DO 10 I=1,LNH
1282 I1=NHP+I
1283 IF(I.EQ.1.AND.IQV.NE.0)THEN
1284 IQH(I1)=IQV
1285 ELSE
1286 IQH(I1)=0
1287 ENDIF
1288 IF(DEBUG.GE.2)WRITE (MONIOU,209)I1,NW,M,IQH(I1)
1289209 FORMAT(2X,'PSCONF: ',I3,'-TH HARD BLOCK IS CONNECTED TO',1X,
1290 * I2,'-TH PROJECTILE NUCLEON (HADRON) AND'/4X,I2,
1291 * '-TH TARGET NUCLEON; TYPE OF THE SEMIHARD INTERACTION:',I1)
1292 ZH(I1)=Z
1293 IAH(I1)=NW
129410 IBH(I1)=M
1295c-------------------------------------------------
1296c NHP - total number of hard blocks
1297 NHP=NHP+LNH
1298 ENDIF
1299
1300c-------------------------------------------------
1301 IF(N.GT.0)THEN
1302c One more block of soft pomerons; soft block characteristics recording
1303 LS=LS+1
1304 IAS(LS)=NW
1305 IBS(LS)=M
1306 LQA(NW)=LQA(NW)+N
1307 LQB(M)=LQB(M)+N
1308 NQS(LS)=N
1309 IF(DEBUG.GE.2)WRITE (MONIOU,210)LS,NW,M,N
1310210 FORMAT(2X,'PSCONF: ',I3,'-TH SOFT BLOCK IS CONNECTED TO',1X,
1311 * I2,'-TH PROJECTILE NUCLEON (HADRON) AND'/4X,I2,
1312 * '-TH TARGET NUCLEON; NUMBER OF POMERONS IN THE BLOCK NP=',
1313 * I2)
1314 ENDIF
131511 CONTINUE
1316c-------------------------------------------------
1317
1318 IF(IQS.NE.0)GOTO 14
1319c No interaction for projectile nucleon considered
1320 NW=NW-1
132112 CONTINUE
1322
1323c One more projectile spectator (noninteracting) nucleon (spectator positions
1324c are recorded to simulate nuclear fragmentation)
1325 NS=NS+1
1326 IF(NS.NE.IN)THEN
1327 DO 13 L=1,3
132813 XA(NS,L)=XA(IN,L)
1329 ENDIF
133014 CONTINUE
1331
1332c In case of no one interacting (or D-diffracted) nucleon the event is
1333c rejected, new impact parameter is generated and all the procedure is
1334c repeated
1335 IF(NS.EQ.IA(1))THEN
1336 IF(DEBUG.GE.3)WRITE (MONIOU,211)
1337211 FORMAT(2X,'PSCONF: NO ONE NUCLEON (HADRON) INTERACTS - ',
1338 * 'REJECTION')
1339 GOTO 5
1340 ENDIF
1341c-------------------------------------------------
1342 NWT = 0
1343C number of interacting target nucleons
1344 DO 102 IT = 1,NT
1345 NWT = NWT + IWT(IT)
1346 102 CONTINUE
1347
1348cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
1349c Fragmentation of the spectator part of the nucleus
1350 CALL XXFRAGM(NS,XA)
1351cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
1352
1353c Inelastic interaction - energy sharing procedure
135420 IF(NW.NE.0)CALL PSSHAR(LS,NHP,NW,NT)
1355 IF(DEBUG.GE.3)WRITE (MONIOU,212)
1356212 FORMAT(2X,'PSCONF - END')
1357 RETURN
1358 END
1359C=======================================================================
1360
1361 SUBROUTINE PSCS(C,S)
1362c C,S - COS and SIN generation for uniformly distributed angle 0<fi<2*pi
1363c-----------------------------------------------------------------------
1364 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1365 INTEGER DEBUG
1366 COMMON /AREA11/ B10
1367 COMMON /AREA43/ MONIOU
1368 COMMON /DEBUG/ DEBUG
1369 SAVE
1370
1371 IF(DEBUG.GE.2)WRITE (MONIOU,201)
1372201 FORMAT(2X,'PSCS - COS(FI) AND SIN(FI) ARE GENERATED',
1373 * ' (0<FI<2*PI)')
13741 S1=2.D0*PSRAN(B10)-1.D0
1375 S2=2.D0*PSRAN(B10)-1.D0
1376 S3=S1*S1+S2*S2
1377 IF(S3.GT.1.D0)GOTO 1
1378 S3=DSQRT(S3)
1379 C=S1/S3
1380 S=S2/S3
1381 IF(DEBUG.GE.3)WRITE (MONIOU,202)C,S
1382202 FORMAT(2X,'PSCS: C=',E10.3,2X,'S=',E10.3)
1383 RETURN
1384 END
1385C=======================================================================
1386
1387 SUBROUTINE PSDEFTR(S,EP,EY)
1388c Determination of the parameters for the Lorentz transform to the rest frame
1389c system for 4-vector EP
1390c-----------------------------------------------------------------------
1391 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1392 INTEGER DEBUG
1393 DIMENSION EY(3),EP(4)
1394 COMMON /AREA43/ MONIOU
1395 COMMON /DEBUG/ DEBUG
1396
1397 IF(DEBUG.GE.2)WRITE (MONIOU,201)EP,S
1398201 FORMAT(2X,'PSDEFTR - LORENTZ BOOST PARAMETERS:'/
1399 * 4X,'4-VECTOR EP=',4E10.3/4X,'4-VECTOR SQUARED S=',E10.3)
1400 DO 2 I=1,3
1401 IF(EP(I+1).EQ.0.D0)THEN
1402 EY(I)=1.D0
1403 ELSE
1404 WP=EP(1)+EP(I+1)
1405 WM=EP(1)-EP(I+1)
1406 IF(WM/WP.LT.1.D-8)THEN
1407 WW=S
1408 DO 1 L=1,3
14091 IF(L.NE.I)WW=WW+EP(L+1)**2
1410 WM=WW/WP
1411 ENDIF
1412 EY(I)=DSQRT(WM/WP)
1413 EP(1)=WP*EY(I)
1414 EP(I+1)=0.D0
1415 ENDIF
14162 CONTINUE
1417 IF(DEBUG.GE.3)WRITE (MONIOU,202)EY
1418202 FORMAT(2X,'PSDEFTR: LORENTZ BOOST PARAMETERS EY(I)=',2X,3E10.3)
1419 RETURN
1420 END
1421C=======================================================================
1422
1423 SUBROUTINE PSDEFROT(EP,S0X,C0X,S0,C0)
1424c Determination of the parameters the spacial rotation to the lab. system
1425c for 4-vector EP
1426c-----------------------------------------------------------------------
1427 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1428 INTEGER DEBUG
1429 DIMENSION EP(4)
1430 COMMON /AREA43/ MONIOU
1431 COMMON /DEBUG/ DEBUG
1432 IF(DEBUG.GE.2)WRITE (MONIOU,201)EP
1433201 FORMAT(2X,'PSDEFROT - SPACIAL ROTATION PARAMETERS'/4X,
1434 * '4-VECTOR EP=',2X,4(E10.3,1X))
1435c Transverse momentum square for the current parton (EP)
1436 PT2=EP(3)**2+EP(4)**2
1437 IF(PT2.NE.0.D0)THEN
1438 PT=DSQRT(PT2)
1439c System rotation to get Pt=0 - Euler angles are determined (C0X = cos theta,
1440c S0X = sin theta, C0 = cos phi, S0 = sin phi)
1441 C0X=EP(3)/PT
1442 S0X=EP(4)/PT
1443c Total momentum for the gluon
1444 PL=DSQRT(PT2+EP(2)**2)
1445 S0=PT/PL
1446 C0=EP(2)/PL
1447 ELSE
1448 C0X=1.D0
1449 S0X=0.D0
1450 PL=ABS(EP(2))
1451 S0=0.D0
1452 C0=EP(2)/PL
1453 ENDIF
1454
1455 EP(2)=PL
1456 EP(3)=0.D0
1457 EP(4)=0.D0
1458 IF(DEBUG.GE.3)WRITE (MONIOU,202)S0X,C0X,S0,C0,EP
1459202 FORMAT(2X,'PSDEFROT: SPACIAL ROTATION PARAMETERS'/
1460 * 4X,'S0X=',E10.3,2X,'C0X=',E10.3,2X,'S0=',E10.3,2X,'C0=',E10.3/
1461 * 4X,'ROTATED 4-VECTOR EP=',4(E10.3,1X))
1462 RETURN
1463 END
1464C=======================================================================
1465
1466 FUNCTION PSDR(X,Y)
1467c PSDR - impact parameter factor for eikonals calculation (exp(-Rij/Rp)=Z)
1468c-----------------------------------------------------------------------
1469 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1470 INTEGER DEBUG
1471 COMMON /AREA7/ RP
1472 COMMON /AREA43/ MONIOU
1473 COMMON /DEBUG/ DEBUG
1474 SAVE
1475 IF(DEBUG.GE.2)WRITE (MONIOU,201)X,Y
1476201 FORMAT(2X,'PSDR: NUCLEON COORDINATES - X=',E10.3,2X,'Y=',E10.3)
1477 PSDR=EXP(-(X*X+Y*Y)/RP)
1478 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSDR
1479202 FORMAT(2X,'PSDR=',E10.3)
1480 RETURN
1481 END
1482C=======================================================================
1483
1484 FUNCTION PSFAP(X,J,L)
1485C PSFAP - Altarelli-Parisi function (multiplied by X)
1486c X - light cone momentum share value,
1487c J - type of the parent parton (0-g,1-q)
1488c L - type of the daughter parton (0-g,1-q)
1489C-----------------------------------------------------------------------
1490 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1491 INTEGER DEBUG
1492 COMMON /AREA43/ MONIOU
1493 COMMON /DEBUG/ DEBUG
1494
1495 IF(DEBUG.GE.2)WRITE (MONIOU,201)X,J,L
1496201 FORMAT(2X,'PSFAP - ALTARELLI-PARISI FUNCTION:',2X,
1497 * 'X=',E10.3,2X,'J=',I1,2X,'L=',I1)
1498 IF(J.EQ.0)THEN
1499 IF(L.EQ.0)THEN
1500 PSFAP=((1.D0-X)/X+X/(1.D0-X)+X*(1.D0-X))*6.d0
1501 ELSE
1502 PSFAP=(X**2+(1.D0-X)**2)*3.d0
1503 ENDIF
1504 ELSE
1505 IF(l.EQ.0)THEN
1506 PSFAP=(1.D0+(1.D0-X)**2)/X/.75D0
1507 ELSE
1508 PSFAP=(X**2+1.D0)/(1.D0-X)/.75D0
1509 ENDIF
1510 ENDIF
1511 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSFAP
1512202 FORMAT(2X,'PSFAP=',E10.3)
1513 RETURN
1514 END
1515C=======================================================================
1516
1517 FUNCTION PSFAZ(Z,FSOFT,FHARD,FSHARD)
1518c Interaction eikonal for hadron-nucleon (nucleon-nucleon) scattering
1519c Z - impact parameter factor, Z=exp(-b**2/Rp),
1520c FSOFT - soft pomeron eikonal - to be determined,
1521c FSHARD - semihard interaction eikonal (gg) - to be determined,
1522c FHARD(k) - hard interaction eikonal (k=1 - qg, 2 - gq, 3 - qq) -
1523c to be determined,
1524c-----------------------------------------------------------------------
1525 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1526 INTEGER DEBUG
1527 DIMENSION FHARD(3)
1528 COMMON /AREA17/ DEL,RS,RS0,FS,ALF,RR,SH,DELH
1529 COMMON /AREA22/ SJV,FJS(5,3)
1530 COMMON /AREA43/ MONIOU
1531 COMMON /DEBUG/ DEBUG
1532 SAVE
1533
1534 IF(DEBUG.GE.2)WRITE (MONIOU,201)Z
1535201 FORMAT(2X,'PSFAZ - HADRON-NUCLEON (NUCLEON-NUCLEON)',
1536 * ' INTERACTION EIKONAL; Z=',E10.3)
1537 FSOFT=FS*Z
1538 FHARD(3)=SJV*Z**(RS/RS0)
1539
1540 JZ=INT(5.D0*Z)
1541 IF(JZ.GT.3)JZ=3
1542 WZ=5.D0*Z-JZ
1543
1544 DO 1 I=1,3
1545 IF(JZ.EQ.0)THEN
1546 FSR=(EXP(FJS(1,I))*WZ+(EXP(FJS(2,I))-2.D0*
1547 * EXP(FJS(1,I)))*WZ*(WZ-1.D0)*.5D0)*Z
1548 ELSE
1549 FSR=EXP(FJS(JZ,I)+(FJS(JZ+1,I)-FJS(JZ,I))*WZ
1550 * +(FJS(JZ+2,I)+FJS(JZ,I)-2.D0*FJS(JZ+1,I))
1551 * *WZ*(WZ-1.D0)*.5D0)*Z
1552 ENDIF
1553 IF(I.NE.1)THEN
1554 FHARD(I-1)=FSR
1555 ELSE
1556 FSHARD=FSR
1557 ENDIF
15581 CONTINUE
1559
1560 PSFAZ=FSOFT+FSHARD
1561 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSFAZ,FSOFT,FSHARD,FHARD
1562202 FORMAT(2X,'PSFAZ=',E10.3,2X,'FSOFT=',E10.3,2X,'FSHARD=',E10.3/4x,
1563 * 'FHARD=',3E10.3)
1564 RETURN
1565 END
1566C=======================================================================
1567
1568 FUNCTION PSFBORN(S,T,IQ1,IQ2)
1569c PSFBORN - integrand for the Born cross-section (matrix element squared)
1570c S - total c.m. energy squared for the scattering,
1571c T - invariant variable for the scattering abs[(p1-p3)**2],
1572c IQ1 - parton type at current end of the ladder (0 - g, 1,2 - q)
1573c IQ2 - parton type at opposite end of the ladder (0 - g, 1,2 - q)
1574c-----------------------------------------------------------------------
1575 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1576 INTEGER DEBUG
1577 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
1578 COMMON /AREA43/ MONIOU
1579 COMMON /DEBUG/ DEBUG
1580 SAVE
1581
1582 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,T,IQ1,IQ2
1583201 FORMAT(2X,'PSFBORN - HARD SCATTERING MATRIX ELEMENT SQUARED:'/
1584 * 4X,'S=',E10.3,2X,'|T|=',E10.3,2X,'IQ1=',I2,2X,'IQ2=',I2)
1585 U=S-T
1586 IF(IQ1.EQ.0.AND.IQ2.EQ.0)THEN
1587c Gluon-gluon
1588 PSFBORN=(3.D0-T*U/S**2+S*U/T**2+S*T/U**2)*4.5D0
1589 ELSEIF(IQ1*IQ2.EQ.0)THEN
1590c Gluon-quark
1591 PSFBORN=(S**2+U**2)/T**2+(S/U+U/S)/2.25D0
1592 ELSEIF(IQ1.EQ.IQ2)THEN
1593c Quark-quark (of the same flavor)
1594 PSFBORN=((S**2+U**2)/T**2+(S**2+T**2)/U**2)/2.25D0
1595 * -S**2/T/U/3.375D0
1596 ELSEIF(IQ1+IQ2.EQ.0)THEN
1597c Quark-antiquark (of the same flavor)
1598 PSFBORN=((S**2+U**2)/T**2+(U**2+T**2)/S**2)/2.25D0
1599 * -U**2/T/S/3.375D0
1600 ELSE
1601c Quark-quark (different flavors)
1602 PSFBORN=(S**2+U**2)/T**2/2.25D0
1603 ENDIF
1604 IF(DEBUG.GE.2)WRITE (MONIOU,202)PSFBORN
1605202 FORMAT(2X,'PSFBORN=',E10.3)
1606 RETURN
1607 END
1608C=======================================================================
1609
1610 FUNCTION PSFSH(S,Z,ICZ,IQQ)
1611c PSFSH - semihard interaction eikonal
1612c S - energy squared for the interaction (hadron-hadron),
1613c ICZ - type of the primaty hadron (nucleon)
1614c Z - impact parameter factor, Z=exp(-b**2/Rp),
1615c IQQ - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
1616c-----------------------------------------------------------------------
1617 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1618 INTEGER DEBUG
1619 COMMON /AREA6/ PI,BM,AM
1620 COMMON /AREA15/ FP(5),RQ(5),CD(5)
1621 COMMON /AREA17/ DEL,RS,RS0,FS,ALF,RR,SH,DELH
1622 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
1623 COMMON /AREA19/ AHL(5)
1624 COMMON /AREA25/ AHV(5)
1625 COMMON /AREA27/ FP0(5)
1626 COMMON /AR3/ X1(7),A1(7)
1627 COMMON /AREA43/ MONIOU
1628 COMMON /DEBUG/ DEBUG
1629 SAVE
1630
1631 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,Z,IQQ,ICZ
1632201 FORMAT(2X,'PSFSH - SEMIHARD INTERACTION EIKONAL:'/
1633 * 4X,'S=',E10.3,2X,'Z=',E10.3,2X,'IQQ=',I1,2X,'ICZ=',I1)
1634 XMIN=4.D0*QT0/S
1635 XMIN=XMIN**(DELH-DEL)
1636 PSFSH=0.D0
1637 IF(IQQ.EQ.1)THEN
1638 ICV=ICZ
1639 ICQ=2
1640 ELSEIF(IQQ.EQ.2)THEN
1641 ICV=2
1642 ICQ=ICZ
1643 ENDIF
1644 IQ=(IQQ+1)/2
1645
1646c Numerical integration over Z1
1647 DO 3 I=1,7
1648 DO 3 M=1,2
1649 Z1=(.5D0*(1.D0+XMIN-(2*M-3)*X1(I)*(1.D0-XMIN)))**(1.D0/
1650 * (DELH-DEL))
1651c SJ is the DLA inclusive hard partonic (gluon-gluon) interaction
1652c cross-section (inclusive cut ladder cross section) for minimal
1653c 4-momentum transfer squre QT0 and c.m. energy square s_hard = exp YJ;
1654c SJB - Born cross-section
1655 CALL PSJINT0(Z1*S,SJ,SJB,IQ,0)
1656c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic (gluon-gluon)
1657c interaction cross-section for minimal 4-momentum transfer square QT0 and
1658c c.m. energy square s_hard = exp YJ; SH=pi*R_hard**2 (R_hard**2=4/QT0)
1659 GY=2.D0*SH*PSGINT((SJ-SJB)/SH*.5D0)+SJB
1660 IF(DEBUG.GE.3)WRITE (MONIOU,203)Z1*S,GY
1661203 FORMAT(2X,'PSFSH:',2X,'S_HARD=',E10.3,2X,'SIGMA_HARD=',E10.3)
1662
1663 IF(IQQ.EQ.0)THEN
1664 ST2=0.D0
1665 DO 1 J=1,7
1666 DO 1 K=1,2
1667 XX=.5D0*(1.D0+X1(J)*(2*K-3))
16681 ST2=ST2+A1(J)*PSFTILD(Z1**XX,ICZ)*
1669 * PSFTILD(Z1**(1.D0-XX),2)
1670
1671 RH=RS0-ALF*DLOG(Z1)
1672 PSFSH=PSFSH-A1(I)*DLOG(Z1)*GY/Z1**DELH*Z**(RS/RH)/RH*ST2
1673 ELSE
1674
1675 ST2=0.D0
1676 DO 2 J=1,7
1677 DO 2 K=1,2
1678 XX=.5D0*(1.D0+X1(J)*(2*K-3))
1679 XAM=Z1**(DEL+.5D0)
1680 XA=(XAM+(1.D0-XAM)*XX)**(1.D0/(DEL+.5D0))
1681 RH=RS0+ALF*DLOG(XA/Z1)
16822 ST2=ST2+A1(J)*(1.D0-XA)**AHV(ICV)*Z**(RS/RH)/RH*
1683 * PSFTILD(Z1/XA,ICQ)
1684 ST2=ST2*(1.D0-XAM)
1685
1686 PSFSH=PSFSH+A1(I)*GY/Z1**DELH*ST2
1687 ENDIF
16883 CONTINUE
1689
1690 IF(IQQ.EQ.0)THEN
1691 PSFSH=PSFSH*.125D0*RR*(1.D0-XMIN)/(DELH-DEL)*FP0(ICZ)*FP0(2)
1692 * *CD(ICZ)
1693 ELSE
1694 PSFSH=PSFSH*DSQRT(RR)/16.D0*FP0(ICQ)*(1.D0-XMIN)/(DELH-DEL)/
1695 * (DEL+.5D0)*GAMFUN(AHV(ICV)+1.5D0)
1696 * /GAMFUN(AHV(ICV)+1.D0)/PI*CD(ICZ)
1697 IF(ICZ.EQ.2.OR.IQQ.EQ.2)THEN
1698 PSFSH=PSFSH*3.D0
1699 ELSEIF((ICZ-1)*(ICZ-3)*(ICZ-5).EQ.0)THEN
1700 PSFSH=PSFSH*2.D0
1701 ENDIF
1702 ENDIF
1703 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSFSH
1704202 FORMAT(2X,'PSFSH=',E10.3)
1705 RETURN
1706 END
1707C=======================================================================
1708
1709 FUNCTION PSFTILD(Z,ICZ)
1710c PSFTILD - auxilliary function for semihard eikonals calculation -
1711c integration over semihard block light cone momentum share x
1712c Z - x-cutoff from below,
1713c ICZ - type of the hadron to which the semihard block is connected
1714c-----------------------------------------------------------------------
1715 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1716 INTEGER DEBUG
1717 COMMON /AREA17/ DEL,RS,RS0,FS,ALFP,RR,SH,DELH
1718 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
1719 COMMON /AREA19/ AHL(5)
1720 COMMON /AR3/ X1(7),A1(7)
1721 COMMON /AREA43/ MONIOU
1722 COMMON /DEBUG/ DEBUG
1723
1724 IF(DEBUG.GE.2)WRITE (MONIOU,201)Z,ICZ
1725201 FORMAT(2X,'PSFTILD:',2X,'Z=',E10.3,2X,'ICZ=',I1)
1726 PSFTILD=0.
1727 DO 1 I=1,7
1728 DO 1 M=1,2
1729 XB=1.D0-(1.D0-Z)*(.5D0*(1.D0+(2*M-3)*X1(I)))**(1.D0/
1730 * (AHL(ICZ)+1.D0))
17311 PSFTILD=PSFTILD+A1(I)*XB**DEL*(1.D0-Z/XB)**BET
1732 PSFTILD=PSFTILD*.5D0*(1.D0-Z)**(AHL(ICZ)+1.D0)/(AHL(ICZ)+1.D0)
1733 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSFTILD
1734202 FORMAT(2X,'PSFTILD=',E10.3)
1735 RETURN
1736 END
1737C=======================================================================
1738
1739 SUBROUTINE PSGEA(IA,XA,JJ)
1740c PSGEA - nuclear configuration simulation (nucleons positions)
1741c IA - number of nucleons to be considered
1742c-----------------------------------------------------------------------
1743 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1744 INTEGER DEBUG
1745 DIMENSION XA(56,3)
1746 COMMON /AREA5/ RD(2),CA1(2),CA2(2),CA3(2)
1747 COMMON /AREA11/ B10
1748 COMMON /AREA43/ MONIOU
1749 COMMON /DEBUG/ DEBUG
1750 SAVE
1751
1752 IF(DEBUG.GE.2)WRITE (MONIOU,201)JJ,IA
1753201 FORMAT(2X,'PSGEA - CONFIGURATION OF THE NUCLEUS ',I1,';',2X,
1754 * 'COORDINATES FOR ',I2,' NUCLEONS')
1755 IF(JJ.EQ.2.OR.IA.GE.10)THEN
1756
1757 DO 7 I=1,IA
17581 ZUK=PSRAN(B10)*CA1(JJ)-1.D0
1759 IF(ZUK)2,2,3
17602 TT=RD(JJ)*(PSRAN(B10)**.3333D0-1.D0)
1761 GOTO 6
17623 IF(ZUK.GT.CA2(JJ))GOTO 4
1763 TT=-DLOG(PSRAN(B10))
1764 GOTO 6
17654 IF(ZUK.GT.CA3(JJ))GOTO 5
1766 TT=-DLOG(PSRAN(B10))-DLOG(PSRAN(B10))
1767 GOTO 6
17685 TT=-DLOG(PSRAN(B10))-DLOG(PSRAN(B10))-DLOG(PSRAN(B10))
17696 IF(PSRAN(B10).GT.1.D0/(1.D0+EXP(-ABS(TT))))GOTO 1
1770 RIM=TT+RD(JJ)
1771 Z=RIM*(2.D0*PSRAN(B10)-1.D0)
1772 RIM=DSQRT(RIM*RIM-Z*Z)
1773 XA(I,3)=Z
1774 CALL PSCS(C,S)
1775 XA(I,1)=RIM*C
17767 XA(I,2)=RIM*S
1777 ELSE
1778
1779 DO 9 L=1,3
1780 SUMM=0.D0
1781 DO 8 I=1,IA-1
1782 J=IA-I
1783 AKS=RD(JJ)*(PSRAN(B10)+PSRAN(B10)+PSRAN(B10)-1.5D0)
1784 K=J+1
1785 XA(K,L)=SUMM-AKS*SQRT(FLOAT(J)/K)
17868 SUMM=SUMM+AKS/SQRT(FLOAT(J*K))
17879 XA(1,L)=SUMM
1788 ENDIF
1789 IF(DEBUG.GE.3)THEN
1790 WRITE (MONIOU,203)
1791 DO 206 I=1,IA
1792206 WRITE (MONIOU,204)I,(XA(I,L),L=1,3)
1793 WRITE (MONIOU,202)
1794 ENDIF
1795202 FORMAT(2X,'PSGEA - END')
1796203 FORMAT(2X,'PSGEA: POSITIONS OF THE NUCLEONS')
1797204 FORMAT(2X,'PSGEA: ',I2,' - ',3(E10.3,1X))
1798 RETURN
1799 END
1800C=======================================================================
1801
1802 FUNCTION PSGINT(Z)
1803c Auxiliary function for eikonal cross-sections calculation
1804c GINT = int(dt) [0<t<Z] (1-exp(-t))/t
1805c-----------------------------------------------------------------------
1806 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1807 INTEGER DEBUG
1808 COMMON /AR3/ X1(7),A1(7)
1809 COMMON /AREA43/ MONIOU
1810 COMMON /DEBUG/ DEBUG
1811 F(Z,X)=(1.-EXP(-.5*Z*(1.+X)))/(1.+X)
1812
1813 IF(DEBUG.GE.2)WRITE (MONIOU,201)Z
1814201 FORMAT(2X,'PSGINT:',2X,'Z=',E10.3)
1815 PSGINT=0.
1816 DO 5 I=1,7
18175 PSGINT=PSGINT+A1(I)*(F(Z,X1(I))+F(Z,-X1(I)))
1818 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSGINT
1819202 FORMAT(2X,'PSGINT=',E10.3)
1820 RETURN
1821 END
1822C=======================================================================
1823
1824 FUNCTION PSHARD(S,ICZ)
1825c PSHARD - hard quark-quark interaction cross-section
1826c S - energy squared for the interaction (hadron-hadron),
1827c ICZ - type of the primaty hadron (nucleon)
1828c-----------------------------------------------------------------------
1829 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1830 INTEGER DEBUG
1831 COMMON /AR3/ X1(7),A1(7)
1832 COMMON /AREA6/ PI,BM,AM
1833 COMMON /AREA15/ FP(5),RQ(5),CD(5)
1834 COMMON /AREA17/ DEL,RS,RS0,FS,ALF,RR,SH,DELH
1835 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
1836 COMMON /AREA19/ AHL(5)
1837 COMMON /AREA25/ AHV(5)
1838 COMMON /AREA43/ MONIOU
1839 COMMON /DEBUG/ DEBUG
1840 SAVE
1841
1842 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,ICZ
1843201 FORMAT(2X,'PSHARD - HARD QUARK-QUARK INTERACTION CROSS',
1844 * ' SECTION:',
1845 * 2X,'S=',E10.3,2X,'ICZ=',I1)
1846 XMIN=4.D0*QT0/S
1847 XMIN=XMIN**(DELH+.5D0)
1848 PSHARD=0.D0
1849
1850c Numerical integration over Z1
1851 DO 2 I=1,7
1852 DO 2 M=1,2
1853 Z1=(.5D0*(1.D0+XMIN-(2*M-3)*X1(I)*(1.D0-XMIN)))**(1.D0/
1854 * (DELH+.5D0))
1855
1856 ST2=0.D0
1857 DO 1 J=1,7
1858 DO 1 K=1,2
1859 XX=.5D0*(1.D0+X1(J)*(2*K-3))
1860 ST2=ST2+A1(J)*(1.D0-Z1**XX)**AHV(ICZ)*
1861 * (1.D0-Z1**(1.D0-XX))**AHV(2)
18621 CONTINUE
1863
1864c SJ is the DLA inclusive hard partonic (gluon-gluon) interaction
1865c cross-section (inclusive cut ladder cross section) for minimal
1866c 4-momentum transfer squre QT0 and c.m. energy square s_hard = exp YJ;
1867c SJB - Born cross-section
1868 CALL PSJINT0(Z1*S,SJ,SJB,1,1)
1869c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic (quark-quark)
1870c interaction cross-section for minimal 4-momentum transfer square QT0 and
1871c c.m. energy square s_hard = exp YJ; SH=pi*R_hard**2 (R_hard**2=4/QT0)
1872 GY=2.D0*SH*PSGINT((SJ-SJB)/SH*.5D0)+SJB
1873
1874 IF(DEBUG.GE.3)WRITE (MONIOU,203)Z1*S,GY
1875203 FORMAT(2X,'PSHARD:',2X,'S_HARD=',E10.3,2X,'SIGMA_HARD=',E10.3)
1876 PSHARD=PSHARD-A1(I)*DLOG(Z1)*GY/Z1**DELH*ST2
18772 CONTINUE
1878
1879 PSHARD=PSHARD*(1.D0-XMIN)/(.5D0+DELH)*.25D0
1880 PSHARD=PSHARD/(GAMFUN(AHV(ICZ)+1.D0)*GAMFUN(AHV(2)+1.D0)*PI)*
1881 * GAMFUN(AHV(ICZ)+1.5D0)*GAMFUN(AHV(2)+1.5D0)
1882
1883 IF(ICZ.EQ.2)THEN
1884 PSHARD=PSHARD*9.D0
1885 ELSEIF((ICZ-1)*(ICZ-3)*(ICZ-5).EQ.0)THEN
1886 PSHARD=PSHARD*6.D0
1887 ELSE
1888 PSHARD=PSHARD*3.D0
1889 ENDIF
1890
1891c Hard cross-section is divided by Regge radius RS0 and multiplied by
1892c shower enhancement coefficient CD(ICZ) - to be used for the eikonal
1893c calculation
1894 PSHARD=PSHARD/(8.D0*PI*RS0)*CD(ICZ)
1895 IF(DEBUG.GE.2)WRITE (MONIOU,202)PSHARD
1896202 FORMAT(2X,'PSHARD=',E10.3)
1897 RETURN
1898 END
1899C=======================================================================
1900
1901 SUBROUTINE PSHOT(WP0,WM0,Z,IPC,EPC,IZP,IZT,ICZ,IQQ)
1902c Semihard jets production simulation (resulted from parton-parton
1903c interaction);
1904c WP0,WM0 - light cone momenta shares (E+-P_l) for the initial partons
1905c IZP, IZT - types for target and projectile nucleons (hadron)
1906c WPQ - light cone momenta for the soft preevolution - to be determined below
1907c IQQ - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
1908c-----------------------------------------------------------------------
1909 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
1910 INTEGER DEBUG
1911 CHARACTER*2 TYQ
1912 DIMENSION EP(4,2),EPT(4),EPT0(4),EP3(4),EPJ(4),EPJ1(4),EY(3),
1913 * QMIN(2),WP(2),IQC(2),IQP(2),
1914 * IPC(2,2),EPC(8,2),IQJ(2),EQJ(4,2),IPQ(2,2),EPQ(8,2),
1915 * ebal(4),
1916 * QV1(30,50),ZV1(30,50),QM1(30,50),IQV1(2,30,50),
1917 * LDAU1(30,49),LPAR1(30,50),
1918 * QV2(30,50),ZV2(30,50),QM2(30,50),IQV2(2,30,50),
1919 * LDAU2(30,49),LPAR2(30,50)
1920 COMMON /AREA6/ PI,BM,AMMM
1921 COMMON /AREA8/ WWM,BE(4),DC(5),DETA,ALMPT
1922 COMMON /AREA10/ STMASS,AM(7)
1923 COMMON /AREA11/ B10
1924 COMMON /AREA17/ DEL,RS,RS0,FS,ALF,RR,SH,DELH
1925 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
1926 COMMON /AREA42/ TYQ(15)
1927 COMMON /AREA43/ MONIOU
1928 COMMON /AREA46/ EPJET(4,2,1000),IPJET(2,1000)
1929 COMMON /AREA47/ NJTOT
1930 COMMON /DEBUG/ DEBUG
1931 SAVE
1932
1933 IF(DEBUG.GE.1)WRITE (MONIOU,201)IQQ,WP0,WM0
1934201 FORMAT(2X,'PSHOT - SEMIHARD INTERACTION SIMULATION:'/
1935 * 4X,'TYPE OF THE INTERACTION:',I2/
1936 * 4X,'INITIAL LIGHT CONE MOMENTA:',2E10.3)
1937c S - total energy squared for the semihard interaction (including preevolution)
1938 NJTOT0=NJTOT
1939 IZP0=IZP
1940 IZT0=IZT
1941
1942301 S=WP0*WM0
1943 NJTOT=NJTOT0
1944 IZP=IZP0
1945 IZT=IZT0
1946
1947 IF(IQQ.EQ.3)THEN
1948c WPI,WMI - light cone momenta for the hard interaction
1949 WPI=WP0
1950 WMI=WM0
1951c PSJINT0(S,SJ,SJB,1,1) - cross-sections interpolation:
1952c SJ - inclusive hard quark-quark interaction
1953c cross-section (inclusive cut ladder cross section) for minimal
1954c 4-momentum transfer square QT0 and c.m. energy square s_hard = S;
1955c SJB - Born cross-section
1956 CALL PSJINT0(S,SJ,SJB,1,1)
1957c GY= Sigma_hard_tot(YJ,QT0) - total hard quark-quark
1958c interaction cross-section for minimal 4-momentum transfer square QT0 and
1959c c.m. energy square s_hard = S
1960 GY=2.D0*SH*PSGINT((SJ-SJB)/SH*.5D0)+SJB
1961
1962 ELSE
1963c-------------------------------------------------
1964c Rejection function normalization
1965c-------------------------------------------------
1966c XMIN corresponds to minimal energy squared for the hard interaction - 4.D0*(QT0+AMJ0)
1967c AMJ0 - jet mass squared (could be put equal zero)
1968 XMIN=4.D0*(QT0+AMJ0)/S
1969 XMIN1=XMIN**(DELH-DEL)
1970c S - maximal available energy for the rejection function normalization
1971c Auxilliary type of parton (1 - gluon, 2 - (anti-)quark)
1972 IQ=(IQQ+1)/2
1973c Rejection function initialization (corresponding to maximal preevolution - minimal x):
1974c Ysoft = - ln x, (1-x)**bet is due to gluon structure function in the soft pomeron
1975 IF(IQQ.EQ.0)THEN
1976 GB0=-DLOG(XMIN)*(1.D0-DSQRT(XMIN))**(2.D0*BET)
1977 ELSE
1978 GB0=(1.D0-XMIN)**BET
1979 ENDIF
1980
1981c SJ0 is the inclusive hard (parton IQ - gluon) interaction
1982c cross-section (inclusive cut ladder cross section) for minimal
1983c 4-momentum transfer square QT0 and c.m. energy square s_hard = SI;
1984c SJB0 - Born cross-section
1985 CALL PSJINT0(S,SJ,SJB,IQ,0)
1986c GY= Sigma_hard_tot(YJ,QT0) - total hard (parton IQ - gluon)
1987c interaction cross-section for minimal 4-momentum transfer square QT0 and
1988c c.m. energy square s_hard = SI
1989 GY0=2.D0*SH*PSGINT((SJ-SJB)/SH*.5D0)+SJB
1990 GB0=GB0*GY0/S**DELH/RS0*Z
1991c-------------------------------------------------
1992c End of rejection function normalization
1993c-------------------------------------------------
1994
1995c-------------------------------------------------
1996c The sharing of the light cone momenta between soft preevolution and
1997c hard interaction:
1998c ( first energy-momentum is shared according to
1999c f_hard(YJ)~ZPM**(DELH-DEL-1) and then rejected as
2000c W_rej ~Sigma_hard_tot(YJ) / exp(DELH*YJ)
2001c ZPM = s_hard / S
2002c YJ = ln s_hard - rapidity range for the hard parton-parton interaction;
2003c-------------------------------------------------
20041 ZPM=(XMIN1+PSRAN(B10)*(1.D0-XMIN1))**(1.D0/(DELH-DEL))
2005c SJ is the DLA inclusive hard partonic (gluon-gluon) interaction
2006c cross-section (inclusive cut ladder cross section) for minimal
2007c 4-momentum transfer square QT0 and c.m. energy square s_hard = exp YJ;
2008c SJB - Born cross-section
2009 CALL PSJINT0(ZPM*S,SJ,SJB,IQ,0)
2010 YJ=DLOG(ZPM*S)
2011c RH - interaction radius due to soft preevolution
2012 RH=RS0-ALF*DLOG(ZPM)
2013
2014 IF(IQQ.EQ.0)THEN
2015c XP, XM - light cone momunta shares for the hard interaction
2016 XP=ZPM**PSRAN(B10)
2017 XM=ZPM/XP
2018c Ysoft = - ln ZPM - part of rejection function,
2019c (1-XP)**bet*(1-XM)**bet is due to gluon structure function in the soft pomeron
2020 GBYJ=-DLOG(ZPM)*((1.-XP)*(1.-XM))**BET
2021c WPI,WMI - light cone momenta for the hard interaction
2022 WPI=WP0*XP
2023 WMI=WM0*XM
2024 ELSE
2025 IF(IQQ.EQ.1)THEN
2026 WPI=WP0
2027 WMI=WM0*ZPM
2028 ELSE
2029 WPI=WP0*ZPM
2030 WMI=WM0
2031 ENDIF
2032 GBYJ=(1.D0-ZPM)**BET
2033 ENDIF
2034
2035c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic
2036c interaction cross-section for minimal 4-momentum transfer square QT0 and
2037c c.m. energy square s_hard = exp YJ
2038 GY=2.D0*SH*PSGINT((SJ-SJB)/SH*.5D0)+SJB
2039
2040c-------------------------------------------------
2041c GBYJ - rejection function for the YJ (ZPM) simulation:
2042c GBYJ ~ Sigma_hard_tot(YJ,QT0) / exp(DELH*YJ) * exp(-b**2/RH) / RH,
2043 GBYJ=GBYJ*GY*EXP(-DELH*YJ)/GB0*Z**(RS/RH)/RH
2044 IF(PSRAN(B10).GT.GBYJ)GOTO 1
2045 ENDIF
2046c-------------------------------------------------
2047 S=WPI*WMI
2048
2049 IF(DEBUG.GE.2)WRITE (MONIOU,203)S
2050203 FORMAT(2X,'PSHOT: MASS SQUARED FOR THE HARD PARTON-PARTON',
2051 * ' INTERACTION:',E10.3)
2052
2053c In case of valence quark hard interaction the type of quark is determined by the
2054c procedure PSVDEF - flavor combinatorics (not good here); IQC(1) - flavor
2055c for the upper quark (0 in case of gluon),
2056c IQC(2) - the same for the lower one
2057 DO 302 I=1,8
2058 DO 302 M=1,2
2059302 EPC(I,M)=0.D0
2060
2061 IF((IQQ-1)*(IQQ-3).EQ.0)THEN
2062 CALL PSVDEF(IZP,IC1,ICZ)
2063 IQC(1)=IC1
2064 IPC(1,1)=0
2065 IPC(2,1)=0
2066 ELSE
2067 IQC(1)=0
2068 IPC(1,1)=-INT(2.D0*PSRAN(B10)+1.D0)
2069 IPC(2,1)=-IPC(1,1)
2070 WP1=WP0-WPI
2071 WP2=WP1*PSRAN(B10)
2072 WP1=WP1-WP2
2073 EPC(1,1)=.5D0*WP1
2074 EPC(2,1)=EPC(1,1)
2075 EPC(5,1)=.5D0*WP2
2076 EPC(6,1)=EPC(5,1)
2077 ENDIF
2078
2079 IF((IQQ-2)*(IQQ-3).EQ.0)THEN
2080 CALL PSVDEF(IZT,IC1,2)
2081 IQC(2)=IC1
2082 IPC(1,2)=0
2083 IPC(2,2)=0
2084 ELSE
2085 IQC(2)=0
2086 IPC(1,2)=-INT(2.D0*PSRAN(B10)+1.D0)
2087 IPC(2,2)=-IPC(1,2)
2088 WM1=WM0-WMI
2089 WM2=WM1*PSRAN(B10)
2090 WM1=WM1-WM2
2091 EPC(1,2)=.5D0*WM1
2092 EPC(2,2)=-EPC(1,2)
2093 EPC(5,2)=.5D0*WM2
2094 EPC(6,2)=-EPC(5,2)
2095 ENDIF
2096
2097 EPT(1)=.5D0*(WPI+WMI)
2098 EPT(2)=.5D0*(WPI-WMI)
2099 EPT(3)=0.D0
2100 EPT(4)=0.D0
2101c Minimal 4-momentum transfer squares above and below current ladder run
2102 QMIN(1)=QT0
2103 QMIN(2)=QT0
2104 DO 303 L=1,2
2105 DO 303 M=1,2
2106 IPQ(L,M)=IPC(L,M)
2107 DO 303 I=1,4
2108303 EPQ(I+4*(L-1),M)=EPC(I+4*(L-1),M)
2109c Minimal 4-momentum transfer square for gluon-gluon (virtual) interaction
2110 QMINN=MAX(QMIN(1),QMIN(2))
2111 SI=PSNORM(EPT)
2112
21135 CONTINUE
2114c 4-momentum squared (c.m. energy square for gluon-gluon (virtual)
2115c interaction)
2116 IF(DEBUG.GE.2)WRITE (MONIOU,208)ILAD, SI,IQC,EPT
2117208 FORMAT(2X,'PSHOT: ',I2,'-TH HARD LADDER;',
2118 * ' MASS SQUARED FOR THE LADDDER:',E10.3/
2119 * 4X,'LADDER END FLAVORS:',2I3/4X,
2120 * 'LADDER 4-MOMENTUM: ',4E10.3)
2121
2122 ebal(1)=.5*(wp0+wm0)-ept(1)
2123 ebal(2)=.5*(wp0-wm0)-ept(2)
2124 ebal(3)=0.d0-ept(3)
2125 ebal(4)=0.d0-ept(4)
2126 do 503 l=1,4
2127 do 501 m=1,2
2128 ebal(l)=ebal(l)-epq(l,m)
2129501 if(iqc(m).eq.0) ebal(l)=ebal(l)-epq(l+4,m)
2130 if(njtot.ne.0)then
2131 do 502 i=1,njtot
2132 do 502 m=1,2
2133502 ebal(l)=ebal(l)-epjet(l,m,i)
2134 endif
2135503 continue
2136c write (*,*)'ebal',ebal,si,njtot
2137
2138 PT2=EPT(3)**2+EPT(4)**2
2139 PT=DSQRT(PT2)
2140 WW=SI+PT2
2141 SWW=DSQRT(WW)
2142
2143 IQP(1)=MIN(1,IABS(IQC(1)))
2144 IQP(2)=MIN(1,IABS(IQC(2)))
2145
2146c Longitudinal momenta for the interaction
2147 WP(1)=EPT(1)+EPT(2)
2148 WP(2)=EPT(1)-EPT(2)
2149
2150 S2MIN=MAX(QMINN,4.D0*(QT0+AMJ0))
2151c WWMIN is the minimal energy square needed for triple s-channel gluons
2152c production with transverse momentum squares q_t**2 above QMIN(JJ),QMINN
2153 WWMIN=(S2MIN+(PT-DSQRT(QT0))**2+(QT0+AMJ0)*(DSQRT(S2MIN/QT0)-
2154 * 1.D0))/(1.D0-DSQRT(QT0/S2MIN))
2155c SJB/SJ is the probability for the last pair of gluons production
2156c (SJB is the Born cross-section and SJ is the inclusive interaction
2157c (cut ladder) cross-section)
2158 SJ=PSJINT(QMIN(1),QMIN(2),SI,IQP(1)+1,IQP(2)+1)
2159 SJB=PSBINT(QMINN,SI,IQP(1)+1,IQP(2)+1)
2160
2161 IF(DEBUG.GE.2)WRITE (MONIOU,251)S2MIN,WWMIN,SJ,SJB
2162251 FORMAT(2X,'PSHOT: KINEMATICAL BOUNDS S2MIN=',E10.3,
2163 * 2X,'WWMIN=',E10.3/4X,'JET CROSS SETION SJ=',E10.3,
2164 * 2X,'BORN CROSS SECTION SJB=',E10.3)
2165
2166 IF(PSRAN(B10).LT.SJB/SJ.
2167 * OR.WW.LT.1.2D0*WWMIN)GOTO 12
2168
2169 IF((SJ-SJB)/SJ.GT..1D0)THEN
2170 SJ1=PSJINT1(QMIN(1),QMIN(2),SI,IQP(1)+1,IQP(2)+1)
2171 SJ2=PSJINT1(QMIN(2),QMIN(1),SI,IQP(2)+1,IQP(1)+1)
2172 DSJ=(SJ2-SJ1)/(SJ-SJB)*.5D0
2173 ELSE
2174 DSJ=0.D0
2175 ENDIF
2176c Current s-channel gluon is simulated either above the run (JJ=1) or
2177c below it (JJ=2)
2178 JJ=INT(1.5D0+DSJ+PSRAN(B10))
2179
2180 AQ=-(SI+AMJ0+2.D0*PT*DSQRT(QT0))/WW
2181 BQ=(QT0+AMJ0)/WW
2182 CQ=QT0/WW
2183 PQ=-AQ**2/3.D0+BQ
2184 QQ=AQ**3/13.5D0-AQ*BQ/3.D0+CQ
2185 PQ=DSQRT(-PQ/3.D0)
2186 COSQ=-.5D0*QQ/PQ**3
2187 FQ=ATAN(1.D0/COSQ**2-1.D0)
2188 IF(COSQ.LT.0.D0)FQ=PI-FQ
2189 FQ=FQ/3.D0
2190
2191c XMIN is the minimal longitudinal momentum transfer share in current
2192c ladder run (corresponding to minimal 4-momentum transfer square QMIN(JJ))
2193 XMIN=1.D0+AQ/3.D0-2.D0*PQ*COS(FQ)
2194 XMAX=1.D0+AQ/3.D0-PQ*(DSQRT(3.D0)*SIN(FQ)-COS(FQ))
2195c QQMAX is the maximal 4-momentum transfer square in the current run
2196c (corresponding to X=XMIN and 4-momentum transfer at next simulation
2197c step to be equal QMAX)
2198 QQMAX=QT0/(1.D0-XMAX)**2
2199 QQMIN=QT0/(1.D0-XMIN)**2
2200
2201 IF(QQMIN.LT.S2MIN)THEN
2202 XMM=(SI-S2MIN+AMJ0+2.D0*PT*DSQRT(QT0))/WW*.5D0
2203 XMIN=1.D0-XMM-DSQRT(XMM*XMM-(QT0+AMJ0)/WW)
2204 QQMIN=QT0/(1.D0-XMIN)**2
2205
2206 IF(QQMIN.LT.QMIN(JJ))THEN
2207 QQMIN=QMIN(JJ)
2208 XMM1=WW-2.D0*PT*DSQRT(QQMIN)+QQMIN
2209 XMM=(SI-S2MIN+AMJ0)/XMM1*.5D0
2210 XMIN=1.D0-XMM-DSQRT(XMM*XMM-AMJ0/XMM1)
2211 ENDIF
2212 ENDIF
2213
2214*********************************************************
2215 XM0=MAX(.5D0,1.D0-DSQRT(QT0/QMIN(JJ)))
2216 IF(XM0.GT..95D0*XMAX.OR.XM0.LT.1.05D0*XMIN)
2217 * XM0=.5D0*(XMAX+XMIN)
2218 QM0=QT0/(1.D0-XM0)**2
2219 S2MAX=XM0*WW
2220
2221 SJ0=PSJINT(QM0,QMIN(3-JJ),S2MAX,1,IQP(3-JJ)+1)*
2222 * PSFAP(XM0,IQP(JJ),0)+
2223 * PSJINT(QM0,QMIN(3-JJ),S2MAX,2,IQP(3-JJ)+1)
2224 * *PSFAP(XM0,IQP(JJ),1)
2225
2226 GB0=SJ0*QM0/QLOG*PSUDS(QM0,IQP(JJ))*1.5D0
2227 IF(XM0.LE..5D0)THEN
2228 GB0=GB0*XM0**(1.D0-DELH)
2229 ELSE
2230 GB0=GB0*(1.D0-XM0)*2.D0**DELH
2231 ENDIF
2232c XMIN, XMAX are put into power DELH to simulate X value below
2233 XMIN2=MAX(.5D0,XMIN)
2234 XMIN1=XMIN**DELH
2235 XMAX1=MIN(XMAX,.5D0)**DELH
2236 IF(XMIN.GE..5D0)THEN
2237 DJL=1.D0
2238 ELSEIF(XMAX.LT..5D0)THEN
2239 DJL=0.D0
2240 ELSE
2241 DJL=1.D0/(1.D0+((2.D0*XMIN)**DELH-1.D0)/DELH/
2242 * DLOG(2.D0*(1.D0-XMAX)))
2243 ENDIF
2244
22457 CONTINUE
2246c Simulation of the longitudinal momentum transfer share in current
2247c ladder run - from XMIN to XMAX according to dX * X**(DELH-1)
2248 IF(PSRAN(B10).GT.DJL)THEN
2249 X=(XMIN1+PSRAN(B10)*(XMAX1-XMIN1))**(1.D0/DELH)
2250 ELSE
2251 X=1.D0-(1.D0-XMIN2)*((1.D0-XMAX)/(1.D0-XMIN2))**PSRAN(B10)
2252 ENDIF
2253*********************************************************
2254
2255c Effective momentum squared QQ in the ladder run is simulated
2256c first as dq**2/q**4 from QMIN(J) to QMAX
2257 QQ=QQMIN/(1.D0+PSRAN(B10)*(QQMIN/QQMAX-1.D0))
2258
2259 IF(DEBUG.GE.2)WRITE (MONIOU,253)QQ,QQMIN,QQMAX
2260253 FORMAT(2X,'PSHOT: QQ=',E10.3,2X,'QQMIN=',E10.3,2X,
2261 * 'QQMAX=',E10.3)
2262
2263 QT2=QQ*(1.D0-X)**2
2264 IF(QT2.LT.QT0)GOTO 7
2265
2266 IF(QQ.GT.QMINN)THEN
2267 QMIN2=QQ
2268 ELSE
2269 QMIN2=QMINN
2270 ENDIF
2271
2272 QT=DSQRT(QT2)
2273 CALL PSCS(CCOS,SSIN)
2274c EP3 is now 4-vector for s-channel gluon produced in current ladder run
2275 EP3(3)=QT*CCOS
2276 EP3(4)=QT*SSIN
2277 PT2=(EPT(3)-EP3(3))**2+(EPT(4)-EP3(4))**2
2278 S2MIN2=MAX(S2MIN,QMIN2)
2279
2280 ZMIN=(QT2+AMJ0)/WW/(1.D0-X)
2281c S2 is the maximal c.m. energy square for the parton-parton interaction
2282c in the next ladder run
2283 S2=X*(1.D0-ZMIN)*WW-PT2
2284c Rejection in case of too low WW2 (insufficient for elastic gluon-gluon
2285c scattering with transverse momentum square q_t**2 above QMIN2)
2286 IF(S2.LT.S2MIN2)GOTO 7
2287
2288 SJ1=PSJINT(QQ,QMIN(3-JJ),S2,1,IQP(3-jj)+1)
2289 * *PSFAP(X,IQP(JJ),0)
2290 SJ2=PSJINT(QQ,QMIN(3-JJ),S2,2,IQP(3-jj)+1)
2291 * *PSFAP(X,IQP(JJ),1)
2292
2293c GB7 is the rejection function for X and Q**2 simulation. It consists
2294c from factor
2295c Q**2/Qmin**2 * ln(Qmin**2/Lambda_qcd**2)/ln(Q**2/Lambda_qcd**2)
2296c from Q**2 simulation and factor SJ/(X*WW)**DELH * const from X simulation
2297 GB7=(SJ1+SJ2)/DLOG(QT2/ALM)*QQ*PSUDS(QQ,IQP(JJ))/GB0
2298
2299*********************************************************
2300 IF(X.LE..5D0)THEN
2301 GB7=GB7*X**(1.D0-DELH)
2302 ELSE
2303 GB7=GB7*(1.D0-X)*2.D0**DELH
2304 ENDIF
2305*********************************************************
2306 IF(PSRAN(B10).GT.GB7)GOTO 7
2307
2308 IF(PSRAN(B10).LT.SJ1/(SJ1+SJ2))THEN
2309 IF(IQC(JJ).EQ.0)THEN
2310 JT=1
2311 JQ=INT(1.5D0+PSRAN(B10))
2312 IQJ(1)=IPQ(JQ,JJ)
2313 IQJ(2)=0
2314 DO 31 I=1,4
2315 EQJ(I,1)=EPQ(I+4*(JQ-1),JJ)
231631 EQJ(I,2)=0.D0
2317 ELSE
2318 JT=2
2319 IF(IQC(JJ).GT.0)THEN
2320 JQ=1
2321 ELSE
2322 JQ=2
2323 ENDIF
2324 IQJ(1)=0
2325 DO 32 I=1,4
232632 EQJ(I,1)=0.D0
2327
2328 IPQ(JQ,JJ)=IPQ(1,JJ)
2329 DO 135 I=1,4
2330135 EPQ(I+4*(JQ-1),JJ)=EPQ(I,JJ)
2331 ENDIF
2332 IQ1=IQC(JJ)
2333 IQC(JJ)=0
2334
2335 ELSE
2336 IF(IQP(JJ).NE.0)THEN
2337 IQ1=0
2338 JT=3
2339 IF(IQC(JJ).GT.0)THEN
2340 JQ=1
2341 ELSE
2342 JQ=2
2343 ENDIF
2344 IQJ(1)=IPQ(1,JJ)
2345 IQJ(2)=0
2346 DO 33 I=1,4
2347 EQJ(I,1)=EPQ(I,JJ)
234833 EQJ(I,2)=0.D0
2349
2350 ELSE
2351 IQ1=INT(3.D0*PSRAN(B10)+1.D0)*(2*INT(.5D0+PSRAN(B10))-1)
2352 IQC(JJ)=-IQ1
2353 JT=4
2354 IF(IQ1.GT.0)THEN
2355 JQ=1
2356 ELSE
2357 JQ=2
2358 ENDIF
2359 IQJ(1)=IPQ(JQ,JJ)
2360 DO 34 I=1,4
236134 EQJ(I,1)=EPQ(I+4*(JQ-1),JJ)
2362 ENDIF
2363 ENDIF
2364 IF(DEBUG.GE.3)WRITE (MONIOU,240)JT
2365
2366 CALL PSCAJET(QT2,IQ1,QV1,ZV1,QM1,IQV1,
2367 * LDAU1,LPAR1,JQ)
2368 Z=(QT2+QM1(1,1))/WW/(1.D0-X)
2369 SI=X*(1.D0-Z)*WW-PT2
2370
2371 IF(SI.GT.S2MIN2)THEN
2372 IQ=MIN(1,IABS(IQC(JJ)))+1
2373 GB=PSJINT(QQ,QMIN(3-JJ),SI,IQ,IQP(3-JJ)+1)/
2374 * PSJINT(QQ,QMIN(3-JJ),S2,IQ,IQP(3-JJ)+1)
2375 IF(PSRAN(B10).GT.GB)GOTO 301
2376 ELSE
2377 GOTO 301
2378 ENDIF
2379
2380 WP3=WP(JJ)*(1.D0-X)
2381 WM3=(QT2+QM1(1,1))/WP3
2382 EP3(1)=.5D0*(WP3+WM3)
2383 EP3(2)=.5D0*(WP3-WM3)*(3-2*JJ)
2384
2385 PT3=DSQRT(EP3(3)**2+EP3(4)**2)
2386
2387 CALL PSREC(EP3,QV1,ZV1,QM1,IQV1,LDAU1,LPAR1,IQJ,EQJ,JFL,JQ)
2388 IF(JFL.EQ.0)GOTO 301
2389
2390 IF(JT.EQ.1)THEN
2391 IPQ(JQ,JJ)=IQJ(2)
2392 DO 35 I=1,4
239335 EPQ(I+4*(JQ-1),JJ)=EQJ(I,2)
2394
2395 IF(IPC(JQ,JJ).EQ.0)THEN
2396 IPC(JQ,JJ)=IQJ(1)
2397 DO 36 I=1,4
239836 EPC(I+4*(JQ-1),JJ)=EQJ(I,1)
2399 ENDIF
2400
2401 ELSEIF(JT.EQ.2)THEN
2402 IPQ(3-JQ,JJ)=IQJ(1)
2403 DO 37 I=1,4
240437 EPQ(I+4*(2-JQ),JJ)=EQJ(I,1)
2405
2406 ELSEIF(JT.EQ.3)THEN
2407 IPQ(1,JJ)=IQJ(2)
2408 DO 38 I=1,4
240938 EPQ(I,JJ)=EQJ(I,2)
2410
2411 IF(IPC(JQ,JJ).EQ.0)THEN
2412 IPC(JQ,JJ)=IQJ(1)
2413 DO 39 I=1,4
241439 EPC(I+4*(JQ-1),JJ)=EQJ(I,1)
2415 ENDIF
2416
2417 ELSEIF(JT.EQ.4)THEN
2418 IF(IPC(JQ,JJ).EQ.0)THEN
2419 IPC(JQ,JJ)=IQJ(1)
2420 DO 40 I=1,4
242140 EPC(I+4*(JQ-1),JJ)=EQJ(I,1)
2422 ENDIF
2423 IF(JQ.EQ.1)THEN
2424 IPQ(1,JJ)=IPQ(2,JJ)
2425 DO 30 I=1,4
242630 EPQ(I,JJ)=EPQ(I+4,JJ)
2427 ENDIF
2428 ENDIF
2429
2430 IF(IABS(IQ1).EQ.3)THEN
2431 IQQQ=8+IQ1/3*4
2432 ELSE
2433 IQQQ=8+IQ1
2434 ENDIF
2435 IF(DEBUG.GE.2)WRITE (MONIOU,209)TYQ(IQQQ),QT2,EP3
2436209 FORMAT(2X,'PSHOT: NEW JET FLAVOR:',A2,
2437 * ' PT SQUARED FOR THE JET:',E10.3/
2438 * 4X,'JET 4-MOMENTUM:',4E10.3)
2439 DO 8 I=1,4
24408 EPT(I)=EPT(I)-EP3(I)
2441c C.m. energy square, minimal 4-momentum transfer square and gluon 4-vector
2442c for the next ladder run
2443 QMIN(JJ)=QQ
2444 QMINN=QMIN2
2445
2446c Next simulation step will be considered for current ladder
2447 GOTO 5
2448C------------------------------------------------
2449
2450C------------------------------------------------
2451c The last gluon pair production (elastic scattering) in the ladder
2452c is simulated
245312 CONTINUE
2454 IF(DEBUG.GE.2)WRITE (MONIOU,211)SI
2455211 FORMAT(2X,'PSHOT: HIGHEST VIRTUALITY SUBPROCESS IN THE LADDER'/
2456 * 4X,'MASS SQUARED FOR THE PROCESS:',E10.3)
2457
2458 XMIN=QMINN/(QMINN+SI)
2459 XMIN1=.5D0-DSQRT(.25D0-(QT0+AMJ0)/SI)
2460 XMIN=MAX(XMIN,XMIN1)
2461 TMIN=SI*XMIN
2462
2463 IF(IQC(1).NE.0.OR.IQC(2).NE.0)THEN
2464 GB0=TMIN**2/DLOG(TMIN*(1.D0-XMIN)/ALM)**2*
2465 * PSFBORN(SI,TMIN,IQC(1),IQC(2))
2466 ELSE
2467 GB0=.25D0*SI**2/DLOG(TMIN*(1.D0-XMIN)/ALM)**2*
2468 * PSFBORN(SI,.5D0*SI,IQC(1),IQC(2))
2469 ENDIF
2470
2471C------------------------------------------------
2472c 4-momentum transfer squared is simulated first as dq_t**2/q_t**4 from
2473c tmin to s/2
247413 Q2=TMIN/(1.D0-PSRAN(B10)*(1.D0-2.D0*TMIN/SI))
2475 Z=Q2/SI
2476 QT2=Q2*(1.D0-Z)
2477 IF(PSRAN(B10).LT..5D0)THEN
2478 JM=2
2479 TQ=SI-Q2
2480 ELSE
2481 JM=1
2482 TQ=Q2
2483 ENDIF
2484
2485 GB=Q2**2/DLOG(QT2/ALM)**2/GB0*
2486 * PSFBORN(SI,TQ,IQC(1),IQC(2))
2487 IF(DEBUG.GE.3)WRITE (MONIOU,241)Q2,GB
2488241 FORMAT(2X,'PSHOT: Q2=',E10.3,' GB=',E10.3)
2489
2490 IF(PSRAN(B10).GT.GB)GOTO 13
2491
2492 IF(IQC(1).EQ.0.AND.IQC(2).EQ.0)THEN
2493 JQ=INT(1.5D0+PSRAN(B10))
2494 IQJ(1)=IPQ(JQ,JM)
2495 DO 51 I=1,4
249651 EQJ(I,1)=EPQ(I+4*(JQ-1),JM)
2497
2498 IF(PSRAN(B10).LT..5D0)THEN
2499 JT=1
2500 IF(IPQ(3-JQ,JM)*IPQ(JQ,3-JM).NE.0)THEN
2501 IPJ=IPQ(3-JQ,JM)
2502 IPJ1=IPQ(JQ,3-JM)
2503 IF(IABS(IPJ).EQ.3)IPJ=IPJ*4/3
2504 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
2505 DO 52 I=1,4
2506 EPJ(I)=EPQ(I+4*(2-JQ),JM)
250752 EPJ1(I)=EPQ(I+4*(JQ-1),3-JM)
2508 CALL PSJDEF(IPJ,IPJ1,EPJ,EPJ1,JFL)
2509 IF(JFL.EQ.0)GOTO 301
2510 ELSEIF(IPQ(3-JQ,JM).NE.0)THEN
2511 IPC(JQ,3-JM)=IPQ(3-JQ,JM)
2512 DO 53 I=1,4
251353 EPC(I+4*(JQ-1),3-JM)=EPQ(I+4*(2-JQ),JM)
2514 ELSEIF(IPQ(JQ,3-JM).NE.0)THEN
2515 IPC(3-JQ,JM)=IPQ(JQ,3-JM)
2516 DO 54 I=1,4
251754 EPC(I+4*(2-JQ),JM)=EPQ(I+4*(JQ-1),3-JM)
2518 ENDIF
2519
2520 IQJ(2)=0
2521 DO 55 I=1,4
252255 EQJ(I,2)=0.D0
2523
2524 ELSE
2525 JT=2
2526 IQJ(2)=IPQ(3-JQ,3-JM)
2527 DO 56 I=1,4
252856 EQJ(I,2)=EPQ(I+4*(2-JQ),3-JM)
2529 ENDIF
2530
2531 ELSEIF(IQC(1)*IQC(2).EQ.0)THEN
2532 IF(IQC(1)+IQC(2).GT.0)THEN
2533 JQ=1
2534 ELSE
2535 JQ=2
2536 ENDIF
2537
2538 IF(PSRAN(B10).LT..5D0)THEN
2539 IF(IQC(JM).EQ.0)THEN
2540 JT=3
2541 IQJ(1)=IPQ(JQ,JM)
2542 IQJ(2)=0
2543 DO 57 I=1,4
2544 EQJ(I,1)=EPQ(I+4*(JQ-1),JM)
254557 EQJ(I,2)=0.D0
2546
2547 IF(IPQ(3-JQ,JM)*IPQ(1,3-JM).NE.0)THEN
2548 IPJ=IPQ(3-JQ,JM)
2549 IPJ1=IPQ(1,3-JM)
2550 IF(IABS(IPJ).EQ.3)IPJ=IPJ*4/3
2551 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
2552 DO 58 I=1,4
2553 EPJ(I)=EPQ(I+4*(2-JQ),JM)
255458 EPJ1(I)=EPQ(I,3-JM)
2555 CALL PSJDEF(IPJ,IPJ1,EPJ,EPJ1,JFL)
2556 IF(JFL.EQ.0)GOTO 301
2557 ELSEIF(IPQ(3-JQ,JM).NE.0)THEN
2558 IPC(JQ,3-JM)=IPQ(3-JQ,JM)
2559 DO 59 I=1,4
256059 EPC(I+4*(JQ-1),3-JM)=EPQ(I+4*(2-JQ),JM)
2561 ELSEIF(IPQ(1,3-JM).NE.0)THEN
2562 IPC(3-JQ,JM)=IPQ(1,3-JM)
2563 DO 60 I=1,4
256460 EPC(I+4*(2-JQ),JM)=EPQ(I,3-JM)
2565 ENDIF
2566
2567 ELSE
2568 JT=4
2569 IQJ(1)=0
2570 DO 61 I=1,4
257161 EQJ(I,1)=0.D0
2572
2573 IF(IPQ(1,JM)*IPQ(3-JQ,3-JM).NE.0)THEN
2574 IPJ=IPQ(1,JM)
2575 IPJ1=IPQ(3-JQ,3-JM)
2576 IF(IABS(IPJ).EQ.3)IPJ=IPJ*4/3
2577 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
2578 DO 62 I=1,4
2579 EPJ(I)=EPQ(I,JM)
258062 EPJ1(I)=EPQ(I+4*(2-JQ),3-JM)
2581 CALL PSJDEF(IPJ,IPJ1,EPJ,EPJ1,JFL)
2582 IF(JFL.EQ.0)GOTO 301
2583 ELSEIF(IPQ(3-JQ,3-JM).NE.0)THEN
2584 IPC(JQ,JM)=IPQ(3-JQ,3-JM)
2585 DO 63 I=1,4
258663 EPC(I+4*(JQ-1),JM)=EPQ(I+4*(2-JQ),3-JM)
2587 ELSEIF(IPQ(1,JM).NE.0)THEN
2588 IPC(3-JQ,3-JM)=IPQ(1,JM)
2589 DO 64 I=1,4
259064 EPC(I+4*(2-JQ),3-JM)=EPQ(I,JM)
2591 ENDIF
2592 ENDIF
2593
2594 ELSE
2595 IF(IQC(JM).EQ.0)THEN
2596 JT=5
2597 IQJ(2)=IPQ(3-JQ,JM)
2598 IQJ(1)=IPQ(1,3-JM)
2599 DO 65 I=1,4
2600 EQJ(I,2)=EPQ(I+4*(2-JQ),JM)
260165 EQJ(I,1)=EPQ(I,3-JM)
2602 ELSE
2603 JT=6
2604 IQJ(1)=IPQ(JQ,3-JM)
2605 DO 66 I=1,4
260666 EQJ(I,1)=EPQ(I+4*(JQ-1),3-JM)
2607 ENDIF
2608 ENDIF
2609
2610 ELSEIF(IQC(1)*IQC(2).GT.0)THEN
2611 JT=7
2612 IF(IQC(1).GT.0)THEN
2613 JQ=1
2614 ELSE
2615 JQ=2
2616 ENDIF
2617 IQJ(1)=IPQ(1,3-JM)
2618 DO 67 I=1,4
261967 EQJ(I,1)=EPQ(I,3-JM)
2620
2621 ELSE
2622 JT=8
2623 IF(IQC(JM).GT.0)THEN
2624 JQ=1
2625 ELSE
2626 JQ=2
2627 ENDIF
2628 IQJ(1)=0
2629 DO 68 I=1,4
263068 EQJ(I,1)=0.D0
2631
2632 IF(IPQ(1,JM)*IPQ(1,3-JM).NE.0)THEN
2633 IPJ=IPQ(1,JM)
2634 IPJ1=IPQ(1,3-JM)
2635 IF(IABS(IPJ).EQ.3)IPJ=IPJ*4/3
2636 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
2637 DO 69 I=1,4
2638 EPJ(I)=EPQ(I,JM)
263969 EPJ1(I)=EPQ(I,3-JM)
2640 CALL PSJDEF(IPJ,IPJ1,EPJ,EPJ1,JFL)
2641 IF(JFL.EQ.0)GOTO 301
2642 ELSEIF(IPQ(1,3-JM).NE.0)THEN
2643 IPC(JQ,JM)=IPQ(1,3-JM)
2644 DO 70 I=1,4
264570 EPC(I+4*(JQ-1),JM)=EPQ(I,3-JM)
2646 ELSEIF(IPQ(1,JM).NE.0)THEN
2647 IPC(3-JQ,3-JM)=IPQ(1,JM)
2648 DO 71 I=1,4
264971 EPC(I+4*(2-JQ),3-JM)=EPQ(I,JM)
2650 ENDIF
2651 ENDIF
2652 IF(JT.NE.8)THEN
2653 JQ2=JQ
2654 ELSE
2655 JQ2=3-JQ
2656 ENDIF
2657 IF(DEBUG.GE.3)WRITE (MONIOU,240)JT
2658240 FORMAT(2X,'PSHOT: COLOUR CONNECTION JT=:',I1)
2659
2660 CALL PSCAJET(QT2,IQC(JM),QV1,ZV1,QM1,IQV1,
2661 * LDAU1,LPAR1,JQ)
2662 CALL PSCAJET(QT2,IQC(3-JM),QV2,ZV2,QM2,IQV2,
2663 * LDAU2,LPAR2,JQ2)
2664
2665 AMT1=QT2+QM1(1,1)
2666 AMT2=QT2+QM2(1,1)
2667
2668 IF(DSQRT(SI).GT.DSQRT(AMT1)+DSQRT(AMT2))THEN
2669 Z=XXTWDEC(SI,AMT1,AMT2)
2670 ELSE
2671 GOTO 301
2672 ENDIF
2673
2674 CALL PSDEFTR(SI,EPT,EY)
2675
2676 WP3=Z*DSQRT(SI)
2677 WM3=(QT2+QM1(1,1))/WP3
2678 EP3(1)=.5D0*(WP3+WM3)
2679 EP3(2)=.5D0*(WP3-WM3)
2680 QT=DSQRT(QT2)
2681 CALL PSCS(CCOS,SSIN)
2682c ep3 is now 4-vector for first s-channel gluon produced in the ladder run
2683 EP3(3)=QT*CCOS
2684 EP3(4)=QT*SSIN
2685
2686 CALL PSTRANS(EP3,EY)
2687 PT3=DSQRT(EP3(3)**2+EP3(4)**2)
2688
2689 CALL PSREC(EP3,QV1,ZV1,QM1,IQV1,LDAU1,LPAR1,IQJ,EQJ,JFL,JQ)
2690 IF(JFL.EQ.0)GOTO 301
2691
2692 if(iabs(IQC(JM)).eq.3)then
2693 iqqq=8+IQC(JM)/3*4
2694 else
2695 iqqq=8+IQC(JM)
2696 endif
2697 IF(DEBUG.GE.2)WRITE (MONIOU,209)TYQ(IQQQ),QT2
2698
2699 WP3=(1.D0-Z)*DSQRT(SI)
2700 WM3=(QT2+QM2(1,1))/WP3
2701 EP3(1)=.5D0*(WP3+WM3)
2702 EP3(2)=.5D0*(WP3-WM3)
2703 EP3(3)=-QT*CCOS
2704 EP3(4)=-QT*SSIN
2705 CALL PSTRANS(EP3,EY)
2706 PT3=DSQRT(EP3(3)**2+EP3(4)**2)
2707
2708 IF(JT.EQ.1)THEN
2709 IF(IPC(JQ,JM).EQ.0)THEN
2710 IPC(JQ,JM)=IQJ(1)
2711 DO 72 I=1,4
271272 EPC(I+4*(JQ-1),JM)=EQJ(I,1)
2713 ENDIF
2714
2715 IQJ(1)=IQJ(2)
2716 IQJ(2)=IPQ(3-JQ,3-JM)
2717 DO 73 I=1,4
2718 EQJ(I,1)=EQJ(I,2)
271973 EQJ(I,2)=EPQ(I+4*(2-JQ),3-JM)
2720
2721 ELSEIF(JT.EQ.2)THEN
2722 IF(IPC(JQ,JM).EQ.0)THEN
2723 IPC(JQ,JM)=IQJ(1)
2724 DO 74 I=1,4
272574 EPC(I+4*(JQ-1),JM)=EQJ(I,1)
2726 ENDIF
2727 IF(IPC(3-JQ,3-JM).EQ.0)THEN
2728 IPC(3-JQ,3-JM)=IQJ(2)
2729 DO 75 I=1,4
273075 EPC(I+4*(2-JQ),3-JM)=EQJ(I,2)
2731 ENDIF
2732
2733 IQJ(2)=IPQ(3-JQ,JM)
2734 IQJ(1)=IPQ(JQ,3-JM)
2735 DO 76 I=1,4
2736 EQJ(I,2)=EPQ(I+4*(2-JQ),JM)
273776 EQJ(I,1)=EPQ(I+4*(JQ-1),3-JM)
2738
2739 ELSEIF(JT.EQ.3)THEN
2740 IF(IPC(JQ,JM).EQ.0)THEN
2741 IPC(JQ,JM)=IQJ(1)
2742 DO 77 I=1,4
274377 EPC(I+4*(JQ-1),JM)=EQJ(I,1)
2744 ENDIF
2745 IQJ(1)=IQJ(2)
2746 DO 78 I=1,4
274778 EQJ(I,1)= EQJ(I,2)
2748
2749 ELSEIF(JT.EQ.4)THEN
2750 IQJ(2)=IQJ(1)
2751 IQJ(1)=IPQ(JQ,3-JM)
2752 DO 79 I=1,4
2753 EQJ(I,2)=EQJ(I,1)
275479 EQJ(I,1)=EPQ(I+4*(JQ-1),3-JM)
2755
2756 ELSEIF(JT.EQ.5)THEN
2757 IF(IPC(3-JQ,JM).EQ.0)THEN
2758 IPC(3-JQ,JM)=IQJ(2)
2759 DO 80 I=1,4
276080 EPC(I+4*(2-JQ),JM)=EQJ(I,2)
2761 ENDIF
2762 IF(IPC(JQ,3-JM).EQ.0)THEN
2763 IPC(JQ,3-JM)=IQJ(1)
2764 DO 81 I=1,4
276581 EPC(I+4*(JQ-1),3-JM)=EQJ(I,1)
2766 ENDIF
2767
2768 IQJ(1)=IPQ(JQ,JM)
2769 DO 82 I=1,4
277082 EQJ(I,1)=EPQ(I+4*(JQ-1),JM)
2771
2772 ELSEIF(JT.EQ.6)THEN
2773 IF(IPC(JQ,3-JM).EQ.0)THEN
2774 IPC(JQ,3-JM)=IQJ(1)
2775 DO 83 I=1,4
277683 EPC(I+4*(JQ-1),3-JM)=EQJ(I,1)
2777 ENDIF
2778
2779 IQJ(2)=IPQ(3-JQ,3-JM)
2780 IQJ(1)=IPQ(1,JM)
2781 DO 84 I=1,4
2782 EQJ(I,2)=EPQ(I+4*(2-JQ),3-JM)
278384 EQJ(I,1)=EPQ(I,JM)
2784
2785 ELSEIF(JT.EQ.7)THEN
2786 IF(IPC(JQ,3-JM).EQ.0)THEN
2787 IPC(JQ,3-JM)=IQJ(1)
2788 DO 85 I=1,4
278985 EPC(I+4*(JQ-1),3-JM)=EQJ(I,1)
2790 ENDIF
2791 IQJ(1)=IPQ(1,JM)
2792 DO 86 I=1,4
279386 EQJ(I,1)= EPQ(I,JM)
2794 ENDIF
2795
2796 CALL PSREC(EP3,QV2,ZV2,QM2,IQV2,LDAU2,LPAR2,IQJ,EQJ,JFL,JQ2)
2797 IF(JFL.EQ.0)GOTO 301
2798
2799 if(iabs(IQC(3-JM)).eq.3)then
2800 iqqq=8+IQC(3-JM)/3*4
2801 else
2802 iqqq=8+IQC(3-JM)
2803 endif
2804 IF(DEBUG.GE.2)WRITE (MONIOU,209)TYQ(IQQQ),QT2
2805 IF(DEBUG.GE.2)WRITE (MONIOU,212)NJTOT
2806212 FORMAT(2X,'PSHOT: TOTAL NUMBER OF JETS:',I2)
2807
2808 IF(JT.EQ.1)THEN
2809 IF(IPC(3-JQ,3-JM).EQ.0)THEN
2810 IPC(3-JQ,3-JM)=IQJ(2)
2811 DO 87 I=1,4
281287 EPC(I+4*(2-JQ),3-JM)=EQJ(I,2)
2813 ENDIF
2814
2815 ELSEIF(JT.EQ.2)THEN
2816 IF(IPC(3-JQ,JM).EQ.0)THEN
2817 IPC(3-JQ,JM)=IQJ(2)
2818 DO 88 I=1,4
281988 EPC(I+4*(2-JQ),JM)=EQJ(I,2)
2820 ENDIF
2821 IF(IPC(JQ,3-JM).EQ.0)THEN
2822 IPC(JQ,3-JM)=IQJ(1)
2823 DO 89 I=1,4
282489 EPC(I+4*(JQ-1),3-JM)=EQJ(I,1)
2825 ENDIF
2826
2827 ELSEIF(JT.EQ.4)THEN
2828 IF(IPC(JQ,3-JM).EQ.0)THEN
2829 IPC(JQ,3-JM)=IQJ(1)
2830 DO 90 I=1,4
283190 EPC(I+4*(JQ-1),3-JM)=EQJ(I,1)
2832 ENDIF
2833
2834 ELSEIF(JT.EQ.5)THEN
2835 IF(IPC(JQ,JM).EQ.0)THEN
2836 IPC(JQ,JM)=IQJ(1)
2837 DO 91 I=1,4
283891 EPC(I+4*(JQ-1),JM)=EQJ(I,1)
2839 ENDIF
2840
2841 ELSEIF(JT.EQ.6)THEN
2842 IF(IPC(3-JQ,3-JM).EQ.0)THEN
2843 IPC(3-JQ,3-JM)=IQJ(2)
2844 DO 92 I=1,4
284592 EPC(I+4*(2-JQ),3-JM)=EQJ(I,2)
2846 ENDIF
2847 IF(IPC(JQ,JM).EQ.0)THEN
2848 IPC(JQ,JM)=IQJ(1)
2849 DO 93 I=1,4
285093 EPC(I+4*(JQ-1),JM)=EQJ(I,1)
2851 ENDIF
2852
2853 ELSEIF(JT.EQ.7)THEN
2854 IF(IPC(JQ,JM).EQ.0)THEN
2855 IPC(JQ,JM)=IQJ(1)
2856 DO 94 I=1,4
285794 EPC(I+4*(JQ-1),JM)=EQJ(I,1)
2858 ENDIF
2859 ENDIF
2860C------------------------------------------------
2861
2862 IF(DEBUG.GE.3)WRITE (MONIOU,217)
2863217 FORMAT(2X,'PSHOT - END')
2864 ebal(1)=.5*(wp0+wm0)
2865 ebal(2)=.5*(wp0-wm0)
2866 ebal(3)=0.d0
2867 ebal(4)=0.d0
2868 do 500 i=1,njtot
2869 do 500 m=1,2
2870 do 500 l=1,4
2871500 ebal(l)=ebal(l)-epjet(l,m,i)
2872c write (*,*)'ebal',ebal
2873 RETURN
2874 END
2875C=======================================================================
2876
2877 SUBROUTINE PSJDEF(IPJ,IPJ1,EPJ,EPJ1,JFL)
2878c Procedure for jet hadronization - each gluon is
2879c considered to be splitted into quark-antiquark pair and usual soft
2880c strings are assumed to be formed between quark and antiquark
2881c-----------------------------------------------------------------------
2882 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2883 INTEGER DEBUG
2884 DIMENSION EPJ(4),EPJ1(4),EPT(4)
2885 COMMON /AREA10/ STMASS,AM(7)
2886 COMMON /AREA43/ MONIOU
2887 COMMON /DEBUG/ DEBUG
2888 COMMON /AREA46/ EPJET(4,2,1000),IPJET(2,1000)
2889 COMMON /AREA47/ NJTOT
2890c if(ipj*ipj1.gt.0.and.iabs(ipj).ne.3.and.iabs(ipj).le.4.
2891c * and.iabs(ipj1).ne.3.and.iabs(ipj1).le.4.or.
2892c * ipj*ipj1.lt.0.and.(iabs(ipj).eq.3.or.iabs(ipj).gt.4.
2893c * or.iabs(ipj1).eq.3.or.iabs(ipj1).eq.4))then
2894c write (*,*)'ipj,ipj1',ipj,ipj1
2895c read (*,*)
2896c endif
2897
2898 IF(DEBUG.GE.2)WRITE (MONIOU,201)IPJ,IPJ1,EPJ,EPJ1
2899201 FORMAT(2X,'PSJDEF: PARTON FLAVORS',
2900 * ': IPJ=',I2,2X,'IPJ1=',I2/
2901 * 4X,'PARTON 4-MOMENTA:',2X,4(E10.3,1X))
2902 DO 1 I=1,4
29031 EPT(I)=EPJ(I)+EPJ1(I)
2904
2905c Invariant mass squared for the jet
2906 WW=PSNORM(EPt)
2907c Minimal mass squared for the jet
2908 IF(IABS(IPJ).LE.2)THEN
2909 AM1=AM(1)
2910 ELSEIF(IABS(IPJ).EQ.4)THEN
2911 AM1=AM(3)
2912 ELSE
2913 AM1=AM(2)
2914 ENDIF
2915 IF(IABS(IPJ1).LE.2)THEN
2916 AM2=AM(1)
2917 ELSEIF(IABS(IPJ1).EQ.4)THEN
2918 AM2=AM(3)
2919 ELSE
2920 AM2=AM(2)
2921 ENDIF
2922 AMJ=(AM1+AM2)**2
2923
2924 IF(AMJ.GT.WW)THEN
2925 JFL=0
2926 RETURN
2927 ELSE
2928 JFL=1
2929 ENDIF
2930
2931 NJTOT=NJTOT+1
2932 IPJET(1,NJTOT)=IPJ
2933 IPJET(2,NJTOT)=IPJ1
2934 DO 2 I=1,4
2935 EPJET(I,1,NJTOT)=EPJ(I)
29362 EPJET(I,2,NJTOT)=EPJ1(I)
2937
2938 IF(DEBUG.GE.3)WRITE (MONIOU,202)
2939202 FORMAT(2X,'PSJDEF - END')
2940 RETURN
2941 END
2942C=======================================================================
2943
2944 FUNCTION PSJET(Q1,Q2,S,S2MIN,J,L)
2945C PSJET - inclusive hard cross-section calculation (one more run is added
2946c to the ladder) - for any ordering
2947c Q1 - effective momentum cutoff for current end of the ladder,
2948c Q2 - effective momentum cutoff for opposide end of the ladder,
2949c S - total c.m. energy squared for the ladder,
2950c S2MIN - minimal c.m. energy squared for BORN process (above Q1 and Q2)
2951c J - parton type at current end of the ladder (0 - g, 1 - q)
2952c L - parton type at opposite end of the ladder (1 - g, 2 - q)
2953C-----------------------------------------------------------------------
2954 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2955 INTEGER DEBUG
2956 COMMON /AREA6/ PI,BM,AM
2957 COMMON /AREA17/ DEL,RS,RS0,FS,ALF,RR,SH,DELH
2958 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
2959 COMMON/AR3/X1(7),A1(7)
2960 COMMON /AREA43/ MONIOU
2961 COMMON /DEBUG/ DEBUG
2962 SAVE
2963
2964 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,Q1,Q2,S2MIN,J,L
2965201 FORMAT(2X,'PSJET - UNORDERED LADDER CROSS SECTION:'/
2966 * 4X,'S=',E10.3,2X,'Q1=',E10.3,2X,'Q2=',E10.3,2X,'S2MIN=',
2967 * E10.3,2X,'J=',I1,2X,'L=',I1)
2968 PSJET=0.D0
2969
2970 P=DSQRT(1.D0-3.D0*QT0/S)
2971 COSF=(1.D0-18.D0*QT0/S)/P**3
2972 FI=ATAN(1.D0/COSF**2-1.D0)
2973 IF(COSF.LT.0.D0)FI=PI-FI
2974 FI=FI/3.D0
2975 ZMAX=(2.D0-P*(DSQRT(3.D0)*SIN(FI)-COS(FI)))/3.D0
2976 ZMIN=(1.D0-P*COS(FI))/1.5D0
2977
2978 IF(QT0/(1.D0-ZMIN)**2.LT.S2MIN)
2979 * ZMIN=.5D0*(1.D0+S2MIN/S-DSQRT((1.D0-S2MIN/S)**2-4.D0*QT0/S))
2980
2981***********************************************************
2982 IF(1.D0-ZMIN.LT.DSQRT(QT0/Q1))THEN
2983 QMIN=QT0/(1.D0-ZMIN)**2
2984 ELSE
2985 QMIN=Q1
2986 ENDIF
2987
2988 QMAX=QT0/(1.D0-ZMAX)**2
2989 SUD0=PSUDS(QMIN,J)
2990***********************************************************
2991
2992 IF(DEBUG.GE.3)WRITE (MONIOU,203)QMIN,QMAX
2993203 FORMAT(2X,'PSJET:',2X,'QMIN=',E10.3,2X,'QMAX=',E10.3)
2994 IF(QMAX.GT.QMIN)THEN
2995
2996c Numerical integration over transverse momentum square;
2997c Gaussian integration is used
2998 DO 3 I=1,7
2999 DO 3 M=1,2
3000 QI=2.D0*QMIN/(1.D0+QMIN/QMAX+(2*M-3)*X1(I)*(1.D0-QMIN/QMAX))
3001
3002 ZMAX=(1.D0-DSQRT(QT0/QI))**DELH
3003 ZMIN=((QI+MAX(QI,S2MIN))/(QI+S))**DELH
3004
3005 FSJ=0.D0
3006
3007 IF(DEBUG.GE.3)WRITE (MONIOU,204)QI,ZMIN,ZMAX
3008204 FORMAT(2X,'PSJET:',2X,'QI=',E10.3,2X,'ZMIN=',E10.3,2X,
3009 * 'ZMAX=',E10.3)
3010 IF(ZMAX.GT.ZMIN)THEN
3011 DO 2 I1=1,7
3012 DO 2 M1=1,2
3013 Z=(.5D0*(ZMAX+ZMIN+(2*M1-3)*X1(I1)*(ZMAX-ZMIN)))**
3014 * (1.D0/DELH)
3015 QT=QI*(1.D0-Z)**2
3016 S2=Z*S-QI*(1.D0-Z)
3017
3018 SJ=0.D0
3019 DO 1 K=1,2
30201 SJ=SJ+PSJINT(QI,Q2,S2,K,L)*PSFAP(Z,J,K-1)*Z
30212 FSJ=FSJ+A1(I1)*SJ/DLOG(QT/ALM)/Z**DELH
3022 FSJ=FSJ*(ZMAX-ZMIN)
3023 ENDIF
3024
30253 PSJET=PSJET+A1(I)*FSJ*QI*PSUDS(QI,J)
3026 PSJET=PSJET*(1.D0/QMIN-1.D0/QMAX)/SUD0/DELH/18.D0
3027 ENDIF
3028 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSJET
3029202 FORMAT(2X,'PSJET=',E10.3)
3030 RETURN
3031 END
3032C=======================================================================
3033
3034 FUNCTION PSJET1(Q1,Q2,S,S2MIN,J,L)
3035C PSJET1 - inclusive hard cross-section calculation (one more run is added
3036c to the ladder) - for strict ordering
3037c Q1 - effective momentum cutoff for current end of the ladder,
3038c Q2 - effective momentum cutoff for opposide end of the ladder,
3039c S - total c.m. energy squared for the ladder,
3040c S2MIN - minimal c.m. energy squared for BORN process (above Q1 and Q2)
3041c J - parton type at current end of the ladder (0 - g, 1 - q)
3042c L - parton type at opposite end of the ladder (1 - g, 2 - q)
3043C-----------------------------------------------------------------------
3044 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3045 INTEGER DEBUG
3046 COMMON /AREA6/ PI,BM,AM
3047 COMMON /AREA17/ DEL,RS,RS0,FS,ALF,RR,SH,DELH
3048 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
3049 COMMON/AR3/X1(7),A1(7)
3050 COMMON /AREA43/ MONIOU
3051 COMMON /DEBUG/ DEBUG
3052 SAVE
3053
3054 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,Q1,Q2,S2MIN,J,L
3055201 FORMAT(2X,'PSJET1 - STRICTLY ORDERED LADDER CROSS SECTION:'/
3056 * 4X,'S=',E10.3,2X,'Q1=',E10.3,2X,'Q2=',E10.3,2X,'S2MIN=',
3057 * E10.3,2X,'J=',I1,2X,'L=',I1)
3058 PSJET1=0.D0
3059
3060 P=DSQRT(1.D0-3.D0*QT0/S)
3061 COSF=(1.D0-18.D0*QT0/S)/P**3
3062 FI=ATAN(1.D0/COSF**2-1.D0)
3063 IF(COSF.LT.0.D0)FI=PI-FI
3064 FI=FI/3.D0
3065 ZMAX=(2.D0-P*(DSQRT(3.D0)*SIN(FI)-COS(FI)))/3.D0
3066 ZMIN=(1.D0-P*COS(FI))/1.5D0
3067
3068 IF(QT0/(1.D0-ZMIN)**2.LT.S2MIN)
3069 * ZMIN=.5D0*(1.D0+S2MIN/S-DSQRT((1.D0-S2MIN/S)**2-4.D0*QT0/S))
3070
3071***********************************************************
3072 IF(1.D0-ZMIN.LT.DSQRT(QT0/Q1))THEN
3073 QMIN=QT0/(1.D0-ZMIN)**2
3074 ELSE
3075 QMIN=Q1
3076 ENDIF
3077
3078 QMAX=QT0/(1.D0-ZMAX)**2
3079 SUD0=PSUDS(QMIN,J)
3080***********************************************************
3081
3082 IF(DEBUG.GE.3)WRITE (MONIOU,203)QMIN,QMAX
3083203 FORMAT(2X,'PSJET1:',2X,'QMIN=',E10.3,2X,'QMAX=',E10.3)
3084 IF(QMAX.GT.QMIN)THEN
3085
3086c Numerical integration over transverse momentum square;
3087c Gaussian integration is used
3088 DO 3 I=1,7
3089 DO 3 M=1,2
3090 QI=2.D0*QMIN/(1.D0+QMIN/QMAX+(2*M-3)*X1(I)*(1.D0-QMIN/QMAX))
3091
3092 ZMAX=(1.D0-DSQRT(QT0/QI))**DELH
3093 ZMIN=((QI+MAX(QI,S2MIN))/(QI+S))**DELH
3094
3095 FSJ=0.D0
3096
3097 IF(DEBUG.GE.3)WRITE (MONIOU,204)QI,ZMIN,ZMAX
3098204 FORMAT(2X,'PSJET1:',2X,'QI=',E10.3,2X,'ZMIN=',E10.3,2X,
3099 * 'ZMAX=',E10.3)
3100 IF(ZMAX.GT.ZMIN)THEN
3101 DO 2 I1=1,7
3102 DO 2 M1=1,2
3103 Z=(.5D0*(ZMAX+ZMIN+(2*M1-3)*X1(I1)*(ZMAX-ZMIN)))**
3104 * (1.D0/DELH)
3105 QT=QI*(1.D0-Z)**2
3106 S2=Z*S-QI*(1.D0-Z)
3107
3108 SJ=0.D0
3109 DO 1 K=1,2
31101 SJ=SJ+PSJINT1(QI,Q2,S2,K,L)*PSFAP(Z,J,K-1)*Z
3111
31122 FSJ=FSJ+A1(I1)*SJ/DLOG(QT/ALM)/Z**DELH
3113 FSJ=FSJ*(ZMAX-ZMIN)
3114 ENDIF
3115
31163 PSJET1=PSJET1+A1(I)*FSJ*QI*PSUDS(QI,J)
3117 PSJET1=PSJET1*(1.D0/QMIN-1.D0/QMAX)/SUD0/DELH/18.D0
3118 ENDIF
3119 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSJET1
3120202 FORMAT(2X,'PSJET1=',E10.3)
3121 RETURN
3122 END
3123C=======================================================================
3124
3125 FUNCTION PSJINT(Q1,Q2,S,M,L)
3126C PSJINT - inclusive hard cross-section interpolation - for any ordering
3127c in the ladder
3128c Q1 - effective momentum cutoff for current end of the ladder,
3129c Q2 - effective momentum cutoff for opposide end of the ladder,
3130c S - total c.m. energy squared for the ladder,
3131c M - parton type at current end of the ladder (1 - g, 2 - q)
3132c L - parton type at opposite end of the ladder (1 - g, 2 - q)
3133C-----------------------------------------------------------------------
3134 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3135 INTEGER DEBUG
3136 DIMENSION WI(3),WJ(3),WK(3)
3137 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
3138 COMMON /AREA29/ CSJ(17,17,68)
3139 COMMON /AREA43/ MONIOU
3140 COMMON /DEBUG/ DEBUG
3141 SAVE
3142
3143 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,Q1,Q2,M,L
3144201 FORMAT(2X,'PSJINT - UNORDERED LADDER CROSS SECTION INTERPOL.:'/
3145 * 4X,'S=',E10.3,2X,'Q1=',E10.3,2X,'Q2=',E10.3,2X,
3146 * 2X,'M=',I1,2X,'L=',I1)
3147 PSJINT=0.D0
3148 QQ=MAX(Q1,Q2)
3149 IF(S.LE.MAX(4.D0*QT0,QQ))THEN
3150 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSJINT
3151202 FORMAT(2X,'PSJINT=',E10.3)
3152 RETURN
3153 ENDIF
3154
3155 ML=17*(M-1)+34*(L-1)
3156 QLI=DLOG(Q1/QT0)/1.38629D0
3157 QLJ=DLOG(Q2/QT0)/1.38629D0
3158 SL=DLOG(S/QT0)/1.38629D0
3159 SQL=SL-MAX(QLI,QLJ)
3160 I=INT(QLI)
3161 J=INT(QLJ)
3162 K=INT(SL)
3163 IF(I.GT.13)I=13
3164 IF(J.GT.13)J=13
3165
3166 IF(SQL.GT.10.D0)THEN
3167 IF(K.GT.14)K=14
3168 IF(I.GT.K-3)I=K-3
3169 IF(J.GT.K-3)J=K-3
3170 WI(2)=QLI-I
3171 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
3172 WI(1)=1.D0-WI(2)+WI(3)
3173 WI(2)=WI(2)-2.D0*WI(3)
3174 WJ(2)=QLJ-J
3175 WJ(3)=WJ(2)*(WJ(2)-1.D0)*.5D0
3176 WJ(1)=1.D0-WJ(2)+WJ(3)
3177 WJ(2)=WJ(2)-2.D0*WJ(3)
3178 WK(2)=SL-K
3179 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
3180 WK(1)=1.D0-WK(2)+WK(3)
3181 WK(2)=WK(2)-2.D0*WK(3)
3182
3183 DO 1 I1=1,3
3184 DO 1 J1=1,3
3185 DO 1 K1=1,3
31861 PSJINT=PSJINT+CSJ(I+I1,J+J1,K+K1+ML)*WI(I1)*WJ(J1)*WK(K1)
3187 PSJINT=EXP(PSJINT)
3188 ELSEIF(SQL.LT.1.D0.AND.I+J.NE.0)THEN
3189 SQ=(S/MAX(Q1,Q2)-1.D0)/3.D0
3190 WI(2)=QLI-I
3191 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
3192 WI(1)=1.D0-WI(2)+WI(3)
3193 WI(2)=WI(2)-2.D0*WI(3)
3194 WJ(2)=QLJ-J
3195 WJ(3)=WJ(2)*(WJ(2)-1.D0)*.5D0
3196 WJ(1)=1.D0-WJ(2)+WJ(3)
3197 WJ(2)=WJ(2)-2.D0*WJ(3)
3198
3199 DO 2 I1=1,3
3200 I2=I+I1
3201 DO 2 J1=1,3
3202 J2=J+J1
3203 K2=MAX(I2,J2)+1+ML
32042 PSJINT=PSJINT+CSJ(I2,J2,K2)*WI(I1)*WJ(J1)
3205 PSJINT=EXP(PSJINT)*SQ
3206 ELSEIF(K.EQ.1)THEN
3207 SQ=(S/QT0/4.D0-1.D0)/3.D0
3208 WI(2)=QLI
3209 WI(1)=1.D0-QLI
3210 WJ(2)=QLJ
3211 WJ(1)=1.D0-QLJ
3212
3213 DO 3 I1=1,2
3214 DO 3 J1=1,2
32153 PSJINT=PSJINT+CSJ(I1,J1,3+ML)*WI(I1)*WJ(J1)
3216 PSJINT=EXP(PSJINT)*SQ
3217 ELSEIF(K.LT.15)THEN
3218 KL=INT(SQL)
3219 IF(I+KL.GT.12)I=12-KL
3220 IF(J+KL.GT.12)J=12-KL
3221 IF(I+J+KL.EQ.1)KL=2
3222 WI(2)=QLI-I
3223 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
3224 WI(1)=1.D0-WI(2)+WI(3)
3225 WI(2)=WI(2)-2.D0*WI(3)
3226 WJ(2)=QLJ-J
3227 WJ(3)=WJ(2)*(WJ(2)-1.D0)*.5D0
3228 WJ(1)=1.D0-WJ(2)+WJ(3)
3229 WJ(2)=WJ(2)-2.D0*WJ(3)
3230 WK(2)=SQL-KL
3231 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
3232 WK(1)=1.D0-WK(2)+WK(3)
3233 WK(2)=WK(2)-2.D0*WK(3)
3234
3235 DO 4 I1=1,3
3236 I2=I+I1
3237 DO 4 J1=1,3
3238 J2=J+J1
3239 DO 4 K1=1,3
3240 K2=MAX(I2,J2)+KL+K1-1+ML
32414 PSJINT=PSJINT+CSJ(I2,J2,K2)*WI(I1)*WJ(J1)*WK(K1)
3242 PSJINT=EXP(PSJINT)
3243 ELSE
3244 K=15
3245 IF(I.GT.K-3)I=K-3
3246 IF(J.GT.K-3)J=K-3
3247 WI(2)=QLI-I
3248 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
3249 WI(1)=1.D0-WI(2)+WI(3)
3250 WI(2)=WI(2)-2.D0*WI(3)
3251 WJ(2)=QLJ-J
3252 WJ(3)=WJ(2)*(WJ(2)-1.D0)*.5D0
3253 WJ(1)=1.D0-WJ(2)+WJ(3)
3254 WJ(2)=WJ(2)-2.D0*WJ(3)
3255 WK(2)=SL-K
3256 WK(1)=1.D0-WK(2)
3257
3258 DO 5 I1=1,3
3259 DO 5 J1=1,3
3260 DO 5 K1=1,2
32615 PSJINT=PSJINT+CSJ(I+I1,J+J1,K+K1+ML)*WI(I1)*WJ(J1)*WK(K1)
3262 PSJINT=EXP(PSJINT)
3263 ENDIF
3264 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSJINT
3265 RETURN
3266 END
3267C=======================================================================
3268
3269 SUBROUTINE PSJINT0(S,SJ,SJB,M,L)
3270C PSJINT0 - inclusive hard cross-section interpolation - for minimal
3271c effective momentum cutoff in the ladder
3272c S - total c.m. energy squared for the ladder,
3273c SJ - inclusive jet cross-section,
3274c SJB - Born cross-section,
3275c M - parton type at current end of the ladder (0 - g, 1 - q)
3276c L - parton type at opposite end of the ladder (0 - g, 1 - q)
3277C-----------------------------------------------------------------------
3278 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3279 INTEGER DEBUG
3280 DIMENSION WK(3)
3281 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
3282 COMMON /AREA32/ CSJ(17,2,2),CSB(17,2,2)
3283 COMMON /AREA43/ MONIOU
3284 COMMON /DEBUG/ DEBUG
3285 SAVE
3286
3287 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,M,L
3288201 FORMAT(2X,'PSJINT0 - HARD CROSS SECTION INTERPOLATION:'/
3289 * 4X,'S=',E10.3,2X,'M=',I1,2X,'L=',I1)
3290 SJ=0.D0
3291 SJB=0.D0
3292 IF(S.LE.4.D0*QT0)THEN
3293 IF(DEBUG.GE.3)WRITE (MONIOU,202)SJ,SJB
3294202 FORMAT(2X,'PSJINT0: SJ=',E10.3,2X,'SJB=',E10.3)
3295 RETURN
3296 ENDIF
3297
3298 SL=DLOG(S/QT0)/1.38629d0
3299 K=INT(SL)
3300 IF(K.EQ.1)THEN
3301 SQ=(S/QT0/4.D0-1.D0)/3.D0
3302 SJB=EXP(CSB(3,M+1,L+1))*SQ
3303 SJ=EXP(CSJ(3,M+1,L+1))*SQ
3304 ELSE
3305 IF(K.GT.14)K=14
3306 WK(2)=SL-K
3307 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
3308 WK(1)=1.D0-WK(2)+WK(3)
3309 WK(2)=WK(2)-2.D0*WK(3)
3310
3311 DO 1 K1=1,3
3312 SJ=SJ+CSJ(K+K1,M+1,L+1)*WK(K1)
33131 SJB=SJB+CSB(K+K1,M+1,L+1)*WK(K1)
3314 SJB=EXP(SJB)
3315 SJ=EXP(SJ)
3316 ENDIF
3317 IF(DEBUG.GE.3)WRITE (MONIOU,202)SJ,SJB
3318 RETURN
3319 END
3320C=======================================================================
3321
3322 FUNCTION PSJINT1(Q1,Q2,S,M,L)
3323C PSJINT1 - inclusive hard cross-section interpolation - for strict ordering
3324c in the ladder
3325c Q1 - effective momentum cutoff for current end of the ladder,
3326c Q2 - effective momentum cutoff for opposide end of the ladder,
3327c S - total c.m. energy squared for the ladder,
3328c M - parton type at current end of the ladder (1 - g, 2 - q)
3329c L - parton type at opposite end of the ladder (1 - g, 2 - q)
3330C-----------------------------------------------------------------------
3331 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3332 INTEGER DEBUG
3333 DIMENSION WI(3),WJ(3),WK(3)
3334 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
3335 COMMON /AREA30/ CSJ(17,17,68)
3336 COMMON /AREA43/ MONIOU
3337 COMMON /DEBUG/ DEBUG
3338 SAVE
3339
3340 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,Q1,Q2,M,L
3341201 FORMAT(2X,'PSJINT1 - STRICTLY ORDERED LADDER CROSS SECTION',
3342 * ' INTERPOLATION:'/
3343 * 4X,'S=',E10.3,2X,'Q1=',E10.3,2X,'Q2=',E10.3,2X,
3344 * 4X,'M=',I1,2X,'L=',I1)
3345 PSJINT1=0.D0
3346 QQ=MAX(Q1,Q2)
3347 IF(S.LE.MAX(4.D0*QT0,QQ))THEN
3348 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSJINT1
3349202 FORMAT(2X,'PSJINT1=',E10.3)
3350 RETURN
3351 ENDIF
3352
3353 ML=17*(M-1)+34*(L-1)
3354 QLI=DLOG(Q1/QT0)/1.38629d0
3355 QLJ=DLOG(Q2/QT0)/1.38629d0
3356 SL=DLOG(S/QT0)/1.38629d0
3357 SQL=SL-MAX(QLI,QLJ)
3358 I=INT(QLI)
3359 J=INT(QLJ)
3360 K=INT(SL)
3361 IF(I.GT.13)I=13
3362 IF(J.GT.13)J=13
3363
3364 IF(SQL.GT.10.D0)THEN
3365 IF(K.GT.14)K=14
3366 IF(I.GT.K-3)I=K-3
3367 IF(J.GT.K-3)J=K-3
3368 WI(2)=QLI-I
3369 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
3370 WI(1)=1.D0-WI(2)+WI(3)
3371 WI(2)=WI(2)-2.D0*WI(3)
3372 WJ(2)=QLJ-J
3373 WJ(3)=WJ(2)*(WJ(2)-1.D0)*.5D0
3374 WJ(1)=1.D0-WJ(2)+WJ(3)
3375 WJ(2)=WJ(2)-2.D0*WJ(3)
3376 WK(2)=SL-K
3377 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
3378 WK(1)=1.D0-WK(2)+WK(3)
3379 WK(2)=WK(2)-2.D0*WK(3)
3380
3381 DO 1 I1=1,3
3382 DO 1 J1=1,3
3383 DO 1 K1=1,3
33841 PSJINT1=PSJINT1+CSJ(I+I1,J+J1,K+K1+ML)*WI(I1)*WJ(J1)*WK(K1)
3385 PSJINT1=EXP(PSJINT1)
3386 ELSEIF(SQL.LT.1.D0.AND.I+J.NE.0)THEN
3387 SQ=(S/MAX(Q1,Q2)-1.D0)/3.D0
3388 WI(2)=QLI-I
3389 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
3390 WI(1)=1.D0-WI(2)+WI(3)
3391 WI(2)=WI(2)-2.D0*WI(3)
3392 WJ(2)=QLJ-J
3393 WJ(3)=WJ(2)*(WJ(2)-1.D0)*.5D0
3394 WJ(1)=1.D0-WJ(2)+WJ(3)
3395 WJ(2)=WJ(2)-2.D0*WJ(3)
3396
3397 DO 2 I1=1,3
3398 I2=I+I1
3399 DO 2 J1=1,3
3400 J2=J+J1
3401 K2=MAX(I2,J2)+1+ML
34022 PSJINT1=PSJINT1+CSJ(I2,J2,K2)*WI(I1)*WJ(J1)
3403 PSJINT1=EXP(PSJINT1)*SQ
3404 ELSEIF(K.EQ.1)THEN
3405 SQ=(S/QT0/4.D0-1.D0)/3.D0
3406 WI(2)=QLI
3407 WI(1)=1.D0-QLI
3408 WJ(2)=QLJ
3409 WJ(1)=1.D0-QLJ
3410
3411 DO 3 I1=1,2
3412 DO 3 J1=1,2
34133 PSJINT1=PSJINT1+CSJ(I1,J1,3+ML)*WI(I1)*WJ(J1)
3414 PSJINT1=EXP(PSJINT1)*SQ
3415 ELSEIF(K.LT.15)THEN
3416 KL=INT(SQL)
3417 IF(I+KL.GT.12)I=12-KL
3418 IF(J+KL.GT.12)J=12-KL
3419 IF(I+J+KL.EQ.1)KL=2
3420
3421 WI(2)=QLI-I
3422 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
3423 WI(1)=1.D0-WI(2)+WI(3)
3424 WI(2)=WI(2)-2.D0*WI(3)
3425 WJ(2)=QLJ-J
3426 WJ(3)=WJ(2)*(WJ(2)-1.D0)*.5D0
3427 WJ(1)=1.D0-WJ(2)+WJ(3)
3428 WJ(2)=WJ(2)-2.D0*WJ(3)
3429 WK(2)=SQL-KL
3430 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
3431 WK(1)=1.D0-WK(2)+WK(3)
3432 WK(2)=WK(2)-2.D0*WK(3)
3433
3434 DO 4 I1=1,3
3435 I2=I+I1
3436 DO 4 J1=1,3
3437 J2=J+J1
3438 DO 4 K1=1,3
3439 K2=MAX(I2,J2)+KL+K1-1+ML
34404 PSJINT1=PSJINT1+CSJ(I2,J2,K2)*WI(I1)*WJ(J1)*WK(K1)
3441 PSJINT1=EXP(PSJINT1)
3442 ELSE
3443 K=15
3444 IF(I.GT.K-3)I=K-3
3445 IF(J.GT.K-3)J=K-3
3446 WI(2)=QLI-I
3447 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
3448 WI(1)=1.D0-WI(2)+WI(3)
3449 WI(2)=WI(2)-2.D0*WI(3)
3450 WJ(2)=QLJ-J
3451 WJ(3)=WJ(2)*(WJ(2)-1.D0)*.5D0
3452 WJ(1)=1.D0-WJ(2)+WJ(3)
3453 WJ(2)=WJ(2)-2.D0*WJ(3)
3454 WK(2)=SL-K
3455 WK(1)=1.D0-WK(2)
3456
3457 DO 5 I1=1,3
3458 DO 5 J1=1,3
3459 DO 5 K1=1,2
34605 PSJINT1=PSJINT1+CSJ(I+I1,J+J1,K+K1+ML)*WI(I1)*WJ(J1)*WK(K1)
3461 PSJINT1=EXP(PSJINT1)
3462 ENDIF
3463 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSJINT1
3464 RETURN
3465 END
3466C=======================================================================
3467
3468 FUNCTION PSLAM(S,A,B)
3469c Kinematical function for two particle decay - maximal Pt-value
3470c A - first particle mass squared,
3471C B - second particle mass squared,
3472C S - two particle invariant mass
3473c-----------------------------------------------------------------------
3474 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3475 INTEGER DEBUG
3476 COMMON /AREA43/ MONIOU
3477 COMMON /DEBUG/ DEBUG
3478 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,A,B
3479201 FORMAT(2X,'PSLAM - KINEMATICAL FUNCTION S=',E10.3,2X,'A=',
3480 * E10.3,2X,'B=',E10.3)
3481 PSLAM=.25D0/S*(S+A-B)**2-A
3482 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSLAM
3483202 FORMAT(2X,'PSLAM=',E10.3)
3484 RETURN
3485 END
3486C=======================================================================
3487
3488 FUNCTION PSNORM(EP)
3489c 4-vector squared calculation
3490c-----------------------------------------------------------------------
3491 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3492 INTEGER DEBUG
3493 DIMENSION EP(4)
3494 COMMON /AREA43/ MONIOU
3495 COMMON /DEBUG/ DEBUG
3496 IF(DEBUG.GE.2)WRITE (MONIOU,201)EP
3497201 FORMAT(2X,'PSNORM - 4-VECTOR SQUARED FOR ',
3498 * 'EP=',4(E10.3,1X))
3499 PSNORM=EP(1)**2
3500 DO 1 I=1,3
35011 PSNORM=PSNORM-EP(I+1)**2
3502 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSNORM
3503202 FORMAT(2X,'PSNORM=',E10.3)
3504 RETURN
3505 END
3506C=======================================================================
3507
3508 SUBROUTINE PSREC(EP,QV,ZV,QM,IQV,LDAU,LPAR,IQJ,EQJ,JFL,JQ)
3509c Jet reconstructuring procedure - 4-momenta for all final jets are determined
3510c EP(i) - jet 4-momentum
3511C-----------------------------------------------------------------------
3512c QV(i,j) - effective momentum for the branching of the parton in i-th row
3513c on j-th level (0 - in case of no branching)
3514c ZV(i,j) - Z-value for the branching of the parton in i-th row
3515c on j-th level
3516c QM(i,j) - mass squared for the parton in i-th row
3517c on j-th level
3518c IQV(i,j) - flavours for the parton in i-th row on j-th level
3519c LDAU(i,j) - first daughter row for the branching of the parton in i-th row
3520c on j-th level
3521c LPAR(i,j) - the parent row for the parton in i-th row on j-th level
3522C-----------------------------------------------------------------------
3523 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3524 INTEGER DEBUG
3525 DIMENSION EP(4),EP3(4),EPV(4,30,50),
3526 * QV(30,50),ZV(30,50),QM(30,50),IQV(30,50),
3527 * LDAU(30,49),LPAR(30,50),
3528 * IQJ(2),EQJ(4,2),IPQ(2,30,50),EPQ(8,30,50),
3529 * EPJ(4),EPJ1(4)
3530 COMMON /AREA43/ MONIOU
3531 COMMON /DEBUG/ DEBUG
3532
3533 IF(DEBUG.GE.2)WRITE (MONIOU,201)JQ,EP,IQJ
3534201 FORMAT(2X,'PSREC - JET RECONSTRUCTURING: JQ=',I1/
3535 * 4X,'JET 4-MOMENTUM EP=',4(E10.3,1X)/4X,'IQJ=',2I2)
3536 JFL = 1
3537 DO 1 I=1,4
3538 EPV(I,1,1)=EP(I)
35391 EPQ(I,1,1)=EQJ(I,1)
3540 IPQ(1,1,1)=IQJ(1)
3541
3542 IF(IQV(1,1).EQ.0)THEN
3543 DO 2 I=1,4
35442 EPQ(I+4,1,1)=EQJ(I,2)
3545 IPQ(2,1,1)=IQJ(2)
3546 ENDIF
3547
3548 NLEV=1
3549 NROW=1
3550
35513 CONTINUE
3552
3553 IF(QV(NROW,NLEV).EQ.0.D0)THEN
3554 IPJ=IQV(NROW,NLEV)
3555 IF(IPJ.NE.0)THEN
3556 IF(EPQ(1,NROW,NLEV).NE.0.D0)THEN
3557 IF(IABS(IPJ).EQ.3)IPJ=IPJ*4/3
3558 DO 4 I=1,4
3559 EPJ(I)=EPV(I,NROW,NLEV)
35604 EPJ1(I)=EPQ(I,NROW,NLEV)
3561 IPJ1=IPQ(1,NROW,NLEV)
3562 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
3563 CALL PSJDEF(IPJ,IPJ1,EPJ,EPJ1,JFL)
3564 IF(DEBUG.GE.3)WRITE (MONIOU,211)IPJ,IPJ1,JFL
3565211 FORMAT(2X,'PSREC - NEW STRING FLAVOURS: ',2I3,' JFL=',I1)
3566 IF(JFL.EQ.0)RETURN
3567 ELSE
3568 IPQ(1,NROW,NLEV)=IPJ
3569 DO 5 I=1,4
35705 EPQ(I,NROW,NLEV)=EPV(I,NROW,NLEV)
3571 IF(DEBUG.GE.3)WRITE (MONIOU,212)IPJ,
3572 * (EPV(I,NROW,NLEV),I=1,4),JFL
3573212 FORMAT(2X,'PSREC: NEW FINAL JET FLAVOR: ',I3,2X,
3574 * 'JET 4-MOMENTUM:', 4(E10.3,1X),' JFL=',I1)
3575 ENDIF
3576
3577 ELSE
3578 IPJ=INT(2.D0*PSRAN(B10)+1.D0)*(3-2*JQ)
3579 DO 6 I=1,4
35806 EPJ(I)=.5D0*EPV(I,NROW,NLEV)
3581
3582 DO 9 M=1,2
3583 IF(EPQ(1+4*(M-1),NROW,NLEV).NE.0.D0)THEN
3584 DO 7 I=1,4
35857 EPJ1(I)=EPQ(4*(M-1)+I,NROW,NLEV)
3586 IPJ1=IPQ(M,NROW,NLEV)
3587 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
3588 CALL PSJDEF(IPJ,IPJ1,EPJ,EPJ1,JFL)
3589 IF(JFL.EQ.0)RETURN
3590 ELSE
3591 IPQ(M,NROW,NLEV)=IPJ
3592 DO 8 I=1,4
35938 EPQ(4*(M-1)+I,NROW,NLEV)=EPJ(I)
3594 ENDIF
35959 IPJ=-IPJ
3596 ENDIF
3597
3598 IF(DEBUG.GE.3)WRITE (MONIOU,204)NLEV,NROW,IQV(NROW,NLEV),
3599 * (EPV(I,NROW,NLEV),I=1,4)
3600204 FORMAT(2X,'PSREC: FINAL JET AT LEVEL NLEV=',I2,
3601 * ' NROW=',I2/4X,'JET FLAVOR: ',I3,2X,'JET 4-MOMENTUM:',
3602 * 4(E10.3,1X))
3603 ELSE
3604
3605 DO 10 I=1,4
360610 EP3(I)=EPV(I,NROW,NLEV)
3607 CALL PSDEFROT(EP3,S0X,C0X,S0,C0)
3608 Z=ZV(NROW,NLEV)
3609 QT2=(Z*(1.D0-Z))**2*QV(NROW,NLEV)
3610 LDROW=LDAU(NROW,NLEV)
3611
3612 WP0=EP3(1)+EP3(2)
3613 WPI=Z*WP0
3614 WMI=(QT2+QM(LDROW,NLEV+1))/WPI
3615 EP3(1)=.5D0*(WPI+WMI)
3616 EP3(2)=.5D0*(WPI-WMI)
3617 QT=DSQRT(QT2)
3618 CALL PSCS(C,S)
3619 EP3(3)=QT*C
3620 EP3(4)=QT*S
3621 CALL PSROTAT(EP3,S0X,C0X,S0,C0)
3622
3623 DO 11 I=1,4
362411 EPV(I,LDROW,NLEV+1)=EP3(I)
3625 IF(DEBUG.GE.3)WRITE (MONIOU,206)NLEV+1,LDROW,EP3
3626206 FORMAT(2X,'PSREC: JET AT LEVEL NLEV=',I2,
3627 * ' NROW=',I2/4X,'JET 4-MOMENTUM:',4(E10.3,1X))
3628
3629 WPI=(1.D0-Z)*WP0
3630 WMI=(QT2+QM(LDROW+1,NLEV+1))/WPI
3631 EP3(1)=.5D0*(WPI+WMI)
3632 EP3(2)=.5D0*(WPI-WMI)
3633 EP3(3)=-QT*C
3634 EP3(4)=-QT*S
3635 CALL PSROTAT(EP3,S0X,C0X,S0,C0)
3636 IF(DEBUG.GE.3)WRITE (MONIOU,206)NLEV+1,LDROW+1,EP3
3637
3638 DO 12 I=1,4
363912 EPV(I,LDROW+1,NLEV+1)=EP3(I)
3640
3641 IF(IQV(NROW,NLEV).EQ.0)THEN
3642 IF(IQV(LDROW,NLEV+1).NE.0)THEN
3643 IPQ(1,LDROW,NLEV+1)=IPQ(1,NROW,NLEV)
3644 IPQ(1,LDROW+1,NLEV+1)=IPQ(2,NROW,NLEV)
3645 DO 13 I=1,4
3646 EPQ(I,LDROW,NLEV+1)=EPQ(I,NROW,NLEV)
364713 EPQ(I,LDROW+1,NLEV+1)=EPQ(I+4,NROW,NLEV)
3648 ELSE
3649 IPQ(1,LDROW,NLEV+1)=IPQ(1,NROW,NLEV)
3650 IPQ(2,LDROW,NLEV+1)=0
3651 IPQ(1,LDROW+1,NLEV+1)=0
3652 IPQ(2,LDROW+1,NLEV+1)=IPQ(2,NROW,NLEV)
3653 DO 14 I=1,4
3654 EPQ(I,LDROW,NLEV+1)=EPQ(I,NROW,NLEV)
3655 EPQ(I+4,LDROW,NLEV+1)=0.D0
3656 EPQ(I,LDROW+1,NLEV+1)=0.D0
365714 EPQ(I+4,LDROW+1,NLEV+1)=EPQ(I+4,NROW,NLEV)
3658 ENDIF
3659 ELSE
3660 IF(IQV(LDROW,NLEV+1).EQ.0)THEN
3661 IPQ(1,LDROW,NLEV+1)=IPQ(1,NROW,NLEV)
3662 IPQ(2,LDROW,NLEV+1)=0
3663 IPQ(1,LDROW+1,NLEV+1)=0
3664 DO 15 I=1,4
3665 EPQ(I,LDROW,NLEV+1)=EPQ(I,NROW,NLEV)
3666 EPQ(I+4,LDROW,NLEV+1)=0.D0
366715 EPQ(I,LDROW+1,NLEV+1)=0.D0
3668 ELSE
3669 IPQ(1,LDROW,NLEV+1)=0
3670 IPQ(1,LDROW+1,NLEV+1)=0
3671 IPQ(2,LDROW+1,NLEV+1)=IPQ(1,NROW,NLEV)
3672 DO 16 I=1,4
3673 EPQ(I,LDROW,NLEV+1)=0.D0
3674 EPQ(I,LDROW+1,NLEV+1)=0.D0
367516 EPQ(I+4,LDROW+1,NLEV+1)=EPQ(I,NROW,NLEV)
3676 ENDIF
3677 ENDIF
3678
3679 NROW=LDROW
3680 NLEV=NLEV+1
3681 GOTO 3
3682 ENDIF
3683
368417 CONTINUE
3685 IF(NLEV.EQ.1)THEN
3686 IQJ(1)=IPQ(1,1,1)
3687 DO 18 I=1,4
368818 EQJ(I,1)=EPQ(I,1,1)
3689 IF(IQV(1,1).EQ.0)THEN
3690 IQJ(2)=IPQ(2,1,1)
3691 DO 19 I=1,4
369219 EQJ(I,2)=EPQ(I+4,1,1)
3693 ENDIF
3694 IF(DEBUG.GE.3)WRITE (MONIOU,202)iqj
3695202 FORMAT(2X,'PSREC - END',2x,'iqj=',2i2)
3696 RETURN
3697 ENDIF
3698
3699 LPROW=LPAR(NROW,NLEV)
3700
3701 IF(LDAU(LPROW,NLEV-1).EQ.NROW)THEN
3702 IF(IQV(NROW,NLEV).EQ.0)THEN
3703 IF(EPQ(1,LPROW,NLEV-1).EQ.0.D0)THEN
3704 IPQ(1,LPROW,NLEV-1)=IPQ(1,NROW,NLEV)
3705 DO 20 I=1,4
370620 EPQ(I,LPROW,NLEV-1)=EPQ(I,NROW,NLEV)
3707 ENDIF
3708 IPQ(1,NROW+1,NLEV)=IPQ(2,NROW,NLEV)
3709 DO 21 I=1,4
371021 EPQ(I,NROW+1,NLEV)=EPQ(I+4,NROW,NLEV)
3711 ELSE
3712 IF(IQV(LPROW,NLEV-1).EQ.0)THEN
3713 IF(EPQ(1,LPROW,NLEV-1).EQ.0.D0)THEN
3714 IPQ(1,LPROW,NLEV-1)=IPQ(1,NROW,NLEV)
3715 DO 22 I=1,4
371622 EPQ(I,LPROW,NLEV-1)=EPQ(I,NROW,NLEV)
3717 ENDIF
3718 ELSE
3719 IPQ(1,NROW+1,NLEV)=IPQ(1,NROW,NLEV)
3720 DO 23 I=1,4
372123 EPQ(I,NROW+1,NLEV)=EPQ(I,NROW,NLEV)
3722 ENDIF
3723 ENDIF
3724 NROW=NROW+1
3725 GOTO 3
3726
3727 ELSE
3728 IF(IQV(NROW,NLEV).EQ.0)THEN
3729 IF(IQV(LPROW,NLEV-1).EQ.0)THEN
3730 IF(EPQ(5,LPROW,NLEV-1).EQ.0.D0)THEN
3731 IPQ(2,LPROW,NLEV-1)=IPQ(2,NROW,NLEV)
3732 DO 24 I=1,4
373324 EPQ(I+4,LPROW,NLEV-1)=EPQ(I+4,NROW,NLEV)
3734 ENDIF
3735 ELSE
3736 IF(EPQ(1,LPROW,NLEV-1).EQ.0.D0)THEN
3737 IPQ(1,LPROW,NLEV-1)=IPQ(2,NROW,NLEV)
3738 DO 25 I=1,4
373925 EPQ(I,LPROW,NLEV-1)=EPQ(I+4,NROW,NLEV)
3740 ENDIF
3741 ENDIF
3742 ELSE
3743 IF(IQV(LPROW,NLEV-1).EQ.0.AND.
3744 * EPQ(5,LPROW,NLEV-1).EQ.0.D0)THEN
3745 IPQ(2,LPROW,NLEV-1)=IPQ(1,NROW,NLEV)
3746 DO 26 I=1,4
374726 EPQ(I+4,LPROW,NLEV-1)=EPQ(I,NROW,NLEV)
3748 ENDIF
3749 ENDIF
3750
3751 NROW=LPROW
3752 NLEV=NLEV-1
3753 GOTO 17
3754 ENDIF
3755 END
3756C=======================================================================
3757
3758 FUNCTION PSREJS(S,Z,IQQ)
3759c PSREJS - rejection function for the energy sharing for semihard
3760c interaction (Hi_semihard(S)/S**delh)
3761c S - energy squared for the semihard interaction,
3762c Z - impact parameter factor, Z=exp(-b**2/Rp),
3763c IQQ - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
3764c-----------------------------------------------------------------------
3765 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3766 INTEGER DEBUG
3767 COMMON /AREA17/ DEL,RS,RS0,FS,ALF,RR,SH,DELH
3768 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
3769 COMMON /AR3/ X1(7),A1(7)
3770 COMMON /AREA43/ MONIOU
3771 COMMON /DEBUG/ DEBUG
3772 SAVE
3773
3774 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,Z,IQQ
3775201 FORMAT(2X,'PSREJS - REJECTION FUNCTION TABULATION: '/
3776 * 4X,'S=',E10.3,2X,'Z=',E10.3,2X,'IQQ=',I1)
3777 XMIN=4.D0*(QT0+AMJ0)/S
3778 XMIN=XMIN**(DELH-DEL)
3779 PSREJS=0.D0
3780
3781c Numerical integration over Z1
3782 DO 2 I=1,7
3783 DO 2 M=1,2
3784 Z1=(.5D0*(1.D0+XMIN-(2*M-3)*X1(I)*(1.D0-XMIN)))**(1.D0/
3785 *(DELH-DEL))
3786
3787c SJ is the inclusive hard partonic interaction
3788c cross-section (inclusive cut ladder cross section) for minimal
3789c 4-momentum transfer squre QT0 and c.m. energy square s_hard = exp YJ;
3790c SJB - Born cross-section
3791 YJ=DLOG(Z1*S)
3792 CALL PSJINT0(Z1*S,SJ,SJB,IQQ,0)
3793c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic
3794c interaction cross-section for minimal 4-momentum transfer square QT0 and
3795c c.m. energy square s_hard = exp YJ; SH=pi*R_hard**2 (R_hard**2=4/QT0)
3796 GY=2.D0*SH*PSGINT((SJ-SJB)/SH*.5D0)+SJB
3797 RH=RS0-ALF*DLOG(Z1)
3798
3799 IF(IQQ.NE.0)THEN
3800 PSREJS=PSREJS+A1(I)*GY/(Z1*S)**DELH*Z**(RS0/RH)/RH*
3801 * (1.D0-Z1)*BET
3802 ELSE
3803 ST2=0.D0
3804 DO 1 J=1,7
38051 ST2=ST2+A1(J)*((1.D0-Z1**(.5D0*(1.D0+X1(J))))*
3806 * (1.D0-Z1**(.5D0*(1.D0-X1(J)))))**BET
3807
3808 PSREJS=PSREJS-A1(I)*DLOG(Z1)*GY/(Z1*S)**DELH*Z**(RS0/RH)/RH*ST2
3809 ENDIF
38102 CONTINUE
3811 PSREJS=DLOG(PSREJS*(1.D0-XMIN)/Z)
3812 IF(DEBUG.GE.2)WRITE (MONIOU,202)PSREJS
3813202 FORMAT(2X,'PSREJS=',E10.3)
3814 RETURN
3815 END
3816C=======================================================================
3817
3818 FUNCTION PSREJV(S)
3819c PSREJV - rejection function for the energy sharing for quark-quark hard
3820c interaction (sigma_hard(S)/S**delh)
3821c S - energy squared for the hard interaction
3822c-----------------------------------------------------------------------
3823 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3824 INTEGER DEBUG
3825 COMMON /AREA17/ DEL,RS,RS0,FS,ALF,RR,SH,DELH
3826 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
3827 COMMON /AREA43/ MONIOU
3828 COMMON /DEBUG/ DEBUG
3829 SAVE
3830
3831 IF(DEBUG.GE.2)WRITE (MONIOU,201)S
3832201 FORMAT(2X,'PSREJV - REJECTION FUNCTION TABULATION: ',
3833 * 'S=',E10.3)
3834c SJ is the inclusive hard QUARK-QUARK interaction
3835c cross-section (inclusive cut ladder cross section) for minimal
3836c 4-momentum transfer squre QT0 and c.m. energy square s;
3837c SJB - Born cross-section
3838 CALL PSJINT0(S,SJ,SJB,1,1)
3839
3840c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic (quark-quark)
3841c interaction cross-section for minimal 4-momentum transfer square QT0 and
3842c c.m. energy square s; SH=pi*R_hard**2 (R_hard**2=4/QT0)
3843 GY=2.D0*SH*PSGINT((SJ-SJB)/SH*.5D0)+SJB
3844 PSREJV=DLOG(GY/S**DELH)
3845 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSREJV
3846202 FORMAT(2X,'PSREJV=',E10.3)
3847 RETURN
3848 END
3849C=======================================================================
3850
3851 FUNCTION PSRJINT(YJ,Z0,IQQ)
3852c PSRJINT - Rejection function for the energy sharing (Hi_semih(S)/S**delh)
3853c YJ=ln S,
3854c Z0 - impact parameter factor, Z0=exp(-b**2/Rp),
3855c IQQ - type of hard interaction (0 - gg; 1 - qg, 2 - gq; 3 - qq)
3856c-----------------------------------------------------------------------
3857 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3858 INTEGER DEBUG
3859 DIMENSION A(3)
3860 COMMON /AREA1/ IA(2),ICZ,ICP
3861 COMMON /AREA17/ DEL,RS,RS0,FS,ALF,RR,SH,DELH
3862 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
3863 COMMON /AREA23/ RJV(50)
3864 COMMON /AREA24/ RJS(50,5,10)
3865 COMMON /AREA43/ MONIOU
3866 COMMON /DEBUG/ DEBUG
3867
3868 IF(DEBUG.GE.2)WRITE (MONIOU,201)YJ,Z0,IQQ
3869201 FORMAT(2X,'PSRJINT - REJECTION FUNCTION INTERPOLATION:'/
3870 * 4X,'YJ=',E10.3,2X,'Z0=',E10.3,2X,'IQQ=',I1)
3871 YY=(YJ-AQT0)*2.D0
3872 JY=INT(YY)
3873
3874 IF(IQQ.EQ.3)THEN
3875 IF(JY.EQ.0)THEN
3876 PSRJINT=EXP(RJV(1))*YY+(EXP(RJV(2))-2.D0*
3877 * EXP(RJV(1)))*YY*(YY-1.D0)*.5D0
3878 ELSE
3879 PSRJINT=EXP(RJV(JY)+(RJV(JY+1)-RJV(JY))*(YY-JY)
3880 * +(RJV(JY+2)+RJV(JY)-2.D0*RJV(JY+1))*(YY-JY)*
3881 * (YY-JY-1.D0)*.5D0)
3882 ENDIF
3883 ELSE
3884 Z=Z0**(RS/RS0)
3885 IQ=(IQQ+1)/2+1+2*(ICZ-1)
3886 JZ=INT(5.D0*Z)
3887 IF(JZ.GT.3)JZ=3
3888 WZ=5.D0*Z-JZ
3889
3890 IF(JZ.EQ.0)THEN
3891 I1=2
3892 ELSE
3893 I1=1
3894 ENDIF
3895
3896 DO 1 I=I1,3
3897 J1=JZ+I-1
3898 IF(JY.EQ.0)THEN
3899 A(I)=EXP(RJS(1,J1,IQ))*YY+(EXP(RJS(2,J1,IQ))-2.D0*
3900 * EXP(RJS(1,J1,IQ)))*YY*(YY-1.D0)*.5D0
3901 IF(A(I).GT.0.D0)THEN
3902 A(I)=DLOG(A(I))
3903 ELSE
3904 A(I)=-80.D0
3905 ENDIF
3906 ELSE
3907 A(I)=RJS(JY,J1,IQ)+(RJS(JY+1,J1,IQ)-
3908 * RJS(JY,J1,IQ))*(YY-JY)
3909 * +(RJS(JY+2,J1,IQ)+RJS(JY,J1,IQ)-2.D0*
3910 * RJS(JY+1,J1,IQ))*(YY-JY)*(YY-JY-1.D0)*.5D0
3911 ENDIF
39121 CONTINUE
3913
3914 IF(JZ.NE.0)THEN
3915 PSRJINT=EXP(A(1)+(A(2)-A(1))*WZ+(A(3)+A(1)-2.D0*A(2))*WZ*
3916 * (WZ-1.D0)*.5D0)*Z
3917 ELSE
3918 PSRJINT=(EXP(A(2))*WZ+(EXP(A(3))-2.D0*EXP(A(2)))*WZ*
3919 * (WZ-1.D0)*.5D0)*Z
3920 IF(PSRJINT.LE.0.D0)PSRJINT=1.D-10
3921 ENDIF
3922 ENDIF
3923 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSRJINT
3924202 FORMAT(2X,'PSRJINT=',E10.3)
3925 RETURN
3926 END
3927C=======================================================================
3928
3929 FUNCTION PSROOT(QLMAX,G,J)
3930c PSROOT - effective momentum tabulation for given set of random number
3931c values and maximal effective momentum QMAX values - according to the
3932c probability of branching: (1 - timelike Sudakov formfactor)
3933c QLMAX - ln QMAX/16/QTF,
3934c G - dzeta number (some function of ksi)
3935c J - type of the parton (1-g,2-q)
3936c-----------------------------------------------------------------------
3937 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3938 INTEGER DEBUG
3939 COMMON /AREA43/ MONIOU
3940 COMMON /DEBUG/ DEBUG
3941 SAVE
3942
3943 IF(DEBUG.GE.2)WRITE (MONIOU,201)QLMAX,G,J
3944201 FORMAT(2X,'PSQINT - BRANCHING MOMENTUM TABULATION:'/
3945 * 4X,'QLMAX=',E10.3,2X,'G=',E10.3,2X,'J=',I1)
3946 QL0=0.D0
3947 QL1=QLMAX
3948 F0=-G
3949 F1=1.D0-G
3950 SUD0=-DLOG(PSUDINT(QLMAX,J))
3951
39521 QL2=QL1-(QL1-QL0)*F1/(F1-F0)
3953 IF(QL2.LT.0.D0)THEN
3954 QL2=0.D0
3955 F2=-G
3956 ELSEIF(QL2.GT.QLMAX)THEN
3957 QL2=QLMAX
3958 F2=1.D0-G
3959 ELSE
3960 F2=-DLOG(PSUDINT(QL2,J))/SUD0-G
3961 ENDIF
3962
3963 IF(ABS(F2).GT.1.D-3)THEN
3964 QL0=QL1
3965 QL1=QL2
3966 F0=F1
3967 F1=F2
3968 GOTO 1
3969 ELSE
3970 PSROOT=QL2
3971 ENDIF
3972 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSROOT
3973202 FORMAT(2X,'PSROOT=',E10.3)
3974 RETURN
3975 END
3976C=======================================================================
3977
3978 SUBROUTINE PSROTAT(EP,S0X,C0X,S0,C0)
3979c Spacial rotation to the lab. system for 4-vector EP
3980c-----------------------------------------------------------------------
3981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3982 INTEGER DEBUG
3983 DIMENSION EP(4),EP1(3)
3984 COMMON /AREA43/ MONIOU
3985 COMMON /DEBUG/ DEBUG
3986 IF(DEBUG.GE.2)WRITE (MONIOU,201)EP,S0X,C0X,S0,C0
3987201 FORMAT(2X,'PSROTAT - SPACIAL ROTATION:'/4X,
3988 * '4-VECTOR EP=',4(E10.3,1X)/4X,'S0X=',E10.3,'C0X=',E10.3,
3989 * 2X,'S0=',E10.3,'C0=',E10.3)
3990 EP1(3)=EP(4)
3991 EP1(2)=EP(2)*S0+EP(3)*C0
3992 EP1(1)=EP(2)*C0-EP(3)*S0
3993
3994 EP(2)=EP1(1)
3995 EP(4)=EP1(2)*S0X+EP1(3)*C0X
3996 EP(3)=EP1(2)*C0X-EP1(3)*S0X
3997 IF(DEBUG.GE.3)WRITE (MONIOU,202)EP
3998202 FORMAT(2X,'PSROTAT: ROTATED 4-VECTOR EP=',
3999 * 2X,4E10.3)
4000 RETURN
4001 END
4002C=======================================================================
4003
4004 FUNCTION PSQINT(QLMAX,G,J)
4005c PSQINT - effective momentum interpolation for given random number G
4006c and maximal effective momentum QMAX
4007c QLMAX - ln QMAX/16/QTF,
4008c G - random number (0<G<1)
4009c J - type of the parton (1-g,2-q)
4010c-----------------------------------------------------------------------
4011 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4012 INTEGER DEBUG
4013 DIMENSION WI(3),WK(3)
4014 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
4015 COMMON /AREA34/ QRT(10,101,2)
4016 COMMON /AREA43/ MONIOU
4017 COMMON /DEBUG/ DEBUG
4018 SAVE
4019
4020 IF(DEBUG.GE.2)WRITE (MONIOU,201)QLMAX,G,J
4021201 FORMAT(2X,'PSQINT - BRANCHING MOMENTUM INTERPOLATION:'/
4022 * 4X,'QLMAX=',E10.3,2X,'G=',E10.3,2X,'J=',I1)
4023 QLI=QLMAX/1.38629d0
4024 SUD0=1.D0/PSUDINT(QLMAX,J)
4025 SL=100.D0*DLOG(1.D0-G*(1.D0-SUD0))/DLOG(SUD0)
4026 I=INT(QLI)
4027 K=INT(SL)
4028 IF(K.GT.98)K=98
4029 WK(2)=SL-K
4030 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
4031 WK(1)=1.D0-WK(2)+WK(3)
4032 WK(2)=WK(2)-2.D0*WK(3)
4033 PSQINT=0.D0
4034
4035 IF(I.GT.7)I=7
4036 WI(2)=QLI-I
4037 WI(3)=WI(2)*(WI(2)-1.D0)*.5D0
4038 WI(1)=1.D0-WI(2)+WI(3)
4039 WI(2)=WI(2)-2.D0*WI(3)
4040
4041 DO 1 K1=1,3
4042 DO 1 I1=1,3
40431 PSQINT=PSQINT+QRT(I+I1,K+K1,J)*WI(I1)*WK(K1)
4044 IF(PSQINT.LE.0.D0)PSQINT=0.D0
4045 PSQINT=16.D0*QTF*EXP(PSQINT)
4046 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSQINT
4047202 FORMAT(2X,'PSQINT=',E10.3)
4048 RETURN
4049 END
4050C=======================================================================
4051
4052 SUBROUTINE PSSHAR(LS,NHP,NW,NT)
4053c Inelastic interaction - energy sharing procedure:
4054c LS - total number of cut soft pomeron blocks (froissarons),
4055c NHP - total number of hard pomerons,
4056c NW - number of interacting projectile nucleons (excluding diffracted),
4057c NT - number of target nucleons in active state
4058c-----------------------------------------------------------------------
4059 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4060 INTEGER DEBUG
4061 REAL*16 GBH,GBH0
4062 DIMENSION WP(56),WM(56),WHA(1000),WHB(1000),LHA0(56),
4063 * LHB0(56),IZP(56),IZT(56),WP0H(56),WM0H(56),
4064 * WPP(2),WMM(2),EP3(4),LQA0(56),LQB0(56),IPC(2,2),EPC(8,2),
4065 * ILA(56),ILB(56),ELA(4,56),ELB(4,56),EP(4),EP1(4)
4066 COMMON /AREA1/ IA(2),ICZ,ICP
4067 COMMON /AREA2/ S,Y0,WP0,WM0
4068 COMMON /AREA9/ LQA(56),LQB(56),NQS(1000),IAS(1000),
4069 * IBS(1000),LHA(56),LHB(56),ZH(1000),IAH(1000),IBH(1000),
4070 * IQH(1000),LVA(56),LVB(56)
4071 COMMON /AREA10/ STMASS,AM(7)
4072 COMMON /AREA11/ B10
4073 COMMON /AREA12/ NSH
4074 COMMON /AREA17/ DEL,RS,RS0,FS,ALFP,RR,SH,DELH
4075 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
4076 COMMON /AREA19/ AHL(5)
4077 COMMON /AREA20/ WPPP
4078 COMMON /AREA25/ AHV(5)
4079 COMMON /AREA43/ MONIOU
4080 COMMON /DEBUG/ DEBUG
4081 COMMON /AREA47/ NJTOT
4082 SAVE
4083 IF(DEBUG.GE.1)WRITE (MONIOU,201)NW,NT,NHP,LS
4084201 FORMAT(2X,'PSSHARE - ENERGY SHARING PROCEDURE'/
4085 * 4X,'NUMBER OF WOUNDED PROJECTILE NUCLEONS(HADRONS) NW=',I2/
4086 * 4X,'NUMBER OF TARGET NUCLEONS IN THE ACTIVE STATE NT=',I2/
4087 * 4X,'NUMBER OF SEMIHARD BLOCKS NHP=',I3/
4088 * 4X,'NUMBER OF SOFT POMERON BLOCKS LS=',I3)
4089 NSH1=NSH
4090 DO 101 I=1,NW
4091101 LQA0(I)=LQA(I)
4092 DO 102 I=1,NT
4093102 LQB0(I)=LQB(I)
4094
4095100 NSH=NSH1
4096 NJTOT=0
4097 DO 103 I=1,NW
4098103 LQA(I)=LQA0(I)
4099 DO 104 I=1,NT
4100104 LQB(I)=LQB0(I)
4101c-------------------------------------------------
4102c Initial nucleons (hadrons) types recording
4103 IF(IA(1).NE.1)THEN
4104c IZP(i) - i-th projectile nucleons type (proton - 2, neutron - 3)
4105 DO 1 I=1,NW
41061 IZP(I)=INT(2.5+PSRAN(B10))
4107 ELSE
4108c IZP(1)=ICP - projectile hadron type
4109 IZP(1)=ICP
4110 ENDIF
4111 IF(IA(2).NE.1)THEN
4112c IZT(j) - j-th target nucleon type (proton - 2 or neutron - 3)
4113 DO 2 I=1,NT
41142 IZT(I)=INT(2.5+PSRAN(B10))
4115 ELSE
4116c Target proton
4117 IZT(1)=2
4118 ENDIF
4119c-------------------------------------------------
4120
4121c WREJ - parameter for energy sharing (to minimise rejection)
4122 WREJ=.0001D0
4123
41243 CONTINUE
4125
4126 IF(NHP.NE.0)THEN
4127 IF(DEBUG.GE.3)WRITE (MONIOU,211)NHP
4128211 FORMAT(2X,'PSSHARE: NUMBER OF HARD POMERONS NHP=',I3)
4129c-------------------------------------------------
4130c-------------------------------------------------
4131c Rejection function initialization:
4132c-------------------------------------------------
4133c energy-momentum will be shared between pomerons
4134c according to s**DEL dependence for soft pomeron and
4135c according to s**DELH dependence for pomeron with hard block,
4136c then rejection is used according to real Sigma_hard(s) dependence.
4137c Rejection is expected to be minimal for the uniform energy
4138c distribution between pomerons ( s_hard = s / LHA(I) / LHB(J) )
4139 GBH0=.6D0
4140c NREJ - total number of rejections
4141 NREJ=0
4142 NHP1=NHP
4143
4144 DO 5 IH=1,NHP1
4145 IF(DEBUG.GE.3)WRITE (MONIOU,212)IH
4146212 FORMAT(2X,'PSSHARE: GBH-INI; CONTRIBUTION FROM ',I3,
4147 * '-TH HARD POMERON')
4148c-------------------------------------------------
4149c LHA(i) (LHB(j)) - total number of cut hard blocks, connected to i-th projectile
4150c (j-th target) nucleon (hadron);
4151c IAH(ih) (IBH(ih)) - number (position in array) of the projectile (target) nucleon,
4152c connected to ih-th hard block;
4153c ZH(ih) - factor exp(-R_ij/R_p) for ih-th hard block;
4154c IQH(ih) - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
4155 IQQ=IQH(IH)
4156 Z=ZH(IH)
4157 I=IAH(IH)
4158 J=IBH(IH)
4159
4160c Uniform energy distribution between hard pomerons
4161 ZA=1.D0/LHA(I)
4162 ZB=1.D0/LHB(J)
4163c SI - c.m. energy squared for one hard block
4164 SI=ZA*ZB*S
4165
4166 IF(SI.LT.4.D0*(QT0+AMJ0))THEN
4167c-------------------------------------------------
4168c One hard pomeron is removed (the energy is insufficient to simulate
4169c great number of pomerons)
4170c-------------------------------------------------
4171 NHP=NHP-1
4172 LHA(I)=LHA(I)-1
4173 LHB(J)=LHB(J)-1
4174
4175 IF(IQQ.EQ.1)THEN
4176 LVA(I)=0
4177 ELSEIF(IQQ.EQ.2)THEN
4178 LVB(J)=0
4179 ELSEIF(IQQ.EQ.3)THEN
4180 LVA(I)=0
4181 LVB(J)=0
4182 ENDIF
4183c Rewriting of other hard pomerons characteristics
4184 IF(NHP.GE.IH)THEN
4185 DO 4 IH1=IH,NHP
4186 IQH(IH1)=IQH(IH1+1)
4187 ZH(IH1)=ZH(IH1+1)
4188 IAH(IH1)=IAH(IH1+1)
41894 IBH(IH1)=IBH(IH1+1)
4190 ENDIF
4191c End of removing - event will be simulated from the very beginning
4192c-------------------------------------------------
4193 GOTO 3
4194 ENDIF
4195
4196c Total rapidity for the interaction (for one hard block)
4197 YI=DLOG(SI)
4198 IF(YI.GT.17.D0)YI=17.D0
4199c Rejection function normalization (on maximal available energy)
4200 GBH0=GBH0/PSRJINT(YI,Z,IQQ)
42015 CONTINUE
4202 IF(DEBUG.GE.3)WRITE (MONIOU,213)
4203213 FORMAT(2X,'PSSHARE: GBH-INI - END')
4204c-------------------------------------------------
4205c End of rejection function normalization
4206c-------------------------------------------------
4207
4208c-------------------------------------------------
4209c LHA0(i), LHB0(j) arrays are used for energy sharing procedure
4210c (they define number of remained cut hard blocks connected to given nucleon from
4211c projectile or target respectively);
4212c WP, WM - arrays for the rest of light cone momenta (E+-P_l) for those
4213c nucleons (hadrons)
4214c Hard pomerons connected to valence quarks are excluded from LHA0(i), LHB0(j)
4215c (to be considered separetely)
42166 DO 7 I=1,NW
4217 LHA0(I)=LHA(I)-LVA(I)
42187 WP(I)=WP0
4219
4220 DO 8 I=1,NT
4221 LHB0(I)=LHB(I)-LVB(I)
42228 WM(I)=WM0
4223
4224c-------------------------------------------------
4225c Projectile valence quarks light cone momenta are choosen according to
4226c 1/sqrt(x) * x**delh * (1-x)**AHV(ICZ), ICZ is the type of the projectile
4227 DO 10 I=1,NW
4228 IF(LVA(I).NE.0)THEN
42299 XW=PSRAN(B10)**(1.D0/(.5D0+DELH))
4230 IF(PSRAN(B10).GT.(1.D0-XW)**AHV(ICZ))GOTO 9
4231 IF(DEBUG.GE.3)WRITE (MONIOU,214)I,XW
4232214 FORMAT(2X,'PSSHARE: ',I2,'-TH PROJ. NUCLEON (HADRON); LIGHT',
4233 * ' CONE MOMENTUM SHARE XW=',E10.3)
4234c WP0H(i) - valence quark light cone momentum for i-th projectile nucleon
4235 WP0H(I)=XW*WP(I)
4236c WP(i) - the remainder of the light cone momentum for i-th projectile nucleon
4237 WP(I)=WP(I)*(1.D0-XW)
4238 ENDIF
423910 CONTINUE
4240
4241c Target valence quarks light cone momenta are choosen according to
4242c 1/sqrt(x) * x**delh * (1-x)**AHV(2) (target nucleon)
4243 DO 12 I=1,NT
4244 IF(LVB(I).NE.0)THEN
424511 XW=PSRAN(B10)**(1.D0/(.5D0+DELH))
4246 IF(PSRAN(B10).GT.(1.D0-XW)**AHV(2))GOTO 11
4247 IF(DEBUG.GE.3)WRITE (MONIOU,215)I,XW
4248215 FORMAT(2X,'PSSHARE: ',I2,'-TH TARGET NUCLEON (HADRON); LIGHT',
4249 * ' CONE MOMENTUM SHARE XW=',E10.3)
4250c WM0H(i) - valence quark light cone momentum for i-th target nucleon
4251 WM0H(I)=XW*WM(I)
4252c WM(i) - the remainder of the light cone momentum for i-th target nucleon
4253 WM(I)=WM(I)*(1.D0-XW)
4254 ENDIF
425512 CONTINUE
4256c-------------------------------------------------
4257
4258 GBH=GBH0
4259c-------------------------------------------------
4260c Cycle over all cut hard blocks
4261c-------------------------------------------------
4262 DO 18 IH=1,NHP1
4263c-------------------------------------------------
4264c IAH(ih) (IBH(ih)) - number (position in array) of the projectile (target) nucleon,
4265c connected to ih-th hard block;
4266c ZH(ih) - factor exp(-R_ij/R_p) for ih-th hard block;
4267c IQH(ih) - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
4268 IQQ=IQH(IH)
4269 Z=ZH(IH)
4270 I=IAH(IH)
4271 J=IBH(IH)
4272
4273 IF((IQQ-3)*(IQQ-1).EQ.0)THEN
4274c WHA(ih) - light cone momentum (E+P_l) for ih-th hard block
4275c Read out of the valence quark light cone momentum
4276 WHA(IH)=WP0H(I)
4277 ELSE
4278c LHA0(i) - number of remained cut hard blocks connected to i-th projectile nucleon
4279 LHA0(I)=LHA0(I)-1
4280c Energy is shared between pomerons according to s**DEL dependence for soft
4281c pomeron and according to s**DELH dependence for the hard block;
4282c AHL(ICZ) determines energetic spectrum of the leading hadronic state of
4283c type ICZ
4284 BPI=1.D0/(1.D0+AHL(ICZ)+
4285 * (1.D0+DELH)*LHA0(I))
4286c BPI=1.D0/(1.D0+AHL(ICZ)+(1.D0+DEL)*LQA(I)+
4287c * (1.D0+DELH)*LHA0(I))
428815 XW=1.-PSRAN(B10)**BPI
4289c Rejection according to XW**DELH
4290 IF(PSRAN(B10).GT.XW**DELH)GOTO 15
4291c WHA(ih) - light cone momentum (E+P_l) for ih-th hard block
4292 WHA(IH)=WP(I)*XW
4293c WP(i) - the remainder of the light cone momentum for i-th projectile nucleon
4294 WP(I)=WP(I)*(1.D0-XW)
4295 ENDIF
4296
4297 IF((IQQ-3)*(IQQ-2).EQ.0)THEN
4298c WHB(ih) - light cone momentum (E-P_l) for ih-th hard block
4299c Read out of the valence quark light cone momentum
4300 WHB(IH)=WM0H(J)
4301 ELSE
4302c Energy is shared between pomerons - in the same way as above
4303 LHB0(J)=LHB0(J)-1
4304 BPI=1.D0/(1.D0+AHL(2)+(1.D0+DELH)
4305 * *LHB0(J))
4306c BPI=1.D0/(1.D0+AHL(2)+(1.D0+DEL)*LQB(J)+(1.D0+DELH)
4307c * *LHB0(J))
430816 XW=1.-PSRAN(B10)**BPI
4309 IF(PSRAN(B10).GT.XW**DELH)GOTO 16
4310c WHB(ih) - light cone momentum (E-P_l) for ih-th hard block
4311 WHB(IH)=WM(J)*XW
4312c WM(j) - the remainder of the light cone momentum for j-th target nucleon
4313 WM(J)=WM(J)*(1.D0-XW)
4314 ENDIF
4315
4316c Invariant mass for ih-th hard block
4317 SW=WHA(IH)*WHB(IH)
4318 IF(SW.LT.4.D0*(QT0+AMJ0))THEN
4319c Rejection in case of insufficient mass
4320 NREJ=NREJ+1
4321
4322 IF(NREJ.GT.30)THEN
4323c-------------------------------------------------
4324c In case of great number of rejections number of hard blocks is put down
4325c-------------------------------------------------
4326c Number of remained hard blocks
4327 NHP=NHP-1
4328 LHA(I)=LHA(I)-1
4329 LHB(J)=LHB(J)-1
4330
4331 IF(IQQ.EQ.1)THEN
4332 LVA(I)=0
4333 ELSEIF(IQQ.EQ.2)THEN
4334 LVB(J)=0
4335 ELSEIF(IQQ.EQ.3)THEN
4336 LVA(I)=0
4337 LVB(J)=0
4338 ENDIF
4339
4340 IF(NHP.GE.IH)THEN
4341 DO 17 IH1=IH,NHP
4342 IQH(IH1)=IQH(IH1+1)
4343 ZH(IH1)=ZH(IH1+1)
4344 IAH(IH1)=IAH(IH1+1)
434517 IBH(IH1)=IBH(IH1+1)
4346 ENDIF
4347 GOTO 3
4348c-------------------------------------------------
4349c End of removing - event will be simulated from the very beginning
4350c-------------------------------------------------
4351
4352 ELSE
4353 GOTO 6
4354 ENDIF
4355 ENDIF
4356 IF(DEBUG.GE.3)WRITE (MONIOU,216)IH,WHA(IH),WHB(IH),WP(I),WM(J)
4357216 FORMAT(2X,'PSSHARE: ',I3,'-TH SEMIHARD BLOCK; LIGHT',
4358 * ' CONE MOMENTA SHARES:',2E10.3/
4359 * 4X,'REMAINED LIGHT CONE MOMENTA:',2E10.3)
4360
4361 YH=DLOG(SW)
4362c PSRINT(YH,Z,IQQ) - phi_hard(s_hard) / s_hard ** DELH;
4363c YH = ln s_hard;
4364c Z - factor exp(-R_ij/R_p) for the hard block;
4365c IQQ - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
4366c Rejection function is multiplied by PSRINT(YH,Z,IQQ) for the ih-th block
4367 GBH=GBH*PSRJINT(YH,Z,IQQ)
436818 CONTINUE
4369c End of the loop for rejection function determination
4370c-------------------------------------------------
4371
4372c-------------------------------------------------
4373c Rejection procedure (due to the deviation of the phi_hard(s_hard)
4374c dependence from pure powerlike s_hard ** DELH law)
4375 IF(DEBUG.GE.2)WRITE (MONIOU,217)1.D0-GBH,NHP
4376217 FORMAT(2X,'PSSHARE: REJECTION PROBABILITY:',E10.3,
4377 * 2X,'NUMBER OF SEMIHARD BLOCKS:',I3)
4378 IF(PSRAN(B10).GT.GBH)THEN
4379 NREJ=NREJ+1
4380
4381 IF(NREJ.GT.30)THEN
4382 IF(DEBUG.GE.2)WRITE (MONIOU,218)
4383218 FORMAT(2X,'PSSHARE: MORE THAN 30 REJECTIONS - HARD POMERON',
4384 * ' NUMBER IS PUT DOWN')
4385c-------------------------------------------------
4386c In case of great number of rejections number of hard blocks is put down
4387c LNH - number of hard blocks to be removed
4388c-------------------------------------------------
4389 LNH=1+NHP/20
4390 DO 19 IHP=NHP-LNH+1,NHP
4391 IIH=IAH(IHP)
4392 JIH=IBH(IHP)
4393 IQQ=IQH(IHP)
4394
4395 IF(IQQ.EQ.1)THEN
4396 LVA(IIH)=0
4397 ELSEIF(IQQ.EQ.2)THEN
4398 LVB(JIH)=0
4399 ELSEIF(IQQ.EQ.3)THEN
4400 LVA(IIH)=0
4401 LVB(JIH)=0
4402 ENDIF
4403
4404 LHA(IIH)=LHA(IIH)-1
440519 LHB(JIH)=LHB(JIH)-1
4406
4407 NHP=NHP-LNH
4408 GOTO 3
4409c-------------------------------------------------
4410c End of removing - event will be simulated from the very beginning
4411c-------------------------------------------------
4412 ELSE
4413 GOTO 6
4414 ENDIF
4415 ENDIF
4416
4417***********************************************************************
4418 DO 31 I=1,NW
441931 LHA0(I)=LHA(I)
4420 DO 32 I=1,NT
442132 LHB0(I)=LHB(I)
4422***********************************************************************
4423
4424c-------------------------------------------------
4425c Particle production for all cut pomerons with hard blocks
4426c-------------------------------------------------
4427 DO 20 IH=1,NHP
4428 IQQ=IQH(IH)
4429 Z=ZH(IH)
4430 I=IAH(IH)
4431 J=IBH(IH)
4432***********************************************************************
4433 LHA0(I)=LHA0(I)-1
4434 LHB0(J)=LHB0(J)-1
4435***********************************************************************
4436c WPI, WMI - light cone momenta for current (ih-th) hard pomeron
4437 WPI=WHA(IH)
4438 WMI=WHB(IH)
4439 IF(DEBUG.GE.2)WRITE (MONIOU,219)IH,IQQ,WPI,WMI,WP(I),WM(J)
4440219 FORMAT(2X,'PSSHARE: ',I3,
4441 * '-TH HARD BLOCK; TYPE OF THE INTERACTION:',I1/
4442 * 4X,'INITIAL LIGHT CONE MOMENTA:',2E10.3/
4443 * 4X,'REMAINED LIGHT CONE MOMENTA:',2E10.3)
4444c-------------------------------------------------
4445c PSHOT procedure is used for hard partonic interaction -
4446c initial jets simulation
4447 CALL PSHOT(WPI,WMI,Z,IPC,EPC,IZP(I),IZT(J),ICZ,IQQ)
4448 IF(IQQ.EQ.1.OR.IQQ.EQ.3)THEN
4449 IF((IABS(IZP(I)).GT.5.OR.IABS(IZP(I)).EQ.3).AND.
4450 * IZP(I).GT.0.OR.IABS(IZP(I)).NE.3.AND.
4451 * IABS(IZP(I)).LE.5.AND.IZP(I).LT.0)THEN
4452 JQ=1
4453 ELSE
4454 JQ=2
4455 ENDIF
4456 ILA(I)=IPC(JQ,1)
4457 DO 330 L=1,4
4458330 ELA(L,I)=EPC(L+4*(JQ-1),1)
4459 ENDIF
4460 IF(IQQ.EQ.2.OR.IQQ.EQ.3)THEN
4461 IF((IABS(IZT(J)).GT.5.OR.IABS(IZT(J)).EQ.3).AND.
4462 * IZT(J).GT.0.OR.IABS(IZT(J)).NE.3.AND.
4463 * IABS(IZT(J)).LE.5.AND.IZT(J).LT.0)THEN
4464 JQ=1
4465 ELSE
4466 JQ=2
4467 ENDIF
4468 ILB(J)=IPC(JQ,2)
4469 DO 331 L=1,4
4470331 ELB(L,J)=EPC(L+4*(JQ-1),2)
4471 ENDIF
4472 IF(IQQ.EQ.3.AND.ILA(I)+ILB(J).EQ.0)NIAS=J
4473c-------------------------------------------------
4474c SW=WP(I)*WM(J)
4475c IF(WP(I).LT.0.D0.OR.WM(J).LT.0.D0.OR.
4476c * SW.LT.(AM(ICZ)+AM(2))**2)THEN
4477c NREJ=NREJ+1
4478c write (*,*)'i,j,WP(I),WM(J),sw',i,j,WP(I),WM(J),sw
4479c GOTO 100
4480c ENDIF
4481
4482c Leading hadronic state fragmentation is treated in the same way as low mass
4483c diffraction (exhitation mass is determined by secodary reggeon intercept
4484c dM**2~M**(-3))
4485 IF(LQA(I)+LHA0(I).EQ.0.AND.LQB(J)+LHB0(J).EQ.0)THEN
4486 IF(LVA(I).EQ.0.AND.LVB(J).EQ.0)THEN
4487 CALL XXDDFR(WP(I),WM(J),IZP(I),IZT(J))
4488 ELSEIF(LVA(I).EQ.0)THEN
4489 CALL XXDPR(WP(I),WM(J),IZP(I),IZT(J),1)
4490 IF(ILB(J).NE.0)THEN
4491 DO 341 L=1,4
4492341 EP1(L)=ELB(L,J)
4493 EP(1)=.5D0*WM(J)
4494 EP(2)=-EP(1)
4495 EP(3)=0.D0
4496 EP(4)=0.D0
4497 IPJ1=ILB(J)
4498 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4499 CALL PSJDEF(IZT(J),IPJ1,EP,EP1,JFL)
4500 IF(JFL.EQ.0)GOTO 100
4501 ENDIF
4502 ELSEIF(LVB(J).EQ.0)THEN
4503 CALL XXDTG(WP(I),WM(J),IZP(I),IZT(J),1)
4504 IF(ILA(I).NE.0)THEN
4505 DO 342 L=1,4
4506342 EP1(L)=ELA(L,I)
4507 EP(1)=.5D0*WP(I)
4508 EP(2)=EP(1)
4509 EP(3)=0.D0
4510 EP(4)=0.D0
4511 IPJ1=ILA(I)
4512 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4513 CALL PSJDEF(IZP(I),IPJ1,EP,EP1,JFL)
4514 IF(JFL.EQ.0)GOTO 100
4515 ENDIF
4516 ELSE
4517 IF(ILA(I).NE.0)THEN
4518 DO 343 L=1,4
4519343 EP1(L)=ELA(L,I)
4520 EP(1)=.5D0*WP(I)
4521 EP(2)=EP(1)
4522 EP(3)=0.D0
4523 EP(4)=0.D0
4524 IPJ1=ILA(I)
4525 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4526 CALL PSJDEF(IZP(I),IPJ1,EP,EP1,JFL)
4527 IF(JFL.EQ.0)GOTO 100
4528 ENDIF
4529 IF(ILB(J).NE.0)THEN
4530 DO 351 L=1,4
4531351 EP1(L)=ELB(L,J)
4532 EP(1)=.5D0*WM(J)
4533 EP(2)=-EP(1)
4534 EP(3)=0.D0
4535 EP(4)=0.D0
4536 IPJ1=ILB(J)
4537 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4538 CALL PSJDEF(IZT(J),IPJ1,EP,EP1,JFL)
4539 IF(JFL.EQ.0)GOTO 100
4540 ENDIF
4541 ENDIF
4542 ELSEIF(LQA(I)+LHA0(I).EQ.0)THEN
4543 IF(LVA(I).EQ.0)THEN
4544 CALL XXDPR(WP(I),WM(J),IZP(I),IZT(J),LQB(J)+LHB0(J))
4545 ELSE
4546 IF(ILA(I).NE.0)THEN
4547 DO 344 L=1,4
4548344 EP1(L)=ELA(L,I)
4549 EP(1)=.5D0*WP(I)
4550 EP(2)=EP(1)
4551 EP(3)=0.D0
4552 EP(4)=0.D0
4553 IPJ1=ILA(I)
4554 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4555 CALL PSJDEF(IZP(I),IPJ1,EP,EP1,JFL)
4556 IF(JFL.EQ.0)GOTO 100
4557 ENDIF
4558 ENDIF
4559 ELSEIF(LQB(J)+LHB0(J).EQ.0)THEN
4560 IF(LVB(J).EQ.0)THEN
4561 CALL XXDTG(WP(I),WM(J),IZP(I),IZT(J),LQA(I)+LHA0(I))
4562 ELSE
4563 IF(ILB(J).NE.0)THEN
4564 DO 345 L=1,4
4565345 EP1(L)=ELB(L,J)
4566 EP(1)=.5D0*WM(J)
4567 EP(2)=-EP(1)
4568 EP(3)=0.D0
4569 EP(4)=0.D0
4570 IPJ1=ILB(J)
4571 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4572 CALL PSJDEF(IZT(J),IPJ1,EP,EP1,JFL)
4573 IF(JFL.EQ.0)GOTO 100
4574 ENDIF
4575 ENDIF
4576 ENDIF
4577cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
457820 CONTINUE
4579c-------------------------------------------------
4580c End of the hard blocks loop
4581c-------------------------------------------------
4582
4583 ELSE
4584c-------------------------------------------------
4585c Initial light cone momenta initialization in case of no one cut hard block
4586 DO 21 I=1,NW
458721 WP(I)=WP0
4588 DO 22 I=1,NT
458922 WM(I)=WM0
4590 ENDIF
4591
4592 IF(LS.NE.0)THEN
4593c-------------------------------------------------
4594c The loop for all cut froissarons (blocks of soft pomerons)
4595c-------------------------------------------------
4596 DO 28 IS=1,LS
4597c NP=NQS(is) - number of cut pomerons in is-th block;
4598c IAS(is) (IBS(is)) - number (position in array) of the projectile (target) nucleon,
4599c connected to is-th block of soft pomerons;
4600c LQA(i) (LQB(j)) - total number of cut soft pomerons, connected to i-th projectile
4601c (j-th target) nucleon (hadron);
4602c WP(i) (WM(j)) - the remainder of the light cone momentum for i-th projectile
4603c (j-th target) nucleon (hadron);
4604c NP=NQS(is) - number of cut pomerons in is-th block;
4605c LQ1, LQ2 define the numbers of the remained cut pomerons connected
4606c to given nucleons (hadrons)
4607 I=IAS(IS)
4608 J=IBS(IS)
4609 LQ1=LQA(I)
4610 LQ2=LQB(J)
4611 WPN=WP(I)
4612 WMN=WM(J)
4613 NP=NQS(IS)
4614 IF(DEBUG.GE.3)WRITE (MONIOU,222)IS,I,J,NP
4615222 FORMAT(2X,'PSSHARE: ',I3,'-TH SOFT POMERON BLOCK IS',
4616 * ' CONNECTED TO ',I2,
4617 * '-TH PROJECTILE NUCLEON'/4x,'(HADRON) AND ',I2,
4618 * '-TH TARGET NUCLEON'/
4619 * 4X,'NUMBER OF CUT SOFT POMERONS IN THE BLOCK:',I2)
4620c-------------------------------------------------
4621c The loop for all cut pomerons in the block
4622 DO 27 IP=1,NP
4623
4624cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4625c High mass diffraction - probability WPPP
462614 JPP=0
4627 IF(LQ1.EQ.1.AND.WPN.EQ.WP0.AND.PSRAN(B10).LT.WPPP)THEN
4628c In case of only one cut soft pomeron high mass diffraction is simulated with the
4629c probability WPPP/2 or triple pomeron contribution - also WPPP/2 to have AGK cancell.
4630c - only for projectile hadron (nucleons) (for target - neglected)
4631c YW is the branching point position (in rapidity)
4632 YW=1.D0+PSRAN(B10)*(Y0-2.D0)
4633 IF(DEBUG.GE.3)WRITE (MONIOU,223)YW
4634223 FORMAT(2X,'PSSHARE: TRIPLE POMERON CONTRIBUTION YW=',E10.3)
4635c Light cone momentum (E+P_l) for the diffractive state (which is just usual cut
4636c pomeron)
4637 XPW=EXP(-YW)
4638 JPP=1
4639cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4640
4641 ELSE
4642 LQ1=LQ1-1
4643c Energy-momentum is shared between pomerons according to s**DEL dependence for soft
4644c pomeron; AHL(ICZ) determines energy spectrum of leading hadronic
4645c state of type ICZ
4646 BPI=1.D0/(1.D0+AHL(ICZ)+(1.D0+DEL)*LQ1)
464723 XPW=1.-PSRAN(B10)**BPI
4648c Rejection according to XW**DEL
4649 IF(PSRAN(B10).GT.XPW**DEL)GOTO 23
4650 ENDIF
4651
4652 LQ2=LQ2-1
4653c Energy-momentum is shared between pomerons according to s**DEL dependence for soft
4654c pomeron - similar to projectile case
4655 BPI=1.D0/(1.D0+AHL(2)+(1.D0+DEL)*LQ2)
465624 XMW=1.-PSRAN(B10)**BPI
4657c Rejection according to XW**DEL
4658 IF(PSRAN(B10).GT.XMW**DEL)GOTO 24
4659c-------------------------------------------------
4660
4661cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4662c High mass diffraction is rejected in case of insufficient energy
4663 IF(JPP.EQ.1.AND.XPW*XMW*WPN*WMN.LT.2.72D0)THEN
4664 LQ2=LQ2+1
4665 GOTO 14
4666 ENDIF
4667cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4668
4669c WPI is the light cone momentum (E+P_l) for the pomeron;
4670c WPN is the remainder of the light cone momentum for given nucleon (hadron)
4671 WPI=WPN*XPW
4672 WPN=WPN-WPI
4673 WMI=WMN*XMW
4674 WMN=WMN-WMI
4675
4676************************************************************************
4677cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4678 IF(LQ1.EQ.0.AND.LVA(I).EQ.0)THEN
4679 CALL IXXDEF(IZP(I),IC11,IC12,ICZ)
4680 ELSE
4681 IC11=0
4682 IC12=0
4683 ENDIF
4684 IF(LQ2.EQ.0.AND.LVB(J).EQ.0)THEN
4685 CALL IXXDEF(IZT(J),IC21,IC22,2)
4686 ELSE
4687 IC21=0
4688 IC22=0
4689 ENDIF
4690
4691cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4692c Fragmentation process for the pomeron ( quarks and antiquarks types at the
4693c ends of the two strings are determined, energy-momentum is shared
4694c between them and strings fragmentation is simulated )
4695 IF(DEBUG.GE.3)WRITE (MONIOU,224)IP,WPI,WMI
4696224 FORMAT(2X,'PSSHARE: ',I2,'-TH SOFT POMERON IN THE BLOCK'/
4697 * 4X,'LIGHT CONE MOMENTA FOR THE POMERON:',2E10.3)
4698 CALL XXSTR(WPI,WMI,WPN,WMN,IC11,IC12,IC22,IC21)
4699cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4700
4701cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4702c Triple pomeron contribution simulation
4703 IF(JPP.EQ.1)THEN
4704 IF(PSRAN(B10).LT..5D0)THEN
4705 SW=WPN*WMN
4706 IF(WPN.LT.0.D0.OR.WMN.LT.0.D0.OR.
4707 * SW.LT.(AM(ICZ)+AM(2))**2)THEN
4708 write (*,*)'difr,i,j,WPn,WMn,sw,lq1,lq2',
4709 * i,j,WPn,WMn,sw,lq1,lq2
4710 NREJ=NREJ+1
4711 GOTO 100
4712 ENDIF
4713
4714 IF(LQ2.EQ.0)THEN
4715 CALL XXDTG(WPN,WMN,IZP(I),IZT(J),0)
4716 ELSE
4717 WP1=WPN
4718 WM1=AM(ICZ)**2/WP1
4719 EP3(1)=.5D0*(WP1+WM1)
4720 EP3(2)=.5D0*(WP1-WM1)
4721 EP3(3)=0.D0
4722 EP3(4)=0.D0
4723 CALL XXREG(EP3,IZP(I))
4724 WMN=WMN-WM1
4725 WPN=0.D0
4726 ENDIF
4727 GOTO 30
4728 ELSE
4729
4730c Triple pomeron contribution simulation (both pomerons are cut)
4731 IF(DEBUG.GE.3)WRITE (MONIOU,225)
4732225 FORMAT(2X,'PSSHARE: TRIPLE POMERON CONRITRIBUTION WITH 3 CUT',
4733 *' POMERONS')
4734 WMM(1)=1.D0/WPI
4735 WMN=WMN-WMM(1)
4736c Light cone momentum (E-P_l) sharing for the two pomerons
4737 WMM(2)=WMM(1)*PSRAN(B10)
4738 WMM(1)=WMM(1)-WMM(2)
4739 LQ1=2
4740 DO 26 L=1,2
4741 LQ1=LQ1-1
4742c Light cone momentum (E+P_l) sharing for the two pomerons
4743 BPI=(1.D0+DEL)*LQ1+1.D0+AHL(ICZ)
4744 BPI=1.D0/BPI
474525 XPW=1.-PSRAN(B10)**BPI
4746 IF(PSRAN(B10).GT.XPW**DEL)GOTO 25
4747 WPP(L)=WPN*XPW
4748 WPN=WPN*(1.D0-XPW)
4749c Fragmentation process for the pomerons
475026 CALL XXSTR(WPP(L),WMM(L),WPN,WMN,0,0,0,0)
4751 SW=WPN*WMN
4752 IF(WPN.LT.0.D0.OR.WMN.LT.0.D0.OR.
4753 * SW.LT.(AM(ICZ)+AM(2))**2)THEN
4754 NREJ=NREJ+1
4755 GOTO 100
4756 ENDIF
4757 ENDIF
4758 ENDIF
4759cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
476027 CONTINUE
4761c End of the pomeron loop
4762cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4763c SW=WPN*WMN
4764c IF(WPN.LT.0.D0.OR.WMN.LT.0.D0.OR.
4765c * SW.LT.(AM(ICZ)+AM(2))**2)THEN
4766c NREJ=NREJ+1
4767c GOTO 100
4768c ENDIF
4769
4770c Leading hadronic state fragmentation is treated in the same way as low mass
4771c diffraction (exhitation mass is determined by secodary reggeon intercept
4772c dM**2~M**(-3))
4773 IF(LQ1.EQ.0.AND.LQ2.EQ.0)THEN
4774 IF(LVA(I).EQ.0.AND.LVB(J).EQ.0)THEN
4775 CALL XXDDFR(WPN,WMN,IZP(I),IZT(J))
4776 ELSEIF(LVA(I).EQ.0)THEN
4777 CALL XXDPR(WPN,WMN,IZP(I),IZT(J),1)
4778 IF(ILB(J).NE.0)THEN
4779 DO 346 L=1,4
4780346 EP1(L)=ELB(L,J)
4781 EP(1)=.5D0*WMN
4782 EP(2)=-EP(1)
4783 EP(3)=0.D0
4784 EP(4)=0.D0
4785 IPJ1=ILB(J)
4786 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4787 CALL PSJDEF(IZT(J),IPJ1,EP,EP1,JFL)
4788 IF(JFL.EQ.0)GOTO 100
4789 ENDIF
4790 ELSEIF(LVB(J).EQ.0)THEN
4791 CALL XXDTG(WPN,WMN,IZP(I),IZT(J),1)
4792 IF(ILA(I).NE.0)THEN
4793 DO 347 L=1,4
4794347 EP1(L)=ELA(L,I)
4795 EP(1)=.5D0*WPN
4796 EP(2)=EP(1)
4797 EP(3)=0.D0
4798 EP(4)=0.D0
4799 IPJ1=ILA(I)
4800 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4801 CALL PSJDEF(IZP(I),IPJ1,EP,EP1,JFL)
4802 IF(JFL.EQ.0)GOTO 100
4803 ENDIF
4804 ELSE
4805 IF(ILA(I).NE.0)THEN
4806 DO 348 L=1,4
4807348 EP1(L)=ELA(L,I)
4808 EP(1)=.5D0*WPN
4809 EP(2)=EP(1)
4810 EP(3)=0.D0
4811 EP(4)=0.D0
4812 IPJ1=ILA(I)
4813 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4814 CALL PSJDEF(IZP(I),IPJ1,EP,EP1,JFL)
4815 IF(JFL.EQ.0)GOTO 100
4816 ENDIF
4817 IF(ILB(J).NE.0)THEN
4818 DO 349 L=1,4
4819349 EP1(L)=ELB(L,J)
4820 EP(1)=.5D0*WMN
4821 EP(2)=-EP(1)
4822 EP(3)=0.D0
4823 EP(4)=0.D0
4824 IPJ1=ILB(J)
4825 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4826 CALL PSJDEF(IZT(J),IPJ1,EP,EP1,JFL)
4827 IF(JFL.EQ.0)GOTO 100
4828 ENDIF
4829 ENDIF
4830
4831 ELSEIF(LQ1.EQ.0)THEN
4832 IF(LVA(I).EQ.0)THEN
4833 CALL XXDPR(WPN,WMN,IZP(I),IZT(J),LQ2)
4834 ELSE
4835 IF(ILA(I).NE.0)THEN
4836 DO 350 L=1,4
4837350 EP1(L)=ELA(L,I)
4838 EP(1)=.5D0*WPN
4839 EP(2)=EP(1)
4840 EP(3)=0.D0
4841 EP(4)=0.D0
4842 IPJ1=ILA(I)
4843 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4844 CALL PSJDEF(IZP(I),IPJ1,EP,EP1,JFL)
4845 IF(JFL.EQ.0)GOTO 100
4846 ENDIF
4847 ENDIF
4848
4849 ELSEIF(LQ2.EQ.0)THEN
4850 IF(LVB(J).EQ.0)THEN
4851 CALL XXDTG(WPN,WMN,IZP(I),IZT(J),LQ1)
4852 ELSE
4853 IF(ILB(J).NE.0)THEN
4854 DO 352 L=1,4
4855352 EP1(L)=ELB(L,J)
4856 EP(1)=.5D0*WMN
4857 EP(2)=-EP(1)
4858 EP(3)=0.D0
4859 EP(4)=0.D0
4860 IPJ1=ILB(J)
4861 IF(IABS(IPJ1).EQ.3)IPJ1=IPJ1*4/3
4862 CALL PSJDEF(IZT(J),IPJ1,EP,EP1,JFL)
4863 IF(JFL.EQ.0)GOTO 100
4864 ENDIF
4865 ENDIF
4866 ENDIF
4867cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4868c-------------------------------------------------
4869c The numbers of the remained cut pomerons connected to given nucleons (hadrons)
4870c as well as the rest of the longitudinal momenta for these nucleons are
4871c recorded
487230 LQA(I)=LQ1
4873 LQB(J)=LQ2
4874 WP(I)=WPN
487528 WM(J)=WMN
4876 ENDIF
4877c-------------------------------------------------
4878c End of the soft blocks loop
4879c-------------------------------------------------
4880 IF(IA(1).EQ.1.AND.LVA(1).NE.0.AND.ILA(1).EQ.0)THEN
4881 EP(1)=.5D0*WP(1)
4882 EP(2)=EP(1)
4883 EP(3)=0.D0
4884 EP(4)=0.D0
4885 EP1(1)=.5D0*WM(NIAS)
4886 EP1(2)=-EP1(1)
4887 EP1(3)=0.D0
4888 EP1(4)=0.D0
4889 CALL PSJDEF(IZP(1),IZT(NIAS),EP,EP1,JFL)
4890 IF(JFL.EQ.0)GOTO 100
4891 ENDIF
4892cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4893 CALL XXJETSIM
4894************************************************************************
4895 IF(DEBUG.GE.3)WRITE (MONIOU,227)
4896227 FORMAT(2X,'PSSHARE - END')
4897 RETURN
4898 END
4899C=======================================================================
4900
4901 SUBROUTINE PSTRANS(EP,EY)
4902c Lorentz transform according to parameters EY ( determining Lorentz shift
4903c along the Z,X,Y-axis respectively (EY(1),EY(2),EY(3)))
4904c-----------------------------------------------------------------------
4905 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4906 INTEGER DEBUG
4907 DIMENSION EY(3),EP(4)
4908 COMMON /AREA43/ MONIOU
4909 COMMON /DEBUG/ DEBUG
4910 IF(DEBUG.GE.2)WRITE (MONIOU,201)EP,EY
4911201 FORMAT(2X,'PSTRANS - LORENTZ BOOST FOR 4-VECTOR'/4X,'EP=',
4912 * 2X,4(E10.3,1X)/4X,'BOOST PARAMETERS EY=',3E10.3)
4913c Lorentz transform to lab. system according to 1/EY(i) parameters
4914 DO 1 I=1,3
4915 IF(EY(4-I).NE.1.D0)THEN
4916 WP=(EP(1)+EP(5-I))/EY(4-I)
4917 WM=(EP(1)-EP(5-I))*EY(4-I)
4918 EP(1)=.5D0*(WP+WM)
4919 EP(5-I)=.5D0*(WP-WM)
4920 ENDIF
49211 CONTINUE
4922 IF(DEBUG.GE.3)WRITE (MONIOU,202)EP
4923202 FORMAT(2X,'PSTRANS: TRANSFORMED 4-VECTOR EP=',
4924 * 2X,4(E10.3,1X))
4925 RETURN
4926 END
4927C=======================================================================
4928
4929 SUBROUTINE PSTRANS1(EP,EY)
4930c Lorentz transform according to parameters EY ( determining Lorentz shift
4931c along the Z,X,Y-axis respectively (EY(1),EY(2),EY(3)))
4932c-----------------------------------------------------------------------
4933 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4934 INTEGER DEBUG
4935 DIMENSION EY(3),EP(4)
4936 COMMON /AREA43/ MONIOU
4937 COMMON /DEBUG/ DEBUG
4938 IF(DEBUG.GE.2)WRITE (MONIOU,201)EP,EY
4939201 FORMAT(2X,'PSTRANS1 - LORENTZ BOOST FOR 4-VECTOR'/4X,'EP=',
4940 * 2X,4(E10.3,1X)/4X,'BOOST PARAMETERS EY=',3E10.3)
4941c Lorentz transform to lab. system according to 1/EY(i) parameters
4942 DO 2 I=1,3
4943 IF(EY(I).NE.1.D0)THEN
4944 WP=(EP(1)+EP(I+1))*EY(I)
4945 WM=(EP(1)-EP(I+1))/EY(I)
4946 EP(1)=.5D0*(WP+WM)
4947 EP(I+1)=.5D0*(WP-WM)
4948 ENDIF
49492 CONTINUE
4950 IF(DEBUG.GE.3)WRITE (MONIOU,202)EP
4951202 FORMAT(2X,'PSTRANS1: TRANSFORMED 4-VECTOR EP=',
4952 * 2X,4(E10.3,1X))
4953 RETURN
4954 END
4955C=======================================================================
4956
4957 FUNCTION PSUDINT(QLMAX,J)
4958c PSUDINT - timelike Sudakov formfactor interpolation
4959c QLMAX - ln QMAX/16/QTF,
4960c J - type of the parton (0-g,1-q)
4961c-----------------------------------------------------------------------
4962 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4963 INTEGER DEBUG
4964 DIMENSION WK(3)
4965 COMMON /AREA33/ FSUD(10,2)
4966 COMMON /AREA43/ MONIOU
4967 COMMON /DEBUG/ DEBUG
4968 SAVE
4969
4970 IF(DEBUG.GE.2)WRITE (MONIOU,201)J,QLMAX
4971201 FORMAT(2X,'PSUDINT - SPACELIKE FORM FACTOR INTERPOLATION:'/
4972 * 4X,'PARTON TYPE J=',
4973 * I1,2X,'MOMENTUM LOGARITHM QLMAX=',E10.3)
4974 QL=QLMAX/1.38629d0
4975
4976 IF(QL.LE.0.D0)THEN
4977 PSUDINT=1.D0
4978 ELSE
4979 K=INT(QL)
4980 IF(K.GT.7)K=7
4981 WK(2)=QL-K
4982 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
4983 WK(1)=1.D0-WK(2)+WK(3)
4984 WK(2)=WK(2)-2.D0*WK(3)
4985
4986 PSUDINT=0.D0
4987 DO 1 K1=1,3
49881 PSUDINT=PSUDINT+FSUD(K+K1,J)*WK(K1)
4989 IF(PSUDINT.LE.0.D0)PSUDINT=0.D0
4990 PSUDINT=EXP(-PSUDINT)
4991 ENDIF
4992 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSUDINT
4993202 FORMAT(2X,'PSUDINT=',E10.3)
4994 RETURN
4995 END
4996C=======================================================================
4997
4998 FUNCTION PSUDS(Q,J)
4999c PSUDS - spacelike Sudakov formfactor
5000c Q - maximal value of the effective momentum,
5001c J - type of parton (0 - g, 1 - q)
5002c-----------------------------------------------------------------------
5003 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5004 INTEGER DEBUG
5005 COMMON /AREA6/ PI,BM,AM
5006 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
5007 COMMON /AREA43/ MONIOU
5008 COMMON /DEBUG/ DEBUG
5009 SAVE
5010
5011 IF(DEBUG.GE.2)WRITE (MONIOU,201)J,Q
5012201 FORMAT(2X,'PSUDS - SPACELIKE FORM FACTOR: PARTON TYPE J=',
5013 * I1,2X,'MOMENTUM Q=',E10.3)
5014 IF(Q.GT.QT0)THEN
5015 QLM=DLOG(Q/ALM)
5016 PSUDS=(QLM*DLOG(QLM/QLOG)-DLOG(Q/QT0))/9.D0
5017
5018 IF(J.EQ.0)THEN
5019 PSUDS=PSUDS*6.D0
5020 ELSE
5021 PSUDS=PSUDS/.375D0
5022 ENDIF
5023 PSUDS=EXP(-PSUDS)
5024
5025 ELSE
5026 PSUDS=1.D0
5027 ENDIF
5028 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSUDS
5029202 FORMAT(2X,'PSUDS=',E10.3)
5030 RETURN
5031 END
5032C=======================================================================
5033
5034 FUNCTION PSUDT(QMAX,J)
5035c PSUDT - timelike Sudakov formfactor
5036c QMAX - maximal value of the effective momentum,
5037c J - type of parton (0 - g, 1 - q)
5038c-----------------------------------------------------------------------
5039 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5040 INTEGER DEBUG
5041 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
5042 COMMON/AR3/X1(7),A1(7)
5043 COMMON /AREA43/ MONIOU
5044 COMMON /DEBUG/ DEBUG
5045 SAVE
5046
5047 IF(DEBUG.GE.2)WRITE (MONIOU,201)J,QMAX
5048201 FORMAT(2X,'PSUDT - TIMELIKE FORM FACTOR: PARTON TYPE J=',
5049 * I1,2X,'MOMENTUM QMAX=',E10.3)
5050 PSUDT=0.D0
5051 QLMAX=DLOG(DLOG(QMAX/16.D0/ALM))
5052 QFL=DLOG(DLOG(QTF/ALM))
5053
5054c Numerical integration over transverse momentum square;
5055c Gaussian integration is used
5056 DO 1 I=1,7
5057 DO 1 M=1,2
5058 QTL=.5D0*(QLMAX+QFL+(2*M-3)*X1(I)*(QLMAX-QFL))
5059 QT=ALM*EXP(EXP(QTL))
5060 IF(QT.GE.QMAX/16.D0)QT=QMAX/16.0001D0
5061 ZMIN=.5D0-DSQRT((.25D0-DSQRT(QT/QMAX)))
5062 ZMAX=1.D0-ZMIN
5063 IF(J.EQ.0)THEN
5064******************************************************
5065 AP=(PSAPINT(ZMAX,0,0)-PSAPINT(ZMIN,0,0)+
5066 * PSAPINT(ZMAX,0,1)-PSAPINT(ZMIN,0,1))*.5D0
5067******************************************************
5068 ELSE
5069 AP=PSAPINT(ZMAX,1,0)-PSAPINT(ZMIN,1,0)
5070 ENDIF
50711 PSUDT=PSUDT+A1(I)*AP
5072 PSUDT=PSUDT*(QLMAX-QFL)/9.D0
5073 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSUDT
5074202 FORMAT(2X,'PSUDT=',E10.3)
5075 RETURN
5076 END
5077C=======================================================================
5078
5079 FUNCTION PSV(X,Y,XB,IB)
5080c XXV - eikonal dependent factor for hadron-nucleus interaction
5081c (used for total and diffractive hadron-nucleus cross-sections calculation)
5082c-----------------------------------------------------------------------
5083 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5084 INTEGER DEBUG
5085 DIMENSION XB(56,3),FHARD(3)
5086 COMMON /AREA43/ MONIOU
5087 COMMON /DEBUG/ DEBUG
5088 SAVE
5089
5090 IF(DEBUG.GE.2)WRITE (MONIOU,201)X,Y,IB
5091201 FORMAT(2X,'PSV - EIKONAL FACTOR: NUCLEON COORDINATES X=',
5092 * E10.3,2X,'Y=',E10.3/4X,'NUMBER OF ACTIVE TARGET NUCLEONS IB='
5093 * ,I2)
5094 DV=0.D0
5095c????????????????????????????????????????????
5096 DO 1 M=1,IB
5097 Z=PSDR(X-XB(M,1),Y-XB(M,2))
5098 DV=DV+PSFAZ(Z,FSOFT,FHARD,FSHARD)+FHARD(1)+FHARD(2)+FHARD(3)
50991 CONTINUE
5100 PSV=(1.D0-EXP(-DV))**2
5101
5102C DH=1.D0
5103C DO 1 M=1,IB
5104C Z=PSDR(X-XB(M,1),Y-XB(M,2))
5105C DV=DV+PSFAZ(Z,FSOFT,FHARD,FSHARD)
5106C 1 DH=DH*(1.D0-FHARD(1)-FHARD(2)-FHARD(3))
5107c????????????????????????????????????????????????
5108 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSV
5109202 FORMAT(2X,'PSV=',E10.3)
5110 RETURN
5111 END
5112C=======================================================================
5113
5114 SUBROUTINE PSVDEF(ICH,IC1,ICZ)
5115c Determination of valence quark flavour -
5116c for valence quark hard scattering
5117c-----------------------------------------------------------------------
5118 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5119 INTEGER DEBUG
5120 COMMON /AREA11/ B10
5121 COMMON /AREA43/ MONIOU
5122 COMMON /DEBUG/ DEBUG
5123 SAVE
5124 IF(DEBUG.GE.2)WRITE (MONIOU,201)ICH,ICZ
5125201 FORMAT(2X,'PSVDEF: HADRON TYPE ICH=',I2,' AUXILLIARY TYPE ICZ='
5126 * ,I1)
5127
5128 IS=IABS(ICH)/ICH
5129 IF(ICZ.EQ.1)THEN
5130 IC1=ICH*(1-3*INT(.5+PSRAN(B10)))
5131 ICH=-IC1-ICH
5132 ELSEIF(ICZ.EQ.2)THEN
5133 IF(PSRAN(B10).GT..33333D0.OR.ICH.LT.0)THEN
5134 IC1=ICH-IS
5135 ICH=3*IS
5136 ELSE
5137 IC1=4*IS-ICH
5138 ICH=ICH+4*IS
5139 ENDIF
5140 ELSEIF(ICZ.EQ.3)THEN
5141 IC1=ICH-3*IS
5142 ICH=-4*IS
5143 ELSEIF(ICZ.EQ.4)THEN
5144 IC1=ICH-9*IS
5145 ICH=5*IS
5146 ENDIF
5147 IF(DEBUG.GE.3)WRITE (MONIOU,202)IC1,ICH
5148202 FORMAT(2X,'PSVDEF-END: QUARK FLAVOR IC1=',I2,
5149 * 'DIQUARK TYPE ICH=',I2)
5150 RETURN
5151 END
5152C=======================================================================
5153
5154 FUNCTION PSZSIM(QQ,J)
5155c PSZSIM - light cone momentum share simulation (for the timelike
5156c branching)
5157c QQ - effective momentum value,
5158c J - type of the parent parton (0-g,1-q)
5159c-----------------------------------------------------------------------
5160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5161 INTEGER DEBUG
5162 COMMON /AREA11/ B10
5163 COMMON /AREA18/ ALM,QT0,QLOG,QLL,AQT0,QTF,BET,AMJ0
5164 COMMON /AREA43/ MONIOU
5165 COMMON /DEBUG/ DEBUG
5166 SAVE
5167
5168 IF(DEBUG.GE.2)WRITE (MONIOU,201)QQ,J
5169201 FORMAT(2X,'PSZSIM - Z-SHARE SIMULATION: QQ=',E10.3,2X,'J=',I1)
5170 ZMIN=.5D0-DSQRT(.25D0-DSQRT(QTF/QQ))
5171 QLF=DLOG(QTF/ALM)
5172
51731 CONTINUE
5174 IF(J.EQ.1)THEN
5175 PSZSIM=.5D0*(2.D0*ZMIN)**PSRAN(B10)
5176******************************************************
5177 GB=PSZSIM*(PSFAP(PSZSIM,0,0)+PSFAP(PSZSIM,0,1))/7.5D0
5178******************************************************
5179 ELSE
5180 PSZSIM=ZMIN*((1.D0-ZMIN)/ZMIN)**PSRAN(B10)
5181 GB=PSZSIM*PSFAP(PSZSIM,1,0)*.375D0
5182 ENDIF
5183 QT=QQ*(PSZSIM*(1.D0-PSZSIM))**2
5184 GB=GB/DLOG(QT/ALM)*QLF
5185 IF(DEBUG.GE.3)WRITE (MONIOU,203)QT,GB
5186203 FORMAT(2X,'PSZSIM: QT=',E10.3,2X,'GB=',E10.3)
5187 IF(PSRAN(B10).GT.GB)GOTO 1
5188 IF(DEBUG.GE.3)WRITE (MONIOU,202)PSZSIM
5189202 FORMAT(2X,'PSZSIM=',E10.3)
5190 RETURN
5191 END
5192C=======================================================================
5193
5194 SUBROUTINE IXXDEF(ICH,IC1,IC2,ICZ)
5195c Determination of parton flavours in forward and backward direction -
5196c for valence quark hard scattering
5197c-----------------------------------------------------------------------
5198 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5199 INTEGER DEBUG
5200 COMMON /AREA11/ B10
5201 COMMON /AREA43/ MONIOU
5202 COMMON /DEBUG/ DEBUG
5203 SAVE
5204 IF(DEBUG.GE.2)WRITE (MONIOU,201)ICH,ICZ
5205201 FORMAT(2X,'IXXDEF: HADRON TYPE ICH=',I2,' AUXILLIARY TYPE ICZ='
5206 * ,I1)
5207 IS=IABS(ICH)/ICH
5208 IF(ICZ.EQ.1)THEN
5209 IC1=ICH*(1-3*INT(.5+PSRAN(B10)))
5210 ICH1=ICH*INT(.5D0+PSRAN(B10))
5211 IC2=-IC1*IABS(ICH1)-(ICH+IC1)*IABS(ICH-ICH1)
5212
5213 ELSEIF(ICZ.EQ.2)THEN
5214c Valence quark type simulation ( for the proton )
5215 IC1=INT(1.3333+PSRAN(B10))
5216c Leading nucleon type simulation ( flavors combinatorics )
5217 ICH1=(2-IC1)*INT(PSRAN(B10)+.5)+2
5218c The type of the parton at the end of the rest string ( after the
5219c leading nucleon ejection )
5220 IC2=(3-ICH1)*(2-IC1)-2
5221
5222 IF(IABS(ICH).EQ.3)THEN
5223 IC1=3-IC1
5224 IC2=-3-IC2
5225 ICH1=5-ICH1
5226 ENDIF
5227 IF(ICH.LT.0)THEN
5228 IC1=-IC1
5229 IC2=-IC2
5230 ICH1=-ICH1
5231 ENDIF
5232
5233 ELSEIF(ICZ.EQ.3)THEN
5234 IC1=ICH-3*IS
5235 IC2=-IS*INT(1.5+PSRAN(B10))
5236 ICH1=3*IS-IC2
5237 ELSEIF(ICZ.EQ.4)THEN
5238 IC1=ICH-9*IS
5239 IC2=IS*INT(1.5+PSRAN(B10))
5240 ICH1=9*IS-IC2
5241 ELSEIF(ICZ.EQ.5)THEN
5242 IC1=IS*INT(1.5+PSRAN(B10))
5243 IC2=-IC1
5244 ICH1=ICH
5245 ENDIF
5246
5247 ICH=ICH1
5248 IF(DEBUG.GE.3)WRITE (MONIOU,202)IC1,IC2,ICH
5249202 FORMAT(2X,'IXXDEF-END: PARTON FLAVORS IC1=',I2,' IC2=',I2,
5250 * 'NEW HADRON TYPE ICH=',I2)
5251 RETURN
5252 END
5253C=======================================================================
5254
5255 FUNCTION IXXSON(NS,AW,G)
5256c Poisson distribution:
5257c AW - average value,
5258c NS-1 - maximal allowed value,
5259c G - random number
5260c-----------------------------------------------------------------------
5261 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5262 INTEGER DEBUG
5263 COMMON /AREA43/ MONIOU
5264 COMMON /DEBUG/ DEBUG
5265 IF(DEBUG.GE.2)WRITE (MONIOU,201)NS-1,AW,G
5266201 FORMAT(2X,'IXXSON - POISSON DITR.: AVERAGE AW=',E10.3,
5267 * ' MAXIMAL VALUE NS=',I2,' RANDOM NUMBER G=',E10.3)
5268 W=EXP(-AW)
5269 SUMM=W
5270 DO 1 I=1,NS
5271 IF(G.LT.SUMM)GOTO 2
5272 W=W*AW/I
52731 SUMM=SUMM+W
52742 IXXSON=I-1
5275 IF(DEBUG.GE.3)WRITE (MONIOU,202)IXXSON
5276202 FORMAT(2X,'IXXSON=',I2)
5277 RETURN
5278 END
5279C=======================================================================
5280
5281 SUBROUTINE XXAINI(E0N,ICP0,IAP,IAT)
5282c Additional initialization procedure
5283c-----------------------------------------------------------------------
5284 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5285 INTEGER DEBUG
5286******************************************************
5287 DIMENSION WK(3),WA(3)
5288******************************************************
5289 COMMON /AREA1/ IA(2),ICZ,ICP
5290 COMMON /AREA2/ S,Y0,WP0,WM0
5291 COMMON /AREA4/ EY0(3)
5292 COMMON /AREA5/ RD(2),CR1(2),CR2(2),CR3(2)
5293 COMMON /AREA6/ PI,BM,AM
5294 COMMON /AREA7/ RP1
5295 COMMON /AREA10/ STMASS,AM0,AMN,AMK,AMC,AMLAMC,AMLAM,AMETA
5296 COMMON /AREA15/ FP(5),RQ(5),CD(5)
5297 COMMON /AREA17/ DEL,RS,RS0,FS,ALFP,RR,SH,DELH
5298 COMMON /AREA22/ SJV,FJS(5,3)
5299 COMMON /AREA35/ SJV0(10,5),FJS0(10,5,15)
5300 COMMON /AREA43/ MONIOU
5301******************************************************
5302 COMMON /AREA44/ GZ(10,5,4)
5303 COMMON /AREA45/ GDT
5304******************************************************
5305 COMMON /DEBUG/ DEBUG
5306
5307 IF(DEBUG.GE.1)WRITE (MONIOU,201)ICP0,IAP,IAT,E0N
5308201 FORMAT(2X,'XXAINI - MINIINITIALIZATION: PARTICLE TYPE ICP0=',
5309 * I1,2X,'PROJECTILE MASS NUMBER IAP=',I2/4X,
5310 * 'TARGET MASS NUMBER IAT=',I2,' INTERACTION ENERGY E0N=',E10.3)
5311 ICP=ICP0
5312 IA(1)=IAP
5313 IA(2)=IAT
5314c ICZ - auxiliary type for the primary particle (1- pion, 2 - nucleon, 3 - kaon,
5315c 4 - D-meson, 5 - Lambda_C)
5316 IF(IABS(ICP).LT.6)THEN
5317 ICZ=IABS(ICP)/2+1
5318 ELSE
5319 ICZ=(IABS(ICP)+1)/2
5320 ENDIF
5321
5322c Energy dependent factors:
5323c WP0, WM0 - initial light cone momenta for the interaction (E+-p)
5324 S=2.D0*E0N*AMN
5325 WP0=DSQRT(S)
5326 WM0=WP0
5327c Y0 - total rapidity range for the interaction
5328 Y0=DLOG(S)
5329c RS - soft pomeron elastic scattering slope (lambda_ab)
5330 RS=RQ(ICZ)+ALFP*Y0
5331c RS0 - initial slope (sum of the pomeron-hadron vertices slopes squared - R_ab)
5332 RS0=RQ(ICZ)
5333c FS - factor for pomeron eikonal calculation (gamma_ab * s**del /lambda_ab * C_ab
5334 FS=FP(ICZ)*EXP(Y0*DEL)/RS*CD(ICZ)
5335c RP1 - factor for the impact parameter dependence of the eikonal ( in fm>2 )
5336 RP1=RS*4.D0*.0391D0/AM**2
5337
5338 EY0(2)=1.D0
5339 EY0(3)=1.D0
5340 EY0(1)=DSQRT(AMN/E0N/2.D0)
5341
5342c-------------------------------------------------
5343c Nuclear radii and weights for nuclear configurations simulation - procedure GEA
5344 DO 1 I=1,2
5345c RD(I) - Wood-Saxon density radius (fit to the data of Murthy et al.)
5346 RD(I)=0.7D0*FLOAT(IA(I))**.446/AM
5347 CR1(I)=1.D0+3.D0/RD(I)+6.D0/RD(I)**2+6.D0/RD(I)**3
5348 CR2(I)=3.D0/RD(I)
5349 CR3(I)=3.D0/RD(I)+6.D0/RD(I)**2
5350 IF(IA(I).LT.10.AND.IA(I).NE.1)THEN
5351c RD(I) - gaussian density radius (for light nucleus)
5352 RD(I)=.9D0*FLOAT(IA(I))**.3333/AM
5353 IF(IA(I).EQ.2)RD(I)=3.16D0
5354c RD -> RD * A / (A-1) - to use Van Hove simulation method - procedure GEA
5355 RD(I)=RD(I)*DSQRT(2.D0*IA(I)/(IA(I)-1.))
5356 ENDIF
53571 CONTINUE
5358
5359 GDT=0.D0
5360c-------------------------------------------------
5361c Impact parameter cutoff setting
5362c-------------------------------------------------
5363 IF(IA(1).NE.1)THEN
5364c Primary nucleus:
5365c Impact parameter cutoff value ( only impact parameters less than BM are
5366c simulated; probability to have larger impact parameter is less than 1% )
5367 BM=RD(1)+RD(2)+5.D0
5368 ELSE
5369c Hadron-nucleus interaction
5370c BM - impact parameter cutoff value
5371 BM=RD(2)+5.D0
5372 ENDIF
5373
5374 YE=DLOG10(E0N)
5375 IF(YE.LT.1.D0)YE=1.D0
5376 JE=INT(YE)
5377 IF(JE.GT.8)JE=8
5378
5379******************************************************
5380 WK(2)=YE-JE
5381 WK(3)=WK(2)*(WK(2)-1.D0)*.5D0
5382 WK(1)=1.D0-WK(2)+WK(3)
5383 WK(2)=WK(2)-2.D0*WK(3)
5384
5385 SJV=SJV0(JE,ICZ)*WK(1)+SJV0(JE+1,ICZ)*WK(2)+SJV0(JE+2,ICZ)*WK(3)
5386
5387 DO 2 I=1,5
5388 DO 2 M=1,3
5389 M1=M+3*(ICZ-1)
53902 FJS(I,M)=FJS0(JE,I,M1)*WK(1)+FJS0(JE+1,I,M1)*WK(2)+
5391 *FJS0(JE+2,I,M1)*WK(3)
5392
5393 GDT=0.D0
5394 IF(IA(1).EQ.1)THEN
5395 YA=IA(2)
5396 YA=DLOG(YA)/1.38629D0+1.D0
5397 JA=MIN(INT(YA),2)
5398 WA(2)=YA-JA
5399 WA(3)=WA(2)*(WA(2)-1.D0)*.5D0
5400 WA(1)=1.D0-WA(2)+WA(3)
5401 WA(2)=WA(2)-2.D0*WA(3)
5402 DO 3 I=1,3
5403 DO 3 M=1,3
54043 GDT=GDT+GZ(JE+I-1,ICZ,JA+M-1)*WK(I)*WA(M)
5405 ENDIF
5406c write (*,*)'gdt=',gdt
5407******************************************************
5408
5409 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5410202 FORMAT(2X,'XXAINI - END')
5411 RETURN
5412 END
5413C=======================================================================
5414
5415 SUBROUTINE XXASET
5416c Particular model parameters setting
5417c-----------------------------------------------------------------------
5418 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5419 INTEGER DEBUG
5420 CHARACTER *2 TYQ
5421 COMMON /AREA3/ RMIN,EMAX,EEV
5422 COMMON /AREA6/ PI,BM,AM
5423 COMMON /AREA8/ WWM,BE(4),DC(5),DETA,ALMPT
5424 COMMON /AREA10/ STMASS,AM0,AMN,AMK,AMC,AMLAMC,AMLAM,AMETA
5425 COMMON /AREA11/ B10
5426 COMMON /AREA20/ WPPP
5427 COMMON /AREA21/ DMMIN(5)
5428 COMMON /AREA28/ ARR(4)
5429 COMMON /AREA40/ JDIFR
5430 COMMON /AREA42/ TYQ(15)
5431 COMMON /AREA43/ MONIOU
5432 COMMON /DEBUG/ DEBUG
5433
5434 IF(DEBUG.GE.1)WRITE (MONIOU,201)
5435201 FORMAT(2X,'XXASET - HADRONIZATION PARAMETERS SETTING')
5436c Regge intercepts for the uu~, qqq~q~, us~, uc~ trajectories
5437 ARR(1)=0.5D0
5438 ARR(2)=-.5D0
5439 ARR(3)=0.D0
5440 ARR(4)=-2.D0
5441c WPPP - Triple pomeron interaction probability (for two cut pomerons and cut
5442c between them)
5443 WPPP=0.4d0
5444c WPPP=0.d0
5445c JDIFR - flag for the low mass diffraction (for JDIFR=0 not considered)
5446 JDIFR=1
5447
5448c-------------------------------------------------
5449c Parameters for the soft fragmentation:
5450c DC(i) - relative probabilities for udu~d~(i=1), ss~(i=2), cc~(i=3)-pairs creation
5451c from the vacuum for the quark (u,d,u~,d~) fragmentation;
5452c ss~(i=4), cc~(i=5) - for the diquark (ud, u~d~) fragmentation
5453 DC(1)=.06D0
5454 DC(2)=.10D0
5455* DC(3)=.0003D0 ! To switch off charmed particles set to 0.000
5456 DC(3)=.000D0
5457 DC(4)=.36D0
5458* DC(5)=.01D0 ! To switch off charmed particles set to 0.000
5459 DC(5)=.0D0
5460cc DETA - ratio of etas production density to all pions production density (1/9)
5461 DETA=.11111D0
5462c WWM defines mass threshold for string to decay into three or more hadrons
5463c ( ajustable parameter for string fragmentation )
5464 WWM=.53D0
5465c BE(i) - parameter for Pt distribution (exponential) for uu~(dd~), ss~, qqq~q~,
5466c cc~ pairs respectively (for the soft fragmentation)
5467 BE(1)=.22D0
5468 BE(2)=.35D0
5469 BE(3)=.29D0
5470 BE(4)=.40D0
5471c ALMPT - parameter for the fragmentation functions (soft ones):
5472c ALMPT = 1 + 2 * alfa_R * <pt**2> (Kaidalov proposed 0.5 value for ALMPT-1,
5473c Sov.J.Nucl.Phys.,1987))
5474 ALMPT=1.7D0
5475
5476c-------------------------------------------------
5477c Parameters for nuclear spectator part fragmentation:
5478c RMIN - coupling radius squared (fm>2),
5479c EMAX - relative critical energy ( divided per mean excitation energy (~12.5 Mev)),
5480c EEV - relative evaporation energy ( divided per mean excitation energy (~12.5 Mev))
5481 RMIN=3.35D0
5482 EMAX=.11D0
5483 EEV=.25D0
5484
5485c-------------------------------------------------
5486c DMMIN(i) - minimal diffractive mass for low-mass diffraction for pion, nucleon,
5487c kaon, D-meson, Lambda_C corresp.
5488 DMMIN(1)=.76D0
5489 DMMIN(2)=1.24D0
5490 DMMIN(3)=.89D0
5491 DMMIN(4)=2.01D0
5492 DMMIN(5)=2.45D0
5493c Proton, kaon, pion, D-meson, Lambda, Lambda_C, eta masses
5494 AMN=.939D0
5495 AMK=.496D0
5496 AM0=.14D0
5497 AMC=1.868D0
5498 AMLAM=1.116D0
5499 AMLAMC=2.27D0
5500 AMETA=.548D0
5501
5502c-------------------------------------------------
5503c B10 - initial value of the pseudorandom number,
5504c PI - pi-number
5505c AM - diffusive radius for the Saxon-Wood nuclear density parametrization
5506 B10=.43876194D0
5507 PI=3.1416D0
5508 AM=.523D0
5509
5510C STMASS - minimal string mass to produce secondary particles
5511 STMASS=4.D0*AM0**2
5512c Here and below all radii, distances and so on are divided by AM.
5513 RMIN=RMIN/AM**2
5514
5515 TYQ(1)='DD'
5516 TYQ(2)='UU'
5517 TYQ(3)='C '
5518 TYQ(4)='S '
5519 TYQ(5)='UD '
5520 TYQ(6)='D '
5521 TYQ(7)='U '
5522 TYQ(8)='G '
5523 TYQ(9)='u '
5524 TYQ(10)='d '
5525 TYQ(11)='ud'
5526 TYQ(12)='s '
5527 TYQ(13)='c '
5528 TYQ(14)='uu'
5529 TYQ(15)='dd'
5530 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5531202 FORMAT(2X,'XXASET - END')
5532 RETURN
5533 END
5534C=======================================================================
5535
5536 SUBROUTINE XXDDFR(WP0,WM0,ICP,ICT)
5537c Double diffractive dissociation
5538c-----------------------------------------------------------------------
5539 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5540 INTEGER DEBUG
5541 DIMENSION EP3(4),EP1(4),EP2(4),EY(3)
5542 COMMON /AREA1/ IA(2),ICZ,ICP0
5543 COMMON /AREA2/ S,Y0,WP00,WM00
5544 COMMON /AREA8/ WWM,BE(4),DC(5),DETA,ALMPT
5545 COMMON /AREA10/ STMASS,AM(7)
5546 COMMON /AREA11/ B10
5547 COMMON /AREA21/ DMMIN(5)
5548 COMMON /AREA43/ MONIOU
5549 COMMON /DEBUG/ DEBUG
5550 SAVE
5551
5552 IF(DEBUG.GE.2)WRITE (MONIOU,201)ICP,ICT,WP0,WM0
5553201 FORMAT(2X,'XXDDFR - LEADING CLUSTERS HADRONIZATION:'
5554 * /4X,'CLUSTER TYPES ICP=',I2,2X,
5555 * 'ICT=',I2/4X,'AVAILABLE LIGHT CONE MOMENTA: WP0=',E10.3,
5556 * ' WM0=',E10.3)
5557 DO 100 I=1,3
5558100 EY(I)=1.D0
5559
5560 SD0=WP0*WM0
5561 IF(SD0.LT.0.D0)SD0=0.D0
5562 DDMIN1=DMMIN(ICZ)
5563 DDMIN2=DMMIN(2)
5564 DDMAX1=MIN(5.D0,DSQRT(SD0)-DDMIN2)
5565
5566 IF(DDMAX1.LT.DDMIN1)THEN
5567c Registration of too slow "leading" hadron if its energy is insufficient for
5568c diffractive exhitation
5569 IF(DSQRT(SD0).LT.AM(ICZ)+AM(2))THEN
5570 IF(WP0.GT.0.D0.AND.(AM(ICZ)+AM(2))**2/WP0.LT..5D0*WM00)THEN
5571 SD0=(AM(ICZ)+AM(2))**2
5572 WM0=SD0/WP0
5573 ELSE
5574 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5575 RETURN
5576 ENDIF
5577 ENDIF
5578
5579 EP3(3)=0.D0
5580 EP3(4)=0.D0
5581 XW=XXTWDEC(SD0,AM(ICZ)**2,AM(2)**2)
5582 WP1=XW*WP0
5583 WM1=AM(ICZ)**2/WP1
5584 EP3(1)=.5D0*(WP1+WM1)
5585 EP3(2)=.5D0*(WP1-WM1)
5586 CALL XXREG(EP3,ICP)
5587 WM2=WM0-WM1
5588 WP2=AM(2)**2/WM2
5589 EP3(1)=.5D0*(WP2+WM2)
5590 EP3(2)=.5D0*(WP2-WM2)
5591 CALL XXREG(EP3,ICT)
5592 WP0=0.D0
5593 WM0=0.D0
5594 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5595 RETURN
5596 ENDIF
5597
5598 DMASS1=(DDMIN1/(1.D0-PSRAN(B10)*(1.D0-DDMIN1/DDMAX1)))**2
5599 DDMAX2=MIN(5.D0,DSQRT(SD0)-DSQRT(DMASS1))
5600 DMASS2=(DDMIN2/(1.D0-PSRAN(B10)*(1.D0-DDMIN2/DDMAX2)))**2
5601
5602 WPD1=WP0*XXTWDEC(SD0,DMASS1,DMASS2)
5603 WMD1=DMASS1/WPD1
5604 WMD2=WM0-WMD1
5605 WPD2=DMASS2/WMD2
5606
5607 IF(ICP.NE.0)IS=IABS(ICP)/ICP
5608 IF(ICZ.EQ.5)THEN
5609 ICH1=ICP
5610 ICH2=0
5611 AMH1=AM(5)**2
5612 AMH2=AM(1)**2
5613
5614 PTMAX=PSLAM(DMASS1,AMH1,AMH2)
5615 IF(PTMAX.LT.0.)PTMAX=0.
5616 IF(PTMAX.LT.BE(4)**2)THEN
56171 PTI=PTMAX*PSRAN(B10)
5618 IF(PSRAN(B10).GT.EXP(-DSQRT(PTI)/BE(4)))GOTO 1
5619 ELSE
56202 PTI=(BE(4)*DLOG(PSRAN(B10)*PSRAN(B10)))**2
5621 IF(PTI.GT.PTMAX)GOTO 2
5622 ENDIF
5623 AMT1=AMH1+PTI
5624 AMT2=AMH2+PTI
5625 Z=XXTWDEC(DMASS1,AMT1,AMT2)
5626 WP1=WPD1*Z
5627 WM1=AMT1/WP1
5628 EP3(1)=.5D0*(WP1+WM1)
5629 EP3(2)=.5D0*(WP1-WM1)
5630 PT=DSQRT(PTI)
5631 CALL PSCS(C,S)
5632 EP3(3)=PT*C
5633 EP3(4)=PT*S
5634 CALL XXREG(EP3,ICH1)
5635
5636 WP1=WPD1*(1.D0-Z)
5637 WM1=AMT2/WP1
5638 EP3(1)=.5D0*(WP1+WM1)
5639 EP3(2)=.5D0*(WP1-WM1)
5640 EP3(3)=-PT*C
5641 EP3(4)=-PT*S
5642 CALL XXREG(EP3,ICH2)
5643 GOTO 3
5644 ENDIF
5645
5646 IF(ICZ.EQ.1)THEN
5647 IF(ICP.NE.0)THEN
5648 IC1=ICP*(1-3*INT(.5D0+PSRAN(B10)))
5649 IC2=-ICP-IC1
5650 ELSE
5651 IC1=INT(1.5D0+PSRAN(B10))*(2*INT(.5D0+PSRAN(B10))-1)
5652 IC2=-IC1
5653 ENDIF
5654 ELSEIF(ICZ.EQ.2)THEN
5655 IF(PSRAN(B10).GT..33333D0)THEN
5656 IC1=3*IS
5657 IC2=ICP-IS
5658 ELSE
5659 IC1=ICP+4*IS
5660 IC2=4*IS-ICP
5661 ENDIF
5662 ELSEIF(ICZ.EQ.3)THEN
5663 IC1=-4*IS
5664 IC2=ICP-3*IS
5665 ELSEIF(ICZ.EQ.4)THEN
5666 IC1=5*IS
5667 IC2=ICP-9*IS
5668 ENDIF
5669 CALL XXGENER(WPD1,WMD1,EY,0.D0,1.D0,0.D0,1.D0,IC1,IC2)
5670
56713 CONTINUE
5672 IS=IABS(ICT)/ICT
5673 IF(PSRAN(B10).GT..33333D0)THEN
5674 IC1=3*IS
5675 IC2=ICT-IS
5676 ELSE
5677 IC1=ICT+4*IS
5678 IC2=4*IS-ICT
5679 ENDIF
5680 CALL XXGENER(WPD2,WMD2,EY,0.D0,1.D0,0.D0,1.D0,IC2,IC1)
5681 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5682202 FORMAT(2X,'XXDDFR - END')
5683 RETURN
5684 END
5685C=======================================================================
5686
5687 SUBROUTINE XXDEC2(EP,EP1,EP2,WW,A,B)
5688c Two particle decay
5689c-----------------------------------------------------------------------
5690 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5691 INTEGER DEBUG
5692 dimension ep(4),ep1(4),ep2(4),EY(3)
5693 COMMON /AREA43/ MONIOU
5694 COMMON /DEBUG/ DEBUG
5695 COMMON /AREA11/ B10
5696 IF(DEBUG.GE.2)WRITE (MONIOU,201)
5697201 FORMAT(2X,'XXDEC2 - TWO PARTICLE DECAY')
5698
5699 PL=PSLAM(WW,A,B)
5700 EP1(1)=DSQRT(PL+A)
5701 EP2(1)=DSQRT(PL+B)
5702 PL=DSQRT(PL)
5703 COSZ=2.D0*PSRAN(B10)-1.D0
5704 PT=PL*DSQRT(1.D0-COSZ**2)
5705 EP1(2)=PL*COSZ
5706 CALL PSCS(C,S)
5707 EP1(3)=PT*C
5708 EP1(4)=PT*S
5709 do 1 I=2,4
57101 EP2(I)=-EP1(I)
5711 CALL PSDEFTR(WW,EP,EY)
5712 CALL PSTRANS(EP1,EY)
5713 CALL PSTRANS(EP2,EY)
5714 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5715202 FORMAT(2X,'XXDEC2 - END')
5716 RETURN
5717 END
5718C=======================================================================
5719
5720 SUBROUTINE XXDEC3(EP,EP1,EP2,EP3,SWW,AM1,AM2,AM3)
5721
5722c-----------------------------------------------------------------------
5723 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5724 INTEGER DEBUG
5725 DIMENSION EP(4),EP1(4),EP2(4),EP3(4),EPT(4),EY(3)
5726 COMMON/AREA11/B10
5727 COMMON /AREA43/ MONIOU
5728 COMMON /DEBUG/ DEBUG
5729
5730 IF(DEBUG.GE.2)WRITE (MONIOU,201)
5731201 FORMAT(2X,'XXDEC3 - THREE PARTICLE DECAY')
5732 AM12=AM1**2
5733 AM23=(AM2+AM3)**2
5734 AM32=(AM2-AM3)**2
5735 S23MAX=(SWW-AM1)**2
5736 EMAX=.25D0*(SWW+(AM12-AM23)/SWW)**2
5737 GB0=DSQRT((EMAX-AM12)/EMAX*(1.D0-AM23/S23MAX)
5738 * *(1.D0-AM32/S23MAX))
57391 P1=PSRAN(B10)*(EMAX-AM12)
5740 E1=DSQRT(P1+AM12)
5741 S23=SWW**2+AM12-2.D0*E1*SWW
5742 GB=DSQRT(P1*(1.D0-AM23/S23)*(1.D0-AM32/S23))/E1/GB0
5743 IF(PSRAN(B10).GT.GB)GOTO 1
5744
5745 P1=DSQRT(P1)
5746 EP1(1)=E1
5747 COSZ=2.D0*PSRAN(B10)-1.D0
5748 PT=P1*DSQRT(1.D0-COSZ**2)
5749 EP1(2)=P1*COSZ
5750 CALL PSCS(C,S)
5751 EP1(3)=PT*C
5752 EP1(4)=PT*S
5753 do 2 I=2,4
57542 EPT(I)=-EP1(I)
5755 EPT(1)=SWW-EP1(1)
5756 CALL PSDEFTR(SWW**2,EP,EY)
5757 CALL PSTRANS(EP1,EY)
5758 CALL PSTRANS(EPT,EY)
5759
5760 CALL XXDEC2(EPT,EP2,EP3,S23,AM2**2,AM3**2)
5761 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5762202 FORMAT(2X,'XXDEC3 - END')
5763 RETURN
5764 END
5765C=======================================================================
5766
5767 SUBROUTINE XXDPR(WP0,WM0,ICP,ICT,LQ2)
5768c Projectile hadron dissociation
5769c Leading hadronic state hadronization
5770c-----------------------------------------------------------------------
5771 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5772 INTEGER DEBUG
5773 DIMENSION EP3(4),EP1(4),EP2(4),EY(3)
5774 COMMON /AREA1/ IA(2),ICZ,ICP0
5775 COMMON /AREA2/ S,Y0,WP00,WM00
5776 COMMON /AREA8/ WWM,BE(4),DC(5),DETA,ALMPT
5777 COMMON /AREA10/ STMASS,AM(7)
5778 COMMON /AREA11/ B10
5779 COMMON /AREA17/ DEL,RS,RS0,FS,ALFP,RR,SH,DELH
5780 COMMON /AREA21/ DMMIN(5)
5781 COMMON /AREA43/ MONIOU
5782 COMMON /DEBUG/ DEBUG
5783 SAVE
5784
5785 IF(DEBUG.GE.2)WRITE (MONIOU,201)ICP,ICT,WP0,WM0
5786201 FORMAT(2X,'XXDPR - LEADING (PROJECTILE) CLUSTER HADRONIZATION:'
5787 * /4X,'CLUSTER TYPE ICP=',I2,2X,'TARGET TYPE ',
5788 * 'ICT=',I2/4X,'AVAILABLE LIGHT CONE MOMENTA: WP0=',E10.3,
5789 * ' WM0=',E10.3)
5790 DO 100 I=1,3
5791100 EY(I)=1.D0
5792
5793 SD0=WP0*WM0
5794 IF(SD0.LT.0.D0)SD0=0.D0
5795 DDMAX=MIN(5.D0,DSQRT(SD0)-AM(2))
5796 DDMIN=DMMIN(ICZ)
5797
5798 IF(DDMAX.LT.DDMIN)THEN
5799c Registration of too slow "leading" hadron if its energy is insufficient for
5800c diffractive exhitation
5801 EP3(3)=0.D0
5802 EP3(4)=0.D0
5803
5804 IF(LQ2.NE.0)THEN
5805 WPI=WP0
5806 IF(AM(ICZ)**2.GT.WPI*WM0)THEN
5807 IF(WPI.GT.0.D0.AND.AM(ICZ)**2/WPI.LT..5D0*WM00)THEN
5808 WMI=AM(ICZ)**2/WPI
5809 WM0=WMI
5810 ELSE
5811 RETURN
5812 ENDIF
5813 ENDIF
5814 WM0=WM0-WMI
5815 WP0=0.D0
5816 EP3(1)=.5D0*(WPI+WMI)
5817 EP3(2)=.5D0*(WPI-WMI)
5818 CALL XXREG(EP3,ICP)
5819 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5820 RETURN
5821 ELSE
5822
5823 IF(DSQRT(SD0).LT.AM(ICZ)+AM(2))THEN
5824 IF(WP0.GT.0.D0.AND.(AM(ICZ)+AM(2))**2/WP0.LT..5D0*WM00)
5825 * THEN
5826 SD0=(AM(ICZ)+AM(2))**2
5827 WM0=SD0/WP0
5828 ELSE
5829 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5830 RETURN
5831 ENDIF
5832 ENDIF
5833 XW=XXTWDEC(SD0,AM(ICZ)**2,AM(2)**2)
5834 WP1=XW*WP0
5835 WM1=AM(ICZ)**2/WP1
5836 EP3(1)=.5D0*(WP1+WM1)
5837 EP3(2)=.5D0*(WP1-WM1)
5838 CALL XXREG(EP3,ICP)
5839 WM2=WM0-WM1
5840 WP2=AM(2)**2/WM2
5841 EP3(1)=.5D0*(WP2+WM2)
5842 EP3(2)=.5D0*(WP2-WM2)
5843 CALL XXREG(EP3,ICT)
5844 WP0=0.D0
5845 WM0=0.D0
5846 ENDIF
5847 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5848 RETURN
5849 ENDIF
5850
5851 IF(ICP.NE.0)IS=IABS(ICP)/ICP
5852
5853 DMASS=DDMIN**2/(1.D0-PSRAN(B10)*(1.D0-(DDMIN/DDMAX)))**2
5854
5855 IF(LQ2.NE.0)THEN
5856 WPD=WP0
5857 WMD=DMASS/WPD
5858 WM0=WM0-WMD
5859 WP0=0.D0
5860 ELSE
5861 IF(ICZ.EQ.5)THEN
5862 WPD=WP0*XXTWDEC(SD0,DMASS,AM(2)**2)
5863 WMD=DMASS/WPD
5864 WM2=WM0-WMD
5865 WP2=AM(2)**2/WM2
5866 EP3(1)=.5D0*(WP2+WM2)
5867 EP3(2)=.5D0*(WP2-WM2)
5868 EP3(3)=0.D0
5869 EP3(4)=0.D0
5870 CALL XXREG(EP3,ICT)
5871 ELSE
5872 PTMAX=PSLAM(SD0,DMASS,AM(2)**2)
5873 IF(PTMAX.LT.0.)PTMAX=0.
5874 PTI=-1.D0/RS*DLOG(1.D0-PSRAN(B10)*(1.D0-EXP(-RS*PTMAX)))
5875
5876 AMT1=DMASS+PTI
5877 AMT2=AM(2)**2+PTI
5878 WPD=WP0*XXTWDEC(SD0,AMT1,AMT2)
5879 WMD=AMT1/WPD
5880 WM2=WM0-WMD
5881 WP2=AMT2/WM2
5882 PT=DSQRT(PTI)
5883 CALL PSCS(CCOS,SSIN)
5884 EP3(3)=PT*CCOS
5885 EP3(4)=PT*SSIN
5886 EP3(1)=.5D0*(WP2+WM2)
5887 EP3(2)=.5D0*(WP2-WM2)
5888 CALL XXREG(EP3,ICT)
5889 EP3(3)=-EP3(3)
5890 EP3(4)=-EP3(4)
5891 EP3(1)=.5D0*(WPD+WMD)
5892 EP3(2)=.5D0*(WPD-WMD)
5893 CALL PSDEFTR(DMASS,EP3,EY)
5894 WPD=DSQRT(DMASS)
5895 WMD=WPD
5896 ENDIF
5897 WP0=0.D0
5898 WM0=0.D0
5899 ENDIF
5900
5901 IF(ICZ.EQ.5)THEN
5902 ICH1=ICP
5903 ICH2=0
5904 AMH1=AM(5)**2
5905 AMH2=AM(1)**2
5906
5907 PTMAX=PSLAM(DMASS,AMH1,AMH2)
5908 IF(PTMAX.LT.0.)PTMAX=0.
5909 IF(PTMAX.LT.BE(4)**2)THEN
59101 PTI=PTMAX*PSRAN(B10)
5911 IF(PSRAN(B10).GT.EXP(-DSQRT(PTI)/BE(4)))GOTO 1
5912 ELSE
59132 PTI=(BE(4)*DLOG(PSRAN(B10)*PSRAN(B10)))**2
5914 IF(PTI.GT.PTMAX)GOTO 2
5915 ENDIF
5916 AMT1=AMH1+PTI
5917 AMT2=AMH2+PTI
5918 Z=XXTWDEC(DMASS,AMT1,AMT2)
5919 WP1=WPD*Z
5920 WM1=AMT1/WP1
5921 EP3(1)=.5D0*(WP1+WM1)
5922 EP3(2)=.5D0*(WP1-WM1)
5923 PT=DSQRT(PTI)
5924 CALL PSCS(C,S)
5925 EP3(3)=PT*C
5926 EP3(4)=PT*S
5927 CALL XXREG(EP3,ICH1)
5928
5929 WP1=WPD*(1.D0-Z)
5930 WM1=AMT2/WP1
5931 EP3(1)=.5D0*(WP1+WM1)
5932 EP3(2)=.5D0*(WP1-WM1)
5933 EP3(3)=-PT*C
5934 EP3(4)=-PT*S
5935 CALL XXREG(EP3,ICH2)
5936 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5937 RETURN
5938 ENDIF
5939
5940 IF(ICZ.EQ.1)THEN
5941 IF(ICP.NE.0)THEN
5942 IC1=ICP*(1-3*INT(.5D0+PSRAN(B10)))
5943 IC2=-ICP-IC1
5944 ELSE
5945 IC1=INT(1.5D0+PSRAN(B10))*(2*INT(.5D0+PSRAN(B10))-1)
5946 IC2=-IC1
5947 ENDIF
5948 ELSEIF(ICZ.EQ.2)THEN
5949 IF(PSRAN(B10).GT..33333D0)THEN
5950 IC1=3*IS
5951 IC2=ICP-IS
5952 ELSE
5953 IC1=ICP+4*IS
5954 IC2=4*IS-ICP
5955 ENDIF
5956 ELSEIF(ICZ.EQ.3)THEN
5957 IC1=-4*IS
5958 IC2=ICP-3*IS
5959 ELSEIF(ICZ.EQ.4)THEN
5960 IC1=5*IS
5961 IC2=ICP-9*IS
5962 ENDIF
5963 CALL XXGENER(WPD,WMD,EY,0.D0,1.D0,0.D0,1.D0,
5964 * IC1,IC2)
5965 IF(DEBUG.GE.3)WRITE (MONIOU,202)
5966202 FORMAT(2X,'XXDPR - END')
5967 RETURN
5968 END
5969C=======================================================================
5970
5971 SUBROUTINE XXDTG(WP0,WM0,ICP,ICT,LQ1)
5972c Target nucleon dissociation
5973c Leading hadronic state hadronization
5974c-----------------------------------------------------------------------
5975 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5976 INTEGER DEBUG
5977 DIMENSION EP3(4),EY(3)
5978 COMMON /AREA1/ IA(2),ICZ,ICP0
5979 COMMON /AREA2/ S,Y0,WP00,WM00
5980 COMMON /AREA10/ STMASS,AM(7)
5981 COMMON /AREA11/ B10
5982 COMMON /AREA17/ DEL,RS,RS0,FS,ALFP,RR,SH,DELH
5983 COMMON /AREA21/ DMMIN(5)
5984 COMMON /AREA43/ MONIOU
5985 COMMON /DEBUG/ DEBUG
5986 SAVE
5987
5988 IF(DEBUG.GE.2)WRITE (MONIOU,201)ICT,ICP,WP0,WM0
5989201 FORMAT(2X,'XXDTG - LEADING (TARGET) CLUSTER HADRONIZATION:'
5990 * /4X,'CLUSTER TYPE ICT=',I2,2X,'PROJECTILE TYPE ',
5991 * 'ICP=',I2/4X,'AVAILABLE LIGHT CONE MOMENTA: WP0=',E10.3,
5992 * ' WM0=',E10.3)
5993 DO 100 I=1,3
5994100 EY(I)=1.D0
5995
5996 SD0=WP0*WM0
5997 IF(SD0.LT.0.D0)SD0=0.D0
5998 DDMIN=DMMIN(2)
5999 DDMAX=MIN(5.D0,DSQRT(SD0)-AM(ICZ))
6000
6001 IF(DDMAX.LT.DDMIN)THEN
6002c Registration of too slow "leading" hadron if its energy is insufficient for
6003c diffractive exhitation
6004 EP3(3)=0.D0
6005 EP3(4)=0.D0
6006
6007 IF(LQ1.NE.0)THEN
6008 WMI=WM0
6009 IF( WP0.LE.0.D0.OR.AM(2)**2.GT.WMI*WP0)RETURN
6010 WPI=AM(2)**2/WMI
6011 WP0=WP0-WPI
6012 WM0=0.D0
6013 EP3(1)=.5D0*(WPI+WMI)
6014 EP3(2)=.5D0*(WPI-WMI)
6015 CALL XXREG(EP3,ICT)
6016 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6017 RETURN
6018 ELSE
6019
6020 IF(DSQRT(SD0).LT.AM(ICZ)+AM(2))THEN
6021 IF(WP0.GT.0.D0.AND.(AM(ICZ)+AM(2))**2/WP0.LT..5D0*WM00)
6022 * THEN
6023 SD0=(AM(ICZ)+AM(2))**2
6024 WM0=SD0/WP0
6025 ELSE
6026 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6027 RETURN
6028 ENDIF
6029 ENDIF
6030 XW=XXTWDEC(SD0,AM(ICZ)**2,AM(2)**2)
6031 WP1=XW*WP0
6032 WM1=AM(ICZ)**2/WP1
6033 EP3(1)=.5D0*(WP1+WM1)
6034 EP3(2)=.5D0*(WP1-WM1)
6035 CALL XXREG(EP3,ICP)
6036 WM2=WM0-WM1
6037 WP2=AM(2)**2/WM2
6038 EP3(1)=.5D0*(WP2+WM2)
6039 EP3(2)=.5D0*(WP2-WM2)
6040 CALL XXREG(EP3,ICT)
6041 WP0=0.D0
6042 WM0=0.D0
6043 ENDIF
6044 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6045 RETURN
6046 ENDIF
6047
6048 DMASS=(DDMIN/(1.D0-PSRAN(B10)*(1.D0-DDMIN/DDMAX)))**2
6049 IF(LQ1.NE.0)THEN
6050 WMD=WM0
6051 WPD=DMASS/WMD
6052 WP0=WP0-WPD
6053 WM0=0.D0
6054 ELSE
6055 PTMAX=PSLAM(SD0,DMASS,AM(ICZ)**2)
6056 IF(PTMAX.LT.0.)PTMAX=0.
6057 PTI=-1.D0/RS*DLOG(1.D0-PSRAN(B10)*(1.D0-EXP(-RS*PTMAX)))
6058
6059 AMT1=DMASS+PTI
6060 AMT2=AM(ICZ)**2+PTI
6061 WMD=WM0*XXTWDEC(SD0,AMT1,AMT2)
6062 WPD=AMT1/WMD
6063 WP2=WP0-WPD
6064 WM2=AMT2/WP2
6065 PT=DSQRT(PTI)
6066 CALL PSCS(CCOS,SSIN)
6067 EP3(3)=PT*CCOS
6068 EP3(4)=PT*SSIN
6069 EP3(1)=.5D0*(WP2+WM2)
6070 EP3(2)=.5D0*(WP2-WM2)
6071 CALL XXREG(EP3,ICP)
6072 EP3(3)=-EP3(3)
6073 EP3(4)=-EP3(4)
6074 EP3(1)=.5D0*(WPD+WMD)
6075 EP3(2)=.5D0*(WPD-WMD)
6076 CALL PSDEFTR(DMASS,EP3,EY)
6077 WPD=DSQRT(DMASS)
6078 WMD=WPD
6079 WP0=0.D0
6080 WM0=0.D0
6081 ENDIF
6082
6083 IS=IABS(ICT)/ICT
6084 IF(PSRAN(B10).GT..33333D0)THEN
6085 IC1=3*IS
6086 IC2=ICT-IS
6087 ELSE
6088 IC1=ICT+4*IS
6089 IC2=4*IS-ICT
6090 ENDIF
6091 CALL XXGENER(WPD,WMD,EY,
6092 * 0.D0,1.D0,0.D0,1.D0,IC2,IC1)
6093 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6094202 FORMAT(2X,'XXDTG - END')
6095 RETURN
6096 END
6097C=======================================================================
6098
6099 SUBROUTINE XXFAU(B,GZ)
6100c Integrands for hadron-hadron and hadron-nucleus cross-sections calculation
6101c-----------------------------------------------------------------------
6102 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6103 INTEGER DEBUG
6104 DIMENSION GZ(3),GZ0(2)
6105 COMMON /AREA1/ IA(2),ICZ,ICP
6106 COMMON /AREA16/ CC(5)
6107 COMMON /AR1/ ANORM
6108 COMMON /AREA43/ MONIOU
6109 COMMON /DEBUG/ DEBUG
6110
6111 IF(DEBUG.GE.2)WRITE (MONIOU,201)
6112201 FORMAT(2X,'XXFAU - INTEGRANDS FOR HADRON-HADRON AND '
6113 * 'HADRON-NUCLEUS CROSS-SECTIONS CALCULATION')
6114
6115 CALL XXFZ(B,GZ0)
6116 DO 1 L=1,2
61171 GZ0(L)=GZ0(L)*CC(2)*ANORM*.5D0
6118
6119 AB=FLOAT(IA(2))
6120
6121 GZ1=(1.D0-GZ0(1))**AB
6122 GZ2=(1.D0-GZ0(2))**AB
6123 GZ3=(1.D0-CC(2)*GZ0(2)-2.D0*(1.D0-CC(2))*GZ0(1))**AB
6124
6125
6126 GZ(1)=CC(ICZ)**2*(GZ2-GZ3)
6127 GZ(2)=CC(ICZ)*(1.D0-CC(ICZ))*(1.D0+GZ2-2.D0*GZ1)
6128 GZ(3)=CC(ICZ)*(1.D0-GZ2)
6129 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6130202 FORMAT(2X,'XXFAU - END')
6131 RETURN
6132 END
6133C=======================================================================
6134
6135 SUBROUTINE XXFRAG(SA,NA,RC)
6136c Connected nucleon clasters extraction - used for the nuclear spectator part
6137c multifragmentation:
6138c-----------------------------------------------------------------------
6139 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6140 INTEGER DEBUG
6141 DIMENSION SA(56,3)
6142 COMMON /AREA13/ NSF,IAF(56)
6143 COMMON /AREA43/ MONIOU
6144 COMMON /DEBUG/ DEBUG
6145 SAVE
6146 IF(DEBUG.GE.2)WRITE (MONIOU,201)NA
6147201 FORMAT(2X,'XXFRAG-MULTIFRAGMENTATION: NUCLEUS MASS NUMBER: NA='
6148 * ,I2)
6149 IF(DEBUG.GE.3)THEN
6150 WRITE (MONIOU,203)
6151203 FORMAT(2X,'NUCLEONS COORDINATES:')
6152204 FORMAT(2X,3E10.3)
6153 DO 205 I=1,NA
6154205 WRITE (MONIOU,204)(SA(I,L),L=1,3)
6155 ENDIF
6156
6157 NI=1
6158 NG=1
6159 J=0
61601 J=J+1
6161 J1=NI+1
6162 DO 4 I=J1,NA
6163 RI=0.D0
6164 DO 2 M=1,3
61652 RI=RI+(SA(J,M)-SA(I,M))**2
6166 IF(RI.GT.RC)GOTO 4
6167 NI=NI+1
6168 NG=NG+1
6169 IF(I.EQ.NI)GOTO 4
6170 DO 3 M=1,3
6171 S0=SA(NI,M)
6172 SA(NI,M)=SA(I,M)
61733 SA(I,M)=S0
61744 CONTINUE
6175 IF(J.LT.NI.AND.NA-NI.GT.0)GOTO 1
6176 NSF=NSF+1
6177 IAF(NSF)=NG
6178 IF(DEBUG.GE.3)WRITE (MONIOU,206)NSF,IAF(NSF)
6179206 FORMAT(2X,'XXFRAG: FRAGMENT N',I2,2X,'FRAGMENT MASS - ',I2)
6180 NG=1
6181 J=NI
6182 NI=NI+1
6183 IF(NA-NI)6,5,1
61845 NSF=NSF+1
6185 IAF(NSF)=1
6186 IF(DEBUG.GE.3)WRITE (MONIOU,206)NSF,IAF(NSF)
61876 CONTINUE
6188 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6189202 FORMAT(2X,'XXFRAG - END')
6190 RETURN
6191 END
6192C=======================================================================
6193
6194 SUBROUTINE XXFRAGM(NS,XA)
6195c Fragmentation of the spectator part of the nucleus
6196c XA(56,3) - arrays for spectator nucleons positions
6197c NS - total number of spectators
6198c-----------------------------------------------------------------------
6199 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6200 DIMENSION XA(56,3)
6201 INTEGER DEBUG
6202 COMMON /AREA1/ IA(2),ICZ,ICP
6203 COMMON /AREA3/ RMIN,EMAX,EEV
6204 COMMON /AREA11/ B10
6205c NSF - number of secondary fragments;
6206c IAF(i) - mass of the i-th fragment
6207 COMMON /AREA13/ NSF,IAF(56)
6208 COMMON /AREA43/ MONIOU
6209 COMMON /DEBUG/ DEBUG
6210 SAVE
6211 IF(DEBUG.GE.2)WRITE (MONIOU,201)NS
6212201 FORMAT(2X,'XXFRAGM: NUMBER OF SPECTATORS: NS=',I2)
6213
6214 NSF=0
6215
6216 IF(NS-1)6,1,2
6217c Single spectator nucleon is recorded
62181 NSF=NSF+1
6219 IAF(NSF)=1
6220 IF(DEBUG.GE.3)WRITE (MONIOU,205)
6221205 FORMAT(2X,'XXFRAGM - SINGLE SPECTATOR')
6222 GOTO 6
62232 EEX=0.D0
6224c EEX - spectator part excitation energy; calculated as the sum of excitations
6225c from all wounded nucleons ( including diffractively excited )
6226 DO 3 I=1,IA(1)-NS
6227c Partial excitation is simulated according to distribution f(E) ~ 1/sqrt(E)
6228c * exp(-E/(2*<E>)), for sqrt(E) we have then normal distribution
62293 EEX=EEX+(PSRAN(B10)+PSRAN(B10)+PSRAN(B10)+
6230 * PSRAN(B10)+PSRAN(B10)-2.5D0)**2*2.4D0
6231 IF(DEBUG.GE.3)WRITE (MONIOU,203)EEX
6232203 FORMAT(2X,'XXFRAGM: EXCITATION ENERGY: EEX=',E10.3)
6233
6234c If the excitation energy per spectator is larger than EMAX
6235c multifragmentation takes place ( percolation algorithm is used for it )
6236 IF(EEX/NS.GT.EMAX)THEN
6237c Multifragmentation
6238 CALL XXFRAG(XA,NS,RMIN)
6239 ELSE
6240
6241c Otherwise average number of eveporated nucleons equals EEX/EEV, where
6242c EEV - mean excitation energy carried out by one nucleon
6243 NF=IXXSON(NS,EEX/EEV,PSRAN(B10))
6244 NSF=NSF+1
6245c Recording of the fragment produced
6246 IAF(NSF)=NS-NF
6247 IF(DEBUG.GE.3)WRITE (MONIOU,206)IAF(NSF)
6248206 FORMAT(2X,'XXFRAGM - EVAPORATION: MASS NUMBER OF THE FRAGMENT:'
6249 * ,I2)
6250
6251c Some part of excitation energy is carried out by alphas; we determine the
6252c number of alphas simply as NF/4
6253 NAL=NF/4
6254 IF(NAL.NE.0)THEN
6255c Recording of the evaporated alphas
6256 DO 4 I=1,NAL
6257 NSF=NSF+1
62584 IAF(NSF)=4
6259 ENDIF
6260
6261 NF=NF-4*NAL
6262 IF(NF.NE.0)THEN
6263c Recording of the evaporated nucleons
6264 DO 5 I=1,NF
6265 NSF=NSF+1
62665 IAF(NSF)=1
6267 ENDIF
6268 IF(DEBUG.GE.3)WRITE (MONIOU,204)NF,NAL
6269204 FORMAT(2X,'XXFRAGM - EVAPORATION: NUMBER OF NUCLEONS NF=',I2,
6270 * 'NUMBER OF ALPHAS NAL=',I2)
6271 ENDIF
62726 CONTINUE
6273 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6274202 FORMAT(2X,'XXFRAGM - END')
6275 RETURN
6276 END
6277C=======================================================================
6278
6279 SUBROUTINE XXFZ(B,GZ)
6280c Hadron-hadron and hadron-nucleus cross sections calculation
6281c-----------------------------------------------------------------------
6282 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6283 INTEGER DEBUG
6284 DIMENSION GZ(2),FHARD(3)
6285 COMMON /AREA1/ IA(2),ICZ,ICP
6286 COMMON /AREA2/ S,Y0,WP0,WM0
6287 COMMON /AREA7/ RP1
6288 COMMON /AR3/ X1(7),A1(7)
6289 COMMON /AREA43/ MONIOU
6290 COMMON /DEBUG/ DEBUG
6291 IF(DEBUG.GE.2)WRITE (MONIOU,201)
6292201 FORMAT(2X,'XXFZ - HADRONIC CROSS-SECTIONS CALCULATION')
6293
6294 DO 1 L=1,2
62951 GZ(L)=0.D0
6296 E1=EXP(-1.D0)
6297
6298 DO 2 I1=1,7
6299 DO 2 M=1,2
6300 Z=.5D0+X1(I1)*(M-1.5D0)
6301 S1=DSQRT(RP1*Z)
6302 ZV1=EXP(-Z)
6303 S2=DSQRT(RP1*(1.D0-DLOG(Z)))
6304 ZV2=E1*Z
6305C??????????
6306C VV1=EXP(-PSFAZ(ZV1,FSOFT,FHARD,FSHARD))*(1.D0-FHARD(1)
6307C * -FHARD(2)-FHARD(3))
6308C VV2=EXP(-PSFAZ(ZV2,FSOFT,FHARD,FSHARD))*(1.D0-FHARD(1)
6309C * -FHARD(2)-FHARD(3))
6310
6311 VV1=EXP(-PSFAZ(ZV1,FSOFT,FHARD,FSHARD)-FHARD(1)
6312 * -FHARD(2)-FHARD(3))
6313 VV2=EXP(-PSFAZ(ZV2,FSOFT,FHARD,FSHARD)-FHARD(1)
6314 * -FHARD(2)-FHARD(3))
6315c???????????
6316
6317 IF(IA(2).EQ.1)THEN
6318 CG1=1.D0
6319 CG2=1.D0
6320 ELSE
6321 CG1=XXROT(B,S1)
6322 CG2=XXROT(B,S2)
6323 ENDIF
6324
6325 DO 2 L=1,2
63262 GZ(L)=GZ(L)+ A1(I1)*(CG1*(1.D0-VV1**L)+CG2*(1.D0-VV2**L)/Z)
6327 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6328202 FORMAT(2X,'XXFZ - END')
6329 RETURN
6330 END
6331C=======================================================================
6332
6333 SUBROUTINE XXGAU(GZ)
6334c Impact parameter integration for impact parameters <BM -
6335c for hadron-hadron and hadron-nucleus cross-sections calculation
6336c-----------------------------------------------------------------------
6337 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6338 INTEGER DEBUG
6339 DIMENSION GZ(3),GZ0(3)
6340 COMMON /AREA6/ PI,BM,AM
6341 COMMON /AR3/ X1(7),A1(7)
6342 COMMON /AR2/ R,RM
6343 COMMON /AREA43/ MONIOU
6344 COMMON /DEBUG/ DEBUG
6345 IF(DEBUG.GE.2)WRITE (MONIOU,201)
6346201 FORMAT(2X,'XXGAU - NUCLEAR CROSS-SECTIONS CALCULATION')
6347
6348 DO 1 I=1,3
63491 GZ(I)=0.D0
6350
6351 DO 2 I=1,7
6352 DO 2 M=1,2
6353 B=BM*DSQRT(.5D0+X1(I)*(M-1.5D0))
6354 CALL XXFAU(B,GZ0)
6355 DO 2 L=1,3
63562 GZ(L)=GZ(L)+GZ0(L)*A1(I)
6357 DO 3 L=1,3
63583 GZ(L)=GZ(L)*(BM*AM)**2*PI*.5D0
6359 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6360202 FORMAT(2X,'XXGAU - END')
6361 RETURN
6362 END
6363C=======================================================================
6364
6365 SUBROUTINE XXGAU1(GZ)
6366c Impact parameter integration for impact parameters >BM -
6367c for hadron-hadron and hadron-nucleus cross-sections calculation
6368c-----------------------------------------------------------------------
6369 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6370 INTEGER DEBUG
6371 DIMENSION GZ(3),GZ0(3)
6372 COMMON /AREA6/ PI,BM,AM
6373 COMMON /AR5/ X5(2),A5(2)
6374 COMMON /AR2/ R,RM
6375 COMMON /AREA43/ MONIOU
6376 COMMON /DEBUG/ DEBUG
6377
6378 IF(DEBUG.GE.2)WRITE (MONIOU,201)
6379201 FORMAT(2X,'XXGAU1 - NUCLEAR CROSS-SECTIONS CALCULATION')
6380
6381 DO 1 I=1,2
6382 B=BM+X5(I)
6383 CALL XXFAU(B,GZ0)
6384 DO 1 L=1,3
63851 GZ(L)=GZ(L)+GZ0(L)*A5(I)*EXP(X5(I))*B*2.D0*PI*AM*AM
6386 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6387202 FORMAT(2X,'XXGAU1 - END')
6388 RETURN
6389 END
6390C=======================================================================
6391
6392 SUBROUTINE XXGENER(WP0,WM0,EY0,S0X,C0X,S0,C0,IC1,IC2)
6393c To simulate the fragmentation of the string into secondary hadrons
6394c The algorithm conserves energy-momentum;
6395c WP0, WM0 are initial longitudinal momenta ( E+p, E-p ) of the quarks
6396c at the ends of the string; IC1, IC2 - their types
6397c The following partons types are used: 1 - u, -1 - U, 2 - d, -2 - D,
6398c 3 - ud, -3 - UD, 4 - s, -4 - S, 5 - c, -5 - C,
6399c 6 - uu, 7 - dd, -6 - UU, -7 - DD
6400c-----------------------------------------------------------------------
6401 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6402 INTEGER DEBUG
6403 CHARACTER *2 TYQ
6404 DIMENSION WP(2),IC(2),EPT(4),EP(4),EY(3),EY0(3)
6405c WP(1), WP(2) - current longitudinal momenta of the partons at the string
6406c ends, IC(1), IC(2) - their types
6407 COMMON /AREA8/ WWM,BEP,BEN,BEK,BEC,DC(5),DETA,ALMPT
6408 COMMON /AREA10/ STMASS,AM0,AMN,AMK,AMC,AMLAMC,AMLAM,AMETA
6409 COMMON /AREA11/ B10
6410 COMMON /AREA19/ AHL(5)
6411********************************************************
6412 COMMON /AREA21/ DMMIN(5)
6413********************************************************
6414 COMMON /AREA28/ ARR(4)
6415 COMMON /AREA42/ TYQ(15)
6416 COMMON /AREA43/ MONIOU
6417 COMMON /DEBUG/ DEBUG
6418 SAVE
6419
6420 IF(DEBUG.GE.2)WRITE (MONIOU,201)TYQ(8+IC1),TYQ(8+IC2),
6421 * WP0,WM0,EY0,S0X,C0X,S0,C0
6422201 FORMAT(2X,'XXGENER: PARTON FLAVORS AT THE ENDS OF THE STRING:',
6423 * 2X,A2,2X,A2/4X,'LIGHT CONE MOMENTA OF THE STRING: ',E10.3,
6424 * 2X,E10.3/4X,'EY0=',3E10.3/4X,
6425 * 'S0X=',E10.3,2X,'C0X=',E10.3,2X,'S0=',E10.3,2X,'C0=',E10.3)
6426
6427 WW=WP0*WM0
6428 EPT(1)=.5D0*(WP0+WM0)
6429 EPT(2)=.5D0*(WP0-WM0)
6430 EPT(3)=0.D0
6431 EPT(4)=0.D0
6432 IC(1)=IC1
6433 IC(2)=IC2
6434
64351 SWW=DSQRT(WW)
6436 CALL PSDEFTR(WW,EPT,EY)
6437 J=INT(2.D0*PSRAN(B10))+1
6438 IF(DEBUG.GE.3)THEN
6439 IQT=8+IC(J)
6440 WRITE (MONIOU,203)J,TYQ(IQT),WW
6441203 FORMAT(2X,'XXGENER: CURRENT PARTON FLAVOR AT THE END ',I1,
6442 * ' OF THE STRING: ',A2/4X,' STRING MASS: ',E10.3)
6443 ENDIF
6444
6445 IAB=IABS(IC(J))
6446 IS=IC(J)/IAB
6447 IF(IAB.GT.5)IAB=3
6448 IAJ=IABS(IC(3-J))
6449 IF(IAJ.GT.5)IAJ=3
6450 IF(IAJ.EQ.3)THEN
6451 RESTM=AMN
6452 ELSEIF(IAJ.EQ.4)THEN
6453 RESTM=AMK
6454 ELSEIF(IAJ.EQ.5)THEN
6455 RESTM=AMC
6456 ELSE
6457 RESTM=AM0
6458 ENDIF
6459
6460 IF(IAB.LE.2.AND.SWW.GT.RESTM+2.D0*AM0+WWM.OR.
6461 *IAB.EQ.3.AND.SWW.GT.RESTM+AM0+AMN+WWM.OR.
6462 *IAB.EQ.4.AND.SWW.GT.RESTM+AM0+AMK+WWM.OR.
6463 *IAB.EQ.5.AND.SWW.GT.RESTM+AM0+AMC+WWM)THEN
6464
6465 IF(IAB.LE.2)THEN
6466 IF(SWW.GT.RESTM+2.D0*AMC.AND.PSRAN(B10).LT.DC(3))THEN
6467c D-meson generation
6468 RESTM=(RESTM+AMC)**2
6469 BET=BEC
6470 AMI=AMC**2
6471 ALF=ALMPT-ARR(4)
6472 BLF=AHL(4)
6473 IC0=IC(J)-9*IS
6474 IC(J)=5*IS
6475 ELSEIF(SWW.GT.RESTM+2.D0*AMN.AND.PSRAN(B10).LT.DC(1))THEN
6476c Nucleon generation
6477 RESTM=(RESTM+AMN)**2
6478 BET=BEN
6479 AMI=AMN**2
6480 ALF=ALMPT-ARR(2)
6481 BLF=AHL(2)
6482 IC0=IC(J)+IS
6483 IC(J)=-3*IS
6484 ELSEIF(SWW.GT.RESTM+2.D0*AMK.AND.PSRAN(B10).LT.DC(2))THEN
6485c Kaon generation
6486 RESTM=(RESTM+AMK)**2
6487 BET=BEK
6488 AMI=AMK**2
6489 ALF=ALMPT-ARR(3)
6490 BLF=AHL(3)
6491 IC0=IC(J)+3*IS
6492 IC(J)=4*IS
6493 ELSEIF(SWW.GT.RESTM+AMETA+AM0.AND.PSRAN(B10).LT.DETA)THEN
6494c Eta generation
6495 RESTM=(RESTM+AM0)**2
6496 BET=BEK
6497 AMI=AMETA**2
6498 ALF=ALMPT-ARR(1)
6499 BLF=AHL(1)
6500 IC0=10
6501 ELSE
6502c Pion generation
6503 RESTM=(RESTM+AM0)**2
6504 BET=BEP
6505 AMI=AM0**2
6506 ALF=ALMPT-ARR(1)
6507 BLF=AHL(1)
6508
6509 IF(PSRAN(B10).LT..3333D0)THEN
6510 IC0=0
6511 ELSE
6512 IC0=3*IS-2*IC(J)
6513 IC(J)=3*IS-IC(J)
6514 ENDIF
6515 ENDIF
6516
6517 ELSEIF(IAB.EQ.3)THEN
6518 IF(SWW.GT.RESTM+AMC+AMLAMC.AND.PSRAN(B10).LT.DC(5).AND.
6519 * IABS(IC(J)).EQ.3)THEN
6520c Lambda_C generation
6521 RESTM=(RESTM+AMC)**2
6522 BET=BEC
6523 AMI=AMLAMC**2
6524 ALF=ALMPT-ARR(4)
6525 BLF=AHL(5)
6526 IC0=9*IS
6527 IC(J)=-5*IS
6528 ELSEIF(SWW.GT.RESTM+AMK+AMLAM.AND.PSRAN(B10).LT.DC(4).AND.
6529 * IABS(IC(J)).EQ.3)THEN
6530c Lambda generation
6531 RESTM=(RESTM+AMK)**2
6532 BET=BEK
6533 AMI=AMLAM**2
6534 ALF=ALMPT-ARR(3)
6535 BLF=AHL(2)+ARR(1)-ARR(3)
6536 IC0=6*IS
6537 IC(J)=-4*IS
6538 ELSE
6539c Nucleon generation
6540 RESTM=(RESTM+AM0)**2
6541 BET=BEN
6542 AMI=AMN**2
6543 ALF=ALMPT-ARR(1)
6544 BLF=AHL(2)
6545 IF(IABS(IC(J)).EQ.3)THEN
6546 IC0=IS*INT(2.5D0+PSRAN(B10))
6547 IC(J)=IS-IC0
6548 ELSE
6549 IC0=IC(J)-4*IS
6550 IC(J)=IC0-4*IS
6551 ENDIF
6552 ENDIF
6553
6554 ELSEIF(IAB.EQ.4)THEN
6555 IF(SWW.GT.RESTM+AMN+AMLAM.AND.PSRAN(B10).LT.DC(1))THEN
6556c Lambda generation
6557 RESTM=(RESTM+AMN)**2
6558 BET=BEN
6559 AMI=AMLAM**2
6560 ALF=ALMPT-ARR(2)
6561 BLF=AHL(2)+ARR(1)-ARR(3)
6562 IC0=6*IS
6563 IC(J)=-3*IS
6564 ELSE
6565c Kaon generation
6566 RESTM=(RESTM+AM0)**2
6567 BET=BEP
6568 AMI=AMK**2
6569 ALF=ALMPT-ARR(1)
6570 BLF=AHL(3)
6571 IC(J)=IS*INT(1.5D0+PSRAN(B10))
6572 IC0=-3*IS-IC(J)
6573 ENDIF
6574
6575 ELSEIF(IAB.EQ.5)THEN
6576 IF(SWW.GT.RESTM+AMN+AMLAMC.AND.PSRAN(B10).LT.DC(1))THEN
6577c Lambda_C generation
6578 RESTM=(RESTM+AMN)**2
6579 BET=BEN
6580 AMI=AMLAMC**2
6581 ALF=ALMPT-ARR(2)
6582 BLF=AHL(5)
6583 IC0=9*IS
6584 IC(J)=-3*IS
6585 ELSE
6586c D-meson generation
6587 RESTM=(RESTM+AM0)**2
6588 BET=BEP
6589 AMI=AMC**2
6590 ALF=ALMPT-ARR(1)
6591 BLF=AHL(4)
6592 IC(J)=IS*INT(1.5D0+PSRAN(B10))
6593 IC0=9*IS-IC(J)
6594 ENDIF
6595 ENDIF
6596
6597********************************************************
6598 PTMAX=PSLAM(WW,RESTM,AMI)
6599 IF(PTMAX.LT.0.)PTMAX=0.
6600
6601 IF(PTMAX.LT.BET**2)THEN
66022 PTI=PTMAX*PSRAN(B10)
6603 IF(PSRAN(B10).GT.EXP(-DSQRT(PTI)/BET))GOTO 2
6604 ELSE
66053 PTI=(BET*DLOG(PSRAN(B10)*PSRAN(B10)))**2
6606 IF(PTI.GT.PTMAX)GOTO 3
6607 ENDIF
6608
6609 AMT=AMI+PTI
6610 RESTM1=RESTM+PTI
6611********************************************************
6612c ALF=ALF+2.*PTI
6613
6614 ZMIN=DSQRT(AMT/WW)
6615 ZMAX=XXTWDEC(WW,AMT,RESTM1)
6616 Z1=(1.-ZMAX)**ALF
6617 Z2=(1.-ZMIN)**ALF
66184 Z=1.-(Z1+(Z2-Z1)*PSRAN(B10))**(1./ALF)
6619 IF(PSRAN(B10).GT.(Z/ZMAX)**BLF)GOTO 4
6620 WP(J)=Z*SWW
6621 WP(3-J)=AMT/WP(J)
6622 EP(1)=.5D0*(WP(1)+WP(2))
6623 EP(2)=.5D0*(WP(1)-WP(2))
6624 PTI=DSQRT(PTI)
6625 CALL PSCS(C,S)
6626 EP(3)=PTI*C
6627 EP(4)=PTI*S
6628
6629 EPT(1)=SWW-EP(1)
6630 DO 5 I=2,4
66315 EPT(I)=-EP(I)
6632 WW=PSNORM(EPT)
6633 IF(WW.LT.RESTM)GOTO 4
6634
6635 CALL PSTRANS(EP,EY)
6636 CALL PSTRANS(EPT,EY)
6637
6638 IF(S0X.NE.0.D0.OR.S0.NE.0.D0)THEN
6639 CALL PSROTAT(EP,S0X,C0X,S0,C0)
6640 ENDIF
6641
6642 IF(EY0(1)*EY0(2)*EY0(3).NE.1.D0)THEN
6643 CALL PSTRANS(EP,EY0)
6644 ENDIF
6645 CALL XXREG(EP,IC0)
6646 ELSE
6647
6648
6649 AMI2=RESTM**2
6650 BET=BEP
6651 IF(IAB.LE.2.AND.IAJ.LE.2)THEN
6652 AMI=AM0**2
6653 IC0=-IC(1)-IC(2)
6654 IF(IC0.NE.0)THEN
6655 IC(J)=IC0*INT(.5D0+PSRAN(B10))
6656 IC(3-J)=IC0-IC(J)
6657 ELSE
6658 IF(PSRAN(B10).LT..2D0)THEN
6659 IC(J)=0
6660 IC(3-J)=0
6661 ELSE
6662 IC(J)=3*IS-2*IC(J)
6663 IC(3-J)=-IC(J)
6664 ENDIF
6665 ENDIF
6666
6667 ELSEIF(IAB.EQ.3.OR.IAJ.EQ.3)THEN
6668 IF(IAB.EQ.3)THEN
6669 AMI=AMN**2
6670 IF(IABS(IC(J)).EQ.3)THEN
6671 IF(IAJ.EQ.3)THEN
6672 IF(IABS(IC(3-J)).EQ.3)THEN
6673 IC(J)=IS*INT(2.5D0+PSRAN(B10))
6674 IC(3-J)=-IC(J)
6675 ELSE
6676 IC(3-J)=IC(3-J)+4*IS
6677 IC(J)=5*IS+IC(3-J)
6678 ENDIF
6679 ELSEIF(IAJ.LT.3)THEN
6680 IF(PSRAN(B10).LT..3333D0)THEN
6681 IC(J)=IC(3-J)+IS
6682 IC(3-J)=0
6683 ELSE
6684 IC(J)=IS*(4-IAJ)
6685 IC(3-J)=IS*(3-2*IAJ)
6686 ENDIF
6687 ELSEIF(IAJ.EQ.4)THEN
6688 IC(J)=IS*INT(2.5D0+PSRAN(B10))
6689 IC(3-J)=-IC(J)-2*IS
6690 ELSEIF(IAJ.EQ.5)THEN
6691 IC(J)=IS*INT(2.5D0+PSRAN(B10))
6692 IC(3-J)=-IC(J)+10*IS
6693 ENDIF
6694 ELSE
6695 IC(J)=IC(J)-4*IS
6696 IC0=IC(J)-4*IS
6697 IF(IAJ.EQ.3)THEN
6698 IC(3-J)=IC0-IS
6699 ELSEIF(IAJ.LT.3)THEN
6700 IC(3-J)=-IC(3-J)-IC0
6701 ELSEIF(IAJ.EQ.4)THEN
6702 IC(3-J)=IC0-3*IS
6703 ELSEIF(IAJ.EQ.5)THEN
6704 IC(3-J)=IC0+9*IS
6705 ENDIF
6706 ENDIF
6707 ELSE
6708 IF(IABS(IC(3-J)).EQ.3)THEN
6709 IF(IAB.LT.3)THEN
6710 AMI=AM0**2
6711 IF(PSRAN(B10).LT..3333D0)THEN
6712 IC(3-J)=IC(J)+IS
6713 IC(J)=0
6714 ELSE
6715 IC(3-J)=IS*(4-IAB)
6716 IC(J)=IS*(3-2*IAB)
6717 ENDIF
6718 ELSEIF(IAB.EQ.4)THEN
6719 AMI=AMK**2
6720 IC(3-J)=IS*INT(2.5D0+PSRAN(B10))
6721 IC(J)=-IC(3-J)-2*IS
6722 ELSEIF(IAB.EQ.5)THEN
6723 AMI=AMC**2
6724 IC(3-J)=IS*INT(2.5D0+PSRAN(B10))
6725 IC(J)=-IC(3-J)+10*IS
6726 ENDIF
6727 ELSE
6728 IC(3-J)=IC(3-J)-4*IS
6729 IC0=IC(3-J)-4*IS
6730 IF(IAB.LT.3)THEN
6731 AMI=AM0**2
6732 IC(J)=-IC0-IC(J)
6733 ELSEIF(IAB.EQ.4)THEN
6734 AMI=AMK**2
6735 IC(J)=IC0-3*IS
6736 ELSEIF(IAB.EQ.5)THEN
6737 AMI=AMC**2
6738 IC(J)=IC0+9*IS
6739 ENDIF
6740 ENDIF
6741 ENDIF
6742
6743 ELSEIF(IAB.EQ.4.OR.IAJ.EQ.4)THEN
6744
6745 IF(IAB.EQ.4)THEN
6746 AMI=AMK**2
6747
6748 IF(IAJ.EQ.4)THEN
6749 IC(J)=-IS*INT(4.5D0+PSRAN(B10))
6750 IC(3-J)=-IC(J)
6751 ELSEIF(IAJ.EQ.5)THEN
6752 IC(J)=-IS*INT(4.5D0+PSRAN(B10))
6753 IC(3-J)=-IC(J)-12*IS
6754 ELSE
6755 IC0=IC(3-J)+INT(.6667D0+PSRAN(B10))*(-3*IS-2*IC(3-J))
6756 IC(J)=IC0-3*IS
6757 IC(3-J)=IC0-IC(3-J)
6758 ENDIF
6759 ELSE
6760 IF(IAB.LE.2)THEN
6761 AMI=AM0**2
6762 IC0=IC(J)+INT(.6667D0+PSRAN(B10))*(3*IS-2*IC(J))
6763 IC(J)=IC0-IC(J)
6764 IC(3-J)=IC0+3*IS
6765 ELSEIF(IAB.EQ.5)THEN
6766 AMI=AMC**2
6767 IC(3-J)=IS*INT(4.5D0+PSRAN(B10))
6768 IC(J)=-IC(3-J)+12*IS
6769 ENDIF
6770 ENDIF
6771
6772 ELSEIF(IAB.EQ.5.OR.IAJ.EQ.5)THEN
6773
6774 IF(IAB.EQ.5)THEN
6775 AMI=AMC**2
6776
6777 IF(IAJ.EQ.5)THEN
6778 IC(J)=IS*INT(7.5D0+PSRAN(B10))
6779 IC(3-J)=-IC(J)
6780 ELSE
6781 IC0=IC(3-J)+INT(.6667D0+PSRAN(B10))*(-3*IS-2*IC(3-J))
6782 IC(J)=IC0+9*IS
6783 IC(3-J)=IC0-IC(3-J)
6784 ENDIF
6785 ELSE
6786 AMI=AM0**2
6787 IC0=IC(J)+INT(.6667D0+PSRAN(B10))*(3*IS-2*IC(J))
6788 IC(J)=IC0-IC(J)
6789 IC(3-J)=IC0-9*IS
6790 ENDIF
6791 ENDIF
6792
6793 PTMAX=PSLAM(WW,AMI2,AMI)
6794 IF(PTMAX.LT.0.)PTMAX=0.
6795 IF(PTMAX.LT.BET**2)THEN
67966 PTI=PTMAX*PSRAN(B10)
6797 IF(PSRAN(B10).GT.EXP(-DSQRT(PTI)/BET))GOTO 6
6798 ELSE
67997 PTI=(BET*DLOG(PSRAN(B10)*PSRAN(B10)))**2
6800 IF(PTI.GT.PTMAX)GOTO 7
6801 ENDIF
6802
6803 AMT1=AMI+PTI
6804 AMT2=AMI2+PTI
6805
6806 Z=XXTWDEC(WW,AMT1,AMT2)
6807 WP(J)=Z*SWW
6808 WP(3-J)=AMT1/WP(J)
6809 EP(1)=.5D0*(WP(1)+WP(2))
6810 EP(2)=.5D0*(WP(1)-WP(2))
6811 PTI=DSQRT(PTI)
6812 CALL PSCS(C,S)
6813 EP(3)=PTI*C
6814 EP(4)=PTI*S
6815
6816 EPT(1)=SWW-EP(1)
6817 DO 8 I=2,4
68188 EPT(I)=-EP(I)
6819
6820 CALL PSTRANS(EP,EY)
6821 CALL PSTRANS(EPT,EY)
6822
6823 IF(S0X.NE.0.D0.OR.S0.NE.0.D0)THEN
6824 CALL PSROTAT(EP,S0X,C0X,S0,C0)
6825 CALL PSROTAT(EPT,S0X,C0X,S0,C0)
6826 ENDIF
6827 IF(EY0(1)*EY0(2)*EY0(3).NE.1.D0)THEN
6828 CALL PSTRANS(EP,EY0)
6829 CALL PSTRANS(EPT,EY0)
6830 ENDIF
6831
6832 CALL XXREG(EP,IC(J))
6833 CALL XXREG(EPT,IC(3-J))
6834 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6835202 FORMAT(2X,'XXGENER - END')
6836 RETURN
6837 ENDIF
6838 GOTO 1
6839 END
6840C=======================================================================
6841
6842 SUBROUTINE XXJETSIM
6843c Procedure for jet hadronization - each gluon is
6844c considered to be splitted into quark-antiquark pair and usual soft
6845c strings are assumed to be formed between quark and antiquark
6846c-----------------------------------------------------------------------
6847 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6848 INTEGER DEBUG
6849 DIMENSION EP(4),EP1(4),ey(3)
6850 COMMON /AREA10/ STMASS,AM(7)
6851 COMMON /AREA11/ B10
6852 COMMON /AREA43/ MONIOU
6853 COMMON /DEBUG/ DEBUG
6854 COMMON /AREA46/ EPJET(4,2,1000),IPJET(2,1000)
6855 COMMON /AREA47/ NJTOT
6856
6857 IF(DEBUG.GE.2)WRITE (MONIOU,201)NJTOT
6858201 FORMAT(2X,'XXJETSIM: TOTAL NUMBER OF JETS NJTOT=',I4)
6859 IF(NJTOT.EQ.0)RETURN
6860 DO 2 NJ=1,NJTOT
6861 DO 1 I=1,4
6862 EP1(I)=EPJET(I,1,NJ)
68631 EP(I)=EP1(I)+EPJET(I,2,NJ)
6864 PT3=DSQRT(EP1(3)**2+EP1(4)**2)
6865 PT4=DSQRT(EPJET(3,2,NJ)**2+EPJET(4,2,NJ)**2)
6866
6867c Invariant mass square for the jet
6868 WW=PSNORM(EP)
6869 SWW=DSQRT(WW)
6870
6871 CALL PSDEFTR(WW,EP,EY)
6872 CALL PSTRANS1(EP1,EY)
6873 CALL PSDEFROT(EP1,S0X,C0X,S0,C0)
6874
68752 CALL XXGENER(SWW,SWW,EY,S0X,C0X,S0,C0,IPJET(1,NJ),IPJET(2,NJ))
6876 IF(DEBUG.GE.3)WRITE (MONIOU,202)
6877202 FORMAT(2X,'XXJETSIM - END')
6878 RETURN
6879 END
6880C=======================================================================
6881
6882 SUBROUTINE XXREG(EP0,IC)
6883c Registration of the produced hadron;
6884c EP - 4-momentum,
6885c IC - hadron type
6886c-----------------------------------------------------------------------
6887 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6888 INTEGER DEBUG
6889 DIMENSION EP(4),EP0(4)
6890 COMMON /AREA4/ EY0(3)
6891 COMMON /AREA10/ STMASS,AM0,AMN,AMK,AMC,AMLAMC,AMLAM,AMETA
6892 COMMON /AREA11/ B10
6893 COMMON /AREA12/ NSH
6894 COMMON /AREA14/ ESP(4,15000),ICH(15000)
6895 COMMON /AREA43/ MONIOU
6896 COMMON /DEBUG/ DEBUG
6897
6898 IF(DEBUG.GE.2)WRITE (MONIOU,201)IC,EP0
6899201 FORMAT(2X,'XXREG: IC=',I2,2X,'C.M. 4-MOMENTUM:',2X,4(E10.3,1X))
6900 pt=dsqrt(ep0(3)**2+ep0(4)**2)
6901c if(pt.gt.11.d0)write (MONIOU,*)'pt,ic,ep',pt,ic,ep0
6902c if(pt.gt.11.d0)write (*,*)'pt,ic,ep',pt,ic,ep0
6903
6904 NSH=NSH+1
6905 IF (NSH .GT. 15000) THEN
6906 WRITE(MONIOU,*)'XXREG: TOO MUCH SECONDARY PARTICLES'
6907 WRITE(MONIOU,*)'XXREG: NSH = ',NSH
6908 STOP
6909 ENDIF
6910 DO 4 I=1,4
69114 EP(I)=EP0(I)
6912 CALL PSTRANS(EP,EY0)
6913 IF(DEBUG.GE.3)WRITE (MONIOU,202)EP
6914202 FORMAT(2X,'XXREG: LAB. 4-MOMENTUM:',2X,4(E10.3,1X))
6915
6916 ICH(NSH)=IC
6917 DO 3 I=1,4
69183 ESP(I,NSH)=EP(I)
6919
6920 IF(DEBUG.GE.3)WRITE (MONIOU,203)
6921203 FORMAT(2X,'XXREG - END')
6922 RETURN
6923 END
6924C=======================================================================
6925
6926 FUNCTION XXROT(S,B)
6927c Convolution of nuclear profile functions (axial angle integration)
6928c-----------------------------------------------------------------------
6929 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6930 INTEGER DEBUG
6931 COMMON /AR8/ X2(4),A2
6932 COMMON /AREA43/ MONIOU
6933 COMMON /DEBUG/ DEBUG
6934 IF(DEBUG.GE.2)WRITE (MONIOU,201)B
6935201 FORMAT(2X,'XXROT - AXIAL ANGLE INTEGRATION OF THE ',
6936 * 'NUCLEAR PROFILE FUNCTION'/4X,
6937 * 'IMPACT PARAMETER B=',E10.3,2X,'NUCLEON COORDINATE S=',E10.3)
6938
6939 XXROT=0.
6940 DO 1 I=1,4
6941 SB1=B**2+S**2-2.*B*S*(2.*X2(I)-1.)
6942 SB2=B**2+S**2-2.*B*S*(1.-2.*X2(I))
69431 XXROT=XXROT+(XXT(SB1)+XXT(SB2))
6944 XXROT=XXROT*A2
6945 IF(DEBUG.GE.3)WRITE (MONIOU,202)XXROT
6946202 FORMAT(2X,'XXROT=',E10.3)
6947 RETURN
6948 END
6949C=======================================================================
6950
6951 SUBROUTINE XXSTR(WPI0,WMI0,WP0,WM0,IC10,IC120,IC210,IC20)
6952**************************************************
6953c Fragmentation process for the pomeron ( quarks and antiquarks types at the
6954c ends of the two strings are determined, energy-momentum is shared
6955c between them and strings fragmentation is simulated )
6956c-----------------------------------------------------------------------
6957 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6958 INTEGER DEBUG
6959 DIMENSION EY(3)
6960 COMMON /AREA6/ PI,BM,AMMM
6961 COMMON /AREA10/ STMASS,AM(7)
6962 COMMON /AREA11/ B10
6963 COMMON /AREA43/ MONIOU
6964 COMMON /DEBUG/ DEBUG
6965 SAVE
6966
6967 IF(DEBUG.GE.2)WRITE (MONIOU,201)WPI0,WMI0,WP0,WM0
6968201 FORMAT(2X,'XXSTR: WPI0=',E10.3,2X,'WMI0=',E10.3,2X,
6969 * 'WP0=',E10.3,2X,'WM0=',E10.3)
6970 DO 1 I=1,3
69711 EY(I)=1.D0
6972
6973 WPI=WPI0
6974 WMI=WMI0
6975c Quark-antiquark types (1 - u, 2 - d, -1 - u~, -2 - d~); s- and d- quarks are
6976c taken into consideration at the fragmentation step
6977**************************************************
6978 IF(IC10.EQ.0)THEN
6979 IC1=INT(1.5+PSRAN(B10))
6980 IC12=-IC1
6981 ELSEIF(IC10.GT.0)THEN
6982 IC1=IC10
6983 IC12=IC120
6984 ELSE
6985 IC1=IC120
6986 IC12=IC10
6987 ENDIF
6988 IF(IC20.EQ.0)THEN
6989 IC2=INT(1.5+PSRAN(B10))
6990 IC21=-IC2
6991 ELSEIF(IC20.gt.0)THEN
6992 IC2=IC20
6993 IC21=IC210
6994 ELSE
6995 IC2=IC210
6996 IC21=IC20
6997 ENDIF
6998**************************************************
6999
7000c Longitudinal momenta for the strings
7001 WP1=WPI*COS(PI*PSRAN(B10))**2
7002 WM1=WMI*COS(PI*PSRAN(B10))**2
7003 WPI=WPI-WP1
7004 WMI=WMI-WM1
7005c String masses
7006 SM1=WP1*WM1
7007 SM2=WPI*WMI
7008c Too short strings are neglected (energy is given to partner string or to the hadron
7009c (nucleon) to which the pomeron is connected)
7010 IF(SM1.GT.STMASS.AND.SM2.GT.STMASS)THEN
7011c Strings fragmentation is simulated - GENER
7012 CALL XXGENER(WP1,WM1,EY,0.D0,1.D0,0.D0,1.D0,IC1,IC21)
7013 CALL XXGENER(WPI,WMI,EY,0.D0,1.D0,0.D0,1.D0,IC12,IC2)
7014 ELSEIF(SM1.GT.STMASS)THEN
7015 CALL XXGENER(WP1+WPI,WM1+WMI,EY,0.D0,1.D0,0.D0,1.D0,IC1,IC21)
7016 ELSEIF(SM2.GT.STMASS)THEN
7017 CALL XXGENER(WPI+WP1,WMI+WM1,EY,0.D0,1.D0,0.D0,1.D0,IC12,IC2)
7018 ELSE
7019 WP0=WP0+WP1+WPI
7020 WM0=WM0+WM1+WMI
7021 ENDIF
7022 IF(DEBUG.GE.3)WRITE (MONIOU,202)WP0,WM0
7023202 FORMAT(2X,'XXSTR - RETURNED LIGHT CONE MOMENTA:',
7024 * 2X,'WP0=',E10.3,2X,'WM0=',E10.3)
7025 RETURN
7026 END
7027C=======================================================================
7028
7029 FUNCTION XXT(B)
7030c Nuclear profile function value at impact parameter squared B
7031c-----------------------------------------------------------------------
7032 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7033 INTEGER DEBUG
7034 COMMON /AREA6/ PI,BM,AM
7035 COMMON /AR2/ R,RM
7036 COMMON /AR5/ X5(2),A5(2)
7037 COMMON /AR9/ X9(3),A9(3)
7038 COMMON /AREA43/ MONIOU
7039 COMMON /DEBUG/ DEBUG
7040
7041 IF(DEBUG.GE.2)WRITE (MONIOU,201)B
7042201 FORMAT(2X,'XXT - NUCLEAR PROFILE FUNCTION VALUE AT IMPACT',
7043 * ' PARAMETER SQUARED B=',E10.3)
7044 XXT=0.
7045 ZM=RM**2-B
7046 IF(ZM.GT.4.*B)THEN
7047 ZM=DSQRT(ZM)
7048 ELSE
7049 ZM=2.*DSQRT(B)
7050 ENDIF
7051
7052 DO 1 I=1,3
7053 Z1=ZM*(1.+X9(I))*0.5
7054 Z2=ZM*(1.-X9(I))*0.5
7055 QUQ=DSQRT(B+Z1**2)-R
7056 IF (QUQ.LT.85.)XXT=XXT+A9(I)/(1.+EXP(QUQ))
7057 QUQ=DSQRT(B+Z2**2)-R
7058 IF (QUQ.LT.85.)XXT=XXT+A9(I)/(1.+EXP(QUQ))
70591 CONTINUE
7060 XXT=XXT*ZM*0.5
7061 DT=0.
7062 DO 2 I=1,2
7063 Z1=X5(I)+ZM
7064 QUQ=DSQRT(B+Z1**2)-R-X5(I)
7065 IF (QUQ.LT.85.)DT=DT+A5(I)/(EXP(-X5(I))+EXP(QUQ))
70662 CONTINUE
7067 XXT=XXT+DT
7068 IF(DEBUG.GE.3)WRITE (MONIOU,202)XXROT
7069202 FORMAT(2X,'XXT=',E10.3)
7070 RETURN
7071 END
7072C=======================================================================
7073
7074 FUNCTION XXTWDEC(S,A,B)
7075c Kinematical function for two particle decay -
7076C light cone momentum share for
7077c the particle of mass squared A,
7078C B - partner's mass squared,
7079C S - two particle invariant mass
7080c-----------------------------------------------------------------------
7081 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7082 INTEGER DEBUG
7083 COMMON /AREA43/ MONIOU
7084 COMMON /DEBUG/ DEBUG
7085
7086 IF(DEBUG.GE.2)WRITE (MONIOU,201)S,A,B
7087201 FORMAT(2X,'XXTWDEC: S=',E10.3,2X,'A=',E10.3,2X,'B=',E10.3)
7088
7089 X=.5D0*(1.D0+(A-B)/S)
7090 DX=(X*X-A/S)
7091 IF(DX.GT.0.D0)THEN
7092 X=X+DSQRT(DX)
7093 ELSE
7094 X=DSQRT(A/S)
7095 ENDIF
7096 XXTWDEC=X
7097 IF(DEBUG.GE.3)WRITE (MONIOU,202)XXTWDEC
7098202 FORMAT(2X,'XXTWDEC=',E10.3)
7099 RETURN
7100 END
7101C=======================================================================
7102
7103 DOUBLE PRECISION FUNCTION GAMFUN(Y)
7104C Gamma function : See Abramowitz, page 257, form. 6.4.40
7105c-----------------------------------------------------------------------
7106 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
7107 DOUBLE PRECISION
7108 + Y,R,S,T,AFSPL,X,
7109 + COEF(10),PI,ZEROD,HALFD,ONED,TWOD,TEND
7110C
7111 DATA COEF/8.3333333333333334D-02,-2.7777777777777778D-03,
7112 . 7.9365079365079365D-04,-5.9523809523809524D-04,
7113 . 8.4175084175084175D-04,-1.9175269175269175D-03,
7114 . 6.4102564102564103D-03,-2.9550653594771242D-02,
7115 . 0.1796443723688306 ,-0.6962161084529506 /
7116 DATA PI/ 3.141592653589793D0/
7117 DATA ZEROD/0.D0/,HALFD/0.5D0/,ONED/1.D0/,TWOD/2.D0/,TEND/10.D0/
7118C
7119 X=Y
7120 AFSPL=ONED
7121 N=INT(TEND-Y)
7122 DO 10 I=0,N
7123 AFSPL=AFSPL*X
7124 X=X+ONED
712510 CONTINUE
7126 R=(X-HALFD)* LOG(X)-X+HALFD* LOG(TWOD*PI)
7127 S=X
7128 T=ZEROD
7129 DO 20 I=1,10
7130 T=T+COEF(I)/S
7131 S=S*X**2
713220 CONTINUE
7133 GAMFUN = EXP(R+T)/AFSPL
7134 END
7135C=======================================================================
7136
7137 BLOCK DATA PSDATA
7138c Constants for numerical integration (Gaussian weights)
7139c-----------------------------------------------------------------------
7140 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7141 COMMON /AR3/ X1(7),A1(7)
7142 COMMON /AR5/ X5(2),A5(2)
7143 COMMON /AR8/ X2(4),A2
7144 COMMON /AR9/ X9(3),A9(3)
7145
7146 DATA X1/.9862838D0,.9284349D0,.8272013D0,.6872929D0,.5152486D0,
7147 * .3191124D0,.1080549D0/
7148 DATA A1/.03511946D0,.08015809D0,.1215186D0,.1572032D0,
7149 * .1855384D0,.2051985D0,.2152639D0/
7150 DATA X2/.00960736D0,.0842652D0,.222215D0,.402455D0/
7151 DATA A2/.392699D0/
7152 DATA X5/.585786D0,3.41421D0/
7153 DATA A5/.853553D0,.146447D0/
7154 DATA X9/.93247D0,.661209D0,.238619D0/
7155 DATA A9/.171324D0,.360762D0,.467914D0/
7156 END
Note: See TracBrowser for help on using the repository browser.