Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

QGSJET.f@ 1118

Visit:

Last change on this file since 1118 was 286, checked in by harald, 26 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
2	C======================================================================C
3	C C
4	C QQQ GGG SSSS JJJJJJJ EEEEEEE TTTTTTT C
5	C Q Q G G S S J E T C
6	C Q Q G S J E T C
7	C Q Q G GGG SSSS J EEEEE T C
8	C Q Q Q G G S J E T C
9	C Q Q G G S S J J E T C
10	C QQQ QQ GGG SSSS JJJ EEEEEEE T C
11	C C
12	C C
13	C----------------------------------------------------------------------C
14	C C
15	C QUARK - GLUON - STRING - MODEL C
16	C C
17	C HIGH ENERGY HADRON INTERACTION PROGRAM C
18	C C
19	C BY C
20	C C
21	C N. N. KALMYKOV AND S. S. OSTAPCHENKO C
22	C C
23	C MOSCOW STATE UNIVERSITY, MOSCOW, RUSSIA C
24	C e-mail: serg@eas.npi.msu.su C
25	C----------------------------------------------------------------------C
26	C SUBROUTINE VERSION TO BE LINKED WITH C
27	C C O R S I K A C
28	C KARLSRUHE AIR SHOWER SIMULATION PROGRAM C
29	C WITH MODIFICATIONS C
30	C BY C
31	C D. HECK IK3 FZK KARLSRUHE C
32	C----------------------------------------------------------------------C
33	C last modification: feb 21, 1997 C
34	C----------------------------------------------------------------------C
35
36	C=======================================================================
37
38	SUBROUTINE PSAINI
39	c Common initialization procedure
40	c-----------------------------------------------------------------------
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)
80	c Auxiliary common blocks to calculate hadron-nucleus cross-sections
81	COMMON /AR1/ ANORM
82	COMMON /AR2/ RRR,RRRM
83	********************************************
84
85	c-------------------------------------------------
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)
102	210 FORMAT(2X,'PSAINI - MAIN INITIALIZATION PROCEDURE')
103
104	c AHL(i) - parameter for the energy sharing procedure (govern leading hadronic state
105	c 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
112	c-------------------------------------------------
113	c 1/CC(i) = C_i - shower enhancement coefficients for one vertex
114	c (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
121	c 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
128	c SH - hard interaction effective squared (SH=pi*R_h>2, R_h>2=4/Q0>2)
129	SH=4.D0/QT0*PI
130	c 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)
139	211 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)
149	201 FORMAT(2X,'PSAINI: HARD CROSS SECTIONS CALCULATION')
150	c--------------------------------------------------
151	c Hard pomeron inclusive cross sections calculation
152	c--------------------------------------------------
153	c EQ(I) - energy squared tabulation (Q0>2, 4*Q0>2, ...)
154	DO 1 I=1,17
155	1 EQ(I)=QT04.D0*FLOAT(I-1)
156
157	DO 2 I=1,17
158	c QI - effective momentum (Qt2/(1-z)2) cutoff for the Born process
159	QI=EQ(I)
160	c M, L define parton types (1-g, 2-q)
161	DO 2 M=1,2
162	DO 2 L=1,2
163	c 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
169	c SK - c.m. energy squared for the hard interaction
170	SK=EQ(K)
171	c CSBORN(I,K1) - Born cross-section (2->2 process) - procedure PSBORN
172	CSBORN(I,K1)=PSBORN(QI,SK,M-1,L-1)
173	ENDIF
174	2 CONTINUE
175
176	c 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
195	3 CONTINUE
196
197	c N-maximal number of ladder runs taken into account
198	N=2
199	4 CONTINUE
200	IF(DEBUG.GE.2)WRITE (MONIOU,202)N,EQ(MIJ(1,1,1)),EQ(NIJ(1,1,1))
201	202 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
205	c QI - effective momentum cutoff for upper end of the ladder
206	QI=EQ(I)
207	DO 6 J=1,17
208	c QJ - effective momentum cutoff for lower end of the ladder
209	QJ=EQ(J)
210	c QQ - maximal effective momentum cutoff
211	QQ=MAX(QI,QJ)
212	c S2MIN - minimal energy squared for 2->2 subprocess
213	S2MIN=MAX(QQ,4.D0*QT0)
214	SM=DSQRT(QT0/S2MIN)
215	c SMIN - minimal energy squared for 2->3 subprocess
216	SMIN=S2MIN*(1.D0+SM)/(1.D0-SM)
217
218	c 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
222	c KMIN corresponds to minimal energy at which more runs are to be considered -
223	c 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)
232	c CS1(I,J,K1) - cross-section for strictly ordered ladder (highest virtuality run
233	c is the lowest one) - procedure PSJET1
234	CS1(I,J,K1)=PSJET1(QI,QJ,SK,S2MIN,M-1,L)
235	ENDIF
236	5 CONTINUE
237	ENDIF
238	6 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)
249	c CSJ - cross-section for strictly ordered ladder (highest virtuality run is the
250	c 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))
253	204 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
258	c CS0(I,J,K1) - cross-section logarithm for strictly ordered ladder
259	CS0(I,J,K1)=DLOG(CSJ)
260	ENDIF
261	7 CONTINUE
262	ENDIF
263	8 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)
272	c 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
278	c KMIN corresponds to minimal energy at which more runs are to be considered
279	c 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)
288	c CS1(I,J,K1) - cross-section for any ordering in the ladder (highest virtuality
289	c run is somewhere in the middle; runs above and below it are strictly ordered
290	c towards highest effective momentum run) - procedure PSJET
291	CS1(I,J,K1)=PSJET(QI,QJ,SK,S2MIN,M-1,L)
292	ENDIF
293	9 CONTINUE
294	ENDIF
295	10 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
302	c 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))
312	203 FORMAT(2X,'PSAINI: NEW AND OLD VALUES OF THE UNORDERED LADDER',
313	* ' CROSS SECTION:'/4X,E10.3,3X,E10.3)
314	11 CSTOT(I,J,K1)=DLOG(CSJ)
315	ENDIF
316	12 CONTINUE
317
318	c One more run
319	N=N+1
320	DO 13 L=1,4
321	13 IF(MIJ(1,1,L).LE.17.OR.NIJ(1,1,L).LE.17)GOTO 4
322
323	c Logarithms of the Born cross-section are calculated - to be interpolated in the
324	c 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
335	14 CONTINUE
336
337	c Total and Born hard cross-sections logarithms for minimal cutoff (QT0) - to be
338	c 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
350	15 CONTINUE
351
352	c-------------------------------------------------
353	c FSUD(K,M)=-ln(SUD) - timelike Sudakov formfactor logarithm - procedure
354	c 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
358	c QMAX is the maximal effective momentum ( Qt2/z2/(1-z)**2 in case of the timelike
359	c evolution )
360	QMAX=QTF4.D0*(1.D0+K)
361	17 FSUD(K,M)=PSUDT(QMAX,M-1)
362
363	c QRT(K,L,M) - effective momentum logarithm for timelike branching ( ln QQ/16/QTF )
364	c for given QMAX (defined by K, QLMAX = ln QMAX/16/QTF ) and a number
365	c of random number values (defined by L) - to be interpolated by the PSQINT
366	c 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
378	18 CONTINUE
379	c-------------------------------------------------
380
381	IF(DEBUG.GE.2)WRITE (MONIOU,205)
382	205 FORMAT(2X,'PSAINI: PRETABULATION OF THE INTERACTION EIKONALS')
383	c-------------------------------------------------
384	************************************************************************
385	c-------------------------------------------------
386	c Interaction cross sections
387	c Factors for interaction eikonals calculation
388	c (convolution of the hard cross-sections with partons structure functions)
389	c - to be used in the PSPSFAZ procedure
390	c-------------------------------------------------
391	IA(1)=1
392	c-------------------------------------------------
393	DO 21 IE=1,10
394	c Energy of the interaction (per nucleon)
395	E0N=10.D0**IE
396	c-------------------------------------------------
397	c Energy dependent factors:
398	c WP0, WM0 - initial light cone momenta for the interaction (E+-p)
399	S=2.D0E0NAMN
400	c Y0 - total rapidity range for the interaction
401	Y0=DLOG(S)
402
403	c Type of the incident hadron (icz = 1: pion, 2: nucleon, 3: kaon, etc
404	DO 21 ICZ=1,5
405	c RS - soft pomeron elastic scattering slope (lambda_ab)
406	RS=RQ(ICZ)+ALFP*Y0
407	c RS0 - initial slope (sum of the pomeron-hadron vertices slopes squared - R_ab)
408	RS0=RQ(ICZ)
409	c FS - factor for pomeron eikonal calculation
410	c (gamma_ab * s*del /lambda_ab C_ab
411	FS=FP(ICZ)EXP(Y0DEL)/RS*CD(ICZ)
412	c RP1 - factor for the impact parameter dependence of the eikonal ( in fm>2 )
413	RP1=RS4.D0.0391D0/AM**2
414	c Factor for cross-sections calculation ( in mb )
415	G0=PIRP1/CD(ICZ)AM*210.D0
416	c SJV - valence-valence cross-section (divided by 8pilambda_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
423	c Eikonals for gluon-gluon and valence-gluon semihard interactions
424	c (m=1 - gg, 2 - qg, 3 - gq);
425	c 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)
429	19 CONTINUE
430
431	DO 20 IIA=1,4
432	c Target mass number IA(2)
433	IA(2)=4**(IIA-1)
434	IF(DEBUG.GE.1)WRITE (MONIOU,206)E0N,TY(ICZ),IA(2)
435	206 FORMAT(2X,'PSAINI: INITIAL PARTICLE ENERGY:',E10.3,2X,
436	*'ITS TYPE:',A7,2X,'TARGET MASS NUMBER:',I2)
437	c-------------------------------------------------
438	c Nuclear radii
439	IF(IA(2).GT.10)THEN
440	c RD - Wood-Saxon density radius (fit to the data of Murthy et al.)
441	RD(2)=0.7D0FLOAT(IA(2))*.446/AM
442	ELSE
443	c RD - gaussian density radius (for light nucleus)
444	RD(2)=.9D0FLOAT(IA(2))*.3333/AM
445	ENDIF
446
447	IF(IA(2).EQ.1)THEN
448	c Hadron-proton interaction
449	c BM - impact parameter cutoff value
450	BM=2.D0*DSQRT(RP1)
451	c XXFZ - impact parameter integration for the hadron-nucleon interaction eikonal;
452	c GZ0 - total and absorptive cross-sections (up to a factor); first parameter is
453	c used only in case of hadron-nucleus interaction (to make convolution with target
454	c nucleus profile function)
455	CALL XXFZ(0.D0,GZ0)
456	write (,)gz0
457	c GTOT - total cross-section
458	GTOT=G0*GZ0(1)
459	c GABS - cut pomerons cross-section
460	GABS=G0GZ0(2).5D0
461	c GD0 - cross-section for the cut between pomerons
462	GD0=GTOT-GABS
463	c GDP - projectile diffraction cross section
464	GDP=(1.D0-CC(ICZ))CC(2)GD0
465	c GDT - target diffraction cross section
466	GDT=(1.D0-CC(2))CC(ICZ)GD0
467	c GDD - double diffractive cross section
468	GDD=(1.D0-CC(ICZ))(1.D0-CC(2))GD0
469	c GIN - inelastic cross section
470	GIN=GABS+GDP+GDT+GDD
471	GEL=GD0CC(ICZ)CC(2)
472	c
473	IF(DEBUG.GE.1)WRITE (MONIOU,225)GTOT,GIN,GEL,GDP,GDT,GDD
474	c
475	225 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)
479	c GZ - probability to have target diffraction
480	GZ(IE,ICZ,IIA)=GDT/GIN
481	C??????
482	GSECT(IE,ICZ,IIA)=LOG(GIN)
483	C??????
484	ELSE
485
486	c Hadron-nucleus interaction
487	c BM - impact parameter cutoff value
488	BM=RD(2)+DLOG(29.D0)
489	c RRR - Wood-Saxon radius for the target nucleus
490	RRR=RD(2)
491	c RRRM - auxiliary parameter for numerical integration
492	RRRM=RRR+DLOG(9.D0)
493	c ANORM - nuclear density normalization factor multiplied by RP1
494	ANORM=1.5D0/PI/RRR3/(1.D0+(PI/RRR)2)*RP1
495
496	c GAU(GZ) - cross sections calculation ( integration over impact parameters less than
497	c BM )
498	CALL XXGAU(GZ1)
499	c GAU1(GZ) - cross sections calculation ( integration over impact
500	c parameters greater than BM )
501	CALL XXGAU1(GZ1)
502	c GIN - total inelastic cross section
503	GIN=GZ1(1)+GZ1(2)+GZ1(3)
504	c
505	IF(DEBUG.GE.1)WRITE (MONIOU,224)
506	* GIN10.D0,GZ1(1)10.D0,GZ1(2)*10.D0
507	c
508	224 FORMAT(2X,'PSAINI: HADRON-NUCLEUS CROSS SECTIONS:'/
509	* 4X,'GIN=',E10.3,2X,'GDIFR_TARG=',E10.3,2X,
510	* 'GDIFR_PROJ=',E10.3)
511	c GZ - probability to have target diffraction
512	GZ(IE,ICZ,IIA)=GZ1(1)/GIN
513	C??????
514	GIN=GIN*10.
515	GSECT(IE,ICZ,IIA)=LOG(GIN)
516	C??????
517	ENDIF
518	20 CONTINUE
519	21 CONTINUE
520
521	c Rejection functions calculation - to be interpolated in the RJINT procedure
522	DO 23 I=1,50
523	c Rapidity range tabulation for the hard interaction
524	YJ=AQT0+.5D0*I
525	c 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
532	c RS0 - initial slope (sum of the pomeron-hadron vertices slopes squared - R_ab)
533	RS0=RQ(ICZ)
534	M1=M+2*(ICZ-1)
535	c Rejection function for semihard block energy distribution (m=1 - gg,
536	c 2 - qg)
537	RJS(I,J,M1)=PSREJS(EXP(YJ),Z,M-1)
538	22 CONTINUE
539	23 CONTINUE
540
541	IF(DEBUG.GE.1)WRITE (MONIOU,212)
542	212 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)
552	218 FORMAT(2X,'PSAINI - END')
553	RETURN
554	END
555	C=======================================================================
556
557	FUNCTION PSAPINT(X,J,L)
558	c PSAPINT - integrated Altarelli-Parisi function
559	c X - light cone momentum share value,
560	c J - type of initial parton (0 - g, 1 - q)
561	c L - type of final parton (0 - g, 1 - q)
562	C-----------------------------------------------------------------------
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
569	201 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))-X3/3.D0+X2/2.D0-2.D0X)
573	ELSE
574	PSAPINT=3.D0(X+X3/1.5D0-XX)
575	ENDIF
576	ELSE
577	IF(L.EQ.0)THEN
578	PSAPINT=(DLOG(X)-X+.25D0XX)/.375D0
579	ELSE
580	Z=1.D0-X
581	PSAPINT=-(DLOG(Z)-Z+.25D0ZZ)/.375D0
582	ENDIF
583	ENDIF
584	IF(DEBUG.GE.2)WRITE (MONIOU,202)PSAPINT
585	202 FORMAT(2X,'PSAPINT=',E10.3)
586	RETURN
587	END
588	C=======================================================================
589
590	SUBROUTINE PSASET
591	c Common model parameters setting
592	c-----------------------------------------------------------------------
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)
605	210 FORMAT(2X,'PSASET - COMMON MODEL PARAMETERS SETTING')
606
607	c Soft pomeron parameters:
608	c DEL - overcriticity,
609	c ALFP - trajectory slope;
610	c FP(i) - vertices for pomeron-hadrons interaction (gamma(i)*gamma(proton)),
611	c RQ(i) - vertices slopes (R(i)2+R(proton)2),
612	c CD(i) - shower enhancement coefficients
613	c (i=1,...5 - pion,proton,kaon,D-meson,Lambda_C ),
614	c (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
638	c-------------------------------------------------
639	c Hard interaction parameters:
640	c ALM - Lambda_QCD squared,
641	c QT0 - Q**2 cutoff,
642	c RR - vertex constant square for soft pomeron interaction with the hard block (r**2),;
643	c BET - gluon structure function parameter for the soft pomeron ((1-x)**BET),
644	c AMJ0 - jet mass,
645	c QTF - Q**2 cutoff for the timelike evolution,
646	c FACTORK - K-factor value;
647	c DELH is not a parameter of the model; it is used only for energy sharing
648	c procedure - initially energy is shared according to s**DELH dependence
649	c for the hard interaction cross-section and then rejection is used according
650	c 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
660	c-------------------------------------------------
661	c Valence quark structure functions for the hard scattering
662	c (~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
668	c 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
676	C=======================================================================
677
678	FUNCTION PSBINT(QQ,S,M,L)
679	C PSBINT - Born cross-section interpolation
680	c QQ - effective momentum cutoff for the scattering,
681	c S - total c.m. energy squared for the scattering,
682	c M - parton type at current end of the ladder (1 - g, 2 - q)
683	c L - parton type at opposite end of the ladder (1 - g, 2 - q)
684	C-----------------------------------------------------------------------
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
694	201 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
699	202 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
724	1 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
736	2 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
744	3 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
763	4 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
778	5 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
784	C=======================================================================
785
786	FUNCTION PSBORN(QQ,S,IQ1,IQ2)
787	c PSFBORN -hard 2->2 parton scattering Born cross-section
788	c S is the c.m. energy square for the scattering process,
789	c IQ1 - parton type at current end of the ladder (0 - g, 1,2 - q)
790	c IQ2 - parton type at opposite end of the ladder (0 - g, 1,2 - q)
791	c-----------------------------------------------------------------------
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
803	201 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.D0TMIN/(1.D0+2.D0TMIN/S-X1(I)(2M-3)(1.D0-2.D0TMIN/S))
818	QT=T*(1.D0-T/S)
819	FB=PSFBORN(S,T,IQ1,IQ)+PSFBORN(S,S-T,IQ1,IQ)
820	1 PSBORN=PSBORN+A1(I)FB/DLOG(QT/ALM)2T**2
821	PSBORN=PSBORN(.5D0/TMIN-1.D0/S)FACTORKPI3/2.25D02/S*2
822	IF(IQ1.EQ.0.AND.IQ2.EQ.0)PSBORN=PSBORN*.5D0
823	IF(DEBUG.GE.3)WRITE (MONIOU,202)PSBORN
824	202 FORMAT(2X,'PSBORN=',E10.3)
825	RETURN
826	END
827	C=======================================================================
828
829	SUBROUTINE PSCAJET(QQ,IQ1,QV,ZV,QM,IQV,LDAU,LPAR,JQ)
830	c Final state emission process (all branchings as well as parton masses
831	c are determined)
832	C-----------------------------------------------------------------------
833	c QQ - maximal effective momentum transfer for the first branching
834	c IQ1, IQ2 - initial jet flavours in forward and backward direction
835	c (0 - for gluon)
836	c QV(i,j) - effective momentum for the branching of the parton in i-th row
837	c on j-th level (0 - in case of no branching) - to be determined
838	c ZV(i,j) - Z-value for the branching of the parton in i-th row
839	c on j-th level - to be determined
840	c QM(i,j) - mass squared for the parton in i-th row
841	c on j-th level - to be determined
842	c IQV(i,j) - flavour for the parton in i-th row on j-th level
843	c - to be determined
844	c LDAU(i,j) - first daughter row for the branching of the parton in i-th row
845	c on j-th level - to be determined
846	c LPAR(i,j) - the parent row for the parton in i-th row
847	c 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
860	201 FORMAT(2X,'PSCAJET: QQ=',E10.3,2X,'IQ1= ',I1,2X,'JQ=',I1)
861
862	DO 1 I=2,20
863	1 LNV(I)=0
864	LNV(1)=1
865	QMAX(1,1)=QQ
866	IQV(1,1)=IQ1
867	NLEV=1
868	NROW=1
869
870	2 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-2JQ)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.D0PSRAN(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)=QZ*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
917	203 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
926	204 FORMAT(2X,'PSCAJET: NEW FINAL JET AT LEVEL NLEV=',I2,
927	* ' NROW=',I2)
928	ENDIF
929
930	4 CONTINUE
931	IF(NLEV.EQ.1)THEN
932	IF(DEBUG.GE.3)WRITE (MONIOU,202)
933	202 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)
948	205 FORMAT(2X,'PSCAJET: JET MASS AT LEVEL NLEV=',I2,
949	* ' NROW=',I2,' - QM=',E10.3)
950	GOTO 4
951	ENDIF
952	END
953	C=======================================================================
954
955	SUBROUTINE PSCONF
956	c Simulation of the interaction configuration: impact parameter, nucleons positions,
957	c numbers of cut soft pomerons and semihard blocks, their connections.
958	c-----------------------------------------------------------------------
959	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
960	INTEGER DEBUG
961	c XA(56,3),XB(56,3) - arrays for projectile and target nucleons positions recording,
962	c FHARD(i) give the factors to the scattering amplitude due to
963	c valence quark-gluon (i=1), gluon-valence quark (i=2) and
964	c 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
969	c Arrays for interaction configuration recording:
970	c LQA(i) (LQB(j)) - numbers of cut soft pomerons, connected to i-th projectile
971	c (j-th target) nucleon (hadron);
972	c LHA(i) (LHB(j)) - the same for hard pomerons numbers;
973	c IAS(k) (IBS(k)) - number (position in array) of the projectile (target) nucleon,
974	c connected to k-th block of soft pomerons;
975	c NQS(k) - number of soft pomerons in k-th block;
976	c IAH(k) (IBH(k)) - number (position in array) of the projectile (target) nucleon,
977	c connected to k-th hard pomeron;
978	c ZH(k) - impact parameter between the two nucleons connected to k-th hard pomeron
979	c (more exactly exp(-b**2/RP1));
980	c LVA(i)=1 if valence quark from i-th nucleon (i=1 for hadron) is involved into
981	c 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
986	c 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)
1000	201 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
1007	c Target diffraction
1008	IF(IA(2).NE.1)THEN
1009	c ICT - partner target nucleon type (proton - 2 or neutron - 3)
1010	ICT=INT(2.5+PSRAN(B10))
1011	ELSE
1012	c Target proton
1013	ICT=2
1014	ENDIF
1015	WPI=WP0
1016	WMI=WM0
1017	c write (,)'difr'
1018	CALL XXDTG(WPI,WMI,ICP,ICT,0)
1019	RETURN
1020	ENDIF
1021	**************************************************
1022	c For hadron projectile we have given position in transverse plane;
1023	c initially primary hadron is positioned at (X,Y)=(0,0)
1024	DO 1 I=1,3
1025	1 XA(1,I)=0.D0
1026	ENDIF
1027
1028	c-------------------------------------------------
1029	c Inelastic interaction at B<BM (usual case)
1030	c-------------------------------------------------
1031	c NW - number of wounded nucleons in the primary (NW=1 for hadron);
1032	c NT - number of target nucleons being in their active diffractive state;
1033	c LS - number of cut soft pomeron blocks (froissarons);
1034	c NHP - number of cut pomerons having hard block (referred below as hard blocks);
1035	c NQS(k) - number of cut soft pomerons in k-th block;
1036	c IAS(k) (IBS(k)) - number (position in array) of the projectile (target) nucleon,
1037	c connected to k-th block of soft pomerons;
1038	c IAH(k) (IBH(k)) - number 3(position in array) of the projectile (target) nucleon,
1039	c connected to k-th hard pomeron;
1040	c ZH(k) - impact parameter between the two nucleons connected to k-th hard pomeron
1041	c (more exactly exp(-b**2/RP1));
1042	c LQA(i) (LQB(j)) - total number of cut soft pomerons, connected to i-th projectile
1043	c (j-th target) nucleon (hadron);
1044	c LHA(i) (LHB(j)) - total number of cut hard blocks, connected to i-th projectile
1045	c (j-th target) nucleon (hadron);
1046	c LVA(i)=1 if valence quark from i-th nucleon (i=1 for hadron) is involved into
1047	c the hard interaction and LVA(i)=0 otherwise, LVB(j) - similar.
1048	c-------------------------------------------------
1049	c Initialization
1050	2 DO 3 I=1,IA(1)
1051	LHA(I)=0
1052	LVA(I)=0
1053	3 LQA(I)=0
1054	DO 4 I=1,IA(2)
1055	LHB(I)=0
1056	LVB(I)=0
1057	4 LQB(I)=0
1058
1059	c-------------------------------------------------
1060	c The beginning
1061	5 CONTINUE
1062	**************************************************
1063	IF(IA(2).NE.1)THEN
1064	c For target nucleus number of target nucleons being in their active
1065	c diffractive state is simulated (for each nucleon probability equals
1066	c 1./C_n, - shower enhancenment coefficient)
1067	NT=0
1068	DO 6 I=1,IA(2)
1069	6 NT=NT+INT(CC(2)+PSRAN(B10))
1070	c 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
1073	203 FORMAT(2X,'PSCONF: NUMBER OF ACTIVE TARGET NUCLEONS NT=',
1074	* I2)
1075	c PSGEA(NT,XB,2) - target nucleons positions simulation:
1076	CALL PSGEA(NT,XB,2)
1077	c NT - number of target nucleons being in their active diffractive state;
1078	c XB(i,n) - n-th nucleon coordinates (i=1,2,3 corresponds to x,y,z);
1079	c 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
1087	c-------------------------------------------------
1088	c Impact parameter square is simulated uniformly (B2<BM2)
1089	B=BM*DSQRT(PSRAN(B10))
1090	IF(DEBUG.GE.2)WRITE (MONIOU,204)B*AM
1091	204 FORMAT(2X,'PSCONF: IMPACT PARAMETER FOR THE INTERACTION:',
1092	* E10.3,' FM')
1093	c PSGEA(IA(1),XA,1) - projectile nucleons positions simulation:
1094	c IA(1) - projectile nucleus mass number;
1095	c XA(i,n) - n-th nucleon coordinates (i=1,2,3 corresponds to x,y,z);
1096	c 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
1107	c-------------------------------------------------
1108	c 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
1111	205 FORMAT(2X,'PSCONF: ',I2,'-TH PROJECTILE NUCLEON')
1112	c Only nucleons in their active diffractive state are considered (for each nucleon
1113	c 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
1115	c Projectile nucleons positions are shifted according the to impact parameter B
1116	X=XA(IN,1)+B
1117	Y=XA(IN,2)
1118
1119	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
1120	c Projectile diffraction
1121	c For each projectile nucleon (hadron) diffractive dissociation probability is
1122	c (1.D0-CC(ICZ))*PSV(X,Y,XB,NT);
1123	c XXV(X,Y,XB,NT) - nucleon-nucleus scattering eikonal factor
1124	c ( (1-eikonal)**2 ) for given nucleons positions
1125	c (For projectile hadron only in case of JPERI=0, otherwise it was considered
1126	c 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
1131	c ICT - partner target nucleon type (proton - 2 or neutron - 3)
1132	ICT=INT(2.5+PSRAN(B10))
1133	ELSE
1134	c Target proton
1135	ICT=2
1136	ENDIF
1137	IF(IA(1).EQ.1)THEN
1138	c Projectile hadron
1139	IF(DEBUG.GE.2)WRITE (MONIOU,206)
1140	206 FORMAT(2X,'PROJECTILE HADRON DIFFRACTION')
1141	ICP0=ICP
1142	ELSE
1143	c Projectile nucleon
1144	IF(DEBUG.GE.2)WRITE(MONIOU,207)IN
1145	207 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	**************************************************
1159	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
1160
1161	IQS=0
1162	NW=NW+1
1163	c-------------------------------------------------
1164	c Cycle over all target nucleons in active state
1165	DO 11 M=1,NT
1166	c Z - b-factor for pomeron eikonal calculation (exp(-R_ij/R_p))
1167	Z=PSDR(X-XB(M,1),Y-XB(M,2))
1168	c VV - eikonal for nucleon-nucleon (hadron-nucleon) interaction
1169	c (sum of the soft and semihard eikonals)
1170	VV=2.D0*PSFAZ(Z,FSOFT,FHARD,FSHARD)
1171	EV=EXP(-VV)
1172	c EH - eikonal contribution of valence quarks hard interactions
1173	EH=FHARD(1)+FHARD(2)+FHARD(3)
1174	c eh=0.d0
1175	AKS=PSRAN(B10)
1176	c 1.-EXP(-VV)(1.D0-2.D0EH) is the probability for inelastic nucleon-nucleon
1177	c (hadron-nucleon) interaction (for given nucleons positions)
1178	IF(AKS.GT.1.D0-EV(1.D0-2.D0EH))GOTO 11
1179	IF(DEBUG.GE.2)WRITE (MONIOU,208)M
1180	208 FORMAT(2X,'PSCONF: INTERACTION WITH',I2,'-TH TARGET NUCLEON')
1181	C INCREMENT THE NUMBER IWT OF WOUNDED TARGET NUCLEONS
1182	IWT(M) = 1
1183
1184	c-------------------------------------------------
1185	c IQV - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
1186	IQV=0
1187
1188	c 2EHEV = 2EHEXP(-VV) - probability for only valence quarks hard interactions
1189	c (with no one soft or semihard)
1190	SUM=2.D0EHEV
1191
1192	c-------------------------------------------------
1193	IF(AKS.LT.SUM)THEN
1194	AKS1=EH*PSRAN(B10)
1195	IF(AKS1.LT.FHARD(1))THEN
1196	c Rejection in case of valence quark already involved into the interaction
1197	IF(LVA(NW).NE.0)GOTO 11
1198	c LVA(NW)=1 - valence quark-gluon interaction
1199	LVA(NW)=1
1200	IQV=1
1201	ELSEIF(AKS1.LT.FHARD(1)+FHARD(2))THEN
1202	c Rejection in case of valence quark already involved into the interaction
1203	IF(LVB(M).NE.0)GOTO 11
1204	c LVB(M)=1 - gluon-valence quark interaction
1205	LVB(M)=1
1206	IQV=2
1207	ELSE
1208	c Rejection in case of valence quarks already involved into the interaction
1209	IF(LVA(NW)+LVB(M).NE.0)GOTO 11
1210	c 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
1216	c LNH - number of new hard blocks (resulted from current nucleon-nucleon interaction)
1217	LNH=1
1218	GOTO 22
1219	ENDIF
1220	c-------------------------------------------------
1221
1222	c LNH - number of new hard blocks - initialization
1223	LNH=0
1224	c WH - probability to have semihard interaction
1225	WH=2.D0*FSHARD/VV
1226	c N - number of cut pomerons (both soft ones and having hard blocks) for the
1227	c nucleon-nucleon (hadron-nucleon) interaction - is determined according to Poisson
1228	c with average value VV (twice the eikonal)
1229	DO 7 N=1,45
1230	EV=EV*VV/N
1231	SUM=SUM+EV
1232	7 IF(AKS.LT.SUM)GOTO 8
1233
1234	c LNH - number of hard blocks for nucleon-nucleon (hadron-nucleon)
1235	c interaction (according to WH probability)
1236	8 DO 9 I=1,N
1237	9 LNH=LNH+INT(WH+PSRAN(B10))
1238
1239	c-------------------------------------------------
1240	AKS1=.5D0*PSRAN(B10)
1241	c EH is the probability to have valence quarks interactions in addition to the
1242	c soft and semihard
1243	IF(AKS1.LT.EH)THEN
1244	IF(AKS1.LT.FHARD(1))THEN
1245	IF(LVA(NW).NE.0)GOTO 22
1246	c 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
1251	c Gluon-valence quark interaction
1252	LVB(M)=1
1253	IQV=2
1254	ELSE
1255	IF(LVA(NW)+LVB(M).NE.0)GOTO 22
1256	c 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
1265	22 IQS=1
1266	IF(LNH.NE.0)THEN
1267	c-------------------------------------------------
1268	c New hard blocks recording:
1269	c LNH - number of new hard blocks,
1270	c LHA(i) (LHB(j)) - total number of cut hard blocks, connected to i-th projectile
1271	c (j-th target) nucleon (hadron);
1272	c IAH(k) (IBH(k)) - number (position in array) of the projectile (target) nucleon,
1273	c connected to k-th hard block;
1274	c ZH(k) - factor exp(-R_ij/R_p) for k-th hard block;
1275	c IQH(k) - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
1276	c-------------------------------------------------
1277	c 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)
1289	209 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
1294	10 IBH(I1)=M
1295	c-------------------------------------------------
1296	c NHP - total number of hard blocks
1297	NHP=NHP+LNH
1298	ENDIF
1299
1300	c-------------------------------------------------
1301	IF(N.GT.0)THEN
1302	c 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
1310	210 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
1315	11 CONTINUE
1316	c-------------------------------------------------
1317
1318	IF(IQS.NE.0)GOTO 14
1319	c No interaction for projectile nucleon considered
1320	NW=NW-1
1321	12 CONTINUE
1322
1323	c One more projectile spectator (noninteracting) nucleon (spectator positions
1324	c are recorded to simulate nuclear fragmentation)
1325	NS=NS+1
1326	IF(NS.NE.IN)THEN
1327	DO 13 L=1,3
1328	13 XA(NS,L)=XA(IN,L)
1329	ENDIF
1330	14 CONTINUE
1331
1332	c In case of no one interacting (or D-diffracted) nucleon the event is
1333	c rejected, new impact parameter is generated and all the procedure is
1334	c repeated
1335	IF(NS.EQ.IA(1))THEN
1336	IF(DEBUG.GE.3)WRITE (MONIOU,211)
1337	211 FORMAT(2X,'PSCONF: NO ONE NUCLEON (HADRON) INTERACTS - ',
1338	* 'REJECTION')
1339	GOTO 5
1340	ENDIF
1341	c-------------------------------------------------
1342	NWT = 0
1343	C number of interacting target nucleons
1344	DO 102 IT = 1,NT
1345	NWT = NWT + IWT(IT)
1346	102 CONTINUE
1347
1348	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
1349	c Fragmentation of the spectator part of the nucleus
1350	CALL XXFRAGM(NS,XA)
1351	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
1352
1353	c Inelastic interaction - energy sharing procedure
1354	20 IF(NW.NE.0)CALL PSSHAR(LS,NHP,NW,NT)
1355	IF(DEBUG.GE.3)WRITE (MONIOU,212)
1356	212 FORMAT(2X,'PSCONF - END')
1357	RETURN
1358	END
1359	C=======================================================================
1360
1361	SUBROUTINE PSCS(C,S)
1362	c C,S - COS and SIN generation for uniformly distributed angle 0<fi<2*pi
1363	c-----------------------------------------------------------------------
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)
1372	201 FORMAT(2X,'PSCS - COS(FI) AND SIN(FI) ARE GENERATED',
1373	* ' (0<FI<2*PI)')
1374	1 S1=2.D0*PSRAN(B10)-1.D0
1375	S2=2.D0*PSRAN(B10)-1.D0
1376	S3=S1S1+S2S2
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
1382	202 FORMAT(2X,'PSCS: C=',E10.3,2X,'S=',E10.3)
1383	RETURN
1384	END
1385	C=======================================================================
1386
1387	SUBROUTINE PSDEFTR(S,EP,EY)
1388	c Determination of the parameters for the Lorentz transform to the rest frame
1389	c system for 4-vector EP
1390	c-----------------------------------------------------------------------
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
1398	201 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
1409	1 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
1416	2 CONTINUE
1417	IF(DEBUG.GE.3)WRITE (MONIOU,202)EY
1418	202 FORMAT(2X,'PSDEFTR: LORENTZ BOOST PARAMETERS EY(I)=',2X,3E10.3)
1419	RETURN
1420	END
1421	C=======================================================================
1422
1423	SUBROUTINE PSDEFROT(EP,S0X,C0X,S0,C0)
1424	c Determination of the parameters the spacial rotation to the lab. system
1425	c for 4-vector EP
1426	c-----------------------------------------------------------------------
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
1433	201 FORMAT(2X,'PSDEFROT - SPACIAL ROTATION PARAMETERS'/4X,
1434	* '4-VECTOR EP=',2X,4(E10.3,1X))
1435	c 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)
1439	c System rotation to get Pt=0 - Euler angles are determined (C0X = cos theta,
1440	c S0X = sin theta, C0 = cos phi, S0 = sin phi)
1441	C0X=EP(3)/PT
1442	S0X=EP(4)/PT
1443	c 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
1459	202 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
1464	C=======================================================================
1465
1466	FUNCTION PSDR(X,Y)
1467	c PSDR - impact parameter factor for eikonals calculation (exp(-Rij/Rp)=Z)
1468	c-----------------------------------------------------------------------
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
1476	201 FORMAT(2X,'PSDR: NUCLEON COORDINATES - X=',E10.3,2X,'Y=',E10.3)
1477	PSDR=EXP(-(XX+YY)/RP)
1478	IF(DEBUG.GE.3)WRITE (MONIOU,202)PSDR
1479	202 FORMAT(2X,'PSDR=',E10.3)
1480	RETURN
1481	END
1482	C=======================================================================
1483
1484	FUNCTION PSFAP(X,J,L)
1485	C PSFAP - Altarelli-Parisi function (multiplied by X)
1486	c X - light cone momentum share value,
1487	c J - type of the parent parton (0-g,1-q)
1488	c L - type of the daughter parton (0-g,1-q)
1489	C-----------------------------------------------------------------------
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
1496	201 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=(X2+(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
1512	202 FORMAT(2X,'PSFAP=',E10.3)
1513	RETURN
1514	END
1515	C=======================================================================
1516
1517	FUNCTION PSFAZ(Z,FSOFT,FHARD,FSHARD)
1518	c Interaction eikonal for hadron-nucleon (nucleon-nucleon) scattering
1519	c Z - impact parameter factor, Z=exp(-b**2/Rp),
1520	c FSOFT - soft pomeron eikonal - to be determined,
1521	c FSHARD - semihard interaction eikonal (gg) - to be determined,
1522	c FHARD(k) - hard interaction eikonal (k=1 - qg, 2 - gq, 3 - qq) -
1523	c to be determined,
1524	c-----------------------------------------------------------------------
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
1535	201 FORMAT(2X,'PSFAZ - HADRON-NUCLEON (NUCLEON-NUCLEON)',
1536	* ' INTERACTION EIKONAL; Z=',E10.3)
1537	FSOFT=FS*Z
1538	FHARD(3)=SJVZ*(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
1558	1 CONTINUE
1559
1560	PSFAZ=FSOFT+FSHARD
1561	IF(DEBUG.GE.3)WRITE (MONIOU,202)PSFAZ,FSOFT,FSHARD,FHARD
1562	202 FORMAT(2X,'PSFAZ=',E10.3,2X,'FSOFT=',E10.3,2X,'FSHARD=',E10.3/4x,
1563	* 'FHARD=',3E10.3)
1564	RETURN
1565	END
1566	C=======================================================================
1567
1568	FUNCTION PSFBORN(S,T,IQ1,IQ2)
1569	c PSFBORN - integrand for the Born cross-section (matrix element squared)
1570	c S - total c.m. energy squared for the scattering,
1571	c T - invariant variable for the scattering abs[(p1-p3)**2],
1572	c IQ1 - parton type at current end of the ladder (0 - g, 1,2 - q)
1573	c IQ2 - parton type at opposite end of the ladder (0 - g, 1,2 - q)
1574	c-----------------------------------------------------------------------
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
1583	201 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
1587	c Gluon-gluon
1588	PSFBORN=(3.D0-TU/S2+SU/T*2+ST/U*2)4.5D0
1589	ELSEIF(IQ1*IQ2.EQ.0)THEN
1590	c Gluon-quark
1591	PSFBORN=(S2+U2)/T**2+(S/U+U/S)/2.25D0
1592	ELSEIF(IQ1.EQ.IQ2)THEN
1593	c Quark-quark (of the same flavor)
1594	PSFBORN=((S2+U2)/T2+(S2+T2)/U2)/2.25D0
1595	* -S**2/T/U/3.375D0
1596	ELSEIF(IQ1+IQ2.EQ.0)THEN
1597	c Quark-antiquark (of the same flavor)
1598	PSFBORN=((S2+U2)/T2+(U2+T2)/S2)/2.25D0
1599	* -U**2/T/S/3.375D0
1600	ELSE
1601	c Quark-quark (different flavors)
1602	PSFBORN=(S2+U2)/T**2/2.25D0
1603	ENDIF
1604	IF(DEBUG.GE.2)WRITE (MONIOU,202)PSFBORN
1605	202 FORMAT(2X,'PSFBORN=',E10.3)
1606	RETURN
1607	END
1608	C=======================================================================
1609
1610	FUNCTION PSFSH(S,Z,ICZ,IQQ)
1611	c PSFSH - semihard interaction eikonal
1612	c S - energy squared for the interaction (hadron-hadron),
1613	c ICZ - type of the primaty hadron (nucleon)
1614	c Z - impact parameter factor, Z=exp(-b**2/Rp),
1615	c IQQ - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
1616	c-----------------------------------------------------------------------
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
1632	201 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
1646	c Numerical integration over Z1
1647	DO 3 I=1,7
1648	DO 3 M=1,2
1649	Z1=(.5D0(1.D0+XMIN-(2M-3)X1(I)(1.D0-XMIN)))**(1.D0/
1650	* (DELH-DEL))
1651	c SJ is the DLA inclusive hard partonic (gluon-gluon) interaction
1652	c cross-section (inclusive cut ladder cross section) for minimal
1653	c 4-momentum transfer squre QT0 and c.m. energy square s_hard = exp YJ;
1654	c SJB - Born cross-section
1655	CALL PSJINT0(Z1*S,SJ,SJB,IQ,0)
1656	c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic (gluon-gluon)
1657	c interaction cross-section for minimal 4-momentum transfer square QT0 and
1658	c c.m. energy square s_hard = exp YJ; SH=piR_hard2 (R_hard*2=4/QT0)
1659	GY=2.D0SHPSGINT((SJ-SJB)/SH*.5D0)+SJB
1660	IF(DEBUG.GE.3)WRITE (MONIOU,203)Z1*S,GY
1661	203 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))
1668	1 ST2=ST2+A1(J)PSFTILD(Z1XX,ICZ)
1669	* PSFTILD(Z1**(1.D0-XX),2)
1670
1671	RH=RS0-ALF*DLOG(Z1)
1672	PSFSH=PSFSH-A1(I)DLOG(Z1)GY/Z1*DELHZ*(RS/RH)/RHST2
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)
1682	2 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/Z1DELHST2
1687	ENDIF
1688	3 CONTINUE
1689
1690	IF(IQQ.EQ.0)THEN
1691	PSFSH=PSFSH.125D0RR(1.D0-XMIN)/(DELH-DEL)FP0(ICZ)*FP0(2)
1692	* *CD(ICZ)
1693	ELSE
1694	PSFSH=PSFSHDSQRT(RR)/16.D0FP0(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
1704	202 FORMAT(2X,'PSFSH=',E10.3)
1705	RETURN
1706	END
1707	C=======================================================================
1708
1709	FUNCTION PSFTILD(Z,ICZ)
1710	c PSFTILD - auxilliary function for semihard eikonals calculation -
1711	c integration over semihard block light cone momentum share x
1712	c Z - x-cutoff from below,
1713	c ICZ - type of the hadron to which the semihard block is connected
1714	c-----------------------------------------------------------------------
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
1725	201 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+(2M-3)X1(I)))**(1.D0/
1730	* (AHL(ICZ)+1.D0))
1731	1 PSFTILD=PSFTILD+A1(I)XBDEL(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
1734	202 FORMAT(2X,'PSFTILD=',E10.3)
1735	RETURN
1736	END
1737	C=======================================================================
1738
1739	SUBROUTINE PSGEA(IA,XA,JJ)
1740	c PSGEA - nuclear configuration simulation (nucleons positions)
1741	c IA - number of nucleons to be considered
1742	c-----------------------------------------------------------------------
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
1753	201 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
1758	1 ZUK=PSRAN(B10)*CA1(JJ)-1.D0
1759	IF(ZUK)2,2,3
1760	2 TT=RD(JJ)(PSRAN(B10)*.3333D0-1.D0)
1761	GOTO 6
1762	3 IF(ZUK.GT.CA2(JJ))GOTO 4
1763	TT=-DLOG(PSRAN(B10))
1764	GOTO 6
1765	4 IF(ZUK.GT.CA3(JJ))GOTO 5
1766	TT=-DLOG(PSRAN(B10))-DLOG(PSRAN(B10))
1767	GOTO 6
1768	5 TT=-DLOG(PSRAN(B10))-DLOG(PSRAN(B10))-DLOG(PSRAN(B10))
1769	6 IF(PSRAN(B10).GT.1.D0/(1.D0+EXP(-ABS(TT))))GOTO 1
1770	RIM=TT+RD(JJ)
1771	Z=RIM(2.D0PSRAN(B10)-1.D0)
1772	RIM=DSQRT(RIMRIM-ZZ)
1773	XA(I,3)=Z
1774	CALL PSCS(C,S)
1775	XA(I,1)=RIM*C
1776	7 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)
1786	8 SUMM=SUMM+AKS/SQRT(FLOAT(J*K))
1787	9 XA(1,L)=SUMM
1788	ENDIF
1789	IF(DEBUG.GE.3)THEN
1790	WRITE (MONIOU,203)
1791	DO 206 I=1,IA
1792	206 WRITE (MONIOU,204)I,(XA(I,L),L=1,3)
1793	WRITE (MONIOU,202)
1794	ENDIF
1795	202 FORMAT(2X,'PSGEA - END')
1796	203 FORMAT(2X,'PSGEA: POSITIONS OF THE NUCLEONS')
1797	204 FORMAT(2X,'PSGEA: ',I2,' - ',3(E10.3,1X))
1798	RETURN
1799	END
1800	C=======================================================================
1801
1802	FUNCTION PSGINT(Z)
1803	c Auxiliary function for eikonal cross-sections calculation
1804	c GINT = int(dt) [0<t<Z] (1-exp(-t))/t
1805	c-----------------------------------------------------------------------
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(-.5Z(1.+X)))/(1.+X)
1812
1813	IF(DEBUG.GE.2)WRITE (MONIOU,201)Z
1814	201 FORMAT(2X,'PSGINT:',2X,'Z=',E10.3)
1815	PSGINT=0.
1816	DO 5 I=1,7
1817	5 PSGINT=PSGINT+A1(I)*(F(Z,X1(I))+F(Z,-X1(I)))
1818	IF(DEBUG.GE.3)WRITE (MONIOU,202)PSGINT
1819	202 FORMAT(2X,'PSGINT=',E10.3)
1820	RETURN
1821	END
1822	C=======================================================================
1823
1824	FUNCTION PSHARD(S,ICZ)
1825	c PSHARD - hard quark-quark interaction cross-section
1826	c S - energy squared for the interaction (hadron-hadron),
1827	c ICZ - type of the primaty hadron (nucleon)
1828	c-----------------------------------------------------------------------
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
1843	201 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
1850	c Numerical integration over Z1
1851	DO 2 I=1,7
1852	DO 2 M=1,2
1853	Z1=(.5D0(1.D0+XMIN-(2M-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-Z1XX)AHV(ICZ)
1861	* (1.D0-Z1(1.D0-XX))AHV(2)
1862	1 CONTINUE
1863
1864	c SJ is the DLA inclusive hard partonic (gluon-gluon) interaction
1865	c cross-section (inclusive cut ladder cross section) for minimal
1866	c 4-momentum transfer squre QT0 and c.m. energy square s_hard = exp YJ;
1867	c SJB - Born cross-section
1868	CALL PSJINT0(Z1*S,SJ,SJB,1,1)
1869	c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic (quark-quark)
1870	c interaction cross-section for minimal 4-momentum transfer square QT0 and
1871	c c.m. energy square s_hard = exp YJ; SH=piR_hard2 (R_hard*2=4/QT0)
1872	GY=2.D0SHPSGINT((SJ-SJB)/SH*.5D0)+SJB
1873
1874	IF(DEBUG.GE.3)WRITE (MONIOU,203)Z1*S,GY
1875	203 FORMAT(2X,'PSHARD:',2X,'S_HARD=',E10.3,2X,'SIGMA_HARD=',E10.3)
1876	PSHARD=PSHARD-A1(I)DLOG(Z1)GY/Z1*DELHST2
1877	2 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
1891	c Hard cross-section is divided by Regge radius RS0 and multiplied by
1892	c shower enhancement coefficient CD(ICZ) - to be used for the eikonal
1893	c calculation
1894	PSHARD=PSHARD/(8.D0PIRS0)*CD(ICZ)
1895	IF(DEBUG.GE.2)WRITE (MONIOU,202)PSHARD
1896	202 FORMAT(2X,'PSHARD=',E10.3)
1897	RETURN
1898	END
1899	C=======================================================================
1900
1901	SUBROUTINE PSHOT(WP0,WM0,Z,IPC,EPC,IZP,IZT,ICZ,IQQ)
1902	c Semihard jets production simulation (resulted from parton-parton
1903	c interaction);
1904	c WP0,WM0 - light cone momenta shares (E+-P_l) for the initial partons
1905	c IZP, IZT - types for target and projectile nucleons (hadron)
1906	c WPQ - light cone momenta for the soft preevolution - to be determined below
1907	c IQQ - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
1908	c-----------------------------------------------------------------------
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
1934	201 FORMAT(2X,'PSHOT - SEMIHARD INTERACTION SIMULATION:'/
1935	* 4X,'TYPE OF THE INTERACTION:',I2/
1936	* 4X,'INITIAL LIGHT CONE MOMENTA:',2E10.3)
1937	c S - total energy squared for the semihard interaction (including preevolution)
1938	NJTOT0=NJTOT
1939	IZP0=IZP
1940	IZT0=IZT
1941
1942	301 S=WP0*WM0
1943	NJTOT=NJTOT0
1944	IZP=IZP0
1945	IZT=IZT0
1946
1947	IF(IQQ.EQ.3)THEN
1948	c WPI,WMI - light cone momenta for the hard interaction
1949	WPI=WP0
1950	WMI=WM0
1951	c PSJINT0(S,SJ,SJB,1,1) - cross-sections interpolation:
1952	c SJ - inclusive hard quark-quark interaction
1953	c cross-section (inclusive cut ladder cross section) for minimal
1954	c 4-momentum transfer square QT0 and c.m. energy square s_hard = S;
1955	c SJB - Born cross-section
1956	CALL PSJINT0(S,SJ,SJB,1,1)
1957	c GY= Sigma_hard_tot(YJ,QT0) - total hard quark-quark
1958	c interaction cross-section for minimal 4-momentum transfer square QT0 and
1959	c c.m. energy square s_hard = S
1960	GY=2.D0SHPSGINT((SJ-SJB)/SH*.5D0)+SJB
1961
1962	ELSE
1963	c-------------------------------------------------
1964	c Rejection function normalization
1965	c-------------------------------------------------
1966	c XMIN corresponds to minimal energy squared for the hard interaction - 4.D0*(QT0+AMJ0)
1967	c AMJ0 - jet mass squared (could be put equal zero)
1968	XMIN=4.D0*(QT0+AMJ0)/S
1969	XMIN1=XMIN**(DELH-DEL)
1970	c S - maximal available energy for the rejection function normalization
1971	c Auxilliary type of parton (1 - gluon, 2 - (anti-)quark)
1972	IQ=(IQQ+1)/2
1973	c Rejection function initialization (corresponding to maximal preevolution - minimal x):
1974	c 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.D0BET)
1977	ELSE
1978	GB0=(1.D0-XMIN)**BET
1979	ENDIF
1980
1981	c SJ0 is the inclusive hard (parton IQ - gluon) interaction
1982	c cross-section (inclusive cut ladder cross section) for minimal
1983	c 4-momentum transfer square QT0 and c.m. energy square s_hard = SI;
1984	c SJB0 - Born cross-section
1985	CALL PSJINT0(S,SJ,SJB,IQ,0)
1986	c GY= Sigma_hard_tot(YJ,QT0) - total hard (parton IQ - gluon)
1987	c interaction cross-section for minimal 4-momentum transfer square QT0 and
1988	c c.m. energy square s_hard = SI
1989	GY0=2.D0SHPSGINT((SJ-SJB)/SH*.5D0)+SJB
1990	GB0=GB0GY0/SDELH/RS0Z
1991	c-------------------------------------------------
1992	c End of rejection function normalization
1993	c-------------------------------------------------
1994
1995	c-------------------------------------------------
1996	c The sharing of the light cone momenta between soft preevolution and
1997	c hard interaction:
1998	c ( first energy-momentum is shared according to
1999	c f_hard(YJ)~ZPM**(DELH-DEL-1) and then rejected as
2000	c W_rej ~Sigma_hard_tot(YJ) / exp(DELH*YJ)
2001	c ZPM = s_hard / S
2002	c YJ = ln s_hard - rapidity range for the hard parton-parton interaction;
2003	c-------------------------------------------------
2004	1 ZPM=(XMIN1+PSRAN(B10)(1.D0-XMIN1))*(1.D0/(DELH-DEL))
2005	c SJ is the DLA inclusive hard partonic (gluon-gluon) interaction
2006	c cross-section (inclusive cut ladder cross section) for minimal
2007	c 4-momentum transfer square QT0 and c.m. energy square s_hard = exp YJ;
2008	c SJB - Born cross-section
2009	CALL PSJINT0(ZPM*S,SJ,SJB,IQ,0)
2010	YJ=DLOG(ZPM*S)
2011	c RH - interaction radius due to soft preevolution
2012	RH=RS0-ALF*DLOG(ZPM)
2013
2014	IF(IQQ.EQ.0)THEN
2015	c XP, XM - light cone momunta shares for the hard interaction
2016	XP=ZPM**PSRAN(B10)
2017	XM=ZPM/XP
2018	c Ysoft = - ln ZPM - part of rejection function,
2019	c (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
2021	c 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
2035	c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic
2036	c interaction cross-section for minimal 4-momentum transfer square QT0 and
2037	c c.m. energy square s_hard = exp YJ
2038	GY=2.D0SHPSGINT((SJ-SJB)/SH*.5D0)+SJB
2039
2040	c-------------------------------------------------
2041	c GBYJ - rejection function for the YJ (ZPM) simulation:
2042	c GBYJ ~ Sigma_hard_tot(YJ,QT0) / exp(DELHYJ) exp(-b**2/RH) / RH,
2043	GBYJ=GBYJGYEXP(-DELHYJ)/GB0Z**(RS/RH)/RH
2044	IF(PSRAN(B10).GT.GBYJ)GOTO 1
2045	ENDIF
2046	c-------------------------------------------------
2047	S=WPI*WMI
2048
2049	IF(DEBUG.GE.2)WRITE (MONIOU,203)S
2050	203 FORMAT(2X,'PSHOT: MASS SQUARED FOR THE HARD PARTON-PARTON',
2051	* ' INTERACTION:',E10.3)
2052
2053	c In case of valence quark hard interaction the type of quark is determined by the
2054	c procedure PSVDEF - flavor combinatorics (not good here); IQC(1) - flavor
2055	c for the upper quark (0 in case of gluon),
2056	c IQC(2) - the same for the lower one
2057	DO 302 I=1,8
2058	DO 302 M=1,2
2059	302 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
2101	c 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
2108	303 EPQ(I+4(L-1),M)=EPC(I+4(L-1),M)
2109	c Minimal 4-momentum transfer square for gluon-gluon (virtual) interaction
2110	QMINN=MAX(QMIN(1),QMIN(2))
2111	SI=PSNORM(EPT)
2112
2113	5 CONTINUE
2114	c 4-momentum squared (c.m. energy square for gluon-gluon (virtual)
2115	c interaction)
2116	IF(DEBUG.GE.2)WRITE (MONIOU,208)ILAD, SI,IQC,EPT
2117	208 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)
2129	501 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
2133	502 ebal(l)=ebal(l)-epjet(l,m,i)
2134	endif
2135	503 continue
2136	c 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
2146	c 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))
2151	c WWMIN is the minimal energy square needed for triple s-channel gluons
2152	c 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))
2155	c SJB/SJ is the probability for the last pair of gluons production
2156	c (SJB is the Born cross-section and SJ is the inclusive interaction
2157	c (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
2162	251 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
2176	c Current s-channel gluon is simulated either above the run (JJ=1) or
2177	c below it (JJ=2)
2178	JJ=INT(1.5D0+DSJ+PSRAN(B10))
2179
2180	AQ=-(SI+AMJ0+2.D0PTDSQRT(QT0))/WW
2181	BQ=(QT0+AMJ0)/WW
2182	CQ=QT0/WW
2183	PQ=-AQ**2/3.D0+BQ
2184	QQ=AQ*3/13.5D0-AQBQ/3.D0+CQ
2185	PQ=DSQRT(-PQ/3.D0)
2186	COSQ=-.5D0QQ/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
2191	c XMIN is the minimal longitudinal momentum transfer share in current
2192	c ladder run (corresponding to minimal 4-momentum transfer square QMIN(JJ))
2193	XMIN=1.D0+AQ/3.D0-2.D0PQCOS(FQ)
2194	XMAX=1.D0+AQ/3.D0-PQ(DSQRT(3.D0)SIN(FQ)-COS(FQ))
2195	c QQMAX is the maximal 4-momentum transfer square in the current run
2196	c (corresponding to X=XMIN and 4-momentum transfer at next simulation
2197	c 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.D0PTDSQRT(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.D0PTDSQRT(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..95D0XMAX.OR.XM0.LT.1.05D0XMIN)
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=SJ0QM0/QLOGPSUDS(QM0,IQP(JJ))*1.5D0
2227	IF(XM0.LE..5D0)THEN
2228	GB0=GB0XM0*(1.D0-DELH)
2229	ELSE
2230	GB0=GB0(1.D0-XM0)2.D0**DELH
2231	ENDIF
2232	c 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.D0XMIN)*DELH-1.D0)/DELH/
2242	* DLOG(2.D0*(1.D0-XMAX)))
2243	ENDIF
2244
2245	7 CONTINUE
2246	c Simulation of the longitudinal momentum transfer share in current
2247	c 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
2255	c Effective momentum squared QQ in the ladder run is simulated
2256	c first as dq2/q4 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
2260	253 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)
2274	c 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)
2281	c S2 is the maximal c.m. energy square for the parton-parton interaction
2282	c in the next ladder run
2283	S2=X(1.D0-ZMIN)WW-PT2
2284	c Rejection in case of too low WW2 (insufficient for elastic gluon-gluon
2285	c 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
2293	c GB7 is the rejection function for X and Q**2 simulation. It consists
2294	c from factor
2295	c Q2/Qmin2 * ln(Qmin2/Lambda_qcd2)/ln(Q2/Lambda_qcd2)
2296	c from Q*2 simulation and factor SJ/(XWW)*DELH const from X simulation
2297	GB7=(SJ1+SJ2)/DLOG(QT2/ALM)QQPSUDS(QQ,IQP(JJ))/GB0
2298
2299	*********************************************************
2300	IF(X.LE..5D0)THEN
2301	GB7=GB7X*(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)
2316	31 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
2326	32 EQJ(I,1)=0.D0
2327
2328	IPQ(JQ,JJ)=IPQ(1,JJ)
2329	DO 135 I=1,4
2330	135 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)
2348	33 EQJ(I,2)=0.D0
2349
2350	ELSE
2351	IQ1=INT(3.D0PSRAN(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
2361	34 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
2393	35 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
2398	36 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
2404	37 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
2409	38 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
2414	39 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
2421	40 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
2426	30 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
2436	209 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
2440	8 EPT(I)=EPT(I)-EP3(I)
2441	c C.m. energy square, minimal 4-momentum transfer square and gluon 4-vector
2442	c for the next ladder run
2443	QMIN(JJ)=QQ
2444	QMINN=QMIN2
2445
2446	c Next simulation step will be considered for current ladder
2447	GOTO 5
2448	C------------------------------------------------
2449
2450	C------------------------------------------------
2451	c The last gluon pair production (elastic scattering) in the ladder
2452	c is simulated
2453	12 CONTINUE
2454	IF(DEBUG.GE.2)WRITE (MONIOU,211)SI
2455	211 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=.25D0SI2/DLOG(TMIN(1.D0-XMIN)/ALM)*2
2468	* PSFBORN(SI,.5D0*SI,IQC(1),IQC(2))
2469	ENDIF
2470
2471	C------------------------------------------------
2472	c 4-momentum transfer squared is simulated first as dq_t2/q_t4 from
2473	c tmin to s/2
2474	13 Q2=TMIN/(1.D0-PSRAN(B10)(1.D0-2.D0TMIN/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=Q22/DLOG(QT2/ALM)2/GB0*
2486	* PSFBORN(SI,TQ,IQC(1),IQC(2))
2487	IF(DEBUG.GE.3)WRITE (MONIOU,241)Q2,GB
2488	241 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
2496	51 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)
2507	52 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
2513	53 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
2517	54 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
2522	55 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
2528	56 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)
2545	57 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)
2554	58 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
2560	59 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
2564	60 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
2571	61 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)
2580	62 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
2586	63 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
2590	64 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)
2601	65 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
2606	66 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
2619	67 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
2630	68 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)
2639	69 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
2645	70 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
2649	71 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
2658	240 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)
2682	c 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
2712	72 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)
2719	73 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
2725	74 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
2730	75 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)
2737	76 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
2743	77 EPC(I+4*(JQ-1),JM)=EQJ(I,1)
2744	ENDIF
2745	IQJ(1)=IQJ(2)
2746	DO 78 I=1,4
2747	78 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)
2754	79 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
2760	80 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
2765	81 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
2770	82 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
2776	83 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)
2783	84 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
2789	85 EPC(I+4*(JQ-1),3-JM)=EQJ(I,1)
2790	ENDIF
2791	IQJ(1)=IPQ(1,JM)
2792	DO 86 I=1,4
2793	86 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
2806	212 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
2812	87 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
2819	88 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
2824	89 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
2831	90 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
2838	91 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
2845	92 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
2850	93 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
2857	94 EPC(I+4*(JQ-1),JM)=EQJ(I,1)
2858	ENDIF
2859	ENDIF
2860	C------------------------------------------------
2861
2862	IF(DEBUG.GE.3)WRITE (MONIOU,217)
2863	217 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
2871	500 ebal(l)=ebal(l)-epjet(l,m,i)
2872	c write (,)'ebal',ebal
2873	RETURN
2874	END
2875	C=======================================================================
2876
2877	SUBROUTINE PSJDEF(IPJ,IPJ1,EPJ,EPJ1,JFL)
2878	c Procedure for jet hadronization - each gluon is
2879	c considered to be splitted into quark-antiquark pair and usual soft
2880	c strings are assumed to be formed between quark and antiquark
2881	c-----------------------------------------------------------------------
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
2890	c if(ipj*ipj1.gt.0.and.iabs(ipj).ne.3.and.iabs(ipj).le.4.
2891	c * and.iabs(ipj1).ne.3.and.iabs(ipj1).le.4.or.
2892	c * ipj*ipj1.lt.0.and.(iabs(ipj).eq.3.or.iabs(ipj).gt.4.
2893	c * or.iabs(ipj1).eq.3.or.iabs(ipj1).eq.4))then
2894	c write (,)'ipj,ipj1',ipj,ipj1
2895	c read (,)
2896	c endif
2897
2898	IF(DEBUG.GE.2)WRITE (MONIOU,201)IPJ,IPJ1,EPJ,EPJ1
2899	201 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
2903	1 EPT(I)=EPJ(I)+EPJ1(I)
2904
2905	c Invariant mass squared for the jet
2906	WW=PSNORM(EPt)
2907	c 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)
2936	2 EPJET(I,2,NJTOT)=EPJ1(I)
2937
2938	IF(DEBUG.GE.3)WRITE (MONIOU,202)
2939	202 FORMAT(2X,'PSJDEF - END')
2940	RETURN
2941	END
2942	C=======================================================================
2943
2944	FUNCTION PSJET(Q1,Q2,S,S2MIN,J,L)
2945	C PSJET - inclusive hard cross-section calculation (one more run is added
2946	c to the ladder) - for any ordering
2947	c Q1 - effective momentum cutoff for current end of the ladder,
2948	c Q2 - effective momentum cutoff for opposide end of the ladder,
2949	c S - total c.m. energy squared for the ladder,
2950	c S2MIN - minimal c.m. energy squared for BORN process (above Q1 and Q2)
2951	c J - parton type at current end of the ladder (0 - g, 1 - q)
2952	c L - parton type at opposite end of the ladder (1 - g, 2 - q)
2953	C-----------------------------------------------------------------------
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
2965	201 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.D0QT0/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.D0QT0/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
2993	203 FORMAT(2X,'PSJET:',2X,'QMIN=',E10.3,2X,'QMAX=',E10.3)
2994	IF(QMAX.GT.QMIN)THEN
2995
2996	c Numerical integration over transverse momentum square;
2997	c Gaussian integration is used
2998	DO 3 I=1,7
2999	DO 3 M=1,2
3000	QI=2.D0QMIN/(1.D0+QMIN/QMAX+(2M-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
3008	204 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+(2M1-3)X1(I1)(ZMAX-ZMIN)))**
3014	* (1.D0/DELH)
3015	QT=QI(1.D0-Z)*2
3016	S2=ZS-QI(1.D0-Z)
3017
3018	SJ=0.D0
3019	DO 1 K=1,2
3020	1 SJ=SJ+PSJINT(QI,Q2,S2,K,L)PSFAP(Z,J,K-1)Z
3021	2 FSJ=FSJ+A1(I1)SJ/DLOG(QT/ALM)/Z*DELH
3022	FSJ=FSJ*(ZMAX-ZMIN)
3023	ENDIF
3024
3025	3 PSJET=PSJET+A1(I)FSJQI*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
3029	202 FORMAT(2X,'PSJET=',E10.3)
3030	RETURN
3031	END
3032	C=======================================================================
3033
3034	FUNCTION PSJET1(Q1,Q2,S,S2MIN,J,L)
3035	C PSJET1 - inclusive hard cross-section calculation (one more run is added
3036	c to the ladder) - for strict ordering
3037	c Q1 - effective momentum cutoff for current end of the ladder,
3038	c Q2 - effective momentum cutoff for opposide end of the ladder,
3039	c S - total c.m. energy squared for the ladder,
3040	c S2MIN - minimal c.m. energy squared for BORN process (above Q1 and Q2)
3041	c J - parton type at current end of the ladder (0 - g, 1 - q)
3042	c L - parton type at opposite end of the ladder (1 - g, 2 - q)
3043	C-----------------------------------------------------------------------
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
3055	201 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.D0QT0/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.D0QT0/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
3083	203 FORMAT(2X,'PSJET1:',2X,'QMIN=',E10.3,2X,'QMAX=',E10.3)
3084	IF(QMAX.GT.QMIN)THEN
3085
3086	c Numerical integration over transverse momentum square;
3087	c Gaussian integration is used
3088	DO 3 I=1,7
3089	DO 3 M=1,2
3090	QI=2.D0QMIN/(1.D0+QMIN/QMAX+(2M-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
3098	204 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+(2M1-3)X1(I1)(ZMAX-ZMIN)))**
3104	* (1.D0/DELH)
3105	QT=QI(1.D0-Z)*2
3106	S2=ZS-QI(1.D0-Z)
3107
3108	SJ=0.D0
3109	DO 1 K=1,2
3110	1 SJ=SJ+PSJINT1(QI,Q2,S2,K,L)PSFAP(Z,J,K-1)Z
3111
3112	2 FSJ=FSJ+A1(I1)SJ/DLOG(QT/ALM)/Z*DELH
3113	FSJ=FSJ*(ZMAX-ZMIN)
3114	ENDIF
3115
3116	3 PSJET1=PSJET1+A1(I)FSJQI*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
3120	202 FORMAT(2X,'PSJET1=',E10.3)
3121	RETURN
3122	END
3123	C=======================================================================
3124
3125	FUNCTION PSJINT(Q1,Q2,S,M,L)
3126	C PSJINT - inclusive hard cross-section interpolation - for any ordering
3127	c in the ladder
3128	c Q1 - effective momentum cutoff for current end of the ladder,
3129	c Q2 - effective momentum cutoff for opposide end of the ladder,
3130	c S - total c.m. energy squared for the ladder,
3131	c M - parton type at current end of the ladder (1 - g, 2 - q)
3132	c L - parton type at opposite end of the ladder (1 - g, 2 - q)
3133	C-----------------------------------------------------------------------
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
3144	201 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
3151	202 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
3186	1 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
3204	2 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
3215	3 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
3241	4 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
3261	5 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
3267	C=======================================================================
3268
3269	SUBROUTINE PSJINT0(S,SJ,SJB,M,L)
3270	C PSJINT0 - inclusive hard cross-section interpolation - for minimal
3271	c effective momentum cutoff in the ladder
3272	c S - total c.m. energy squared for the ladder,
3273	c SJ - inclusive jet cross-section,
3274	c SJB - Born cross-section,
3275	c M - parton type at current end of the ladder (0 - g, 1 - q)
3276	c L - parton type at opposite end of the ladder (0 - g, 1 - q)
3277	C-----------------------------------------------------------------------
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
3288	201 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
3294	202 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)
3313	1 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
3320	C=======================================================================
3321
3322	FUNCTION PSJINT1(Q1,Q2,S,M,L)
3323	C PSJINT1 - inclusive hard cross-section interpolation - for strict ordering
3324	c in the ladder
3325	c Q1 - effective momentum cutoff for current end of the ladder,
3326	c Q2 - effective momentum cutoff for opposide end of the ladder,
3327	c S - total c.m. energy squared for the ladder,
3328	c M - parton type at current end of the ladder (1 - g, 2 - q)
3329	c L - parton type at opposite end of the ladder (1 - g, 2 - q)
3330	C-----------------------------------------------------------------------
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
3341	201 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
3349	202 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
3384	1 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
3402	2 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
3413	3 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
3440	4 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
3460	5 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
3466	C=======================================================================
3467
3468	FUNCTION PSLAM(S,A,B)
3469	c Kinematical function for two particle decay - maximal Pt-value
3470	c A - first particle mass squared,
3471	C B - second particle mass squared,
3472	C S - two particle invariant mass
3473	c-----------------------------------------------------------------------
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
3479	201 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
3483	202 FORMAT(2X,'PSLAM=',E10.3)
3484	RETURN
3485	END
3486	C=======================================================================
3487
3488	FUNCTION PSNORM(EP)
3489	c 4-vector squared calculation
3490	c-----------------------------------------------------------------------
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
3497	201 FORMAT(2X,'PSNORM - 4-VECTOR SQUARED FOR ',
3498	* 'EP=',4(E10.3,1X))
3499	PSNORM=EP(1)**2
3500	DO 1 I=1,3
3501	1 PSNORM=PSNORM-EP(I+1)**2
3502	IF(DEBUG.GE.3)WRITE (MONIOU,202)PSNORM
3503	202 FORMAT(2X,'PSNORM=',E10.3)
3504	RETURN
3505	END
3506	C=======================================================================
3507
3508	SUBROUTINE PSREC(EP,QV,ZV,QM,IQV,LDAU,LPAR,IQJ,EQJ,JFL,JQ)
3509	c Jet reconstructuring procedure - 4-momenta for all final jets are determined
3510	c EP(i) - jet 4-momentum
3511	C-----------------------------------------------------------------------
3512	c QV(i,j) - effective momentum for the branching of the parton in i-th row
3513	c on j-th level (0 - in case of no branching)
3514	c ZV(i,j) - Z-value for the branching of the parton in i-th row
3515	c on j-th level
3516	c QM(i,j) - mass squared for the parton in i-th row
3517	c on j-th level
3518	c IQV(i,j) - flavours for the parton in i-th row on j-th level
3519	c LDAU(i,j) - first daughter row for the branching of the parton in i-th row
3520	c on j-th level
3521	c LPAR(i,j) - the parent row for the parton in i-th row on j-th level
3522	C-----------------------------------------------------------------------
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
3534	201 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)
3539	1 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
3544	2 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
3551	3 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)
3560	4 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
3565	211 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
3570	5 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
3573	212 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.D0PSRAN(B10)+1.D0)(3-2*JQ)
3579	DO 6 I=1,4
3580	6 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
3585	7 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
3593	8 EPQ(4*(M-1)+I,NROW,NLEV)=EPJ(I)
3594	ENDIF
3595	9 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)
3600	204 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
3606	10 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))2QV(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
3624	11 EPV(I,LDROW,NLEV+1)=EP3(I)
3625	IF(DEBUG.GE.3)WRITE (MONIOU,206)NLEV+1,LDROW,EP3
3626	206 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
3639	12 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)
3647	13 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
3657	14 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
3667	15 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
3675	16 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
3684	17 CONTINUE
3685	IF(NLEV.EQ.1)THEN
3686	IQJ(1)=IPQ(1,1,1)
3687	DO 18 I=1,4
3688	18 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
3692	19 EQJ(I,2)=EPQ(I+4,1,1)
3693	ENDIF
3694	IF(DEBUG.GE.3)WRITE (MONIOU,202)iqj
3695	202 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
3706	20 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
3710	21 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
3716	22 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
3721	23 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
3733	24 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
3739	25 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
3747	26 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
3756	C=======================================================================
3757
3758	FUNCTION PSREJS(S,Z,IQQ)
3759	c PSREJS - rejection function for the energy sharing for semihard
3760	c interaction (Hi_semihard(S)/S**delh)
3761	c S - energy squared for the semihard interaction,
3762	c Z - impact parameter factor, Z=exp(-b**2/Rp),
3763	c IQQ - type of the hard interaction (0 - gg, 1 - qg, 2 - gq)
3764	c-----------------------------------------------------------------------
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
3775	201 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
3781	c Numerical integration over Z1
3782	DO 2 I=1,7
3783	DO 2 M=1,2
3784	Z1=(.5D0(1.D0+XMIN-(2M-3)X1(I)(1.D0-XMIN)))**(1.D0/
3785	*(DELH-DEL))
3786
3787	c SJ is the inclusive hard partonic interaction
3788	c cross-section (inclusive cut ladder cross section) for minimal
3789	c 4-momentum transfer squre QT0 and c.m. energy square s_hard = exp YJ;
3790	c SJB - Born cross-section
3791	YJ=DLOG(Z1*S)
3792	CALL PSJINT0(Z1*S,SJ,SJB,IQQ,0)
3793	c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic
3794	c interaction cross-section for minimal 4-momentum transfer square QT0 and
3795	c c.m. energy square s_hard = exp YJ; SH=piR_hard2 (R_hard*2=4/QT0)
3796	GY=2.D0SHPSGINT((SJ-SJB)/SH*.5D0)+SJB
3797	RH=RS0-ALF*DLOG(Z1)
3798
3799	IF(IQQ.NE.0)THEN
3800	PSREJS=PSREJS+A1(I)GY/(Z1S)*DELHZ*(RS0/RH)/RH
3801	* (1.D0-Z1)*BET
3802	ELSE
3803	ST2=0.D0
3804	DO 1 J=1,7
3805	1 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/(Z1S)DELHZ*(RS0/RH)/RHST2
3809	ENDIF
3810	2 CONTINUE
3811	PSREJS=DLOG(PSREJS*(1.D0-XMIN)/Z)
3812	IF(DEBUG.GE.2)WRITE (MONIOU,202)PSREJS
3813	202 FORMAT(2X,'PSREJS=',E10.3)
3814	RETURN
3815	END
3816	C=======================================================================
3817
3818	FUNCTION PSREJV(S)
3819	c PSREJV - rejection function for the energy sharing for quark-quark hard
3820	c interaction (sigma_hard(S)/S**delh)
3821	c S - energy squared for the hard interaction
3822	c-----------------------------------------------------------------------
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
3832	201 FORMAT(2X,'PSREJV - REJECTION FUNCTION TABULATION: ',
3833	* 'S=',E10.3)
3834	c SJ is the inclusive hard QUARK-QUARK interaction
3835	c cross-section (inclusive cut ladder cross section) for minimal
3836	c 4-momentum transfer squre QT0 and c.m. energy square s;
3837	c SJB - Born cross-section
3838	CALL PSJINT0(S,SJ,SJB,1,1)
3839
3840	c GY= Sigma_hard_tot(YJ,QT0) - total hard partonic (quark-quark)
3841	c interaction cross-section for minimal 4-momentum transfer square QT0 and
3842	c c.m. energy square s; SH=piR_hard2 (R_hard*2=4/QT0)
3843	GY=2.D0SHPSGINT((SJ-SJB)/SH*.5D0)+SJB
3844	PSREJV=DLOG(GY/S**DELH)
3845	IF(DEBUG.GE.3)WRITE (MONIOU,202)PSREJV
3846	202 FORMAT(2X,'PSREJV=',E10.3)
3847	RETURN
3848	END
3849	C=======================================================================
3850
3851	FUNCTION PSRJINT(YJ,Z0,IQQ)
3852	c PSRJINT - Rejection function for the energy sharing (Hi_semih(S)/S**delh)
3853	c YJ=ln S,
3854	c Z0 - impact parameter factor, Z0=exp(-b**2/Rp),
3855	c IQQ - type of hard interaction (0 - gg; 1 - qg, 2 - gq; 3 - qq)
3856	c-----------------------------------------------------------------------
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
3869	201 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.D0RJV(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
3912	1 CONTINUE
3913
3914	IF(JZ.NE.0)THEN
3915	PSRJINT=EXP(A(1)+(A(2)-A(1))WZ+(A(3)+A(1)-2.D0A(2))WZ
3916	* (WZ-1.D0).5D0)Z
3917	ELSE
3918	PSRJINT=(EXP(A(2))WZ+(EXP(A(3))-2.D0EXP(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
3924	202 FORMAT(2X,'PSRJINT=',E10.3)
3925	RETURN
3926	END
3927	C=======================================================================
3928
3929	FUNCTION PSROOT(QLMAX,G,J)
3930	c PSROOT - effective momentum tabulation for given set of random number
3931	c values and maximal effective momentum QMAX values - according to the
3932	c probability of branching: (1 - timelike Sudakov formfactor)
3933	c QLMAX - ln QMAX/16/QTF,
3934	c G - dzeta number (some function of ksi)
3935	c J - type of the parton (1-g,2-q)
3936	c-----------------------------------------------------------------------
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
3944	201 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
3952	1 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
3973	202 FORMAT(2X,'PSROOT=',E10.3)
3974	RETURN
3975	END
3976	C=======================================================================
3977
3978	SUBROUTINE PSROTAT(EP,S0X,C0X,S0,C0)
3979	c Spacial rotation to the lab. system for 4-vector EP
3980	c-----------------------------------------------------------------------
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
3987	201 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
3998	202 FORMAT(2X,'PSROTAT: ROTATED 4-VECTOR EP=',
3999	* 2X,4E10.3)
4000	RETURN
4001	END
4002	C=======================================================================
4003
4004	FUNCTION PSQINT(QLMAX,G,J)
4005	c PSQINT - effective momentum interpolation for given random number G
4006	c and maximal effective momentum QMAX
4007	c QLMAX - ln QMAX/16/QTF,
4008	c G - random number (0<G<1)
4009	c J - type of the parton (1-g,2-q)
4010	c-----------------------------------------------------------------------
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
4021	201 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.D0DLOG(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
4043	1 PSQINT=PSQINT+QRT(I+I1,K+K1,J)WI(I1)WK(K1)
4044	IF(PSQINT.LE.0.D0)PSQINT=0.D0
4045	PSQINT=16.D0QTFEXP(PSQINT)
4046	IF(DEBUG.GE.3)WRITE (MONIOU,202)PSQINT
4047	202 FORMAT(2X,'PSQINT=',E10.3)
4048	RETURN
4049	END
4050	C=======================================================================
4051
4052	SUBROUTINE PSSHAR(LS,NHP,NW,NT)
4053	c Inelastic interaction - energy sharing procedure:
4054	c LS - total number of cut soft pomeron blocks (froissarons),
4055	c NHP - total number of hard pomerons,
4056	c NW - number of interacting projectile nucleons (excluding diffracted),
4057	c NT - number of target nucleons in active state
4058	c-----------------------------------------------------------------------
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
4084	201 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
4091	101 LQA0(I)=LQA(I)
4092	DO 102 I=1,NT
4093	102 LQB0(I)=LQB(I)
4094
4095	100 NSH=NSH1
4096	NJTOT=0
4097	DO 103 I=1,NW
4098	103 LQA(I)=LQA0(I)
4099	DO 104 I=1,NT
4100	104 LQB(I)=LQB0(I)
4101	c-------------------------------------------------
4102	c Initial nucleons (hadrons) types recording
4103	IF(IA(1).NE.1)THEN
4104	c IZP(i) - i-th projectile nucleons type (proton - 2, neutron - 3)
4105	DO 1 I=1,NW
4106	1 IZP(I)=INT(2.5+PSRAN(B10))
4107	ELSE
4108	c IZP(1)=ICP - projectile hadron type
4109	IZP(1)=ICP
4110	ENDIF
4111	IF(IA(2).NE.1)THEN
4112	c IZT(j) - j-th target nucleon type (proton - 2 or neutron - 3)
4113	DO 2 I=1,NT
4114	2 IZT(I)=INT(2.5+PSRAN(B10))
4115	ELSE
4116	c Target proton
4117	IZT(1)=2
4118	ENDIF
4119	c-------------------------------------------------
4120
4121	c WREJ - parameter for energy sharing (to minimise rejection)
4122	WREJ=.0001D0
4123
4124	3 CONTINUE
4125
4126	IF(NHP.NE.0)THEN
4127	IF(DEBUG.GE.3)WRITE (MONIOU,211)NHP
4128	211 FORMAT(2X,'PSSHARE: NUMBER OF HARD POMERONS NHP=',I3)
4129	c-------------------------------------------------
4130	c-------------------------------------------------
4131	c Rejection function initialization:
4132	c-------------------------------------------------
4133	c energy-momentum will be shared between pomerons
4134	c according to s**DEL dependence for soft pomeron and
4135	c according to s**DELH dependence for pomeron with hard block,
4136	c then rejection is used according to real Sigma_hard(s) dependence.
4137	c Rejection is expected to be minimal for the uniform energy
4138	c distribution between pomerons ( s_hard = s / LHA(I) / LHB(J) )
4139	GBH0=.6D0
4140	c 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
4146	212 FORMAT(2X,'PSSHARE: GBH-INI; CONTRIBUTION FROM ',I3,
4147	* '-TH HARD POMERON')
4148	c-------------------------------------------------
4149	c LHA(i) (LHB(j)) - total number of cut hard blocks, connected to i-th projectile
4150	c (j-th target) nucleon (hadron);
4151	c IAH(ih) (IBH(ih)) - number (position in array) of the projectile (target) nucleon,
4152	c connected to ih-th hard block;
4153	c ZH(ih) - factor exp(-R_ij/R_p) for ih-th hard block;
4154	c 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
4160	c Uniform energy distribution between hard pomerons
4161	ZA=1.D0/LHA(I)
4162	ZB=1.D0/LHB(J)
4163	c SI - c.m. energy squared for one hard block
4164	SI=ZAZBS
4165
4166	IF(SI.LT.4.D0*(QT0+AMJ0))THEN
4167	c-------------------------------------------------
4168	c One hard pomeron is removed (the energy is insufficient to simulate
4169	c great number of pomerons)
4170	c-------------------------------------------------
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
4183	c 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)
4189	4 IBH(IH1)=IBH(IH1+1)
4190	ENDIF
4191	c End of removing - event will be simulated from the very beginning
4192	c-------------------------------------------------
4193	GOTO 3
4194	ENDIF
4195
4196	c Total rapidity for the interaction (for one hard block)
4197	YI=DLOG(SI)
4198	IF(YI.GT.17.D0)YI=17.D0
4199	c Rejection function normalization (on maximal available energy)
4200	GBH0=GBH0/PSRJINT(YI,Z,IQQ)
4201	5 CONTINUE
4202	IF(DEBUG.GE.3)WRITE (MONIOU,213)
4203	213 FORMAT(2X,'PSSHARE: GBH-INI - END')
4204	c-------------------------------------------------
4205	c End of rejection function normalization
4206	c-------------------------------------------------
4207
4208	c-------------------------------------------------
4209	c LHA0(i), LHB0(j) arrays are used for energy sharing procedure
4210	c (they define number of remained cut hard blocks connected to given nucleon from
4211	c projectile or target respectively);
4212	c WP, WM - arrays for the rest of light cone momenta (E+-P_l) for those
4213	c nucleons (hadrons)
4214	c Hard pomerons connected to valence quarks are excluded from LHA0(i), LHB0(j)
4215	c (to be considered separetely)
4216	6 DO 7 I=1,NW
4217	LHA0(I)=LHA(I)-LVA(I)
4218	7 WP(I)=WP0
4219
4220	DO 8 I=1,NT
4221	LHB0(I)=LHB(I)-LVB(I)
4222	8 WM(I)=WM0
4223
4224	c-------------------------------------------------
4225	c Projectile valence quarks light cone momenta are choosen according to
4226	c 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
4229	9 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
4232	214 FORMAT(2X,'PSSHARE: ',I2,'-TH PROJ. NUCLEON (HADRON); LIGHT',
4233	* ' CONE MOMENTUM SHARE XW=',E10.3)
4234	c WP0H(i) - valence quark light cone momentum for i-th projectile nucleon
4235	WP0H(I)=XW*WP(I)
4236	c WP(i) - the remainder of the light cone momentum for i-th projectile nucleon
4237	WP(I)=WP(I)*(1.D0-XW)
4238	ENDIF
4239	10 CONTINUE
4240
4241	c Target valence quarks light cone momenta are choosen according to
4242	c 1/sqrt(x) * x*delh (1-x)**AHV(2) (target nucleon)
4243	DO 12 I=1,NT
4244	IF(LVB(I).NE.0)THEN
4245	11 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
4248	215 FORMAT(2X,'PSSHARE: ',I2,'-TH TARGET NUCLEON (HADRON); LIGHT',
4249	* ' CONE MOMENTUM SHARE XW=',E10.3)
4250	c WM0H(i) - valence quark light cone momentum for i-th target nucleon
4251	WM0H(I)=XW*WM(I)
4252	c WM(i) - the remainder of the light cone momentum for i-th target nucleon
4253	WM(I)=WM(I)*(1.D0-XW)
4254	ENDIF
4255	12 CONTINUE
4256	c-------------------------------------------------
4257
4258	GBH=GBH0
4259	c-------------------------------------------------
4260	c Cycle over all cut hard blocks
4261	c-------------------------------------------------
4262	DO 18 IH=1,NHP1
4263	c-------------------------------------------------
4264	c IAH(ih) (IBH(ih)) - number (position in array) of the projectile (target) nucleon,
4265	c connected to ih-th hard block;
4266	c ZH(ih) - factor exp(-R_ij/R_p) for ih-th hard block;
4267	c 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
4274	c WHA(ih) - light cone momentum (E+P_l) for ih-th hard block
4275	c Read out of the valence quark light cone momentum
4276	WHA(IH)=WP0H(I)
4277	ELSE
4278	c LHA0(i) - number of remained cut hard blocks connected to i-th projectile nucleon
4279	LHA0(I)=LHA0(I)-1
4280	c Energy is shared between pomerons according to s**DEL dependence for soft
4281	c pomeron and according to s**DELH dependence for the hard block;
4282	c AHL(ICZ) determines energetic spectrum of the leading hadronic state of
4283	c type ICZ
4284	BPI=1.D0/(1.D0+AHL(ICZ)+
4285	* (1.D0+DELH)*LHA0(I))
4286	c BPI=1.D0/(1.D0+AHL(ICZ)+(1.D0+DEL)*LQA(I)+
4287	c * (1.D0+DELH)*LHA0(I))
4288	15 XW=1.-PSRAN(B10)**BPI
4289	c Rejection according to XW**DELH
4290	IF(PSRAN(B10).GT.XW**DELH)GOTO 15
4291	c WHA(ih) - light cone momentum (E+P_l) for ih-th hard block
4292	WHA(IH)=WP(I)*XW
4293	c 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
4298	c WHB(ih) - light cone momentum (E-P_l) for ih-th hard block
4299	c Read out of the valence quark light cone momentum
4300	WHB(IH)=WM0H(J)
4301	ELSE
4302	c 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))
4306	c BPI=1.D0/(1.D0+AHL(2)+(1.D0+DEL)*LQB(J)+(1.D0+DELH)
4307	c * *LHB0(J))
4308	16 XW=1.-PSRAN(B10)**BPI
4309	IF(PSRAN(B10).GT.XW**DELH)GOTO 16
4310	c WHB(ih) - light cone momentum (E-P_l) for ih-th hard block
4311	WHB(IH)=WM(J)*XW
4312	c 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
4316	c Invariant mass for ih-th hard block
4317	SW=WHA(IH)*WHB(IH)
4318	IF(SW.LT.4.D0*(QT0+AMJ0))THEN
4319	c Rejection in case of insufficient mass
4320	NREJ=NREJ+1
4321
4322	IF(NREJ.GT.30)THEN
4323	c-------------------------------------------------
4324	c In case of great number of rejections number of hard blocks is put down
4325	c-------------------------------------------------
4326	c 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)
4345	17 IBH(IH1)=IBH(IH1+1)
4346	ENDIF
4347	GOTO 3
4348	c-------------------------------------------------
4349	c End of removing - event will be simulated from the very beginning
4350	c-------------------------------------------------
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)
4357	216 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)
4362	c PSRINT(YH,Z,IQQ) - phi_hard(s_hard) / s_hard ** DELH;
4363	c YH = ln s_hard;
4364	c Z - factor exp(-R_ij/R_p) for the hard block;
4365	c IQQ - type of the hard interaction: 0 - gg, 1 - qg, 2 - gq, 3 - qq
4366	c Rejection function is multiplied by PSRINT(YH,Z,IQQ) for the ih-th block
4367	GBH=GBH*PSRJINT(YH,Z,IQQ)
4368	18 CONTINUE
4369	c End of the loop for rejection function determination
4370	c-------------------------------------------------
4371
4372	c-------------------------------------------------
4373	c Rejection procedure (due to the deviation of the phi_hard(s_hard)
4374	c dependence from pure powerlike s_hard ** DELH law)
4375	IF(DEBUG.GE.2)WRITE (MONIOU,217)1.D0-GBH,NHP
4376	217 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)
4383	218 FORMAT(2X,'PSSHARE: MORE THAN 30 REJECTIONS - HARD POMERON',
4384	* ' NUMBER IS PUT DOWN')
4385	c-------------------------------------------------
4386	c In case of great number of rejections number of hard blocks is put down
4387	c LNH - number of hard blocks to be removed
4388	c-------------------------------------------------
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
4405	19 LHB(JIH)=LHB(JIH)-1
4406
4407	NHP=NHP-LNH
4408	GOTO 3
4409	c-------------------------------------------------
4410	c End of removing - event will be simulated from the very beginning
4411	c-------------------------------------------------
4412	ELSE
4413	GOTO 6
4414	ENDIF
4415	ENDIF
4416
4417	***********************************************************************
4418	DO 31 I=1,NW
4419	31 LHA0(I)=LHA(I)
4420	DO 32 I=1,NT
4421	32 LHB0(I)=LHB(I)
4422	***********************************************************************
4423
4424	c-------------------------------------------------
4425	c Particle production for all cut pomerons with hard blocks
4426	c-------------------------------------------------
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	***********************************************************************
4436	c 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)
4440	219 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)
4444	c-------------------------------------------------
4445	c PSHOT procedure is used for hard partonic interaction -
4446	c 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
4458	330 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
4470	331 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
4473	c-------------------------------------------------
4474	c SW=WP(I)*WM(J)
4475	c IF(WP(I).LT.0.D0.OR.WM(J).LT.0.D0.OR.
4476	c * SW.LT.(AM(ICZ)+AM(2))**2)THEN
4477	c NREJ=NREJ+1
4478	c write (,)'i,j,WP(I),WM(J),sw',i,j,WP(I),WM(J),sw
4479	c GOTO 100
4480	c ENDIF
4481
4482	c Leading hadronic state fragmentation is treated in the same way as low mass
4483	c diffraction (exhitation mass is determined by secodary reggeon intercept
4484	c dM2~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
4492	341 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
4506	342 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
4519	343 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
4531	351 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
4548	344 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
4565	345 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
4577	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4578	20 CONTINUE
4579	c-------------------------------------------------
4580	c End of the hard blocks loop
4581	c-------------------------------------------------
4582
4583	ELSE
4584	c-------------------------------------------------
4585	c Initial light cone momenta initialization in case of no one cut hard block
4586	DO 21 I=1,NW
4587	21 WP(I)=WP0
4588	DO 22 I=1,NT
4589	22 WM(I)=WM0
4590	ENDIF
4591
4592	IF(LS.NE.0)THEN
4593	c-------------------------------------------------
4594	c The loop for all cut froissarons (blocks of soft pomerons)
4595	c-------------------------------------------------
4596	DO 28 IS=1,LS
4597	c NP=NQS(is) - number of cut pomerons in is-th block;
4598	c IAS(is) (IBS(is)) - number (position in array) of the projectile (target) nucleon,
4599	c connected to is-th block of soft pomerons;
4600	c LQA(i) (LQB(j)) - total number of cut soft pomerons, connected to i-th projectile
4601	c (j-th target) nucleon (hadron);
4602	c WP(i) (WM(j)) - the remainder of the light cone momentum for i-th projectile
4603	c (j-th target) nucleon (hadron);
4604	c NP=NQS(is) - number of cut pomerons in is-th block;
4605	c LQ1, LQ2 define the numbers of the remained cut pomerons connected
4606	c 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
4615	222 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)
4620	c-------------------------------------------------
4621	c The loop for all cut pomerons in the block
4622	DO 27 IP=1,NP
4623
4624	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4625	c High mass diffraction - probability WPPP
4626	14 JPP=0
4627	IF(LQ1.EQ.1.AND.WPN.EQ.WP0.AND.PSRAN(B10).LT.WPPP)THEN
4628	c In case of only one cut soft pomeron high mass diffraction is simulated with the
4629	c probability WPPP/2 or triple pomeron contribution - also WPPP/2 to have AGK cancell.
4630	c - only for projectile hadron (nucleons) (for target - neglected)
4631	c 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
4634	223 FORMAT(2X,'PSSHARE: TRIPLE POMERON CONTRIBUTION YW=',E10.3)
4635	c Light cone momentum (E+P_l) for the diffractive state (which is just usual cut
4636	c pomeron)
4637	XPW=EXP(-YW)
4638	JPP=1
4639	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4640
4641	ELSE
4642	LQ1=LQ1-1
4643	c Energy-momentum is shared between pomerons according to s**DEL dependence for soft
4644	c pomeron; AHL(ICZ) determines energy spectrum of leading hadronic
4645	c state of type ICZ
4646	BPI=1.D0/(1.D0+AHL(ICZ)+(1.D0+DEL)*LQ1)
4647	23 XPW=1.-PSRAN(B10)**BPI
4648	c Rejection according to XW**DEL
4649	IF(PSRAN(B10).GT.XPW**DEL)GOTO 23
4650	ENDIF
4651
4652	LQ2=LQ2-1
4653	c Energy-momentum is shared between pomerons according to s**DEL dependence for soft
4654	c pomeron - similar to projectile case
4655	BPI=1.D0/(1.D0+AHL(2)+(1.D0+DEL)*LQ2)
4656	24 XMW=1.-PSRAN(B10)**BPI
4657	c Rejection according to XW**DEL
4658	IF(PSRAN(B10).GT.XMW**DEL)GOTO 24
4659	c-------------------------------------------------
4660
4661	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4662	c High mass diffraction is rejected in case of insufficient energy
4663	IF(JPP.EQ.1.AND.XPWXMWWPN*WMN.LT.2.72D0)THEN
4664	LQ2=LQ2+1
4665	GOTO 14
4666	ENDIF
4667	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4668
4669	c WPI is the light cone momentum (E+P_l) for the pomeron;
4670	c 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	************************************************************************
4677	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
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
4691	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4692	c Fragmentation process for the pomeron ( quarks and antiquarks types at the
4693	c ends of the two strings are determined, energy-momentum is shared
4694	c between them and strings fragmentation is simulated )
4695	IF(DEBUG.GE.3)WRITE (MONIOU,224)IP,WPI,WMI
4696	224 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)
4699	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4700
4701	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4702	c 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
4730	c Triple pomeron contribution simulation (both pomerons are cut)
4731	IF(DEBUG.GE.3)WRITE (MONIOU,225)
4732	225 FORMAT(2X,'PSSHARE: TRIPLE POMERON CONRITRIBUTION WITH 3 CUT',
4733	*' POMERONS')
4734	WMM(1)=1.D0/WPI
4735	WMN=WMN-WMM(1)
4736	c 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
4742	c 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
4745	25 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)
4749	c Fragmentation process for the pomerons
4750	26 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
4759	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4760	27 CONTINUE
4761	c End of the pomeron loop
4762	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4763	c SW=WPN*WMN
4764	c IF(WPN.LT.0.D0.OR.WMN.LT.0.D0.OR.
4765	c * SW.LT.(AM(ICZ)+AM(2))**2)THEN
4766	c NREJ=NREJ+1
4767	c GOTO 100
4768	c ENDIF
4769
4770	c Leading hadronic state fragmentation is treated in the same way as low mass
4771	c diffraction (exhitation mass is determined by secodary reggeon intercept
4772	c dM2~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
4780	346 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
4794	347 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
4807	348 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
4819	349 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
4837	350 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
4855	352 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
4867	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4868	c-------------------------------------------------
4869	c The numbers of the remained cut pomerons connected to given nucleons (hadrons)
4870	c as well as the rest of the longitudinal momenta for these nucleons are
4871	c recorded
4872	30 LQA(I)=LQ1
4873	LQB(J)=LQ2
4874	WP(I)=WPN
4875	28 WM(J)=WMN
4876	ENDIF
4877	c-------------------------------------------------
4878	c End of the soft blocks loop
4879	c-------------------------------------------------
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
4892	cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
4893	CALL XXJETSIM
4894	************************************************************************
4895	IF(DEBUG.GE.3)WRITE (MONIOU,227)
4896	227 FORMAT(2X,'PSSHARE - END')
4897	RETURN
4898	END
4899	C=======================================================================
4900
4901	SUBROUTINE PSTRANS(EP,EY)
4902	c Lorentz transform according to parameters EY ( determining Lorentz shift
4903	c along the Z,X,Y-axis respectively (EY(1),EY(2),EY(3)))
4904	c-----------------------------------------------------------------------
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
4911	201 FORMAT(2X,'PSTRANS - LORENTZ BOOST FOR 4-VECTOR'/4X,'EP=',
4912	* 2X,4(E10.3,1X)/4X,'BOOST PARAMETERS EY=',3E10.3)
4913	c 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
4921	1 CONTINUE
4922	IF(DEBUG.GE.3)WRITE (MONIOU,202)EP
4923	202 FORMAT(2X,'PSTRANS: TRANSFORMED 4-VECTOR EP=',
4924	* 2X,4(E10.3,1X))
4925	RETURN
4926	END
4927	C=======================================================================
4928
4929	SUBROUTINE PSTRANS1(EP,EY)
4930	c Lorentz transform according to parameters EY ( determining Lorentz shift
4931	c along the Z,X,Y-axis respectively (EY(1),EY(2),EY(3)))
4932	c-----------------------------------------------------------------------
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
4939	201 FORMAT(2X,'PSTRANS1 - LORENTZ BOOST FOR 4-VECTOR'/4X,'EP=',
4940	* 2X,4(E10.3,1X)/4X,'BOOST PARAMETERS EY=',3E10.3)
4941	c 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
4949	2 CONTINUE
4950	IF(DEBUG.GE.3)WRITE (MONIOU,202)EP
4951	202 FORMAT(2X,'PSTRANS1: TRANSFORMED 4-VECTOR EP=',
4952	* 2X,4(E10.3,1X))
4953	RETURN
4954	END
4955	C=======================================================================
4956
4957	FUNCTION PSUDINT(QLMAX,J)
4958	c PSUDINT - timelike Sudakov formfactor interpolation
4959	c QLMAX - ln QMAX/16/QTF,
4960	c J - type of the parton (0-g,1-q)
4961	c-----------------------------------------------------------------------
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
4971	201 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
4988	1 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
4993	202 FORMAT(2X,'PSUDINT=',E10.3)
4994	RETURN
4995	END
4996	C=======================================================================
4997
4998	FUNCTION PSUDS(Q,J)
4999	c PSUDS - spacelike Sudakov formfactor
5000	c Q - maximal value of the effective momentum,
5001	c J - type of parton (0 - g, 1 - q)
5002	c-----------------------------------------------------------------------
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
5012	201 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
5029	202 FORMAT(2X,'PSUDS=',E10.3)
5030	RETURN
5031	END
5032	C=======================================================================
5033
5034	FUNCTION PSUDT(QMAX,J)
5035	c PSUDT - timelike Sudakov formfactor
5036	c QMAX - maximal value of the effective momentum,
5037	c J - type of parton (0 - g, 1 - q)
5038	c-----------------------------------------------------------------------
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
5048	201 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
5054	c Numerical integration over transverse momentum square;
5055	c Gaussian integration is used
5056	DO 1 I=1,7
5057	DO 1 M=1,2
5058	QTL=.5D0(QLMAX+QFL+(2M-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
5071	1 PSUDT=PSUDT+A1(I)*AP
5072	PSUDT=PSUDT*(QLMAX-QFL)/9.D0
5073	IF(DEBUG.GE.3)WRITE (MONIOU,202)PSUDT
5074	202 FORMAT(2X,'PSUDT=',E10.3)
5075	RETURN
5076	END
5077	C=======================================================================
5078
5079	FUNCTION PSV(X,Y,XB,IB)
5080	c XXV - eikonal dependent factor for hadron-nucleus interaction
5081	c (used for total and diffractive hadron-nucleus cross-sections calculation)
5082	c-----------------------------------------------------------------------
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
5091	201 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
5095	c????????????????????????????????????????????
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)
5099	1 CONTINUE
5100	PSV=(1.D0-EXP(-DV))**2
5101
5102	C DH=1.D0
5103	C DO 1 M=1,IB
5104	C Z=PSDR(X-XB(M,1),Y-XB(M,2))
5105	C DV=DV+PSFAZ(Z,FSOFT,FHARD,FSHARD)
5106	C 1 DH=DH*(1.D0-FHARD(1)-FHARD(2)-FHARD(3))
5107	c????????????????????????????????????????????????
5108	IF(DEBUG.GE.3)WRITE (MONIOU,202)PSV
5109	202 FORMAT(2X,'PSV=',E10.3)
5110	RETURN
5111	END
5112	C=======================================================================
5113
5114	SUBROUTINE PSVDEF(ICH,IC1,ICZ)
5115	c Determination of valence quark flavour -
5116	c for valence quark hard scattering
5117	c-----------------------------------------------------------------------
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
5125	201 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-3INT(.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
5148	202 FORMAT(2X,'PSVDEF-END: QUARK FLAVOR IC1=',I2,
5149	* 'DIQUARK TYPE ICH=',I2)
5150	RETURN
5151	END
5152	C=======================================================================
5153
5154	FUNCTION PSZSIM(QQ,J)
5155	c PSZSIM - light cone momentum share simulation (for the timelike
5156	c branching)
5157	c QQ - effective momentum value,
5158	c J - type of the parent parton (0-g,1-q)
5159	c-----------------------------------------------------------------------
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
5169	201 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
5173	1 CONTINUE
5174	IF(J.EQ.1)THEN
5175	PSZSIM=.5D0(2.D0ZMIN)**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=PSZSIMPSFAP(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
5186	203 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
5189	202 FORMAT(2X,'PSZSIM=',E10.3)
5190	RETURN
5191	END
5192	C=======================================================================
5193
5194	SUBROUTINE IXXDEF(ICH,IC1,IC2,ICZ)
5195	c Determination of parton flavours in forward and backward direction -
5196	c for valence quark hard scattering
5197	c-----------------------------------------------------------------------
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
5205	201 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-3INT(.5+PSRAN(B10)))
5210	ICH1=ICH*INT(.5D0+PSRAN(B10))
5211	IC2=-IC1IABS(ICH1)-(ICH+IC1)IABS(ICH-ICH1)
5212
5213	ELSEIF(ICZ.EQ.2)THEN
5214	c Valence quark type simulation ( for the proton )
5215	IC1=INT(1.3333+PSRAN(B10))
5216	c Leading nucleon type simulation ( flavors combinatorics )
5217	ICH1=(2-IC1)*INT(PSRAN(B10)+.5)+2
5218	c The type of the parton at the end of the rest string ( after the
5219	c 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
5249	202 FORMAT(2X,'IXXDEF-END: PARTON FLAVORS IC1=',I2,' IC2=',I2,
5250	* 'NEW HADRON TYPE ICH=',I2)
5251	RETURN
5252	END
5253	C=======================================================================
5254
5255	FUNCTION IXXSON(NS,AW,G)
5256	c Poisson distribution:
5257	c AW - average value,
5258	c NS-1 - maximal allowed value,
5259	c G - random number
5260	c-----------------------------------------------------------------------
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
5266	201 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
5273	1 SUMM=SUMM+W
5274	2 IXXSON=I-1
5275	IF(DEBUG.GE.3)WRITE (MONIOU,202)IXXSON
5276	202 FORMAT(2X,'IXXSON=',I2)
5277	RETURN
5278	END
5279	C=======================================================================
5280
5281	SUBROUTINE XXAINI(E0N,ICP0,IAP,IAT)
5282	c Additional initialization procedure
5283	c-----------------------------------------------------------------------
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
5308	201 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
5314	c ICZ - auxiliary type for the primary particle (1- pion, 2 - nucleon, 3 - kaon,
5315	c 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
5322	c Energy dependent factors:
5323	c WP0, WM0 - initial light cone momenta for the interaction (E+-p)
5324	S=2.D0E0NAMN
5325	WP0=DSQRT(S)
5326	WM0=WP0
5327	c Y0 - total rapidity range for the interaction
5328	Y0=DLOG(S)
5329	c RS - soft pomeron elastic scattering slope (lambda_ab)
5330	RS=RQ(ICZ)+ALFP*Y0
5331	c RS0 - initial slope (sum of the pomeron-hadron vertices slopes squared - R_ab)
5332	RS0=RQ(ICZ)
5333	c FS - factor for pomeron eikonal calculation (gamma_ab * s*del /lambda_ab C_ab
5334	FS=FP(ICZ)EXP(Y0DEL)/RS*CD(ICZ)
5335	c RP1 - factor for the impact parameter dependence of the eikonal ( in fm>2 )
5336	RP1=RS4.D0.0391D0/AM**2
5337
5338	EY0(2)=1.D0
5339	EY0(3)=1.D0
5340	EY0(1)=DSQRT(AMN/E0N/2.D0)
5341
5342	c-------------------------------------------------
5343	c Nuclear radii and weights for nuclear configurations simulation - procedure GEA
5344	DO 1 I=1,2
5345	c RD(I) - Wood-Saxon density radius (fit to the data of Murthy et al.)
5346	RD(I)=0.7D0FLOAT(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
5351	c RD(I) - gaussian density radius (for light nucleus)
5352	RD(I)=.9D0FLOAT(IA(I))*.3333/AM
5353	IF(IA(I).EQ.2)RD(I)=3.16D0
5354	c RD -> RD * A / (A-1) - to use Van Hove simulation method - procedure GEA
5355	RD(I)=RD(I)DSQRT(2.D0IA(I)/(IA(I)-1.))
5356	ENDIF
5357	1 CONTINUE
5358
5359	GDT=0.D0
5360	c-------------------------------------------------
5361	c Impact parameter cutoff setting
5362	c-------------------------------------------------
5363	IF(IA(1).NE.1)THEN
5364	c Primary nucleus:
5365	c Impact parameter cutoff value ( only impact parameters less than BM are
5366	c simulated; probability to have larger impact parameter is less than 1% )
5367	BM=RD(1)+RD(2)+5.D0
5368	ELSE
5369	c Hadron-nucleus interaction
5370	c 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)
5390	2 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
5404	3 GDT=GDT+GZ(JE+I-1,ICZ,JA+M-1)WK(I)WA(M)
5405	ENDIF
5406	c write (,)'gdt=',gdt
5407	******************************************************
5408
5409	IF(DEBUG.GE.3)WRITE (MONIOU,202)
5410	202 FORMAT(2X,'XXAINI - END')
5411	RETURN
5412	END
5413	C=======================================================================
5414
5415	SUBROUTINE XXASET
5416	c Particular model parameters setting
5417	c-----------------------------------------------------------------------
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)
5435	201 FORMAT(2X,'XXASET - HADRONIZATION PARAMETERS SETTING')
5436	c 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
5441	c WPPP - Triple pomeron interaction probability (for two cut pomerons and cut
5442	c between them)
5443	WPPP=0.4d0
5444	c WPPP=0.d0
5445	c JDIFR - flag for the low mass diffraction (for JDIFR=0 not considered)
5446	JDIFR=1
5447
5448	c-------------------------------------------------
5449	c Parameters for the soft fragmentation:
5450	c DC(i) - relative probabilities for udu~d~(i=1), ss~(i=2), cc~(i=3)-pairs creation
5451	c from the vacuum for the quark (u,d,u~,d~) fragmentation;
5452	c 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
5460	cc DETA - ratio of etas production density to all pions production density (1/9)
5461	DETA=.11111D0
5462	c WWM defines mass threshold for string to decay into three or more hadrons
5463	c ( ajustable parameter for string fragmentation )
5464	WWM=.53D0
5465	c BE(i) - parameter for Pt distribution (exponential) for uu~(dd~), ss~, qqq~q~,
5466	c cc~ pairs respectively (for the soft fragmentation)
5467	BE(1)=.22D0
5468	BE(2)=.35D0
5469	BE(3)=.29D0
5470	BE(4)=.40D0
5471	c ALMPT - parameter for the fragmentation functions (soft ones):
5472	c ALMPT = 1 + 2 * alfa_R * <pt**2> (Kaidalov proposed 0.5 value for ALMPT-1,
5473	c Sov.J.Nucl.Phys.,1987))
5474	ALMPT=1.7D0
5475
5476	c-------------------------------------------------
5477	c Parameters for nuclear spectator part fragmentation:
5478	c RMIN - coupling radius squared (fm>2),
5479	c EMAX - relative critical energy ( divided per mean excitation energy (~12.5 Mev)),
5480	c EEV - relative evaporation energy ( divided per mean excitation energy (~12.5 Mev))
5481	RMIN=3.35D0
5482	EMAX=.11D0
5483	EEV=.25D0
5484
5485	c-------------------------------------------------
5486	c DMMIN(i) - minimal diffractive mass for low-mass diffraction for pion, nucleon,
5487	c 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
5493	c 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
5502	c-------------------------------------------------
5503	c B10 - initial value of the pseudorandom number,
5504	c PI - pi-number
5505	c AM - diffusive radius for the Saxon-Wood nuclear density parametrization
5506	B10=.43876194D0
5507	PI=3.1416D0
5508	AM=.523D0
5509
5510	C STMASS - minimal string mass to produce secondary particles
5511	STMASS=4.D0AM0*2
5512	c 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)
5531	202 FORMAT(2X,'XXASET - END')
5532	RETURN
5533	END
5534	C=======================================================================
5535
5536	SUBROUTINE XXDDFR(WP0,WM0,ICP,ICT)
5537	c Double diffractive dissociation
5538	c-----------------------------------------------------------------------
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
5553	201 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
5558	100 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
5567	c Registration of too slow "leading" hadron if its energy is insufficient for
5568	c 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..5D0WM00)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
5617	1 PTI=PTMAX*PSRAN(B10)
5618	IF(PSRAN(B10).GT.EXP(-DSQRT(PTI)/BE(4)))GOTO 1
5619	ELSE
5620	2 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-3INT(.5D0+PSRAN(B10)))
5649	IC2=-ICP-IC1
5650	ELSE
5651	IC1=INT(1.5D0+PSRAN(B10))(2INT(.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
5671	3 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)
5682	202 FORMAT(2X,'XXDDFR - END')
5683	RETURN
5684	END
5685	C=======================================================================
5686
5687	SUBROUTINE XXDEC2(EP,EP1,EP2,WW,A,B)
5688	c Two particle decay
5689	c-----------------------------------------------------------------------
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)
5697	201 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=PLDSQRT(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
5710	1 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)
5715	202 FORMAT(2X,'XXDEC2 - END')
5716	RETURN
5717	END
5718	C=======================================================================
5719
5720	SUBROUTINE XXDEC3(EP,EP1,EP2,EP3,SWW,AM1,AM2,AM3)
5721
5722	c-----------------------------------------------------------------------
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)
5731	201 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))
5739	1 P1=PSRAN(B10)*(EMAX-AM12)
5740	E1=DSQRT(P1+AM12)
5741	S23=SWW*2+AM12-2.D0E1*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=P1DSQRT(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
5754	2 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,AM22,AM32)
5761	IF(DEBUG.GE.3)WRITE (MONIOU,202)
5762	202 FORMAT(2X,'XXDEC3 - END')
5763	RETURN
5764	END
5765	C=======================================================================
5766
5767	SUBROUTINE XXDPR(WP0,WM0,ICP,ICT,LQ2)
5768	c Projectile hadron dissociation
5769	c Leading hadronic state hadronization
5770	c-----------------------------------------------------------------------
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
5786	201 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
5791	100 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
5799	c Registration of too slow "leading" hadron if its energy is insufficient for
5800	c 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.WPIWM0)THEN
5807	IF(WPI.GT.0.D0.AND.AM(ICZ)*2/WPI.LT..5D0WM00)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..5D0WM00)
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=WP0XXTWDEC(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/RSDLOG(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
5910	1 PTI=PTMAX*PSRAN(B10)
5911	IF(PSRAN(B10).GT.EXP(-DSQRT(PTI)/BE(4)))GOTO 1
5912	ELSE
5913	2 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-3INT(.5D0+PSRAN(B10)))
5943	IC2=-ICP-IC1
5944	ELSE
5945	IC1=INT(1.5D0+PSRAN(B10))(2INT(.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)
5966	202 FORMAT(2X,'XXDPR - END')
5967	RETURN
5968	END
5969	C=======================================================================
5970
5971	SUBROUTINE XXDTG(WP0,WM0,ICP,ICT,LQ1)
5972	c Target nucleon dissociation
5973	c Leading hadronic state hadronization
5974	c-----------------------------------------------------------------------
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
5989	201 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
5994	100 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
6002	c Registration of too slow "leading" hadron if its energy is insufficient for
6003	c 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.WMIWP0)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..5D0WM00)
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/RSDLOG(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)
6094	202 FORMAT(2X,'XXDTG - END')
6095	RETURN
6096	END
6097	C=======================================================================
6098
6099	SUBROUTINE XXFAU(B,GZ)
6100	c Integrands for hadron-hadron and hadron-nucleus cross-sections calculation
6101	c-----------------------------------------------------------------------
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)
6112	201 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
6117	1 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)
6130	202 FORMAT(2X,'XXFAU - END')
6131	RETURN
6132	END
6133	C=======================================================================
6134
6135	SUBROUTINE XXFRAG(SA,NA,RC)
6136	c Connected nucleon clasters extraction - used for the nuclear spectator part
6137	c multifragmentation:
6138	c-----------------------------------------------------------------------
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
6147	201 FORMAT(2X,'XXFRAG-MULTIFRAGMENTATION: NUCLEUS MASS NUMBER: NA='
6148	* ,I2)
6149	IF(DEBUG.GE.3)THEN
6150	WRITE (MONIOU,203)
6151	203 FORMAT(2X,'NUCLEONS COORDINATES:')
6152	204 FORMAT(2X,3E10.3)
6153	DO 205 I=1,NA
6154	205 WRITE (MONIOU,204)(SA(I,L),L=1,3)
6155	ENDIF
6156
6157	NI=1
6158	NG=1
6159	J=0
6160	1 J=J+1
6161	J1=NI+1
6162	DO 4 I=J1,NA
6163	RI=0.D0
6164	DO 2 M=1,3
6165	2 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)
6173	3 SA(I,M)=S0
6174	4 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)
6179	206 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
6184	5 NSF=NSF+1
6185	IAF(NSF)=1
6186	IF(DEBUG.GE.3)WRITE (MONIOU,206)NSF,IAF(NSF)
6187	6 CONTINUE
6188	IF(DEBUG.GE.3)WRITE (MONIOU,202)
6189	202 FORMAT(2X,'XXFRAG - END')
6190	RETURN
6191	END
6192	C=======================================================================
6193
6194	SUBROUTINE XXFRAGM(NS,XA)
6195	c Fragmentation of the spectator part of the nucleus
6196	c XA(56,3) - arrays for spectator nucleons positions
6197	c NS - total number of spectators
6198	c-----------------------------------------------------------------------
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
6205	c NSF - number of secondary fragments;
6206	c 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
6212	201 FORMAT(2X,'XXFRAGM: NUMBER OF SPECTATORS: NS=',I2)
6213
6214	NSF=0
6215
6216	IF(NS-1)6,1,2
6217	c Single spectator nucleon is recorded
6218	1 NSF=NSF+1
6219	IAF(NSF)=1
6220	IF(DEBUG.GE.3)WRITE (MONIOU,205)
6221	205 FORMAT(2X,'XXFRAGM - SINGLE SPECTATOR')
6222	GOTO 6
6223	2 EEX=0.D0
6224	c EEX - spectator part excitation energy; calculated as the sum of excitations
6225	c from all wounded nucleons ( including diffractively excited )
6226	DO 3 I=1,IA(1)-NS
6227	c Partial excitation is simulated according to distribution f(E) ~ 1/sqrt(E)
6228	c * exp(-E/(2*<E>)), for sqrt(E) we have then normal distribution
6229	3 EEX=EEX+(PSRAN(B10)+PSRAN(B10)+PSRAN(B10)+
6230	* PSRAN(B10)+PSRAN(B10)-2.5D0)*22.4D0
6231	IF(DEBUG.GE.3)WRITE (MONIOU,203)EEX
6232	203 FORMAT(2X,'XXFRAGM: EXCITATION ENERGY: EEX=',E10.3)
6233
6234	c If the excitation energy per spectator is larger than EMAX
6235	c multifragmentation takes place ( percolation algorithm is used for it )
6236	IF(EEX/NS.GT.EMAX)THEN
6237	c Multifragmentation
6238	CALL XXFRAG(XA,NS,RMIN)
6239	ELSE
6240
6241	c Otherwise average number of eveporated nucleons equals EEX/EEV, where
6242	c EEV - mean excitation energy carried out by one nucleon
6243	NF=IXXSON(NS,EEX/EEV,PSRAN(B10))
6244	NSF=NSF+1
6245	c Recording of the fragment produced
6246	IAF(NSF)=NS-NF
6247	IF(DEBUG.GE.3)WRITE (MONIOU,206)IAF(NSF)
6248	206 FORMAT(2X,'XXFRAGM - EVAPORATION: MASS NUMBER OF THE FRAGMENT:'
6249	* ,I2)
6250
6251	c Some part of excitation energy is carried out by alphas; we determine the
6252	c number of alphas simply as NF/4
6253	NAL=NF/4
6254	IF(NAL.NE.0)THEN
6255	c Recording of the evaporated alphas
6256	DO 4 I=1,NAL
6257	NSF=NSF+1
6258	4 IAF(NSF)=4
6259	ENDIF
6260
6261	NF=NF-4*NAL
6262	IF(NF.NE.0)THEN
6263	c Recording of the evaporated nucleons
6264	DO 5 I=1,NF
6265	NSF=NSF+1
6266	5 IAF(NSF)=1
6267	ENDIF
6268	IF(DEBUG.GE.3)WRITE (MONIOU,204)NF,NAL
6269	204 FORMAT(2X,'XXFRAGM - EVAPORATION: NUMBER OF NUCLEONS NF=',I2,
6270	* 'NUMBER OF ALPHAS NAL=',I2)
6271	ENDIF
6272	6 CONTINUE
6273	IF(DEBUG.GE.3)WRITE (MONIOU,202)
6274	202 FORMAT(2X,'XXFRAGM - END')
6275	RETURN
6276	END
6277	C=======================================================================
6278
6279	SUBROUTINE XXFZ(B,GZ)
6280	c Hadron-hadron and hadron-nucleus cross sections calculation
6281	c-----------------------------------------------------------------------
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)
6292	201 FORMAT(2X,'XXFZ - HADRONIC CROSS-SECTIONS CALCULATION')
6293
6294	DO 1 L=1,2
6295	1 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
6305	C??????????
6306	C VV1=EXP(-PSFAZ(ZV1,FSOFT,FHARD,FSHARD))*(1.D0-FHARD(1)
6307	C * -FHARD(2)-FHARD(3))
6308	C VV2=EXP(-PSFAZ(ZV2,FSOFT,FHARD,FSHARD))*(1.D0-FHARD(1)
6309	C * -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))
6315	c???????????
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
6326	2 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)
6328	202 FORMAT(2X,'XXFZ - END')
6329	RETURN
6330	END
6331	C=======================================================================
6332
6333	SUBROUTINE XXGAU(GZ)
6334	c Impact parameter integration for impact parameters <BM -
6335	c for hadron-hadron and hadron-nucleus cross-sections calculation
6336	c-----------------------------------------------------------------------
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)
6346	201 FORMAT(2X,'XXGAU - NUCLEAR CROSS-SECTIONS CALCULATION')
6347
6348	DO 1 I=1,3
6349	1 GZ(I)=0.D0
6350
6351	DO 2 I=1,7
6352	DO 2 M=1,2
6353	B=BMDSQRT(.5D0+X1(I)(M-1.5D0))
6354	CALL XXFAU(B,GZ0)
6355	DO 2 L=1,3
6356	2 GZ(L)=GZ(L)+GZ0(L)*A1(I)
6357	DO 3 L=1,3
6358	3 GZ(L)=GZ(L)(BMAM)*2PI*.5D0
6359	IF(DEBUG.GE.3)WRITE (MONIOU,202)
6360	202 FORMAT(2X,'XXGAU - END')
6361	RETURN
6362	END
6363	C=======================================================================
6364
6365	SUBROUTINE XXGAU1(GZ)
6366	c Impact parameter integration for impact parameters >BM -
6367	c for hadron-hadron and hadron-nucleus cross-sections calculation
6368	c-----------------------------------------------------------------------
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)
6379	201 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
6385	1 GZ(L)=GZ(L)+GZ0(L)A5(I)EXP(X5(I))B2.D0PIAM*AM
6386	IF(DEBUG.GE.3)WRITE (MONIOU,202)
6387	202 FORMAT(2X,'XXGAU1 - END')
6388	RETURN
6389	END
6390	C=======================================================================
6391
6392	SUBROUTINE XXGENER(WP0,WM0,EY0,S0X,C0X,S0,C0,IC1,IC2)
6393	c To simulate the fragmentation of the string into secondary hadrons
6394	c The algorithm conserves energy-momentum;
6395	c WP0, WM0 are initial longitudinal momenta ( E+p, E-p ) of the quarks
6396	c at the ends of the string; IC1, IC2 - their types
6397	c The following partons types are used: 1 - u, -1 - U, 2 - d, -2 - D,
6398	c 3 - ud, -3 - UD, 4 - s, -4 - S, 5 - c, -5 - C,
6399	c 6 - uu, 7 - dd, -6 - UU, -7 - DD
6400	c-----------------------------------------------------------------------
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)
6405	c WP(1), WP(2) - current longitudinal momenta of the partons at the string
6406	c 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
6422	201 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
6435	1 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
6441	203 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
6467	c 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
6476	c 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
6485	c 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
6494	c 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
6502	c 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=3IS-2IC(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
6520	c 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
6530	c 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
6539	c 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
6556	c 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
6565	c 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
6577	c 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
6586	c 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
6602	2 PTI=PTMAX*PSRAN(B10)
6603	IF(PSRAN(B10).GT.EXP(-DSQRT(PTI)/BET))GOTO 2
6604	ELSE
6605	3 PTI=(BETDLOG(PSRAN(B10)PSRAN(B10)))**2
6606	IF(PTI.GT.PTMAX)GOTO 3
6607	ENDIF
6608
6609	AMT=AMI+PTI
6610	RESTM1=RESTM+PTI
6611	********************************************************
6612	c 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
6618	4 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
6631	5 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)=3IS-2IC(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-2IAJ)
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-2IAB)
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))(-3IS-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))(3IS-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))(-3IS-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))(3IS-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
6796	6 PTI=PTMAX*PSRAN(B10)
6797	IF(PSRAN(B10).GT.EXP(-DSQRT(PTI)/BET))GOTO 6
6798	ELSE
6799	7 PTI=(BETDLOG(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
6818	8 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)
6835	202 FORMAT(2X,'XXGENER - END')
6836	RETURN
6837	ENDIF
6838	GOTO 1
6839	END
6840	C=======================================================================
6841
6842	SUBROUTINE XXJETSIM
6843	c Procedure for jet hadronization - each gluon is
6844	c considered to be splitted into quark-antiquark pair and usual soft
6845	c strings are assumed to be formed between quark and antiquark
6846	c-----------------------------------------------------------------------
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
6858	201 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)
6863	1 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
6867	c 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
6875	2 CALL XXGENER(SWW,SWW,EY,S0X,C0X,S0,C0,IPJET(1,NJ),IPJET(2,NJ))
6876	IF(DEBUG.GE.3)WRITE (MONIOU,202)
6877	202 FORMAT(2X,'XXJETSIM - END')
6878	RETURN
6879	END
6880	C=======================================================================
6881
6882	SUBROUTINE XXREG(EP0,IC)
6883	c Registration of the produced hadron;
6884	c EP - 4-momentum,
6885	c IC - hadron type
6886	c-----------------------------------------------------------------------
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
6899	201 FORMAT(2X,'XXREG: IC=',I2,2X,'C.M. 4-MOMENTUM:',2X,4(E10.3,1X))
6900	pt=dsqrt(ep0(3)2+ep0(4)2)
6901	c if(pt.gt.11.d0)write (MONIOU,*)'pt,ic,ep',pt,ic,ep0
6902	c 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
6911	4 EP(I)=EP0(I)
6912	CALL PSTRANS(EP,EY0)
6913	IF(DEBUG.GE.3)WRITE (MONIOU,202)EP
6914	202 FORMAT(2X,'XXREG: LAB. 4-MOMENTUM:',2X,4(E10.3,1X))
6915
6916	ICH(NSH)=IC
6917	DO 3 I=1,4
6918	3 ESP(I,NSH)=EP(I)
6919
6920	IF(DEBUG.GE.3)WRITE (MONIOU,203)
6921	203 FORMAT(2X,'XXREG - END')
6922	RETURN
6923	END
6924	C=======================================================================
6925
6926	FUNCTION XXROT(S,B)
6927	c Convolution of nuclear profile functions (axial angle integration)
6928	c-----------------------------------------------------------------------
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
6935	201 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=B2+S2-2.BS(2.X2(I)-1.)
6942	SB2=B2+S2-2.BS(1.-2.X2(I))
6943	1 XXROT=XXROT+(XXT(SB1)+XXT(SB2))
6944	XXROT=XXROT*A2
6945	IF(DEBUG.GE.3)WRITE (MONIOU,202)XXROT
6946	202 FORMAT(2X,'XXROT=',E10.3)
6947	RETURN
6948	END
6949	C=======================================================================
6950
6951	SUBROUTINE XXSTR(WPI0,WMI0,WP0,WM0,IC10,IC120,IC210,IC20)
6952	**************************************************
6953	c Fragmentation process for the pomeron ( quarks and antiquarks types at the
6954	c ends of the two strings are determined, energy-momentum is shared
6955	c between them and strings fragmentation is simulated )
6956	c-----------------------------------------------------------------------
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
6968	201 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
6971	1 EY(I)=1.D0
6972
6973	WPI=WPI0
6974	WMI=WMI0
6975	c Quark-antiquark types (1 - u, 2 - d, -1 - u~, -2 - d~); s- and d- quarks are
6976	c 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
7000	c Longitudinal momenta for the strings
7001	WP1=WPICOS(PIPSRAN(B10))**2
7002	WM1=WMICOS(PIPSRAN(B10))**2
7003	WPI=WPI-WP1
7004	WMI=WMI-WM1
7005	c String masses
7006	SM1=WP1*WM1
7007	SM2=WPI*WMI
7008	c Too short strings are neglected (energy is given to partner string or to the hadron
7009	c (nucleon) to which the pomeron is connected)
7010	IF(SM1.GT.STMASS.AND.SM2.GT.STMASS)THEN
7011	c 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
7023	202 FORMAT(2X,'XXSTR - RETURNED LIGHT CONE MOMENTA:',
7024	* 2X,'WP0=',E10.3,2X,'WM0=',E10.3)
7025	RETURN
7026	END
7027	C=======================================================================
7028
7029	FUNCTION XXT(B)
7030	c Nuclear profile function value at impact parameter squared B
7031	c-----------------------------------------------------------------------
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
7042	201 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))
7059	1 CONTINUE
7060	XXT=XXTZM0.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))
7066	2 CONTINUE
7067	XXT=XXT+DT
7068	IF(DEBUG.GE.3)WRITE (MONIOU,202)XXROT
7069	202 FORMAT(2X,'XXT=',E10.3)
7070	RETURN
7071	END
7072	C=======================================================================
7073
7074	FUNCTION XXTWDEC(S,A,B)
7075	c Kinematical function for two particle decay -
7076	C light cone momentum share for
7077	c the particle of mass squared A,
7078	C B - partner's mass squared,
7079	C S - two particle invariant mass
7080	c-----------------------------------------------------------------------
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
7087	201 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
7098	202 FORMAT(2X,'XXTWDEC=',E10.3)
7099	RETURN
7100	END
7101	C=======================================================================
7102
7103	DOUBLE PRECISION FUNCTION GAMFUN(Y)
7104	C Gamma function : See Abramowitz, page 257, form. 6.4.40
7105	c-----------------------------------------------------------------------
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
7110	C
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/
7118	C
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
7125	10 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=SX*2
7132	20 CONTINUE
7133	GAMFUN = EXP(R+T)/AFSPL
7134	END
7135	C=======================================================================
7136
7137	BLOCK DATA PSDATA
7138	c Constants for numerical integration (Gaussian weights)
7139	c-----------------------------------------------------------------------
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.

Context Navigation

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

Download in other formats: