]> git.uio.no Git - u/mrichter/AliRoot.git/blame - TAmpt/AMPT/hipyset1.35.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
randomize reaction plane
[u/mrichter/AliRoot.git] / TAmpt / AMPT / hipyset1.35.f
CommitLineData
0119ef9a 1c.................... hipyset1.35.f
2C
3C
4C
5C Modified for HIJING program
6c
7c modification July 22, 1997 In pyremnn put an upper limit
8c on the total pt kick the parton can accumulate via multiple
9C scattering. Set the upper limit to be the sqrt(s)/2,
10c this is fix cronin bug for Pb+Pb events at SPS energy.
11c
12C
13C Last modification Oct. 1993 to comply with non-vax
14C machines' compiler
15C
16C*********************************************************************
17
18cms
19cms gsfs 8/2009 Renamed common block PYINT4A due to conflict with something in CMSSW
20cms
21 SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)
22
23C...Purpose: to store two partons/particles in their CM frame,
24C...with the first along the +z axis.
25 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
26 SAVE /LUJETSA/
27 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28 SAVE /LUDAT1A/
29 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
30 SAVE /LUDAT2A/
31
32C...Standard checks.
33 MSTU(28)=0
34 IF(MSTU(12).GE.1) CALL LULIST(0)
35 IPA=MAX(1,IABS(IP))
36 IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,
37 &'(LU2ENT:) writing outside LUJETSA memory')
38 KC1=LUCOMP(KF1)
39 KC2=LUCOMP(KF2)
40 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,
41 &'(LU2ENT:) unknown flavour code')
42
43C...Find masses. Reset K, P and V vectors.
44 PM1=0.
45 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
46 IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
47 PM2=0.
48 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
49 IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
50 DO 100 I=IPA,IPA+1
51 DO 100 J=1,5
52 K(I,J)=0
53 P(I,J)=0.
54 100 V(I,J)=0.
55
56C...Check flavours.
57 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,
60 &'(LU2ENT:) unphysical flavour combination')
61 K(IPA,2)=KF1
62 K(IPA+1,2)=KF2
63
64C...Store partons/particles in K vectors for normal case.
65 IF(IP.GE.0) THEN
66 K(IPA,1)=1
67 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
68 K(IPA+1,1)=1
69
70C...Store partons in K vectors for parton shower evolution.
71 ELSE
72 IF(KQ1.EQ.0.OR.KQ2.EQ.0) CALL LUERRM(2,
73 & '(LU2ENT:) requested flavours can not develop parton shower')
74 K(IPA,1)=3
75 K(IPA+1,1)=3
76 K(IPA,4)=MSTU(5)*(IPA+1)
77 K(IPA,5)=K(IPA,4)
78 K(IPA+1,4)=MSTU(5)*IPA
79 K(IPA+1,5)=K(IPA+1,4)
80 ENDIF
81
82C...Check kinematics and store partons/particles in P vectors.
83 IF(PECM.LE.PM1+PM2) CALL LUERRM(13,
84 &'(LU2ENT:) energy smaller than sum of masses')
85 PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
86 &(2.*PECM)
87 P(IPA,3)=PA
88 P(IPA,4)=SQRT(PM1**2+PA**2)
89 P(IPA,5)=PM1
90 P(IPA+1,3)=-PA
91 P(IPA+1,4)=SQRT(PM2**2+PA**2)
92 P(IPA+1,5)=PM2
93
94C...Set N. Optionally fragment/decay.
95 N=IPA+1
96 IF(IP.EQ.0) CALL LUEXEC
97
98 RETURN
99 END
100
101C*********************************************************************
102
103 SUBROUTINE LUGIVE(CHIN)
104
105C...Purpose: to set values of commonblock variables.
106 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
107 SAVE /LUJETSA/
108 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
109 SAVE /LUDAT1A/
110 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
111 SAVE /LUDAT2A/
112 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
113 SAVE /LUDAT3A/
114 COMMON/LUDAT4A/CHAF(500)
115 CHARACTER CHAF*8
116 SAVE /LUDAT4A/
117 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,
118 &CHNAM*4,CHVAR(17)*4,CHALP(2)*26,CHIND*8,CHINI*10,CHINR*16
119 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
120 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF'/
121 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
122 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
123
124C...Length of character variable. Subdivide it into instructions.
125 IF(MSTU(12).GE.1) CALL LULIST(0)
126 CHBIT=CHIN//' '
127 LBIT=101
128 100 LBIT=LBIT-1
129 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
130 LTOT=0
131 DO 110 LCOM=1,LBIT
132 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
133 LTOT=LTOT+1
134 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
135 110 CONTINUE
136 LLOW=0
137 120 LHIG=LLOW+1
138 130 LHIG=LHIG+1
139 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
140 LBIT=LHIG-LLOW-1
141 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
142
143C...Identify commonblock variable.
144 LNAM=1
145 140 LNAM=LNAM+1
146 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
147 &LNAM.LE.4) GOTO 140
148 CHNAM=CHBIT(1:LNAM-1)//' '
149 DO 150 LCOM=1,LNAM-1
150 DO 150 LALP=1,26
151 150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
152 &CHALP(2)(LALP:LALP)
153 IVAR=0
154 DO 160 IV=1,17
155 160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
156 IF(IVAR.EQ.0) THEN
157 CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)
158 LLOW=LHIG
159 IF(LLOW.LT.LTOT) GOTO 120
160 RETURN
161 ENDIF
162
163C...Identify any indices.
164 I=0
165 J=0
166 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
167 LIND=LNAM
168 170 LIND=LIND+1
169 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170
170 CHIND=' '
171 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
172 & AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
173 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
174 READ(CHIND,'(I8)') I1
175 I=LUCOMP(I1)
176 ELSE
177 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
178 READ(CHIND,'(I8)') I
179 ENDIF
180 LNAM=LIND
181 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
182 ENDIF
183 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
184 LIND=LNAM
185 180 LIND=LIND+1
186 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
187 CHIND=' '
188 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
189 READ(CHIND,'(I8)') J
190 LNAM=LIND+1
191 ENDIF
192
193C...Check that indices allowed and save old value.
194 IERR=1
195 IF(CHBIT(LNAM:LNAM).NE.'=') GOTO 190
196 IF(IVAR.EQ.1) THEN
197 IF(I.NE.0.OR.J.NE.0) GOTO 190
198 IOLD=N
199 ELSEIF(IVAR.EQ.2) THEN
200 IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
201 IOLD=K(I,J)
202 ELSEIF(IVAR.EQ.3) THEN
203 IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
204 ROLD=P(I,J)
205 ELSEIF(IVAR.EQ.4) THEN
206 IF(I.LT.1.OR.I.GT.MSTU(4).OR.J.LT.1.OR.J.GT.5) GOTO 190
207 ROLD=V(I,J)
208 ELSEIF(IVAR.EQ.5) THEN
209 IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
210 IOLD=MSTU(I)
211 ELSEIF(IVAR.EQ.6) THEN
212 IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
213 ROLD=PARU(I)
214 ELSEIF(IVAR.EQ.7) THEN
215 IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
216 IOLD=MSTJ(I)
217 ELSEIF(IVAR.EQ.8) THEN
218 IF(I.LT.1.OR.I.GT.200.OR.J.NE.0) GOTO 190
219 ROLD=PARJ(I)
220 ELSEIF(IVAR.EQ.9) THEN
221 IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
222 IOLD=KCHG(I,J)
223 ELSEIF(IVAR.EQ.10) THEN
224 IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.4) GOTO 190
225 ROLD=PMAS(I,J)
226 ELSEIF(IVAR.EQ.11) THEN
227 IF(I.LT.1.OR.I.GT.2000.OR.J.NE.0) GOTO 190
228 ROLD=PARF(I)
229 ELSEIF(IVAR.EQ.12) THEN
230 IF(I.LT.1.OR.I.GT.4.OR.J.LT.1.OR.J.GT.4) GOTO 190
231 ROLD=VCKM(I,J)
232 ELSEIF(IVAR.EQ.13) THEN
233 IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.LT.1.OR.J.GT.3) GOTO 190
234 IOLD=MDCY(I,J)
235 ELSEIF(IVAR.EQ.14) THEN
236 IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.2) GOTO 190
237 IOLD=MDME(I,J)
238 ELSEIF(IVAR.EQ.15) THEN
239 IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.NE.0) GOTO 190
240 ROLD=BRAT(I)
241 ELSEIF(IVAR.EQ.16) THEN
242 IF(I.LT.1.OR.I.GT.MSTU(7).OR.J.LT.1.OR.J.GT.5) GOTO 190
243 IOLD=KFDP(I,J)
244 ELSEIF(IVAR.EQ.17) THEN
245 IF(I.LT.1.OR.I.GT.MSTU(6).OR.J.NE.0) GOTO 190
246 CHOLD=CHAF(I)
247 ENDIF
248 IERR=0
249 190 IF(IERR.EQ.1) THEN
250 CALL LUERRM(18,'(LUGIVE:) unallowed indices for '//
251 & CHBIT(1:LNAM-1))
252 LLOW=LHIG
253 IF(LLOW.LT.LTOT) GOTO 120
254 RETURN
255 ENDIF
256
257C...Print current value of variable. Loop back.
258 IF(LNAM.GE.LBIT) THEN
259 CHBIT(LNAM:14)=' '
260 CHBIT(15:60)=' has the value '
261 IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
262 & IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
263 WRITE(CHBIT(51:60),'(I10)') IOLD
264 ELSEIF(IVAR.NE.17) THEN
265 WRITE(CHBIT(47:60),'(F14.5)') ROLD
266 ELSE
267 CHBIT(53:60)=CHOLD
268 ENDIF
269 IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
270 LLOW=LHIG
271 IF(LLOW.LT.LTOT) GOTO 120
272 RETURN
273 ENDIF
274
275C...Read in new variable value.
276 IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
277 &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
278 CHINI=' '
279 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
280 READ(CHINI,'(I10)') INEW
281 ELSEIF(IVAR.NE.17) THEN
282 CHINR=' '
283 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
284 READ(CHINR,'(F16.2)') RNEW
285 ELSE
286 CHNEW=CHBIT(LNAM+1:LBIT)//' '
287 ENDIF
288
289C...Store new variable value.
290 IF(IVAR.EQ.1) THEN
291 N=INEW
292 ELSEIF(IVAR.EQ.2) THEN
293 K(I,J)=INEW
294 ELSEIF(IVAR.EQ.3) THEN
295 P(I,J)=RNEW
296 ELSEIF(IVAR.EQ.4) THEN
297 V(I,J)=RNEW
298 ELSEIF(IVAR.EQ.5) THEN
299 MSTU(I)=INEW
300 ELSEIF(IVAR.EQ.6) THEN
301 PARU(I)=RNEW
302 ELSEIF(IVAR.EQ.7) THEN
303 MSTJ(I)=INEW
304 ELSEIF(IVAR.EQ.8) THEN
305 PARJ(I)=RNEW
306 ELSEIF(IVAR.EQ.9) THEN
307 KCHG(I,J)=INEW
308 ELSEIF(IVAR.EQ.10) THEN
309 PMAS(I,J)=RNEW
310 ELSEIF(IVAR.EQ.11) THEN
311 PARF(I)=RNEW
312 ELSEIF(IVAR.EQ.12) THEN
313 VCKM(I,J)=RNEW
314 ELSEIF(IVAR.EQ.13) THEN
315 MDCY(I,J)=INEW
316 ELSEIF(IVAR.EQ.14) THEN
317 MDME(I,J)=INEW
318 ELSEIF(IVAR.EQ.15) THEN
319 BRAT(I)=RNEW
320 ELSEIF(IVAR.EQ.16) THEN
321 KFDP(I,J)=INEW
322 ELSEIF(IVAR.EQ.17) THEN
323 CHAF(I)=CHNEW
324 ENDIF
325
326C...Write old and new value. Loop back.
327 CHBIT(LNAM:14)=' '
328 CHBIT(15:60)=' changed from to '
329 IF(IVAR.EQ.1.OR.IVAR.EQ.2.OR.IVAR.EQ.5.OR.IVAR.EQ.7.OR.
330 &IVAR.EQ.9.OR.IVAR.EQ.13.OR.IVAR.EQ.14.OR.IVAR.EQ.16) THEN
331 WRITE(CHBIT(33:42),'(I10)') IOLD
332 WRITE(CHBIT(51:60),'(I10)') INEW
333 ELSEIF(IVAR.NE.17) THEN
334 WRITE(CHBIT(29:42),'(F14.5)') ROLD
335 WRITE(CHBIT(47:60),'(F14.5)') RNEW
336 ELSE
337 CHBIT(35:42)=CHOLD
338 CHBIT(53:60)=CHNEW
339 ENDIF
340 IF(MSTU(13).GE.1) WRITE(MSTU(11),1000) CHBIT(1:60)
341 LLOW=LHIG
342 IF(LLOW.LT.LTOT) GOTO 120
343
344C...Format statement for output on unit MSTU(11) (by default 6).
345 1000 FORMAT(5X,A60)
346
347 RETURN
348 END
349
350C*********************************************************************
351
352 SUBROUTINE LUEXEC
353
354C...Purpose: to administrate the fragmentation and decay chain.
355 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
356 SAVE /LUJETSA/
357 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
358 SAVE /LUDAT1A/
359 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
360 SAVE /LUDAT2A/
361 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
362 SAVE /LUDAT3A/
363 DIMENSION PS(2,6)
364
365C...Initialize and reset.
366 MSTU(24)=0
367 IF(MSTU(12).GE.1) CALL LULIST(0)
368 MSTU(31)=MSTU(31)+1
369 MSTU(1)=0
370 MSTU(2)=0
371 MSTU(3)=0
372 MCONS=1
373
374C...Sum up momentum, energy and charge for starting entries.
375 NSAV=N
376 DO 100 I=1,2
377 DO 100 J=1,6
378 100 PS(I,J)=0.
379 DO 120 I=1,N
380 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
381 DO 110 J=1,4
382 110 PS(1,J)=PS(1,J)+P(I,J)
383 PS(1,6)=PS(1,6)+LUCHGE(K(I,2))
384 120 CONTINUE
385 PARU(21)=PS(1,4)
386
387C...Prepare system for subsequent fragmentation/decay.
388 CALL LUPREP(0)
389
390C...Loop through jet fragmentation and particle decays.
391 MBE=0
392 130 MBE=MBE+1
393 IP=0
394 140 IP=IP+1
395 KC=0
396 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2))
397 IF(KC.EQ.0) THEN
398
399C...Particle decay if unstable and allowed. Save long-lived particle
400C...decays until second pass after Bose-Einstein effects.
401 ELSEIF(KCHG(KC,2).EQ.0) THEN
402clin-4/2008 break up compound IF statements:
403c IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE.
404c & EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
405c & CALL LUDECY(IP)
406 if(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1) then
407 if(MSTJ(51).LE.0.OR.MBE.EQ.2.OR.PMAS(KC,2).GE.PARJ(91)
408 & .OR.IABS(K(IP,2)).EQ.311)
409 & CALL LUDECY(IP)
410 endif
411c
412C...Decay products may develop a shower.
413 IF(MSTJ(92).GT.0) THEN
414 IP1=MSTJ(92)
415 QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
416 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
417 CALL LUSHOW(IP1,IP1+1,QMAX)
418 CALL LUPREP(IP1)
419 MSTJ(92)=0
420 ELSEIF(MSTJ(92).LT.0) THEN
421 IP1=-MSTJ(92)
422clin-8/19/02 avoid actual argument in common blocks of LUSHOW:
423c CALL LUSHOW(IP1,-3,P(IP,5))
424 pip5=P(IP,5)
425 CALL LUSHOW(IP1,-3,pip5)
426 CALL LUPREP(IP1)
427 MSTJ(92)=0
428 ENDIF
429
430C...Jet fragmentation: string or independent fragmentation.
431 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
432 MFRAG=MSTJ(1)
433 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
434 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
435 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
436 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
437 IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
438 ENDIF
439 ENDIF
440 IF(MFRAG.EQ.1) then
441 CALL LUSTRF(IP)
442 endif
443 IF(MFRAG.EQ.2) CALL LUINDF(IP)
444 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
445 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
446 ENDIF
447
448C...Loop back if enough space left in LUJETSA and no error abort.
449 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
450 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
451 GOTO 140
452 ELSEIF(IP.LT.N) THEN
453 CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETSA')
454 ENDIF
455
456C...Include simple Bose-Einstein effect parametrization if desired.
457 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
458 CALL LUBOEI(NSAV)
459 GOTO 130
460 ENDIF
461
462C...Check that momentum, energy and charge were conserved.
463 DO 160 I=1,N
464 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160
465 DO 150 J=1,4
466 150 PS(2,J)=PS(2,J)+P(I,J)
467 PS(2,6)=PS(2,6)+LUCHGE(K(I,2))
468 160 CONTINUE
469 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
470 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
471 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,
472 &'(LUEXEC:) four-momentum was not conserved')
473c IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) then
474c CALL LUERRM(15,
475c &'(LUEXEC:) four-momentum was not conserved')
476c write(6,*) 'PS1,2=',PS(1,1),PS(1,2),PS(1,3),PS(1,4),
477c 1 '*',PS(2,1),PS(2,2),PS(2,3),PS(2,4)
478c endif
479
480 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,
481 &'(LUEXEC:) charge was not conserved')
482
483 RETURN
484 END
485
486C*********************************************************************
487
488 SUBROUTINE LUPREP(IP)
489
490C...Purpose: to rearrange partons along strings, to allow small systems
491C...to collapse into one or two particles and to check flavours.
492 IMPLICIT DOUBLE PRECISION(D)
493 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
494 SAVE /LUJETSA/
495 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
496 SAVE /LUDAT1A/
497 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
498 SAVE /LUDAT2A/
499 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
500 SAVE /LUDAT3A/
501 DIMENSION DPS(5),DPC(5),UE(3)
502
503 ic1=0
504 ic2=0
505 kci=0
506C...Rearrange parton shower product listing along strings: begin loop.
507 I1=N
508 DO 130 MQGST=1,2
509 DO 120 I=MAX(1,IP),N
510 IF(K(I,1).NE.3) GOTO 120
511 KC=LUCOMP(K(I,2))
512 IF(KC.EQ.0) GOTO 120
513 KQ=KCHG(KC,2)
514 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
515
516C...Pick up loose string end.
517 KCS=4
518 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
519 IA=I
520 NSTP=0
521 100 NSTP=NSTP+1
522 IF(NSTP.GT.4*N) THEN
523 CALL LUERRM(14,'(LUPREP:) caught in infinite loop')
524 RETURN
525 ENDIF
526
527C...Copy undecayed parton.
528 IF(K(IA,1).EQ.3) THEN
529 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
530 CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETSA')
531 RETURN
532 ENDIF
533 I1=I1+1
534 K(I1,1)=2
535 IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
536 K(I1,2)=K(IA,2)
537 K(I1,3)=IA
538 K(I1,4)=0
539 K(I1,5)=0
540 DO 110 J=1,5
541 P(I1,J)=P(IA,J)
542 110 V(I1,J)=V(IA,J)
543 K(IA,1)=K(IA,1)+10
544 IF(K(I1,1).EQ.1) GOTO 120
545 ENDIF
546
547C...Go to next parton in colour space.
548 IB=IA
549 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).
550 &NE.0) THEN
551 IA=MOD(K(IB,KCS),MSTU(5))
552 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
553 MREV=0
554 ELSE
555 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)).
556 & EQ.0) KCS=9-KCS
557 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
558 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
559 MREV=1
560 ENDIF
561 IF(IA.LE.0.OR.IA.GT.N) THEN
562 CALL LUERRM(12,'(LUPREP:) colour rearrangement failed')
563 RETURN
564 ENDIF
565 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
566 &MSTU(5)).EQ.IB) THEN
567 IF(MREV.EQ.1) KCS=9-KCS
568 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
569 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
570 ELSE
571 IF(MREV.EQ.0) KCS=9-KCS
572 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
573 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
574 ENDIF
575 IF(IA.NE.I) GOTO 100
576 K(I1,1)=1
577 120 CONTINUE
578 130 CONTINUE
579 N=I1
580
581C...Find lowest-mass colour singlet jet system, OK if above thresh.
582 IF(MSTJ(14).LE.0) GOTO 320
583 NS=N
584 140 NSIN=N-NS
585 PDM=1.+PARJ(32)
586 IC=0
587 DO 190 I=MAX(1,IP),NS
588 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
589 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
590 NSIN=NSIN+1
591 IC=I
592 DO 150 J=1,4
593 150 DPS(J)=dble(P(I,J))
594 MSTJ(93)=1
595 DPS(5)=dble(ULMASS(K(I,2)))
596 ELSEIF(K(I,1).EQ.2) THEN
597 DO 160 J=1,4
598 160 DPS(J)=DPS(J)+dble(P(I,J))
599 ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN
600 DO 170 J=1,4
601 170 DPS(J)=DPS(J)+dble(P(I,J))
602 MSTJ(93)=1
603 DPS(5)=DPS(5)+dble(ULMASS(K(I,2)))
604 PD=sngl(SQRT(MAX(0D0,DPS(4)**2
605 1 -DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5))
606 IF(PD.LT.PDM) THEN
607 PDM=PD
608 DO 180 J=1,5
609 180 DPC(J)=DPS(J)
610 IC1=IC
611 IC2=I
612 ENDIF
613 IC=0
614 ELSE
615 NSIN=NSIN+1
616 ENDIF
617 190 CONTINUE
618 IF(PDM.GE.PARJ(32)) GOTO 320
619
620C...Fill small-mass system as cluster.
621 NSAV=N
622 PECM=sngl(SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2)))
623 K(N+1,1)=11
624 K(N+1,2)=91
625 K(N+1,3)=IC1
626 K(N+1,4)=N+2
627 K(N+1,5)=N+3
628 P(N+1,1)=sngl(DPC(1))
629 P(N+1,2)=sngl(DPC(2))
630 P(N+1,3)=sngl(DPC(3))
631 P(N+1,4)=sngl(DPC(4))
632 P(N+1,5)=PECM
633
634C...Form two particles from flavours of lowest-mass system, if feasible.
635 K(N+2,1)=1
636 K(N+3,1)=1
637 IF(MSTU(16).NE.2) THEN
638 K(N+2,3)=N+1
639 K(N+3,3)=N+1
640 ELSE
641 K(N+2,3)=IC1
642 K(N+3,3)=IC2
643 ENDIF
644 K(N+2,4)=0
645 K(N+3,4)=0
646 K(N+2,5)=0
647 K(N+3,5)=0
648 IF(IABS(K(IC1,2)).NE.21) THEN
649 KC1=LUCOMP(K(IC1,2))
650 KC2=LUCOMP(K(IC2,2))
651 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
652 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
653 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
654 IF(KQ1+KQ2.NE.0) GOTO 320
655 200 CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))
656 CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
657 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
658 ELSE
659 IF(IABS(K(IC2,2)).NE.21) GOTO 320
660 210 CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)
661 CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))
662 CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
663 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
664 ENDIF
665 P(N+2,5)=ULMASS(K(N+2,2))
666 P(N+3,5)=ULMASS(K(N+3,2))
667 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
668 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
669
670C...Perform two-particle decay of jet system, if possible.
671 IF(PECM.GE.0.02d0*DPC(4)) THEN
672 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
673 & (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
674 UE(3)=2.*RLU(0)-1.
675 PHI=PARU(2)*RLU(0)
676 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
677 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
678 DO 220 J=1,3
679 P(N+2,J)=PA*UE(J)
680 220 P(N+3,J)=-PA*UE(J)
681 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
682 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
683 CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
684 & DPC(3)/DPC(4))
685 ELSE
686 NP=0
687 DO 230 I=IC1,IC2
688 230 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
689 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
690 & P(IC1,3)*P(IC2,3)
691 IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
692 HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
693 HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
694 HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
695 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
696 HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
697 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
698 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
699 DO 240 J=1,4
700 P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
701 240 P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
702 ENDIF
703 DO 250 J=1,4
704 V(N+1,J)=V(IC1,J)
705 V(N+2,J)=V(IC1,J)
706 250 V(N+3,J)=V(IC2,J)
707 V(N+1,5)=0.
708 V(N+2,5)=0.
709 V(N+3,5)=0.
710 N=N+3
711 GOTO 300
712
713C...Else form one particle from the flavours available, if possible.
714 260 K(N+1,5)=N+2
715 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
716 GOTO 320
717 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
718 CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
719 ELSE
720 KFLN=1+INT((2.+PARJ(2))*RLU(0))
721 CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
722 ENDIF
723 IF(K(N+2,2).EQ.0) GOTO 260
724 P(N+2,5)=ULMASS(K(N+2,2))
725
726C...Find parton/particle which combines to largest extra mass.
727 IR=0
728 HA=0.
729 DO 280 MCOMB=1,3
730 IF(IR.NE.0) GOTO 280
731 DO 270 I=MAX(1,IP),N
732 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2.
733 &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
734 IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2))
735 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
736 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
737 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
738 &GOTO 270
739 HCR=sngl(DPC(4))*P(I,4)-sngl(DPC(1))*P(I,1)
740 1 -sngl(DPC(2))*P(I,2)-sngl(DPC(3))*P(I,3)
741 IF(HCR.GT.HA) THEN
742 IR=I
743 HA=HCR
744 ENDIF
745 270 CONTINUE
746 280 CONTINUE
747
748C...Shuffle energy and momentum to put new particle on mass shell.
749 HB=PECM**2+HA
750 HC=P(N+2,5)**2+HA
751 HD=P(IR,5)**2+HA
752C******************CHANGES BY HIJING************
753 HK2=0.0
754 IF(HA**2-(PECM*P(IR,5))**2.EQ.0.0.OR.HB+HD.EQ.0.0) GO TO 285
755C******************
756 HK2=0.5*(HB*SQRT(((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
757 &(HA**2-(PECM*P(IR,5))**2))-(HB+HC))/(HB+HD)
758 285 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
759 DO 290 J=1,4
760 P(N+2,J)=(1.+HK1)*sngl(DPC(J))-HK2*P(IR,J)
761 P(IR,J)=(1.+HK2)*P(IR,J)-HK1*sngl(DPC(J))
762 V(N+1,J)=V(IC1,J)
763 290 V(N+2,J)=V(IC1,J)
764 V(N+1,5)=0.
765 V(N+2,5)=0.
766 N=N+2
767
768C...Mark collapsed system and store daughter pointers. Iterate.
769 300 DO 310 I=IC1,IC2
770 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)
771 &THEN
772 K(I,1)=K(I,1)+10
773 IF(MSTU(16).NE.2) THEN
774 K(I,4)=NSAV+1
775 K(I,5)=NSAV+1
776 ELSE
777 K(I,4)=NSAV+2
778 K(I,5)=N
779 ENDIF
780 ENDIF
781 310 CONTINUE
782 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
783
784C...Check flavours and invariant masses in parton systems.
785 320 NP=0
786 KFN=0
787 KQS=0
788 DO 330 J=1,5
789 330 DPS(J)=0d0
790 DO 360 I=MAX(1,IP),N
791 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
792 KC=LUCOMP(K(I,2))
793 IF(KC.EQ.0) GOTO 360
794 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
795 IF(KQ.EQ.0) GOTO 360
796 NP=NP+1
797 IF(KQ.NE.2) THEN
798 KFN=KFN+1
799 KQS=KQS+KQ
800 MSTJ(93)=1
801 DPS(5)=DPS(5)+dble(ULMASS(K(I,2)))
802 ENDIF
803 DO 340 J=1,4
804 340 DPS(J)=DPS(J)+dble(P(I,J))
805
806clin-4/12/01:
807c np: # of partons, KFN: number of quarks and diquarks,
808c KC=0 for color singlet system, -1 for quarks and anti-diquarks,
809c 1 for quarks and anti-diquarks, and 2 for gluons:
810 IF(K(I,1).EQ.1) THEN
811clin-4/12/01 end of color singlet system.
812 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
813 & LUERRM(2,'(LUPREP:) unphysical flavour combination')
814
815clin-4/16/01: 'jet system' should be defined as np.ne.2:
816c IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
817c & (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,
818c & '(LUPREP:) too small mass in jet system')
819 IF(NP.NE.2.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
820 & (0.9d0*dble(PARJ(32))+DPS(5))**2) then
821 CALL LUERRM(3,
822 & '(LUPREP:) too small mass in jet system')
823 write (6,*) 'DPS(1-5),KI1-5=',DPS(1),DPS(2),DPS(3),DPS(4),
824 1 DPS(5),'*',K(I,1),K(I,2),K(I,3),K(I,4),K(I,5)
825 endif
826
827 NP=0
828 KFN=0
829 KQS=0
830 DO 350 J=1,5
831 350 DPS(J)=0d0
832 ENDIF
833 360 CONTINUE
834
835 RETURN
836 END
837
838C*********************************************************************
839
840 SUBROUTINE LUSTRF(IP)
841C...Purpose: to handle the fragmentation of an arbitrary colour singlet
842C...jet system according to the Lund string fragmentation model.
843 IMPLICIT DOUBLE PRECISION(D)
844 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
845 SAVE /LUJETSA/
846 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
847 SAVE /LUDAT1A/
848 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
849 SAVE /LUDAT2A/
850 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
851 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
852 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5)
853
854C...Function: four-product of two vectors.
855 FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
856 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
857 &DP(I,3)*DP(J,3)
858
859 ir=0
860 in3=0
861 jr=0
862 prev=0
863
864C...Reset counters. Identify parton system.
865 MSTJ(91)=0
866 NSAV=N
867 NP=0
868 KQSUM=0
869 DO 100 J=1,5
870 100 DPS(J)=0d0
871 MJU(1)=0
872 MJU(2)=0
873 I=IP-1
874 110 I=I+1
875 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
876 CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')
877 IF(MSTU(21).GE.1) RETURN
878 ENDIF
879 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
880 KC=LUCOMP(K(I,2))
881 IF(KC.EQ.0) GOTO 110
882 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
883 IF(KQ.EQ.0) GOTO 110
884 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
885 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETSA')
886 IF(MSTU(21).GE.1) RETURN
887 ENDIF
888
889C...Take copy of partons to be considered. Check flavour sum.
890 NP=NP+1
891 DO 120 J=1,5
892 K(N+NP,J)=K(I,J)
893 P(N+NP,J)=P(I,J)
894 120 DPS(J)=DPS(J)+dble(P(I,J))
895 K(N+NP,3)=I
896 IF(P(N+NP,4)**2.LT.P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2) THEN
897 P(N+NP,4)=SQRT(P(N+NP,1)**2+P(N+NP,2)**2+P(N+NP,3)**2+
898 & P(N+NP,5)**2)
899 DPS(4)=DPS(4)+dble(MAX(0.,P(N+NP,4)-P(I,4)))
900 ENDIF
901 IF(KQ.NE.2) KQSUM=KQSUM+KQ
902 IF(K(I,1).EQ.41) THEN
903 KQSUM=KQSUM+2*KQ
904 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
905 IF(KQSUM.NE.KQ) MJU(2)=N+NP
906 ENDIF
907 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
908 IF(KQSUM.NE.0) THEN
909 CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
910 IF(MSTU(21).GE.1) RETURN
911 ENDIF
912
913C...Boost copied system to CM frame (for better numerical precision).
914 CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
915 &-DPS(3)/DPS(4))
916
917C...Search for very nearby partons that may be recombined.
918 NTRYR=0
919 PARU12=PARU(12)
920 PARU13=PARU(13)
921 MJU(3)=MJU(1)
922 MJU(4)=MJU(2)
923 NR=NP
924 130 IF(NR.GE.3) THEN
925 PDRMIN=2.*PARU12
926 DO 140 I=N+1,N+NR
927 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 140
928 I1=I+1
929 IF(I.EQ.N+NR) I1=N+1
930 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 140
931 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
932 & GOTO 140
933 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 140
934 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
935 & P(I1,2)**2+P(I1,3)**2))
936 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
937 PDR=4.*(PAP-PVP)**2/(PARU13**2*PAP+2.*(PAP-PVP))
938 IF(PDR.LT.PDRMIN) THEN
939 IR=I
940 PDRMIN=PDR
941 ENDIF
942 140 CONTINUE
943
944C...Recombine very nearby partons to avoid machine precision problems.
945 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
946 DO 150 J=1,4
947 150 P(N+1,J)=P(N+1,J)+P(N+NR,J)
948 P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
949 & P(N+1,3)**2))
950 NR=NR-1
951 GOTO 130
952 ELSEIF(PDRMIN.LT.PARU12) THEN
953 DO 160 J=1,4
954 160 P(IR,J)=P(IR,J)+P(IR+1,J)
955 P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
956 & P(IR,3)**2))
957 DO 170 I=IR+1,N+NR-1
958 K(I,2)=K(I+1,2)
959 DO 170 J=1,5
960 170 P(I,J)=P(I+1,J)
961 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
962 NR=NR-1
963 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
964 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
965 GOTO 130
966 ENDIF
967 ENDIF
968 NTRYR=NTRYR+1
969
970C...Reset particle counter. Skip ahead if no junctions are present;
971C...this is usually the case!
972 NRS=MAX(5*NR+11,NP)
973 NTRY=0
974 180 NTRY=NTRY+1
975 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
976 PARU12=4.*PARU12
977 PARU13=2.*PARU13
978 GOTO 130
979 ELSEIF(NTRY.GT.100) THEN
980 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
981 IF(MSTU(21).GE.1) RETURN
982 ENDIF
983 I=N+NRS
984 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 500
985 DO 490 JT=1,2
986 NJS(JT)=0
987 IF(MJU(JT).EQ.0) GOTO 490
988 JS=3-2*JT
989
990C...Find and sum up momentum on three sides of junction. Check flavours.
991 DO 190 IU=1,3
992 IJU(IU)=0
993 DO 190 J=1,5
994 190 PJU(IU,J)=0.
995 IU=0
996 DO 200 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
997 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
998 IU=IU+1
999 IJU(IU)=I1
1000 ENDIF
1001 DO 200 J=1,4
1002 200 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1003 DO 210 IU=1,3
1004 210 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1005 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1006 &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1007 CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1008 IF(MSTU(21).GE.1) RETURN
1009 ENDIF
1010
1011C...Calculate (approximate) boost to rest frame of junction.
1012 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1013 &(PJU(1,5)*PJU(2,5))
1014 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1015 &(PJU(1,5)*PJU(3,5))
1016 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1017 &(PJU(2,5)*PJU(3,5))
1018 T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1019 T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1020 TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1021 T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1022 T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1023 DO 220 J=1,3
1024 220 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1025 TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1026 DO 230 IU=1,3
1027 230 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1028 &TJU(3)*PJU(IU,3)
1029
1030C...Put junction at rest if motion could give inconsistencies.
1031 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1032 DO 240 J=1,3
1033 240 TJU(J)=0.
1034 TJU(4)=1.
1035 PJU(1,5)=PJU(1,4)
1036 PJU(2,5)=PJU(2,4)
1037 PJU(3,5)=PJU(3,4)
1038 ENDIF
1039
1040C...Start preparing for fragmentation of two strings from junction.
1041 ISTA=I
1042 DO 470 IU=1,2
1043 NS=IJU(IU+1)-IJU(IU)
1044
1045C...Junction strings: find longitudinal string directions.
1046 DO 260 IS=1,NS
1047 IS1=IJU(IU)+IS-1
1048 IS2=IJU(IU)+IS
1049 DO 250 J=1,5
1050 DP(1,J)=dble(0.5*P(IS1,J))
1051 IF(IS.EQ.1) DP(1,J)=dble(P(IS1,J))
1052 DP(2,J)=dble(0.5*P(IS2,J))
1053 250 IF(IS.EQ.NS) DP(2,J)=-dble(PJU(IU,J))
1054 IF(IS.EQ.NS) DP(2,4)=dble(
1055 1 SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2))
1056 IF(IS.EQ.NS) DP(2,5)=0d0
1057 DP(3,5)=DFOUR(1,1)
1058 DP(4,5)=DFOUR(2,2)
1059 DHKC=DFOUR(1,2)
1060 IF(DP(3,5)+2d0*DHKC+DP(4,5).LE.0d0) THEN
1061 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1062 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1063 DP(3,5)=0D0
1064 DP(4,5)=0D0
1065 DHKC=DFOUR(1,2)
1066 ENDIF
1067 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1068 DHK1=0.5d0*((DP(4,5)+DHKC)/DHKS-1d0)
1069 DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1d0)
1070 IN1=N+NR+4*IS-3
1071 P(IN1,5)=sngl(SQRT(DP(3,5)+2d0*DHKC+DP(4,5)))
1072 DO 260 J=1,4
1073 P(IN1,J)=sngl((1d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
1074 260 P(IN1+1,J)=sngl((1d0+DHK2)*DP(2,J)-DHK1*DP(1,J))
1075
1076C...Junction strings: initialize flavour, momentum and starting pos.
1077 ISAV=I
1078 270 NTRY=NTRY+1
1079 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1080 PARU12=4.*PARU12
1081 PARU13=2.*PARU13
1082 GOTO 130
1083 ELSEIF(NTRY.GT.100) THEN
1084 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1085 IF(MSTU(21).GE.1) RETURN
1086 ENDIF
1087 I=ISAV
1088 IRANKJ=0
1089 IE(1)=K(N+1+(JT/2)*(NP-1),3)
1090 IN(4)=N+NR+1
1091 IN(5)=IN(4)+1
1092 IN(6)=N+NR+4*NS+1
1093 DO 280 JQ=1,2
1094 DO 280 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1095 P(IN1,1)=2-JQ
1096 P(IN1,2)=JQ-1
1097 280 P(IN1,3)=1.
1098 KFL(1)=K(IJU(IU),2)
1099 PX(1)=0.
1100 PY(1)=0.
1101 GAM(1)=0.
1102 DO 290 J=1,5
1103 290 PJU(IU+3,J)=0.
1104
1105C...Junction strings: find initial transverse directions.
1106 DO 300 J=1,4
1107 DP(1,J)=dble(P(IN(4),J))
1108 DP(2,J)=dble(P(IN(4)+1,J))
1109 DP(3,J)=0d0
1110 300 DP(4,J)=0d0
1111 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1112 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1113 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1114 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1115 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1116 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1d0
1117 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1d0
1118 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1d0
1119 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1d0
1120 DHC12=DFOUR(1,2)
1121 DHCX1=DFOUR(3,1)/DHC12
1122 DHCX2=DFOUR(3,2)/DHC12
1123 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1124 DHCY1=DFOUR(4,1)/DHC12
1125 DHCY2=DFOUR(4,2)/DHC12
1126 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1127 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1128 DO 310 J=1,4
1129 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1130 P(IN(6),J)=sngl(DP(3,J))
1131 310 P(IN(6)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1132 &DHCYX*DP(3,J)))
1133
1134C...Junction strings: produce new particle, origin.
1135 320 I=I+1
1136 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1137 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETSA')
1138 IF(MSTU(21).GE.1) RETURN
1139 ENDIF
1140 IRANKJ=IRANKJ+1
1141 K(I,1)=1
1142 K(I,3)=IE(1)
1143 K(I,4)=0
1144 K(I,5)=0
1145
1146C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1147 330 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))
1148 IF(K(I,2).EQ.0) GOTO 270
1149 IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1150 &IABS(KFL(3)).GT.10) THEN
1151 IF(RLU(0).GT.PARJ(19)) GOTO 330
1152 ENDIF
1153 P(I,5)=ULMASS(K(I,2))
1154 CALL LUPTDI(KFL(1),PX(3),PY(3))
1155 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1156 CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)
1157 GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1158 DO 340 J=1,3
1159 340 IN(J)=IN(3+J)
1160
1161C...Junction strings: stepping within or from 'low' string region easy.
1162 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1163 &P(IN(1),5)**2.GE.PR(1)) THEN
1164 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1165 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1166 DO 350 J=1,4
1167 350 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1168 GOTO 420
1169 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1170 P(IN(2)+2,4)=P(IN(2)+2,3)
1171 P(IN(2)+2,1)=1.
1172 IN(2)=IN(2)+4
1173 IF(IN(2).GT.N+NR+4*NS) GOTO 270
1174 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1175 P(IN(1)+2,4)=P(IN(1)+2,3)
1176 P(IN(1)+2,1)=0.
1177 IN(1)=IN(1)+4
1178 ENDIF
1179 ENDIF
1180
1181C...Junction strings: find new transverse directions.
1182 360 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1183 &IN(1).GT.IN(2)) GOTO 270
1184 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1185 DO 370 J=1,4
1186 DP(1,J)=dble(P(IN(1),J))
1187 DP(2,J)=dble(P(IN(2),J))
1188 DP(3,J)=0d0
1189 370 DP(4,J)=0d0
1190 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1191 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1192 DHC12=DFOUR(1,2)
1193 IF(DHC12.LE.1E-2) THEN
1194 P(IN(1)+2,4)=P(IN(1)+2,3)
1195 P(IN(1)+2,1)=0.
1196 IN(1)=IN(1)+4
1197 GOTO 360
1198 ENDIF
1199 IN(3)=N+NR+4*NS+5
1200 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1201 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1202 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1203 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1d0
1204 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1d0
1205 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1d0
1206 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1d0
1207 DHCX1=DFOUR(3,1)/DHC12
1208 DHCX2=DFOUR(3,2)/DHC12
1209 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1210 DHCY1=DFOUR(4,1)/DHC12
1211 DHCY2=DFOUR(4,2)/DHC12
1212 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1213 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1214 DO 380 J=1,4
1215 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1216 P(IN(3),J)=sngl(DP(3,J))
1217 380 P(IN(3)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1218 & DHCYX*DP(3,J)))
1219C...Express pT with respect to new axes, if sensible.
1220 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
1221 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
1222 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1223 PX(3)=PXP
1224 PY(3)=PYP
1225 ENDIF
1226 ENDIF
1227
1228C...Junction strings: sum up known four-momentum, coefficients for m2.
1229 DO 400 J=1,4
1230 DHG(J)=0d0
1231 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1232 &PY(3)*P(IN(3)+1,J)
1233 DO 390 IN1=IN(4),IN(1)-4,4
1234 390 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1235 DO 400 IN2=IN(5),IN(2)-4,4
1236 400 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1237 DHM(1)=dble(FOUR(I,I))
1238 DHM(2)=dble(2.*FOUR(I,IN(1)))
1239 DHM(3)=dble(2.*FOUR(I,IN(2)))
1240 DHM(4)=dble(2.*FOUR(IN(1),IN(2)))
1241
1242C...Junction strings: find coefficients for Gamma expression.
1243 DO 410 IN2=IN(1)+1,IN(2),4
1244 DO 410 IN1=IN(1),IN2-1,4
1245 DHC=dble(2.*FOUR(IN1,IN2))
1246 DHG(1)=DHG(1)+dble(P(IN1+2,1)*P(IN2+2,1))*DHC
1247 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-dble(P(IN2+2,1))*DHC
1248 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+dble(P(IN1+2,1))*DHC
1249 410 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1250
1251C...Junction strings: solve (m2, Gamma) equation system for energies.
1252 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1253 IF(ABS(DHS1).LT.1E-4) GOTO 270
1254 DHS2=DHM(4)*(dble(GAM(3))-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1255 &(dble(P(I,5))**2-DHM(1))+DHG(2)*DHM(3)
1256 DHS3=DHM(2)*(dble(GAM(3))-DHG(1))
1257 1 -DHG(2)*(dble(P(I,5))**2-DHM(1))
1258 P(IN(2)+2,4)=0.5*sngl(SQRT(MAX(0D0,DHS2**2-4d0*DHS1*DHS3))
1259 & /ABS(DHS1)-DHS2/DHS1)
1260 IF(DHM(2)+DHM(4)*dble(P(IN(2)+2,4)).LE.0d0) GOTO 270
1261 P(IN(1)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(3))*P(IN(2)+2,4))/
1262 &(sngl(DHM(2))+sngl(DHM(4))*P(IN(2)+2,4))
1263
1264C...Junction strings: step to new region if necessary.
1265 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1266 P(IN(2)+2,4)=P(IN(2)+2,3)
1267 P(IN(2)+2,1)=1.
1268 IN(2)=IN(2)+4
1269 IF(IN(2).GT.N+NR+4*NS) GOTO 270
1270 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1271 P(IN(1)+2,4)=P(IN(1)+2,3)
1272 P(IN(1)+2,1)=0.
1273 IN(1)=IN(1)+4
1274 ENDIF
1275 GOTO 360
1276 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1277 P(IN(1)+2,4)=P(IN(1)+2,3)
1278 P(IN(1)+2,1)=0.
1279 IN(1)=IN(1)+JS
1280 GOTO 710
1281 ENDIF
1282
1283C...Junction strings: particle four-momentum, remainder, loop back.
1284 420 DO 430 J=1,4
1285 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1286 430 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1287 IF(P(I,4).LE.0.) GOTO 270
1288 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1289 &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1290 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1291 KFL(1)=-KFL(3)
1292 PX(1)=-PX(3)
1293 PY(1)=-PY(3)
1294 GAM(1)=GAM(3)
1295 IF(IN(3).NE.IN(6)) THEN
1296 DO 440 J=1,4
1297 P(IN(6),J)=P(IN(3),J)
1298 440 P(IN(6)+1,J)=P(IN(3)+1,J)
1299 ENDIF
1300 DO 450 JQ=1,2
1301 IN(3+JQ)=IN(JQ)
1302 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1303 450 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1304 GOTO 320
1305 ENDIF
1306
1307C...Junction strings: save quantities left after each string.
1308 IF(IABS(KFL(1)).GT.10) GOTO 270
1309 I=I-1
1310 KFJH(IU)=KFL(1)
1311 DO 460 J=1,4
1312 460 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
1313 470 CONTINUE
1314
1315C...Junction strings: put together to new effective string endpoint.
1316 NJS(JT)=I-ISTA
1317 KFJS(JT)=K(K(MJU(JT+2),3),2)
1318 KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
1319 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
1320 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
1321 &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
1322 &KFLS,KFJH(1))
1323 DO 480 J=1,4
1324 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
1325 480 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
1326 PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
1327 &PJS(JT,3)**2))
1328 490 CONTINUE
1329
1330C...Open versus closed strings. Choose breakup region for latter.
1331 500 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
1332 NS=MJU(2)-MJU(1)
1333 NB=MJU(1)-N
1334 ELSEIF(MJU(1).NE.0) THEN
1335 NS=N+NR-MJU(1)
1336 NB=MJU(1)-N
1337 ELSEIF(MJU(2).NE.0) THEN
1338 NS=MJU(2)-N
1339 NB=1
1340 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
1341 NS=NR-1
1342 NB=1
1343 ELSE
1344 NS=NR+1
1345 W2SUM=0.
1346 DO 510 IS=1,NR
1347 P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
1348 510 W2SUM=W2SUM+P(N+NR+IS,1)
1349 W2RAN=RLU(0)*W2SUM
1350 NB=0
1351 520 NB=NB+1
1352 W2SUM=W2SUM-P(N+NR+NB,1)
1353 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 520
1354 ENDIF
1355
1356C...Find longitudinal string directions (i.e. lightlike four-vectors).
1357 DO 540 IS=1,NS
1358 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
1359 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
1360 DO 530 J=1,5
1361 DP(1,J)=dble(P(IS1,J))
1362 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5d0*DP(1,J)
1363 IF(IS1.EQ.MJU(1)) DP(1,J)=dble(PJS(1,J)-PJS(3,J))
1364 DP(2,J)=dble(P(IS2,J))
1365 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5d0*DP(2,J)
1366 530 IF(IS2.EQ.MJU(2)) DP(2,J)=dble(PJS(2,J)-PJS(4,J))
1367 DP(3,5)=DFOUR(1,1)
1368 DP(4,5)=DFOUR(2,2)
1369 DHKC=DFOUR(1,2)
1370 IF(DP(3,5)+2.d0*DHKC+DP(4,5).LE.0.d0) THEN
1371 DP(3,5)=DP(1,5)**2
1372 DP(4,5)=DP(2,5)**2
1373 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
1374 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
1375 DHKC=DFOUR(1,2)
1376 ENDIF
1377 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1378 DHK1=0.5d0*((DP(4,5)+DHKC)/DHKS-1.d0)
1379 DHK2=0.5d0*((DP(3,5)+DHKC)/DHKS-1.d0)
1380 IN1=N+NR+4*IS-3
1381 P(IN1,5)=SQRT(sngl(DP(3,5)+2.d0*DHKC+DP(4,5)))
1382 DO 540 J=1,4
1383 P(IN1,J)=sngl((1.d0+DHK1)*DP(1,J)-DHK2*DP(2,J))
1384 540 P(IN1+1,J)=sngl((1.d0+DHK2)*DP(2,J)-DHK1*DP(1,J))
1385
1386C...Begin initialization: sum up energy, set starting position.
1387 ISAV=I
1388 550 NTRY=NTRY+1
1389 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1390 PARU12=4.*PARU12
1391 PARU13=2.*PARU13
1392 GOTO 130
1393 ELSEIF(NTRY.GT.100) THEN
1394 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1395 IF(MSTU(21).GE.1) RETURN
1396 ENDIF
1397 I=ISAV
1398 DO 560 J=1,4
1399 P(N+NRS,J)=0.
1400 DO 560 IS=1,NR
1401 560 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
1402 DO 570 JT=1,2
1403 IRANK(JT)=0
1404 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
1405 IF(NS.GT.NR) IRANK(JT)=1
1406 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
1407 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
1408 IN(3*JT+2)=IN(3*JT+1)+1
1409 IN(3*JT+3)=N+NR+4*NS+2*JT-1
1410 DO 570 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
1411 P(IN1,1)=2-JT
1412 P(IN1,2)=JT-1
1413 570 P(IN1,3)=1.
1414
1415C...Initialize flavour and pT variables for open string.
1416 IF(NS.LT.NR) THEN
1417 PX(1)=0.
1418 PY(1)=0.
1419 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))
1420 PX(2)=-PX(1)
1421 PY(2)=-PY(1)
1422 DO 580 JT=1,2
1423 KFL(JT)=K(IE(JT),2)
1424 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
1425 MSTJ(93)=1
1426 PMQ(JT)=ULMASS(KFL(JT))
1427 580 GAM(JT)=0.
1428
1429C...Closed string: random initial breakup flavour, pT and vertex.
1430 ELSE
1431 KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1432 CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)
1433 KFL(2)=-KFL(1)
1434 IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN
1435 KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
1436 ELSEIF(IABS(KFL(1)).GT.10) THEN
1437 KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
1438 ENDIF
1439 CALL LUPTDI(KFL(1),PX(1),PY(1))
1440 PX(2)=-PX(1)
1441 PY(2)=-PY(1)
1442 PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
1443 590 CALL LUZDIS(KFL(1),KFL(2),PR3,Z)
1444 ZR=PR3/(Z*P(N+NR+1,5)**2)
1445 IF(ZR.GE.1.) GOTO 590
1446
1447 DO 600 JT=1,2
1448 MSTJ(93)=1
1449 PMQ(JT)=ULMASS(KFL(JT))
1450 GAM(JT)=PR3*(1.-Z)/Z
1451 IN1=N+NR+3+4*(JT/2)*(NS-1)
1452 P(IN1,JT)=1.-Z
1453 P(IN1,3-JT)=JT-1
1454 P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
1455 P(IN1+1,JT)=ZR
1456 P(IN1+1,3-JT)=2-JT
1457 600 P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
1458 ENDIF
1459
1460C...Find initial transverse directions (i.e. spacelike four-vectors).
1461 DO 640 JT=1,2
1462 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
1463 IN1=IN(3*JT+1)
1464 IN3=IN(3*JT+3)
1465 DO 610 J=1,4
1466 DP(1,J)=dble(P(IN1,J))
1467 DP(2,J)=dble(P(IN1+1,J))
1468 DP(3,J)=0.d0
1469 610 DP(4,J)=0.d0
1470 DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1471 DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1472 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1473 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1474 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1475 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.d0
1476 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
1477 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
1478 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
1479 DHC12=DFOUR(1,2)
1480 DHCX1=DFOUR(3,1)/DHC12
1481 DHCX2=DFOUR(3,2)/DHC12
1482 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1483 DHCY1=DFOUR(4,1)/DHC12
1484 DHCY2=DFOUR(4,2)/DHC12
1485 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1486 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1487 DO 620 J=1,4
1488 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1489 P(IN3,J)=sngl(DP(3,J))
1490 620 P(IN3+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1491 & DHCYX*DP(3,J)))
1492 ELSE
1493 DO 630 J=1,4
1494 P(IN3+2,J)=P(IN3,J)
1495 630 P(IN3+3,J)=P(IN3+1,J)
1496 ENDIF
1497 640 CONTINUE
1498
1499C...Remove energy used up in junction string fragmentation.
1500 IF(MJU(1)+MJU(2).GT.0) THEN
1501 DO 660 JT=1,2
1502 IF(NJS(JT).EQ.0) GOTO 660
1503 DO 650 J=1,4
1504 650 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
1505 660 CONTINUE
1506 ENDIF
1507
1508C...Produce new particle: side, origin.
1509 670 I=I+1
1510 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1511 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETSA')
1512 IF(MSTU(21).GE.1) RETURN
1513 ENDIF
1514 JT=int(1.5+RLU(0))
1515 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
1516 JR=3-JT
1517 JS=3-2*JT
1518 IRANK(JT)=IRANK(JT)+1
1519 K(I,1)=1
1520 K(I,3)=IE(JT)
1521 K(I,4)=0
1522 K(I,5)=0
1523
1524C...Generate flavour, hadron and pT.
1525 680 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))
1526 IF(K(I,2).EQ.0) GOTO 550
1527 IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
1528 &IABS(KFL(3)).GT.10) THEN
1529 IF(RLU(0).GT.PARJ(19)) GOTO 680
1530 ENDIF
1531 P(I,5)=ULMASS(K(I,2))
1532 CALL LUPTDI(KFL(JT),PX(3),PY(3))
1533 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
1534
1535C...Final hadrons for small invariant mass.
1536 MSTJ(93)=1
1537 PMQ(3)=ULMASS(KFL(3))
1538 WMIN=PARJ(32+MSTJ(11))+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
1539 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
1540 &WMIN-0.5*PARJ(36)*PMQ(3)
1541 WREM2=FOUR(N+NRS,N+NRS)
1542 IF(WREM2.LT.0.10) GOTO 550
1543 IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),
1544 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 810
1545
1546C...Choose z, which gives Gamma. Shift z for heavy flavours.
1547 CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)
1548
1549 KFL1A=IABS(KFL(1))
1550 KFL2A=IABS(KFL(2))
1551 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
1552 &MOD(KFL2A/1000,10)).GE.4) THEN
1553 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
1554 PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
1555 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
1556 PR(JR)=(PMQ(JR)+PARJ(32+MSTJ(11)))**2+(PX(JR)-PX(3))**2+
1557 & (PY(JR)-PY(3))**2
1558 IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 810
1559 ENDIF
1560 GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
1561 DO 690 J=1,3
1562 690 IN(J)=IN(3*JT+J)
1563
1564C...Stepping within or from 'low' string region easy.
1565 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1566 &P(IN(1),5)**2.GE.PR(JT)) THEN
1567 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
1568 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
1569 DO 700 J=1,4
1570 700 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
1571 GOTO 770
1572 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1573 P(IN(JR)+2,4)=P(IN(JR)+2,3)
1574 P(IN(JR)+2,JT)=1.
1575 IN(JR)=IN(JR)+4*JS
1576 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
1577 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1578 P(IN(JT)+2,4)=P(IN(JT)+2,3)
1579 P(IN(JT)+2,JT)=0.
1580 IN(JT)=IN(JT)+4*JS
1581 ENDIF
1582 ENDIF
1583
1584C...Find new transverse directions (i.e. spacelike string vectors).
1585 710 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
1586 &IN(1).GT.IN(2)) GOTO 550
1587 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
1588 DO 720 J=1,4
1589 DP(1,J)=dble(P(IN(1),J))
1590 DP(2,J)=dble(P(IN(2),J))
1591 DP(3,J)=0.d0
1592 720 DP(4,J)=0.d0
1593 DP(1,4)=DSQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1594 DP(2,4)=DSQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1595 DHC12=DFOUR(1,2)
1596 IF(DHC12.LE.1E-2) THEN
1597 P(IN(JT)+2,4)=P(IN(JT)+2,3)
1598 P(IN(JT)+2,JT)=0.
1599 IN(JT)=IN(JT)+4*JS
1600 GOTO 710
1601 ENDIF
1602 IN(3)=N+NR+4*NS+5
1603 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1604 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1605 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1606 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.d0
1607 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.d0
1608 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.d0
1609 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.d0
1610 DHCX1=DFOUR(3,1)/DHC12
1611 DHCX2=DFOUR(3,2)/DHC12
1612 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1613 DHCY1=DFOUR(4,1)/DHC12
1614 DHCY2=DFOUR(4,2)/DHC12
1615 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1616 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1617 DO 730 J=1,4
1618 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1619 P(IN(3),J)=sngl(DP(3,J))
1620 730 P(IN(3)+1,J)=sngl(DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1621 & DHCYX*DP(3,J)))
1622C...Express pT with respect to new axes, if sensible.
1623 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
1624 & FOUR(IN(3*JT+3)+1,IN(3)))
1625 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
1626 & FOUR(IN(3*JT+3)+1,IN(3)+1))
1627 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1628 PX(3)=PXP
1629 PY(3)=PYP
1630 ENDIF
1631 ENDIF
1632
1633C...Sum up known four-momentum. Gives coefficients for m2 expression.
1634 DO 750 J=1,4
1635 DHG(J)=0.d0
1636 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
1637 &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
1638 DO 740 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
1639 740 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1640 DO 750 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
1641 750 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1642 DHM(1)=dble(FOUR(I,I))
1643 DHM(2)=dble(2.*FOUR(I,IN(1)))
1644 DHM(3)=dble(2.*FOUR(I,IN(2)))
1645 DHM(4)=dble(2.*FOUR(IN(1),IN(2)))
1646
1647C...Find coefficients for Gamma expression.
1648 DO 760 IN2=IN(1)+1,IN(2),4
1649 DO 760 IN1=IN(1),IN2-1,4
1650 DHC=dble(2.*FOUR(IN1,IN2))
1651 DHG(1)=DHG(1)+dble(P(IN1+2,JT)*P(IN2+2,JT))*DHC
1652 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-dble(float(JS)*P(IN2+2,JT))*DHC
1653 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+dble(float(JS)*P(IN1+2,JT))*DHC
1654 760 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1655
1656C...Solve (m2, Gamma) equation system for energies taken.
1657 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
1658 IF(ABS(DHS1).LT.1E-4) GOTO 550
1659 DHS2=DHM(4)*(dble(GAM(3))-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
1660 &(dble(P(I,5))**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
1661 DHS3=DHM(JT+1)*(dble(GAM(3))-DHG(1))-DHG(JT+1)
1662 & *(dble(P(I,5))**2-DHM(1))
1663 P(IN(JR)+2,4)=0.5*sngl((SQRT(MAX(0D0,DHS2**2-4.d0*DHS1*DHS3)))
1664 &/ABS(DHS1)-DHS2/DHS1)
1665 IF(DHM(JT+1)+DHM(4)*dble(P(IN(JR)+2,4)).LE.0.d0) GOTO 550
1666 P(IN(JT)+2,4)=(P(I,5)**2-sngl(DHM(1))-sngl(DHM(JR+1))
1667 & *P(IN(JR)+2,4))/(sngl(DHM(JT+1))+sngl(DHM(4))*P(IN(JR)+2,4))
1668
1669C...Step to new region if necessary.
1670 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
1671 P(IN(JR)+2,4)=P(IN(JR)+2,3)
1672 P(IN(JR)+2,JT)=1.
1673 IN(JR)=IN(JR)+4*JS
1674 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 550
1675 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1676 P(IN(JT)+2,4)=P(IN(JT)+2,3)
1677 P(IN(JT)+2,JT)=0.
1678 IN(JT)=IN(JT)+4*JS
1679 ENDIF
1680 GOTO 710
1681 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
1682 P(IN(JT)+2,4)=P(IN(JT)+2,3)
1683 P(IN(JT)+2,JT)=0.
1684 IN(JT)=IN(JT)+4*JS
1685 GOTO 710
1686 ENDIF
1687
1688C...Four-momentum of particle. Remaining quantities. Loop back.
1689 770 DO 780 J=1,4
1690 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1691 780 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
1692 IF(P(I,4).LE.0.) GOTO 550
1693 KFL(JT)=-KFL(3)
1694 PMQ(JT)=PMQ(3)
1695 PX(JT)=-PX(3)
1696 PY(JT)=-PY(3)
1697 GAM(JT)=GAM(3)
1698 IF(IN(3).NE.IN(3*JT+3)) THEN
1699 DO 790 J=1,4
1700 P(IN(3*JT+3),J)=P(IN(3),J)
1701 790 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
1702 ENDIF
1703 DO 800 JQ=1,2
1704 IN(3*JT+JQ)=IN(JQ)
1705 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1706 800 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
1707 GOTO 670
1708
1709C...Final hadron: side, flavour, hadron, mass.
1710 810 I=I+1
1711 K(I,1)=1
1712 K(I,3)=IE(JR)
1713 K(I,4)=0
1714 K(I,5)=0
1715 CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
1716 IF(K(I,2).EQ.0) GOTO 550
1717 P(I,5)=ULMASS(K(I,2))
1718 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
1719
1720C...Final two hadrons: find common setup of four-vectors.
1721 JQ=1
1722 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
1723 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
1724 DHC12=dble(FOUR(IN(3*JQ+1),IN(3*JQ+2)))
1725 DHR1=dble(FOUR(N+NRS,IN(3*JQ+2)))/DHC12
1726 DHR2=dble(FOUR(N+NRS,IN(3*JQ+1)))/DHC12
1727 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
1728 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
1729 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
1730 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
1731 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
1732 ENDIF
1733
1734C...Solve kinematics for final two hadrons, if possible.
1735 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
1736 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
1737 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 180
1738 IF(FD.GE.1.) GOTO 550
1739 FA=WREM2+PR(JT)-PR(JR)
1740 IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(37+MSTJ(11))
1741 IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-100.,LOG(FD)*
1742 &PARJ(37+MSTJ(11))*(PR(1)+PR(2))**2))
1743 FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV))
1744 KFL1A=IABS(KFL(1))
1745 KFL2A=IABS(KFL(2))
1746 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
1747 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
1748 &4.*WREM2*PR(JT))),FLOAT(JS))
1749 DO 820 J=1,4
1750 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
1751 &P(IN(3*JQ+3)+1,J)+0.5*(sngl(DHR1)*(FA+FB)*P(IN(3*JQ+1),J)+
1752 &sngl(DHR2)*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
1753 820 P(I,J)=P(N+NRS,J)-P(I-1,J)
1754
1755C...Mark jets as fragmented and give daughter pointers.
1756 N=I-NRS+1
1757 DO 830 I=NSAV+1,NSAV+NP
1758 IM=K(I,3)
1759 K(IM,1)=K(IM,1)+10
1760 IF(MSTU(16).NE.2) THEN
1761 K(IM,4)=NSAV+1
1762 K(IM,5)=NSAV+1
1763 ELSE
1764 K(IM,4)=NSAV+2
1765 K(IM,5)=N
1766 ENDIF
1767 830 CONTINUE
1768
1769C...Document string system. Move up particles.
1770 NSAV=NSAV+1
1771 K(NSAV,1)=11
1772 K(NSAV,2)=92
1773 K(NSAV,3)=IP
1774 K(NSAV,4)=NSAV+1
1775 K(NSAV,5)=N
1776 DO 840 J=1,4
1777 P(NSAV,J)=sngl(DPS(J))
1778 840 V(NSAV,J)=V(IP,J)
1779 P(NSAV,5)=SQRT(sngl(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2
1780 & -DPS(3)**2)))
1781 V(NSAV,5)=0.
1782 DO 850 I=NSAV+1,N
1783
1784 DO 850 J=1,5
1785 K(I,J)=K(I+NRS-1,J)
1786 P(I,J)=P(I+NRS-1,J)
1787 850 V(I,J)=0.
1788
1789C...Order particles in rank along the chain. Update mother pointer.
1790 DO 860 I=NSAV+1,N
1791 DO 860 J=1,5
1792 K(I-NSAV+N,J)=K(I,J)
1793 860 P(I-NSAV+N,J)=P(I,J)
1794 I1=NSAV
1795 DO 880 I=N+1,2*N-NSAV
1796 IF(K(I,3).NE.IE(1)) GOTO 880
1797 I1=I1+1
1798 DO 870 J=1,5
1799 K(I1,J)=K(I,J)
1800 870 P(I1,J)=P(I,J)
1801 IF(MSTU(16).NE.2) K(I1,3)=NSAV
1802 880 CONTINUE
1803 DO 900 I=2*N-NSAV,N+1,-1
1804 IF(K(I,3).EQ.IE(1)) GOTO 900
1805 I1=I1+1
1806 DO 890 J=1,5
1807 K(I1,J)=K(I,J)
1808 890 P(I1,J)=P(I,J)
1809 IF(MSTU(16).NE.2) K(I1,3)=NSAV
1810 900 CONTINUE
1811
1812C...Boost back particle system. Set production vertices.
1813 CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
1814 &DPS(3)/DPS(4))
1815 DO 910 I=NSAV+1,N
1816
1817 DO 910 J=1,4
1818 910 V(I,J)=V(IP,J)
1819
1820 RETURN
1821 END
1822
1823C*********************************************************************
1824
1825 SUBROUTINE LUINDF(IP)
1826
1827C...Purpose: to handle the fragmentation of a jet system (or a single
1828C...jet) according to independent fragmentation models.
1829 IMPLICIT DOUBLE PRECISION(D)
1830 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
1831 SAVE /LUJETSA/
1832 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1833 SAVE /LUDAT1A/
1834 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1835 SAVE /LUDAT2A/
1836 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
1837 &KFLO(2),PXO(2),PYO(2),WO(2)
1838
1839 pw=0.
1840C...Reset counters. Identify parton system and take copy. Check flavour.
1841 NSAV=N
1842 NJET=0
1843 KQSUM=0
1844 DO 100 J=1,5
1845 100 DPS(J)=0.d0
1846 I=IP-1
1847 110 I=I+1
1848 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1849 CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')
1850 IF(MSTU(21).GE.1) RETURN
1851 ENDIF
1852 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
1853 KC=LUCOMP(K(I,2))
1854 IF(KC.EQ.0) GOTO 110
1855 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1856 IF(KQ.EQ.0) GOTO 110
1857 NJET=NJET+1
1858 IF(KQ.NE.2) KQSUM=KQSUM+KQ
1859 DO 120 J=1,5
1860 K(NSAV+NJET,J)=K(I,J)
1861 P(NSAV+NJET,J)=P(I,J)
1862 120 DPS(J)=DPS(J)+dble(P(I,J))
1863 K(NSAV+NJET,3)=I
1864 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
1865 &K(I+1,1).EQ.2)) GOTO 110
1866 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
1867 CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')
1868 IF(MSTU(21).GE.1) RETURN
1869 ENDIF
1870
1871C...Boost copied system to CM frame. Find CM energy and sum flavours.
1872 IF(NJET.NE.1) CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
1873 &-DPS(2)/DPS(4),-DPS(3)/DPS(4))
1874 PECM=0.
1875 DO 130 J=1,3
1876 130 NFI(J)=0
1877 DO 140 I=NSAV+1,NSAV+NJET
1878 PECM=PECM+P(I,4)
1879 KFA=IABS(K(I,2))
1880 IF(KFA.LE.3) THEN
1881 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
1882 ELSEIF(KFA.GT.1000) THEN
1883 KFLA=MOD(KFA/1000,10)
1884 KFLB=MOD(KFA/100,10)
1885 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
1886 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
1887 ENDIF
1888 140 CONTINUE
1889
1890C...Loop over attempts made. Reset counters.
1891 NTRY=0
1892 150 NTRY=NTRY+1
1893 N=NSAV+NJET
1894 IF(NTRY.GT.200) THEN
1895 CALL LUERRM(14,'(LUINDF:) caught in infinite loop')
1896 IF(MSTU(21).GE.1) RETURN
1897 ENDIF
1898 DO 160 J=1,3
1899 NFL(J)=NFI(J)
1900 IFET(J)=0
1901 160 KFLF(J)=0
1902
1903C...Loop over jets to be fragmented.
1904 DO 230 IP1=NSAV+1,NSAV+NJET
1905 MSTJ(91)=0
1906 NSAV1=N
1907
1908C...Initial flavour and momentum values. Jet along +z axis.
1909 KFLH=IABS(K(IP1,2))
1910 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
1911 KFLO(2)=0
1912 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
1913
1914C...Initial values for quark or diquark jet.
1915 170 IF(IABS(K(IP1,2)).NE.21) THEN
1916 NSTR=1
1917 KFLO(1)=K(IP1,2)
1918 CALL LUPTDI(0,PXO(1),PYO(1))
1919 WO(1)=WF
1920
1921C...Initial values for gluon treated like random quark jet.
1922 ELSEIF(MSTJ(2).LE.2) THEN
1923 NSTR=1
1924 IF(MSTJ(2).EQ.2) MSTJ(91)=1
1925 KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1926 CALL LUPTDI(0,PXO(1),PYO(1))
1927 WO(1)=WF
1928
1929C...Initial values for gluon treated like quark-antiquark jet pair,
1930C...sharing energy according to Altarelli-Parisi splitting function.
1931 ELSE
1932 NSTR=2
1933 IF(MSTJ(2).EQ.4) MSTJ(91)=1
1934 KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1935 KFLO(2)=-KFLO(1)
1936 CALL LUPTDI(0,PXO(1),PYO(1))
1937 PXO(2)=-PXO(1)
1938 PYO(2)=-PYO(1)
1939 WO(1)=WF*RLU(0)**(1./3.)
1940 WO(2)=WF-WO(1)
1941 ENDIF
1942
1943C...Initial values for rank, flavour, pT and W+.
1944 DO 220 ISTR=1,NSTR
1945 180 I=N
1946 IRANK=0
1947 KFL1=KFLO(ISTR)
1948 PX1=PXO(ISTR)
1949 PY1=PYO(ISTR)
1950 W=WO(ISTR)
1951
1952C...New hadron. Generate flavour and hadron species.
1953 190 I=I+1
1954 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
1955 CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETSA')
1956 IF(MSTU(21).GE.1) RETURN
1957 ENDIF
1958 IRANK=IRANK+1
1959 K(I,1)=1
1960 K(I,3)=IP1
1961 K(I,4)=0
1962 K(I,5)=0
1963 200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))
1964 IF(K(I,2).EQ.0) GOTO 180
1965 IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
1966 &IABS(KFL2).GT.10) THEN
1967 IF(RLU(0).GT.PARJ(19)) GOTO 200
1968 ENDIF
1969
1970C...Find hadron mass. Generate four-momentum.
1971 P(I,5)=ULMASS(K(I,2))
1972 CALL LUPTDI(KFL1,PX2,PY2)
1973 P(I,1)=PX1+PX2
1974 P(I,2)=PY1+PY2
1975 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
1976 CALL LUZDIS(KFL1,KFL2,PR,Z)
1977 P(I,3)=0.5*(Z*W-PR/(Z*W))
1978 P(I,4)=0.5*(Z*W+PR/(Z*W))
1979 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
1980 &P(I,3).LE.0.001) THEN
1981 IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
1982 P(I,3)=0.0001
1983 P(I,4)=SQRT(PR)
1984 Z=P(I,4)/W
1985 ENDIF
1986
1987C...Remaining flavour and momentum.
1988 KFL1=-KFL2
1989 PX1=-PX2
1990 PY1=-PY2
1991 W=(1.-Z)*W
1992 DO 210 J=1,5
1993 210 V(I,J)=0.
1994
1995C...Check if pL acceptable. Go back for new hadron if enough energy.
1996 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) I=I-1
1997 IF(W.GT.PARJ(31)) GOTO 190
1998 220 N=I
1999 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2000 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2001
2002C...Rotate jet to new direction.
2003 THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2004 PHI=ULANGL(P(IP1,1),P(IP1,2))
2005 CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2006 K(K(IP1,3),4)=NSAV1+1
2007 K(K(IP1,3),5)=N
2008
2009C...End of jet generation loop. Skip conservation in some cases.
2010 230 CONTINUE
2011 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470
2012 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2013
2014C...Subtract off produced hadron flavours, finished if zero.
2015 DO 240 I=NSAV+NJET+1,N
2016 KFA=IABS(K(I,2))
2017 KFLA=MOD(KFA/1000,10)
2018 KFLB=MOD(KFA/100,10)
2019 KFLC=MOD(KFA/10,10)
2020 IF(KFLA.EQ.0) THEN
2021 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2022 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2023 ELSE
2024 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2025 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2026 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2027 ENDIF
2028 240 CONTINUE
2029 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2030 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2031 IF(NREQ.EQ.0) GOTO 320
2032
2033C...Take away flavour of low-momentum particles until enough freedom.
2034 NREM=0
2035 250 IREM=0
2036 P2MIN=PECM**2
2037 DO 260 I=NSAV+NJET+1,N
2038 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2039 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2040 260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2041 IF(IREM.EQ.0) GOTO 150
2042 K(IREM,1)=7
2043 KFA=IABS(K(IREM,2))
2044 KFLA=MOD(KFA/1000,10)
2045 KFLB=MOD(KFA/100,10)
2046 KFLC=MOD(KFA/10,10)
2047 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2048 IF(K(IREM,1).EQ.8) GOTO 250
2049 IF(KFLA.EQ.0) THEN
2050 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2051 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2052 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2053 ELSE
2054 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2055 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2056 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2057 ENDIF
2058 NREM=NREM+1
2059 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2060 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2061 IF(NREQ.GT.NREM) GOTO 250
2062 DO 270 I=NSAV+NJET+1,N
2063 270 IF(K(I,1).EQ.8) K(I,1)=1
2064
2065C...Find combination of existing and new flavours for hadron.
2066 280 NFET=2
2067 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2068 IF(NREQ.LT.NREM) NFET=1
2069 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2070 DO 290 J=1,NFET
2071 IFET(J)=1+int((IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0))
2072 KFLF(J)=ISIGN(1,NFL(1))
2073 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2074 290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2075 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2076 &GOTO 280
2077 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2078 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).
2079 &LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2080 IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))
2081 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2082 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))
2083 IF(NFET.LE.2) KFLF(3)=0
2084 IF(KFLF(3).NE.0) THEN
2085 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2086 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2087 IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)
2088 & KFLFC=KFLFC+ISIGN(2,KFLFC)
2089 ELSE
2090 KFLFC=KFLF(1)
2091 ENDIF
2092 CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2093 IF(KF.EQ.0) GOTO 280
2094 DO 300 J=1,MAX(2,NFET)
2095 300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2096
2097C...Store hadron at random among free positions.
2098 NPOS=MIN(1+INT(RLU(0)*NREM),NREM)
2099 DO 310 I=NSAV+NJET+1,N
2100 IF(K(I,1).EQ.7) NPOS=NPOS-1
2101 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2102 K(I,1)=1
2103 K(I,2)=KF
2104 P(I,5)=ULMASS(K(I,2))
2105 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2106 310 CONTINUE
2107 NREM=NREM-1
2108 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2109 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2110 IF(NREM.GT.0) GOTO 280
2111
2112C...Compensate for missing momentum in global scheme (3 options).
2113 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
2114 DO 330 J=1,3
2115 PSI(J)=0.
2116 DO 330 I=NSAV+NJET+1,N
2117 330 PSI(J)=PSI(J)+P(I,J)
2118 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2119 PWS=0.
2120 DO 340 I=NSAV+NJET+1,N
2121 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2122 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2123 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2124 340 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2125 DO 360 I=NSAV+NJET+1,N
2126 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2127 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2128 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2129 IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2130 DO 350 J=1,3
2131 350 P(I,J)=P(I,J)-PSI(J)*PW/PWS
2132 360 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2133
2134C...Compensate for missing momentum withing each jet separately.
2135 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2136 DO 370 I=N+1,N+NJET
2137 K(I,1)=0
2138 DO 370 J=1,5
2139 370 P(I,J)=0.
2140 DO 390 I=NSAV+NJET+1,N
2141 IR1=K(I,3)
2142 IR2=N+IR1-NSAV
2143 K(IR2,1)=K(IR2,1)+1
2144 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2145 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2146 DO 380 J=1,3
2147 380 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2148 P(IR2,4)=P(IR2,4)+P(I,4)
2149 390 P(IR2,5)=P(IR2,5)+PLS
2150 PSS=0.
2151 DO 400 I=N+1,N+NJET
2152 400 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2153 DO 420 I=NSAV+NJET+1,N
2154 IR1=K(I,3)
2155 IR2=N+IR1-NSAV
2156 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2157 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2158 DO 410 J=1,3
2159 410 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2160 & P(IR1,J)
2161 420 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2162 ENDIF
2163
2164C...Scale momenta for energy conservation.
2165 IF(MOD(MSTJ(3),5).NE.0) THEN
2166 PMS=0.
2167 PES=0.
2168 PQS=0.
2169 DO 430 I=NSAV+NJET+1,N
2170 PMS=PMS+P(I,5)
2171 PES=PES+P(I,4)
2172 430 PQS=PQS+P(I,5)**2/P(I,4)
2173 IF(PMS.GE.PECM) GOTO 150
2174 NECO=0
2175 440 NECO=NECO+1
2176 PFAC=(PECM-PQS)/(PES-PQS)
2177 PES=0.
2178 PQS=0.
2179 DO 460 I=NSAV+NJET+1,N
2180 DO 450 J=1,3
2181 450 P(I,J)=PFAC*P(I,J)
2182 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2183 PES=PES+P(I,4)
2184 460 PQS=PQS+P(I,5)**2/P(I,4)
2185 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440
2186 ENDIF
2187
2188C...Origin of produced particles and parton daughter pointers.
2189 470 DO 480 I=NSAV+NJET+1,N
2190 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2191 480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
2192 DO 490 I=NSAV+1,NSAV+NJET
2193 I1=K(I,3)
2194 K(I1,1)=K(I1,1)+10
2195 IF(MSTU(16).NE.2) THEN
2196 K(I1,4)=NSAV+1
2197 K(I1,5)=NSAV+1
2198 ELSE
2199 K(I1,4)=K(I1,4)-NJET+1
2200 K(I1,5)=K(I1,5)-NJET+1
2201 IF(K(I1,5).LT.K(I1,4)) THEN
2202 K(I1,4)=0
2203 K(I1,5)=0
2204 ENDIF
2205 ENDIF
2206 490 CONTINUE
2207
2208C...Document independent fragmentation system. Remove copy of jets.
2209 NSAV=NSAV+1
2210 K(NSAV,1)=11
2211 K(NSAV,2)=93
2212 K(NSAV,3)=IP
2213 K(NSAV,4)=NSAV+1
2214 K(NSAV,5)=N-NJET+1
2215 DO 500 J=1,4
2216 P(NSAV,J)=sngl(DPS(J))
2217 500 V(NSAV,J)=V(IP,J)
2218 P(NSAV,5)=SQRT(sngl(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2
2219 & -DPS(3)**2)))
2220 V(NSAV,5)=0.
2221 DO 510 I=NSAV+NJET,N
2222 DO 510 J=1,5
2223 K(I-NJET+1,J)=K(I,J)
2224 P(I-NJET+1,J)=P(I,J)
2225 510 V(I-NJET+1,J)=V(I,J)
2226 N=N-NJET+1
2227
2228C...Boost back particle system. Set production vertices.
2229 IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
2230 &DPS(2)/DPS(4),DPS(3)/DPS(4))
2231 DO 520 I=NSAV+1,N
2232 DO 520 J=1,4
2233 520 V(I,J)=V(IP,J)
2234
2235 RETURN
2236 END
2237
2238C*********************************************************************
2239
2240 SUBROUTINE LUDECY(IP)
2241
2242C...Purpose: to handle the decay of unstable particles.
2243 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
2244 SAVE /LUJETSA/
2245 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2246 SAVE /LUDAT1A/
2247 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2248 SAVE /LUDAT2A/
2249 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
2250 SAVE /LUDAT3A/
2251 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
2252 &WTCOR(10)
2253clin-2/18/03 for resonance decay in hadron cascade:
2254 common/resdcy/NSAV,iksdcy
2255 SAVE /resdcy/
2256 DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
2257
2258C...Functions: momentum in two-particle decays, four-product and
2259C...matrix element times phase space in weak decays.
2260 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2261 FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
2262 HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
2263 &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
2264
2265C...Initial values.
2266
2267 idc=0
2268 pqt=0.
2269 hatu=0.
2270 hmp1=0.
2271 im=0
2272 kfam=0
2273 wtmax=0.
2274 pmes=0.
2275 pmst=0.
2276 wt=0.
2277 pmr=0.
2278
2279 NTRY=0
2280 NSAV=N
2281 KFA=IABS(K(IP,2))
2282 KFS=ISIGN(1,K(IP,2))
2283 KC=LUCOMP(KFA)
2284 MSTJ(92)=0
2285
2286C...Choose lifetime and determine decay vertex.
2287 IF(K(IP,1).EQ.5) THEN
2288 V(IP,5)=0.
2289 ELSEIF(K(IP,1).NE.4) THEN
2290 V(IP,5)=-PMAS(KC,4)*LOG(RLU(0))
2291 ENDIF
2292 DO 100 J=1,4
2293 100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
2294
2295C...Determine whether decay allowed or not.
2296 MOUT=0
2297 IF(MSTJ(22).EQ.2) THEN
2298 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
2299 ELSEIF(MSTJ(22).EQ.3) THEN
2300 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
2301 ELSEIF(MSTJ(22).EQ.4) THEN
2302 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
2303 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
2304 ENDIF
2305 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
2306 K(IP,1)=4
2307 RETURN
2308 ENDIF
2309
2310C...Check existence of decay channels. Particle/antiparticle rules.
2311 KCA=KC
2312 IF(MDCY(KC,2).GT.0) THEN
2313 MDMDCY=MDME(MDCY(KC,2),2)
2314 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
2315 ENDIF
2316 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
2317 CALL LUERRM(9,'(LUDECY:) no decay channel defined')
2318 RETURN
2319 ENDIF
2320 IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
2321 IF(KCHG(KC,3).EQ.0) THEN
2322 KFSP=1
2323 KFSN=0
2324 IF(RLU(0).GT.0.5) KFS=-KFS
2325 ELSEIF(KFS.GT.0) THEN
2326 KFSP=1
2327 KFSN=0
2328 ELSE
2329 KFSP=0
2330 KFSN=1
2331 ENDIF
2332
2333C...Sum branching ratios of allowed decay channels.
2334clin 110 NOPE=0
2335 NOPE=0
2336 BRSU=0.
2337 DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
2338 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2339 &KFSN*MDME(IDL,1).NE.3) GOTO 120
2340 IF(MDME(IDL,2).GT.100) GOTO 120
2341 NOPE=NOPE+1
2342 BRSU=BRSU+BRAT(IDL)
2343 120 CONTINUE
2344 IF(NOPE.EQ.0) THEN
2345 CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')
2346 RETURN
2347 ENDIF
2348
2349C...Select decay channel among allowed ones.
2350 130 RBR=BRSU*RLU(0)
2351 IDL=MDCY(KCA,2)-1
2352 140 IDL=IDL+1
2353 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2354 &KFSN*MDME(IDL,1).NE.3) THEN
2355 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2356 ELSEIF(MDME(IDL,2).GT.100) THEN
2357 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2358 ELSE
2359 IDC=IDL
2360 RBR=RBR-BRAT(IDL)
2361 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140
2362 ENDIF
2363
2364C...Start readout of decay channel: matrix element, reset counters.
2365 MMAT=MDME(IDC,2)
2366 150 NTRY=NTRY+1
2367 IF(NTRY.GT.1000) THEN
2368 CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2369 IF(MSTU(21).GE.1) RETURN
2370 ENDIF
2371 I=N
2372 NP=0
2373 NQ=0
2374 MBST=0
2375 IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
2376 DO 160 J=1,4
2377 PV(1,J)=0.
2378 160 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
2379 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
2380 PV(1,5)=P(IP,5)
2381 PS=0.
2382 PSQ=0.
2383 MREM=0
2384
2385C...Read out decay products. Convert to standard flavour code.
2386 JTMAX=5
2387 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
2388 DO 170 JT=1,JTMAX
2389 IF(JT.LE.5) KP=KFDP(IDC,JT)
2390 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
2391 IF(KP.EQ.0) GOTO 170
2392 KPA=IABS(KP)
2393 KCP=LUCOMP(KPA)
2394 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
2395 KFP=KP
2396 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
2397 KFP=KFS*KP
2398 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
2399 KFP=-KFS*MOD(KFA/10,10)
2400 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
2401 KFP=KFS*(100*MOD(KFA/10,100)+3)
2402 ELSEIF(KPA.EQ.81) THEN
2403 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
2404 ELSEIF(KP.EQ.82) THEN
2405 CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)
2406 IF(KFP.EQ.0) GOTO 150
2407 MSTJ(93)=1
2408 IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150
2409 ELSEIF(KP.EQ.-82) THEN
2410 KFP=-KFP
2411 IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
2412 ENDIF
2413 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)
2414
2415C...Add decay product to event record or to quark flavour list.
2416 KFPA=IABS(KFP)
2417 KQP=KCHG(KCP,2)
2418 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
2419 NQ=NQ+1
2420 KFLO(NQ)=KFP
2421 MSTJ(93)=2
2422 PSQ=PSQ+ULMASS(KFLO(NQ))
2423 ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)
2424 &THEN
2425 NQ=NQ-1
2426 PS=PS-P(I,5)
2427 K(I,1)=1
2428 KFI=K(I,2)
2429 CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))
2430 IF(K(I,2).EQ.0) GOTO 150
2431 MSTJ(93)=1
2432 P(I,5)=ULMASS(K(I,2))
2433 PS=PS+P(I,5)
2434 ELSE
2435 I=I+1
2436 NP=NP+1
2437 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
2438 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
2439 K(I,1)=1+MOD(NQ,2)
2440 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
2441 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
2442 K(I,2)=KFP
2443 K(I,3)=IP
2444 K(I,4)=0
2445 K(I,5)=0
2446 P(I,5)=ULMASS(KFP)
2447 IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
2448 PS=PS+P(I,5)
2449 ENDIF
2450 170 CONTINUE
2451
2452C...Choose decay multiplicity in phase space model.
2453 180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
2454 PSP=PS
2455 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
2456 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
2457 190 NTRY=NTRY+1
2458 IF(NTRY.GT.1000) THEN
2459 CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2460 IF(MSTU(21).GE.1) RETURN
2461 ENDIF
2462 IF(MMAT.LE.20) THEN
2463 GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*
2464 & SIN(PARU(2)*RLU(0))
2465 ND=int(0.5+0.5*NP+0.25*NQ+CNDE+GAUSS)
2466 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190
2467 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190
2468 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190
2469 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190
2470 ELSE
2471 ND=MMAT-20
2472 ENDIF
2473
2474C...Form hadrons from flavour content.
2475 DO 200 JT=1,4
2476 200 KFL1(JT)=KFLO(JT)
2477 IF(ND.EQ.NP+NQ/2) GOTO 220
2478 DO 210 I=N+NP+1,N+ND-NQ/2
2479 JT=1+INT((NQ-1)*RLU(0))
2480 CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2))
2481 IF(K(I,2).EQ.0) GOTO 190
2482 210 KFL1(JT)=-KFL2
2483 220 JT=2
2484 JT2=3
2485 JT3=4
2486 IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4
2487 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
2488 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
2489 IF(JT.EQ.3) JT2=2
2490 IF(JT.EQ.4) JT3=2
2491 CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
2492 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190
2493 IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
2494 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190
2495
2496C...Check that sum of decay product masses not too large.
2497 PS=PSP
2498 DO 230 I=N+NP+1,N+ND
2499 K(I,1)=1
2500 K(I,3)=IP
2501 K(I,4)=0
2502 K(I,5)=0
2503 P(I,5)=ULMASS(K(I,2))
2504 230 PS=PS+P(I,5)
2505 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190
2506
2507C...Rescale energy to subtract off spectator quark mass.
2508 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).
2509 &AND.NP.GE.3) THEN
2510 PS=PS-P(N+NP,5)
2511 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
2512 DO 240 J=1,5
2513 P(N+NP,J)=PQT*PV(1,J)
2514 240 PV(1,J)=(1.-PQT)*PV(1,J)
2515 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150
2516 ND=NP-1
2517 MREM=1
2518
2519C...Phase space factors imposed in W decay.
2520 ELSEIF(MMAT.EQ.46) THEN
2521 MSTJ(93)=1
2522 PSMC=ULMASS(K(N+1,2))
2523 MSTJ(93)=1
2524 PSMC=PSMC+ULMASS(K(N+2,2))
2525 IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130
2526 HR1=(P(N+1,5)/PV(1,5))**2
2527 HR2=(P(N+2,5)/PV(1,5))**2
2528 IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).
2529 & LT.2.*RLU(0)) GOTO 130
2530 ND=NP
2531
2532C...Fully specified final state: check mass broadening effects.
2533 ELSE
2534 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150
2535 ND=NP
2536 ENDIF
2537
2538C...Select W mass in decay Q -> W + q, without W propagator.
2539 IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
2540 HLQ=(PARJ(32)/PV(1,5))**2
2541 HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
2542 HRQ=(P(N+2,5)/PV(1,5))**2
2543 250 HW=HLQ+RLU(0)*(HUQ-HLQ)
2544 IF(HMEPS(HW).LT.RLU(0)) GOTO 250
2545 P(N+1,5)=PV(1,5)*SQRT(HW)
2546
2547C...Ditto, including W propagator. Divide mass range into three regions.
2548 ELSEIF(MMAT.EQ.45) THEN
2549 HQW=(PV(1,5)/PMAS(24,1))**2
2550 HLW=(PARJ(32)/PMAS(24,1))**2
2551 HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
2552 HRQ=(P(N+2,5)/PV(1,5))**2
2553 HG=PMAS(24,2)/PMAS(24,1)
2554 HATL=ATAN((HLW-1.)/HG)
2555 HM=MIN(1.,HUW-0.001)
2556 HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2557 260 HM=HM-HG
2558 HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
2559 HSAV1=HMEPS(HM/HQW)
2560 HSAV2=1./((HM-1.)**2+HG**2)
2561 IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
2562 HMV1=HMV2
2563 GOTO 260
2564 ENDIF
2565 HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
2566 HM1=1.-SQRT(1./HMV-HG**2)
2567 IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
2568 HM=HM1
2569 ELSEIF(HMV2.LE.HMV1) THEN
2570 HM=MAX(HLW,HM-MIN(0.1,1.-HM))
2571 ENDIF
2572 HATM=ATAN((HM-1.)/HG)
2573 HWT1=(HATM-HATL)/HG
2574 HWT2=HMV*(MIN(1.,HUW)-HM)
2575 HWT3=0.
2576 IF(HUW.GT.1.) THEN
2577 HATU=ATAN((HUW-1.)/HG)
2578 HMP1=HMEPS(1./HQW)
2579 HWT3=HMP1*HATU/HG
2580 ENDIF
2581
2582C...Select mass region and W mass there. Accept according to weight.
2583 270 HREG=RLU(0)*(HWT1+HWT2+HWT3)
2584 IF(HREG.LE.HWT1) THEN
2585 HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL))
2586 HACC=HMEPS(HW/HQW)
2587 ELSEIF(HREG.LE.HWT1+HWT2) THEN
2588 HW=HM+RLU(0)*(MIN(1.,HUW)-HM)
2589 HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
2590 ELSE
2591 HW=1.+HG*TAN(RLU(0)*HATU)
2592 HACC=HMEPS(HW/HQW)/HMP1
2593 ENDIF
2594 IF(HACC.LT.RLU(0)) GOTO 270
2595 P(N+1,5)=PMAS(24,1)*SQRT(HW)
2596 ENDIF
2597
2598C...Determine position of grandmother, number of sisters, Q -> W sign.
2599 NM=0
2600 MSGN=0
2601 IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
2602 IM=K(IP,3)
2603 IF(IM.LT.0.OR.IM.GE.IP) IM=0
2604 IF(IM.NE.0) KFAM=IABS(K(IM,2))
2605 IF(IM.NE.0.AND.MMAT.EQ.3) THEN
2606 DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
2607 280 IF(K(IL,3).EQ.IM) NM=NM+1
2608 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
2609 & MOD(KFAM/1000,10).NE.0) NM=0
2610 ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
2611 MSGN=ISIGN(1,K(IM,2)*K(IP,2))
2612 IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
2613 & MSGN*(-1)**MOD(KFAM/100,10)
2614 ENDIF
2615 ENDIF
2616
2617C...Kinematics of one-particle decays.
2618 IF(ND.EQ.1) THEN
2619 DO 290 J=1,4
2620 290 P(N+1,J)=P(IP,J)
2621 GOTO 510
2622 ENDIF
2623
2624C...Calculate maximum weight ND-particle decay.
2625 PV(ND,5)=P(N+ND,5)
2626 IF(ND.GE.3) THEN
2627 WTMAX=1./WTCOR(ND-2)
2628 PMAX=PV(1,5)-PS+P(N+ND,5)
2629 PMIN=0.
2630 DO 300 IL=ND-1,1,-1
2631 PMAX=PMAX+P(N+IL,5)
2632 PMIN=PMIN+P(N+IL+1,5)
2633 300 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
2634 ENDIF
2635
2636C...Find virtual gamma mass in Dalitz decay.
2637 310 IF(ND.EQ.2) THEN
2638 ELSEIF(MMAT.EQ.2) THEN
2639 PMES=4.*PMAS(11,1)**2
2640 PMRHO2=PMAS(131,1)**2
2641 PGRHO2=PMAS(131,2)**2
2642 320 PMST=PMES*(P(IP,5)**2/PMES)**RLU(0)
2643 WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
2644 & (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
2645 & ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
2646 IF(WT.LT.RLU(0)) GOTO 320
2647 PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
2648
2649C...M-generator gives weight. If rejected, try again.
2650 ELSE
2651 330 RORD(1)=1.
2652 DO 350 IL1=2,ND-1
2653 RSAV=RLU(0)
2654 DO 340 IL2=IL1-1,1,-1
2655 IF(RSAV.LE.RORD(IL2)) GOTO 350
2656 340 RORD(IL2+1)=RORD(IL2)
2657 350 RORD(IL2+1)=RSAV
2658 RORD(ND)=0.
2659 WT=1.
2660 DO 360 IL=ND-1,1,-1
2661 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
2662 360 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2663 IF(WT.LT.RLU(0)*WTMAX) GOTO 330
2664 ENDIF
2665
2666C...Perform two-particle decays in respective CM frame.
2667 370 DO 390 IL=1,ND-1
2668 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
2669 UE(3)=2.*RLU(0)-1.
2670 PHI=PARU(2)*RLU(0)
2671 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
2672 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
2673 DO 380 J=1,3
2674 P(N+IL,J)=PA*UE(J)
2675 380 PV(IL+1,J)=-PA*UE(J)
2676 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
2677 390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
2678
2679C...Lorentz transform decay products to lab frame.
2680 DO 400 J=1,4
2681 400 P(N+ND,J)=PV(ND,J)
2682 DO 430 IL=ND-1,1,-1
2683 DO 410 J=1,3
2684 410 BE(J)=PV(IL,J)/PV(IL,4)
2685 GA=PV(IL,4)/PV(IL,5)
2686 DO 430 I=N+IL,N+ND
2687 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
2688 DO 420 J=1,3
2689 420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
2690 430 P(I,4)=GA*(P(I,4)+BEP)
2691
2692C...Matrix elements for omega and phi decays.
2693 IF(MMAT.EQ.1) THEN
2694 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
2695 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
2696 & +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
2697 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310
2698
2699C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
2700 ELSEIF(MMAT.EQ.2) THEN
2701 FOUR12=FOUR(N+1,N+2)
2702 FOUR13=FOUR(N+1,N+3)
2703 FOUR23=0.5*PMST-0.25*PMES
2704 WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
2705 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
2706 IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370
2707
2708C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
2709C...V vector), of form cos**2(theta02) in V1 rest frame.
2710 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
2711 IF((P(IP,5)**2*FOUR(IM,N+1)-FOUR(IP,IM)*FOUR(IP,N+1))**2.LE.
2712 & RLU(0)*(FOUR(IP,IM)**2-(P(IP,5)*P(IM,5))**2)*(FOUR(IP,N+1)**2-
2713 & (P(IP,5)*P(N+1,5))**2)) GOTO 370
2714
2715C...Matrix element for "onium" -> g + g + g or gamma + g + g.
2716 ELSEIF(MMAT.EQ.4) THEN
2717 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
2718 HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
2719 HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
2720 WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
2721 & ((1.-HX3)/(HX1*HX2))**2
2722 IF(WT.LT.2.*RLU(0)) GOTO 310
2723 IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
2724 & GOTO 310
2725
2726C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
2727 ELSEIF(MMAT.EQ.41) THEN
2728 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
2729 IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310
2730
2731C...Matrix elements for weak decays (only semileptonic for c and b)
2732 ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN
2733 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
2734 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
2735 IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
2736 ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN
2737 DO 440 J=1,4
2738 P(N+NP+1,J)=0.
2739 DO 440 IS=N+3,N+NP
2740 440 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
2741 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
2742 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
2743 IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
2744
2745C...Angular distribution in W decay.
2746 ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
2747 IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
2748 IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
2749 IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370
2750 ENDIF
2751
2752C...Scale back energy and reattach spectator.
2753 IF(MREM.EQ.1) THEN
2754 DO 450 J=1,5
2755 450 PV(1,J)=PV(1,J)/(1.-PQT)
2756 ND=ND+1
2757 MREM=0
2758 ENDIF
2759
2760C...Low invariant mass for system with spectator quark gives particle,
2761C...not two jets. Readjust momenta accordingly.
2762 IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
2763 MSTJ(93)=1
2764 PM2=ULMASS(K(N+2,2))
2765 MSTJ(93)=1
2766 PM3=ULMASS(K(N+3,2))
2767 IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
2768 & (PARJ(32)+PM2+PM3)**2) GOTO 510
2769 K(N+2,1)=1
2770 KFTEMP=K(N+2,2)
2771 CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
2772 IF(K(N+2,2).EQ.0) GOTO 150
2773 P(N+2,5)=ULMASS(K(N+2,2))
2774 PS=P(N+1,5)+P(N+2,5)
2775 PV(2,5)=P(N+2,5)
2776 MMAT=0
2777 ND=2
2778 GOTO 370
2779 ELSEIF(MMAT.EQ.44) THEN
2780 MSTJ(93)=1
2781 PM3=ULMASS(K(N+3,2))
2782 MSTJ(93)=1
2783 PM4=ULMASS(K(N+4,2))
2784 IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
2785 & (PARJ(32)+PM3+PM4)**2) GOTO 480
2786 K(N+3,1)=1
2787 KFTEMP=K(N+3,2)
2788 CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
2789 IF(K(N+3,2).EQ.0) GOTO 150
2790 P(N+3,5)=ULMASS(K(N+3,2))
2791 DO 460 J=1,3
2792 460 P(N+3,J)=P(N+3,J)+P(N+4,J)
2793 P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2)
2794 HA=P(N+1,4)**2-P(N+2,4)**2
2795 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
2796 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
2797 & (P(N+1,3)-P(N+2,3))**2
2798 HD=(PV(1,4)-P(N+3,4))**2
2799 HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
2800 HF=HD*HC-HB**2
2801 HG=HD*HC-HA*HB
2802 HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
2803 DO 470 J=1,3
2804 PCOR=HH*(P(N+1,J)-P(N+2,J))
2805 P(N+1,J)=P(N+1,J)+PCOR
2806 470 P(N+2,J)=P(N+2,J)-PCOR
2807 P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2)
2808 P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2)
2809 ND=ND-1
2810 ENDIF
2811
2812C...Check invariant mass of W jets. May give one particle or start over.
2813 480 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN
2814 PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
2815 MSTJ(93)=1
2816 PM1=ULMASS(K(N+1,2))
2817 MSTJ(93)=1
2818 PM2=ULMASS(K(N+2,2))
2819 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 490
2820 KFLDUM=INT(1.5+RLU(0))
2821 CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
2822 CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
2823 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150
2824 PSM=ULMASS(KF1)+ULMASS(KF2)
2825 IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 490
2826 IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 490
2827 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150
2828 K(N+1,1)=1
2829 KFTEMP=K(N+1,2)
2830 CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
2831 IF(K(N+1,2).EQ.0) GOTO 150
2832 P(N+1,5)=ULMASS(K(N+1,2))
2833 K(N+2,2)=K(N+3,2)
2834 P(N+2,5)=P(N+3,5)
2835 PS=P(N+1,5)+P(N+2,5)
2836 PV(2,5)=P(N+3,5)
2837 MMAT=0
2838 ND=2
2839 GOTO 370
2840 ENDIF
2841
2842C...Phase space decay of partons from W decay.
2843 490 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN
2844 KFLO(1)=K(N+1,2)
2845 KFLO(2)=K(N+2,2)
2846 K(N+1,1)=K(N+3,1)
2847 K(N+1,2)=K(N+3,2)
2848 DO 500 J=1,5
2849 PV(1,J)=P(N+1,J)+P(N+2,J)
2850 500 P(N+1,J)=P(N+3,J)
2851 PV(1,5)=PMR
2852 N=N+1
2853 NP=0
2854 NQ=2
2855 PS=0.
2856 MSTJ(93)=2
2857 PSQ=ULMASS(KFLO(1))
2858 MSTJ(93)=2
2859 PSQ=PSQ+ULMASS(KFLO(2))
2860 MMAT=11
2861 GOTO 180
2862 ENDIF
2863
2864C...Boost back for rapidly moving particle.
2865 510 N=N+ND
2866 IF(MBST.EQ.1) THEN
2867 DO 520 J=1,3
2868 520 BE(J)=P(IP,J)/P(IP,4)
2869 GA=P(IP,4)/P(IP,5)
2870 DO 540 I=NSAV+1,N
2871 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
2872 DO 530 J=1,3
2873 530 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
2874 540 P(I,4)=GA*(P(I,4)+BEP)
2875 ENDIF
2876
2877C...Fill in position of decay vertex.
2878 DO 560 I=NSAV+1,N
2879 DO 550 J=1,4
2880 550 V(I,J)=VDCY(J)
2881 560 V(I,5)=0.
2882
2883C...Set up for parton shower evolution from jets.
2884 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
2885 K(NSAV+1,1)=3
2886 K(NSAV+2,1)=3
2887 K(NSAV+3,1)=3
2888 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
2889 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
2890 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
2891 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
2892 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
2893 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
2894 MSTJ(92)=-(NSAV+1)
2895 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
2896 K(NSAV+2,1)=3
2897 K(NSAV+3,1)=3
2898 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
2899 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
2900 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
2901 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
2902 MSTJ(92)=NSAV+2
2903 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
2904 &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
2905 K(NSAV+1,1)=3
2906 K(NSAV+2,1)=3
2907 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
2908 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
2909 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
2910 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
2911 MSTJ(92)=NSAV+1
2912 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
2913 &THEN
2914 K(NSAV+1,1)=3
2915 K(NSAV+2,1)=3
2916 K(NSAV+3,1)=3
2917 KCP=LUCOMP(K(NSAV+1,2))
2918 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
2919 JCON=4
2920 IF(KQP.LT.0) JCON=5
2921 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
2922 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
2923 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
2924 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
2925 MSTJ(92)=NSAV+1
2926 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
2927 K(NSAV+1,1)=3
2928 K(NSAV+3,1)=3
2929 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
2930 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
2931 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
2932 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
2933 MSTJ(92)=NSAV+1
2934 ENDIF
2935
2936C...Mark decayed particle.
2937 IF(K(IP,1).EQ.5) K(IP,1)=15
2938 IF(K(IP,1).LE.10) K(IP,1)=11
2939 K(IP,4)=NSAV+1
2940 K(IP,5)=N
2941
2942 RETURN
2943 END
2944
2945C*********************************************************************
2946
2947 SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)
2948
2949C...Purpose: to generate a new flavour pair and combine off a hadron.
2950 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2951 SAVE /LUDAT1A/
2952 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2953 SAVE /LUDAT2A/
2954
2955 par3m=0.
2956 par4m=0.
2957 pardm=0.
2958 pars0=0.
2959 pars1=0.
2960 pars2=0.
2961 parsm=0.
2962 kmul=0
2963 ktab3=0
2964
2965C...Default flavour values. Input consistency checks.
2966 KF1A=IABS(KFL1)
2967 KF2A=IABS(KFL2)
2968 KFL3=0
2969 KF=0
2970 IF(KF1A.EQ.0) RETURN
2971 IF(KF2A.NE.0) THEN
2972 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
2973 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
2974 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
2975 ENDIF
2976
2977C...Check if tabulated flavour probabilities are to be used.
2978 IF(MSTJ(15).EQ.1) THEN
2979 KTAB1=-1
2980 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
2981 KFL1A=MOD(KF1A/1000,10)
2982 KFL1B=MOD(KF1A/100,10)
2983 KFL1S=MOD(KF1A,10)
2984 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
2985 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
2986 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
2987 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
2988 KTAB2=0
2989 IF(KF2A.NE.0) THEN
2990 KTAB2=-1
2991 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
2992 KFL2A=MOD(KF2A/1000,10)
2993 KFL2B=MOD(KF2A/100,10)
2994 KFL2S=MOD(KF2A,10)
2995 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
2996 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
2997 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
2998 ENDIF
2999 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
3000 ENDIF
3001
3002C...Parameters and breaking diquark parameter combinations.
3003 100 PAR2=PARJ(2)
3004 PAR3=PARJ(3)
3005 PAR4=3.*PARJ(4)
3006 IF(MSTJ(12).GE.2) THEN
3007 PAR3M=SQRT(PARJ(3))
3008 PAR4M=1./(3.*SQRT(PARJ(4)))
3009 PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3010 PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3011 PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3012 & PAR2*PAR3M*PARJ(6)*PARJ(7))
3013 PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3014 PARSM=MAX(PARS0,PARS1,PARS2)
3015 PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3016 ENDIF
3017
3018C...Choice of whether to generate meson or baryon.
3019 MBARY=0
3020 KFDA=0
3021 IF(KF1A.LE.10) THEN
3022 IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)
3023 & MBARY=1
3024 IF(KF2A.GT.10) MBARY=2
3025 IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
3026 ELSE
3027 MBARY=2
3028 IF(KF1A.LE.10000) KFDA=KF1A
3029 ENDIF
3030
3031C...Possibility of process diquark -> meson + new diquark.
3032 IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
3033 KFLDA=MOD(KFDA/1000,10)
3034 KFLDB=MOD(KFDA/100,10)
3035 KFLDS=MOD(KFDA,10)
3036 WTDQ=PARS0
3037 IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
3038 IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
3039 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3040 IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1
3041 IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
3042 ENDIF
3043
3044C...Flavour for meson, possibly with new flavour.
3045 IF(MBARY.LE.0) THEN
3046 KFS=ISIGN(1,KFL1)
3047 IF(MBARY.EQ.0) THEN
3048 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)
3049 KFLA=MAX(KF1A,KF2A+IABS(KFL3))
3050 KFLB=MIN(KF1A,KF2A+IABS(KFL3))
3051 IF(KFLA.NE.KF1A) KFS=-KFS
3052
3053C...Splitting of diquark into meson plus new diquark.
3054 ELSE
3055 KFL1A=MOD(KF1A/1000,10)
3056 KFL1B=MOD(KF1A/100,10)
3057 110 KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A)
3058 KFL1E=KFL1A+KFL1B-KFL1D
3059 IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
3060 & RLU(0).LT.PARDM)) THEN
3061 KFL1D=KFL1A+KFL1B-KFL1D
3062 KFL1E=KFL1A+KFL1B-KFL1E
3063 ENDIF
3064 KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))
3065 IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).
3066 & OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))
3067 & GOTO 110
3068 KFLDS=3
3069 IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1
3070 KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
3071 & KFLDS,-KFL1)
3072 KFLA=MAX(KFL1D,KFL3A)
3073 KFLB=MIN(KFL1D,KFL3A)
3074 IF(KFLA.NE.KFL1D) KFS=-KFS
3075 ENDIF
3076
3077C...Form meson, with spin and flavour mixing for diagonal states.
3078 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0))
3079 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0))
3080 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0))
3081 IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
3082 IF(RLU(0).LT.PARJ(14)) KMUL=2
3083 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
3084 RMUL=RLU(0)
3085 IF(RMUL.LT.PARJ(15)) KMUL=3
3086 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
3087 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
3088 ENDIF
3089 KFLS=3
3090 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
3091 IF(KMUL.EQ.5) KFLS=5
3092 IF(KFLA.NE.KFLB) THEN
3093 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
3094 ELSE
3095 RMIX=RLU(0)
3096 IMIX=2*KFLA+10*KMUL
3097 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
3098 & INT(RMIX+PARF(IMIX)))+KFLS
3099 IF(KFLA.GE.4) KF=110*KFLA+KFLS
3100 ENDIF
3101 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
3102 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
3103
3104C...Generate diquark flavour.
3105 ELSE
3106 120 IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
3107 KFLA=KF1A
3108 130 KFLB=1+INT((2.+PAR2*PAR3)*RLU(0))
3109 KFLC=1+INT((2.+PAR2*PAR3)*RLU(0))
3110 KFLDS=1
3111 IF(KFLB.GE.KFLC) KFLDS=3
3112 IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130
3113 IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130
3114 KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
3115
3116C...Take diquark flavour from input.
3117 ELSEIF(KF1A.LE.10) THEN
3118 KFLA=KF1A
3119 KFLB=MOD(KF2A/1000,10)
3120 KFLC=MOD(KF2A/100,10)
3121 KFLDS=MOD(KF2A,10)
3122
3123C...Generate (or take from input) quark to go with diquark.
3124 ELSE
3125 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)
3126 KFLA=KF2A+IABS(KFL3)
3127 KFLB=MOD(KF1A/1000,10)
3128 KFLC=MOD(KF1A/100,10)
3129 KFLDS=MOD(KF1A,10)
3130 ENDIF
3131
3132C...SU(6) factors for formation of baryon. Try again if fails.
3133 KBARY=KFLDS
3134 IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
3135 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
3136 WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
3137 IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
3138 WTDQ=PARS0
3139 IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
3140 IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
3141 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3142 IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
3143 IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
3144 ENDIF
3145 IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120
3146
3147C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3148 KFLD=MAX(KFLA,KFLB,KFLC)
3149 KFLF=MIN(KFLA,KFLB,KFLC)
3150 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3151 KFLS=2
3152 IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.
3153 & PARF(60+KBARY)) KFLS=4
3154 KFLL=0
3155 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
3156 IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
3157 IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0))
3158 IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0))
3159 ENDIF
3160 IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
3161 IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
3162 ENDIF
3163 RETURN
3164
3165C...Use tabulated probabilities to select new flavour and hadron.
3166 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
3167 KT3L=1
3168 KT3U=6
3169 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
3170 KT3L=1
3171 KT3U=6
3172 ELSEIF(KTAB2.EQ.0) THEN
3173 KT3L=1
3174 KT3U=22
3175 ELSE
3176 KT3L=KTAB2
3177 KT3U=KTAB2
3178 ENDIF
3179 RFL=0.
3180 DO 150 KTS=0,2
3181 DO 150 KT3=KT3L,KT3U
3182 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
3183 150 CONTINUE
3184 RFL=RLU(0)*RFL
3185 DO 160 KTS=0,2
3186 KTABS=KTS
3187 DO 160 KT3=KT3L,KT3U
3188 KTAB3=KT3
3189 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
3190 160 IF(RFL.LE.0.) GOTO 170
3191 170 CONTINUE
3192
3193C...Reconstruct flavour of produced quark/diquark.
3194 IF(KTAB3.LE.6) THEN
3195 KFL3A=KTAB3
3196 KFL3B=0
3197 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
3198 ELSE
3199 KFL3A=1
3200 IF(KTAB3.GE.8) KFL3A=2
3201 IF(KTAB3.GE.11) KFL3A=3
3202 IF(KTAB3.GE.16) KFL3A=4
3203 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
3204 KFL3=1000*KFL3A+100*KFL3B+1
3205 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
3206 & KFL3+2
3207 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
3208 ENDIF
3209
3210C...Reconstruct meson code.
3211 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
3212 &KFL3B.NE.0)) THEN
3213 RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3214 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
3215 KF=110+2*KTABS+1
3216 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
3217 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3218 & 25*KTABS)) KF=330+2*KTABS+1
3219 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
3220 KFLA=MAX(KTAB1,KTAB3)
3221 KFLB=MIN(KTAB1,KTAB3)
3222 KFS=ISIGN(1,KFL1)
3223 IF(KFLA.NE.KF1A) KFS=-KFS
3224 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3225 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
3226 KFS=ISIGN(1,KFL1)
3227 IF(KFL1A.EQ.KFL3A) THEN
3228 KFLA=MAX(KFL1B,KFL3B)
3229 KFLB=MIN(KFL1B,KFL3B)
3230 IF(KFLA.NE.KFL1B) KFS=-KFS
3231 ELSEIF(KFL1A.EQ.KFL3B) THEN
3232 KFLA=KFL3A
3233 KFLB=KFL1B
3234 KFS=-KFS
3235 ELSEIF(KFL1B.EQ.KFL3A) THEN
3236 KFLA=KFL1A
3237 KFLB=KFL3B
3238 ELSEIF(KFL1B.EQ.KFL3B) THEN
3239 KFLA=MAX(KFL1A,KFL3A)
3240 KFLB=MIN(KFL1A,KFL3A)
3241 IF(KFLA.NE.KFL1A) KFS=-KFS
3242 ELSE
3243 CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')
3244 GOTO 100
3245 ENDIF
3246 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3247
3248C...Reconstruct baryon code.
3249 ELSE
3250 IF(KTAB1.GE.7) THEN
3251 KFLA=KFL3A
3252 KFLB=KFL1A
3253 KFLC=KFL1B
3254 ELSE
3255 KFLA=KFL1A
3256 KFLB=KFL3A
3257 KFLC=KFL3B
3258 ENDIF
3259 KFLD=MAX(KFLA,KFLB,KFLC)
3260 KFLF=MIN(KFLA,KFLB,KFLC)
3261 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3262 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
3263 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
3264 ENDIF
3265
3266C...Check that constructed flavour code is an allowed one.
3267 IF(KFL2.NE.0) KFL3=0
3268 KC=LUCOMP(KF)
3269 IF(KC.EQ.0) THEN
3270 CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '//
3271 & 'failed')
3272 GOTO 100
3273 ENDIF
3274
3275 RETURN
3276 END
3277
3278C*********************************************************************
3279
3280 SUBROUTINE LUPTDI(KFL,PX,PY)
3281
3282C...Purpose: to generate transverse momentum according to a Gaussian.
3283 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3284 SAVE /LUDAT1A/
3285
3286C...Generate p_T and azimuthal angle, gives p_x and p_y.
3287 KFLA=IABS(KFL)
3288 PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0))))
3289 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
3290 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
3291 PHI=PARU(2)*RLU(0)
3292 PX=PT*COS(PHI)
3293 PY=PT*SIN(PHI)
3294
3295 RETURN
3296 END
3297
3298C*********************************************************************
3299
3300 SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z)
3301
3302C...Purpose: to generate the longitudinal splitting variable z.
3303 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3304 SAVE /LUDAT1A/
3305
3306 zdiv=0.
3307 fint=0.
3308 zdivc=0.
3309
3310C...Check if heavy flavour fragmentation.
3311 KFLA=IABS(KFL1)
3312 KFLB=IABS(KFL2)
3313 KFLH=KFLA
3314 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
3315
3316C...Lund symmetric scaling function: determine parameters of shape.
3317 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3)) THEN
3318 FA=PARJ(41)
3319 IF(MSTJ(91).EQ.1) FA=PARJ(43)
3320 IF(KFLB.GE.10) FA=FA+PARJ(45)
3321 FB=PARJ(42)*PR
3322 IF(MSTJ(91).EQ.1) FB=PARJ(44)*PR
3323 FC=1.
3324 IF(KFLA.GE.10) FC=FC-PARJ(45)
3325 IF(KFLB.GE.10) FC=FC+PARJ(45)
3326 MC=1
3327 IF(ABS(FC-1.).GT.0.01) MC=2
3328
3329C...Determine position of maximum. Special cases for a = 0 or a = c.
3330 IF(FA.LT.0.02) THEN
3331 MA=1
3332 ZMAX=1.
3333 IF(FC.GT.FB) ZMAX=FB/FC
3334 ELSEIF(ABS(FC-FA).LT.0.01) THEN
3335 MA=2
3336 ZMAX=FB/(FB+FC)
3337 ELSE
3338 MA=3
3339 ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
3340 IF(ZMAX.GT.0.99.AND.FB.GT.100.) ZMAX=1.-FA/FB
3341 ENDIF
3342
3343C...Subdivide z range if distribution very peaked near endpoint.
3344 MMAX=2
3345 IF(ZMAX.LT.0.1) THEN
3346 MMAX=1
3347 ZDIV=2.75*ZMAX
3348 IF(MC.EQ.1) THEN
3349 FINT=1.-LOG(ZDIV)
3350 ELSE
3351 ZDIVC=ZDIV**(1.-FC)
3352 FINT=1.+(1.-1./ZDIVC)/(FC-1.)
3353 ENDIF
3354 ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
3355 MMAX=3
3356 FSCB=SQRT(4.+(FC/FB)**2)
3357 ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
3358 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
3359 ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
3360 FINT=1.+FB*(1.-ZDIV)
3361 ENDIF
3362
3363C...Choice of z, preweighted for peaks at low or high z.
3364 100 Z=RLU(0)
3365 FPRE=1.
3366 IF(MMAX.EQ.1) THEN
3367 IF(FINT*RLU(0).LE.1.) THEN
3368 Z=ZDIV*Z
3369 ELSEIF(MC.EQ.1) THEN
3370 Z=ZDIV**Z
3371 FPRE=ZDIV/Z
3372 ELSE
3373 Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
3374 FPRE=(ZDIV/Z)**FC
3375 ENDIF
3376 ELSEIF(MMAX.EQ.3) THEN
3377 IF(FINT*RLU(0).LE.1.) THEN
3378 Z=ZDIV+LOG(Z)/FB
3379 FPRE=EXP(FB*(Z-ZDIV))
3380 ELSE
3381 Z=ZDIV+Z*(1.-ZDIV)
3382 ENDIF
3383 ENDIF
3384
3385C...Weighting according to correct formula.
3386 IF(Z.LE.FB/(50.+FB).OR.Z.GE.1.) GOTO 100
3387 FVAL=(ZMAX/Z)**FC*EXP(FB*(1./ZMAX-1./Z))
3388 IF(MA.GE.2) FVAL=((1.-Z)/(1.-ZMAX))**FA*FVAL
3389 IF(FVAL.LT.RLU(0)*FPRE) GOTO 100
3390
3391C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
3392 ELSE
3393 FC=PARJ(50+MAX(1,KFLH))
3394 IF(MSTJ(91).EQ.1) FC=PARJ(59)
3395 110 Z=RLU(0)
3396 IF(FC.GE.0..AND.FC.LE.1.) THEN
3397 IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)
3398 ELSEIF(FC.GT.-1.) THEN
3399 IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
3400 ELSE
3401 IF(FC.GT.0.) Z=1.-Z**(1./FC)
3402 IF(FC.LT.0.) Z=Z**(-1./FC)
3403 ENDIF
3404 ENDIF
3405
3406 RETURN
3407 END
3408
3409C*********************************************************************
3410
3411 SUBROUTINE LUSHOW(IP1,IP2,QMAX)
3412
3413C...Purpose: to generate timelike parton showers from given partons.
3414 IMPLICIT DOUBLE PRECISION(D)
3415 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
3416 SAVE /LUJETSA/
3417 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3418 SAVE /LUDAT1A/
3419 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3420 SAVE /LUDAT2A/
3421 DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
3422 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4)
3423
3424 npa=0
3425 kflm=0
3426 pem=0.
3427 pmed=0.
3428 fbre=0.
3429 pm2=0.
3430 ped=0.
3431 zm=0.
3432 pa1s=0.
3433 pa2s=0.
3434 pa3s=0.
3435 pts=0.
3436 pzm=0.
3437 pmls=0.
3438 pt=0.
3439 hazip=0.
3440 hazic=0.
3441
3442C...Initialization of cutoff masses etc.
3443 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
3444 &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN
3445 PMTH(1,21)=ULMASS(21)
3446 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
3447 PMTH(3,21)=2.*PMTH(2,21)
3448 PMTH(4,21)=PMTH(3,21)
3449 PMTH(5,21)=PMTH(3,21)
3450 PMTH(1,22)=ULMASS(22)
3451 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
3452 PMTH(3,22)=2.*PMTH(2,22)
3453 PMTH(4,22)=PMTH(3,22)
3454 PMTH(5,22)=PMTH(3,22)
3455 PMQTH1=PARJ(82)
3456 IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))
3457 PMQTH2=PMTH(2,21)
3458 IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
3459 DO 100 IF=1,8
3460 PMTH(1,IF)=ULMASS(IF)
3461 PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2)
3462 PMTH(3,IF)=PMTH(2,IF)+PMQTH2
3463 PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)
3464 100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)
3465 PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
3466 ALAMS=PARJ(81)**2
3467 ALFM=LOG(PT2MIN/ALAMS)
3468
3469C...Store positions of shower initiating partons.
3470 M3JC=0
3471 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
3472 NPA=1
3473 IPA(1)=IP1
3474 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
3475 &MSTU(32))) THEN
3476 NPA=2
3477 IPA(1)=IP1
3478 IPA(2)=IP2
3479 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.
3480 &AND.IP2.GE.-3) THEN
3481 NPA=IABS(IP2)
3482 DO 110 I=1,NPA
3483 110 IPA(I)=IP1+I-1
3484 ELSE
3485 CALL LUERRM(12,
3486 & '(LUSHOW:) failed to reconstruct showering system')
3487 IF(MSTU(21).GE.1) RETURN
3488 ENDIF
3489
3490C...Check on phase space available for emission.
3491 IREJ=0
3492 DO 120 J=1,5
3493 120 PS(J)=0.
3494 PM=0.
3495 DO 130 I=1,NPA
3496 KFLA(I)=IABS(K(IPA(I),2))
3497 PMA(I)=P(IPA(I),5)
3498 IF(KFLA(I).NE.0.AND.(KFLA(I).LE.8.OR.KFLA(I).EQ.21))
3499 &PMA(I)=PMTH(3,KFLA(I))
3500 PM=PM+PMA(I)
3501 IF(KFLA(I).EQ.0.OR.(KFLA(I).GT.8.AND.KFLA(I).NE.21).OR.
3502 &PMA(I).GT.QMAX) IREJ=IREJ+1
3503 DO 130 J=1,4
3504 130 PS(J)=PS(J)+P(IPA(I),J)
3505 IF(IREJ.EQ.NPA) RETURN
3506 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
3507 IF(NPA.EQ.1) PS(5)=PS(4)
3508 IF(PS(5).LE.PM+PMQTH1) RETURN
3509 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
3510 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
3511 & KFLA(2).LE.8) M3JC=1
3512 IF(MSTJ(47).GE.2) M3JC=1
3513 ENDIF
3514
3515C...Define imagined single initiator of shower for parton system.
3516 NS=N
3517 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
3518 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETSA')
3519 IF(MSTU(21).GE.1) RETURN
3520 ENDIF
3521 IF(NPA.GE.2) THEN
3522 K(N+1,1)=11
3523 K(N+1,2)=21
3524 K(N+1,3)=0
3525 K(N+1,4)=0
3526 K(N+1,5)=0
3527 P(N+1,1)=0.
3528 P(N+1,2)=0.
3529 P(N+1,3)=0.
3530 P(N+1,4)=PS(5)
3531 P(N+1,5)=PS(5)
3532 V(N+1,5)=PS(5)**2
3533 N=N+1
3534 ENDIF
3535
3536C...Loop over partons that may branch.
3537 NEP=NPA
3538 IM=NS
3539 IF(NPA.EQ.1) IM=NS-1
3540 140 IM=IM+1
3541 IF(N.GT.NS) THEN
3542 IF(IM.GT.N) GOTO 380
3543 KFLM=IABS(K(IM,2))
3544 IF(KFLM.EQ.0.OR.(KFLM.GT.8.AND.KFLM.NE.21)) GOTO 140
3545 IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140
3546 IGM=K(IM,3)
3547 ELSE
3548 IGM=-1
3549 ENDIF
3550 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
3551 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETSA')
3552 IF(MSTU(21).GE.1) RETURN
3553 ENDIF
3554
3555C...Position of aunt (sister to branching parton).
3556C...Origin and flavour of daughters.
3557 IAU=0
3558 IF(IGM.GT.0) THEN
3559 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
3560 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
3561 ENDIF
3562 IF(IGM.GE.0) THEN
3563 K(IM,4)=N+1
3564 DO 150 I=1,NEP
3565 150 K(N+I,3)=IM
3566 ELSE
3567 K(N+1,3)=IPA(1)
3568 ENDIF
3569 IF(IGM.LE.0) THEN
3570 DO 160 I=1,NEP
3571 160 K(N+I,2)=K(IPA(I),2)
3572 ELSEIF(KFLM.NE.21) THEN
3573 K(N+1,2)=K(IM,2)
3574 K(N+2,2)=K(IM,5)
3575 ELSEIF(K(IM,5).EQ.21) THEN
3576 K(N+1,2)=21
3577 K(N+2,2)=21
3578 ELSE
3579 K(N+1,2)=K(IM,5)
3580 K(N+2,2)=-K(IM,5)
3581 ENDIF
3582
3583C...Reset flags on daughers and tries made.
3584 DO 170 IP=1,NEP
3585 K(N+IP,1)=3
3586 K(N+IP,4)=0
3587 K(N+IP,5)=0
3588 KFLD(IP)=IABS(K(N+IP,2))
3589 ITRY(IP)=0
3590 ISL(IP)=0
3591 ISI(IP)=0
3592 170 IF(KFLD(IP).GT.0.AND.(KFLD(IP).LE.8.OR.KFLD(IP).EQ.21)) ISI(IP)=1
3593 ISLM=0
3594
3595C...Maximum virtuality of daughters.
3596 IF(IGM.LE.0) THEN
3597 DO 180 I=1,NPA
3598 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
3599 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
3600 P(N+I,5)=MIN(QMAX,PS(5))
3601 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
3602 180 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
3603 ELSE
3604 IF(MSTJ(43).LE.2) PEM=V(IM,2)
3605 IF(MSTJ(43).GE.3) PEM=P(IM,4)
3606 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
3607 P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)
3608 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
3609 ENDIF
3610 DO 190 I=1,NEP
3611 PMSD(I)=P(N+I,5)
3612 IF(ISI(I).EQ.1) THEN
3613 IF(P(N+I,5).LE.PMTH(3,KFLD(I))) P(N+I,5)=PMTH(1,KFLD(I))
3614 ENDIF
3615 190 V(N+I,5)=P(N+I,5)**2
3616
3617C...Choose one of the daughters for evolution.
3618 200 INUM=0
3619 IF(NEP.EQ.1) INUM=1
3620 DO 210 I=1,NEP
3621 210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
3622 DO 220 I=1,NEP
3623 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
3624 IF(P(N+I,5).GE.PMTH(2,KFLD(I))) INUM=I
3625 ENDIF
3626 220 CONTINUE
3627 IF(INUM.EQ.0) THEN
3628 RMAX=0.
3629 DO 230 I=1,NEP
3630 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
3631 RPM=P(N+I,5)/PMSD(I)
3632 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,KFLD(I))) THEN
3633 RMAX=RPM
3634 INUM=I
3635 ENDIF
3636 ENDIF
3637 230 CONTINUE
3638 ENDIF
3639
3640C...Store information on choice of evolving daughter.
3641 INUM=MAX(1,INUM)
3642 IEP(1)=N+INUM
3643 DO 240 I=2,NEP
3644 IEP(I)=IEP(I-1)+1
3645 240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
3646 DO 250 I=1,NEP
3647 250 KFL(I)=IABS(K(IEP(I),2))
3648 ITRY(INUM)=ITRY(INUM)+1
3649 IF(ITRY(INUM).GT.200) THEN
3650 CALL LUERRM(14,'(LUSHOW:) caught in infinite loop')
3651 IF(MSTU(21).GE.1) RETURN
3652 ENDIF
3653 Z=0.5
3654 IF(KFL(1).EQ.0.OR.(KFL(1).GT.8.AND.KFL(1).NE.21)) GOTO 300
3655 IF(P(IEP(1),5).LT.PMTH(2,KFL(1))) GOTO 300
3656
3657C...Calculate allowed z range.
3658 IF(NEP.EQ.1) THEN
3659 PMED=PS(4)
3660 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3661 PMED=P(IM,5)
3662 ELSE
3663 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
3664 IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
3665 ENDIF
3666 IF(MOD(MSTJ(43),2).EQ.1) THEN
3667 ZC=PMTH(2,21)/PMED
3668 ZCE=PMTH(2,22)/PMED
3669 ELSE
3670 ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
3671 IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
3672 ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
3673 IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
3674 ENDIF
3675 ZC=MIN(ZC,0.491)
3676 ZCE=MIN(ZCE,0.491)
3677 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.
3678 &MIN(ZC,ZCE).GT.0.49)) THEN
3679 P(IEP(1),5)=PMTH(1,KFL(1))
3680 V(IEP(1),5)=P(IEP(1),5)**2
3681 GOTO 300
3682 ENDIF
3683
3684C...Integral of Altarelli-Parisi z kernel for QCD.
3685 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
3686 FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
3687 ELSEIF(MSTJ(49).EQ.0) THEN
3688 FBR=(8./3.)*LOG((1.-ZC)/ZC)
3689
3690C...Integral of Altarelli-Parisi z kernel for scalar gluon.
3691 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
3692 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
3693 ELSEIF(MSTJ(49).EQ.1) THEN
3694 FBR=(1.-2.*ZC)/3.
3695 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
3696
3697C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
3698 ELSEIF(KFL(1).EQ.21) THEN
3699 FBR=6.*MSTJ(45)*(0.5-ZC)
3700 ELSE
3701 FBR=2.*LOG((1.-ZC)/ZC)
3702 ENDIF
3703
3704C...Integral of Altarelli-Parisi kernel for photon emission.
3705 IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8)
3706 &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
3707
3708C...Inner veto algorithm starts. Find maximum mass for evolution.
3709 260 PMS=V(IEP(1),5)
3710 IF(IGM.GE.0) THEN
3711 PM2=0.
3712 DO 270 I=2,NEP
3713 PM=P(IEP(I),5)
3714 IF(KFL(I).GT.0.AND.(KFL(I).LE.8.OR.KFL(I).EQ.21)) PM=
3715 & PMTH(2,KFL(I))
3716 270 PM2=PM2+PM
3717 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
3718 ENDIF
3719
3720C...Select mass for daughter in QCD evolution.
3721 B0=27./6.
3722 DO 280 IF=4,MSTJ(45)
3723 280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6.
3724 IF(MSTJ(44).LE.0) THEN
3725 PMSQCD=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))
3726 ELSEIF(MSTJ(44).EQ.1) THEN
3727 PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))
3728 ELSE
3729 PMSQCD=PMS*RLU(0)**(ALFM*B0/FBR)
3730 ENDIF
3731 IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD=
3732 &PMTH(2,KFL(1))**2
3733 V(IEP(1),5)=PMSQCD
3734 MCE=1
3735
3736C...Select mass for daughter in QED evolution.
3737 IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.8) THEN
3738 PMSQED=PMS*EXP(MAX(-100.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE)))
3739 IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=
3740 & PMTH(2,KFL(1))**2
3741 IF(PMSQED.GT.PMSQCD) THEN
3742 V(IEP(1),5)=PMSQED
3743 MCE=2
3744 ENDIF
3745 ENDIF
3746
3747C...Check whether daughter mass below cutoff.
3748 P(IEP(1),5)=SQRT(V(IEP(1),5))
3749 IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN
3750 P(IEP(1),5)=PMTH(1,KFL(1))
3751 V(IEP(1),5)=P(IEP(1),5)**2
3752 GOTO 300
3753 ENDIF
3754
3755C...Select z value of branching: q -> qgamma.
3756 IF(MCE.EQ.2) THEN
3757 Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)
3758 IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
3759 K(IEP(1),5)=22
3760
3761C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
3762 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
3763 Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
3764 IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
3765 K(IEP(1),5)=21
3766 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN
3767 Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
3768 IF(RLU(0).GT.0.5) Z=1.-Z
3769 IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260
3770 K(IEP(1),5)=21
3771 ELSEIF(MSTJ(49).NE.1) THEN
3772 Z=ZC+(1.-2.*ZC)*RLU(0)
3773 IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260
3774 KFLB=1+INT(MSTJ(45)*RLU(0))
3775 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
3776 IF(PMQ.GE.1.) GOTO 260
3777 PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
3778 IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
3779 & RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260
3780 K(IEP(1),5)=KFLB
3781
3782C...Ditto for scalar gluon model.
3783 ELSEIF(KFL(1).NE.21) THEN
3784 Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))
3785 K(IEP(1),5)=21
3786 ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
3787 Z=ZC+(1.-2.*ZC)*RLU(0)
3788 K(IEP(1),5)=21
3789 ELSE
3790 Z=ZC+(1.-2.*ZC)*RLU(0)
3791 KFLB=1+INT(MSTJ(45)*RLU(0))
3792 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
3793 IF(PMQ.GE.1.) GOTO 260
3794 K(IEP(1),5)=KFLB
3795 ENDIF
3796 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
3797 IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260
3798 IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260
3799 ENDIF
3800
3801C...Check if z consistent with chosen m.
3802 IF(KFL(1).EQ.21) THEN
3803 KFLGD1=IABS(K(IEP(1),5))
3804 KFLGD2=KFLGD1
3805 ELSE
3806 KFLGD1=KFL(1)
3807 KFLGD2=IABS(K(IEP(1),5))
3808 ENDIF
3809 IF(NEP.EQ.1) THEN
3810 PED=PS(4)
3811 ELSEIF(NEP.GE.3) THEN
3812 PED=P(IEP(1),4)
3813 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3814 PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
3815 ELSE
3816 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
3817 IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
3818 ENDIF
3819 IF(MOD(MSTJ(43),2).EQ.1) THEN
3820 PMQTH3=0.5*PARJ(82)
3821 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
3822 PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
3823 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
3824 ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
3825 & 4.*PMQ1*PMQ2)))
3826 ZH=1.+PMQ1-PMQ2
3827 ELSE
3828 ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
3829 ZH=1.
3830 ENDIF
3831 ZL=0.5*(ZH-ZD)
3832 ZU=0.5*(ZH+ZD)
3833 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260
3834 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
3835 &(1.-ZU)))
3836 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
3837
3838C...Three-jet matrix element correction.
3839 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
3840 X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
3841 X2=1.-V(IEP(1),5)/V(NS+1,5)
3842 X3=(1.-X1)+(1.-X2)
3843 IF(MCE.EQ.2) THEN
3844 KI1=K(IPA(INUM),2)
3845 KI2=K(IPA(3-INUM),2)
3846 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
3847 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
3848 WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
3849 & QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
3850 WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
3851 ELSEIF(MSTJ(49).NE.1) THEN
3852 WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
3853 & (1.-X2)/X3*(X2/(2.-X1))**2
3854 WME=X1**2+X2**2
3855 ELSE
3856 WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
3857 WME=X3**2
3858 ENDIF
3859 IF(WME.LT.RLU(0)*WSHOW) GOTO 260
3860
3861C...Impose angular ordering by rejection of nonordered emission.
3862 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
3863 MAOM=1
3864 ZM=V(IM,1)
3865 IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
3866 THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
3867 IAOM=IM
3868 290 IF(K(IAOM,5).EQ.22) THEN
3869 IAOM=K(IAOM,3)
3870 IF(K(IAOM,3).LE.NS) MAOM=0
3871 IF(MAOM.EQ.1) GOTO 290
3872 ENDIF
3873 IF(MAOM.EQ.1) THEN
3874 THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
3875 IF(THE2ID.LT.THE2IM) GOTO 260
3876 ENDIF
3877 ENDIF
3878
3879C...Impose user-defined maximum angle at first branching.
3880 IF(MSTJ(48).EQ.1) THEN
3881 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
3882 THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
3883 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
3884 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
3885 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
3886 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
3887 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
3888 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
3889 IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260
3890 ENDIF
3891 ENDIF
3892
3893C...End of inner veto algorithm. Check if only one leg evolved so far.
3894 300 V(IEP(1),1)=Z
3895 ISL(1)=0
3896 ISL(2)=0
3897 IF(NEP.EQ.1) GOTO 330
3898 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200
3899 DO 310 I=1,NEP
3900 IF(ITRY(I).EQ.0.AND.KFLD(I).GT.0.AND.(KFLD(I).LE.8.OR.KFLD(I).EQ.
3901 &21)) THEN
3902 IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200
3903 ENDIF
3904 310 CONTINUE
3905
3906C...Check if chosen multiplet m1,m2,z1,z2 is physical.
3907 IF(NEP.EQ.3) THEN
3908 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
3909 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
3910 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
3911 PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
3912 & PA1S**2-PA2S**2-PA3S**2)/PA1S
3913 IF(PTS.LE.0.) GOTO 200
3914 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
3915 DO 320 I1=N+1,N+2
3916 KFLDA=IABS(K(I1,2))
3917 IF(KFLDA.EQ.0.OR.(KFLDA.GT.8.AND.KFLDA.NE.21)) GOTO 320
3918 IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320
3919 IF(KFLDA.EQ.21) THEN
3920 KFLGD1=IABS(K(I1,5))
3921 KFLGD2=KFLGD1
3922 ELSE
3923 KFLGD1=KFLDA
3924 KFLGD2=IABS(K(I1,5))
3925 ENDIF
3926 I2=2*N+3-I1
3927 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
3928 PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
3929 ELSE
3930 IF(I1.EQ.N+1) ZM=V(IM,1)
3931 IF(I1.EQ.N+2) ZM=1.-V(IM,1)
3932 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
3933 & 4.*V(N+1,5)*V(N+2,5))
3934 PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
3935 ENDIF
3936 IF(MOD(MSTJ(43),2).EQ.1) THEN
3937 PMQTH3=0.5*PARJ(82)
3938 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
3939 PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)
3940 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
3941 ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
3942 & 4.*PMQ1*PMQ2)))
3943 ZH=1.+PMQ1-PMQ2
3944 ELSE
3945 ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
3946 ZH=1.
3947 ENDIF
3948 ZL=0.5*(ZH-ZD)
3949 ZU=0.5*(ZH+ZD)
3950 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
3951 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
3952 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
3953 IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
3954 320 CONTINUE
3955 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
3956 ISL(3-ISLM)=0
3957 ISLM=3-ISLM
3958 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
3959 ZDR1=MAX(0.,V(N+1,3)/V(N+1,4)-1.)
3960 ZDR2=MAX(0.,V(N+2,3)/V(N+2,4)-1.)
3961 IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0
3962 IF(ISL(1).EQ.1) ISL(2)=0
3963 IF(ISL(1).EQ.0) ISLM=1
3964 IF(ISL(2).EQ.0) ISLM=2
3965 ENDIF
3966 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200
3967 ENDIF
3968 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
3969 &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN
3970 PMQ1=V(N+1,5)/V(IM,5)
3971 PMQ2=V(N+2,5)/V(IM,5)
3972 ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
3973 & 4.*PMQ1*PMQ2)))
3974 ZH=1.+PMQ1-PMQ2
3975 ZL=0.5*(ZH-ZD)
3976 ZU=0.5*(ZH+ZD)
3977 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200
3978 ENDIF
3979
3980C...Accepted branch. Construct four-momentum for initial partons.
3981 330 MAZIP=0
3982 MAZIC=0
3983 IF(NEP.EQ.1) THEN
3984 P(N+1,1)=0.
3985 P(N+1,2)=0.
3986 P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
3987 & P(N+1,5))))
3988 P(N+1,4)=P(IPA(1),4)
3989 V(N+1,2)=P(N+1,4)
3990 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
3991 PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
3992 P(N+1,1)=0.
3993 P(N+1,2)=0.
3994 P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
3995 P(N+1,4)=PED1
3996 P(N+2,1)=0.
3997 P(N+2,2)=0.
3998 P(N+2,3)=-P(N+1,3)
3999 P(N+2,4)=P(IM,5)-PED1
4000 V(N+1,2)=P(N+1,4)
4001 V(N+2,2)=P(N+2,4)
4002 ELSEIF(NEP.EQ.3) THEN
4003 P(N+1,1)=0.
4004 P(N+1,2)=0.
4005 P(N+1,3)=SQRT(MAX(0.,PA1S))
4006 P(N+2,1)=SQRT(PTS)
4007 P(N+2,2)=0.
4008 P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
4009 P(N+3,1)=-P(N+2,1)
4010 P(N+3,2)=0.
4011 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
4012 V(N+1,2)=P(N+1,4)
4013 V(N+2,2)=P(N+2,4)
4014 V(N+3,2)=P(N+3,4)
4015
4016C...Construct transverse momentum for ordinary branching in shower.
4017 ELSE
4018 ZM=V(IM,1)
4019 PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
4020 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
4021 IF(PZM.LE.0.) THEN
4022 PTS=0.
4023 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
4024 PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
4025 & ZM*V(N+2,5))-0.25*PMLS)/PZM**2
4026 ELSE
4027 PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
4028 ENDIF
4029 PT=SQRT(MAX(0.,PTS))
4030
4031C...Find coefficient of azimuthal asymmetry due to gluon polarization.
4032 HAZIP=0.
4033 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
4034 & AND.IAU.NE.0) THEN
4035 IF(K(IGM,3).NE.0) MAZIP=1
4036 ZAU=V(IGM,1)
4037 IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
4038 IF(MAZIP.EQ.0) ZAU=0.
4039 IF(K(IGM,2).NE.21) THEN
4040 HAZIP=2.*ZAU/(1.+ZAU**2)
4041 ELSE
4042 HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
4043 ENDIF
4044 IF(K(N+1,2).NE.21) THEN
4045 HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
4046 ELSE
4047 HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
4048 ENDIF
4049 ENDIF
4050
4051C...Find coefficient of azimuthal asymmetry due to soft gluon
4052C...interference.
4053 HAZIC=0.
4054 IF(MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.K(N+2,2).EQ.21).
4055 & AND.IAU.NE.0) THEN
4056 IF(K(IGM,3).NE.0) MAZIC=N+1
4057 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
4058 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
4059 & ZM.GT.0.5) MAZIC=N+2
4060 IF(K(IAU,2).EQ.22) MAZIC=0
4061 ZS=ZM
4062 IF(MAZIC.EQ.N+2) ZS=1.-ZM
4063 ZGM=V(IGM,1)
4064 IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
4065 IF(MAZIC.EQ.0) ZGM=1.
4066 HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
4067 HAZIC=MIN(0.95,HAZIC)
4068 ENDIF
4069 ENDIF
4070
4071C...Construct kinematics for ordinary branching in shower.
4072 340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
4073 IF(MOD(MSTJ(43),2).EQ.1) THEN
4074 P(N+1,4)=PEM*V(IM,1)
4075 ELSE
4076 P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
4077 & SQRT(PMLS)*ZM)/V(IM,5)
4078 ENDIF
4079 PHI=PARU(2)*RLU(0)
4080 P(N+1,1)=PT*COS(PHI)
4081 P(N+1,2)=PT*SIN(PHI)
4082 IF(PZM.GT.0.) THEN
4083 P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
4084 ELSE
4085 P(N+1,3)=0.
4086 ENDIF
4087 P(N+2,1)=-P(N+1,1)
4088 P(N+2,2)=-P(N+1,2)
4089 P(N+2,3)=PZM-P(N+1,3)
4090 P(N+2,4)=PEM-P(N+1,4)
4091 IF(MSTJ(43).LE.2) THEN
4092 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
4093 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
4094 ENDIF
4095 ENDIF
4096
4097C...Rotate and boost daughters.
4098 IF(IGM.GT.0) THEN
4099 IF(MSTJ(43).LE.2) THEN
4100 BEX=P(IGM,1)/P(IGM,4)
4101 BEY=P(IGM,2)/P(IGM,4)
4102 BEZ=P(IGM,3)/P(IGM,4)
4103 GA=P(IGM,4)/P(IGM,5)
4104 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
4105 & P(IM,4))
4106 ELSE
4107 BEX=0.
4108 BEY=0.
4109 BEZ=0.
4110 GA=1.
4111 GABEP=0.
4112 ENDIF
4113 THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
4114 & (P(IM,2)+GABEP*BEY)**2))
4115 PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
4116 DO 350 I=N+1,N+2
4117 DP(1)=dble(COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
4118 & SIN(THE)*COS(PHI)*P(I,3))
4119 DP(2)=dble(COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
4120 & SIN(THE)*SIN(PHI)*P(I,3))
4121 DP(3)=dble(-SIN(THE)*P(I,1)+COS(THE)*P(I,3))
4122 DP(4)=dble(P(I,4))
4123 DBP=dble(BEX)*DP(1)+dble(BEY)*DP(2)+dble(BEZ)*DP(3)
4124 DGABP=dble(GA)*(dble(GA)*DBP/(1D0+dble(GA))+DP(4))
4125 P(I,1)=sngl(DP(1)+DGABP*dble(BEX))
4126 P(I,2)=sngl(DP(2)+DGABP*dble(BEY))
4127 P(I,3)=sngl(DP(3)+DGABP*dble(BEZ))
4128 350 P(I,4)=GA*sngl(DP(4)+DBP)
4129 ENDIF
4130
4131C...Weight with azimuthal distribution, if required.
4132 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
4133 DO 360 J=1,3
4134 DPT(1,J)=dble(P(IM,J))
4135 DPT(2,J)=dble(P(IAU,J))
4136 360 DPT(3,J)=dble(P(N+1,J))
4137 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
4138 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
4139 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
4140 DO 370 J=1,3
4141 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
4142 370 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
4143 DPT(4,4)=DSQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
4144 DPT(5,4)=DSQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
4145 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN
4146 CAD=sngl((DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
4147 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)))
4148 IF(MAZIP.NE.0) THEN
4149 IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))
4150 & GOTO 340
4151 ENDIF
4152 IF(MAZIC.NE.0) THEN
4153 IF(MAZIC.EQ.N+2) CAD=-CAD
4154 IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).
4155 & LT.RLU(0)) GOTO 340
4156 ENDIF
4157 ENDIF
4158 ENDIF
4159
4160C...Continue loop over partons that may branch, until none left.
4161 IF(IGM.GE.0) K(IM,1)=14
4162 N=N+NEP
4163 NEP=2
4164 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4165 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETSA')
4166 IF(MSTU(21).GE.1) N=NS
4167 IF(MSTU(21).GE.1) RETURN
4168 ENDIF
4169 GOTO 140
4170
4171C...Set information on imagined shower initiator.
4172 380 IF(NPA.GE.2) THEN
4173 K(NS+1,1)=11
4174 K(NS+1,2)=94
4175 K(NS+1,3)=IP1
4176 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
4177 K(NS+1,4)=NS+2
4178 K(NS+1,5)=NS+1+NPA
4179 IIM=1
4180 ELSE
4181 IIM=0
4182 ENDIF
4183
4184C...Reconstruct string drawing information.
4185 DO 390 I=NS+1+IIM,N
4186 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
4187 K(I,1)=1
4188 ELSEIF(K(I,1).LE.10) THEN
4189 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
4190 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
4191 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
4192 ID1=MOD(K(I,4),MSTU(5))
4193 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
4194 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
4195 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4196 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
4197 K(ID1,4)=K(ID1,4)+MSTU(5)*I
4198 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
4199 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
4200 K(ID2,5)=K(ID2,5)+MSTU(5)*I
4201 ELSE
4202 ID1=MOD(K(I,4),MSTU(5))
4203 ID2=ID1+1
4204 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4205 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
4206 K(ID1,4)=K(ID1,4)+MSTU(5)*I
4207 K(ID1,5)=K(ID1,5)+MSTU(5)*I
4208 K(ID2,4)=0
4209 K(ID2,5)=0
4210 ENDIF
4211 390 CONTINUE
4212
4213C...Transformation from CM frame.
4214 IF(NPA.GE.2) THEN
4215 BEX=PS(1)/PS(4)
4216 BEY=PS(2)/PS(4)
4217 BEZ=PS(3)/PS(4)
4218 GA=PS(4)/PS(5)
4219 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
4220 & /(1.+GA)-P(IPA(1),4))
4221 ELSE
4222 BEX=0.
4223 BEY=0.
4224 BEZ=0.
4225 GABEP=0.
4226 ENDIF
4227 THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
4228 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
4229 PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
4230 IF(NPA.EQ.3) THEN
4231 CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
4232 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
4233 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
4234 & GABEP*BEY))
4235 CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
4236 ENDIF
4237 DBEX=DBLE(BEX)
4238 DBEY=DBLE(BEY)
4239 DBEZ=DBLE(BEZ)
4240 CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
4241
4242C...Decay vertex of shower.
4243 DO 400 I=NS+1,N
4244 DO 400 J=1,5
4245 400 V(I,J)=V(IP1,J)
4246
4247C...Delete trivial shower, else connect initiators.
4248 IF(N.EQ.NS+NPA+IIM) THEN
4249 N=NS
4250 ELSE
4251 DO 410 IP=1,NPA
4252 K(IPA(IP),1)=14
4253 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
4254 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
4255 K(NS+IIM+IP,3)=IPA(IP)
4256 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
4257 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
4258 410 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
4259 ENDIF
4260
4261 RETURN
4262 END
4263
4264C*********************************************************************
4265
4266 SUBROUTINE LUBOEI(NSAV)
4267
4268C...Purpose: to modify event so as to approximately take into account
4269C...Bose-Einstein effects according to a simple phenomenological
4270C...parametrization.
4271 IMPLICIT DOUBLE PRECISION(D)
4272 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
4273 SAVE /LUJETSA/
4274 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4275 SAVE /LUDAT1A/
4276 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
4277 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
4278
4279 pmhq=0.
4280 qdel=0.
4281 nbin=0
4282 beex=0.
4283 bert=0.
4284
4285C...Boost event to overall CM frame. Calculate CM energy.
4286 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
4287 DO 100 J=1,4
4288 100 DPS(J)=0.d0
4289 DO 120 I=1,N
4290 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
4291 DO 110 J=1,4
4292 110 DPS(J)=DPS(J)+dble(P(I,J))
4293 120 CONTINUE
4294 CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
4295 &-DPS(3)/DPS(4))
4296 PECM=0.
4297 DO 130 I=1,N
4298 130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
4299
4300C...Reserve copy of particles by species at end of record.
4301 NBE(0)=N+MSTU(3)
4302 DO 160 IBE=1,MIN(9,MSTJ(51))
4303 NBE(IBE)=NBE(IBE-1)
4304 DO 150 I=NSAV+1,N
4305 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
4306 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
4307 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
4308 CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETSA')
4309 RETURN
4310 ENDIF
4311 NBE(IBE)=NBE(IBE)+1
4312 K(NBE(IBE),1)=I
4313 DO 140 J=1,3
4314 140 P(NBE(IBE),J)=0.
4315 150 CONTINUE
4316 160 CONTINUE
4317
4318C...Tabulate integral for subsequent momentum shift.
4319 DO 210 IBE=1,MIN(9,MSTJ(51))
4320 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
4321 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).
4322 &LE.1) GOTO 180
4323 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
4324 &NBE(7)-NBE(6)).LE.1) GOTO 180
4325 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
4326 IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)
4327 IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)
4328 IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)
4329 IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)
4330 QDEL=0.1*MIN(PMHQ,PARJ(93))
4331 IF(MSTJ(51).EQ.1) THEN
4332 NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
4333 BEEX=EXP(0.5*QDEL/PARJ(93))
4334 BERT=EXP(-QDEL/PARJ(93))
4335 ELSE
4336 NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
4337 ENDIF
4338 DO 170 IBIN=1,NBIN
4339 QBIN=QDEL*(IBIN-0.5)
4340 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
4341 IF(MSTJ(51).EQ.1) THEN
4342 BEEX=BEEX*BERT
4343 BEI(IBIN)=BEI(IBIN)*BEEX
4344 ELSE
4345 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
4346 ENDIF
4347 170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
4348
4349C...Loop through particle pairs and find old relative momentum.
4350 180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
4351 I1=K(I1M,1)
4352 DO 200 I2M=I1M+1,NBE(IBE)
4353 I2=K(I2M,1)
4354 Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
4355 &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
4356 QOLD=SQRT(Q2OLD)
4357
4358C...Calculate new relative momentum.
4359 IF(QOLD.LT.0.5*QDEL) THEN
4360 QMOV=QOLD/3.
4361 ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
4362 RBIN=QOLD/QDEL
4363 IBIN=int(RBIN)
4364 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
4365 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
4366 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
4367 ELSE
4368 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
4369 ENDIF
4370 Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
4371
4372C...Calculate and save shift to be performed on three-momenta.
4373 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
4374 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
4375 HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
4376 DO 190 J=1,3
4377 PD=HA*(P(I2,J)-P(I1,J))
4378 P(I1M,J)=P(I1M,J)+PD
4379 190 P(I2M,J)=P(I2M,J)-PD
4380 200 CONTINUE
4381 210 CONTINUE
4382
4383C...Shift momenta and recalculate energies.
4384 DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(51)))
4385 I=K(IM,1)
4386 DO 220 J=1,3
4387 220 P(I,J)=P(I,J)+P(IM,J)
4388 230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4389
4390C...Rescale all momenta for energy conservation.
4391 PES=0.
4392 PQS=0.
4393 DO 240 I=1,N
4394 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
4395 PES=PES+P(I,4)
4396 PQS=PQS+P(I,5)**2/P(I,4)
4397 240 CONTINUE
4398 FAC=(PECM-PQS)/(PES-PQS)
4399 DO 260 I=1,N
4400 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260
4401 DO 250 J=1,3
4402 250 P(I,J)=FAC*P(I,J)
4403 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
4404 260 CONTINUE
4405
4406C...Boost back to correct reference frame.
4407 CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
4408
4409 RETURN
4410 END
4411
4412C*********************************************************************
4413
4414 FUNCTION ULMASS(KF)
4415
4416C...Purpose: to give the mass of a particle/parton.
4417 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4418 SAVE /LUDAT1A/
4419 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4420 SAVE /LUDAT2A/
4421
4422 pmspl=0.
4423
4424C...Reset variables. Compressed code.
4425 ULMASS=0.
4426 KFA=IABS(KF)
4427 KC=LUCOMP(KF)
4428 IF(KC.EQ.0) RETURN
4429 PARF(106)=PMAS(6,1)
4430 PARF(107)=PMAS(7,1)
4431 PARF(108)=PMAS(8,1)
4432
4433C...Guarantee use of constituent masses for internal checks.
4434 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
4435 ULMASS=PARF(100+KFA)
4436 IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))
4437
4438C...Masses that can be read directly off table.
4439 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4440 ULMASS=PMAS(KC,1)
4441
4442C...Find constituent partons and their masses.
4443 ELSE
4444 KFLA=MOD(KFA/1000,10)
4445 KFLB=MOD(KFA/100,10)
4446 KFLC=MOD(KFA/10,10)
4447 KFLS=MOD(KFA,10)
4448 KFLR=MOD(KFA/10000,10)
4449 PMA=PARF(100+KFLA)
4450 PMB=PARF(100+KFLB)
4451 PMC=PARF(100+KFLC)
4452
4453C...Construct masses for various meson, diquark and baryon cases.
4454 IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4455 IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
4456 IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
4457 ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
4458 ELSEIF(KFLA.EQ.0) THEN
4459 KMUL=2
4460 IF(KFLS.EQ.1) KMUL=3
4461 IF(KFLR.EQ.2) KMUL=4
4462 IF(KFLS.EQ.5) KMUL=5
4463 ULMASS=PARF(113+KMUL)+PMB+PMC
4464 ELSEIF(KFLC.EQ.0) THEN
4465 IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
4466 IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
4467 ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
4468 IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB
4469 IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)-
4470 & 2.*PARF(112)/3.)
4471 ELSE
4472 IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
4473 PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
4474 ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
4475 PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
4476 ELSEIF(KFLS.EQ.2) THEN
4477 PMSPL=-3./(PMB*PMC)
4478 ELSE
4479 PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
4480 ENDIF
4481 ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
4482 ENDIF
4483 ENDIF
4484
4485C...Optional mass broadening according to truncated Breit-Wigner
4486C...(either in m or in m^2).
4487 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
4488 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
4489 ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*
4490 & ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
4491 ELSE
4492 PM0=ULMASS
4493 PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
4494 & (PM0*PMAS(KC,2)))
4495 PMUPP=ATAN((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))
4496 ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
4497 & (PMUPP-PMLOW)*RLU(0))))
4498 ENDIF
4499 ENDIF
4500 MSTJ(93)=0
4501
4502 RETURN
4503 END
4504
4505C*********************************************************************
4506
4507 SUBROUTINE LUNAME(KF,CHAU)
4508
4509C...Purpose: to give the particle/parton name as a character string.
4510 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4511 SAVE /LUDAT1A/
4512 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4513 SAVE /LUDAT2A/
4514 COMMON/LUDAT4A/CHAF(500)
4515 CHARACTER CHAF*8
4516 SAVE /LUDAT4A/
4517 CHARACTER CHAU*16
4518
4519C...Initial values. Charge. Subdivide code.
4520 CHAU=' '
4521 KFA=IABS(KF)
4522 KC=LUCOMP(KF)
4523 IF(KC.EQ.0) RETURN
4524 KQ=LUCHGE(KF)
4525 KFLA=MOD(KFA/1000,10)
4526 KFLB=MOD(KFA/100,10)
4527 KFLC=MOD(KFA/10,10)
4528 KFLS=MOD(KFA,10)
4529 KFLR=MOD(KFA/10000,10)
4530
4531C...Read out root name and spin for simple particle.
4532 IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
4533 CHAU=CHAF(KC)
4534 LEN=0
4535 DO 100 LEM=1,8
4536 100 IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
4537
4538C...Construct root name for diquark. Add on spin.
4539 ELSEIF(KFLC.EQ.0) THEN
4540 CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
4541 IF(KFLS.EQ.1) CHAU(3:4)='_0'
4542 IF(KFLS.EQ.3) CHAU(3:4)='_1'
4543 LEN=4
4544
4545C...Construct root name for heavy meson. Add on spin and heavy flavour.
4546 ELSEIF(KFLA.EQ.0) THEN
4547 IF(KFLB.EQ.5) CHAU(1:1)='B'
4548 IF(KFLB.EQ.6) CHAU(1:1)='T'
4549 IF(KFLB.EQ.7) CHAU(1:1)='L'
4550 IF(KFLB.EQ.8) CHAU(1:1)='H'
4551 LEN=1
4552 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4553 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4554 CHAU(2:2)='*'
4555 LEN=2
4556 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4557 CHAU(2:3)='_1'
4558 LEN=3
4559 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4560 CHAU(2:4)='*_0'
4561 LEN=4
4562 ELSEIF(KFLR.EQ.2) THEN
4563 CHAU(2:4)='*_1'
4564 LEN=4
4565 ELSEIF(KFLS.EQ.5) THEN
4566 CHAU(2:4)='*_2'
4567 LEN=4
4568 ENDIF
4569 IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
4570 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
4571 LEN=LEN+2
4572 ELSEIF(KFLC.GE.3) THEN
4573 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4574 LEN=LEN+1
4575 ENDIF
4576
4577C...Construct root name and spin for heavy baryon.
4578 ELSE
4579 IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
4580 CHAU='Sigma '
4581 IF(KFLC.GT.KFLB) CHAU='Lambda'
4582 IF(KFLS.EQ.4) CHAU='Sigma*'
4583 LEN=5
4584 IF(CHAU(6:6).NE.' ') LEN=6
4585 ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
4586 CHAU='Xi '
4587 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
4588 IF(KFLS.EQ.4) CHAU='Xi*'
4589 LEN=2
4590 IF(CHAU(3:3).NE.' ') LEN=3
4591 ELSE
4592 CHAU='Omega '
4593 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
4594 IF(KFLS.EQ.4) CHAU='Omega*'
4595 LEN=5
4596 IF(CHAU(6:6).NE.' ') LEN=6
4597 ENDIF
4598
4599C...Add on heavy flavour content for heavy baryon.
4600 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
4601 LEN=LEN+2
4602 IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
4603 CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
4604 LEN=LEN+2
4605 ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
4606 CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
4607 LEN=LEN+1
4608 ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
4609 CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
4610 LEN=LEN+2
4611 ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
4612 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
4613 LEN=LEN+1
4614 ENDIF
4615 ENDIF
4616
4617C...Add on bar sign for antiparticle (where necessary).
4618 IF(KF.GT.0.OR.LEN.EQ.0) THEN
4619 ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0) THEN
4620 ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
4621 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
4622 ELSEIF(MSTU(15).LE.1) THEN
4623 CHAU(LEN+1:LEN+1)='~'
4624 LEN=LEN+1
4625 ELSE
4626 CHAU(LEN+1:LEN+3)='bar'
4627 LEN=LEN+3
4628 ENDIF
4629
4630C...Add on charge where applicable (conventional cases skipped).
4631 IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
4632 IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
4633 IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
4634 IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
4635 IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
4636 ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
4637 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
4638 &KFLB.NE.1) THEN
4639 ELSEIF(KQ.EQ.0) THEN
4640 CHAU(LEN+1:LEN+1)='0'
4641 ENDIF
4642
4643 RETURN
4644 END
4645
4646C*********************************************************************
4647
4648 FUNCTION LUCHGE(KF)
4649
4650C...Purpose: to give three times the charge for a particle/parton.
4651 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4652 SAVE /LUDAT2A/
4653
4654C...Initial values. Simple case of direct readout.
4655 LUCHGE=0
4656 KFA=IABS(KF)
4657 KC=LUCOMP(KFA)
4658 IF(KC.EQ.0) THEN
4659 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
4660 LUCHGE=KCHG(KC,1)
4661
4662C...Construction from quark content for heavy meson, diquark, baryon.
4663 ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
4664 LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
4665 & (-1)**MOD(KFA/100,10)
4666 ELSEIF(MOD(KFA/10,10).EQ.0) THEN
4667 LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
4668 ELSE
4669 LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
4670 & KCHG(MOD(KFA/10,10),1)
4671 ENDIF
4672
4673C...Add on correct sign.
4674 LUCHGE=LUCHGE*ISIGN(1,KF)
4675
4676 RETURN
4677 END
4678
4679C*********************************************************************
4680
4681 FUNCTION LUCOMP(KF)
4682
4683C...Purpose: to compress the standard KF codes for use in mass and decay
4684C...arrays; also to check whether a given code actually is defined.
4685 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4686 SAVE /LUDAT2A/
4687
4688C...Subdivide KF code into constituent pieces.
4689 LUCOMP=0
4690 KFA=IABS(KF)
4691 KFLA=MOD(KFA/1000,10)
4692 KFLB=MOD(KFA/100,10)
4693 KFLC=MOD(KFA/10,10)
4694 KFLS=MOD(KFA,10)
4695 KFLR=MOD(KFA/10000,10)
4696
4697C...Simple cases: direct translation or special codes.
4698 IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
4699 ELSEIF(KFA.LE.100) THEN
4700 LUCOMP=KFA
4701 IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0
4702 ELSEIF(KFLS.EQ.0) THEN
4703 IF(KF.EQ.130) LUCOMP=221
4704 IF(KF.EQ.310) LUCOMP=222
4705 IF(KFA.EQ.210) LUCOMP=281
4706 IF(KFA.EQ.2110) LUCOMP=282
4707 IF(KFA.EQ.2210) LUCOMP=283
4708
4709C...Mesons.
4710 ELSEIF(KFA-10000*KFLR.LT.1000) THEN
4711 IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
4712 ELSEIF(KFLB.LT.KFLC) THEN
4713 ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
4714 ELSEIF(KFLB.EQ.KFLC) THEN
4715 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4716 LUCOMP=110+KFLB
4717 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4718 LUCOMP=130+KFLB
4719 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4720 LUCOMP=150+KFLB
4721 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4722 LUCOMP=170+KFLB
4723 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
4724 LUCOMP=190+KFLB
4725 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
4726 LUCOMP=210+KFLB
4727 ENDIF
4728 ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN
4729 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
4730 LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
4731 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
4732 LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
4733 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
4734 LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
4735 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
4736 LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
4737 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
4738 LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
4739 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
4740 LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
4741 ENDIF
4742 ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).
4743 & OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
4744 LUCOMP=80+KFLB
4745 ENDIF
4746
4747C...Diquarks.
4748 ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
4749 IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
4750 ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
4751 ELSEIF(KFLA.LT.KFLB) THEN
4752 ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
4753 ELSE
4754 LUCOMP=90
4755 ENDIF
4756
4757C...Spin 1/2 baryons.
4758 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
4759 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
4760 ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
4761 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
4762 LUCOMP=80+KFLA
4763 ELSEIF(KFLB.LT.KFLC) THEN
4764 LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
4765 ELSE
4766 LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
4767 ENDIF
4768
4769C...Spin 3/2 baryons.
4770 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
4771 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
4772 ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
4773 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
4774 LUCOMP=80+KFLA
4775 ELSE
4776 LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
4777 ENDIF
4778 ENDIF
4779
4780 RETURN
4781 END
4782
4783C*********************************************************************
4784
4785 SUBROUTINE LUERRM(MERR,CHMESS)
4786
4787C...Purpose: to inform user of errors in program execution.
4788 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
4789 SAVE /LUJETSA/
4790 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4791 SAVE /LUDAT1A/
4792 CHARACTER CHMESS*(*)
4793
4794 write (6,*) 'merr,chmess=',merr,chmess
4795
4796C...Write first few warnings, then be silent.
4797 IF(MERR.LE.10) THEN
4798 MSTU(27)=MSTU(27)+1
4799 MSTU(28)=MERR
4800 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),1000)
4801 & MERR,MSTU(31),CHMESS
4802
4803C...Write first few errors, then be silent or stop program.
4804 ELSEIF(MERR.LE.20) THEN
4805 MSTU(23)=MSTU(23)+1
4806 MSTU(24)=MERR-10
4807 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),1100)
4808 & MERR-10,MSTU(31),CHMESS
4809 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
4810 WRITE(MSTU(11),1100) MERR-10,MSTU(31),CHMESS
4811 WRITE(MSTU(11),1200)
4812 IF(MERR.NE.17) CALL LULIST(2)
4813 STOP
4814 ENDIF
4815
4816C...Stop program in case of irreparable error.
4817 ELSE
4818 WRITE(MSTU(11),1300) MERR-20,MSTU(31),CHMESS
4819 STOP
4820 ENDIF
4821
4822C...Formats for output.
4823 1000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
4824 &' LUEXEC calls:'/5X,A)
4825 1100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
4826 &' LUEXEC calls:'/5X,A)
4827 1200 FORMAT(5X,'Execution will be stopped after listing of last ',
4828 &'event!')
4829 1300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
4830 &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
4831
4832 RETURN
4833 END
4834
4835C*********************************************************************
4836
4837 FUNCTION ULALPS(Q2)
4838
4839C...Purpose: to give the value of alpha_strong.
4840 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4841 SAVE /LUDAT1A/
4842 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4843 SAVE /LUDAT2A/
4844
4845C...Constant alpha_strong trivial.
4846 IF(MSTU(111).LE.0) THEN
4847 ULALPS=PARU(111)
4848 MSTU(118)=MSTU(112)
4849 PARU(117)=0.
4850 PARU(118)=PARU(111)
4851 RETURN
4852 ENDIF
4853
4854C...Find effective Q2, number of flavours and Lambda.
4855 Q2EFF=Q2
4856 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
4857 NF=MSTU(112)
4858 ALAM2=PARU(112)**2
4859 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
4860 Q2THR=PARU(113)*PMAS(NF,1)**2
4861 IF(Q2EFF.LT.Q2THR) THEN
4862 NF=NF-1
4863 ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
4864 GOTO 100
4865 ENDIF
4866 ENDIF
4867 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
4868 Q2THR=PARU(113)*PMAS(NF+1,1)**2
4869 IF(Q2EFF.GT.Q2THR) THEN
4870 NF=NF+1
4871 ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
4872 GOTO 110
4873 ENDIF
4874 ENDIF
4875 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
4876 PARU(117)=SQRT(ALAM2)
4877
4878C...Evaluate first or second order alpha_strong.
4879 B0=(33.-2.*NF)/6.
4880 ALGQ=LOG(Q2EFF/ALAM2)
4881 IF(MSTU(111).EQ.1) THEN
4882 ULALPS=PARU(2)/(B0*ALGQ)
4883 ELSE
4884 B1=(153.-19.*NF)/6.
4885 ULALPS=PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/(B0**2*ALGQ))
4886 ENDIF
4887 MSTU(118)=NF
4888 PARU(118)=ULALPS
4889
4890 RETURN
4891 END
4892
4893C*********************************************************************
4894
4895 FUNCTION ULANGL(X,Y)
4896
4897C...Purpose: to reconstruct an angle from given x and y coordinates.
4898 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4899 SAVE /LUDAT1A/
4900
4901 ULANGL=0.
4902 R=SQRT(X**2+Y**2)
4903 IF(R.LT.1E-20) RETURN
4904 IF(ABS(X)/R.LT.0.8) THEN
4905 ULANGL=SIGN(ACOS(X/R),Y)
4906 ELSE
4907 ULANGL=ASIN(Y/R)
4908 IF(X.LT.0..AND.ULANGL.GE.0.) THEN
4909 ULANGL=PARU(1)-ULANGL
4910 ELSEIF(X.LT.0.) THEN
4911 ULANGL=-PARU(1)-ULANGL
4912 ENDIF
4913 ENDIF
4914
4915 RETURN
4916 END
4917
4918C*********************************************************************
4919c$$$
4920c$$$ FUNCTION RLU(IDUM)
4921c$$$
4922c$$$C...Purpose: to generate random numbers uniformly distributed between
4923c$$$C...0 and 1, excluding the endpoints.
4924c$$$ COMMON/LUDATRA/MRLU(6),RRLU(100)
4925c$$$ SAVE /LUDATRA/
4926c$$$ EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
4927c$$$ &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
4928c$$$ &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
4929c$$$
4930c$$$C...Initialize generation from given seed.
4931c$$$ IDUM=IDUM
4932c$$$ IF(MRLU2.EQ.0) THEN
4933c$$$ IJ=MOD(MRLU1/30082,31329)
4934c$$$ KL=MOD(MRLU1,30082)
4935c$$$ I=MOD(IJ/177,177)+2
4936c$$$ J=MOD(IJ,177)+2
4937c$$$ K=MOD(KL/169,178)+1
4938c$$$ L=MOD(KL,169)
4939c$$$ DO 110 II=1,97
4940c$$$ S=0.
4941c$$$ T=0.5
4942c$$$ DO 100 JJ=1,24
4943c$$$ M=MOD(MOD(I*J,179)*K,179)
4944c$$$ I=J
4945c$$$ J=K
4946c$$$ K=M
4947c$$$ L=MOD(53*L+1,169)
4948c$$$ IF(MOD(L*M,64).GE.32) S=S+T
4949c$$$ 100 T=0.5*T
4950c$$$ 110 RRLU(II)=S
4951c$$$ TWOM24=1.
4952c$$$ DO 120 I24=1,24
4953c$$$ 120 TWOM24=0.5*TWOM24
4954c$$$ RRLU98=362436.*TWOM24
4955c$$$ RRLU99=7654321.*TWOM24
4956c$$$ RRLU00=16777213.*TWOM24
4957c$$$ MRLU2=1
4958c$$$ MRLU3=0
4959c$$$ MRLU4=97
4960c$$$ MRLU5=33
4961c$$$ ENDIF
4962c$$$
4963c$$$C...Generate next random number.
4964c$$$ 130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
4965c$$$ IF(RUNI.LT.0.) RUNI=RUNI+1.
4966c$$$ RRLU(MRLU4)=RUNI
4967c$$$ MRLU4=MRLU4-1
4968c$$$ IF(MRLU4.EQ.0) MRLU4=97
4969c$$$ MRLU5=MRLU5-1
4970c$$$ IF(MRLU5.EQ.0) MRLU5=97
4971c$$$ RRLU98=RRLU98-RRLU99
4972c$$$ IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
4973c$$$ RUNI=RUNI-RRLU98
4974c$$$ IF(RUNI.LT.0.) RUNI=RUNI+1.
4975c$$$ IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
4976c$$$
4977c$$$C...Update counters. Random number to output.
4978c$$$ MRLU3=MRLU3+1
4979c$$$ IF(MRLU3.EQ.1000000000) THEN
4980c$$$ MRLU2=MRLU2+1
4981c$$$ MRLU3=0
4982c$$$ ENDIF
4983c$$$ RLU=RUNI
4984c$$$
4985c$$$ RETURN
4986c$$$ END
4987
4988C*********************************************************************
4989
4990 SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)
4991
4992C...Purpose: to perform rotations and boosts.
4993 IMPLICIT DOUBLE PRECISION(D)
4994 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
4995 SAVE /LUJETSA/
4996 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4997 SAVE /LUDAT1A/
4998 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
4999
5000C...Find range of rotation/boost. Convert boost to double precision.
5001 IMIN=1
5002 IF(MSTU(1).GT.0) IMIN=MSTU(1)
5003 IMAX=N
5004 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5005 DBX=dble(BEX)
5006 DBY=dble(BEY)
5007 DBZ=dble(BEZ)
5008 GOTO 100
5009
5010C...Entry for specific range and double precision boost.
5011 ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
5012 IMIN=IMI
5013 IF(IMIN.LE.0) IMIN=1
5014 IMAX=IMA
5015 IF(IMAX.LE.0) IMAX=N
5016 DBX=DBEX
5017 DBY=DBEY
5018 DBZ=DBEZ
5019
5020C...Check range of rotation/boost.
5021 100 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5022 CALL LUERRM(11,'(LUROBO:) range outside LUJETSA memory')
5023 RETURN
5024 ENDIF
5025
5026C...Rotate, typically from z axis to direction (theta,phi).
5027 IF(THE**2+PHI**2.GT.1E-20) THEN
5028 ROT(1,1)=COS(THE)*COS(PHI)
5029 ROT(1,2)=-SIN(PHI)
5030 ROT(1,3)=SIN(THE)*COS(PHI)
5031 ROT(2,1)=COS(THE)*SIN(PHI)
5032 ROT(2,2)=COS(PHI)
5033 ROT(2,3)=SIN(THE)*SIN(PHI)
5034 ROT(3,1)=-SIN(THE)
5035 ROT(3,2)=0.
5036 ROT(3,3)=COS(THE)
5037 DO 130 I=IMIN,IMAX
5038 IF(K(I,1).LE.0) GOTO 130
5039 DO 110 J=1,3
5040 PR(J)=P(I,J)
5041 110 VR(J)=V(I,J)
5042 DO 120 J=1,3
5043 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5044 120 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
5045 130 CONTINUE
5046 ENDIF
5047
5048C...Boost, typically from rest to momentum/energy=beta.
5049 IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5050 DB=SQRT(DBX**2+DBY**2+DBZ**2)
5051 IF(DB.GT.0.99999999D0) THEN
5052C...Rescale boost vector if too close to unity.
5053 CALL LUERRM(3,'(LUROBO:) boost vector too large')
5054 DBX=DBX*(0.99999999D0/DB)
5055 DBY=DBY*(0.99999999D0/DB)
5056 DBZ=DBZ*(0.99999999D0/DB)
5057 DB=0.99999999D0
5058 ENDIF
5059 DGA=1D0/SQRT(1D0-DB**2)
5060 DO 150 I=IMIN,IMAX
5061 IF(K(I,1).LE.0) GOTO 150
5062 DO 140 J=1,4
5063 DP(J)=dble(P(I,J))
5064 140 DV(J)=dble(V(I,J))
5065 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5066 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5067 P(I,1)=sngl(DP(1)+DGABP*DBX)
5068 P(I,2)=sngl(DP(2)+DGABP*DBY)
5069 P(I,3)=sngl(DP(3)+DGABP*DBZ)
5070 P(I,4)=sngl(DGA*(DP(4)+DBP))
5071 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
5072 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
5073 V(I,1)=sngl(DV(1)+DGABV*DBX)
5074 V(I,2)=sngl(DV(2)+DGABV*DBY)
5075 V(I,3)=sngl(DV(3)+DGABV*DBZ)
5076 V(I,4)=sngl(DGA*(DV(4)+DBV))
5077 150 CONTINUE
5078 ENDIF
5079
5080 RETURN
5081 END
5082
5083C*********************************************************************
5084C THIS SUBROUTINE IS ONLY FOR THE USE OF HIJING TO ROTATE OR BOOST
5085C THE FOUR MOMENTUM ONLY
5086C*********************************************************************
5087
5088 SUBROUTINE HIROBO(THE,PHI,BEX,BEY,BEZ)
5089
5090C...Purpose: to perform rotations and boosts.
5091 IMPLICIT DOUBLE PRECISION(D)
5092 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
5093 SAVE /LUJETSA/
5094 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5095 SAVE /LUDAT1A/
5096 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5097
5098 DV(1)=DV(1)
5099 VR(1)=VR(1)
5100C...Find range of rotation/boost. Convert boost to double precision.
5101 IMIN=1
5102 IF(MSTU(1).GT.0) IMIN=MSTU(1)
5103 IMAX=N
5104 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5105 DBX=dble(BEX)
5106 DBY=dble(BEY)
5107 DBZ=dble(BEZ)
5108
5109C...Check range of rotation/boost.
5110 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5111 CALL LUERRM(11,'(LUROBO:) range outside LUJETSA memory')
5112 RETURN
5113 ENDIF
5114
5115C...Rotate, typically from z axis to direction (theta,phi).
5116 IF(THE**2+PHI**2.GT.1E-20) THEN
5117 ROT(1,1)=COS(THE)*COS(PHI)
5118 ROT(1,2)=-SIN(PHI)
5119 ROT(1,3)=SIN(THE)*COS(PHI)
5120 ROT(2,1)=COS(THE)*SIN(PHI)
5121 ROT(2,2)=COS(PHI)
5122 ROT(2,3)=SIN(THE)*SIN(PHI)
5123 ROT(3,1)=-SIN(THE)
5124 ROT(3,2)=0.
5125 ROT(3,3)=COS(THE)
5126 DO 130 I=IMIN,IMAX
5127 IF(K(I,1).LE.0) GOTO 130
5128 DO 110 J=1,3
5129 110 PR(J)=P(I,J)
5130 DO 120 J=1,3
5131 120 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5132 130 CONTINUE
5133 ENDIF
5134
5135C...Boost, typically from rest to momentum/energy=beta.
5136 IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5137 DB=SQRT(DBX**2+DBY**2+DBZ**2)
5138 IF(DB.GT.0.99999999D0) THEN
5139C...Rescale boost vector if too close to unity.
5140 CALL LUERRM(3,'(LUROBO:) boost vector too large')
5141 DBX=DBX*(0.99999999D0/DB)
5142 DBY=DBY*(0.99999999D0/DB)
5143 DBZ=DBZ*(0.99999999D0/DB)
5144 DB=0.99999999D0
5145 ENDIF
5146 DGA=1D0/SQRT(1D0-DB**2)
5147 DO 150 I=IMIN,IMAX
5148 IF(K(I,1).LE.0) GOTO 150
5149 DO 140 J=1,4
5150 140 DP(J)=dble(P(I,J))
5151 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5152 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5153 P(I,1)=sngl(DP(1)+DGABP*DBX)
5154 P(I,2)=sngl(DP(2)+DGABP*DBY)
5155 P(I,3)=sngl(DP(3)+DGABP*DBZ)
5156 P(I,4)=sngl(DGA*(DP(4)+DBP))
5157 150 CONTINUE
5158 ENDIF
5159
5160 RETURN
5161 END
5162
5163C*********************************************************************
5164
5165 SUBROUTINE LUEDIT(MEDIT)
5166
5167C...Purpose: to perform global manipulations on the event record,
5168C...in particular to exclude unstable or undetectable partons/particles.
5169 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
5170 SAVE /LUJETSA/
5171 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5172 SAVE /LUDAT1A/
5173 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5174 SAVE /LUDAT2A/
5175 DIMENSION NS(2),PTS(2),PLS(2)
5176
5177C...Remove unwanted partons/particles.
5178 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
5179 IMAX=N
5180 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5181 I1=MAX(1,MSTU(1))-1
5182 DO 110 I=MAX(1,MSTU(1)),IMAX
5183 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
5184 IF(MEDIT.EQ.1) THEN
5185 IF(K(I,1).GT.10) GOTO 110
5186 ELSEIF(MEDIT.EQ.2) THEN
5187 IF(K(I,1).GT.10) GOTO 110
5188 KC=LUCOMP(K(I,2))
5189 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
5190 & GOTO 110
5191 ELSEIF(MEDIT.EQ.3) THEN
5192 IF(K(I,1).GT.10) GOTO 110
5193 KC=LUCOMP(K(I,2))
5194 IF(KC.EQ.0) GOTO 110
5195 IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110
5196 ELSEIF(MEDIT.EQ.5) THEN
5197 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
5198 KC=LUCOMP(K(I,2))
5199 IF(KC.EQ.0) GOTO 110
5200 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
5201 ENDIF
5202
5203C...Pack remaining partons/particles. Origin no longer known.
5204 I1=I1+1
5205 DO 100 J=1,5
5206 K(I1,J)=K(I,J)
5207 P(I1,J)=P(I,J)
5208 100 V(I1,J)=V(I,J)
5209 K(I1,3)=0
5210 110 CONTINUE
5211 N=I1
5212
5213C...Selective removal of class of entries. New position of retained.
5214 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
5215 I1=0
5216 DO 120 I=1,N
5217 K(I,3)=MOD(K(I,3),MSTU(5))
5218 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
5219 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
5220 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
5221 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
5222 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
5223 & K(I,2).EQ.94)) GOTO 120
5224 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
5225 I1=I1+1
5226 K(I,3)=K(I,3)+MSTU(5)*I1
5227 120 CONTINUE
5228
5229C...Find new event history information and replace old.
5230 DO 140 I=1,N
5231 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
5232 ID=I
5233 130 IM=MOD(K(ID,3),MSTU(5))
5234 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
5235 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
5236 & K(IM,2).NE.94) THEN
5237 ID=IM
5238 GOTO 130
5239 ENDIF
5240 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
5241 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
5242 ID=IM
5243 GOTO 130
5244 ENDIF
5245 ENDIF
5246 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
5247 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
5248 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
5249 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
5250 & K(K(I,4),3)/MSTU(5)
5251 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
5252 & K(K(I,5),3)/MSTU(5)
5253 ELSE
5254 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
5255 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5256 KCD=MOD(K(I,4),MSTU(5))
5257 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5258 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5259 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
5260 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5261 KCD=MOD(K(I,5),MSTU(5))
5262 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5263 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5264 ENDIF
5265 140 CONTINUE
5266
5267C...Pack remaining entries.
5268 I1=0
5269 DO 160 I=1,N
5270 IF(K(I,3)/MSTU(5).EQ.0) GOTO 160
5271 I1=I1+1
5272 DO 150 J=1,5
5273 K(I1,J)=K(I,J)
5274 P(I1,J)=P(I,J)
5275 150 V(I1,J)=V(I,J)
5276 K(I1,3)=MOD(K(I1,3),MSTU(5))
5277 160 CONTINUE
5278 N=I1
5279
5280C...Save top entries at bottom of LUJETSA commonblock.
5281 ELSEIF(MEDIT.EQ.21) THEN
5282 IF(2*N.GE.MSTU(4)) THEN
5283 CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETSA')
5284 RETURN
5285 ENDIF
5286 DO 170 I=1,N
5287 DO 170 J=1,5
5288 K(MSTU(4)-I,J)=K(I,J)
5289 P(MSTU(4)-I,J)=P(I,J)
5290 170 V(MSTU(4)-I,J)=V(I,J)
5291 MSTU(32)=N
5292
5293C...Restore bottom entries of commonblock LUJETSA to top.
5294 ELSEIF(MEDIT.EQ.22) THEN
5295 DO 180 I=1,MSTU(32)
5296 DO 180 J=1,5
5297 K(I,J)=K(MSTU(4)-I,J)
5298 P(I,J)=P(MSTU(4)-I,J)
5299 180 V(I,J)=V(MSTU(4)-I,J)
5300 N=MSTU(32)
5301
5302C...Mark primary entries at top of commonblock LUJETSA as untreated.
5303 ELSEIF(MEDIT.EQ.23) THEN
5304 I1=0
5305 DO 190 I=1,N
5306 KH=K(I,3)
5307 IF(KH.GE.1) THEN
5308 IF(K(KH,1).GT.20) KH=0
5309 ENDIF
5310 IF(KH.NE.0) GOTO 200
5311 I1=I1+1
5312 190 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
5313 200 N=I1
5314
5315C...Place largest axis along z axis and second largest in xy plane.
5316 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
5317 CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),
5318 & P(MSTU(61),2)),0D0,0D0,0D0)
5319 CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),
5320 & P(MSTU(61),1)),0.,0D0,0D0,0D0)
5321 CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1),
5322 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
5323 IF(MEDIT.EQ.31) RETURN
5324
5325C...Rotate to put slim jet along +z axis.
5326 DO 210 IS=1,2
5327 NS(IS)=0
5328 PTS(IS)=0.
5329 210 PLS(IS)=0.
5330 DO 220 I=1,N
5331 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 220
5332 IF(MSTU(41).GE.2) THEN
5333 KC=LUCOMP(K(I,2))
5334 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5335 & KC.EQ.18) GOTO 220
5336 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5337 & GOTO 220
5338 ENDIF
5339 IS=int(2.-SIGN(0.5,P(I,3)))
5340 NS(IS)=NS(IS)+1
5341 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
5342 220 CONTINUE
5343 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
5344 & CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
5345
5346C...Rotate to put second largest jet into -z,+x quadrant.
5347 DO 230 I=1,N
5348 IF(P(I,3).GE.0.) GOTO 230
5349 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230
5350 IF(MSTU(41).GE.2) THEN
5351 KC=LUCOMP(K(I,2))
5352 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
5353 & KC.EQ.18) GOTO 230
5354 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
5355 & GOTO 230
5356 ENDIF
5357 IS=int(2.-SIGN(0.5,P(I,1)))
5358 PLS(IS)=PLS(IS)-P(I,3)
5359 230 CONTINUE
5360 IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
5361 & 0D0,0D0,0D0)
5362 ENDIF
5363
5364 RETURN
5365 END
5366
5367C*********************************************************************
5368
5369 SUBROUTINE LULIST(MLIST)
5370
5371C...Purpose: to give program heading, or list an event, or particle
5372C...data, or current parameter values.
5373 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
5374 SAVE /LUJETSA/
5375 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5376 SAVE /LUDAT1A/
5377 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5378 SAVE /LUDAT2A/
5379 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5380 SAVE /LUDAT3A/
5381 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4
5382 DIMENSION PS(6)
5383 DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
5384 &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/
5385
5386 CHMO(1)=CHMO(1)
5387C...Initialization printout: version number and date of last change.
5388C IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
5389C WRITE(MSTU(11),1000) MSTU(181),MSTU(182),MSTU(185),
5390C & CHMO(MSTU(184)),MSTU(183)
5391C MSTU(12)=0
5392C IF(MLIST.EQ.0) RETURN
5393C ENDIF
5394
5395C...List event data, including additional lines after N.
5396 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
5397 IF(MLIST.EQ.1) WRITE(MSTU(11),1100)
5398 IF(MLIST.EQ.2) WRITE(MSTU(11),1200)
5399 IF(MLIST.EQ.3) WRITE(MSTU(11),1300)
5400 LMX=12
5401 IF(MLIST.GE.2) LMX=16
5402 ISTR=0
5403 IMAX=N
5404 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5405 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
5406 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
5407
5408C...Get particle name, pad it and check it is not too long.
5409 CALL LUNAME(K(I,2),CHAP)
5410 LEN=0
5411 DO 100 LEM=1,16
5412 100 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
5413 MDL=(K(I,1)+19)/10
5414 LDL=0
5415 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
5416 CHAC=CHAP
5417 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
5418 ELSE
5419 LDL=1
5420 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
5421 IF(LEN.EQ.0) THEN
5422 CHAC=CHDL(MDL)(1:2*LDL)//' '
5423 ELSE
5424 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
5425 & CHDL(MDL)(LDL+1:2*LDL)//' '
5426 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
5427 ENDIF
5428 ENDIF
5429
5430C...Add information on string connection.
5431 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
5432 & THEN
5433 KC=LUCOMP(K(I,2))
5434 KCC=0
5435 IF(KC.NE.0) KCC=KCHG(KC,2)
5436 IF(KCC.NE.0.AND.ISTR.EQ.0) THEN
5437 ISTR=1
5438 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
5439 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
5440 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
5441 ELSEIF(KCC.NE.0) THEN
5442 ISTR=0
5443 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
5444 ENDIF
5445 ENDIF
5446
5447C...Write data for particle/jet.
5448 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
5449 WRITE(MSTU(11),1400) I,CHAC(1:12),(K(I,J1),J1=1,3),
5450 & (P(I,J2),J2=1,5)
5451 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
5452 WRITE(MSTU(11),1500) I,CHAC(1:12),(K(I,J1),J1=1,3),
5453 & (P(I,J2),J2=1,5)
5454 ELSEIF(MLIST.EQ.1) THEN
5455 WRITE(MSTU(11),1600) I,CHAC(1:12),(K(I,J1),J1=1,3),
5456 & (P(I,J2),J2=1,5)
5457 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
5458 & K(I,1).EQ.14)) THEN
5459 WRITE(MSTU(11),1700) I,CHAC,(K(I,J1),J1=1,3),
5460 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
5461 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
5462 & (P(I,J2),J2=1,5)
5463 ELSE
5464 WRITE(MSTU(11),1800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
5465 ENDIF
5466 IF(MLIST.EQ.3) WRITE(MSTU(11),1900) (V(I,J),J=1,5)
5467
5468C...Insert extra separator lines specified by user.
5469 IF(MSTU(70).GE.1) THEN
5470 ISEP=0
5471 DO 110 J=1,MIN(10,MSTU(70))
5472 110 IF(I.EQ.MSTU(70+J)) ISEP=1
5473 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),2000)
5474 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),2100)
5475 ENDIF
5476 120 CONTINUE
5477
5478C...Sum of charges and momenta.
5479 DO 130 J=1,6
5480 130 PS(J)=PLU(0,J)
5481 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
5482 WRITE(MSTU(11),2200) PS(6),(PS(J),J=1,5)
5483 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
5484 WRITE(MSTU(11),2300) PS(6),(PS(J),J=1,5)
5485 ELSEIF(MLIST.EQ.1) THEN
5486 WRITE(MSTU(11),2400) PS(6),(PS(J),J=1,5)
5487 ELSE
5488 WRITE(MSTU(11),2500) PS(6),(PS(J),J=1,5)
5489 ENDIF
5490
5491C...Give simple list of KF codes defined in program.
5492 ELSEIF(MLIST.EQ.11) THEN
5493 WRITE(MSTU(11),2600)
5494 DO 140 KF=1,40
5495 CALL LUNAME(KF,CHAP)
5496 CALL LUNAME(-KF,CHAN)
5497 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),2700) KF,CHAP
5498 140 IF(CHAN.NE.' ') WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5499 DO 150 KFLS=1,3,2
5500 DO 150 KFLA=1,8
5501 DO 150 KFLB=1,KFLA-(3-KFLS)/2
5502 KF=1000*KFLA+100*KFLB+KFLS
5503 CALL LUNAME(KF,CHAP)
5504 CALL LUNAME(-KF,CHAN)
5505 150 WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5506 DO 170 KMUL=0,5
5507 KFLS=3
5508 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
5509 IF(KMUL.EQ.5) KFLS=5
5510 KFLR=0
5511 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
5512 IF(KMUL.EQ.4) KFLR=2
5513 DO 170 KFLB=1,8
5514 DO 160 KFLC=1,KFLB-1
5515 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
5516 CALL LUNAME(KF,CHAP)
5517 CALL LUNAME(-KF,CHAN)
5518 160 WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5519 KF=10000*KFLR+110*KFLB+KFLS
5520 CALL LUNAME(KF,CHAP)
5521 170 WRITE(MSTU(11),2700) KF,CHAP
5522 KF=130
5523 CALL LUNAME(KF,CHAP)
5524 WRITE(MSTU(11),2700) KF,CHAP
5525 KF=310
5526 CALL LUNAME(KF,CHAP)
5527 WRITE(MSTU(11),2700) KF,CHAP
5528 DO 190 KFLSP=1,3
5529 KFLS=2+2*(KFLSP/3)
5530 DO 190 KFLA=1,8
5531 DO 190 KFLB=1,KFLA
5532 DO 180 KFLC=1,KFLB
5533 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180
5534 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180
5535 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
5536 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
5537 CALL LUNAME(KF,CHAP)
5538 CALL LUNAME(-KF,CHAN)
5539 WRITE(MSTU(11),2700) KF,CHAP,-KF,CHAN
5540 180 CONTINUE
5541 190 CONTINUE
5542
5543C...List parton/particle data table. Check whether to be listed.
5544 ELSEIF(MLIST.EQ.12) THEN
5545 WRITE(MSTU(11),2800)
5546 MSTJ24=MSTJ(24)
5547 MSTJ(24)=0
5548 KFMAX=20883
5549 IF(MSTU(2).NE.0) KFMAX=MSTU(2)
5550 DO 220 KF=MAX(1,MSTU(1)),KFMAX
5551 KC=LUCOMP(KF)
5552 IF(KC.EQ.0) GOTO 220
5553 IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220
5554 IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
5555 & MOD(KF/100,10)).GT.MSTU(14)) GOTO 220
5556
5557C...Find particle name and mass. Print information.
5558 CALL LUNAME(KF,CHAP)
5559 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220
5560 CALL LUNAME(-KF,CHAN)
5561 PM=ULMASS(KF)
5562 WRITE(MSTU(11),2900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
5563 & KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
5564
5565C...Particle decay: channel number, branching ration, matrix element,
5566C...decay products.
5567 IF(KF.GT.100.AND.KC.LE.100) GOTO 220
5568 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
5569 DO 200 J=1,5
5570 200 CALL LUNAME(KFDP(IDC,J),CHAD(J))
5571 210 WRITE(MSTU(11),3000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
5572 & (CHAD(J),J=1,5)
5573 220 CONTINUE
5574 MSTJ(24)=MSTJ24
5575
5576C...List parameter value table.
5577 ELSEIF(MLIST.EQ.13) THEN
5578 WRITE(MSTU(11),3100)
5579 DO 230 I=1,200
5580 230 WRITE(MSTU(11),3200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
5581 ENDIF
5582
5583C...Format statements for output on unit MSTU(11) (by default 6).
5584clin 1000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/
5585clin &20X,'** Last date of change: ',I2,1X,A3,1X,I4,' **'/)
5586 1100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
5587 &5X,'KF orig p_x p_y p_z E m'/)
5588 1200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
5589 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
5590 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
5591 1300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
5592 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
5593 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
5594 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
5595 1400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
5596 1500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
5597 1600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
5598 1700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
5599 1800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
5600 1900 FORMAT(66X,5(1X,F12.3))
5601 2000 FORMAT(1X,78('='))
5602 2100 FORMAT(1X,130('='))
5603 2200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
5604 2300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
5605 2400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
5606 2500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
5607 &5F13.5)
5608 2600 FORMAT(///20X,'List of KF codes in program'/)
5609 2700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
5610 2800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
5611 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
5612 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
5613 &1X,'ME',3X,'Br.rat.',4X,'decay products')
5614 2900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
5615 &2X,F12.5,3X,I2)
5616 3000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
5617 3100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
5618 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
5619 3200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
5620
5621 RETURN
5622 END
5623
5624C*********************************************************************
5625
5626 FUNCTION PLU(I,J)
5627
5628C...Purpose: to provide various real-valued event related data.
5629 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
5630 SAVE /LUJETSA/
5631 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5632 SAVE /LUDAT1A/
5633 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5634 SAVE /LUDAT2A/
5635 DIMENSION PSUM(4)
5636
5637C...Set default value. For I = 0 sum of momenta or charges,
5638C...or invariant mass of system.
5639 PLU=0.
5640 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
5641 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
5642 DO 100 I1=1,N
5643 100 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)
5644 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
5645 DO 110 J1=1,4
5646 PSUM(J1)=0.
5647 DO 110 I1=1,N
5648 110 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
5649 PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
5650 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
5651 DO 120 I1=1,N
5652 120 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.
5653 ELSEIF(I.EQ.0) THEN
5654
5655C...Direct readout of P matrix.
5656 ELSEIF(J.LE.5) THEN
5657 PLU=P(I,J)
5658
5659C...Charge, total momentum, transverse momentum, transverse mass.
5660 ELSEIF(J.LE.12) THEN
5661 IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.
5662 IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2
5663 IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2
5664 IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2
5665 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)
5666
5667C...Theta and phi angle in radians or degrees.
5668 ELSEIF(J.LE.16) THEN
5669 IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
5670 IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))
5671 IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1)
5672
5673C...True rapidity, rapidity with pion mass, pseudorapidity.
5674 ELSEIF(J.LE.19) THEN
5675 PMR=0.
5676 IF(J.EQ.17) PMR=P(I,5)
5677 IF(J.EQ.18) PMR=ULMASS(211)
5678 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
5679 PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
5680 & 1E20)),P(I,3))
5681
5682C...Energy and momentum fractions (only to be used in CM frame).
5683 ELSEIF(J.LE.25) THEN
5684 IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
5685 IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)
5686 IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
5687 IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)
5688 IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)
5689 IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)
5690 ENDIF
5691
5692 RETURN
5693 END
5694
5695C*********************************************************************
5696
5697 BLOCK DATA LUDATA
5698
5699C...Purpose: to give default values to parameters and particle and
5700C...decay data.
5701 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5702 SAVE /LUDAT1A/
5703 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5704 SAVE /LUDAT2A/
5705 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
5706 SAVE /LUDAT3A/
5707 COMMON/LUDAT4A/CHAF(500)
5708 CHARACTER CHAF*8
5709 SAVE /LUDAT4A/
5710 COMMON/LUDATRA/MRLU(6),RRLU(100)
5711 SAVE /LUDATRA/
5712
5713C...LUDAT1A, containing status codes and most parameters.
5714 DATA MSTU/
5715 & 0, 0, 0, 9000,10000, 500, 2000, 0, 0, 2,
5716 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
5717 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
5718 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5719 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
5720 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
5721 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5722 7 40*0,
5723 1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
5724 2 60*0,
5725 8 7, 2, 1989, 11, 25, 0, 0, 0, 0, 0,
5726 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
5727 DATA PARU/
5728 & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
5729 1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
5730 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5731 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5732 4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
5733 5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
5734 6 40*0.,
5735 & 0.0072974, 0.230, 0., 0., 0., 0., 0., 0., 0., 0.,
5736 1 0.20, 0.25, 1.0, 4.0, 0., 0., 0., 0., 0., 0.,
5737 2 1.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5738 3 70*0./
5739 DATA MSTJ/
5740 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
5741 1 1, 2, 0, 1, 0, 0, 0, 0, 0, 0,
5742 2 2, 1, 1, 2, 1, 0, 0, 0, 0, 0,
5743 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5744 4 1, 2, 4, 2, 5, 0, 1, 0, 0, 0,
5745 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
5746 6 40*0,
5747 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 1,
5748 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
5749 2 80*0/
5750 DATA PARJ/
5751 & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
5752 1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
5753 2 0.35, 1.0, 0., 0., 0., 0., 0., 0., 0., 0.,
5754 3 0.10, 1.0, 0.8, 1.5, 0.8, 2.0, 0.2, 2.5, 0.6, 2.5,
5755 4 0.5, 0.9, 0.5, 0.9, 0.5, 0., 0., 0., 0., 0.,
5756 5 0.77, 0.77, 0.77, 0., 0., 0., 0., 0., 1.0, 0.,
5757 6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
5758 7 10., 1000., 100., 1000., 0., 0., 0., 0., 0., 0.,
5759 8 0.4, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
5760 9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
5761 & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5762 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5763 2 1.5, 0.5, 91.2, 2.40, 0.02, 2.0, 1.0, 0.25,0.002, 0.,
5764 3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
5765 4 60*0./
5766
5767C...LUDAT2A, with particle data and flavour treatment parameters.
5768 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
5769 &-3,0,-3,6*0,3,9*0,3,2*0,3,46*0,2,-1,2,-1,2,3,11*0,3,0,2*3,
5770 &0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,
5771 &3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,72*0,3,0,3,28*0,
5772 &3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,3,5*0,-3,0,3,-3,0,-3,
5773 &4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,-3,0,3,-3,0,-3,114*0/
5774 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,68*0,-1,410*0/
5775 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,2*0,1,
5776 &41*0,1,0,7*1,10*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,
5777 &11*0,9*1,71*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,
5778 &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
5779 DATA (PMAS(I,1),I= 1, 500)/.0099,.0056,.199,1.35,5.,90.,120.,
5780 &200.,2*0.,.00051,0.,.1057,0.,1.7841,0.,60.,5*0.,91.2,80.,15.,
5781 &6*0.,300.,900.,600.,300.,900.,300.,2*0.,5000.,60*0.,.1396,.4977,
5782 &.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,.135,.5488,
5783 &.9575,2.9796,9.4,117.99,238.,397.,2*0.,.7669,.8962,.8921,
5784 &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,.77,.782,1.0194,3.0969,
5785 &9.4603,118.,238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,
5786 &0.,1.233,1.17,1.41,3.46,9.875,118.42,238.42,397.42,2*0.,
5787 &.983,2*1.429,2*2.272,2.46,2*5.68,5.92,0.,.983,1.,1.4,3.4151,
5788 &9.8598,118.4,238.4,397.4,2*0.,1.26,2*1.401,2*2.372,
5789 &2.56,2*5.78,6.02,0.,1.26,1.283,1.422,3.5106,9.8919,118.5,238.5,
5790 &397.5,2*0.,1.318,2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274,
5791 &1.525,3.5563,9.9132,118.45,238.45,397.45,2*0.,2*.4977,
5792 &83*0.,1.1156,5*0.,2.2849,0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,
5793 &.9396,.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.454,
5794 &2.4529,2.4522,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,
5795 &1.233,1.232,1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,
5796 &2*2.63,2.8,4*0.,3*5.81,2*5.97,6.13,114*0./
5797 DATA (PMAS(I,2),I= 1, 500)/22*0.,2.4,2.3,88*0.,.0002,.001,
5798 &6*0.,.149,.0505,.0513,7*0.,.153,.0085,.0044,7*0.,.15,2*.09,2*.06,
5799 &.04,3*.1,0.,.15,.335,.08,2*.01,5*0.,.057,2*.287,2*.06,.04,3*.1,
5800 &0.,.057,0.,.25,.0135,6*0.,.4,2*.184,2*.06,.04,3*.1,0.,.4,.025,
5801 &.055,.0135,6*0.,.11,.115,.099,2*.06,4*.1,0.,.11,.185,.076,.0026,
5802 &146*0.,4*.115,.039,2*.036,.0099,.0091,131*0./
5803 DATA (PMAS(I,3),I= 1, 500)/22*0.,2*20.,88*0.,.002,.005,6*0.,.4,
5804 &2*.2,7*0.,.4,.1,.015,7*0.,.25,2*.01,3*.08,2*.2,.12,0.,.25,.2,
5805 &.001,2*.02,5*0.,.05,2*.4,3*.08,2*.2,.12,0.,.05,0.,.35,.05,6*0.,
5806 &3*.3,2*.08,.06,2*.2,.12,0.,.3,.05,.025,.001,6*0.,.25,4*.12,4*.2,
5807 &0.,.25,.17,.2,.01,146*0.,4*.14,.04,2*.035,2*.05,131*0./
5808 DATA (PMAS(I,4),I= 1, 500)/12*0.,658650.,0.,.091,68*0.,.1,.43,
5809 &15*0.,7803.,0.,3709.,.32,.128,.131,3*.393,84*0.,.004,26*0.,
5810 &15540.,26.75,83*0.,78.88,5*0.,.054,0.,2*.13,6*0.,.393,0.,2*.393,
5811 &9*0.,44.3,0.,24.,49.1,86.9,6*0.,.13,9*0.,.393,13*0.,24.6,130*0./
5812 DATA PARF/
5813 & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
5814 1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5815 2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5816 3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5817 4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5818 5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
5819 6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
5820 7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
5821 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5822 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
5823 & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
5824 1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
5825 2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
5826 3 1870*0./
5827 DATA ((VCKM(I,J),J=1,4),I=1,4)/
5828 1 0.95150, 0.04847, 0.00003, 0.00000,
5829 2 0.04847, 0.94936, 0.00217, 0.00000,
5830 3 0.00003, 0.00217, 0.99780, 0.00000,
5831 4 0.00000, 0.00000, 0.00000, 1.00000/
5832
5833C...LUDAT3A, with particle decay parameters and data.
5834 DATA (MDCY(I,1),I= 1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,4*0,1,2*0,
5835 &1,42*0,7*1,12*0,1,0,6*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,2*0,
5836 &9*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,3*0,1,83*0,1,5*0,1,0,2*1,
5837 &6*0,1,0,2*1,9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
5838 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,
5839 &76,78,118,120,125,2*0,127,136,149,166,186,6*0,203,4*0,219,2*0,
5840 &227,42*0,236,237,241,250,252,254,256,11*0,276,277,279,285,406,
5841 &574,606,607,608,0,609,611,617,623,624,625,626,627,2*0,628,629,
5842 &632,635,638,640,641,642,643,0,644,645,650,658,661,670,685,686,
5843 &2*0,687,688,693,698,700,702,703,705,707,0,709,710,713,717,718,
5844 &719,721,722,2*0,723,726,728,730,734,738,740,744,748,0,752,755,
5845 &759,763,765,767,769,770,2*0,771,773,775,777,779,781,784,786,788,
5846 &0,791,793,806,810,812,814,816,817,2*0,818,824,835,846,854,862,
5847 &867,875,883,0,888,895,903,905,907,909,911,912,2*0,913,921,83*0,
5848 &923,5*0,927,0,1001,1002,6*0,1003,0,1004,1005,9*0,1006,1008,1009,
5849 &1012,1013,0,1015,1016,1017,1018,1019,1020,4*0,1021,1022,1023,
5850 &1024,1025,1026,4*0,1027,1028,1031,1034,1035,1038,1041,1044,1046,
5851 &1048,1052,1053,1054,1055,1057,1059,4*0,1060,1061,1062,1063,1064,
5852 &1065,114*0/
5853 DATA (MDCY(I,3),I= 1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,13,
5854 &17,20,17,6*0,16,4*0,8,2*0,9,42*0,1,4,9,3*2,20,11*0,1,2,6,121,168,
5855 &32,3*1,0,2,2*6,5*1,2*0,1,3*3,2,4*1,0,1,5,8,3,9,15,2*1,2*0,1,2*5,
5856 &2*2,1,3*2,0,1,3,4,2*1,2,2*1,2*0,3,2*2,2*4,2,3*4,0,3,2*4,3*2,2*1,
5857 &2*0,5*2,3,2*2,3,0,2,13,4,3*2,2*1,2*0,6,2*11,2*8,5,2*8,5,0,7,8,
5858 &4*2,2*1,2*0,8,2,83*0,4,5*0,74,0,2*1,6*0,1,0,2*1,9*0,2,1,3,1,2,0,
5859 &6*1,4*0,6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
5860 DATA (MDME(I,1),I= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
5861 &7*1,-1,85*1,2*-1,7*1,2*-1,3*1,2*-1,6*1,2*-1,6*1,3*-1,3*1,-1,3*1,
5862 &-1,3*1,5*-1,3*1,-1,6*1,2*-1,3*1,-1,11*1,2*-1,6*1,2*-1,3*1,-1,3*1,
5863 &-1,4*1,2*-1,2*1,-1,488*1,2*0,1275*1/
5864 DATA (MDME(I,2),I= 1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,
5865 &23*41,6*102,45,28*102,8*32,9*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
5866 &8*0,4*32,4*0,6*32,3*0,12,2*42,2*11,9*42,6*45,20*46,7*0,34*42,
5867 &86*0,2*25,26,24*42,142*0,25,26,0,10*42,19*0,2*13,3*85,0,2,4*0,2,
5868 &8*0,2*32,87,88,3*3,0,2*3,0,2*3,0,3,5*0,3,1,0,3,2*0,2*3,3*0,1,4*0,
5869 &12,3*0,4*32,2*4,6*0,5*32,2*4,2*45,87,88,30*0,12,32,0,32,87,88,
5870 &41*0,12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,
5871 &32,87,88,2*0,4*42,8*0,14*42,50*0,10*13,2*84,3*85,14*0,84,5*0,85,
5872 &974*0/
5873 DATA (BRAT(I) ,I= 1, 525)/70*0.,1.,6*0.,2*.177,.108,.225,.003,
5874 &.06,.02,.025,.013,2*.004,.007,.014,2*.002,2*.001,.054,.014,.016,
5875 &.005,2*.012,5*.006,.002,2*.001,5*.002,6*0.,1.,28*0.,.143,.111,
5876 &.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,3*0.,.25,.01,
5877 &2*0.,.01,.25,4*0.,.24,5*0.,3*.08,3*0.,.01,.08,.82,5*0.,.09,6*0.,
5878 &.143,.111,.143,.111,.143,.085,2*0.,.03,.058,.03,.058,.03,.058,
5879 &4*0.,1.,5*0.,4*.215,2*0.,2*.07,0.,1.,2*.08,.76,.08,2*.112,.05,
5880 &.476,.08,.14,.01,.015,.005,1.,0.,1.,0.,1.,0.,.25,.01,2*0.,.01,
5881 &.25,4*0.,.24,5*0.,3*.08,0.,1.,2*.5,.635,.212,.056,.017,.048,.032,
5882 &.035,.03,2*.015,.044,2*.022,9*.001,.035,.03,2*.015,.044,2*.022,
5883 &9*.001,.028,.017,.066,.02,.008,2*.006,.003,.001,2*.002,.003,.001,
5884 &2*.002,.005,.002,.005,.006,.004,.012,2*.005,.008,2*.005,.037,
5885 &.004,.067,2*.01,2*.001,3*.002,.003,8*.002,.005,4*.004,.015,.005,
5886 &.027,2*.005,.007,.014,.007,.01,.008,.012,.015,11*.002,3*.004,
5887 &.002,.004,6*.002,2*.004,.005,.011,.005,.015,.02,2*.01,3*.004,
5888 &5*.002,.015,.02,2*.01,3*.004,5*.002,.038,.048,.082,.06,.028,.021,
5889 &2*.005,2*.002,.005,.018,.005,.01,.008,.005,3*.004,.001,3*.003,
5890 &.001,2*.002,.003,2*.002,2*.001,.002,.001,.002,.001,.005,4*.003,
5891 &.001,2*.002,.003,2*.001,.013,.03,.058,.055,3*.003,2*.01,.007,
5892 &.019,4*.005,.015,3*.005,8*.002,3*.001,.002,2*.001,.003,16*.001/
5893 DATA (BRAT(I) ,I= 526, 893)/.019,2*.003,.002,.005,.004,.008,
5894 &.003,.006,.003,.01,5*.002,2*.001,2*.002,11*.001,.002,14*.001,
5895 &.018,.005,.01,2*.015,.017,4*.015,.017,3*.015,.025,.08,2*.025,.04,
5896 &.001,2*.005,.02,.04,2*.06,.04,.01,4*.005,.25,.115,3*1.,.988,.012,
5897 &.389,.319,.237,.049,.005,.001,.441,.205,.301,.03,.022,.001,6*1.,
5898 &.665,.333,.002,.666,.333,.001,.49,.34,.17,.52,.48,5*1.,.893,.08,
5899 &.017,2*.005,.495,.343,3*.043,.019,.013,.001,2*.069,.862,3*.027,
5900 &.015,.045,.015,.045,.77,.029,6*.02,5*.05,.115,.015,.5,0.,3*1.,
5901 &.28,.14,.313,.157,.11,.28,.14,.313,.157,.11,.667,.333,.667,.333,
5902 &1.,.667,.333,.667,.333,2*.5,1.,.333,.334,.333,4*.25,2*1.,.3,.7,
5903 &2*1.,.8,2*.1,.667,.333,.667,.333,.6,.3,.067,.033,.6,.3,.067,.033,
5904 &2*.5,.6,.3,.067,.033,.6,.3,.067,.033,2*.4,2*.1,.8,2*.1,.52,.26,
5905 &2*.11,.62,.31,2*.035,.007,.993,.02,.98,.3,.7,2*1.,2*.5,.667,.333,
5906 &.667,.333,.667,.333,.667,.333,2*.35,.3,.667,.333,.667,.333,2*.35,
5907 &.3,2*.5,3*.14,.1,.05,4*.08,.028,.027,.028,.027,4*.25,.273,.727,
5908 &.35,.65,.3,.7,2*1.,2*.35,.144,.105,.048,.003,.332,.166,.168,.084,
5909 &.086,.043,.059,2*.029,2*.002,.332,.166,.168,.084,.086,.043,.059,
5910 &2*.029,2*.002,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,.16,.08,.13,
5911 &.06,.08,.04,2*.4,.1,2*.05,.3,.15,.16,.08,.13,.06,.08,.04,.3,.15,
5912 &.16,.08,.13,.06,.08,.04,2*.4,.1,2*.05,2*.35,.144,.105,2*.024/
5913 DATA (BRAT(I) ,I= 894,2000)/.003,.573,.287,.063,.028,2*.021,
5914 &.004,.003,2*.5,.15,.85,.22,.78,.3,.7,2*1.,.217,.124,2*.193,
5915 &2*.135,.002,.001,.686,.314,.641,.357,2*.001,.018,2*.005,.003,
5916 &.002,2*.006,.018,2*.005,.003,.002,2*.006,.005,.025,.015,.006,
5917 &2*.005,.004,.005,5*.004,2*.002,2*.004,.003,.002,2*.003,3*.002,
5918 &2*.001,.002,2*.001,2*.002,5*.001,4*.003,2*.005,2*.002,2*.001,
5919 &2*.002,2*.001,.255,.057,2*.035,.15,2*.075,.03,2*.015,5*1.,.999,
5920 &.001,1.,.516,.483,.001,1.,.995,.005,13*1.,.331,.663,.006,.663,
5921 &.331,.006,1.,.88,2*.06,.88,2*.06,.88,2*.06,.667,2*.333,.667,.676,
5922 &.234,.085,.005,3*1.,4*.5,7*1.,935*0./
5923 DATA (KFDP(I,1),I= 1, 499)/21,22,23,4*-24,25,21,22,23,4*24,25,
5924 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
5925 &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,
5926 &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,
5927 &23,-24,25,23,24,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,
5928 &37,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,37,4*-1,4*-3,4*-5,
5929 &4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1,
5930 &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,-1,-3,-5,-7,-11,-13,-15,
5931 &-17,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,
5932 &-4,2*89,2*-89,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
5933 &310,-13,3*211,12,14,16*-11,16*-13,-311,-313,-311,-313,-311,-313,
5934 &-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,-313,2*-311,
5935 &-313,3*-311,-321,-323,-321,2*211,2*213,-213,113,3*213,3*211,
5936 &2*213,2*-311,-313,-321,2*-311,-313,-311,-313,4*-311,-321,-323,
5937 &2*-321,3*211,213,2*211,213,5*211,213,4*211,3*213,211,213,321,311,
5938 &3,2*2,12*-11,12*-13,-321,-323,-321,-323,-311,-313,-311,-313,-311,
5939 &-313,-311,-313,-311,-313,-311,-321,-323,-321,-323,211,213,211,
5940 &213,111,221,331,113,223,333,221,331,113,223,113,223,113,223,333,
5941 &223,333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321,
5942 &-323,-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321/
5943 DATA (KFDP(I,1),I= 500, 873)/-323,2*-321,-311,2*333,211,213,
5944 &2*211,2*213,4*211,10*111,-321,-323,5*-321,-323,2*-321,-311,-313,
5945 &4*-311,-313,4*-311,-321,-323,2*-321,-323,-321,-313,-311,-313,
5946 &-311,211,213,2*211,213,4*211,111,221,113,223,113,223,2*3,-15,
5947 &5*-11,5*-13,221,331,333,221,331,333,211,213,211,213,321,323,321,
5948 &323,2212,221,331,333,221,2*2,3*0,3*22,111,211,2*22,2*211,111,
5949 &3*22,111,3*21,2*0,211,321,3*311,2*321,421,2*411,2*421,431,511,
5950 &521,531,2*211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,
5951 &82,11,13,15,1,2,3,4,21,22,11,12,13,14,15,16,1,2,3,4,5,21,22,2*89,
5952 &2*0,223,321,311,323,313,2*311,321,313,323,321,421,2*411,421,433,
5953 &521,2*511,521,523,513,223,213,113,-213,313,-313,323,-323,82,21,
5954 &663,21,2*0,221,213,113,321,2*311,321,421,411,423,413,411,421,413,
5955 &423,431,433,521,511,523,513,511,521,513,523,521,511,531,533,221,
5956 &213,-213,211,111,321,130,211,111,321,130,443,82,553,21,663,21,
5957 &2*0,113,213,323,2*313,323,423,2*413,423,421,411,433,523,2*513,
5958 &523,521,511,533,213,-213,10211,10111,-10211,2*221,213,2*113,-213,
5959 &2*321,2*311,313,-313,323,-323,443,82,553,21,663,21,2*0,213,113,
5960 &221,223,321,211,321,311,323,313,323,313,321,5*311,321,313,323,
5961 &313,323,311,4*321,421,411,423,413,423,413,421,2*411,421,413,423,
5962 &413,423,411,2*421,411,433,2*431,521,511,523,513,523,513,521/
5963 DATA (KFDP(I,1),I= 874,2000)/2*511,521,513,523,513,523,511,2*521,
5964 &511,533,2*531,213,-213,221,223,321,130,111,211,111,2*211,321,130,
5965 &221,111,321,130,443,82,553,21,663,21,2*0,111,211,-12,12,-14,14,
5966 &211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
5967 &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,5*2212,
5968 &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
5969 &2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,
5970 &4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,
5971 &3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,
5972 &3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,
5973 &935*0/
5974 DATA (KFDP(I,2),I= 1, 496)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
5975 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,3*7,2,4,6,8,7,
5976 &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211,
5977 &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,
5978 &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
5979 &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2,
5980 &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-37,-1,-2,-3,-4,-5,-6,-7,-8,
5981 &-11,-12,-13,-14,-15,-16,-17,-18,-37,2,4,6,8,2,4,6,8,2,4,6,8,2,4,
5982 &6,8,12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,
5983 &2*23,-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
5984 &2,4,6,8,12,14,16,18,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,
5985 &-3,11,13,15,1,4,3,4,1,3,5,3,6,4,7,5,2,4,6,8,2,4,6,8,2,4,6,8,2,4,
5986 &6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,16*14,2*211,
5987 &2*213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,211,
5988 &213,2*211,213,7*211,213,211,111,211,111,2*211,-213,213,2*113,223,
5989 &2*113,221,321,2*311,321,313,4*211,213,113,213,-213,2*211,213,113,
5990 &111,221,331,111,113,223,4*113,223,6*211,213,4*211,-321,-311,3*-1,
5991 &12*12,12*14,2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,
5992 &2*323,2*-211,2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,
5993 &113,111,2*211,213,6*211,321,2*211,213,211,2*111,113,2*223,2*321/
5994 DATA (KFDP(I,2),I= 497, 863)/323,321,2*311,313,2*311,111,211,
5995 &2*-211,-213,-211,-213,-211,-213,3*-211,5*111,2*113,223,113,223,
5996 &2*211,213,5*211,213,3*211,213,2*211,2*111,221,113,223,3*321,323,
5997 &2*321,323,311,313,311,313,3*211,2*-211,-213,3*-211,4*111,2*113,
5998 &2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,2*-311,2*-313,-2112,
5999 &3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,2*-211,111,113,223,
6000 &22,111,3*21,2*0,111,-211,111,22,211,111,22,211,111,22,111,5*22,
6001 &2*-211,111,-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,
6002 &-11,-13,-15,-1,-2,-3,-4,2*21,-11,-12,-13,-14,-15,-16,-1,-2,-3,-4,
6003 &-5,2*21,5,3,2*0,211,-213,113,-211,111,223,211,111,211,111,223,
6004 &211,111,-211,2*111,-211,111,211,111,-321,-311,111,-211,111,211,
6005 &-311,311,-321,321,-82,21,22,21,2*0,211,111,211,-211,111,211,111,
6006 &211,111,211,111,-211,111,-211,3*111,-211,111,-211,111,211,111,
6007 &211,111,-321,-311,3*111,-211,211,-211,111,-321,310,-211,111,-321,
6008 &310,22,-82,22,21,22,21,2*0,211,111,-211,111,211,111,211,111,-211,
6009 &111,321,311,111,-211,111,211,111,-321,-311,111,-211,211,-211,111,
6010 &2*211,111,-211,211,111,211,-321,2*-311,-321,-311,311,-321,321,22,
6011 &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211,
6012 &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211,
6013 &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311/
6014 DATA (KFDP(I,2),I= 864,2000)/2*111,211,-211,111,-211,111,-211,
6015 &211,-211,2*211,111,211,111,4*211,-321,-311,2*111,211,-211,211,
6016 &111,211,-321,310,22,-211,111,2*-211,-321,310,221,111,-321,310,22,
6017 &-82,22,21,22,21,2*0,111,-211,11,-11,13,-13,-211,111,-211,111,
6018 &-211,111,22,11,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,
6019 &211,213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,
6020 &-211,-213,111,221,331,113,223,111,221,331,113,223,211,213,211,
6021 &213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
6022 &2*3201,2203,2101,2103,5*0,-211,11,22,111,211,22,-211,111,22,-211,
6023 &111,211,2*22,0,-211,111,211,2*22,0,2*-211,111,22,111,211,22,211,
6024 &2*-211,2*111,-211,2*211,111,211,-211,2*111,211,-321,-211,111,11,
6025 &-211,111,211,111,22,111,2*22,-211,111,211,3*22,935*0/
6026 DATA (KFDP(I,3),I= 1, 918)/70*0,14,6*0,2*16,2*0,5*111,310,130,
6027 &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,
6028 &221,113,2*213,-213,123*0,4*3,4*4,1,4,3,2*2,6*81,25*0,-211,3*111,
6029 &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
6030 &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
6031 &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211,
6032 &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,
6033 &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211,
6034 &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,
6035 &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,
6036 &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,
6037 &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,
6038 &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,
6039 &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,
6040 &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,
6041 &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,11*0,
6042 &2*21,2*-6,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,
6043 &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111,
6044 &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,
6045 &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/
6046 DATA (KFDP(I,3),I= 919,2000)/7*0,2212,3122,3212,3214,2112,2114,
6047 &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0,
6048 &2112,43*0,3322,949*0/
6049 DATA (KFDP(I,4),I= 1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,
6050 &0,111,0,2*111,113,221,111,-213,-211,211,123*0,13*81,37*0,111,
6051 &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,
6052 &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,
6053 &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,
6054 &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,
6055 &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211,
6056 &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,
6057 &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,
6058 &1006*0/
6059 DATA (KFDP(I,5),I= 1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,
6060 &175*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111,
6061 &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1571*0/
6062
6063C...LUDAT4A, with character strings.
6064 DATA (CHAF(I) ,I= 1, 331)/'d','u','s','c','b','t','l','h',
6065 &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
6066 &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','H"',
6067 &'H',2*' ','R',40*' ','specflav','rndmflav','phasespa','c-hadron',
6068 &'b-hadron','t-hadron','l-hadron','h-hadron','Wvirt','diquark',
6069 &'cluster','string','indep.','CMshower','SPHEaxis','THRUaxis',
6070 &'CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B',
6071 &'B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t','eta_l',
6072 &'eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',' ','rho',
6073 &'omega','phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',
6074 &2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ','b_1',
6075 &'h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',
6076 &2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',
6077 &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',
6078 &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',
6079 &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
6080 &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',
6081 &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
6082 &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',5*' ',
6083 &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' '/
6084 DATA (CHAF(I) ,I= 332, 500)/'n','p',' ',3*'Sigma',2*'Xi',' ',
6085 &3*'Sigma_c',2*'Xi''_c','Omega_c',
6086 &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
6087 &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
6088 &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
6089
6090C...LUDATRA, with initial values for the random number generator.
6091 DATA MRLU/19780503,0,0,97,33,0/
6092
6093 END
ce320da8 6094 SUBROUTINE PYINITA(FRAME,BEAM,TARGET,WIN)
0119ef9a 6095
6096C...Initializes the generation procedure; finds maxima of the
6097C...differential cross-sections to be used for weighting.
6098 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6099 SAVE /LUDAT1A/
6100 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6101 SAVE /LUDAT2A/
6102 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6103 SAVE /LUDAT3A/
6104 COMMON/LUDAT4A/CHAF(500)
6105 CHARACTER CHAF*8
6106 SAVE /LUDAT4A/
6107 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
6108 SAVE /PYSUBSA/
6109 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6110 SAVE /PYPARSA/
6111 COMMON/PYINT1A/MINT(400),VINT(400)
6112 SAVE /PYINT1A/
6113 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
6114 SAVE /PYINT2A/
6115 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
6116 SAVE /PYINT5A/
6117 CHARACTER*(*) FRAME,BEAM,TARGET
6118 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHMO(12)*3,CHLH(2)*6
6119 DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
6120 &'Oct','Nov','Dec'/, CHLH/'lepton','hadron'/
6121
6122 CHMO(1)=CHMO(1)
6123C...Write headers.
6124C IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(181),MSTP(182),
6125C &MSTP(185),CHMO(MSTP(184)),MSTP(183)
6126 CALL LULIST(0)
6127C IF(MSTP(122).GE.1) WRITE(MSTU(11),1100)
6128
6129C...Identify beam and target particles and initialize kinematics.
6130 CHFRAM=FRAME//' '
6131 CHBEAM=BEAM//' '
6132 CHTARG=TARGET//' '
ce320da8 6133 CALL PYINKIA(CHFRAM,CHBEAM,CHTARG,WIN)
0119ef9a 6134
6135C...Select partonic subprocesses to be included in the simulation.
6136 IF(MSEL.NE.0) THEN
6137 DO 100 I=1,200
6138 100 MSUB(I)=0
6139 ENDIF
6140 IF(MINT(43).EQ.1.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
6141C...Lepton+lepton -> gamma/Z0 or W.
6142 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6143 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6144 ELSEIF(MSEL.EQ.1) THEN
6145C...High-pT QCD processes:
6146 MSUB(11)=1
6147 MSUB(12)=1
6148 MSUB(13)=1
6149 MSUB(28)=1
6150 MSUB(53)=1
6151 MSUB(68)=1
6152 IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
6153 IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
6154 ELSEIF(MSEL.EQ.2) THEN
6155C...All QCD processes:
6156 MSUB(11)=1
6157 MSUB(12)=1
6158 MSUB(13)=1
6159 MSUB(28)=1
6160 MSUB(53)=1
6161 MSUB(68)=1
6162 MSUB(91)=1
6163 MSUB(92)=1
6164 MSUB(93)=1
6165 MSUB(95)=1
6166 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6167C...Heavy quark production.
6168 MSUB(81)=1
6169 MSUB(82)=1
6170 DO 110 J=1,MIN(8,MDCY(21,3))
6171 110 MDME(MDCY(21,2)+J-1,1)=0
6172 MDME(MDCY(21,2)+MSEL-1,1)=1
6173 ELSEIF(MSEL.EQ.10) THEN
6174C...Prompt photon production:
6175 MSUB(14)=1
6176 MSUB(18)=1
6177 MSUB(29)=1
6178 ELSEIF(MSEL.EQ.11) THEN
6179C...Z0/gamma* production:
6180 MSUB(1)=1
6181 ELSEIF(MSEL.EQ.12) THEN
6182C...W+/- production:
6183 MSUB(2)=1
6184 ELSEIF(MSEL.EQ.13) THEN
6185C...Z0 + jet:
6186 MSUB(15)=1
6187 MSUB(30)=1
6188 ELSEIF(MSEL.EQ.14) THEN
6189C...W+/- + jet:
6190 MSUB(16)=1
6191 MSUB(31)=1
6192 ELSEIF(MSEL.EQ.15) THEN
6193C...Z0 & W+/- pair production:
6194 MSUB(19)=1
6195 MSUB(20)=1
6196 MSUB(22)=1
6197 MSUB(23)=1
6198 MSUB(25)=1
6199 ELSEIF(MSEL.EQ.16) THEN
6200C...H0 production:
6201 MSUB(3)=1
6202 MSUB(5)=1
6203 MSUB(8)=1
6204 MSUB(102)=1
6205 ELSEIF(MSEL.EQ.17) THEN
6206C...H0 & Z0 or W+/- pair production:
6207 MSUB(24)=1
6208 MSUB(26)=1
6209 ELSEIF(MSEL.EQ.21) THEN
6210C...Z'0 production:
6211 MSUB(141)=1
6212 ELSEIF(MSEL.EQ.22) THEN
6213C...H+/- production:
6214 MSUB(142)=1
6215 ELSEIF(MSEL.EQ.23) THEN
6216C...R production:
6217 MSUB(143)=1
6218 ENDIF
6219
6220C...Count number of subprocesses on.
6221 MINT(44)=0
6222 DO 120 ISUB=1,200
6223 IF(MINT(43).LT.4.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
6224 &MSUB(ISUB).EQ.1) THEN
6225 WRITE(MSTU(11),1200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
6226 STOP
6227 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
6228 WRITE(MSTU(11),1300) ISUB
6229 STOP
6230 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
6231 WRITE(MSTU(11),1400) ISUB
6232 STOP
6233 ELSEIF(MSUB(ISUB).EQ.1) THEN
6234 MINT(44)=MINT(44)+1
6235 ENDIF
6236 120 CONTINUE
6237 IF(MINT(44).EQ.0) THEN
6238 WRITE(MSTU(11),1500)
6239 STOP
6240 ENDIF
6241 MINT(45)=MINT(44)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
6242
6243C...Maximum 4 generations; set maximum number of allowed flavours.
6244 MSTP(1)=MIN(4,MSTP(1))
6245 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
6246 MSTP(54)=MIN(MSTP(54),2*MSTP(1))
6247
6248C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
6249 DO 140 I=-20,20
6250 VINT(180+I)=0.
6251 IA=IABS(I)
6252 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
6253 DO 130 J=1,MSTP(1)
6254 IB=2*J-1+MOD(IA,2)
6255 IPM=(5-ISIGN(1,I))/2
6256 IDC=J+MDCY(IA,2)+2
6257 130 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
6258 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
6259 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
6260 VINT(180+I)=1.
6261 ENDIF
6262 140 CONTINUE
6263
6264C...Choose Lambda value to use in alpha-strong.
6265 MSTU(111)=MSTP(2)
6266 IF(MSTP(3).GE.1) THEN
6267 ALAM=PARP(1)
6268 IF(MSTP(51).EQ.1) ALAM=0.2
6269 IF(MSTP(51).EQ.2) ALAM=0.29
6270 IF(MSTP(51).EQ.3) ALAM=0.2
6271 IF(MSTP(51).EQ.4) ALAM=0.4
6272 IF(MSTP(51).EQ.11) ALAM=0.16
6273 IF(MSTP(51).EQ.12) ALAM=0.26
6274 IF(MSTP(51).EQ.13) ALAM=0.36
6275 PARP(1)=ALAM
6276 PARP(61)=ALAM
6277 PARU(112)=ALAM
6278 PARJ(81)=ALAM
6279 ENDIF
6280
6281C...Initialize widths and partial widths for resonances.
ce320da8 6282 CALL PYINREA
0119ef9a 6283
6284C...Reset variables for cross-section calculation.
6285 DO 150 I=0,200
6286 DO 150 J=1,3
6287 NGEN(I,J)=0
6288 150 XSEC(I,J)=0.
6289 VINT(108)=0.
6290
6291C...Find parametrized total cross-sections.
ce320da8 6292 IF(MINT(43).EQ.4) CALL PYXTOTA
0119ef9a 6293
6294C...Maxima of differential cross-sections.
ce320da8 6295 IF(MSTP(121).LE.0) CALL PYMAXIA
0119ef9a 6296
6297C...Initialize possibility of overlayed events.
6298 IF(MSTP(131).NE.0) CALL PYOVLY(1)
6299
6300C...Initialize multiple interactions with variable impact parameter.
6301 IF(MINT(43).EQ.4.AND.(MINT(45).NE.0.OR.MSTP(131).NE.0).AND.
ce320da8 6302 &MSTP(82).GE.2) CALL PYMULTA(1)
0119ef9a 6303C IF(MSTP(122).GE.1) WRITE(MSTU(11),1600)
6304
6305C...Formats for initialization information.
6306clin 1000 FORMAT(///20X,'The Lund Monte Carlo - PYTHIA version ',I1,'.',I1/
6307clin &20X,'** Last date of change: ',I2,1X,A3,1X,I4,' **'/)
ce320da8 6308clin 1100 FORMAT('1',18('*'),1X,'PYINITA: initialization of PYTHIA ',
0119ef9a 6309clin &'routines',1X,17('*'))
6310 1200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
6311 &'-',A6,' interactions.'/1X,'Execution stopped!')
6312 1300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
6313 &1X,'Execution stopped!')
6314 1400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
6315 &1X,'Execution stopped!')
6316 1500 FORMAT(1X,'Error: no subprocess switched on.'/
6317 &1X,'Execution stopped.')
ce320da8 6318clin 1600 FORMAT(/1X,22('*'),1X,'PYINITA: initialization completed',1X,
0119ef9a 6319clin &22('*'))
6320
6321 RETURN
6322 END
6323
6324C*********************************************************************
6325
440e3d40 6326 SUBROUTINE PYTHIAA
0119ef9a 6327
6328C...Administers the generation of a high-pt event via calls to a number
6329C...of subroutines; also computes cross-sections.
6330 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
6331 SAVE /LUJETSA/
6332 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6333 SAVE /LUDAT1A/
6334 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6335 SAVE /LUDAT2A/
6336 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
6337 SAVE /PYSUBSA/
6338 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6339 SAVE /PYPARSA/
6340 COMMON/PYINT1A/MINT(400),VINT(400)
6341 SAVE /PYINT1A/
6342 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
6343 SAVE /PYINT2A/
6344 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
6345 SAVE /PYINT5A/
6346
6347C...Loop over desired number of overlayed events (normally 1).
6348 MINT(7)=0
6349 MINT(8)=0
6350 NOVL=1
6351 IF(MSTP(131).NE.0) CALL PYOVLY(2)
6352 IF(MSTP(131).NE.0) NOVL=MINT(81)
6353 MINT(83)=0
6354 MINT(84)=MSTP(126)
6355 MSTU(70)=0
6356 DO 190 IOVL=1,NOVL
6357 IF(MINT(84)+100.GE.MSTU(4)) THEN
6358 CALL LUERRM(11,
6359 & '(PYTHIA:) no more space in LUJETSA for overlayed events')
6360 IF(MSTU(21).GE.1) GOTO 200
6361 ENDIF
6362 MINT(82)=IOVL
6363
6364C...Generate variables of hard scattering.
6365 100 CONTINUE
6366 IF(IOVL.EQ.1) NGEN(0,2)=NGEN(0,2)+1
6367 MINT(31)=0
6368 MINT(51)=0
ce320da8 6369 CALL PYRANDA
0119ef9a 6370 ISUB=MINT(1)
6371 IF(IOVL.EQ.1) THEN
6372 NGEN(ISUB,2)=NGEN(ISUB,2)+1
6373
6374C...Store information on hard interaction.
6375 DO 110 J=1,200
6376 MSTI(J)=0
6377 110 PARI(J)=0.
6378 MSTI(1)=MINT(1)
6379 MSTI(2)=MINT(2)
6380 MSTI(11)=MINT(11)
6381 MSTI(12)=MINT(12)
6382 MSTI(15)=MINT(15)
6383 MSTI(16)=MINT(16)
6384 MSTI(17)=MINT(17)
6385 MSTI(18)=MINT(18)
6386 PARI(11)=VINT(1)
6387 PARI(12)=VINT(2)
6388 IF(ISUB.NE.95) THEN
6389 DO 120 J=13,22
6390 120 PARI(J)=VINT(30+J)
6391 PARI(33)=VINT(41)
6392 PARI(34)=VINT(42)
6393 PARI(35)=PARI(33)-PARI(34)
6394 PARI(36)=VINT(21)
6395 PARI(37)=VINT(22)
6396 PARI(38)=VINT(26)
6397 PARI(41)=VINT(23)
6398 ENDIF
6399 ENDIF
6400
6401 IF(MSTP(111).EQ.-1) GOTO 160
6402 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
6403C...Hard scattering (including low-pT):
6404C...reconstruct kinematics and colour flow of hard scattering.
ce320da8 6405 CALL PYSCATA
0119ef9a 6406 IF(MINT(51).EQ.1) GOTO 100
6407
6408C...Showering of initial state partons (optional).
6409 IPU1=MINT(84)+1
6410 IPU2=MINT(84)+2
6411 IF(MSTP(61).GE.1.AND.MINT(43).NE.1.AND.ISUB.NE.95)
ce320da8 6412 & CALL PYSSPAA(IPU1,IPU2)
0119ef9a 6413 NSAV1=N
6414
6415C...Multiple interactions.
6416 IF(MSTP(81).GE.1.AND.MINT(43).EQ.4.AND.ISUB.NE.95)
ce320da8 6417 & CALL PYMULTA(6)
0119ef9a 6418 MINT(1)=ISUB
6419 NSAV2=N
6420
6421C...Hadron remnants and primordial kT.
ce320da8 6422 CALL PYREMNA(IPU1,IPU2)
0119ef9a 6423 IF(MINT(51).EQ.1) GOTO 100
6424 NSAV3=N
6425
6426C...Showering of final state partons (optional).
6427 IPU3=MINT(84)+3
6428 IPU4=MINT(84)+4
6429 IF(MSTP(71).GE.1.AND.ISUB.NE.95.AND.K(IPU3,1).GT.0.AND.
6430 & K(IPU3,1).LE.10.AND.K(IPU4,1).GT.0.AND.K(IPU4,1).LE.10) THEN
6431 QMAX=SQRT(PARP(71)*VINT(52))
6432 IF(ISUB.EQ.5) QMAX=SQRT(PMAS(23,1)**2)
6433 IF(ISUB.EQ.8) QMAX=SQRT(PMAS(24,1)**2)
6434 CALL LUSHOW(IPU3,IPU4,QMAX)
6435 ENDIF
6436
6437C...Sum up transverse and longitudinal momenta.
6438 IF(IOVL.EQ.1) THEN
6439 PARI(65)=2.*PARI(17)
6440 DO 130 I=MSTP(126)+1,N
6441 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
6442 PT=SQRT(P(I,1)**2+P(I,2)**2)
6443 PARI(69)=PARI(69)+PT
6444 IF(I.LE.NSAV1.OR.I.GT.NSAV3) PARI(66)=PARI(66)+PT
6445 IF(I.GT.NSAV1.AND.I.LE.NSAV2) PARI(68)=PARI(68)+PT
6446 130 CONTINUE
6447 PARI(67)=PARI(68)
6448 PARI(71)=VINT(151)
6449 PARI(72)=VINT(152)
6450 PARI(73)=VINT(151)
6451 PARI(74)=VINT(152)
6452 ENDIF
6453
6454C...Decay of final state resonances.
ce320da8 6455 IF(MSTP(41).GE.1.AND.ISUB.NE.95) CALL PYRESDA
0119ef9a 6456
6457 ELSE
6458C...Diffractive and elastic scattering.
ce320da8 6459 CALL PYDIFFA
0119ef9a 6460 IF(IOVL.EQ.1) THEN
6461 PARI(65)=2.*PARI(17)
6462 PARI(66)=PARI(65)
6463 PARI(69)=PARI(65)
6464 ENDIF
6465 ENDIF
6466
6467C...Recalculate energies from momenta and masses (if desired).
6468 IF(MSTP(113).GE.1) THEN
6469 DO 140 I=MINT(83)+1,N
6470 140 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
6471 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
6472 ENDIF
6473
6474C...Rearrange partons along strings, check invariant mass cuts.
6475 MSTU(28)=0
6476 CALL LUPREP(MINT(84)+1)
6477 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
6478 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
6479 DO 150 I=MINT(84)+1,N
6480 IF(K(I,2).NE.94) GOTO 150
6481 K(I+1,3)=MOD(K(I+1,4)/MSTU(5),MSTU(5))
6482 K(I+2,3)=MOD(K(I+2,4)/MSTU(5),MSTU(5))
6483 150 CONTINUE
6484 CALL LUEDIT(12)
6485 CALL LUEDIT(14)
6486 IF(MSTP(125).EQ.0) CALL LUEDIT(15)
6487 IF(MSTP(125).EQ.0) MINT(4)=0
6488 ENDIF
6489
6490C...Introduce separators between sections in LULIST event listing.
6491 IF(IOVL.EQ.1.AND.MSTP(125).LE.0) THEN
6492 MSTU(70)=1
6493 MSTU(71)=N
6494 ELSEIF(IOVL.EQ.1) THEN
6495 MSTU(70)=3
6496 MSTU(71)=2
6497 MSTU(72)=MINT(4)
6498 MSTU(73)=N
6499 ENDIF
6500
6501C...Perform hadronization (if desired).
6502 IF(MSTP(111).GE.1) CALL LUEXEC
6503 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL LUEDIT(14)
6504
6505C...Calculate Monte Carlo estimates of cross-sections.
6506 160 IF(IOVL.EQ.1) THEN
6507 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
6508 NGEN(0,3)=NGEN(0,3)+1
6509 XSEC(0,3)=0.
6510 DO 170 I=1,200
6511 IF(I.EQ.96) THEN
6512 XSEC(I,3)=0.
6513 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
6514 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
6515 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1.,FLOAT(NGEN(96,1))*
6516 & FLOAT(NGEN(96,2)))
6517 ELSEIF(NGEN(I,1).EQ.0) THEN
6518 XSEC(I,3)=0.
6519 ELSEIF(NGEN(I,2).EQ.0) THEN
6520 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(FLOAT(NGEN(I,1))*
6521 & FLOAT(NGEN(0,2)))
6522 ELSE
6523 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(FLOAT(NGEN(I,1))*
6524 & FLOAT(NGEN(I,2)))
6525 ENDIF
6526 170 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
6527 IF(MSUB(95).EQ.1) THEN
6528 NGENS=NGEN(91,3)+NGEN(92,3)+NGEN(93,3)+NGEN(94,3)+NGEN(95,3)
6529 XSECS=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+XSEC(95,3)
6530 XMAXS=XSEC(95,1)
6531 IF(MSUB(91).EQ.1) XMAXS=XMAXS+XSEC(91,1)
6532 IF(MSUB(92).EQ.1) XMAXS=XMAXS+XSEC(92,1)
6533 IF(MSUB(93).EQ.1) XMAXS=XMAXS+XSEC(93,1)
6534 IF(MSUB(94).EQ.1) XMAXS=XMAXS+XSEC(94,1)
6535 FAC=1.
6536 IF(NGENS.LT.NGEN(0,3)) FAC=(XMAXS-XSECS)/(XSEC(0,3)-XSECS)
6537 XSEC(11,3)=FAC*XSEC(11,3)
6538 XSEC(12,3)=FAC*XSEC(12,3)
6539 XSEC(13,3)=FAC*XSEC(13,3)
6540 XSEC(28,3)=FAC*XSEC(28,3)
6541 XSEC(53,3)=FAC*XSEC(53,3)
6542 XSEC(68,3)=FAC*XSEC(68,3)
6543 XSEC(0,3)=XSEC(91,3)+XSEC(92,3)+XSEC(93,3)+XSEC(94,3)+
6544 & XSEC(95,1)
6545 ENDIF
6546
6547C...Store final information.
6548 MINT(5)=MINT(5)+1
6549 MSTI(3)=MINT(3)
6550 MSTI(4)=MINT(4)
6551 MSTI(5)=MINT(5)
6552 MSTI(6)=MINT(6)
6553 MSTI(7)=MINT(7)
6554 MSTI(8)=MINT(8)
6555 MSTI(13)=MINT(13)
6556 MSTI(14)=MINT(14)
6557 MSTI(21)=MINT(21)
6558 MSTI(22)=MINT(22)
6559 MSTI(23)=MINT(23)
6560 MSTI(24)=MINT(24)
6561 MSTI(25)=MINT(25)
6562 MSTI(26)=MINT(26)
6563 MSTI(31)=MINT(31)
6564 PARI(1)=XSEC(0,3)
6565 PARI(2)=XSEC(0,3)/MINT(5)
6566 PARI(31)=VINT(141)
6567 PARI(32)=VINT(142)
6568 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
6569 PARI(42)=2.*VINT(47)/VINT(1)
6570 DO 180 IS=7,8
6571 PARI(36+IS)=P(MINT(IS),3)/VINT(1)
6572 PARI(38+IS)=P(MINT(IS),4)/VINT(1)
6573 I=MINT(IS)
6574 PR=MAX(1E-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
6575 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
6576 & SQRT(PR),1E20)),P(I,3))
6577 PR=MAX(1E-20,P(I,1)**2+P(I,2)**2)
6578 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
6579 & SQRT(PR),1E20)),P(I,3))
6580 PARI(44+IS)=P(I,3)/SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6581 PARI(46+IS)=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
6582 PARI(48+IS)=ULANGL(P(I,1),P(I,2))
6583 180 CONTINUE
6584 ENDIF
6585 PARI(61)=VINT(148)
6586 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
6587 MSTU(161)=MINT(21)
6588 MSTU(162)=0
6589 ELSE
6590 MSTU(161)=MINT(21)
6591 MSTU(162)=MINT(22)
6592 ENDIF
6593 ENDIF
6594
6595C...Prepare to go to next overlayed event.
6596 MSTI(41)=IOVL
6597 IF(IOVL.GE.2.AND.IOVL.LE.10) MSTI(40+IOVL)=ISUB
6598 IF(MSTU(70).LT.10) THEN
6599 MSTU(70)=MSTU(70)+1
6600 MSTU(70+MSTU(70))=N
6601 ENDIF
6602 MINT(83)=N
6603 MINT(84)=N+MSTP(126)
6604 190 CONTINUE
6605
6606C...Information on overlayed events.
6607 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
6608 PARI(91)=VINT(132)
6609 PARI(92)=VINT(133)
6610 PARI(93)=VINT(134)
6611 IF(MSTP(133).EQ.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
6612 ENDIF
6613
6614C...Transform to the desired coordinate frame.
ce320da8 6615 200 CALL PYFRAMA(MSTP(124))
0119ef9a 6616
6617 RETURN
6618 END
6619
6620C*********************************************************************
6621
ce320da8 6622 SUBROUTINE PYINKIA(CHFRAM,CHBEAM,CHTARG,WIN)
0119ef9a 6623
6624C...Identifies the two incoming particles and sets up kinematics,
6625C...including rotations and boosts to/from CM frame.
6626 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
6627 SAVE /LUJETSA/
6628 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6629 SAVE /LUDAT1A/
6630 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
6631 SAVE /PYSUBSA/
6632 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6633 SAVE /PYPARSA/
6634 COMMON/PYINT1A/MINT(400),VINT(400)
6635 SAVE /PYINT1A/
6636 CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
6637 &CHIDNT(3)*8,CHTEMP*8,CHCDE(18)*8,CHINIT*76
6638 DIMENSION LEN(3),KCDE(18)
6639 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
6640 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
6641 DATA CHCDE/'e- ','e+ ','nue ','nue~ ',
6642 &'mu- ','mu+ ','numu ','numu~ ','tau- ',
6643 &'tau+ ','nutau ','nutau~ ','pi+ ','pi- ',
6644 &'n ','n~ ','p ','p~ '/
6645 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
6646 &211,-211,2112,-2112,2212,-2212/
6647
6648C...Convert character variables to lowercase and find their length.
6649 CHCOM(1)=CHFRAM
6650 CHCOM(2)=CHBEAM
6651 CHCOM(3)=CHTARG
6652 DO 120 I=1,3
6653 LEN(I)=8
6654 DO 100 LL=8,1,-1
6655 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
6656 DO 100 LA=1,26
6657 100 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
6658 &CHALP(1)(LA:LA)
6659 CHIDNT(I)=CHCOM(I)
6660 DO 110 LL=1,6
6661 IF(CHIDNT(I)(LL:LL+2).EQ.'bar') THEN
6662 CHTEMP=CHIDNT(I)
6663 CHIDNT(I)=CHTEMP(1:LL-1)//'~'//CHTEMP(LL+3:8)//' '
6664 ENDIF
6665 110 CONTINUE
6666 DO 120 LL=1,8
6667 IF(CHIDNT(I)(LL:LL).EQ.'_') THEN
6668 CHTEMP=CHIDNT(I)
6669 CHIDNT(I)=CHTEMP(1:LL-1)//CHTEMP(LL+1:8)//' '
6670 ENDIF
6671 120 CONTINUE
6672
6673C...Set initial state. Error for unknown codes. Reset variables.
6674 N=2
6675 DO 140 I=1,2
6676 K(I,2)=0
6677 DO 130 J=1,18
6678 130 IF(CHIDNT(I+1).EQ.CHCDE(J)) K(I,2)=KCDE(J)
6679 P(I,5)=ULMASS(K(I,2))
6680 MINT(40+I)=1
6681 IF(IABS(K(I,2)).GT.100) MINT(40+I)=2
6682 DO 140 J=1,5
6683 140 V(I,J)=0.
6684 IF(K(1,2).EQ.0) WRITE(MSTU(11),1000) CHBEAM(1:LEN(2))
6685 IF(K(2,2).EQ.0) WRITE(MSTU(11),1100) CHTARG(1:LEN(3))
6686 IF(K(1,2).EQ.0.OR.K(2,2).EQ.0) STOP
6687 DO 150 J=6,10
6688 150 VINT(J)=0.
6689 CHINIT=' '
6690
6691C...Set up kinematics for events defined in CM frame.
6692 IF(CHCOM(1)(1:2).EQ.'cm') THEN
6693 IF(CHCOM(2)(1:1).NE.'e') THEN
6694 LOFFS=(34-(LEN(2)+LEN(3)))/2
6695 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
6696 & CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' '
6697 ELSE
6698 LOFFS=(33-(LEN(2)+LEN(3)))/2
6699 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
6700 & CHCOM(2)(1:LEN(2))//'-'//CHCOM(3)(1:LEN(3))//' collider'//' '
6701 ENDIF
6702C WRITE(MSTU(11),1200) CHINIT
6703C WRITE(MSTU(11),1300) WIN
6704 S=WIN**2
6705 P(1,1)=0.
6706 P(1,2)=0.
6707 P(2,1)=0.
6708 P(2,2)=0.
6709 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2.*P(1,5)*P(2,5))**2)/
6710 & (4.*S))
6711 P(2,3)=-P(1,3)
6712 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
6713 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
6714
6715C...Set up kinematics for fixed target events.
6716 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
6717 LOFFS=(29-(LEN(2)+LEN(3)))/2
6718 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
6719 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
6720 & ' fixed target'//' '
6721C WRITE(MSTU(11),1200) CHINIT
6722C WRITE(MSTU(11),1400) WIN
6723 P(1,1)=0.
6724 P(1,2)=0.
6725 P(2,1)=0.
6726 P(2,2)=0.
6727 P(1,3)=WIN
6728 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
6729 P(2,3)=0.
6730 P(2,4)=P(2,5)
6731 S=P(1,5)**2+P(2,5)**2+2.*P(2,4)*P(1,4)
6732 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
6733 CALL LUROBO(0.,0.,0.,0.,-VINT(10))
6734C WRITE(MSTU(11),1500) SQRT(S)
6735
6736C...Set up kinematics for events in user-defined frame.
6737 ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
6738 LOFFS=(13-(LEN(1)+LEN(2)))/2
6739 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
6740 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
6741 & 'user-specified configuration'//' '
6742C WRITE(MSTU(11),1200) CHINIT
6743C WRITE(MSTU(11),1600)
6744C WRITE(MSTU(11),1700) CHCOM(2),P(1,1),P(1,2),P(1,3)
6745C WRITE(MSTU(11),1700) CHCOM(3),P(2,1),P(2,2),P(2,3)
6746 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
6747 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
6748 DO 160 J=1,3
6749 160 VINT(7+J)=sngl((DBLE(P(1,J))+DBLE(P(2,J)))
6750 & /DBLE(P(1,4)+P(2,4)))
6751 CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))
6752 VINT(7)=ULANGL(P(1,1),P(1,2))
6753 CALL LUROBO(0.,-VINT(7),0.,0.,0.)
6754 VINT(6)=ULANGL(P(1,3),P(1,1))
6755 CALL LUROBO(-VINT(6),0.,0.,0.,0.)
6756 S=P(1,5)**2+P(2,5)**2+2.*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
6757C WRITE(MSTU(11),1500) SQRT(S)
6758
6759C...Unknown frame. Error for too low CM energy.
6760 ELSE
6761 WRITE(MSTU(11),1800) CHFRAM(1:LEN(1))
6762 STOP
6763 ENDIF
6764 IF(S.LT.PARP(2)**2) THEN
6765 WRITE(MSTU(11),1900) SQRT(S)
6766 STOP
6767 ENDIF
6768
6769C...Save information on incoming particles.
6770 MINT(11)=K(1,2)
6771 MINT(12)=K(2,2)
6772 MINT(43)=2*MINT(41)+MINT(42)-2
6773 VINT(1)=SQRT(S)
6774 VINT(2)=S
6775 VINT(3)=P(1,5)
6776 VINT(4)=P(2,5)
6777 VINT(5)=P(1,3)
6778
6779C...Store constants to be used in generation.
6780 IF(MSTP(82).LE.1) VINT(149)=4.*PARP(81)**2/S
6781 IF(MSTP(82).GE.2) VINT(149)=4.*PARP(82)**2/S
6782
6783C...Formats for initialization and error information.
6784 1000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''.'/
6785 &1X,'Execution stopped!')
6786 1100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''.'/
6787 &1X,'Execution stopped!')
6788clin 1200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
6789c 1300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
6790c &19X,'I'/1X,'I',76X,'I'/1X,78('='))
6791c 1400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
6792c 1500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
6793c &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
6794c 1600 FORMAT(1X,'I',76X,'I'/1X,'I',24X,'px (GeV/c)',3X,'py (GeV/c)',3X,
6795c &'pz (GeV/c)',16X,'I')
6796clin 1700 FORMAT(1X,'I',15X,A8,3(2X,F10.3,1X),15X,'I')
6797 1800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''.'/
6798 &1X,'Execution stopped!')
6799 1900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
6800 &'generation.'/1X,'Execution stopped!')
6801
6802 RETURN
6803 END
6804
6805C*********************************************************************
6806
ce320da8 6807 SUBROUTINE PYINREA
0119ef9a 6808
6809C...Calculates full and effective widths of guage bosons, stores masses
6810C...and widths, rescales coefficients to be used for resonance
6811C...production generation.
6812 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6813 SAVE /LUDAT1A/
6814 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6815 SAVE /LUDAT2A/
6816 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6817 SAVE /LUDAT3A/
6818 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
6819 SAVE /PYSUBSA/
6820 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6821 SAVE /PYPARSA/
6822 COMMON/PYINT1A/MINT(400),VINT(400)
6823 SAVE /PYINT1A/
6824 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
6825 SAVE /PYINT2A/
6826 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
6827 SAVE /PYINT4AA/
6828 COMMON/PYINT6A/PROC(0:200)
6829 CHARACTER PROC*28
6830 SAVE /PYINT6A/
6831 DIMENSION WDTP(0:40),WDTE(0:40,0:5)
6832
6833 kc=0
6834
6835C...Calculate full and effective widths of gauge bosons.
6836 AEM=PARU(101)
6837 XW=PARU(102)
6838 DO 100 I=21,40
6839 DO 100 J=0,40
6840 WIDP(I,J)=0.
6841 100 WIDE(I,J)=0.
6842
6843C...W+/-:
6844 WMAS=PMAS(24,1)
6845 WFAC=AEM/(24.*XW)*WMAS
ce320da8 6846 CALL PYWIDTA(24,WMAS,WDTP,WDTE)
0119ef9a 6847 WIDS(24,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
6848 &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
6849 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6850 WIDS(24,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6851 WIDS(24,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
6852 DO 110 I=0,40
6853 WIDP(24,I)=WFAC*WDTP(I)
6854 110 WIDE(24,I)=WFAC*WDTE(I,0)
6855
6856C...H+/-:
6857 HCMAS=PMAS(37,1)
6858 HCFAC=AEM/(8.*XW)*(HCMAS/WMAS)**2*HCMAS
ce320da8 6859 CALL PYWIDTA(37,HCMAS,WDTP,WDTE)
0119ef9a 6860 WIDS(37,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
6861 &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
6862 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6863 WIDS(37,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6864 WIDS(37,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
6865 DO 120 I=0,40
6866 WIDP(37,I)=HCFAC*WDTP(I)
6867 120 WIDE(37,I)=HCFAC*WDTE(I,0)
6868
6869C...Z0:
6870 ZMAS=PMAS(23,1)
6871 ZFAC=AEM/(48.*XW*(1.-XW))*ZMAS
ce320da8 6872 CALL PYWIDTA(23,ZMAS,WDTP,WDTE)
0119ef9a 6873 WIDS(23,1)=((WDTE(0,1)+WDTE(0,2))**2+
6874 &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
6875 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6876 WIDS(23,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6877 WIDS(23,3)=0.
6878 DO 130 I=0,40
6879 WIDP(23,I)=ZFAC*WDTP(I)
6880 130 WIDE(23,I)=ZFAC*WDTE(I,0)
6881
6882C...H0:
6883 HMAS=PMAS(25,1)
6884 HFAC=AEM/(8.*XW)*(HMAS/WMAS)**2*HMAS
ce320da8 6885 CALL PYWIDTA(25,HMAS,WDTP,WDTE)
0119ef9a 6886 WIDS(25,1)=((WDTE(0,1)+WDTE(0,2))**2+
6887 &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
6888 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6889 WIDS(25,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6890 WIDS(25,3)=0.
6891 DO 140 I=0,40
6892 WIDP(25,I)=HFAC*WDTP(I)
6893 140 WIDE(25,I)=HFAC*WDTE(I,0)
6894
6895C...Z'0:
6896 ZPMAS=PMAS(32,1)
6897 ZPFAC=AEM/(48.*XW*(1.-XW))*ZPMAS
ce320da8 6898 CALL PYWIDTA(32,ZPMAS,WDTP,WDTE)
0119ef9a 6899 WIDS(32,1)=((WDTE(0,1)+WDTE(0,2)+WDTE(0,3))**2+
6900 &2.*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
6901 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6902 WIDS(32,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6903 WIDS(32,3)=0.
6904 DO 150 I=0,40
6905 WIDP(32,I)=ZPFAC*WDTP(I)
6906 150 WIDE(32,I)=ZPFAC*WDTE(I,0)
6907
6908C...R:
6909 RMAS=PMAS(40,1)
6910 RFAC=0.08*RMAS/((MSTP(1)-1)*(1.+6.*(1.+ULALPS(RMAS**2)/PARU(1))))
ce320da8 6911 CALL PYWIDTA(40,RMAS,WDTP,WDTE)
0119ef9a 6912 WIDS(40,1)=((WDTE(0,1)+WDTE(0,2))*(WDTE(0,1)+WDTE(0,3))+
6913 &(WDTE(0,1)+WDTE(0,2)+WDTE(0,1)+WDTE(0,3))*(WDTE(0,4)+WDTE(0,5))+
6914 &2.*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
6915 WIDS(40,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
6916 WIDS(40,3)=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
6917 DO 160 I=0,40
6918 WIDP(40,I)=WFAC*WDTP(I)
6919 160 WIDE(40,I)=WFAC*WDTE(I,0)
6920
6921C...Q:
6922 KFLQM=1
6923 DO 170 I=1,MIN(8,MDCY(21,3))
6924 IDC=I+MDCY(21,2)-1
6925 IF(MDME(IDC,1).LE.0) GOTO 170
6926 KFLQM=I
6927 170 CONTINUE
6928 MINT(46)=KFLQM
6929 KFPR(81,1)=KFLQM
6930 KFPR(81,2)=KFLQM
6931 KFPR(82,1)=KFLQM
6932 KFPR(82,2)=KFLQM
6933
6934C...Set resonance widths and branching ratios in JETSET.
6935 DO 180 I=1,6
6936 IF(I.LE.3) KC=I+22
6937 IF(I.EQ.4) KC=32
6938 IF(I.EQ.5) KC=37
6939 IF(I.EQ.6) KC=40
6940 PMAS(KC,2)=WIDP(KC,0)
6941 PMAS(KC,3)=MIN(0.9*PMAS(KC,1),10.*PMAS(KC,2))
6942 DO 180 J=1,MDCY(KC,3)
6943 IDC=J+MDCY(KC,2)-1
6944 BRAT(IDC)=WIDE(KC,J)/WIDE(KC,0)
6945 180 CONTINUE
6946
6947C...Special cases in treatment of gamma*/Z0: redefine process name.
6948 IF(MSTP(43).EQ.1) THEN
6949 PROC(1)='f + fb -> gamma*'
6950 ELSEIF(MSTP(43).EQ.2) THEN
6951 PROC(1)='f + fb -> Z0'
6952 ELSEIF(MSTP(43).EQ.3) THEN
6953 PROC(1)='f + fb -> gamma*/Z0'
6954 ENDIF
6955
6956C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
6957 IF(MSTP(44).EQ.1) THEN
6958 PROC(141)='f + fb -> gamma*'
6959 ELSEIF(MSTP(44).EQ.2) THEN
6960 PROC(141)='f + fb -> Z0'
6961 ELSEIF(MSTP(44).EQ.3) THEN
6962 PROC(141)='f + fb -> Z''0'
6963 ELSEIF(MSTP(44).EQ.4) THEN
6964 PROC(141)='f + fb -> gamma*/Z0'
6965 ELSEIF(MSTP(44).EQ.5) THEN
6966 PROC(141)='f + fb -> gamma*/Z''0'
6967 ELSEIF(MSTP(44).EQ.6) THEN
6968 PROC(141)='f + fb -> Z0/Z''0'
6969 ELSEIF(MSTP(44).EQ.7) THEN
6970 PROC(141)='f + fb -> gamma*/Z0/Z''0'
6971 ENDIF
6972
6973 RETURN
6974 END
6975
6976C*********************************************************************
6977
ce320da8 6978 SUBROUTINE PYXTOTA
0119ef9a 6979
6980C...Parametrizes total, double diffractive, single diffractive and
6981C...elastic cross-sections for different energies and beams.
6982 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6983 SAVE /LUDAT1A/
6984 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
6985 SAVE /PYPARSA/
6986 COMMON/PYINT1A/MINT(400),VINT(400)
6987 SAVE /PYINT1A/
6988 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
6989 SAVE /PYINT5A/
6990 DIMENSION BCS(5,8),BCB(2,5),BCC(3)
6991
6992C...The following data lines are coefficients needed in the
6993C...Block, Cahn parametrization of total cross-section and nuclear
6994C...slope parameter; see below.
6995 DATA ((BCS(I,J),J=1,8),I=1,5)/
6996 1 41.74, 0.66, 0.0000, 337., 0.0, 0.0, -39.3, 0.48,
6997 2 41.66, 0.60, 0.0000, 306., 0.0, 0.0, -34.6, 0.51,
6998 3 41.36, 0.63, 0.0000, 299., 7.3, 0.5, -40.4, 0.47,
6999 4 41.68, 0.63, 0.0083, 330., 0.0, 0.0, -39.0, 0.48,
7000 5 41.13, 0.59, 0.0074, 278., 10.5, 0.5, -41.2, 0.46/
7001 DATA ((BCB(I,J),J=1,5),I=1,2)/
7002 1 10.79, -0.049, 0.040, 21.5, 1.23,
7003 2 9.92, -0.027, 0.013, 18.9, 1.07/
7004 DATA BCC/2.0164346,-0.5590311,0.0376279/
7005
7006C...Total cross-section and nuclear slope parameter for pp and p-pbar
7007 NFIT=MIN(5,MAX(1,MSTP(31)))
7008 SIGP=BCS(NFIT,1)+BCS(NFIT,2)*(-0.25*PARU(1)**2*
7009 &(1.-0.25*BCS(NFIT,3)*PARU(1)**2)+(1.+0.5*BCS(NFIT,3)*PARU(1)**2)*
7010 &(LOG(VINT(2)/BCS(NFIT,4)))**2+BCS(NFIT,3)*
7011 &(LOG(VINT(2)/BCS(NFIT,4)))**4)/
7012 &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*
7013 &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)*(LOG(VINT(2)/BCS(NFIT,4)))**2+
7014 &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)+BCS(NFIT,5)*
7015 &VINT(2)**(BCS(NFIT,6)-1.)*SIN(0.5*PARU(1)*BCS(NFIT,6))
7016 SIGM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*
7017 &COS(0.5*PARU(1)*BCS(NFIT,8))
7018 REFP=BCS(NFIT,2)*PARU(1)*LOG(VINT(2)/BCS(NFIT,4))/
7019 &((1.-0.25*BCS(NFIT,3)*PARU(1)**2)**2+2.*BCS(NFIT,3)*
7020 &(1.+0.25*BCS(NFIT,3)*PARU(1)**2)+(LOG(VINT(2)/BCS(NFIT,4)))**2+
7021 &BCS(NFIT,3)**2*(LOG(VINT(2)/BCS(NFIT,4)))**4)-BCS(NFIT,5)*
7022 &VINT(2)**(BCS(NFIT,6)-1.)*COS(0.5*PARU(1)*BCS(NFIT,6))
7023 REFM=-BCS(NFIT,7)*VINT(2)**(BCS(NFIT,8)-1.)*
7024 &SIN(0.5*PARU(1)*BCS(NFIT,8))
7025 SIGMA=SIGP-ISIGN(1,MINT(11)*MINT(12))*SIGM
7026 RHO=(REFP-ISIGN(1,MINT(11)*MINT(12))*REFM)/SIGMA
7027
7028C...Nuclear slope parameter B, curvature C:
7029 NFIT=1
7030 IF(MSTP(31).GE.4) NFIT=2
7031 BP=BCB(NFIT,1)+BCB(NFIT,2)*LOG(VINT(2))+
7032 &BCB(NFIT,3)*(LOG(VINT(2)))**2
7033 BM=BCB(NFIT,4)+BCB(NFIT,5)*LOG(VINT(2))
7034 B=BP-ISIGN(1,MINT(11)*MINT(12))*SIGM/SIGP*(BM-BP)
7035 VINT(121)=B
7036 C=-0.5*BCC(2)/BCC(3)*(1.-SQRT(MAX(0.,1.+4.*BCC(3)/BCC(2)**2*
7037 &(1.E-03*VINT(1)-BCC(1)))))
7038 VINT(122)=C
7039
7040C...Elastic scattering cross-section (fixed by sigma-tot, rho and B).
7041 SIGEL=SIGMA**2*(1.+RHO**2)/(16.*PARU(1)*PARU(5)*B)
7042
7043C...Single diffractive scattering cross-section from Goulianos:
7044 SIGSD=2.*0.68*(1.+36./VINT(2))*LOG(0.6+0.1*VINT(2))
7045
7046C...Double diffractive scattering cross-section (essentially fixed by
7047C...sigma-sd and sigma-el).
7048 SIGDD=SIGSD**2/(3.*SIGEL)
7049
7050C...Total non-elastic, non-diffractive cross-section.
7051 SIGND=SIGMA-SIGDD-SIGSD-SIGEL
7052
7053C...Rescale for pions.
7054 IF(IABS(MINT(11)).EQ.211.AND.IABS(MINT(12)).EQ.211) THEN
7055 SIGMA=4./9.*SIGMA
7056 SIGDD=4./9.*SIGDD
7057 SIGSD=4./9.*SIGSD
7058 SIGEL=4./9.*SIGEL
7059 SIGND=4./9.*SIGND
7060 ELSEIF(IABS(MINT(11)).EQ.211.OR.IABS(MINT(12)).EQ.211) THEN
7061 SIGMA=2./3.*SIGMA
7062 SIGDD=2./3.*SIGDD
7063 SIGSD=2./3.*SIGSD
7064 SIGEL=2./3.*SIGEL
7065 SIGND=2./3.*SIGND
7066 ENDIF
7067
7068C...Save cross-sections in common block PYPARA.
7069 VINT(101)=SIGMA
7070 VINT(102)=SIGEL
7071 VINT(103)=SIGSD
7072 VINT(104)=SIGDD
7073 VINT(106)=SIGND
7074 XSEC(95,1)=SIGND
7075
7076 RETURN
7077 END
7078
7079C*********************************************************************
7080
ce320da8 7081 SUBROUTINE PYMAXIA
0119ef9a 7082
7083C...Finds optimal set of coefficients for kinematical variable selection
7084C...and the maximum of the part of the differential cross-section used
7085C...in the event weighting.
7086 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7087 SAVE /LUDAT1A/
7088 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7089 SAVE /LUDAT2A/
7090 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
7091 SAVE /PYSUBSA/
7092 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
7093 SAVE /PYPARSA/
7094 COMMON/PYINT1A/MINT(400),VINT(400)
7095 SAVE /PYINT1A/
7096 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
7097 SAVE /PYINT2A/
7098 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7099 SAVE /PYINT3A/
7100 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
7101 SAVE /PYINT4AA/
7102 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
7103 SAVE /PYINT5A/
7104 COMMON/PYINT6A/PROC(0:200)
7105 CHARACTER PROC*28
7106 SAVE /PYINT6A/
7107 CHARACTER CVAR(4)*4
7108 DIMENSION NPTS(4),MVARPT(200,4),VINTPT(200,30),SIGSPT(200),
7109 &NAREL(6),WTREL(6),WTMAT(6,6),COEFU(6),IACCMX(4),SIGSMX(4),
7110 &SIGSSM(3)
7111 DATA CVAR/'tau ','tau''','y* ','cth '/
7112
7113 taur1=0.
7114 gamr1=0.
7115 taur2=0.
7116 gamr2=0.
7117 atau3=0.
7118 atau4=0.
7119 atau5=0.
7120 atau6=0.
7121 ioff=0
7122 vvar=0.
7123 vdel=0.
7124 vmar=0.
7125
7126C...Select subprocess to study: skip cases not applicable.
7127 VINT(143)=1.
7128 VINT(144)=1.
7129 XSEC(0,1)=0.
7130 DO 350 ISUB=1,200
7131 IF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7132 XSEC(ISUB,1)=VINT(ISUB+11)
7133 IF(MSUB(ISUB).NE.1) GOTO 350
7134 GOTO 340
7135 ELSEIF(ISUB.EQ.96) THEN
7136 IF(MINT(43).NE.4) GOTO 350
7137 IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0) GOTO 350
7138 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7139 &ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7140 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 350
7141 ELSE
7142 IF(MSUB(ISUB).NE.1) GOTO 350
7143 ENDIF
7144 MINT(1)=ISUB
7145 ISTSB=ISET(ISUB)
7146 IF(ISUB.EQ.96) ISTSB=2
7147 IF(MSTP(122).GE.2) WRITE(MSTU(11),1000) ISUB
7148
7149C...Find resonances (explicit or implicit in cross-section).
7150 MINT(72)=0
7151 KFR1=0
7152 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3) THEN
7153 KFR1=KFPR(ISUB,1)
7154 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7155 KFR1=25
7156 ENDIF
7157 IF(KFR1.NE.0) THEN
7158 TAUR1=PMAS(KFR1,1)**2/VINT(2)
7159 GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2)
7160 MINT(72)=1
7161 MINT(73)=KFR1
7162 VINT(73)=TAUR1
7163 VINT(74)=GAMR1
7164 ENDIF
7165 IF(ISUB.EQ.141) THEN
7166 KFR2=23
7167 TAUR2=PMAS(KFR2,1)**2/VINT(2)
7168 GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2)
7169 MINT(72)=2
7170 MINT(74)=KFR2
7171 VINT(75)=TAUR2
7172 VINT(76)=GAMR2
7173 ENDIF
7174
7175C...Find product masses and minimum pT of process.
7176 SQM3=0.
7177 SQM4=0.
7178 MINT(71)=0
7179 VINT(71)=CKIN(3)
7180 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7181 IF(KFPR(ISUB,1).NE.0) SQM3=PMAS(KFPR(ISUB,1),1)**2
7182 IF(KFPR(ISUB,2).NE.0) SQM4=PMAS(KFPR(ISUB,2),1)**2
7183 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7184 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7185 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
7186 IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08*PARP(82)
7187 ENDIF
7188 VINT(63)=SQM3
7189 VINT(64)=SQM4
7190
7191C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7192 NPTS(1)=2+2*MINT(72)
7193 IF(MINT(43).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) NPTS(1)=1
7194 NPTS(2)=1
7195 IF(MINT(43).GE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) NPTS(2)=2
7196 NPTS(3)=1
7197 IF(MINT(43).EQ.4) NPTS(3)=3
7198 NPTS(4)=1
7199 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7200 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7201
7202C...Reset coefficients of cross-section weighting.
7203 DO 100 J=1,20
7204 100 COEF(ISUB,J)=0.
7205 COEF(ISUB,1)=1.
7206 COEF(ISUB,7)=0.5
7207 COEF(ISUB,8)=0.5
7208 COEF(ISUB,10)=1.
7209 COEF(ISUB,15)=1.
7210 MCTH=0
7211 MTAUP=0
7212 CTH=0.
7213 TAUP=0.
7214 SIGSAM=0.
7215
7216C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7217C...in grid of phase space points.
ce320da8 7218 CALL PYKLIMA(1)
0119ef9a 7219 NACC=0
7220 DO 120 ITRY=1,NTRY
7221 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7222 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
ce320da8 7223 CALL PYKMAPA(1,MTAU,0.5)
7224 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIMA(4)
0119ef9a 7225 ENDIF
7226 IF((ISTSB.EQ.3.OR.ISTSB.EQ.4).AND.MOD(ITRY-1,NPTS(3)*NPTS(4)).
7227 &EQ.0) THEN
7228 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
ce320da8 7229 CALL PYKMAPA(4,MTAUP,0.5)
0119ef9a 7230 ENDIF
ce320da8 7231 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) CALL PYKLIMA(2)
0119ef9a 7232 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7233 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
ce320da8 7234 CALL PYKMAPA(2,MYST,0.5)
7235 CALL PYKLIMA(3)
0119ef9a 7236 ENDIF
7237 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7238 MCTH=1+MOD(ITRY-1,NPTS(4))
ce320da8 7239 CALL PYKMAPA(3,MCTH,0.5)
0119ef9a 7240 ENDIF
7241 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
7242
7243C...Calculate and store cross-section.
7244 MINT(51)=0
ce320da8 7245 CALL PYKLIMA(0)
0119ef9a 7246 IF(MINT(51).EQ.1) GOTO 120
7247 NACC=NACC+1
7248 MVARPT(NACC,1)=MTAU
7249 MVARPT(NACC,2)=MTAUP
7250 MVARPT(NACC,3)=MYST
7251 MVARPT(NACC,4)=MCTH
7252 DO 110 J=1,30
7253 110 VINTPT(NACC,J)=VINT(10+J)
ce320da8 7254 CALL PYSIGHA(NCHN,SIGS)
0119ef9a 7255 SIGSPT(NACC)=SIGS
7256 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7257 IF(MSTP(122).GE.2) WRITE(MSTU(11),1100) MTAU,MTAUP,MYST,MCTH,
7258 &VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7259 120 CONTINUE
7260 IF(SIGSAM.EQ.0.) THEN
7261 WRITE(MSTU(11),1200) ISUB
7262 STOP
7263 ENDIF
7264
7265C...Calculate integrals in tau and y* over maximal phase space limits.
7266 TAUMIN=VINT(11)
7267 TAUMAX=VINT(31)
7268 ATAU1=LOG(TAUMAX/TAUMIN)
7269 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7270 IF(NPTS(1).GE.3) THEN
7271 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7272 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7273 & GAMR1
7274 ENDIF
7275 IF(NPTS(1).GE.5) THEN
7276 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7277 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7278 & GAMR2
7279 ENDIF
7280 YSTMIN=0.5*LOG(TAUMIN)
7281 YSTMAX=-YSTMIN
7282 AYST0=YSTMAX-YSTMIN
7283 AYST1=0.5*(YSTMAX-YSTMIN)**2
7284 AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7285
7286C...Reset. Sum up cross-sections in points calculated.
7287 DO 230 IVAR=1,4
7288 IF(NPTS(IVAR).EQ.1) GOTO 230
7289 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 230
7290 NBIN=NPTS(IVAR)
7291 DO 130 J1=1,NBIN
7292 NAREL(J1)=0
7293 WTREL(J1)=0.
7294 COEFU(J1)=0.
7295 DO 130 J2=1,NBIN
7296 130 WTMAT(J1,J2)=0.
7297 DO 140 IACC=1,NACC
7298 IBIN=MVARPT(IACC,IVAR)
7299 NAREL(IBIN)=NAREL(IBIN)+1
7300 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7301
7302C...Sum up tau cross-section pieces in points used.
7303 IF(IVAR.EQ.1) THEN
7304 TAU=VINTPT(IACC,11)
7305 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
7306 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7307 IF(NBIN.GE.3) THEN
7308 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7309 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7310 & ((TAU-TAUR1)**2+GAMR1**2)
7311 ENDIF
7312 IF(NBIN.GE.5) THEN
7313 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7314 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7315 & ((TAU-TAUR2)**2+GAMR2**2)
7316 ENDIF
7317
7318C...Sum up tau' cross-section pieces in points used.
7319 ELSEIF(IVAR.EQ.2) THEN
7320 TAU=VINTPT(IACC,11)
7321 TAUP=VINTPT(IACC,16)
7322 TAUPMN=VINTPT(IACC,6)
7323 TAUPMX=VINTPT(IACC,26)
7324 ATAUP1=LOG(TAUPMX/TAUPMN)
7325 ATAUP2=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU)
7326 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
7327 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*(1.-TAU/TAUP)**3/
7328 & TAUP
7329
7330C...Sum up y* and cos(theta-hat) cross-section pieces in points used.
7331 ELSEIF(IVAR.EQ.3) THEN
7332 YST=VINTPT(IACC,12)
7333 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7334 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST1)*(YSTMAX-YST)
7335 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7336 ELSE
7337 RM34=2.*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2
7338 RSQM=1.+RM34
7339 CTHMAX=SQRT(1.-4.*VINT(71)**2/(TAUMAX*VINT(2)))
7340 CTHMIN=-CTHMAX
7341 IF(CTHMAX.GT.0.9999) RM34=MAX(RM34,2.*VINT(71)**2/
7342 & (TAUMAX*VINT(2)))
7343 ACTH1=CTHMAX-CTHMIN
7344 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7345 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7346 ACTH4=1./MAX(RM34,RSQM-CTHMAX)-1./MAX(RM34,RSQM-CTHMIN)
7347 ACTH5=1./MAX(RM34,RSQM+CTHMIN)-1./MAX(RM34,RSQM+CTHMAX)
7348 CTH=VINTPT(IACC,13)
7349 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1.
7350 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/MAX(RM34,RSQM-CTH)
7351 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/MAX(RM34,RSQM+CTH)
7352 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/MAX(RM34,RSQM-CTH)**2
7353 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/MAX(RM34,RSQM+CTH)**2
7354 ENDIF
7355 140 CONTINUE
7356
7357C...Check that equation system solvable; else trivial way out.
7358 IF(MSTP(122).GE.2) WRITE(MSTU(11),1300) CVAR(IVAR)
7359 MSOLV=1
7360 DO 150 IBIN=1,NBIN
7361 IF(MSTP(122).GE.2) WRITE(MSTU(11),1400) (WTMAT(IBIN,IRED),
7362 &IRED=1,NBIN),WTREL(IBIN)
7363 150 IF(NAREL(IBIN).EQ.0) MSOLV=0
7364 IF(MSOLV.EQ.0) THEN
7365 DO 160 IBIN=1,NBIN
7366 160 COEFU(IBIN)=1.
7367
7368C...Solve to find relative importance of cross-section pieces.
7369 ELSE
7370 DO 170 IRED=1,NBIN-1
7371 DO 170 IBIN=IRED+1,NBIN
7372 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
7373 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
7374 DO 170 ICOE=IRED,NBIN
7375 170 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
7376 DO 190 IRED=NBIN,1,-1
7377 DO 180 ICOE=IRED+1,NBIN
7378 180 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
7379 190 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
7380 ENDIF
7381
7382C...Normalize coefficients, with piece shared democratically.
7383 COEFSU=0.
7384 DO 200 IBIN=1,NBIN
7385 COEFU(IBIN)=MAX(0.,COEFU(IBIN))
7386 200 COEFSU=COEFSU+COEFU(IBIN)
7387 IF(IVAR.EQ.1) IOFF=0
7388 IF(IVAR.EQ.2) IOFF=14
7389 IF(IVAR.EQ.3) IOFF=6
7390 IF(IVAR.EQ.4) IOFF=9
7391 IF(COEFSU.GT.0.) THEN
7392 DO 210 IBIN=1,NBIN
7393 210 COEF(ISUB,IOFF+IBIN)=PARP(121)/NBIN+(1.-PARP(121))*COEFU(IBIN)/
7394 & COEFSU
7395 ELSE
7396 DO 220 IBIN=1,NBIN
7397 220 COEF(ISUB,IOFF+IBIN)=1./NBIN
7398 ENDIF
7399 IF(MSTP(122).GE.2) WRITE(MSTU(11),1500) CVAR(IVAR),
7400 &(COEF(ISUB,IOFF+IBIN),IBIN=1,NBIN)
7401 230 CONTINUE
7402
7403C...Find two most promising maxima among points previously determined.
7404 DO 240 J=1,4
7405 IACCMX(J)=0
7406 240 SIGSMX(J)=0.
7407 NMAX=0
7408 DO 290 IACC=1,NACC
7409 DO 250 J=1,30
7410 250 VINT(10+J)=VINTPT(IACC,J)
ce320da8 7411 CALL PYSIGHA(NCHN,SIGS)
0119ef9a 7412 IEQ=0
7413 DO 260 IMV=1,NMAX
7414 260 IF(ABS(SIGS-SIGSMX(IMV)).LT.1E-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
7415 IF(IEQ.EQ.0) THEN
7416 DO 270 IMV=NMAX,1,-1
7417 IIN=IMV+1
7418 IF(SIGS.LE.SIGSMX(IMV)) GOTO 280
7419 IACCMX(IMV+1)=IACCMX(IMV)
7420 270 SIGSMX(IMV+1)=SIGSMX(IMV)
7421 IIN=1
7422 280 IACCMX(IIN)=IACC
7423 SIGSMX(IIN)=SIGS
7424 IF(NMAX.LE.1) NMAX=NMAX+1
7425 ENDIF
7426 290 CONTINUE
7427
7428C...Read out starting position for search.
7429 IF(MSTP(122).GE.2) WRITE(MSTU(11),1600)
7430 SIGSAM=SIGSMX(1)
7431 DO 330 IMAX=1,NMAX
7432 IACC=IACCMX(IMAX)
7433 MTAU=MVARPT(IACC,1)
7434 MTAUP=MVARPT(IACC,2)
7435 MYST=MVARPT(IACC,3)
7436 MCTH=MVARPT(IACC,4)
7437 VTAU=0.5
7438 VYST=0.5
7439 VCTH=0.5
7440 VTAUP=0.5
7441
7442C...Starting point and step size in parameter space.
7443 DO 320 IRPT=1,2
7444 DO 310 IVAR=1,4
7445 IF(NPTS(IVAR).EQ.1) GOTO 310
7446 IF(IVAR.EQ.1) VVAR=VTAU
7447 IF(IVAR.EQ.2) VVAR=VTAUP
7448 IF(IVAR.EQ.3) VVAR=VYST
7449 IF(IVAR.EQ.4) VVAR=VCTH
7450 IF(IVAR.EQ.1) MVAR=MTAU
7451 IF(IVAR.EQ.2) MVAR=MTAUP
7452 IF(IVAR.EQ.3) MVAR=MYST
7453 IF(IVAR.EQ.4) MVAR=MCTH
7454 IF(IRPT.EQ.1) VDEL=0.1
7455 IF(IRPT.EQ.2) VDEL=MAX(0.01,MIN(0.05,VVAR-0.02,0.98-VVAR))
7456 IF(IRPT.EQ.1) VMAR=0.02
7457 IF(IRPT.EQ.2) VMAR=0.002
7458 IMOV0=1
7459 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
7460 DO 300 IMOV=IMOV0,8
7461
7462C...Define new point in parameter space.
7463 IF(IMOV.EQ.0) THEN
7464 INEW=2
7465 VNEW=VVAR
7466 ELSEIF(IMOV.EQ.1) THEN
7467 INEW=3
7468 VNEW=VVAR+VDEL
7469 ELSEIF(IMOV.EQ.2) THEN
7470 INEW=1
7471 VNEW=VVAR-VDEL
7472 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
7473 &VVAR+2.*VDEL.LT.1.-VMAR) THEN
7474 VVAR=VVAR+VDEL
7475 SIGSSM(1)=SIGSSM(2)
7476 SIGSSM(2)=SIGSSM(3)
7477 INEW=3
7478 VNEW=VVAR+VDEL
7479 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
7480 &VVAR-2.*VDEL.GT.VMAR) THEN
7481 VVAR=VVAR-VDEL
7482 SIGSSM(3)=SIGSSM(2)
7483 SIGSSM(2)=SIGSSM(1)
7484 INEW=1
7485 VNEW=VVAR-VDEL
7486 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
7487 VDEL=0.5*VDEL
7488 VVAR=VVAR+VDEL
7489 SIGSSM(1)=SIGSSM(2)
7490 INEW=2
7491 VNEW=VVAR
7492 ELSE
7493 VDEL=0.5*VDEL
7494 VVAR=VVAR-VDEL
7495 SIGSSM(3)=SIGSSM(2)
7496 INEW=2
7497 VNEW=VVAR
7498 ENDIF
7499
7500C...Convert to relevant variables and find derived new limits.
7501 IF(IVAR.EQ.1) THEN
7502 VTAU=VNEW
ce320da8 7503 CALL PYKMAPA(1,MTAU,VTAU)
7504 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) CALL PYKLIMA(4)
0119ef9a 7505 ENDIF
7506 IF(IVAR.LE.2.AND.(ISTSB.EQ.3.OR.ISTSB.EQ.4)) THEN
7507 IF(IVAR.EQ.2) VTAUP=VNEW
ce320da8 7508 CALL PYKMAPA(4,MTAUP,VTAUP)
0119ef9a 7509 ENDIF
ce320da8 7510 IF(IVAR.LE.2) CALL PYKLIMA(2)
0119ef9a 7511 IF(IVAR.LE.3) THEN
7512 IF(IVAR.EQ.3) VYST=VNEW
ce320da8 7513 CALL PYKMAPA(2,MYST,VYST)
7514 CALL PYKLIMA(3)
0119ef9a 7515 ENDIF
7516 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7517 IF(IVAR.EQ.4) VCTH=VNEW
ce320da8 7518 CALL PYKMAPA(3,MCTH,VCTH)
0119ef9a 7519 ENDIF
7520 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
7521
7522C...Evaluate cross-section. Save new maximum. Final maximum.
ce320da8 7523 CALL PYSIGHA(NCHN,SIGS)
0119ef9a 7524 SIGSSM(INEW)=SIGS
7525 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7526 IF(MSTP(122).GE.2) WRITE(MSTU(11),1700) IMAX,IVAR,MVAR,IMOV,
7527 &VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7528 300 CONTINUE
7529 310 CONTINUE
7530 320 CONTINUE
7531 IF(IMAX.EQ.1) SIGS11=SIGSAM
7532 330 CONTINUE
7533 XSEC(ISUB,1)=1.05*SIGSAM
7534 340 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
7535 350 CONTINUE
7536
7537C...Print summary table.
7538 IF(MSTP(122).GE.1) THEN
7539 WRITE(MSTU(11),1800)
7540 WRITE(MSTU(11),1900)
7541 DO 360 ISUB=1,200
7542 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 360
7543 IF(ISUB.EQ.96.AND.MINT(43).NE.4) GOTO 360
7544 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 360
7545 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.
7546 & ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 360
7547 WRITE(MSTU(11),2000) ISUB,PROC(ISUB),XSEC(ISUB,1)
7548 360 CONTINUE
7549 WRITE(MSTU(11),2100)
7550 ENDIF
7551
7552C...Format statements for maximization results.
7553 1000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
7554 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
7555 &'cth',9X,'tau''',7X,'sigma')
7556 1100 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,E12.4)
7557 1200 FORMAT(1X,'Error: requested subprocess ',I3,' has vanishing ',
7558 &'cross-section.'/1X,'Execution stopped!')
7559 1300 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
7560 1400 FORMAT(1X,1P,7E11.3)
7561 1500 FORMAT(1X,'Result for ',A4,':',6F9.4)
7562 1600 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
7563 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
7564 1700 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,E12.4)
ce320da8 7565 1800 FORMAT(/1X,8('*'),1X,'PYMAXIA: summary of differential ',
0119ef9a 7566 &'cross-section maximum search',1X,8('*'))
7567 1900 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
7568 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
7569 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
7570 2000 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,E12.4,3X,'I')
7571 2100 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
7572
7573 RETURN
7574 END
7575
7576C*********************************************************************
7577
7578 SUBROUTINE PYOVLY(MOVLY)
7579
7580C...Initializes multiplicity distribution and selects mutliplicity
7581C...of overlayed events, i.e. several events occuring at the same
7582C...beam crossing.
7583 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7584 SAVE /LUDAT1A/
7585 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
7586 SAVE /PYPARSA/
7587 COMMON/PYINT1A/MINT(400),VINT(400)
7588 SAVE /PYINT1A/
7589 DIMENSION WTI(0:100)
7590 SAVE IMAX,WTI,WTS
7591
7592C...Sum of allowed cross-sections for overlayed events.
7593 IF(MOVLY.EQ.1) THEN
7594 VINT(131)=VINT(106)
7595 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+VINT(104)
7596 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+VINT(103)
7597 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+VINT(102)
7598
7599C...Initialize multiplicity distribution for unbiased events.
7600 IF(MSTP(133).EQ.1) THEN
7601 XNAVE=VINT(131)*PARP(131)
7602 IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE
7603 WTI(0)=EXP(-MIN(50.,XNAVE))
7604 WTS=0.
7605 WTN=0.
7606 DO 100 I=1,100
7607 WTI(I)=WTI(I-1)*XNAVE/I
7608 IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 110
7609 WTS=WTS+WTI(I)
7610 WTN=WTN+WTI(I)*I
7611 100 IMAX=I
7612 110 VINT(132)=XNAVE
7613 VINT(133)=WTN/WTS
7614 VINT(134)=WTS
7615
7616C...Initialize mutiplicity distribution for biased events.
7617 ELSEIF(MSTP(133).EQ.2) THEN
7618 XNAVE=VINT(131)*PARP(131)
7619 IF(XNAVE.GT.40.) WRITE(MSTU(11),1000) XNAVE
7620 WTI(1)=EXP(-MIN(50.,XNAVE))*XNAVE
7621 WTS=WTI(1)
7622 WTN=WTI(1)
7623 DO 120 I=2,100
7624 WTI(I)=WTI(I-1)*XNAVE/(I-1)
7625 IF(I-2.5.GT.XNAVE.AND.WTI(I).LT.1E-6) GOTO 130
7626 WTS=WTS+WTI(I)
7627 WTN=WTN+WTI(I)*I
7628 120 IMAX=I
7629 130 VINT(132)=XNAVE
7630 VINT(133)=WTN/WTS
7631 VINT(134)=WTS
7632 ENDIF
7633
7634C...Pick multiplicity of overlayed events.
7635 ELSE
7636 IF(MSTP(133).EQ.0) THEN
7637 MINT(81)=MAX(1,MSTP(134))
7638 ELSE
7639 WTR=WTS*RLU(0)
7640 DO 140 I=1,IMAX
7641 MINT(81)=I
7642 WTR=WTR-WTI(I)
7643 IF(WTR.LE.0.) GOTO 150
7644 140 CONTINUE
7645 150 CONTINUE
7646 ENDIF
7647 ENDIF
7648
7649C...Format statement for error message.
7650 1000 FORMAT(1X,'Warning: requested average number of events per bunch',
7651 &'crossing too large, ',1P,E12.4)
7652
7653 RETURN
7654 END
7655
7656C*********************************************************************
7657
ce320da8 7658 SUBROUTINE PYRANDA
0119ef9a 7659
7660C...Generates quantities characterizing the high-pT scattering at the
7661C...parton level according to the matrix elements. Chooses incoming,
7662C...reacting partons, their momentum fractions and one of the possible
7663C...subprocesses.
7664 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7665 SAVE /LUDAT1A/
7666 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7667 SAVE /LUDAT2A/
7668 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
7669 SAVE /PYSUBSA/
7670 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
7671 SAVE /PYPARSA/
7672 COMMON/PYINT1A/MINT(400),VINT(400)
7673 SAVE /PYINT1A/
7674 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
7675 SAVE /PYINT2A/
7676 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7677 SAVE /PYINT3A/
7678 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
7679 SAVE /PYINT4AA/
7680 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
7681 SAVE /PYINT5A/
7682
7683C...Initial values, specifically for (first) semihard interaction.
7684 MINT(17)=0
7685 MINT(18)=0
7686 VINT(143)=1.
7687 VINT(144)=1.
ce320da8 7688 IF(MSUB(95).EQ.1.OR.MINT(82).GE.2) CALL PYMULTA(2)
0119ef9a 7689 ISUB=0
7690 100 MINT(51)=0
7691
7692C...Choice of process type - first event of overlay.
7693 IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
7694 RSUB=XSEC(0,1)*RLU(0)
7695 DO 110 I=1,200
7696 IF(MSUB(I).NE.1) GOTO 110
7697 ISUB=I
7698 RSUB=RSUB-XSEC(I,1)
7699 IF(RSUB.LE.0.) GOTO 120
7700 110 CONTINUE
7701 120 IF(ISUB.EQ.95) ISUB=96
7702
7703C...Choice of inclusive process type - overlayed events.
7704 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
7705 RSUB=VINT(131)*RLU(0)
7706 ISUB=96
7707 IF(RSUB.GT.VINT(106)) ISUB=93
7708 IF(RSUB.GT.VINT(106)+VINT(104)) ISUB=92
7709 IF(RSUB.GT.VINT(106)+VINT(104)+VINT(103)) ISUB=91
7710 ENDIF
7711 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
7712 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
7713 MINT(1)=ISUB
7714
7715C...Find resonances (explicit or implicit in cross-section).
7716 MINT(72)=0
7717 KFR1=0
7718 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
7719 KFR1=KFPR(ISUB,1)
7720 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7721 KFR1=25
7722 ENDIF
7723 IF(KFR1.NE.0) THEN
7724 TAUR1=PMAS(KFR1,1)**2/VINT(2)
7725 GAMR1=PMAS(KFR1,1)*PMAS(KFR1,2)/VINT(2)
7726 MINT(72)=1
7727 MINT(73)=KFR1
7728 VINT(73)=TAUR1
7729 VINT(74)=GAMR1
7730 ENDIF
7731 IF(ISUB.EQ.141) THEN
7732 KFR2=23
7733 TAUR2=PMAS(KFR2,1)**2/VINT(2)
7734 GAMR2=PMAS(KFR2,1)*PMAS(KFR2,2)/VINT(2)
7735 MINT(72)=2
7736 MINT(74)=KFR2
7737 VINT(75)=TAUR2
7738 VINT(76)=GAMR2
7739 ENDIF
7740
7741C...Find product masses and minimum pT of process,
7742C...optionally with broadening according to a truncated Breit-Wigner.
7743 VINT(63)=0.
7744 VINT(64)=0.
7745 MINT(71)=0
7746 VINT(71)=CKIN(3)
7747 IF(MINT(82).GE.2) VINT(71)=0.
7748 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
7749 DO 130 I=1,2
7750 IF(KFPR(ISUB,I).EQ.0) THEN
7751 ELSEIF(MSTP(42).LE.0) THEN
7752 VINT(62+I)=PMAS(KFPR(ISUB,I),1)**2
7753 ELSE
7754 VINT(62+I)=ULMASS(KFPR(ISUB,I))**2
7755 ENDIF
7756 130 CONTINUE
7757 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
7758 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7759 ENDIF
7760
7761 IF(ISET(ISUB).EQ.0) THEN
7762C...Double or single diffractive, or elastic scattering:
7763C...choose m^2 according to 1/m^2 (diffractive), constant (elastic)
7764 IS=INT(1.5+RLU(0))
7765 VINT(63)=VINT(3)**2
7766 VINT(64)=VINT(4)**2
7767 IF(ISUB.EQ.92.OR.ISUB.EQ.93) VINT(62+IS)=PARP(111)**2
7768 IF(ISUB.EQ.93) VINT(65-IS)=PARP(111)**2
7769 SH=VINT(2)
7770 SQM1=VINT(3)**2
7771 SQM2=VINT(4)**2
7772 SQM3=VINT(63)
7773 SQM4=VINT(64)
7774 SQLA12=(SH-SQM1-SQM2)**2-4.*SQM1*SQM2
7775 SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
7776 THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH
7777 THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH
7778 THL=0.5*(THTER1-THTER2)
7779 THU=0.5*(THTER1+THTER2)
7780 THM=MIN(MAX(THL,PARP(101)),THU)
7781 JTMAX=0
7782 IF(ISUB.EQ.92.OR.ISUB.EQ.93) JTMAX=ISUB-91
7783 DO 140 JT=1,JTMAX
7784 MINT(13+3*JT-IS*(2*JT-3))=1
7785 SQMMIN=VINT(59+3*JT-IS*(2*JT-3))
7786 SQMI=VINT(8-3*JT+IS*(2*JT-3))**2
7787 SQMJ=VINT(3*JT-1-IS*(2*JT-3))**2
7788 SQMF=VINT(68-3*JT+IS*(2*JT-3))
7789 SQUA=0.5*SH/SQMI*((1.+(SQMI-SQMJ)/SH)*THM+SQMI-SQMF-
7790 & SQMJ**2/SH+(SQMI+SQMJ)*SQMF/SH+(SQMI-SQMJ)**2/SH**2*SQMF)
7791 QUAR=SH/SQMI*(THM*(THM+SH-SQMI-SQMJ-SQMF*(1.-(SQMI-SQMJ)/SH))+
7792 & SQMI*SQMJ-SQMJ*SQMF*(1.+(SQMI-SQMJ-SQMF)/SH))
7793 SQMMAX=SQUA+SQRT(MAX(0.,SQUA**2-QUAR))
7794 IF(ABS(QUAR/SQUA**2).LT.1.E-06) SQMMAX=0.5*QUAR/SQUA
7795 SQMMAX=MIN(SQMMAX,(VINT(1)-SQRT(SQMF))**2)
7796 VINT(59+3*JT-IS*(2*JT-3))=SQMMIN*(SQMMAX/SQMMIN)**RLU(0)
7797 140 CONTINUE
7798C...Choose t-hat according to exp(B*t-hat+C*t-hat^2).
7799 SQM3=VINT(63)
7800 SQM4=VINT(64)
7801 SQLA34=(SH-SQM3-SQM4)**2-4.*SQM3*SQM4
7802 THTER1=SQM1+SQM2+SQM3+SQM4-(SQM1-SQM2)*(SQM3-SQM4)/SH-SH
7803 THTER2=SQRT(MAX(0.,SQLA12))*SQRT(MAX(0.,SQLA34))/SH
7804 THL=0.5*(THTER1-THTER2)
7805 THU=0.5*(THTER1+THTER2)
7806 B=VINT(121)
7807 C=VINT(122)
7808 IF(ISUB.EQ.92.OR.ISUB.EQ.93) THEN
7809 B=0.5*B
7810 C=0.5*C
7811 ENDIF
7812 THM=MIN(MAX(THL,PARP(101)),THU)
7813 EXPTH=0.
7814 THARG=B*(THM-THU)
7815 IF(THARG.GT.-20.) EXPTH=EXP(THARG)
7816 150 TH=THU+LOG(EXPTH+(1.-EXPTH)*RLU(0))/B
7817 TH=MAX(THM,MIN(THU,TH))
7818 RATLOG=MIN((B+C*(TH+THM))*(TH-THM),(B+C*(TH+THU))*(TH-THU))
7819 IF(RATLOG.LT.LOG(RLU(0))) GOTO 150
7820 VINT(21)=1.
7821 VINT(22)=0.
7822 VINT(23)=MIN(1.,MAX(-1.,(2.*TH-THTER1)/THTER2))
7823
7824C...Note: in the following, by In is meant the integral over the
7825C...quantity multiplying coefficient cn.
7826C...Choose tau according to h1(tau)/tau, where
7827C...h1(tau) = c0 + I0/I1*c1*1/tau + I0/I2*c2*1/(tau+tau_R) +
7828C...I0/I3*c3*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
7829C...I0/I4*c4*1/(tau+tau_R') +
7830C...I0/I5*c5*tau/((s*tau-m'^2)^2+(m'*Gamma')^2), and
7831C...c0 + c1 + c2 + c3 + c4 + c5 = 1
7832 ELSEIF(ISET(ISUB).GE.1.AND.ISET(ISUB).LE.4) THEN
ce320da8 7833 CALL PYKLIMA(1)
0119ef9a 7834 IF(MINT(51).NE.0) GOTO 100
7835 RTAU=RLU(0)
7836 MTAU=1
7837 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
7838 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
7839 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
7840 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
7841 & MTAU=5
7842 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
7843 & COEF(ISUB,5)) MTAU=6
ce320da8 7844 CALL PYKMAPA(1,MTAU,RLU(0))
0119ef9a 7845
7846C...2 -> 3, 4 processes:
7847C...Choose tau' according to h4(tau,tau')/tau', where
7848C...h4(tau,tau') = c0 + I0/I1*c1*(1 - tau/tau')^3/tau', and
7849C...c0 + c1 = 1.
7850 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
ce320da8 7851 CALL PYKLIMA(4)
0119ef9a 7852 IF(MINT(51).NE.0) GOTO 100
7853 RTAUP=RLU(0)
7854 MTAUP=1
7855 IF(RTAUP.GT.COEF(ISUB,15)) MTAUP=2
ce320da8 7856 CALL PYKMAPA(4,MTAUP,RLU(0))
0119ef9a 7857 ENDIF
7858
7859C...Choose y* according to h2(y*), where
7860C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
7861C...I0/I3*c3*1/cosh(y*), I0 = y*max-y*min, and c1 + c2 + c3 = 1.
ce320da8 7862 CALL PYKLIMA(2)
0119ef9a 7863 IF(MINT(51).NE.0) GOTO 100
7864 RYST=RLU(0)
7865 MYST=1
7866 IF(RYST.GT.COEF(ISUB,7)) MYST=2
7867 IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
ce320da8 7868 CALL PYKMAPA(2,MYST,RLU(0))
0119ef9a 7869
7870C...2 -> 2 processes:
7871C...Choose cos(theta-hat) (cth) according to h3(cth), where
7872C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
7873C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
7874C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
7875C...and c0 + c1 + c2 + c3 + c4 = 1.
ce320da8 7876 CALL PYKLIMA(3)
0119ef9a 7877 IF(MINT(51).NE.0) GOTO 100
7878 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
7879 RCTH=RLU(0)
7880 MCTH=1
7881 IF(RCTH.GT.COEF(ISUB,10)) MCTH=2
7882 IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)) MCTH=3
7883 IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)) MCTH=4
7884 IF(RCTH.GT.COEF(ISUB,10)+COEF(ISUB,11)+COEF(ISUB,12)+
7885 & COEF(ISUB,13)) MCTH=5
ce320da8 7886 CALL PYKMAPA(3,MCTH,RLU(0))
0119ef9a 7887 ENDIF
7888
7889C...Low-pT or multiple interactions (first semihard interaction).
7890 ELSEIF(ISET(ISUB).EQ.5) THEN
ce320da8 7891 CALL PYMULTA(3)
0119ef9a 7892 ISUB=MINT(1)
7893 ENDIF
7894
7895C...Choose azimuthal angle.
7896 VINT(24)=PARU(2)*RLU(0)
7897
7898C...Check against user cuts on kinematics at parton level.
7899 MINT(51)=0
ce320da8 7900 IF(ISUB.LE.90.OR.ISUB.GT.100) CALL PYKLIMA(0)
0119ef9a 7901 IF(MINT(51).NE.0) GOTO 100
7902 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1) THEN
7903 MCUT=0
7904 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
ce320da8 7905 & CALL PYKCUTA(MCUT)
0119ef9a 7906 IF(MCUT.NE.0) GOTO 100
7907 ENDIF
7908
7909C...Calculate differential cross-section for different subprocesses.
ce320da8 7910 CALL PYSIGHA(NCHN,SIGS)
0119ef9a 7911
7912C...Calculations for Monte Carlo estimate of all cross-sections.
7913 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
7914 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
7915 ELSEIF(MINT(82).EQ.1) THEN
7916 XSEC(ISUB,2)=XSEC(ISUB,2)+XSEC(ISUB,1)
7917 ENDIF
7918
7919C...Multiple interactions: store results of cross-section calculation.
7920 IF(MINT(43).EQ.4.AND.MSTP(82).GE.3) THEN
7921 VINT(153)=SIGS
ce320da8 7922 CALL PYMULTA(4)
0119ef9a 7923 ENDIF
7924
7925C...Weighting using estimate of maximum of differential cross-section.
7926 VIOL=SIGS/XSEC(ISUB,1)
7927 IF(VIOL.LT.RLU(0)) GOTO 100
7928
7929C...Check for possible violation of estimated maximum of differential
7930C...cross-section used in weighting.
7931 IF(MSTP(123).LE.0) THEN
7932 IF(VIOL.GT.1.) THEN
7933 WRITE(MSTU(11),1000) VIOL,NGEN(0,3)+1
7934 WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26)
7935 STOP
7936 ENDIF
7937 ELSEIF(MSTP(123).EQ.1) THEN
7938 IF(VIOL.GT.VINT(108)) THEN
7939 VINT(108)=VIOL
7940C IF(VIOL.GT.1.) THEN
7941C WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
7942C WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),
7943C & VINT(26)
7944C ENDIF
7945 ENDIF
7946 ELSEIF(VIOL.GT.VINT(108)) THEN
7947 VINT(108)=VIOL
7948 IF(VIOL.GT.1.) THEN
7949 XDIF=XSEC(ISUB,1)*(VIOL-1.)
7950 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
7951 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
7952 & XSEC(0,1)=XSEC(0,1)+XDIF
7953C WRITE(MSTU(11),1200) VIOL,NGEN(0,3)+1
7954C WRITE(MSTU(11),1100) ISUB,VINT(21),VINT(22),VINT(23),VINT(26)
7955C IF(ISUB.LE.9) THEN
7956C WRITE(MSTU(11),1300) ISUB,XSEC(ISUB,1)
7957C ELSEIF(ISUB.LE.99) THEN
7958C WRITE(MSTU(11),1400) ISUB,XSEC(ISUB,1)
7959C ELSE
7960C WRITE(MSTU(11),1500) ISUB,XSEC(ISUB,1)
7961C ENDIF
7962 VINT(108)=1.
7963 ENDIF
7964 ENDIF
7965
7966C...Multiple interactions: choose impact parameter.
7967 VINT(148)=1.
7968 IF(MINT(43).EQ.4.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.MSTP(82).GE.3)
7969 &THEN
ce320da8 7970 CALL PYMULTA(5)
0119ef9a 7971 IF(VINT(150).LT.RLU(0)) GOTO 100
7972 ENDIF
7973 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
7974 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
7975 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
7976 ENDIF
7977 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
7978
7979C...Choose flavour of reacting partons (and subprocess).
7980 RSIGS=SIGS*RLU(0)
7981 QT2=VINT(48)
7982 RQQBAR=PARP(87)*(1.-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
7983 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
7984 &RLU(0).GT.RQQBAR)) THEN
7985 DO 190 ICHN=1,NCHN
7986 KFL1=ISIG(ICHN,1)
7987 KFL2=ISIG(ICHN,2)
7988 MINT(2)=ISIG(ICHN,3)
7989 RSIGS=RSIGS-SIGH(ICHN)
7990 IF(RSIGS.LE.0.) GOTO 210
7991 190 CONTINUE
7992
7993C...Multiple interactions: choose qqbar preferentially at small pT.
7994 ELSEIF(ISUB.EQ.96) THEN
ce320da8 7995 CALL PYSPLIA(MINT(11),21,KFL1,KFLDUM)
7996 CALL PYSPLIA(MINT(12),21,KFL2,KFLDUM)
0119ef9a 7997 MINT(1)=11
7998 MINT(2)=1
7999 IF(KFL1.EQ.KFL2.AND.RLU(0).LT.0.5) MINT(2)=2
8000
8001C...Low-pT: choose string drawing configuration.
8002 ELSE
8003 KFL1=21
8004 KFL2=21
8005 RSIGS=6.*RLU(0)
8006 MINT(2)=1
8007 IF(RSIGS.GT.1.) MINT(2)=2
8008 IF(RSIGS.GT.2.) MINT(2)=3
8009 ENDIF
8010
8011C...Reassign QCD process. Partons before initial state radiation.
8012 210 IF(MINT(2).GT.10) THEN
8013 MINT(1)=MINT(2)/10
8014 MINT(2)=MOD(MINT(2),10)
8015 ENDIF
8016 MINT(15)=KFL1
8017 MINT(16)=KFL2
8018 MINT(13)=MINT(15)
8019 MINT(14)=MINT(16)
8020 VINT(141)=VINT(41)
8021 VINT(142)=VINT(42)
8022
8023C...Format statements for differential cross-section maximum violations.
8024 1000 FORMAT(1X,'Error: maximum violated by',1P,E11.3,1X,
8025 &'in event',1X,I7,'.'/1X,'Execution stopped!')
8026 1100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau=',1P,
8027 &E11.3,', y* =',E11.3,', cthe = ',0P,F11.7,', tau'' =',1P,E11.3)
8028clin 1200 FORMAT(1X,'Warning: maximum violated by',1P,E11.3,1X,
8029c &'in event',1X,I7)
8030c 1300 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,E11.3)
8031c 1400 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,E11.3)
8032clin 1500 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,E11.3)
8033
8034 RETURN
8035 END
8036
8037C*********************************************************************
8038
ce320da8 8039 SUBROUTINE PYSCATA
0119ef9a 8040
8041C...Finds outgoing flavours and event type; sets up the kinematics
8042C...and colour flow of the hard scattering.
8043 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
8044 SAVE /LUJETSA/
8045 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8046 SAVE /LUDAT1A/
8047 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8048 SAVE /LUDAT2A/
8049 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
8050 SAVE /LUDAT3A/
8051 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
8052 SAVE /PYSUBSA/
8053 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
8054 SAVE /PYPARSA/
8055 COMMON/PYINT1A/MINT(400),VINT(400)
8056 SAVE /PYINT1A/
8057 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
8058 SAVE /PYINT2A/
8059 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8060 SAVE /PYINT3A/
8061 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
8062 SAVE /PYINT4AA/
8063 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
8064 SAVE /PYINT5A/
8065 DIMENSION WDTP(0:40),WDTE(0:40,0:5),PMQ(2),Z(2),CTHE(2),PHI(2)
8066
8067 kflq=0
8068 phir=0.
8069
8070C...Choice of subprocess, number of documentation lines.
8071 ISUB=MINT(1)
8072 IDOC=6+ISET(ISUB)
8073 IF(ISUB.EQ.95) IDOC=8
8074 MINT(3)=IDOC-6
8075 IF(IDOC.GE.9) IDOC=IDOC+2
8076 MINT(4)=IDOC
8077 IPU1=MINT(84)+1
8078 IPU2=MINT(84)+2
8079 IPU3=MINT(84)+3
8080 IPU4=MINT(84)+4
8081 IPU5=MINT(84)+5
8082 IPU6=MINT(84)+6
8083
8084C...Reset K, P and V vectors. Store incoming particles.
8085 DO 100 JT=1,MSTP(126)+10
8086 I=MINT(83)+JT
8087 DO 100 J=1,5
8088 K(I,J)=0
8089 P(I,J)=0.
8090 100 V(I,J)=0.
8091 DO 110 JT=1,2
8092 I=MINT(83)+JT
8093 K(I,1)=21
8094 K(I,2)=MINT(10+JT)
8095 P(I,1)=0.
8096 P(I,2)=0.
8097 P(I,5)=VINT(2+JT)
8098 P(I,3)=VINT(5)*(-1)**(JT+1)
8099 110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
8100 MINT(6)=2
8101 KFRES=0
8102
8103C...Store incoming partons in their CM-frame.
8104 SH=VINT(44)
8105 SHR=SQRT(SH)
8106 SHP=VINT(26)*VINT(2)
8107 SHPR=SQRT(SHP)
8108 SHUSER=SHR
8109 IF(ISET(ISUB).GE.3) SHUSER=SHPR
8110 DO 120 JT=1,2
8111 I=MINT(84)+JT
8112 K(I,1)=14
8113 K(I,2)=MINT(14+JT)
8114 K(I,3)=MINT(83)+2+JT
8115 120 P(I,5)=ULMASS(K(I,2))
8116 IF(P(IPU1,5)+P(IPU2,5).GE.SHUSER) THEN
8117 P(IPU1,5)=0.
8118 P(IPU2,5)=0.
8119 ENDIF
8120 P(IPU1,4)=0.5*(SHUSER+(P(IPU1,5)**2-P(IPU2,5)**2)/SHUSER)
8121 P(IPU1,3)=SQRT(MAX(0.,P(IPU1,4)**2-P(IPU1,5)**2))
8122 P(IPU2,4)=SHUSER-P(IPU1,4)
8123 P(IPU2,3)=-P(IPU1,3)
8124
8125C...Copy incoming partons to documentation lines.
8126 DO 130 JT=1,2
8127 I1=MINT(83)+4+JT
8128 I2=MINT(84)+JT
8129 K(I1,1)=21
8130 K(I1,2)=K(I2,2)
8131 K(I1,3)=I1-2
8132 DO 130 J=1,5
8133 130 P(I1,J)=P(I2,J)
8134
8135C...Choose new quark flavour for relevant annihilation graphs.
8136 IF(ISUB.EQ.12.OR.ISUB.EQ.53) THEN
ce320da8 8137 CALL PYWIDTA(21,SHR,WDTP,WDTE)
0119ef9a 8138 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*RLU(0)
8139 DO 140 I=1,2*MSTP(1)
8140 KFLQ=I
8141 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
8142 IF(RKFL.LE.0.) GOTO 150
8143 140 CONTINUE
8144 150 CONTINUE
8145 ENDIF
8146
8147C...Final state flavours and colour flow: default values.
8148 JS=1
8149 MINT(21)=MINT(15)
8150 MINT(22)=MINT(16)
8151 MINT(23)=0
8152 MINT(24)=0
8153 KCC=20
8154 KCS=ISIGN(1,MINT(15))
8155
8156 IF(ISUB.LE.10) THEN
8157 IF(ISUB.EQ.1) THEN
8158C...f + fb -> gamma*/Z0.
8159 KFRES=23
8160
8161 ELSEIF(ISUB.EQ.2) THEN
8162C...f + fb' -> W+/- .
8163 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8164 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8165 KFRES=ISIGN(24,KCH1+KCH2)
8166
8167 ELSEIF(ISUB.EQ.3) THEN
8168C...f + fb -> H0.
8169 KFRES=25
8170
8171 ELSEIF(ISUB.EQ.4) THEN
8172C...gamma + W+/- -> W+/-.
8173
8174 ELSEIF(ISUB.EQ.5) THEN
8175C...Z0 + Z0 -> H0.
8176 XH=SH/SHP
8177 MINT(21)=MINT(15)
8178 MINT(22)=MINT(16)
8179 PMQ(1)=ULMASS(MINT(21))
8180 PMQ(2)=ULMASS(MINT(22))
8181 240 JT=INT(1.5+RLU(0))
8182 ZMIN=2.*PMQ(JT)/SHPR
8183 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8184 ZMAX=MIN(1.-XH,ZMAX)
8185 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8186 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8187 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 240
8188 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8189 IF(SQC1.LT.1.E-8) GOTO 240
8190 C1=SQRT(SQC1)
8191 C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8192 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8193 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8194 Z(3-JT)=1.-XH/(1.-Z(JT))
8195 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8196 IF(SQC1.LT.1.E-8) GOTO 240
8197 C1=SQRT(SQC1)
8198 C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8199 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8200 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8201 PHIR=PARU(2)*RLU(0)
8202 CPHI=COS(PHIR)
8203 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8204 Z1=2.-Z(JT)
8205 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8206 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8207 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8208 & PMQ(3-JT)**2/SHP))
8209 ZMIN=2.*PMQ(3-JT)/SHPR
8210 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8211 ZMAX=MIN(1.-XH,ZMAX)
8212 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 240
8213 KCC=22
8214 KFRES=25
8215
8216 ELSEIF(ISUB.EQ.6) THEN
8217C...Z0 + W+/- -> W+/-.
8218
8219 ELSEIF(ISUB.EQ.7) THEN
8220C...W+ + W- -> Z0.
8221
8222 ELSEIF(ISUB.EQ.8) THEN
8223C...W+ + W- -> H0.
8224 XH=SH/SHP
8225 250 DO 280 JT=1,2
8226 I=MINT(14+JT)
8227 IA=IABS(I)
8228 IF(IA.LE.10) THEN
8229 RVCKM=VINT(180+I)*RLU(0)
8230 DO 270 J=1,MSTP(1)
8231 IB=2*J-1+MOD(IA,2)
8232 IPM=(5-ISIGN(1,I))/2
8233 IDC=J+MDCY(IA,2)+2
8234 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
8235 MINT(20+JT)=ISIGN(IB,I)
8236 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8237 IF(RVCKM.LE.0.) GOTO 280
8238 270 CONTINUE
8239 ELSE
8240 IB=2*((IA+1)/2)-1+MOD(IA,2)
8241 MINT(20+JT)=ISIGN(IB,I)
8242 ENDIF
8243 280 PMQ(JT)=ULMASS(MINT(20+JT))
8244 JT=INT(1.5+RLU(0))
8245 ZMIN=2.*PMQ(JT)/SHPR
8246 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8247 ZMAX=MIN(1.-XH,ZMAX)
8248 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8249 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8250 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 250
8251 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8252 IF(SQC1.LT.1.E-8) GOTO 250
8253 C1=SQRT(SQC1)
8254 C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8255 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8256 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8257 Z(3-JT)=1.-XH/(1.-Z(JT))
8258 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8259 IF(SQC1.LT.1.E-8) GOTO 250
8260 C1=SQRT(SQC1)
8261 C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8262 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8263 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8264 PHIR=PARU(2)*RLU(0)
8265 CPHI=COS(PHIR)
8266 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8267 Z1=2.-Z(JT)
8268 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8269 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8270 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8271 & PMQ(3-JT)**2/SHP))
8272 ZMIN=2.*PMQ(3-JT)/SHPR
8273 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8274 ZMAX=MIN(1.-XH,ZMAX)
8275 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 250
8276 KCC=22
8277 KFRES=25
8278 ENDIF
8279
8280 ELSEIF(ISUB.LE.20) THEN
8281 IF(ISUB.EQ.11) THEN
8282C...f + f' -> f + f'; th = (p(f)-p(f))**2.
8283 KCC=MINT(2)
8284 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8285
8286 ELSEIF(ISUB.EQ.12) THEN
8287C...f + fb -> f' + fb'; th = (p(f)-p(f'))**2.
8288 MINT(21)=ISIGN(KFLQ,MINT(15))
8289 MINT(22)=-MINT(21)
8290 KCC=4
8291
8292 ELSEIF(ISUB.EQ.13) THEN
8293C...f + fb -> g + g; th arbitrary.
8294 MINT(21)=21
8295 MINT(22)=21
8296 KCC=MINT(2)+4
8297
8298 ELSEIF(ISUB.EQ.14) THEN
8299C...f + fb -> g + gam; th arbitrary.
8300 IF(RLU(0).GT.0.5) JS=2
8301 MINT(20+JS)=21
8302 MINT(23-JS)=22
8303 KCC=17+JS
8304
8305 ELSEIF(ISUB.EQ.15) THEN
8306C...f + fb -> g + Z0; th arbitrary.
8307 IF(RLU(0).GT.0.5) JS=2
8308 MINT(20+JS)=21
8309 MINT(23-JS)=23
8310 KCC=17+JS
8311
8312 ELSEIF(ISUB.EQ.16) THEN
8313C...f + fb' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
8314 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8315 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8316 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8317 MINT(20+JS)=21
8318 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8319 KCC=17+JS
8320
8321 ELSEIF(ISUB.EQ.17) THEN
8322C...f + fb -> g + H0; th arbitrary.
8323 IF(RLU(0).GT.0.5) JS=2
8324 MINT(20+JS)=21
8325 MINT(23-JS)=25
8326 KCC=17+JS
8327
8328 ELSEIF(ISUB.EQ.18) THEN
8329C...f + fb -> gamma + gamma; th arbitrary.
8330 MINT(21)=22
8331 MINT(22)=22
8332
8333 ELSEIF(ISUB.EQ.19) THEN
8334C...f + fb -> gamma + Z0; th arbitrary.
8335 IF(RLU(0).GT.0.5) JS=2
8336 MINT(20+JS)=22
8337 MINT(23-JS)=23
8338
8339 ELSEIF(ISUB.EQ.20) THEN
8340C...f + fb' -> gamma + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
8341 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8342 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8343 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8344 MINT(20+JS)=22
8345 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8346 ENDIF
8347
8348 ELSEIF(ISUB.LE.30) THEN
8349 IF(ISUB.EQ.21) THEN
8350C...f + fb -> gamma + H0; th arbitrary.
8351 IF(RLU(0).GT.0.5) JS=2
8352 MINT(20+JS)=22
8353 MINT(23-JS)=25
8354
8355 ELSEIF(ISUB.EQ.22) THEN
8356C...f + fb -> Z0 + Z0; th arbitrary.
8357 MINT(21)=23
8358 MINT(22)=23
8359
8360 ELSEIF(ISUB.EQ.23) THEN
8361C...f + fb' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
8362 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8363 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8364 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
8365 MINT(20+JS)=23
8366 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
8367
8368 ELSEIF(ISUB.EQ.24) THEN
8369C...f + fb -> Z0 + H0; th arbitrary.
8370 IF(RLU(0).GT.0.5) JS=2
8371 MINT(20+JS)=23
8372 MINT(23-JS)=25
8373
8374 ELSEIF(ISUB.EQ.25) THEN
8375C...f + fb -> W+ + W-; th = (p(f)-p(W-))**2.
8376 MINT(21)=-ISIGN(24,MINT(15))
8377 MINT(22)=-MINT(21)
8378
8379 ELSEIF(ISUB.EQ.26) THEN
8380C...f + fb' -> W+/- + H0; th = (p(f)-p(W-))**2 or (p(fb')-p(W+))**2.
8381 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8382 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8383 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
8384 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
8385 MINT(23-JS)=25
8386
8387 ELSEIF(ISUB.EQ.27) THEN
8388C...f + fb -> H0 + H0.
8389
8390 ELSEIF(ISUB.EQ.28) THEN
8391C...f + g -> f + g; th = (p(f)-p(f))**2.
8392 KCC=MINT(2)+6
8393 IF(MINT(15).EQ.21) KCC=KCC+2
8394 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
8395 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
8396
8397 ELSEIF(ISUB.EQ.29) THEN
8398C...f + g -> f + gamma; th = (p(f)-p(f))**2.
8399 IF(MINT(15).EQ.21) JS=2
8400 MINT(23-JS)=22
8401 KCC=15+JS
8402 KCS=ISIGN(1,MINT(14+JS))
8403
8404 ELSEIF(ISUB.EQ.30) THEN
8405C...f + g -> f + Z0; th = (p(f)-p(f))**2.
8406 IF(MINT(15).EQ.21) JS=2
8407 MINT(23-JS)=23
8408 KCC=15+JS
8409 KCS=ISIGN(1,MINT(14+JS))
8410 ENDIF
8411
8412 ELSEIF(ISUB.LE.40) THEN
8413 IF(ISUB.EQ.31) THEN
8414C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'.
8415 IF(MINT(15).EQ.21) JS=2
8416 I=MINT(14+JS)
8417 IA=IABS(I)
8418 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
8419 RVCKM=VINT(180+I)*RLU(0)
8420 DO 220 J=1,MSTP(1)
8421 IB=2*J-1+MOD(IA,2)
8422 IPM=(5-ISIGN(1,I))/2
8423 IDC=J+MDCY(IA,2)+2
8424 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 220
8425 MINT(20+JS)=ISIGN(IB,I)
8426 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8427 IF(RVCKM.LE.0.) GOTO 230
8428 220 CONTINUE
8429 230 KCC=15+JS
8430 KCS=ISIGN(1,MINT(14+JS))
8431
8432 ELSEIF(ISUB.EQ.32) THEN
8433C...f + g -> f + H0; th = (p(f)-p(f))**2.
8434 IF(MINT(15).EQ.21) JS=2
8435 MINT(23-JS)=25
8436 KCC=15+JS
8437 KCS=ISIGN(1,MINT(14+JS))
8438
8439 ELSEIF(ISUB.EQ.33) THEN
8440C...f + gamma -> f + g.
8441
8442 ELSEIF(ISUB.EQ.34) THEN
8443C...f + gamma -> f + gamma.
8444
8445 ELSEIF(ISUB.EQ.35) THEN
8446C...f + gamma -> f + Z0.
8447
8448 ELSEIF(ISUB.EQ.36) THEN
8449C...f + gamma -> f' + W+/-.
8450
8451 ELSEIF(ISUB.EQ.37) THEN
8452C...f + gamma -> f + H0.
8453
8454 ELSEIF(ISUB.EQ.38) THEN
8455C...f + Z0 -> f + g.
8456
8457 ELSEIF(ISUB.EQ.39) THEN
8458C...f + Z0 -> f + gamma.
8459
8460 ELSEIF(ISUB.EQ.40) THEN
8461C...f + Z0 -> f + Z0.
8462 ENDIF
8463
8464 ELSEIF(ISUB.LE.50) THEN
8465 IF(ISUB.EQ.41) THEN
8466C...f + Z0 -> f' + W+/-.
8467
8468 ELSEIF(ISUB.EQ.42) THEN
8469C...f + Z0 -> f + H0.
8470
8471 ELSEIF(ISUB.EQ.43) THEN
8472C...f + W+/- -> f' + g.
8473
8474 ELSEIF(ISUB.EQ.44) THEN
8475C...f + W+/- -> f' + gamma.
8476
8477 ELSEIF(ISUB.EQ.45) THEN
8478C...f + W+/- -> f' + Z0.
8479
8480 ELSEIF(ISUB.EQ.46) THEN
8481C...f + W+/- -> f' + W+/-.
8482
8483 ELSEIF(ISUB.EQ.47) THEN
8484C...f + W+/- -> f' + H0.
8485
8486 ELSEIF(ISUB.EQ.48) THEN
8487C...f + H0 -> f + g.
8488
8489 ELSEIF(ISUB.EQ.49) THEN
8490C...f + H0 -> f + gamma.
8491
8492 ELSEIF(ISUB.EQ.50) THEN
8493C...f + H0 -> f + Z0.
8494 ENDIF
8495
8496 ELSEIF(ISUB.LE.60) THEN
8497 IF(ISUB.EQ.51) THEN
8498C...f + H0 -> f' + W+/-.
8499
8500 ELSEIF(ISUB.EQ.52) THEN
8501C...f + H0 -> f + H0.
8502
8503 ELSEIF(ISUB.EQ.53) THEN
8504C...g + g -> f + fb; th arbitrary.
8505 KCS=(-1)**INT(1.5+RLU(0))
8506 MINT(21)=ISIGN(KFLQ,KCS)
8507 MINT(22)=-MINT(21)
8508 KCC=MINT(2)+10
8509
8510 ELSEIF(ISUB.EQ.54) THEN
8511C...g + gamma -> f + fb.
8512
8513 ELSEIF(ISUB.EQ.55) THEN
8514C...g + Z0 -> f + fb.
8515
8516 ELSEIF(ISUB.EQ.56) THEN
8517C...g + W+/- -> f + fb'.
8518
8519 ELSEIF(ISUB.EQ.57) THEN
8520C...g + H0 -> f + fb.
8521
8522 ELSEIF(ISUB.EQ.58) THEN
8523C...gamma + gamma -> f + fb.
8524
8525 ELSEIF(ISUB.EQ.59) THEN
8526C...gamma + Z0 -> f + fb.
8527
8528 ELSEIF(ISUB.EQ.60) THEN
8529C...gamma + W+/- -> f + fb'.
8530 ENDIF
8531
8532 ELSEIF(ISUB.LE.70) THEN
8533 IF(ISUB.EQ.61) THEN
8534C...gamma + H0 -> f + fb.
8535
8536 ELSEIF(ISUB.EQ.62) THEN
8537C...Z0 + Z0 -> f + fb.
8538
8539 ELSEIF(ISUB.EQ.63) THEN
8540C...Z0 + W+/- -> f + fb'.
8541
8542 ELSEIF(ISUB.EQ.64) THEN
8543C...Z0 + H0 -> f + fb.
8544
8545 ELSEIF(ISUB.EQ.65) THEN
8546C...W+ + W- -> f + fb.
8547
8548 ELSEIF(ISUB.EQ.66) THEN
8549C...W+/- + H0 -> f + fb'.
8550
8551 ELSEIF(ISUB.EQ.67) THEN
8552C...H0 + H0 -> f + fb.
8553
8554 ELSEIF(ISUB.EQ.68) THEN
8555C...g + g -> g + g; th arbitrary.
8556 KCC=MINT(2)+12
8557 KCS=(-1)**INT(1.5+RLU(0))
8558
8559 ELSEIF(ISUB.EQ.69) THEN
8560C...gamma + gamma -> W+ + W-.
8561
8562 ELSEIF(ISUB.EQ.70) THEN
8563C...gamma + W+/- -> gamma + W+/-
8564 ENDIF
8565
8566 ELSEIF(ISUB.LE.80) THEN
8567 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
8568C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-.
8569 XH=SH/SHP
8570 MINT(21)=MINT(15)
8571 MINT(22)=MINT(16)
8572 PMQ(1)=ULMASS(MINT(21))
8573 PMQ(2)=ULMASS(MINT(22))
8574 290 JT=INT(1.5+RLU(0))
8575 ZMIN=2.*PMQ(JT)/SHPR
8576 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8577 ZMAX=MIN(1.-XH,ZMAX)
8578 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8579 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8580 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 290
8581 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8582 IF(SQC1.LT.1.E-8) GOTO 290
8583 C1=SQRT(SQC1)
8584 C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8585 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8586 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8587 Z(3-JT)=1.-XH/(1.-Z(JT))
8588 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8589 IF(SQC1.LT.1.E-8) GOTO 290
8590 C1=SQRT(SQC1)
8591 C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8592 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8593 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8594 PHIR=PARU(2)*RLU(0)
8595 CPHI=COS(PHIR)
8596 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8597 Z1=2.-Z(JT)
8598 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8599 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8600 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8601 & PMQ(3-JT)**2/SHP))
8602 ZMIN=2.*PMQ(3-JT)/SHPR
8603 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8604 ZMAX=MIN(1.-XH,ZMAX)
8605 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 290
8606 KCC=22
8607
8608 ELSEIF(ISUB.EQ.73) THEN
8609C...Z0 + W+/- -> Z0 + W+/-.
8610 XH=SH/SHP
8611 300 JT=INT(1.5+RLU(0))
8612 I=MINT(14+JT)
8613 IA=IABS(I)
8614 IF(IA.LE.10) THEN
8615 RVCKM=VINT(180+I)*RLU(0)
8616 DO 320 J=1,MSTP(1)
8617 IB=2*J-1+MOD(IA,2)
8618 IPM=(5-ISIGN(1,I))/2
8619 IDC=J+MDCY(IA,2)+2
8620 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 320
8621 MINT(20+JT)=ISIGN(IB,I)
8622 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8623 IF(RVCKM.LE.0.) GOTO 330
8624 320 CONTINUE
8625 ELSE
8626 IB=2*((IA+1)/2)-1+MOD(IA,2)
8627 MINT(20+JT)=ISIGN(IB,I)
8628 ENDIF
8629 330 PMQ(JT)=ULMASS(MINT(20+JT))
8630 MINT(23-JT)=MINT(17-JT)
8631 PMQ(3-JT)=ULMASS(MINT(23-JT))
8632 JT=INT(1.5+RLU(0))
8633 ZMIN=2.*PMQ(JT)/SHPR
8634 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8635 ZMAX=MIN(1.-XH,ZMAX)
8636 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8637 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8638 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 300
8639 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8640 IF(SQC1.LT.1.E-8) GOTO 300
8641 C1=SQRT(SQC1)
8642 C2=1.+2.*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8643 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8644 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8645 Z(3-JT)=1.-XH/(1.-Z(JT))
8646 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8647 IF(SQC1.LT.1.E-8) GOTO 300
8648 C1=SQRT(SQC1)
8649 C2=1.+2.*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8650 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8651 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8652 PHIR=PARU(2)*RLU(0)
8653 CPHI=COS(PHIR)
8654 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8655 Z1=2.-Z(JT)
8656 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8657 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8658 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8659 & PMQ(3-JT)**2/SHP))
8660 ZMIN=2.*PMQ(3-JT)/SHPR
8661 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8662 ZMAX=MIN(1.-XH,ZMAX)
8663 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 300
8664 KCC=22
8665
8666 ELSEIF(ISUB.EQ.74) THEN
8667C...Z0 + H0 -> Z0 + H0.
8668
8669 ELSEIF(ISUB.EQ.75) THEN
8670C...W+ + W- -> gamma + gamma.
8671
8672 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
8673C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-.
8674 XH=SH/SHP
8675 340 DO 370 JT=1,2
8676 I=MINT(14+JT)
8677 IA=IABS(I)
8678 IF(IA.LE.10) THEN
8679 RVCKM=VINT(180+I)*RLU(0)
8680 DO 360 J=1,MSTP(1)
8681 IB=2*J-1+MOD(IA,2)
8682 IPM=(5-ISIGN(1,I))/2
8683 IDC=J+MDCY(IA,2)+2
8684 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 360
8685 MINT(20+JT)=ISIGN(IB,I)
8686 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
8687 IF(RVCKM.LE.0.) GOTO 370
8688 360 CONTINUE
8689 ELSE
8690 IB=2*((IA+1)/2)-1+MOD(IA,2)
8691 MINT(20+JT)=ISIGN(IB,I)
8692 ENDIF
8693 370 PMQ(JT)=ULMASS(MINT(20+JT))
8694 JT=INT(1.5+RLU(0))
8695 ZMIN=2.*PMQ(JT)/SHPR
8696 ZMAX=1.-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/(SHPR*(SHPR-PMQ(3-JT)))
8697 ZMAX=MIN(1.-XH,ZMAX)
8698 Z(JT)=ZMIN+(ZMAX-ZMIN)*RLU(0)
8699 IF(-1.+(1.+XH)/(1.-Z(JT))-XH/(1.-Z(JT))**2.LT.
8700 & (1.-XH)**2/(4.*XH)*RLU(0)) GOTO 340
8701 SQC1=1.-4.*PMQ(JT)**2/(Z(JT)**2*SHP)
8702 IF(SQC1.LT.1.E-8) GOTO 340
8703 C1=SQRT(SQC1)
8704 C2=1.+2.*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
8705 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8706 CTHE(JT)=MIN(1.,MAX(-1.,CTHE(JT)))
8707 Z(3-JT)=1.-XH/(1.-Z(JT))
8708 SQC1=1.-4.*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
8709 IF(SQC1.LT.1.E-8) GOTO 340
8710 C1=SQRT(SQC1)
8711 C2=1.+2.*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
8712 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2.*RLU(0)-1.)*C1))/C1
8713 CTHE(3-JT)=MIN(1.,MAX(-1.,CTHE(3-JT)))
8714 PHIR=PARU(2)*RLU(0)
8715 CPHI=COS(PHIR)
8716 ANG=CTHE(1)*CTHE(2)-SQRT(1.-CTHE(1)**2)*SQRT(1.-CTHE(2)**2)*CPHI
8717 Z1=2.-Z(JT)
8718 Z2=ANG*SQRT(Z(JT)**2-4.*PMQ(JT)**2/SHP)
8719 Z3=1.-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
8720 Z(3-JT)=2./(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
8721 & PMQ(3-JT)**2/SHP))
8722 ZMIN=2.*PMQ(3-JT)/SHPR
8723 ZMAX=1.-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
8724 ZMAX=MIN(1.-XH,ZMAX)
8725 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
8726 KCC=22
8727
8728 ELSEIF(ISUB.EQ.78) THEN
8729C...W+/- + H0 -> W+/- + H0.
8730
8731 ELSEIF(ISUB.EQ.79) THEN
8732C...H0 + H0 -> H0 + H0.
8733 ENDIF
8734
8735 ELSEIF(ISUB.LE.90) THEN
8736 IF(ISUB.EQ.81) THEN
8737C...q + qb -> Q' + Qb'; th = (p(q)-p(q'))**2.
8738 MINT(21)=ISIGN(MINT(46),MINT(15))
8739 MINT(22)=-MINT(21)
8740 KCC=4
8741
8742 ELSEIF(ISUB.EQ.82) THEN
8743C...g + g -> Q + Qb; th arbitrary.
8744 KCS=(-1)**INT(1.5+RLU(0))
8745 MINT(21)=ISIGN(MINT(46),KCS)
8746 MINT(22)=-MINT(21)
8747 KCC=MINT(2)+10
8748 ENDIF
8749
8750 ELSEIF(ISUB.LE.100) THEN
8751 IF(ISUB.EQ.95) THEN
8752C...Low-pT ( = energyless g + g -> g + g).
8753 KCC=MINT(2)+12
8754 KCS=(-1)**INT(1.5+RLU(0))
8755
8756 ELSEIF(ISUB.EQ.96) THEN
8757C...Multiple interactions (should be reassigned to QCD process).
8758 ENDIF
8759
8760 ELSEIF(ISUB.LE.110) THEN
8761 IF(ISUB.EQ.101) THEN
8762C...g + g -> gamma*/Z0.
8763 KCC=21
8764 KFRES=22
8765
8766 ELSEIF(ISUB.EQ.102) THEN
8767C...g + g -> H0.
8768 KCC=21
8769 KFRES=25
8770 ENDIF
8771
8772 ELSEIF(ISUB.LE.120) THEN
8773 IF(ISUB.EQ.111) THEN
8774C...f + fb -> g + H0; th arbitrary.
8775 IF(RLU(0).GT.0.5) JS=2
8776 MINT(20+JS)=21
8777 MINT(23-JS)=25
8778 KCC=17+JS
8779
8780 ELSEIF(ISUB.EQ.112) THEN
8781C...f + g -> f + H0; th = (p(f) - p(f))**2.
8782 IF(MINT(15).EQ.21) JS=2
8783 MINT(23-JS)=25
8784 KCC=15+JS
8785 KCS=ISIGN(1,MINT(14+JS))
8786
8787 ELSEIF(ISUB.EQ.113) THEN
8788C...g + g -> g + H0; th arbitrary.
8789 IF(RLU(0).GT.0.5) JS=2
8790 MINT(23-JS)=25
8791 KCC=22+JS
8792 KCS=(-1)**INT(1.5+RLU(0))
8793
8794 ELSEIF(ISUB.EQ.114) THEN
8795C...g + g -> gamma + gamma; th arbitrary.
8796 IF(RLU(0).GT.0.5) JS=2
8797 MINT(21)=22
8798 MINT(22)=22
8799 KCC=21
8800
8801 ELSEIF(ISUB.EQ.115) THEN
8802C...g + g -> gamma + Z0.
8803
8804 ELSEIF(ISUB.EQ.116) THEN
8805C...g + g -> Z0 + Z0.
8806
8807 ELSEIF(ISUB.EQ.117) THEN
8808C...g + g -> W+ + W-.
8809 ENDIF
8810
8811 ELSEIF(ISUB.LE.140) THEN
8812 IF(ISUB.EQ.121) THEN
8813C...g + g -> f + fb + H0.
8814 ENDIF
8815
8816 ELSEIF(ISUB.LE.160) THEN
8817 IF(ISUB.EQ.141) THEN
8818C...f + fb -> gamma*/Z0/Z'0.
8819 KFRES=32
8820
8821 ELSEIF(ISUB.EQ.142) THEN
8822C...f + fb' -> H+/-.
8823 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
8824 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
8825 KFRES=ISIGN(37,KCH1+KCH2)
8826
8827 ELSEIF(ISUB.EQ.143) THEN
8828C...f + fb' -> R.
8829 KFRES=ISIGN(40,MINT(15)+MINT(16))
8830 ENDIF
8831
8832 ELSE
8833 IF(ISUB.EQ.161) THEN
8834C...g + f -> H+/- + f'; th = (p(f)-p(f))**2.
8835 IF(MINT(16).EQ.21) JS=2
8836 IA=IABS(MINT(17-JS))
8837 MINT(20+JS)=ISIGN(37,KCHG(IA,1)*MINT(17-JS))
8838 JA=IA+MOD(IA,2)-MOD(IA+1,2)
8839 MINT(23-JS)=ISIGN(JA,MINT(17-JS))
8840 KCC=18-JS
8841 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
8842 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
8843 ENDIF
8844 ENDIF
8845
8846 IF(IDOC.EQ.7) THEN
8847C...Resonance not decaying: store colour connection indices.
8848 I=MINT(83)+7
8849 K(IPU3,1)=1
8850 K(IPU3,2)=KFRES
8851 K(IPU3,3)=I
8852 P(IPU3,4)=SHUSER
8853 P(IPU3,5)=SHUSER
8854 K(IPU1,4)=IPU2
8855 K(IPU1,5)=IPU2
8856 K(IPU2,4)=IPU1
8857 K(IPU2,5)=IPU1
8858 K(I,1)=21
8859 K(I,2)=KFRES
8860 P(I,4)=SHUSER
8861 P(I,5)=SHUSER
8862 N=IPU3
8863 MINT(21)=KFRES
8864 MINT(22)=0
8865
8866 ELSEIF(IDOC.EQ.8) THEN
8867C...2 -> 2 processes: store outgoing partons in their CM-frame.
8868 DO 390 JT=1,2
8869 I=MINT(84)+2+JT
8870 K(I,1)=1
8871 IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
8872 K(I,2)=MINT(20+JT)
8873 K(I,3)=MINT(83)+IDOC+JT-2
8874 IF(IABS(K(I,2)).LE.10.OR.K(I,2).EQ.21) THEN
8875 P(I,5)=ULMASS(K(I,2))
8876 ELSE
8877 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8878 ENDIF
8879 390 CONTINUE
8880 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
8881 KFA1=IABS(MINT(21))
8882 KFA2=IABS(MINT(22))
8883 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
8884 & THEN
8885 MINT(51)=1
8886 RETURN
8887 ENDIF
8888 P(IPU3,5)=0.
8889 P(IPU4,5)=0.
8890 ENDIF
8891 P(IPU3,4)=0.5*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
8892 P(IPU3,3)=SQRT(MAX(0.,P(IPU3,4)**2-P(IPU3,5)**2))
8893 P(IPU4,4)=SHR-P(IPU3,4)
8894 P(IPU4,3)=-P(IPU3,3)
8895 N=IPU4
8896 MINT(7)=MINT(83)+7
8897 MINT(8)=MINT(83)+8
8898
8899C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4).
8900 CALL LUDBRB(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
8901
8902 ELSEIF(IDOC.EQ.9) THEN
8903C'''2 -> 3 processes:
8904
8905 ELSEIF(IDOC.EQ.11) THEN
8906C...Z0 + Z0 -> H0, W+ + W- -> H0: store Higgs and outgoing partons.
8907 PHI(1)=PARU(2)*RLU(0)
8908 PHI(2)=PHI(1)-PHIR
8909 DO 400 JT=1,2
8910 I=MINT(84)+2+JT
8911 K(I,1)=1
8912 IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
8913 K(I,2)=MINT(20+JT)
8914 K(I,3)=MINT(83)+IDOC+JT-2
8915 P(I,5)=ULMASS(K(I,2))
8916 IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.
8917 PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))
8918 PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2))
8919 P(I,1)=PTABS*COS(PHI(JT))
8920 P(I,2)=PTABS*SIN(PHI(JT))
8921 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8922 P(I,4)=0.5*SHPR*Z(JT)
8923 IZW=MINT(83)+6+JT
8924 K(IZW,1)=21
8925 K(IZW,2)=23
8926 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT)))
8927 K(IZW,3)=IZW-2
8928 P(IZW,1)=-P(I,1)
8929 P(IZW,2)=-P(I,2)
8930 P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8931 P(IZW,4)=0.5*SHPR*(1.-Z(JT))
8932 400 P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8933 I=MINT(83)+9
8934 K(IPU5,1)=1
8935 K(IPU5,2)=KFRES
8936 K(IPU5,3)=I
8937 P(IPU5,5)=SHR
8938 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8939 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8940 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
8941 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
8942 K(I,1)=21
8943 K(I,2)=KFRES
8944 DO 410 J=1,5
8945 410 P(I,J)=P(IPU5,J)
8946 N=IPU5
8947 MINT(23)=KFRES
8948
8949 ELSEIF(IDOC.EQ.12) THEN
8950C...Z0 and W+/- scattering: store bosons and outgoing partons.
8951 PHI(1)=PARU(2)*RLU(0)
8952 PHI(2)=PHI(1)-PHIR
8953 DO 420 JT=1,2
8954 I=MINT(84)+2+JT
8955 K(I,1)=1
8956 IF(IABS(MINT(20+JT)).LE.10.OR.MINT(20+JT).EQ.21) K(I,1)=3
8957 K(I,2)=MINT(20+JT)
8958 K(I,3)=MINT(83)+IDOC+JT-2
8959 P(I,5)=ULMASS(K(I,2))
8960 IF(0.5*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0.
8961 PABS=SQRT(MAX(0.,(0.5*SHPR*Z(JT))**2-P(I,5)**2))
8962 PTABS=PABS*SQRT(MAX(0.,1.-CTHE(JT)**2))
8963 P(I,1)=PTABS*COS(PHI(JT))
8964 P(I,2)=PTABS*SIN(PHI(JT))
8965 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8966 P(I,4)=0.5*SHPR*Z(JT)
8967 IZW=MINT(83)+6+JT
8968 K(IZW,1)=21
8969 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
8970 K(IZW,2)=23
8971 ELSE
8972 K(IZW,2)=ISIGN(24,LUCHGE(MINT(14+JT))-LUCHGE(MINT(20+JT)))
8973 ENDIF
8974 K(IZW,3)=IZW-2
8975 P(IZW,1)=-P(I,1)
8976 P(IZW,2)=-P(I,2)
8977 P(IZW,3)=(0.5*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8978 P(IZW,4)=0.5*SHPR*(1.-Z(JT))
8979 P(IZW,5)=-SQRT(MAX(0.,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8980 IPU=MINT(84)+4+JT
8981 K(IPU,1)=3
8982 K(IPU,2)=KFPR(ISUB,JT)
8983 K(IPU,3)=MINT(83)+8+JT
8984 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
8985 P(IPU,5)=ULMASS(K(IPU,2))
8986 ELSE
8987 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8988 ENDIF
8989 MINT(22+JT)=K(IZW,2)
8990 420 CONTINUE
8991 IF(ISUB.EQ.72) K(MINT(84)+4+INT(1.5+RLU(0)),2)=-24
8992C...Find rotation and boost for hard scattering subsystem.
8993 I1=MINT(83)+7
8994 I2=MINT(83)+8
8995 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
8996 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
8997 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
8998 GAMCM=(P(I1,4)+P(I2,4))/SHR
8999 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
9000 PX=P(I1,1)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEXCM
9001 PY=P(I1,2)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEYCM
9002 PZ=P(I1,3)+GAMCM*(GAMCM/(1.+GAMCM)*BEPCM-P(I1,4))*BEZCM
9003 THECM=ULANGL(PZ,SQRT(PX**2+PY**2))
9004 PHICM=ULANGL(PX,PY)
9005C...Store hard scattering subsystem. Rotate and boost it.
9006 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4.*P(IPU5,5)**2*
9007 & P(IPU6,5)**2
9008 PABS=SQRT(MAX(0.,SQLAM/(4.*SH)))
9009 CTHWZ=VINT(23)
9010 STHWZ=SQRT(MAX(0.,1.-CTHWZ**2))
9011 PHIWZ=VINT(24)-PHICM
9012 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
9013 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
9014 P(IPU5,3)=PABS*CTHWZ
9015 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
9016 P(IPU6,1)=-P(IPU5,1)
9017 P(IPU6,2)=-P(IPU5,2)
9018 P(IPU6,3)=-P(IPU5,3)
9019 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
9020 CALL LUDBRB(IPU5,IPU6,THECM,PHICM,DBLE(BEXCM),DBLE(BEYCM),
9021 & DBLE(BEZCM))
9022 DO 430 JT=1,2
9023 I1=MINT(83)+8+JT
9024 I2=MINT(84)+4+JT
9025 K(I1,1)=21
9026 K(I1,2)=K(I2,2)
9027 DO 430 J=1,5
9028 430 P(I1,J)=P(I2,J)
9029 N=IPU6
9030 MINT(7)=MINT(83)+9
9031 MINT(8)=MINT(83)+10
9032 ENDIF
9033
9034 IF(IDOC.GE.8) THEN
9035C...Store colour connection indices.
9036 DO 440 J=1,2
9037 JC=J
9038 IF(KCS.EQ.-1) JC=3-J
9039 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
9040 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
9041 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
9042 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
9043 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
9044 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
9045 440 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
9046 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
9047
9048C...Copy outgoing partons to documentation lines.
9049 DO 450 I=1,2
9050 I1=MINT(83)+IDOC-2+I
9051 I2=MINT(84)+2+I
9052 K(I1,1)=21
9053 K(I1,2)=K(I2,2)
9054 IF(IDOC.LE.9) K(I1,3)=0
9055 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
9056 DO 450 J=1,5
9057 450 P(I1,J)=P(I2,J)
9058 ENDIF
9059 MINT(52)=N
9060
9061C...Low-pT events: remove gluons used for string drawing purposes.
9062 IF(ISUB.EQ.95) THEN
9063 K(IPU3,1)=K(IPU3,1)+10
9064 K(IPU4,1)=K(IPU4,1)+10
9065 DO 460 J=41,66
9066 460 VINT(J)=0.
9067 DO 470 I=MINT(83)+5,MINT(83)+8
9068 DO 470 J=1,5
9069 470 P(I,J)=0.
9070 ENDIF
9071
9072 RETURN
9073 END
9074
9075C*********************************************************************
9076
ce320da8 9077 SUBROUTINE PYSSPAA(IPU1,IPU2)
0119ef9a 9078
9079C...Generates spacelike parton showers.
9080 IMPLICIT DOUBLE PRECISION(D)
9081 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
9082 SAVE /LUJETSA/
9083 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9084 SAVE /LUDAT1A/
9085 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9086 SAVE /LUDAT2A/
9087 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
9088 SAVE /PYSUBSA/
9089 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
9090 SAVE /PYPARSA/
9091 COMMON/PYINT1A/MINT(400),VINT(400)
9092 SAVE /PYINT1A/
9093 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
9094 SAVE /PYINT2A/
9095 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9096 SAVE /PYINT3A/
9097 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVS(2),ROBO(5),
9098 &XFS(2,-6:6),XFA(-6:6),XFB(-6:6),XFN(-6:6),WTAP(-6:6),WTSF(-6:6),
9099 &THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),DPB(4)
9100
9101 tevb=0.
9102 kfla=0
9103 z=0.
9104 the2t=0.
9105 ipo=0
9106 dmsma=0.
9107 dpt2=0.
9108
9109C...Calculate maximum virtuality and check that evolution possible.
9110 IPUS1=IPU1
9111 IPUS2=IPU2
9112 ISUB=MINT(1)
9113 Q2E=VINT(52)
9114 IF(ISET(ISUB).EQ.1) THEN
9115 Q2E=Q2E/PARP(67)
9116 ELSEIF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
9117 Q2E=PMAS(23,1)**2
9118 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2E=PMAS(24,1)**2
9119 ENDIF
9120 TMAX=LOG(PARP(67)*PARP(63)*Q2E/PARP(61)**2)
9121 IF(PARP(67)*Q2E.LT.MAX(PARP(62)**2,2.*PARP(61)**2).OR.
9122 &TMAX.LT.0.2) RETURN
9123
9124C...Common constants and initial values. Save normal Lambda value.
9125 XE0=2.*PARP(65)/VINT(1)
9126 ALAMS=PARU(111)
9127 PARU(111)=PARP(61)
9128 NS=N
9129 100 N=NS
9130 DO 110 JT=1,2
9131 KFLS(JT)=MINT(14+JT)
9132 KFLS(JT+2)=KFLS(JT)
9133 XS(JT)=VINT(40+JT)
9134 ZS(JT)=1.
9135 Q2S(JT)=PARP(67)*Q2E
9136 TEVS(JT)=TMAX
9137 ALAM(JT)=PARP(61)
9138 THE2(JT)=100.
9139 DO 110 KFL=-6,6
9140 110 XFS(JT,KFL)=XSFX(JT,KFL)
9141 DSH=dble(VINT(44))
9142 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) DSH=dble(VINT(26)*VINT(2))
9143
9144C...Pick up leg with highest virtuality.
9145 120 N=N+1
9146 JT=1
9147 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
9148 KFLB=KFLS(JT)
9149 XB=XS(JT)
9150 DO 130 KFL=-6,6
9151 130 XFB(KFL)=XFS(JT,KFL)
9152 DSHR=2D0*SQRT(DSH)
9153 DSHZ=DSH/DBLE(ZS(JT))
9154 XE=MAX(XE0,XB*(1./(1.-PARP(66))-1.))
9155 IF(XB+XE.GE.0.999) THEN
9156 Q2B=0.
9157 GOTO 220
9158 ENDIF
9159
9160C...Maximum Q2 without or with Q2 ordering. Effective Lambda and n_f.
9161 IF(MSTP(62).LE.1) THEN
9162 Q2B=0.5*(1./ZS(JT)+1.)*Q2S(JT)+0.5*(1./ZS(JT)-1.)*(Q2S(3-JT)-
9163 & SNGL(DSH)+SQRT((SNGL(DSH)+Q2S(1)+Q2S(2))**2+8.*Q2S(1)*Q2S(2)*
9164 & ZS(JT)/(1.-ZS(JT))))
9165 TEVB=LOG(PARP(63)*Q2B/ALAM(JT)**2)
9166 ELSE
9167 Q2B=Q2S(JT)
9168 TEVB=TEVS(JT)
9169 ENDIF
9170 ALSDUM=ULALPS(PARP(63)*Q2B)
9171 TEVB=TEVB+2.*LOG(ALAM(JT)/PARU(117))
9172 TEVBSV=TEVB
9173 ALAM(JT)=PARU(117)
9174 B0=(33.-2.*MSTU(118))/6.
9175
9176C...Calculate Altarelli-Parisi and structure function weights.
9177 DO 140 KFL=-6,6
9178 WTAP(KFL)=0.
9179 140 WTSF(KFL)=0.
9180 IF(KFLB.EQ.21) THEN
9181 WTAPQ=16.*(1.-SQRT(XB+XE))/(3.*SQRT(XB))
9182 DO 150 KFL=-MSTP(54),MSTP(54)
9183 IF(KFL.EQ.0) WTAP(KFL)=6.*LOG((1.-XB)/XE)
9184 150 IF(KFL.NE.0) WTAP(KFL)=WTAPQ
9185 ELSE
9186 WTAP(0)=0.5*XB*(1./(XB+XE)-1.)
9187 WTAP(KFLB)=8.*LOG((1.-XB)*(XB+XE)/XE)/3.
9188 ENDIF
9189 160 WTSUM=0.
9190 IF(KFLB.NE.21) XFBO=XFB(KFLB)
9191 IF(KFLB.EQ.21) XFBO=XFB(0)
9192C***************************************************************
9193C**********ERROR HAS OCCURED HERE
9194 IF(XFBO.EQ.0.0) THEN
9195 WRITE(MSTU(11),1000)
9196 WRITE(MSTU(11),1001) KFLB,XFB(KFLB)
9197 XFBO=0.00001
9198 ENDIF
9199C****************************************************************
9200 DO 170 KFL=-MSTP(54),MSTP(54)
9201 WTSF(KFL)=XFB(KFL)/XFBO
9202 170 WTSUM=WTSUM+WTAP(KFL)*WTSF(KFL)
9203 WTSUM=MAX(0.0001,WTSUM)
9204
9205C...Choose new t: fix alpha_s, alpha_s(Q2), alpha_s(k_T2).
9206 180 IF(MSTP(64).LE.0) THEN
9207 TEVB=TEVB+LOG(RLU(0))*PARU(2)/(PARU(111)*WTSUM)
9208 ELSEIF(MSTP(64).EQ.1) THEN
9209 TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/WTSUM))
9210 ELSE
9211 TEVB=TEVB*EXP(MAX(-100.,LOG(RLU(0))*B0/(5.*WTSUM)))
9212 ENDIF
9213 190 Q2REF=ALAM(JT)**2*EXP(TEVB)
9214 Q2B=Q2REF/PARP(63)
9215
9216C...Evolution ended or select flavour for branching parton.
9217 IF(Q2B.LT.PARP(62)**2) THEN
9218 Q2B=0.
9219 ELSE
9220 WTRAN=RLU(0)*WTSUM
9221 KFLA=-MSTP(54)-1
9222 200 KFLA=KFLA+1
9223 WTRAN=WTRAN-WTAP(KFLA)*WTSF(KFLA)
9224 IF(KFLA.LT.MSTP(54).AND.WTRAN.GT.0.) GOTO 200
9225 IF(KFLA.EQ.0) KFLA=21
9226
9227C...Choose z value and corrective weight.
9228 IF(KFLB.EQ.21.AND.KFLA.EQ.21) THEN
9229 Z=1./(1.+((1.-XB)/XB)*(XE/(1.-XB))**RLU(0))
9230 WTZ=(1.-Z*(1.-Z))**2
9231 ELSEIF(KFLB.EQ.21) THEN
9232 Z=XB/(1.-RLU(0)*(1.-SQRT(XB+XE)))**2
9233 WTZ=0.5*(1.+(1.-Z)**2)*SQRT(Z)
9234 ELSEIF(KFLA.EQ.21) THEN
9235 Z=XB*(1.+RLU(0)*(1./(XB+XE)-1.))
9236 WTZ=1.-2.*Z*(1.-Z)
9237 ELSE
9238 Z=1.-(1.-XB)*(XE/((XB+XE)*(1.-XB)))**RLU(0)
9239 WTZ=0.5*(1.+Z**2)
9240 ENDIF
9241
9242C...Option with resummation of soft gluon emission as effective z shift.
9243 IF(MSTP(65).GE.1) THEN
9244 RSOFT=6.
9245 IF(KFLB.NE.21) RSOFT=8./3.
9246 Z=Z*(TEVB/TEVS(JT))**(RSOFT*XE/((XB+XE)*B0))
9247 IF(Z.LE.XB) GOTO 180
9248 ENDIF
9249
9250C...Option with alpha_s(k_T2)Q2): demand k_T2 > cutoff, reweight.
9251 IF(MSTP(64).GE.2) THEN
9252 IF((1.-Z)*Q2B.LT.PARP(62)**2) GOTO 180
9253 ALPRAT=TEVB/(TEVB+LOG(1.-Z))
9254 IF(ALPRAT.LT.5.*RLU(0)) GOTO 180
9255 IF(ALPRAT.GT.5.) WTZ=WTZ*ALPRAT/5.
9256 ENDIF
9257
9258C...Option with angular ordering requirement.
9259 IF(MSTP(62).GE.3) THEN
9260 THE2T=(4.*Z**2*Q2B)/(VINT(2)*(1.-Z)*XB**2)
9261 IF(THE2T.GT.THE2(JT)) GOTO 180
9262 ENDIF
9263
9264C...Weighting with new structure functions.
9265 CALL PYSTFU(MINT(10+JT),XB,Q2REF,XFN,JT)
9266 IF(KFLB.NE.21) XFBN=XFN(KFLB)
9267 IF(KFLB.EQ.21) XFBN=XFN(0)
9268 IF(XFBN.LT.1E-20) THEN
9269 IF(KFLA.EQ.KFLB) THEN
9270 TEVB=TEVBSV
9271 WTAP(KFLB)=0.
9272 GOTO 160
9273 ELSEIF(TEVBSV-TEVB.GT.0.2) THEN
9274 TEVB=0.5*(TEVBSV+TEVB)
9275 GOTO 190
9276 ELSE
9277 XFBN=1E-10
9278 ENDIF
9279 ENDIF
9280 DO 210 KFL=-MSTP(54),MSTP(54)
9281 210 XFB(KFL)=XFN(KFL)
9282 XA=XB/Z
9283 CALL PYSTFU(MINT(10+JT),XA,Q2REF,XFA,JT)
9284 IF(KFLA.NE.21) XFAN=XFA(KFLA)
9285 IF(KFLA.EQ.21) XFAN=XFA(0)
9286 IF(XFAN.LT.1E-20) GOTO 160
9287 IF(KFLA.NE.21) WTSFA=WTSF(KFLA)
9288 IF(KFLA.EQ.21) WTSFA=WTSF(0)
9289 IF(WTZ*XFAN/XFBN.LT.RLU(0)*WTSFA) GOTO 160
9290 ENDIF
9291
9292C...Define two hard scatterers in their CM-frame.
9293 220 IF(N.EQ.NS+2) THEN
9294 DQ2(JT)=dble(Q2B)
9295 DPLCM=DSQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
9296 DO 240 JR=1,2
9297 I=NS+JR
9298 IF(JR.EQ.1) IPO=IPUS1
9299 IF(JR.EQ.2) IPO=IPUS2
9300 DO 230 J=1,5
9301 K(I,J)=0
9302 P(I,J)=0.
9303 230 V(I,J)=0.
9304 K(I,1)=14
9305 K(I,2)=KFLS(JR+2)
9306 K(I,4)=IPO
9307 K(I,5)=IPO
9308 P(I,3)=sngl(DPLCM)*(-1)**(JR+1)
9309 P(I,4)=sngl((DSH+DQ2(3-JR)-DQ2(JR))/DSHR)
9310 P(I,5)=-SQRT(SNGL(DQ2(JR)))
9311 K(IPO,1)=14
9312 K(IPO,3)=I
9313 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
9314 240 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
9315
9316C...Find maximum allowed mass of timelike parton.
9317 ELSEIF(N.GT.NS+2) THEN
9318 JR=3-JT
9319 DQ2(3)=dble(Q2B)
9320 DPC(1)=dble(P(IS(1),4))
9321 DPC(2)=dble(P(IS(2),4))
9322 DPC(3)=dble(0.5*(ABS(P(IS(1),3))+ABS(P(IS(2),3))))
9323 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
9324 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
9325 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
9326 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
9327 IKIN=0
9328 IF(Q2S(JR).GE.(0.5*PARP(62))**2.AND.DPD(1)-DPD(3).GE.
9329 & 1D-10*DPD(1)) IKIN=1
9330 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/DBLE(ZS(JT))-DQ2(3))*(DSH/
9331 & (DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
9332 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/(2.d0*
9333 & DQ2(JR))-DQ2(JT)-DQ2(3)
9334
9335C...Generate timelike parton shower (if required).
9336 IT=N
9337 DO 250 J=1,5
9338 K(IT,J)=0
9339 P(IT,J)=0.
9340 250 V(IT,J)=0.
9341 K(IT,1)=3
9342 K(IT,2)=21
9343 IF(KFLB.EQ.21.AND.KFLS(JT+2).NE.21) K(IT,2)=-KFLS(JT+2)
9344 IF(KFLB.NE.21.AND.KFLS(JT+2).EQ.21) K(IT,2)=KFLB
9345 P(IT,5)=ULMASS(K(IT,2))
9346 IF(SNGL(DMSMA).LE.P(IT,5)**2) GOTO 100
9347 IF(MSTP(63).GE.1) THEN
9348 P(IT,4)=sngl((DSHZ-DSH-dble(P(IT,5))**2)/DSHR)
9349 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
9350 IF(MSTP(63).EQ.1) THEN
9351 Q2TIM=sngl(DMSMA)
9352 ELSEIF(MSTP(63).EQ.2) THEN
9353 Q2TIM=MIN(SNGL(DMSMA),PARP(71)*Q2S(JT))
9354 ELSE
9355C'''Here remains to introduce angular ordering in first branching.
9356 Q2TIM=sngl(DMSMA)
9357 ENDIF
9358 CALL LUSHOW(IT,0,SQRT(Q2TIM))
9359 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
9360 ENDIF
9361
9362C...Reconstruct kinematics of branching: timelike parton shower.
9363 DMS=dble(P(IT,5)**2)
9364 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9365 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5d0*DPD(1)*DPD(2)
9366 & +0.5d0*DPD(3)*
9367 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/(4.d0*DSH*DPC(3)**2)
9368 IF(DPT2.LT.0.d0) GOTO 100
9369 DPB(1)=(0.5d0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
9370 & DSHR)/DPC(3)-DPC(3)
9371 P(IT,1)=SQRT(SNGL(DPT2))
9372 P(IT,3)=sngl(DPB(1))*(-1)**(JT+1)
9373 P(IT,4)=sngl((DSHZ-DSH-DMS)/DSHR)
9374 IF(N.GE.IT+1) THEN
9375 DPB(1)=SQRT(DPB(1)**2+DPT2)
9376 DPB(2)=SQRT(DPB(1)**2+DMS)
9377 DPB(3)=dble(P(IT+1,3))
9378 DPB(4)=SQRT(DPB(3)**2+DMS)
9379 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
9380 & DPB(1))
9381 CALL LUDBRB(IT+1,N,0.,0.,0D0,0D0,DBEZ)
9382 THE=ULANGL(P(IT,3),P(IT,1))
9383 CALL LUDBRB(IT+1,N,THE,0.,0D0,0D0,0D0)
9384 ENDIF
9385
9386C...Reconstruct kinematics of branching: spacelike parton.
9387 DO 260 J=1,5
9388 K(N+1,J)=0
9389 P(N+1,J)=0.
9390 260 V(N+1,J)=0.
9391 K(N+1,1)=14
9392 K(N+1,2)=KFLB
9393 P(N+1,1)=P(IT,1)
9394 P(N+1,3)=P(IT,3)+P(IS(JT),3)
9395 P(N+1,4)=P(IT,4)+P(IS(JT),4)
9396 P(N+1,5)=-SQRT(SNGL(DQ2(3)))
9397
9398C...Define colour flow of branching.
9399 K(IS(JT),3)=N+1
9400 K(IT,3)=N+1
9401 ID1=IT
9402 IF((K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(ID1,2).GT.0.AND.
9403 & K(ID1,2).NE.21).OR.(K(N+1,2).LT.0.AND.K(ID1,2).EQ.21).OR.
9404 & (K(N+1,2).EQ.21.AND.K(ID1,2).EQ.21.AND.RLU(0).GT.0.5).OR.
9405 & (K(N+1,2).EQ.21.AND.K(ID1,2).LT.0)) ID1=IS(JT)
9406 ID2=IT+IS(JT)-ID1
9407 K(N+1,4)=K(N+1,4)+ID1
9408 K(N+1,5)=K(N+1,5)+ID2
9409 K(ID1,4)=K(ID1,4)+MSTU(5)*(N+1)
9410 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
9411 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
9412 K(ID2,5)=K(ID2,5)+MSTU(5)*(N+1)
9413 N=N+1
9414
9415C...Boost to new CM-frame.
9416 CALL LUDBRB(NS+1,N,0.,0.,-DBLE((P(N,1)+P(IS(JR),1))/(P(N,4)+
9417 & P(IS(JR),4))),0D0,-DBLE((P(N,3)+P(IS(JR),3))/(P(N,4)+
9418 & P(IS(JR),4))))
9419 IR=N+(JT-1)*(IS(1)-N)
9420 CALL LUDBRB(NS+1,N,-ULANGL(P(IR,3),P(IR,1)),PARU(2)*RLU(0),
9421 & 0D0,0D0,0D0)
9422 ENDIF
9423
9424C...Save quantities, loop back.
9425 IS(JT)=N
9426 Q2S(JT)=Q2B
9427 DQ2(JT)=dble(Q2B)
9428 IF(MSTP(62).GE.3) THE2(JT)=THE2T
9429 DSH=DSHZ
9430 IF(Q2B.GE.(0.5*PARP(62))**2) THEN
9431 KFLS(JT+2)=KFLS(JT)
9432 KFLS(JT)=KFLA
9433 XS(JT)=XA
9434 ZS(JT)=Z
9435 DO 270 KFL=-6,6
9436 270 XFS(JT,KFL)=XFA(KFL)
9437 TEVS(JT)=TEVB
9438 ELSE
9439 IF(JT.EQ.1) IPU1=N
9440 IF(JT.EQ.2) IPU2=N
9441 ENDIF
9442 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
ce320da8 9443 CALL LUERRM(11,'(PYSSPAS:) no more memory left in LUJETSA')
0119ef9a 9444 IF(MSTU(21).GE.1) N=NS
9445 IF(MSTU(21).GE.1) RETURN
9446 ENDIF
9447 IF(MAX(Q2S(1),Q2S(2)).GE.(0.5*PARP(62))**2.OR.N.LE.NS+1) GOTO 120
9448
9449C...Boost hard scattering partons to frame of shower initiators.
9450 DO 280 J=1,3
9451 280 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
9452 DO 290 J=1,5
9453 290 P(N+2,J)=P(NS+1,J)
9454 ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
9455 IF(ROBOT.GE.0.999999) THEN
9456 ROBOT=1.00001*SQRT(ROBOT)
9457 ROBO(3)=ROBO(3)/ROBOT
9458 ROBO(4)=ROBO(4)/ROBOT
9459 ROBO(5)=ROBO(5)/ROBOT
9460 ENDIF
9461 CALL LUDBRB(N+2,N+2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),
9462 &-DBLE(ROBO(5)))
9463 ROBO(2)=ULANGL(P(N+2,1),P(N+2,2))
9464 ROBO(1)=ULANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
9465 CALL LUDBRB(MINT(83)+5,NS,ROBO(1),ROBO(2),DBLE(ROBO(3)),
9466 &DBLE(ROBO(4)),DBLE(ROBO(5)))
9467
9468C...Store user information. Reset Lambda value.
9469 K(IPU1,3)=MINT(83)+3
9470 K(IPU2,3)=MINT(83)+4
9471 DO 300 JT=1,2
9472 MINT(12+JT)=KFLS(JT)
9473 300 VINT(140+JT)=XS(JT)
9474 PARU(111)=ALAMS
9475 1000 FORMAT(5X,'structure function has a zero point here')
9476 1001 FORMAT(5X,'xf(x,i=',I5,')=',F10.5)
9477
9478 RETURN
9479 END
9480
9481C*********************************************************************
9482
ce320da8 9483 SUBROUTINE PYMULTA(MMUL)
0119ef9a 9484
9485C...Initializes treatment of multiple interactions, selects kinematics
9486C...of hardest interaction if low-pT physics included in run, and
9487C...generates all non-hardest interactions.
9488 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
9489 SAVE /LUJETSA/
9490 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9491 SAVE /LUDAT1A/
9492 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9493 SAVE /LUDAT2A/
9494 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
9495 SAVE /PYSUBSA/
9496 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
9497 SAVE /PYPARSA/
9498 COMMON/PYINT1A/MINT(400),VINT(400)
9499 SAVE /PYINT1A/
9500 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
9501 SAVE /PYINT2A/
9502 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9503 SAVE /PYINT3A/
9504 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
9505 SAVE /PYINT5A/
9506 DIMENSION NMUL(20),SIGM(20),KSTR(500,2)
9507 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
9508
9509 xf=0.
9510 yf=0.
9511 deltab=0.
9512 ist1=0
9513 ist2=0
9514 istm=0
9515
9516C...Initialization of multiple interaction treatment.
9517 IF(MMUL.EQ.1) THEN
9518 IF(MSTP(122).GE.1) WRITE(MSTU(11),1000) MSTP(82)
9519 ISUB=96
9520 MINT(1)=96
9521 VINT(63)=0.
9522 VINT(64)=0.
9523 VINT(143)=1.
9524 VINT(144)=1.
9525
9526C...Loop over phase space points: xT2 choice in 20 bins.
9527 100 SIGSUM=0.
9528 DO 120 IXT2=1,20
9529 NMUL(IXT2)=MSTP(83)
9530 SIGM(IXT2)=0.
9531 DO 110 ITRY=1,MSTP(83)
9532 RSCA=0.05*((21-IXT2)-RLU(0))
9533 XT2=VINT(149)*(1.+VINT(149))/(VINT(149)+RSCA)-VINT(149)
9534 XT2=MAX(0.01*VINT(149),XT2)
9535 VINT(25)=XT2
9536
9537C...Choose tau and y*. Calculate cos(theta-hat).
9538 IF(RLU(0).LE.COEF(ISUB,1)) THEN
9539 TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
9540 TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
9541 ELSE
9542 TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
9543 ENDIF
9544 VINT(21)=TAU
ce320da8 9545 CALL PYKLIMA(2)
0119ef9a 9546 RYST=RLU(0)
9547 MYST=1
9548 IF(RYST.GT.COEF(ISUB,7)) MYST=2
9549 IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
ce320da8 9550 CALL PYKMAPA(2,MYST,RLU(0))
0119ef9a 9551 VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
9552
9553C...Calculate differential cross-section.
9554 VINT(71)=0.5*VINT(1)*SQRT(XT2)
ce320da8 9555 CALL PYSIGHA(NCHN,SIGS)
0119ef9a 9556 110 SIGM(IXT2)=SIGM(IXT2)+SIGS
9557 120 SIGSUM=SIGSUM+SIGM(IXT2)
9558 SIGSUM=SIGSUM/(20.*MSTP(83))
9559
9560C...Reject result if sigma(parton-parton) is smaller than hadronic one.
9561 IF(SIGSUM.LT.1.1*VINT(106)) THEN
9562 IF(MSTP(122).GE.1) WRITE(MSTU(11),1100) PARP(82),SIGSUM
9563 PARP(82)=0.9*PARP(82)
9564 VINT(149)=4.*PARP(82)**2/VINT(2)
9565 GOTO 100
9566 ENDIF
9567 IF(MSTP(122).GE.1) WRITE(MSTU(11),1200) PARP(82), SIGSUM
9568
9569C...Start iteration to find k factor.
9570 YKE=SIGSUM/VINT(106)
9571 SO=0.5
9572 XI=0.
9573 YI=0.
9574 XK=0.5
9575 IIT=0
9576 130 IF(IIT.EQ.0) THEN
9577 XK=2.*XK
9578 ELSEIF(IIT.EQ.1) THEN
9579 XK=0.5*XK
9580 ELSE
9581 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
9582 ENDIF
9583
9584C...Evaluate overlap integrals.
9585 IF(MSTP(82).EQ.2) THEN
9586 SP=0.5*PARU(1)*(1.-EXP(-XK))
9587 SOP=SP/PARU(1)
9588 ELSE
9589 IF(MSTP(82).EQ.3) DELTAB=0.02
9590 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01,0.05*PARP(84))
9591 SP=0.
9592 SOP=0.
9593 B=-0.5*DELTAB
9594 140 B=B+DELTAB
9595 IF(MSTP(82).EQ.3) THEN
9596 OV=EXP(-B**2)/PARU(2)
9597 ELSE
9598 CQ2=PARP(84)**2
9599 OV=((1.-PARP(83))**2*EXP(-MIN(100.,B**2))+2.*PARP(83)*
9600 & (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B**2*2./(1.+CQ2)))+
9601 & PARP(83)**2/CQ2*EXP(-MIN(100.,B**2/CQ2)))/PARU(2)
9602 ENDIF
9603 PACC=1.-EXP(-MIN(100.,PARU(1)*XK*OV))
9604 SP=SP+PARU(2)*B*DELTAB*PACC
9605 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
9606 IF(B.LT.1..OR.B*PACC.GT.1E-6) GOTO 140
9607 ENDIF
9608 YK=PARU(1)*XK*SO/SP
9609
9610C...Continue iteration until convergence.
9611 IF(YK.LT.YKE) THEN
9612 XI=XK
9613 YI=YK
9614 IF(IIT.EQ.1) IIT=2
9615 ELSE
9616 XF=XK
9617 YF=YK
9618 IF(IIT.EQ.0) IIT=1
9619 ENDIF
9620 IF(ABS(YK-YKE).GE.1E-5*YKE) GOTO 130
9621
9622C...Store some results for subsequent use.
9623 VINT(145)=SIGSUM
9624 VINT(146)=SOP/SO
9625 VINT(147)=SOP/SP
9626
9627C...Initialize iteration in xT2 for hardest interaction.
9628 ELSEIF(MMUL.EQ.2) THEN
9629 IF(MSTP(82).LE.0) THEN
9630 ELSEIF(MSTP(82).EQ.1) THEN
9631 XT2=1.
9632 XT2FAC=XSEC(96,1)/VINT(106)*VINT(149)/(1.-VINT(149))
9633 ELSEIF(MSTP(82).EQ.2) THEN
9634 XT2=1.
9635 XT2FAC=VINT(146)*XSEC(96,1)/VINT(106)*VINT(149)*(1.+VINT(149))
9636 ELSE
9637 XC2=4.*CKIN(3)**2/VINT(2)
9638 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0.
9639 ENDIF
9640
9641 ELSEIF(MMUL.EQ.3) THEN
9642C...Low-pT or multiple interactions (first semihard interaction):
9643C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
9644C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
9645 ISUB=MINT(1)
9646 IF(MSTP(82).LE.0) THEN
9647 XT2=0.
9648 ELSEIF(MSTP(82).EQ.1) THEN
9649 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))
9650 ELSEIF(MSTP(82).EQ.2) THEN
9651 IF(XT2.LT.1..AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
9652 & VINT(149)))).GT.RLU(0)) XT2=1.
9653 IF(XT2.GE.1.) THEN
9654 XT2=(1.+VINT(149))*XT2FAC/(XT2FAC-(1.+VINT(149))*LOG(1.-
9655 & RLU(0)*(1.-EXP(-XT2FAC/(VINT(149)*(1.+VINT(149)))))))-
9656 & VINT(149)
9657 ELSE
9658 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+RLU(0)*
9659 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
9660 & VINT(149)
9661 ENDIF
9662 XT2=MAX(0.01*VINT(149),XT2)
9663 ELSE
9664 XT2=(XC2+VINT(149))*(1.+VINT(149))/(1.+VINT(149)-
9665 & RLU(0)*(1.-XC2))-VINT(149)
9666 XT2=MAX(0.01*VINT(149),XT2)
9667 ENDIF
9668 VINT(25)=XT2
9669
9670C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
9671 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
9672 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
9673 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
9674 ISUB=95
9675 MINT(1)=ISUB
9676 VINT(21)=0.01*VINT(149)
9677 VINT(22)=0.
9678 VINT(23)=0.
9679 VINT(25)=0.01*VINT(149)
9680
9681 ELSE
9682C...Multiple interactions (first semihard interaction).
9683C...Choose tau and y*. Calculate cos(theta-hat).
9684 IF(RLU(0).LE.COEF(ISUB,1)) THEN
9685 TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
9686 TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
9687 ELSE
9688 TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
9689 ENDIF
9690 VINT(21)=TAU
ce320da8 9691 CALL PYKLIMA(2)
0119ef9a 9692 RYST=RLU(0)
9693 MYST=1
9694 IF(RYST.GT.COEF(ISUB,7)) MYST=2
9695 IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
ce320da8 9696 CALL PYKMAPA(2,MYST,RLU(0))
0119ef9a 9697 VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
9698 ENDIF
9699 VINT(71)=0.5*VINT(1)*SQRT(VINT(25))
9700
9701C...Store results of cross-section calculation.
9702 ELSEIF(MMUL.EQ.4) THEN
9703 ISUB=MINT(1)
9704 XTS=VINT(25)
9705 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
9706 IF(ISET(ISUB).EQ.2) XTS=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/
9707 & VINT(2)
9708 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XTS=VINT(26)
9709 RBIN=MAX(0.000001,MIN(0.999999,XTS*(1.+VINT(149))/
9710 & (XTS+VINT(149))))
9711 IRBIN=INT(1.+20.*RBIN)
9712 IF(ISUB.EQ.96) NMUL(IRBIN)=NMUL(IRBIN)+1
9713 IF(ISUB.EQ.96) SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
9714
9715C...Choose impact parameter.
9716 ELSEIF(MMUL.EQ.5) THEN
9717 IF(MSTP(82).EQ.3) THEN
9718 VINT(148)=RLU(0)/(PARU(2)*VINT(147))
9719 ELSE
9720 RTYPE=RLU(0)
9721 CQ2=PARP(84)**2
9722 IF(RTYPE.LT.(1.-PARP(83))**2) THEN
9723 B2=-LOG(RLU(0))
9724 ELSEIF(RTYPE.LT.1.-PARP(83)**2) THEN
9725 B2=-0.5*(1.+CQ2)*LOG(RLU(0))
9726 ELSE
9727 B2=-CQ2*LOG(RLU(0))
9728 ENDIF
9729 VINT(148)=((1.-PARP(83))**2*EXP(-MIN(100.,B2))+2.*PARP(83)*
9730 & (1.-PARP(83))*2./(1.+CQ2)*EXP(-MIN(100.,B2*2./(1.+CQ2)))+
9731 & PARP(83)**2/CQ2*EXP(-MIN(100.,B2/CQ2)))/(PARU(2)*VINT(147))
9732 ENDIF
9733
9734C...Multiple interactions (variable impact parameter) : reject with
9735C...probability exp(-overlap*cross-section above pT/normalization).
9736 RNCOR=(IRBIN-20.*RBIN)*NMUL(IRBIN)
9737 SIGCOR=(IRBIN-20.*RBIN)*SIGM(IRBIN)
9738 DO 150 IBIN=IRBIN+1,20
9739 RNCOR=RNCOR+NMUL(IBIN)
9740 150 SIGCOR=SIGCOR+SIGM(IBIN)
9741 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1.-XTS)/(XTS+VINT(149))
9742 VINT(150)=EXP(-MIN(100.,VINT(146)*VINT(148)*SIGABV/VINT(106)))
9743
9744C...Generate additional multiple semihard interactions.
9745 ELSEIF(MMUL.EQ.6) THEN
9746
9747C...Reconstruct strings in hard scattering.
9748 ISUB=MINT(1)
9749 NMAX=MINT(84)+4
9750 IF(ISET(ISUB).EQ.1) NMAX=MINT(84)+2
9751 NSTR=0
9752 DO 170 I=MINT(84)+1,NMAX
9753 KCS=KCHG(LUCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
9754 IF(KCS.EQ.0) GOTO 170
9755 DO 160 J=1,4
9756 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 160
9757 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 160
9758 IF(J.LE.2) THEN
9759 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
9760 ELSE
9761 IST=MOD(K(I,J+1),MSTU(5))
9762 ENDIF
9763 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 160
9764 IF(KCHG(LUCOMP(K(IST,2)),2).EQ.0) GOTO 160
9765 NSTR=NSTR+1
9766 IF(J.EQ.1.OR.J.EQ.4) THEN
9767 KSTR(NSTR,1)=I
9768 KSTR(NSTR,2)=IST
9769 ELSE
9770 KSTR(NSTR,1)=IST
9771 KSTR(NSTR,2)=I
9772 ENDIF
9773 160 CONTINUE
9774 170 CONTINUE
9775
9776C...Set up starting values for iteration in xT2.
9777 XT2=VINT(25)
9778 IF(ISET(ISUB).EQ.1) XT2=VINT(21)
9779 IF(ISET(ISUB).EQ.2) XT2=(4.*VINT(48)+2.*VINT(63)+2.*VINT(64))/
9780 & VINT(2)
9781 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) XT2=VINT(26)
9782 ISUB=96
9783 MINT(1)=96
9784 IF(MSTP(82).LE.1) THEN
9785 XT2FAC=XSEC(ISUB,1)*VINT(149)/((1.-VINT(149))*VINT(106))
9786 ELSE
9787 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/VINT(106)*
9788 & VINT(149)*(1.+VINT(149))
9789 ENDIF
9790 VINT(63)=0.
9791 VINT(64)=0.
9792 VINT(151)=0.
9793 VINT(152)=0.
9794 VINT(143)=1.-VINT(141)
9795 VINT(144)=1.-VINT(142)
9796
9797C...Iterate downwards in xT2.
9798 180 IF(MSTP(82).LE.1) THEN
9799 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(RLU(0)))
9800 IF(XT2.LT.VINT(149)) GOTO 220
9801 ELSE
9802 IF(XT2.LE.0.01*VINT(149)) GOTO 220
9803 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
9804 & LOG(RLU(0)))-VINT(149)
9805 IF(XT2.LE.0.) GOTO 220
9806 XT2=MAX(0.01*VINT(149),XT2)
9807 ENDIF
9808 VINT(25)=XT2
9809
9810C...Choose tau and y*. Calculate cos(theta-hat).
9811 IF(RLU(0).LE.COEF(ISUB,1)) THEN
9812 TAUP=(2.*(1.+SQRT(1.-XT2))/XT2-1.)**RLU(0)
9813 TAU=XT2*(1.+TAUP)**2/(4.*TAUP)
9814 ELSE
9815 TAU=XT2*(1.+TAN(RLU(0)*ATAN(SQRT(1./XT2-1.)))**2)
9816 ENDIF
9817 VINT(21)=TAU
ce320da8 9818 CALL PYKLIMA(2)
0119ef9a 9819 RYST=RLU(0)
9820 MYST=1
9821 IF(RYST.GT.COEF(ISUB,7)) MYST=2
9822 IF(RYST.GT.COEF(ISUB,7)+COEF(ISUB,8)) MYST=3
ce320da8 9823 CALL PYKMAPA(2,MYST,RLU(0))
0119ef9a 9824 VINT(23)=SQRT(MAX(0.,1.-XT2/TAU))*(-1)**INT(1.5+RLU(0))
9825
9826C...Check that x not used up. Accept or reject kinematical variables.
9827 X1M=SQRT(TAU)*EXP(VINT(22))
9828 X2M=SQRT(TAU)*EXP(-VINT(22))
9829 IF(VINT(143)-X1M.LT.0.01.OR.VINT(144)-X2M.LT.0.01) GOTO 180
9830 VINT(71)=0.5*VINT(1)*SQRT(XT2)
ce320da8 9831 CALL PYSIGHA(NCHN,SIGS)
0119ef9a 9832 IF(SIGS.LT.XSEC(ISUB,1)*RLU(0)) GOTO 180
9833
9834C...Reset K, P and V vectors. Select some variables.
9835 DO 190 I=N+1,N+2
9836 DO 190 J=1,5
9837 K(I,J)=0
9838 P(I,J)=0.
9839 190 V(I,J)=0.
9840 RFLAV=RLU(0)
9841 PT=0.5*VINT(1)*SQRT(XT2)
9842 PHI=PARU(2)*RLU(0)
9843 CTH=VINT(23)
9844
9845C...Add first parton to event record.
9846 K(N+1,1)=3
9847 K(N+1,2)=21
9848 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
9849 & 1+INT((2.+PARJ(2))*RLU(0))
9850 P(N+1,1)=PT*COS(PHI)
9851 P(N+1,2)=PT*SIN(PHI)
9852 P(N+1,3)=0.25*VINT(1)*(VINT(41)*(1.+CTH)-VINT(42)*(1.-CTH))
9853 P(N+1,4)=0.25*VINT(1)*(VINT(41)*(1.+CTH)+VINT(42)*(1.-CTH))
9854 P(N+1,5)=0.
9855
9856C...Add second parton to event record.
9857 K(N+2,1)=3
9858 K(N+2,2)=21
9859 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
9860 P(N+2,1)=-P(N+1,1)
9861 P(N+2,2)=-P(N+1,2)
9862 P(N+2,3)=0.25*VINT(1)*(VINT(41)*(1.-CTH)-VINT(42)*(1.+CTH))
9863 P(N+2,4)=0.25*VINT(1)*(VINT(41)*(1.-CTH)+VINT(42)*(1.+CTH))
9864 P(N+2,5)=0.
9865
9866 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
9867C....Choose relevant string pieces to place gluons on.
9868 DO 210 I=N+1,N+2
9869 DMIN=1E8
9870 DO 200 ISTR=1,NSTR
9871 I1=KSTR(ISTR,1)
9872 I2=KSTR(ISTR,2)
9873 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
9874 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
9875 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1.,P(I1,4)*P(I2,4)-
9876 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
9877 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
9878 DMIN=DIST
9879 IST1=I1
9880 IST2=I2
9881 ISTM=ISTR
9882 ENDIF
9883 200 CONTINUE
9884
9885C....Colour flow adjustments, new string pieces.
9886 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
9887 & MOD(K(IST1,4),MSTU(5))
9888 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
9889 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
9890 K(I,5)=MSTU(5)*IST1
9891 K(I,4)=MSTU(5)*IST2
9892 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
9893 & MOD(K(IST2,5),MSTU(5))
9894 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
9895 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
9896 KSTR(ISTM,2)=I
9897 KSTR(NSTR+1,1)=I
9898 KSTR(NSTR+1,2)=IST2
9899 210 NSTR=NSTR+1
9900
9901C...String drawing and colour flow for gluon loop.
9902 ELSEIF(K(N+1,2).EQ.21) THEN
9903 K(N+1,4)=MSTU(5)*(N+2)
9904 K(N+1,5)=MSTU(5)*(N+2)
9905 K(N+2,4)=MSTU(5)*(N+1)
9906 K(N+2,5)=MSTU(5)*(N+1)
9907 KSTR(NSTR+1,1)=N+1
9908 KSTR(NSTR+1,2)=N+2
9909 KSTR(NSTR+2,1)=N+2
9910 KSTR(NSTR+2,2)=N+1
9911 NSTR=NSTR+2
9912
9913C...String drawing and colour flow for q-qbar pair.
9914 ELSE
9915 K(N+1,4)=MSTU(5)*(N+2)
9916 K(N+2,5)=MSTU(5)*(N+1)
9917 KSTR(NSTR+1,1)=N+1
9918 KSTR(NSTR+1,2)=N+2
9919 NSTR=NSTR+1
9920 ENDIF
9921
9922C...Update remaining energy; iterate.
9923 N=N+2
9924 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
ce320da8 9925 CALL LUERRM(11,'(PYMULTA:) no more memory left in LUJETSA')
0119ef9a 9926 IF(MSTU(21).GE.1) RETURN
9927 ENDIF
9928 MINT(31)=MINT(31)+1
9929 VINT(151)=VINT(151)+VINT(41)
9930 VINT(152)=VINT(152)+VINT(42)
9931 VINT(143)=VINT(143)-VINT(41)
9932 VINT(144)=VINT(144)-VINT(42)
9933 IF(MINT(31).LT.240) GOTO 180
9934 220 CONTINUE
9935 ENDIF
9936
9937C...Format statements for printout.
ce320da8 9938 1000 FORMAT(/1X,'****** PYMULTA: initialization of multiple inter',
0119ef9a 9939 &'actions for MSTP(82) =',I2,' ******')
9940 1100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
9941 &E9.2,' mb: rejected')
9942 1200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
9943 &E9.2,' mb: accepted')
9944
9945 RETURN
9946 END
9947
9948C*********************************************************************
9949
ce320da8 9950 SUBROUTINE PYREMNA(IPU1,IPU2)
0119ef9a 9951
9952C...Adds on target remnants (one or two from each side) and
9953C...includes primordial kT.
9954 COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
9955 SAVE /HPARNT/
9956 COMMON/HSTRNG/NFP(300,15),PPHI(300,15),NFT(300,15),PTHI(300,15)
9957 SAVE /HSTRNG/
9958C...COMMON BLOCK FROM HIJING
9959 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
9960 SAVE /LUJETSA/
9961 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9962 SAVE /LUDAT1A/
9963 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9964 SAVE /LUDAT2A/
9965 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
9966 SAVE /PYPARSA/
9967 COMMON/PYINT1A/MINT(400),VINT(400)
9968 SAVE /PYINT1A/
9969 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(6),IS(2),ROBO(5)
9970
9971 iq=0
9972 ipu=0
9973 shs=0.
9974 jpt=0
9975 peh=0.
9976 pzh=0.
9977 pei=0.
9978 pzi=0.
9979 pz=0.
9980
9981C...Special case for lepton-lepton interaction.
9982 IF(MINT(43).EQ.1) THEN
9983 DO 100 JT=1,2
9984 I=MINT(83)+JT+2
9985 K(I,1)=21
9986 K(I,2)=K(I-2,2)
9987 K(I,3)=I-2
9988 DO 100 J=1,5
9989 100 P(I,J)=P(I-2,J)
9990 ENDIF
9991
9992C...Find event type, set pointers.
9993 IF(IPU1.EQ.0.AND.IPU2.EQ.0) RETURN
9994 ISUB=MINT(1)
9995 ILEP=0
9996 IF(IPU1.EQ.0) ILEP=1
9997 IF(IPU2.EQ.0) ILEP=2
9998 IF(ISUB.EQ.95) ILEP=-1
9999 IF(ILEP.EQ.1) IQ=MINT(84)+1
10000 IF(ILEP.EQ.2) IQ=MINT(84)+2
10001 IP=MAX(IPU1,IPU2)
10002 ILEPR=MINT(83)+5-ILEP
10003 NS=N
10004
10005C...Define initial partons, including primordial kT.
10006 110 DO 130 JT=1,2
10007 I=MINT(83)+JT+2
10008 IF(JT.EQ.1) IPU=IPU1
10009 IF(JT.EQ.2) IPU=IPU2
10010 K(I,1)=21
10011 K(I,3)=I-2
10012 IF(ISUB.EQ.95) THEN
10013 K(I,2)=21
10014 SHS=0.
10015 ELSEIF(MINT(40+JT).EQ.1.AND.IPU.NE.0) THEN
10016 K(I,2)=K(IPU,2)
10017 P(I,5)=P(IPU,5)
10018 P(I,1)=0.
10019 P(I,2)=0.
10020 PMS(JT)=P(I,5)**2
10021 ELSEIF(IPU.NE.0) THEN
10022 K(I,2)=K(IPU,2)
10023 P(I,5)=P(IPU,5)
10024C...No primordial kT or chosen according to truncated Gaussian or
10025C...exponential.
10026C
10027c X.N. Wang (7.22.97)
10028c
10029 RPT1=0.0
10030 RPT2=0.0
10031 ssw2=(PPHI(IHNT2(11),4)+PTHI(IHNT2(12),4))**2
10032 & -(PPHI(IHNT2(11),1)+PTHI(IHNT2(12),1))**2
10033 & -(PPHI(IHNT2(11),2)+PTHI(IHNT2(12),2))**2
10034 & -(PPHI(IHNT2(11),3)+PTHI(IHNT2(12),3))**2
10035C
10036C********this is s of the current NN collision
10037 IF(ssw2.LE.4.0*PARP(93)**2) GOTO 1211
10038c
10039 IF(IHPR2(5).LE.0) THEN
10040120 IF(MSTP(91).LE.0) THEN
10041 PT=0.
10042 ELSEIF(MSTP(91).EQ.1) THEN
10043 PT=PARP(91)*SQRT(-LOG(RLU(0)))
10044 ELSE
10045 RPT1=RLU(0)
10046 RPT2=RLU(0)
10047 PT=-PARP(92)*LOG(RPT1*RPT2)
10048 ENDIF
10049 IF(PT.GT.PARP(93)) GOTO 120
10050 PHI=PARU(2)*RLU(0)
10051 RPT1=PT*COS(PHI)
10052 RPT2=PT*SIN(PHI)
10053 ELSE IF(IHPR2(5).EQ.1) THEN
10054 IF(JT.EQ.1) JPT=NFP(IHNT2(11),11)
10055 IF(JT.EQ.2) JPT=NFT(IHNT2(12),11)
100561205 PTGS=PARP(91)*SQRT(-LOG(RLU(0)))
10057 IF(PTGS.GT.PARP(93)) GO TO 1205
10058 PHI=2.0*HIPR1(40)*RLU(0)
10059 RPT1=PTGS*COS(PHI)
10060 RPT2=PTGS*SIN(PHI)
10061 DO 1210 iint=1,JPT-1
10062 PKCSQ=PARP(91)*SQRT(-LOG(RLU(0)))
10063 PHI=2.0*HIPR1(40)*RLU(0)
10064 RPT1=RPT1+PKCSQ*COS(PHI)
10065 RPT2=RPT2+PKCSQ*SIN(PHI)
100661210 CONTINUE
10067 IF(RPT1**2+RPT2**2.GE.ssw2/4.0) GO TO 1205
10068 ENDIF
10069C X.N. Wang
10070C ********When initial interaction among soft partons is
10071C assumed the primordial pt comes from the sum of
10072C pt of JPT-1 number of initial interaction, JPT
10073C is the number of interaction including present
10074C one that nucleon hassuffered
100751211 P(I,1)=RPT1
10076 P(I,2)=RPT2
10077 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
10078 ELSE
10079 K(I,2)=K(IQ,2)
10080 Q2=VINT(52)
10081 P(I,5)=-SQRT(Q2)
10082 PMS(JT)=-Q2
10083 SHS=(1.-VINT(43-JT))*Q2/VINT(43-JT)+VINT(5-JT)**2
10084 ENDIF
10085 130 CONTINUE
10086
10087C...Kinematics construction for initial partons.
10088 I1=MINT(83)+3
10089 I2=MINT(83)+4
10090 IF(ILEP.EQ.0) SHS=VINT(141)*VINT(142)*VINT(2)+
10091 &(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2
10092 SHR=SQRT(MAX(0.,SHS))
10093 IF(ILEP.EQ.0) THEN
10094 IF((SHS-PMS(1)-PMS(2))**2-4.*PMS(1)*PMS(2).LE.0.) GOTO 110
10095 P(I1,4)=0.5*(SHR+(PMS(1)-PMS(2))/SHR)
10096 P(I1,3)=SQRT(MAX(0.,P(I1,4)**2-PMS(1)))
10097 P(I2,4)=SHR-P(I1,4)
10098 P(I2,3)=-P(I1,3)
10099 ELSEIF(ILEP.EQ.1) THEN
10100 P(I1,4)=P(IQ,4)
10101 P(I1,3)=P(IQ,3)
10102 P(I2,4)=P(IP,4)
10103 P(I2,3)=P(IP,3)
10104 ELSEIF(ILEP.EQ.2) THEN
10105 P(I1,4)=P(IP,4)
10106 P(I1,3)=P(IP,3)
10107 P(I2,4)=P(IQ,4)
10108 P(I2,3)=P(IQ,3)
10109 ENDIF
10110 IF(MINT(43).EQ.1) RETURN
10111
10112C...Transform partons to overall CM-frame (not for leptoproduction).
10113 IF(ILEP.EQ.0) THEN
10114 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
10115 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
10116 CALL LUDBRB(I1,I2,0.,0.,-DBLE(ROBO(3)),-DBLE(ROBO(4)),0D0)
10117 ROBO(2)=ULANGL(P(I1,1),P(I1,2))
10118 CALL LUDBRB(I1,I2,0.,-ROBO(2),0D0,0D0,0D0)
10119 ROBO(1)=ULANGL(P(I1,3),P(I1,1))
10120 CALL LUDBRB(I1,I2,-ROBO(1),0.,0D0,0D0,0D0)
10121 NMAX=MAX(MINT(52),IPU1,IPU2)
10122 CALL LUDBRB(I1,NMAX,ROBO(1),ROBO(2),DBLE(ROBO(3)),DBLE(ROBO(4)),
10123 & 0D0)
10124 ROBO(5)=MAX(-0.999999,MIN(0.999999,(VINT(141)-VINT(142))/
10125 & (VINT(141)+VINT(142))))
10126 CALL LUDBRB(I1,NMAX,0.,0.,0D0,0D0,DBLE(ROBO(5)))
10127 ENDIF
10128
10129C...Check invariant mass of remnant system:
10130C...hadronic events or leptoproduction.
10131 IF(ILEP.LE.0) THEN
10132 IF(MSTP(81).LE.0.OR.MSTP(82).LE.0.OR.ISUB.EQ.95) THEN
10133 VINT(151)=0.
10134 VINT(152)=0.
10135 ENDIF
10136 PEH=P(I1,4)+P(I2,4)+0.5*VINT(1)*(VINT(151)+VINT(152))
10137 PZH=P(I1,3)+P(I2,3)+0.5*VINT(1)*(VINT(151)-VINT(152))
10138 SHH=(VINT(1)-PEH)**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+P(I2,2))**2-
10139 & PZH**2
10140 PMMIN=P(MINT(83)+1,5)+P(MINT(83)+2,5)+ULMASS(K(I1,2))+
10141 & ULMASS(K(I2,2))
10142 IF(SHR.GE.VINT(1).OR.SHH.LE.(PMMIN+PARP(111))**2) THEN
10143 MINT(51)=1
10144 RETURN
10145 ENDIF
10146 SHR=SQRT(SHH+(P(I1,1)+P(I2,1))**2+(P(I1,2)+P(I2,2))**2)
10147 ELSE
10148 PEI=P(IQ,4)+P(IP,4)
10149 PZI=P(IQ,3)+P(IP,3)
10150 PMS(ILEP)=MAX(0.,PEI**2-PZI**2)
10151 PMMIN=P(ILEPR-2,5)+ULMASS(K(ILEPR,2))+SQRT(PMS(ILEP))
10152 IF(SHR.LE.PMMIN+PARP(111)) THEN
10153 MINT(51)=1
10154 RETURN
10155 ENDIF
10156 ENDIF
10157
10158C...Subdivide remnant if necessary, store first parton.
10159 140 I=NS
10160 DO 190 JT=1,2
10161 IF(JT.EQ.ILEP) GOTO 190
10162 IF(JT.EQ.1) IPU=IPU1
10163 IF(JT.EQ.2) IPU=IPU2
ce320da8 10164 CALL PYSPLIA(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
0119ef9a 10165 I=I+1
10166 IS(JT)=I
10167 DO 150 J=1,5
10168 K(I,J)=0
10169 P(I,J)=0.
10170 150 V(I,J)=0.
10171 K(I,1)=3
10172 K(I,2)=KFLSP(JT)
10173 K(I,3)=MINT(83)+JT
10174 P(I,5)=ULMASS(K(I,2))
10175
10176C...First parton colour connections and transverse mass.
10177 KFLS=(3-KCHG(LUCOMP(KFLSP(JT)),2)*ISIGN(1,KFLSP(JT)))/2
10178 K(I,KFLS+3)=IPU
10179 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
10180 IF(KFLCH(JT).EQ.0) THEN
10181 P(I,1)=-P(MINT(83)+JT+2,1)
10182 P(I,2)=-P(MINT(83)+JT+2,2)
10183 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
10184
10185C...When extra remnant parton or hadron: find relative pT, store.
10186 ELSE
10187 CALL LUPTDI(1,P(I,1),P(I,2))
10188 PMS(JT+2)=P(I,5)**2+P(I,1)**2+P(I,2)**2
10189 I=I+1
10190 DO 160 J=1,5
10191 K(I,J)=0
10192 P(I,J)=0.
10193 160 V(I,J)=0.
10194 K(I,1)=1
10195 K(I,2)=KFLCH(JT)
10196 K(I,3)=MINT(83)+JT
10197 P(I,5)=ULMASS(K(I,2))
10198 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
10199 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
10200 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
10201C...Relative distribution of energy for particle into two jets.
10202 IMB=1
10203 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
10204 IF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
10205 CHIK=PARP(92+2*IMB)
10206 IF(MSTP(92).LE.1) THEN
10207 IF(IMB.EQ.1) CHI(JT)=RLU(0)
10208 IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))
10209 ELSEIF(MSTP(92).EQ.2) THEN
10210 CHI(JT)=1.-RLU(0)**(1./(1.+CHIK))
10211 ELSEIF(MSTP(92).EQ.3) THEN
10212 CUT=2.*0.3/VINT(1)
10213 170 CHI(JT)=RLU(0)**2
10214 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25*(1.-CHI(JT))**CHIK
10215 & .LT.RLU(0)) GOTO 170
10216 ELSE
10217 CUT=2.*0.3/VINT(1)
10218 CUTR=(1.+SQRT(1.+CUT**2))/CUT
10219 180 CHIR=CUT*CUTR**RLU(0)
10220 CHI(JT)=(CHIR**2-CUT**2)/(2.*CHIR)
10221 IF((1.-CHI(JT))**CHIK.LT.RLU(0)) GOTO 180
10222 ENDIF
10223C...Relative distribution of energy for particle into jet plus particle.
10224 ELSE
10225 IF(MSTP(92).LE.1) THEN
10226 IF(IMB.EQ.1) CHI(JT)=RLU(0)
10227 IF(IMB.EQ.2) CHI(JT)=1.-SQRT(RLU(0))
10228 ELSE
10229 CHI(JT)=1.-RLU(0)**(1./(1.+PARP(93+2*IMB)))
10230 ENDIF
10231 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1.-CHI(JT)
10232 ENDIF
10233 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1.-CHI(JT))
10234 KFLS=KCHG(LUCOMP(KFLCH(JT)),2)*ISIGN(1,KFLCH(JT))
10235 IF(KFLS.NE.0) THEN
10236 K(I,1)=3
10237 KFLS=(3-KFLS)/2
10238 K(I,KFLS+3)=IPU
10239 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
10240 ENDIF
10241 ENDIF
10242 190 CONTINUE
10243 IF(SHR.LE.SQRT(PMS(1))+SQRT(PMS(2))) GOTO 140
10244 N=I
10245
10246C...Reconstruct kinematics of remnants.
10247 DO 200 JT=1,2
10248 IF(JT.EQ.ILEP) GOTO 200
10249 PE=0.5*(SHR+(PMS(JT)-PMS(3-JT))/SHR)
10250 PZ=SQRT(PE**2-PMS(JT))
10251 IF(KFLCH(JT).EQ.0) THEN
10252 P(IS(JT),4)=PE
10253 P(IS(JT),3)=PZ*(-1)**(JT-1)
10254 ELSE
10255 PW1=CHI(JT)*(PE+PZ)
10256 P(IS(JT)+1,4)=0.5*(PW1+PMS(JT+4)/PW1)
10257 P(IS(JT)+1,3)=0.5*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
10258 P(IS(JT),4)=PE-P(IS(JT)+1,4)
10259 P(IS(JT),3)=PZ*(-1)**(JT-1)-P(IS(JT)+1,3)
10260 ENDIF
10261 200 CONTINUE
10262
10263C...Hadronic events: boost remnants to correct longitudinal frame.
10264 IF(ILEP.LE.0) THEN
10265 CALL LUDBRB(NS+1,N,0.,0.,0D0,0D0,-DBLE(PZH/(VINT(1)-PEH)))
10266C...Leptoproduction events: boost colliding subsystem.
10267 ELSE
10268 NMAX=MAX(IP,MINT(52))
10269 PEF=SHR-PE
10270 PZF=PZ*(-1)**(ILEP-1)
10271 PT2=P(ILEPR,1)**2+P(ILEPR,2)**2
10272 PHIPT=ULANGL(P(ILEPR,1),P(ILEPR,2))
10273 CALL LUDBRB(MINT(84)+1,NMAX,0.,-PHIPT,0D0,0D0,0D0)
10274 RQP=P(IQ,3)*(PT2+PEI**2)-P(IQ,4)*PEI*PZI
10275 SINTH=P(IQ,4)*SQRT(PT2*(PT2+PEI**2)/(RQP**2+PT2*
10276 & P(IQ,4)**2*PZI**2))*SIGN(1.,-RQP)
10277 CALL LUDBRB(MINT(84)+1,NMAX,ASIN(SINTH),0.,0D0,0D0,0D0)
10278 BETAX=(-PEI*PZI*SINTH+SQRT(PT2*(PT2+PEI**2-(PZI*SINTH)**2)))/
10279 & (PT2+PEI**2)
10280 CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,DBLE(BETAX),0D0,0D0)
10281 CALL LUDBRB(MINT(84)+1,NMAX,0.,PHIPT,0D0,0D0,0D0)
10282 PEM=P(IQ,4)+P(IP,4)
10283 PZM=P(IQ,3)+P(IP,3)
10284 BETAZ=(-PEM*PZM+PZF*SQRT(PZF**2+PEM**2-PZM**2))/(PZF**2+PEM**2)
10285 CALL LUDBRB(MINT(84)+1,NMAX,0.,0.,0D0,0D0,DBLE(BETAZ))
10286 CALL LUDBRB(I1,I2,ASIN(SINTH),0.,DBLE(BETAX),0D0,0D0)
10287 CALL LUDBRB(I1,I2,0.,PHIPT,0D0,0D0,DBLE(BETAZ))
10288 ENDIF
10289
10290 RETURN
10291 END
10292
10293C*********************************************************************
10294
ce320da8 10295 SUBROUTINE PYRESDA
0119ef9a 10296
10297C...Allows resonances to decay (including parton showers for hadronic
10298C...channels).
10299 IMPLICIT DOUBLE PRECISION(D)
10300 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
10301 SAVE /LUJETSA/
10302 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10303 SAVE /LUDAT1A/
10304 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10305 SAVE /LUDAT2A/
10306 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10307 SAVE /LUDAT3A/
10308 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
10309 SAVE /PYSUBSA/
10310 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
10311 SAVE /PYPARSA/
10312 COMMON/PYINT1A/MINT(400),VINT(400)
10313 SAVE /PYINT1A/
10314 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
10315 SAVE /PYINT2A/
10316 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
10317 SAVE /PYINT4AA/
10318 DIMENSION IREF(10,6),KDCY(2),KFL1(2),KFL2(2),NSD(2),ILIN(6),
10319 &COUP(6,4),PK(6,4),PKK(6,6),CTHE(2),PHI(2),WDTP(0:40),
10320 &WDTE(0:40,0:5)
10321 COMPLEX FGK,HA(6,6),HC(6,6)
10322
10323C...The F, Xi and Xj functions of Gunion and Kunszt
10324C...(Phys. Rev. D33, 665, plus errata from the authors).
10325 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
10326 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
10327 DIGK(DT,DU)=-4.d0*D34*D56+DT*(3.d0*DT+4.d0*DU)
10328 & +DT**2*(DT*DU/(D34*D56)-
10329 &2.d0*(1.d0/D34+1.d0/D56)*(DT+DU)+2.d0*(D34/D56+D56/D34))
10330 DJGK(DT,DU)=8.d0*(D34+D56)**2-8.d0*(D34+D56)*(DT+DU)-6.d0*DT*DU-
10331 &2.d0*DT*DU*(DT*DU/(D34*D56)-2.d0*(1.d0/D34+1.d0/D56)*(DT+DU)+
10332 &2.d0*(D34/D56+D56/D34))
10333
10334 i12=0
10335 wt=0.
10336 wtmax=0.
10337
10338C...Define initial two objects, initialize loop.
10339 ISUB=MINT(1)
10340 SH=VINT(44)
10341 IREF(1,5)=0
10342 IREF(1,6)=0
10343 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
10344 IREF(1,1)=MINT(84)+2+ISET(ISUB)
10345 IREF(1,2)=0
10346 IREF(1,3)=MINT(83)+6+ISET(ISUB)
10347 IREF(1,4)=0
10348 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
10349 IREF(1,1)=MINT(84)+1+ISET(ISUB)
10350 IREF(1,2)=MINT(84)+2+ISET(ISUB)
10351 IREF(1,3)=MINT(83)+5+ISET(ISUB)
10352 IREF(1,4)=MINT(83)+6+ISET(ISUB)
10353 ENDIF
10354 NP=1
10355 IP=0
10356 100 IP=IP+1
10357 NINH=0
10358
10359C...Loop over one/two resonances; reset decay rates.
10360 JTMAX=2
10361 IF(IP.EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3)) JTMAX=1
10362 DO 140 JT=1,JTMAX
10363 KDCY(JT)=0
10364 KFL1(JT)=0
10365 KFL2(JT)=0
10366 NSD(JT)=IREF(IP,JT)
10367 ID=IREF(IP,JT)
10368 IF(ID.EQ.0) GOTO 140
10369 KFA=IABS(K(ID,2))
10370 IF(KFA.LT.23.OR.KFA.GT.40) GOTO 140
10371 IF(MDCY(KFA,1).NE.0) THEN
10372 IF(ISUB.EQ.1.OR.ISUB.EQ.141) MINT(61)=1
ce320da8 10373 CALL PYWIDTA(KFA,P(ID,5),WDTP,WDTE)
0119ef9a 10374 IF(KCHG(KFA,3).EQ.0) THEN
10375 IPM=2
10376 ELSE
10377 IPM=(5+ISIGN(1,K(ID,2)))/2
10378 ENDIF
10379 IF(JTMAX.EQ.1.OR.IABS(K(IREF(IP,1),2)).NE.IABS(K(IREF(IP,2),2)))
10380 & THEN
10381 I12=4
10382 ELSE
10383 IF(JT.EQ.1) I12=INT(4.5+RLU(0))
10384 I12=9-I12
10385 ENDIF
10386 RKFL=(WDTE(0,1)+WDTE(0,IPM)+WDTE(0,I12))*RLU(0)
10387 DO 120 I=1,MDCY(KFA,3)
10388 IDC=I+MDCY(KFA,2)-1
10389 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
10390 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
10391 RKFL=RKFL-(WDTE(I,1)+WDTE(I,IPM)+WDTE(I,I12))
10392 IF(RKFL.LE.0.) GOTO 130
10393 120 CONTINUE
10394 130 CONTINUE
10395 ENDIF
10396
10397C...Summarize result on decay channel chosen.
10398 IF((KFA.EQ.23.OR.KFA.EQ.24).AND.KFL1(JT).EQ.0) NINH=NINH+1
10399 IF(KFL1(JT).EQ.0) GOTO 140
10400 KDCY(JT)=2
10401 IF(IABS(KFL1(JT)).LE.10.OR.KFL1(JT).EQ.21) KDCY(JT)=1
10402 IF((IABS(KFL1(JT)).GE.23.AND.IABS(KFL1(JT)).LE.25).OR.
10403 &(IABS(KFL1(JT)).EQ.37)) KDCY(JT)=3
10404 NSD(JT)=N
10405
10406C...Fill decay products, prepared for parton showers for quarks.
10407clin-8/19/02 avoid actual argument in common blocks of LU2ENT:
10408 pid5=P(ID,5)
10409 IF(KDCY(JT).EQ.1) THEN
10410c CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),P(ID,5))
10411 CALL LU2ENT(-(N+1),KFL1(JT),KFL2(JT),pid5)
10412 ELSE
10413c CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
10414 CALL LU2ENT(N+1,KFL1(JT),KFL2(JT),pid5)
10415 ENDIF
10416
10417 IF(JTMAX.EQ.1) THEN
10418 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*RLU(0)
10419 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
10420 PHI(JT)=VINT(24)
10421 ELSE
10422 CTHE(JT)=2.*RLU(0)-1.
10423 PHI(JT)=PARU(2)*RLU(0)
10424 ENDIF
10425 140 CONTINUE
10426 IF(MINT(3).EQ.1.AND.IP.EQ.1) THEN
10427 MINT(25)=KFL1(1)
10428 MINT(26)=KFL2(1)
10429 ENDIF
10430 IF(JTMAX.EQ.1.AND.KDCY(1).EQ.0) GOTO 530
10431 IF(JTMAX.EQ.2.AND.KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 530
10432 IF(MSTP(45).LE.0.OR.IREF(IP,2).EQ.0.OR.NINH.GE.1) GOTO 500
10433 IF(K(IREF(1,1),2).EQ.25.AND.IP.EQ.1) GOTO 500
10434 IF(K(IREF(1,1),2).EQ.25.AND.KDCY(1)*KDCY(2).EQ.0) GOTO 500
10435
10436C...Order incoming partons and outgoing resonances.
10437 ILIN(1)=MINT(84)+1
10438 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
10439 IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
10440 ILIN(2)=2*MINT(84)+3-ILIN(1)
10441 IMIN=1
10442 IF(IREF(IP,5).EQ.25) IMIN=3
10443 IMAX=2
10444 IORD=1
10445 IF(K(IREF(IP,1),2).EQ.23) IORD=2
10446 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
10447 IF(IABS(K(IREF(IP,IORD),2)).EQ.25) IORD=3-IORD
10448 IF(KDCY(IORD).EQ.0) IORD=3-IORD
10449
10450C...Order decay products of resonances.
10451 DO 390 JT=IORD,3-IORD,3-2*IORD
10452 IF(KDCY(JT).EQ.0) THEN
10453 ILIN(IMAX+1)=NSD(JT)
10454 IMAX=IMAX+1
10455 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
10456 ILIN(IMAX+1)=N+2*JT-1
10457 ILIN(IMAX+2)=N+2*JT
10458 IMAX=IMAX+2
10459 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
10460 K(N+2*JT,2)=K(NSD(JT)+2,2)
10461 ELSE
10462 ILIN(IMAX+1)=N+2*JT
10463 ILIN(IMAX+2)=N+2*JT-1
10464 IMAX=IMAX+2
10465 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
10466 K(N+2*JT,2)=K(NSD(JT)+2,2)
10467 ENDIF
10468 390 CONTINUE
10469
10470C...Find charge, isospin, left- and righthanded couplings.
10471 XW=PARU(102)
10472 DO 410 I=IMIN,IMAX
10473 DO 400 J=1,4
10474 400 COUP(I,J)=0.
10475 KFA=IABS(K(ILIN(I),2))
10476 IF(KFA.GT.20) GOTO 410
10477 COUP(I,1)=LUCHGE(KFA)/3.
10478 COUP(I,2)=(-1)**MOD(KFA,2)
10479 COUP(I,4)=-2.*COUP(I,1)*XW
10480 COUP(I,3)=COUP(I,2)+COUP(I,4)
10481 410 CONTINUE
10482 SQMZ=PMAS(23,1)**2
10483 GZMZ=PMAS(23,1)*PMAS(23,2)
10484 SQMW=PMAS(24,1)**2
10485 GZMW=PMAS(24,1)*PMAS(24,2)
10486 SQMZP=PMAS(32,1)**2
10487 GZMZP=PMAS(32,1)*PMAS(32,2)
10488
10489C...Select random angles; construct massless four-vectors.
10490 420 DO 430 I=N+1,N+4
10491 K(I,1)=1
10492 DO 430 J=1,5
10493 430 P(I,J)=0.
10494 DO 440 JT=1,JTMAX
10495 IF(KDCY(JT).EQ.0) GOTO 440
10496 ID=IREF(IP,JT)
10497 P(N+2*JT-1,3)=0.5*P(ID,5)
10498 P(N+2*JT-1,4)=0.5*P(ID,5)
10499 P(N+2*JT,3)=-0.5*P(ID,5)
10500 P(N+2*JT,4)=0.5*P(ID,5)
10501 CTHE(JT)=2.*RLU(0)-1.
10502 PHI(JT)=PARU(2)*RLU(0)
10503 CALL LUDBRB(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
10504 &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))
10505 440 CONTINUE
10506
10507C...Store incoming and outgoing momenta, with random rotation to
10508C...avoid accidental zeroes in HA expressions.
10509 DO 450 I=1,IMAX
10510 K(N+4+I,1)=1
10511 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+P(ILIN(I),3)**2+
10512 &P(ILIN(I),5)**2)
10513 P(N+4+I,5)=P(ILIN(I),5)
10514 DO 450 J=1,3
10515 450 P(N+4+I,J)=P(ILIN(I),J)
10516 THERR=ACOS(2.*RLU(0)-1.)
10517 PHIRR=PARU(2)*RLU(0)
10518 CALL LUDBRB(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
10519 DO 460 I=1,IMAX
10520 DO 460 J=1,4
10521 460 PK(I,J)=P(N+4+I,J)
10522
10523C...Calculate internal products.
10524 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25) THEN
10525 DO 470 I1=IMIN,IMAX-1
10526 DO 470 I2=I1+1,IMAX
10527 HA(I1,I2)=SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+PK(I2,3))/
10528 & (1E-20+PK(I1,1)**2+PK(I1,2)**2))*CMPLX(PK(I1,1),PK(I1,2))-
10529 & SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
10530 & (1E-20+PK(I2,1)**2+PK(I2,2)**2))*CMPLX(PK(I2,1),PK(I2,2))
10531 HC(I1,I2)=CONJG(HA(I1,I2))
10532 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
10533 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
10534 HA(I2,I1)=-HA(I1,I2)
10535 470 HC(I2,I1)=-HC(I1,I2)
10536 ENDIF
10537 DO 480 I=1,2
10538 DO 480 J=1,4
10539 480 PK(I,J)=-PK(I,J)
10540 DO 490 I1=IMIN,IMAX-1
10541 DO 490 I2=I1+1,IMAX
10542 PKK(I1,I2)=2.*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
10543 &PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
10544 490 PKK(I2,I1)=PKK(I1,I2)
10545
10546 IF(IREF(IP,5).EQ.25) THEN
10547C...Angular weight for H0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons
10548 WT=16.*PKK(3,5)*PKK(4,6)
10549 IF(IP.EQ.1) WTMAX=SH**2
10550 IF(IP.GE.2) WTMAX=P(IREF(IP,6),5)**4
10551
10552 ELSEIF(ISUB.EQ.1) THEN
10553 IF(KFA.NE.37) THEN
10554C...Angular weight for gamma*/Z0 -> 2 quarks/leptons
10555 EI=KCHG(IABS(MINT(15)),1)/3.
10556 AI=SIGN(1.,EI+0.1)
10557 VI=AI-4.*EI*XW
10558 EF=KCHG(KFA,1)/3.
10559 AF=SIGN(1.,EF+0.1)
10560 VF=AF-4.*EF*XW
10561 GG=1.
10562 GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
10563 ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
10564 IF(MSTP(43).EQ.1) THEN
10565C...Only gamma* production included
10566 GZ=0.
10567 ZZ=0.
10568 ELSEIF(MSTP(43).EQ.2) THEN
10569C...Only Z0 production included
10570 GG=0.
10571 GZ=0.
10572 ENDIF
10573 ASYM=2.*(EI*AI*GZ*EF*AF+4.*VI*AI*ZZ*VF*AF)/(EI**2*GG*EF**2+
10574 & EI*VI*GZ*EF*VF+(VI**2+AI**2)*ZZ*(VF**2+AF**2))
10575 WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2
10576 WTMAX=2.+ABS(ASYM)
10577 ELSE
10578C...Angular weight for gamma*/Z0 -> H+ + H-
10579 WT=1.-CTHE(JT)**2
10580 WTMAX=1.
10581 ENDIF
10582
10583 ELSEIF(ISUB.EQ.2) THEN
10584C...Angular weight for W+/- -> 2 quarks/leptons
10585 WT=(1.+CTHE(JT))**2
10586 WTMAX=4.
10587
10588 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
10589C...Angular weight for f + fb -> gluon/gamma + Z0 ->
10590C...-> gluon/gamma + 2 quarks/leptons
10591 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
10592 & (PKK(1,3)**2+PKK(2,4)**2)+((COUP(1,3)*COUP(3,4))**2+
10593 & (COUP(1,4)*COUP(3,3))**2)*(PKK(1,4)**2+PKK(2,3)**2)
10594 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10595 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
10596
10597 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
10598C...Angular weight for f + fb' -> gluon/gamma + W+/- ->
10599C...-> gluon/gamma + 2 quarks/leptons
10600 WT=PKK(1,3)**2+PKK(2,4)**2
10601 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
10602
10603 ELSEIF(ISUB.EQ.22) THEN
10604C...Angular weight for f + fb -> Z0 + Z0 -> 4 quarks/leptons
10605 S34=P(IREF(IP,IORD),5)**2
10606 S56=P(IREF(IP,3-IORD),5)**2
10607 TI=PKK(1,3)+PKK(1,4)+S34
10608 UI=PKK(1,5)+PKK(1,6)+S56
10609 WT=COUP(1,3)**4*((COUP(3,3)*COUP(5,3)*ABS(FGK(1,2,3,4,5,6)/
10610 & TI+FGK(1,2,5,6,3,4)/UI))**2+(COUP(3,4)*COUP(5,3)*ABS(
10611 & FGK(1,2,4,3,5,6)/TI+FGK(1,2,5,6,4,3)/UI))**2+(COUP(3,3)*
10612 & COUP(5,4)*ABS(FGK(1,2,3,4,6,5)/TI+FGK(1,2,6,5,3,4)/UI))**2+
10613 & (COUP(3,4)*COUP(5,4)*ABS(FGK(1,2,4,3,6,5)/TI+FGK(1,2,6,5,4,3)/
10614 & UI))**2)+COUP(1,4)**4*((COUP(3,3)*COUP(5,3)*ABS(
10615 & FGK(2,1,5,6,3,4)/TI+FGK(2,1,3,4,5,6)/UI))**2+(COUP(3,4)*
10616 & COUP(5,3)*ABS(FGK(2,1,6,5,3,4)/TI+FGK(2,1,3,4,6,5)/UI))**2+
10617 & (COUP(3,3)*COUP(5,4)*ABS(FGK(2,1,5,6,4,3)/TI+FGK(2,1,4,3,5,6)/
10618 & UI))**2+(COUP(3,4)*COUP(5,4)*ABS(FGK(2,1,6,5,4,3)/TI+
10619 & FGK(2,1,4,3,6,5)/UI))**2)
10620 WTMAX=4.*S34*S56*(COUP(1,3)**4+COUP(1,4)**4)*(COUP(3,3)**2+
10621 & COUP(3,4)**2)*(COUP(5,3)**2+COUP(5,4)**2)*4.*(TI/UI+UI/TI+
10622 & 2.*SH*(S34+S56)/(TI*UI)-S34*S56*(1./TI**2+1./UI**2))
10623
10624 ELSEIF(ISUB.EQ.23) THEN
10625C...Angular weight for f + fb' -> Z0 + W +/- -> 4 quarks/leptons
10626 D34=dble(P(IREF(IP,IORD),5)**2)
10627 D56=dble(P(IREF(IP,3-IORD),5)**2)
10628 DT=dble(PKK(1,3)+PKK(1,4))+D34
10629 DU=dble(PKK(1,5)+PKK(1,6))+D56
10630 CAWZ=COUP(2,3)/SNGL(DT)-2.*(1.-XW)*COUP(1,2)/(SH-SQMW)
10631 CBWZ=COUP(1,3)/SNGL(DU)+2.*(1.-XW)*COUP(1,2)/(SH-SQMW)
10632 WT=COUP(5,3)**2*ABS(CAWZ*FGK(1,2,3,4,5,6)+CBWZ*
10633 & FGK(1,2,5,6,3,4))**2+COUP(5,4)**2*ABS(CAWZ*
10634 & FGK(1,2,3,4,6,5)+CBWZ*FGK(1,2,6,5,3,4))**2
10635 WTMAX=4.*sngl(D34*D56)*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
10636 & sngl(DIGK(DT,DU))+CBWZ**2*sngl(DIGK(DU,DT))
10637 & +CAWZ*CBWZ*sngl(DJGK(DT,DU)))
10638
10639 ELSEIF(ISUB.EQ.24) THEN
10640C...Angular weight for f + fb -> Z0 + H0 -> 2 quarks/leptons + H0
10641 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
10642 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
10643 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
10644 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10645 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10646
10647 ELSEIF(ISUB.EQ.25) THEN
10648C...Angular weight for f + fb -> W+ + W- -> 4 quarks/leptons
10649 D34=dble(P(IREF(IP,IORD),5)**2)
10650 D56=dble(P(IREF(IP,3-IORD),5)**2)
10651 DT=dble(PKK(1,3)+PKK(1,4))+D34
10652 DU=dble(PKK(1,5)+PKK(1,6))+D56
10653 CDWW=(COUP(1,3)*SQMZ/(SH-SQMZ)+COUP(1,2))/SH
10654 CAWW=CDWW+0.5*(COUP(1,2)+1.)/SNGL(DT)
10655 CBWW=CDWW+0.5*(COUP(1,2)-1.)/SNGL(DU)
10656 CCWW=COUP(1,4)*SQMZ/(SH-SQMZ)/SH
10657 WT=ABS(CAWW*FGK(1,2,3,4,5,6)-CBWW*FGK(1,2,5,6,3,4))**2+
10658 & CCWW**2*ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))**2
10659 WTMAX=4.*sngl(D34*D56)*(CAWW**2*sngl(DIGK(DT,DU))
10660 & +CBWW**2*sngl(DIGK(DU,DT))-CAWW*CBWW*sngl(DJGK(DT,DU))
10661 & +CCWW**2*sngl(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
10662
10663 ELSEIF(ISUB.EQ.26) THEN
10664C...Angular weight for f + fb' -> W+/- + H0 -> 2 quarks/leptons + H0
10665 WT=PKK(1,3)*PKK(2,4)
10666 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10667
10668 ELSEIF(ISUB.EQ.30) THEN
10669C...Angular weight for f + g -> f + Z0 -> f + 2 quarks/leptons
10670 IF(K(ILIN(1),2).GT.0) WT=((COUP(1,3)*COUP(3,3))**2+
10671 & (COUP(1,4)*COUP(3,4))**2)*(PKK(1,4)**2+PKK(3,5)**2)+
10672 & ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
10673 & (PKK(1,3)**2+PKK(4,5)**2)
10674 IF(K(ILIN(1),2).LT.0) WT=((COUP(1,3)*COUP(3,3))**2+
10675 & (COUP(1,4)*COUP(3,4))**2)*(PKK(1,3)**2+PKK(4,5)**2)+
10676 & ((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*COUP(3,3))**2)*
10677 & (PKK(1,4)**2+PKK(3,5)**2)
10678 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10679 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
10680
10681 ELSEIF(ISUB.EQ.31) THEN
10682C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons
10683 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
10684 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
10685 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
10686
10687 ELSEIF(ISUB.EQ.141) THEN
10688C...Angular weight for gamma*/Z0/Z'0 -> 2 quarks/leptons
10689 EI=KCHG(IABS(MINT(15)),1)/3.
10690 AI=SIGN(1.,EI+0.1)
10691 VI=AI-4.*EI*XW
10692 API=SIGN(1.,EI+0.1)
10693 VPI=API-4.*EI*XW
10694 EF=KCHG(KFA,1)/3.
10695 AF=SIGN(1.,EF+0.1)
10696 VF=AF-4.*EF*XW
10697 APF=SIGN(1.,EF+0.1)
10698 VPF=APF-4.*EF*XW
10699 GG=1.
10700 GZ=1./(8.*XW*(1.-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GZMZ**2)
10701 GZP=1./(8.*XW*(1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GZMZP**2)
10702 ZZ=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZ)**2+GZMZ**2)
10703 ZZP=2./(16.*XW*(1.-XW))**2*
10704 & SH**2*((SH-SQMZ)*(SH-SQMZP)+GZMZ*GZMZP)/
10705 & (((SH-SQMZ)**2+GZMZ**2)*((SH-SQMZP)**2+GZMZP**2))
10706 ZPZP=1./(16.*XW*(1.-XW))**2*SH**2/((SH-SQMZP)**2+GZMZP**2)
10707 IF(MSTP(44).EQ.1) THEN
10708C...Only gamma* production included
10709 GZ=0.
10710 GZP=0.
10711 ZZ=0.
10712 ZZP=0.
10713 ZPZP=0.
10714 ELSEIF(MSTP(44).EQ.2) THEN
10715C...Only Z0 production included
10716 GG=0.
10717 GZ=0.
10718 GZP=0.
10719 ZZP=0.
10720 ZPZP=0.
10721 ELSEIF(MSTP(44).EQ.3) THEN
10722C...Only Z'0 production included
10723 GG=0.
10724 GZ=0.
10725 GZP=0.
10726 ZZ=0.
10727 ZZP=0.
10728 ELSEIF(MSTP(44).EQ.4) THEN
10729C...Only gamma*/Z0 production included
10730 GZP=0.
10731 ZZP=0.
10732 ZPZP=0.
10733 ELSEIF(MSTP(44).EQ.5) THEN
10734C...Only gamma*/Z'0 production included
10735 GZ=0.
10736 ZZ=0.
10737 ZZP=0.
10738 ELSEIF(MSTP(44).EQ.6) THEN
10739C...Only Z0/Z'0 production included
10740 GG=0.
10741 GZ=0.
10742 GZP=0.
10743 ENDIF
10744 ASYM=2.*(EI*AI*GZ*EF*AF+EI*API*GZP*EF*APF+4.*VI*AI*ZZ*VF*AF+
10745 & (VI*API+VPI*AI)*ZZP*(VF*APF+VPF*AF)+4.*VPI*API*ZPZP*VPF*APF)/
10746 & (EI**2*GG*EF**2+EI*VI*GZ*EF*VF+EI*VPI*GZP*EF*VPF+
10747 & (VI**2+AI**2)*ZZ*(VF**2+AF**2)+(VI*VPI+AI*API)*ZZP*
10748 & (VF*VPF+AF*APF)+(VPI**2+API**2)*ZPZP*(VPF**2+APF**2))
10749 WT=1.+ASYM*CTHE(JT)+CTHE(JT)**2
10750 WTMAX=2.+ABS(ASYM)
10751
10752 ELSE
10753 WT=1.
10754 WTMAX=1.
10755 ENDIF
10756C...Obtain correct angular distribution by rejection techniques.
10757 IF(WT.LT.RLU(0)*WTMAX) GOTO 420
10758
10759C...Construct massive four-vectors using angles chosen. Mark decayed
10760C...resonances, add documentation lines. Shower evolution.
10761 500 DO 520 JT=1,JTMAX
10762 IF(KDCY(JT).EQ.0) GOTO 520
10763 ID=IREF(IP,JT)
10764 CALL LUDBRB(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
10765 &DBLE(P(ID,1)/P(ID,4)),DBLE(P(ID,2)/P(ID,4)),DBLE(P(ID,3)/P(ID,4)))
10766 K(ID,1)=K(ID,1)+10
10767 K(ID,4)=NSD(JT)+1
10768 K(ID,5)=NSD(JT)+2
10769 IDOC=MINT(83)+MINT(4)
10770 DO 510 I=NSD(JT)+1,NSD(JT)+2
10771 MINT(4)=MINT(4)+1
10772 I1=MINT(83)+MINT(4)
10773 K(I,3)=I1
10774 K(I1,1)=21
10775 K(I1,2)=K(I,2)
10776 K(I1,3)=IREF(IP,JT+2)
10777 DO 510 J=1,5
10778 510 P(I1,J)=P(I,J)
10779 IF(JTMAX.EQ.1) THEN
10780 MINT(7)=MINT(83)+6+2*ISET(ISUB)
10781 MINT(8)=MINT(83)+7+2*ISET(ISUB)
10782 ENDIF
10783clin-8/19/02 avoid actual argument in common blocks of LUSHOW:
10784c IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,
10785c &NSD(JT)+2,P(ID,5))
10786 pid5=P(ID,5)
10787 IF(MSTP(71).GE.1.AND.KDCY(JT).EQ.1) CALL LUSHOW(NSD(JT)+1,
10788 &NSD(JT)+2,pid5)
10789
10790C...Check if new resonances were produced, loop back if needed.
10791 IF(KDCY(JT).NE.3) GOTO 520
10792 NP=NP+1
10793 IREF(NP,1)=NSD(JT)+1
10794 IREF(NP,2)=NSD(JT)+2
10795 IREF(NP,3)=IDOC+1
10796 IREF(NP,4)=IDOC+2
10797 IREF(NP,5)=K(IREF(IP,JT),2)
10798 IREF(NP,6)=IREF(IP,JT)
10799 520 CONTINUE
10800 530 IF(IP.LT.NP) GOTO 100
10801
10802 RETURN
10803 END
10804
10805C*********************************************************************
10806
ce320da8 10807 SUBROUTINE PYDIFFA
0119ef9a 10808
10809C...Handles diffractive and elastic scattering.
10810 COMMON/LUJETSA/N,K(9000,5),P(9000,5),V(9000,5)
10811 SAVE /LUJETSA/
10812 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10813 SAVE /LUDAT1A/
10814 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
10815 SAVE /PYPARSA/
10816 COMMON/PYINT1A/MINT(400),VINT(400)
10817 SAVE /PYINT1A/
10818
10819 chi=0.
10820
10821C...Reset K, P and V vectors. Store incoming particles.
10822 DO 100 JT=1,MSTP(126)+10
10823 I=MINT(83)+JT
10824 DO 100 J=1,5
10825 K(I,J)=0
10826 P(I,J)=0.
10827 100 V(I,J)=0.
10828 N=MINT(84)
10829 MINT(3)=0
10830 MINT(21)=0
10831 MINT(22)=0
10832 MINT(23)=0
10833 MINT(24)=0
10834 MINT(4)=4
10835 DO 110 JT=1,2
10836 I=MINT(83)+JT
10837 K(I,1)=21
10838 K(I,2)=MINT(10+JT)
10839 P(I,5)=VINT(2+JT)
10840 P(I,3)=VINT(5)*(-1)**(JT+1)
10841 110 P(I,4)=SQRT(P(I,3)**2+P(I,5)**2)
10842 MINT(6)=2
10843
10844C...Subprocess; kinematics.
10845 ISUB=MINT(1)
10846 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4.*VINT(63)*VINT(64)
10847 PZ=SQRT(SQLAM)/(2.*VINT(1))
10848 DO 150 JT=1,2
10849 I=MINT(83)+JT
10850 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2.*VINT(1))
10851
10852C...Elastically scattered particle.
10853 IF(MINT(16+JT).LE.0) THEN
10854 N=N+1
10855 K(N,1)=1
10856 K(N,2)=K(I,2)
10857 K(N,3)=I+2
10858 P(N,3)=PZ*(-1)**(JT+1)
10859 P(N,4)=PE
10860 P(N,5)=P(I,5)
10861
10862C...Diffracted particle: valence quark kicked out.
10863 ELSEIF(MSTP(101).EQ.1) THEN
10864 N=N+2
10865 K(N-1,1)=2
10866 K(N,1)=1
10867 K(N-1,3)=I+2
10868 K(N,3)=I+2
ce320da8 10869 CALL PYSPLIA(K(I,2),21,K(N,2),K(N-1,2))
0119ef9a 10870 P(N-1,5)=ULMASS(K(N-1,2))
10871 P(N,5)=ULMASS(K(N,2))
10872 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
10873 & 4.*P(N-1,5)**2*P(N,5)**2
10874 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
10875 & P(N,5)**2))/(2.*VINT(62+JT))*(-1)**(JT+1)
10876 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
10877 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
10878 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
10879
10880C...Diffracted particle: gluon kicked out.
10881 ELSE
10882 N=N+3
10883 K(N-2,1)=2
10884 K(N-1,1)=2
10885 K(N,1)=1
10886 K(N-2,3)=I+2
10887 K(N-1,3)=I+2
10888 K(N,3)=I+2
ce320da8 10889 CALL PYSPLIA(K(I,2),21,K(N,2),K(N-2,2))
0119ef9a 10890 K(N-1,2)=21
10891 P(N-2,5)=ULMASS(K(N-2,2))
10892 P(N-1,5)=0.
10893 P(N,5)=ULMASS(K(N,2))
10894C...Energy distribution for particle into two jets.
10895 120 IMB=1
10896 IF(MOD(K(I,2)/1000,10).NE.0) IMB=2
10897 CHIK=PARP(92+2*IMB)
10898 IF(MSTP(92).LE.1) THEN
10899 IF(IMB.EQ.1) CHI=RLU(0)
10900 IF(IMB.EQ.2) CHI=1.-SQRT(RLU(0))
10901 ELSEIF(MSTP(92).EQ.2) THEN
10902 CHI=1.-RLU(0)**(1./(1.+CHIK))
10903 ELSEIF(MSTP(92).EQ.3) THEN
10904 CUT=2.*0.3/VINT(1)
10905 130 CHI=RLU(0)**2
10906 IF((CHI**2/(CHI**2+CUT**2))**0.25*(1.-CHI)**CHIK.LT.
10907 & RLU(0)) GOTO 130
10908 ELSE
10909 CUT=2.*0.3/VINT(1)
10910 CUTR=(1.+SQRT(1.+CUT**2))/CUT
10911 140 CHIR=CUT*CUTR**RLU(0)
10912 CHI=(CHIR**2-CUT**2)/(2.*CHIR)
10913 IF((1.-CHI)**CHIK.LT.RLU(0)) GOTO 140
10914 ENDIF
10915 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1.-P(N-2,5)**2/
10916 & VINT(62+JT)) GOTO 120
10917 SQM=P(N-2,5)**2/(1.-CHI)+P(N,5)**2/CHI
10918 IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 120
10919 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
10920 & (2.*VINT(62+JT))
10921 PEI=SQRT(PZI**2+SQM)
10922 PQQP=(1.-CHI)*(PEI+PZI)
10923 P(N-2,3)=0.5*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
10924 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
10925 P(N-1,3)=(PZ-PZI)*(-1)**(JT+1)
10926 P(N-1,4)=ABS(P(N-1,3))
10927 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
10928 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
10929 ENDIF
10930
10931C...Documentation lines.
10932 K(I+2,1)=21
10933 IF(MINT(16+JT).EQ.0) K(I+2,2)=MINT(10+JT)
10934 IF(MINT(16+JT).NE.0) K(I+2,2)=10*(MINT(10+JT)/10)
10935 K(I+2,3)=I
10936 P(I+2,3)=PZ*(-1)**(JT+1)
10937 P(I+2,4)=PE
10938 P(I+2,5)=SQRT(VINT(62+JT))
10939 150 CONTINUE
10940
10941C...Rotate outgoing partons/particles using cos(theta).
10942 CALL LUDBRB(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
10943
10944 RETURN
10945 END
10946
10947C*********************************************************************
10948
ce320da8 10949 SUBROUTINE PYFRAMA(IFRAME)
0119ef9a 10950
10951C...Performs transformations between different coordinate frames.
10952 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10953 SAVE /LUDAT1A/
10954 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
10955 SAVE /PYPARSA/
10956 COMMON/PYINT1A/MINT(400),VINT(400)
10957 SAVE /PYINT1A/
10958
10959 IF(IFRAME.LT.1.OR.IFRAME.GT.2) THEN
10960 WRITE(MSTU(11),1000) IFRAME,MINT(6)
10961 RETURN
10962 ENDIF
10963 IF(IFRAME.EQ.MINT(6)) RETURN
10964
10965 IF(MINT(6).EQ.1) THEN
10966C...Transform from fixed target or user specified frame to
10967C...CM-frame of incoming particles.
10968 CALL LUROBO(0.,0.,-VINT(8),-VINT(9),-VINT(10))
10969 CALL LUROBO(0.,-VINT(7),0.,0.,0.)
10970 CALL LUROBO(-VINT(6),0.,0.,0.,0.)
10971 MINT(6)=2
10972
10973 ELSE
10974C...Transform from particle CM-frame to fixed target or user specified
10975C...frame.
10976 CALL LUROBO(VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
10977 MINT(6)=1
10978 ENDIF
10979 MSTI(6)=MINT(6)
10980
ce320da8 10981 1000 FORMAT(1X,'Error: illegal values in subroutine PYFRAMA.',1X,
0119ef9a 10982 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
10983 &1X,I5)
10984
10985 RETURN
10986 END
10987
10988C*********************************************************************
10989
ce320da8 10990 SUBROUTINE PYWIDTA(KFLR,RMAS,WDTP,WDTE)
0119ef9a 10991
10992C...Calculates full and partial widths of resonances.
10993 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10994 SAVE /LUDAT1A/
10995 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10996 SAVE /LUDAT2A/
10997 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10998 SAVE /LUDAT3A/
10999 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
11000 SAVE /PYPARSA/
11001 COMMON/PYINT1A/MINT(400),VINT(400)
11002 SAVE /PYINT1A/
11003 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
11004 SAVE /PYINT4AA/
11005 DIMENSION WDTP(0:40),WDTE(0:40,0:5)
11006
11007 wid2=0.
11008 ai=0.
11009 ggi=0.
11010 gzi=0.
11011 zzi=0.
11012 ggf=0.
11013 gzf=0.
11014 zzf=0.
11015 ej=0.
11016 vj=0.
11017 gzpi=0.
11018 zzpi=0.
11019 zpzpi=0.
11020 gzpf=0.
11021 zzpf=0.
11022 zpzpf=0.
11023
11024C...Some common constants.
11025 KFLA=IABS(KFLR)
11026 SQM=RMAS**2
11027 AS=ULALPS(SQM)
11028 AEM=PARU(101)
11029 XW=PARU(102)
11030 RADC=1.+AS/PARU(1)
11031
11032C...Reset width information.
11033 DO 100 I=0,40
11034 WDTP(I)=0.
11035 DO 100 J=0,5
11036 100 WDTE(I,J)=0.
11037
11038 IF(KFLA.EQ.21) THEN
11039C...QCD:
11040 DO 110 I=1,MDCY(21,3)
11041 IDC=I+MDCY(21,2)-1
11042 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11043 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11044 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 110
11045 IF(I.LE.8) THEN
11046C...QCD -> q + qb
11047 WDTP(I)=(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11048 WID2=1.
11049 ENDIF
11050 WDTP(0)=WDTP(0)+WDTP(I)
11051 IF(MDME(IDC,1).GT.0) THEN
11052 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11053 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11054 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11055 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11056 ENDIF
11057 110 CONTINUE
11058
11059 ELSEIF(KFLA.EQ.23) THEN
11060C...Z0:
11061 IF(MINT(61).EQ.1) THEN
11062 EI=KCHG(IABS(MINT(15)),1)/3.
11063 AI=SIGN(1.,EI)
11064 VI=AI-4.*EI*XW
11065 SQMZ=PMAS(23,1)**2
11066 GZMZ=PMAS(23,2)*PMAS(23,1)
11067 GGI=EI**2
11068 GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/
11069 & ((SQM-SQMZ)**2+GZMZ**2)
11070 ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/
11071 & ((SQM-SQMZ)**2+GZMZ**2)
11072 IF(MSTP(43).EQ.1) THEN
11073C...Only gamma* production included
11074 GZI=0.
11075 ZZI=0.
11076 ELSEIF(MSTP(43).EQ.2) THEN
11077C...Only Z0 production included
11078 GGI=0.
11079 GZI=0.
11080 ENDIF
11081 ELSEIF(MINT(61).EQ.2) THEN
11082 VINT(111)=0.
11083 VINT(112)=0.
11084 VINT(114)=0.
11085 ENDIF
11086 DO 120 I=1,MDCY(23,3)
11087 IDC=I+MDCY(23,2)-1
11088 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11089 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11090 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 120
11091 IF(I.LE.8) THEN
11092C...Z0 -> q + qb
11093 EF=KCHG(I,1)/3.
11094 AF=SIGN(1.,EF+0.1)
11095 VF=AF-4.*EF*XW
11096 IF(MINT(61).EQ.0) THEN
11097 WDTP(I)=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11098 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11099 ELSEIF(MINT(61).EQ.1) THEN
11100 WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*
11101 & (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))*
11102 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11103 ELSEIF(MINT(61).EQ.2) THEN
11104 GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11105 GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11106 ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11107 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11108 ENDIF
11109 WID2=1.
11110 ELSEIF(I.LE.16) THEN
11111C...Z0 -> l+ + l-, nu + nub
11112 EF=KCHG(I+2,1)/3.
11113 AF=SIGN(1.,EF+0.1)
11114 VF=AF-4.*EF*XW
11115 WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11116 & SQRT(MAX(0.,1.-4.*RM1))
11117 IF(MINT(61).EQ.0) THEN
11118 WDTP(I)=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11119 & SQRT(MAX(0.,1.-4.*RM1))
11120 ELSEIF(MINT(61).EQ.1) THEN
11121 WDTP(I)=((GGI*EF**2+GZI*EF*VF+ZZI*VF**2)*
11122 & (1.+2.*RM1)+ZZI*AF**2*(1.-4.*RM1))*
11123 & SQRT(MAX(0.,1.-4.*RM1))
11124 ELSEIF(MINT(61).EQ.2) THEN
11125 GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11126 GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11127 ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11128 & SQRT(MAX(0.,1.-4.*RM1))
11129 ENDIF
11130 WID2=1.
11131 ELSE
11132C...Z0 -> H+ + H-
11133 CF=2.*(1.-2.*XW)
11134 IF(MINT(61).EQ.0) THEN
11135 WDTP(I)=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11136 ELSEIF(MINT(61).EQ.1) THEN
11137 WDTP(I)=0.25*(GGI+GZI*CF+ZZI*CF**2)*(1.-4.*RM1)*
11138 & SQRT(MAX(0.,1.-4.*RM1))
11139 ELSEIF(MINT(61).EQ.2) THEN
11140 GGF=0.25*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11141 GZF=0.25*CF*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11142 ZZF=0.25*CF**2*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11143 ENDIF
11144 WID2=WIDS(37,1)
11145 ENDIF
11146 WDTP(0)=WDTP(0)+WDTP(I)
11147 IF(MDME(IDC,1).GT.0) THEN
11148 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11149 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11150 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11151 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11152clin-4/2008 modified a la pythia6115.f to avoid undefined values (GGF,GZF,ZZF):
11153c VINT(111)=VINT(111)+GGF*WID2
11154c VINT(112)=VINT(112)+GZF*WID2
11155c VINT(114)=VINT(114)+ZZF*WID2
11156 IF(MINT(61).EQ.2) THEN
11157 VINT(111)=VINT(111)+GGF*WID2
11158 VINT(112)=VINT(112)+GZF*WID2
11159 VINT(114)=VINT(114)+ZZF*WID2
11160 ENDIF
11161clin-4/2008-end
11162 ENDIF
11163 120 CONTINUE
11164 IF(MSTP(43).EQ.1) THEN
11165C...Only gamma* production included
11166 VINT(112)=0.
11167 VINT(114)=0.
11168 ELSEIF(MSTP(43).EQ.2) THEN
11169C...Only Z0 production included
11170 VINT(111)=0.
11171 VINT(112)=0.
11172 ENDIF
11173
11174 ELSEIF(KFLA.EQ.24) THEN
11175C...W+/-:
11176 DO 130 I=1,MDCY(24,3)
11177 IDC=I+MDCY(24,2)-1
11178 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11179 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11180 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 130
11181 IF(I.LE.16) THEN
11182C...W+/- -> q + qb'
11183 WDTP(I)=3.*(2.-RM1-RM2-(RM1-RM2)**2)*
11184 & SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*
11185 & VCKM((I-1)/4+1,MOD(I-1,4)+1)*RADC
11186 WID2=1.
11187 ELSE
11188C...W+/- -> l+/- + nu
11189 WDTP(I)=(2.-RM1-RM2-(RM1-RM2)**2)*
11190 & SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))
11191 WID2=1.
11192 ENDIF
11193 WDTP(0)=WDTP(0)+WDTP(I)
11194 IF(MDME(IDC,1).GT.0) THEN
11195 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11196 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11197 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11198 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11199 ENDIF
11200 130 CONTINUE
11201
11202 ELSEIF(KFLA.EQ.25) THEN
11203C...H0:
11204 DO 170 I=1,MDCY(25,3)
11205 IDC=I+MDCY(25,2)-1
11206 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11207 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11208 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 170
11209 IF(I.LE.8) THEN
11210C...H0 -> q + qb
11211 WDTP(I)=3.*RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11212 WID2=1.
11213 ELSEIF(I.LE.12) THEN
11214C...H0 -> l+ + l-
11215 WDTP(I)=RM1*(1.-4.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11216 WID2=1.
11217 ELSEIF(I.EQ.13) THEN
11218C...H0 -> g + g; quark loop contribution only
11219 ETARE=0.
11220 ETAIM=0.
11221 DO 140 J=1,2*MSTP(1)
11222 EPS=(2.*PMAS(J,1)/RMAS)**2
11223 IF(EPS.LE.1.) THEN
11224 IF(EPS.GT.1.E-4) THEN
11225 ROOT=SQRT(1.-EPS)
11226 RLN=LOG((1.+ROOT)/(1.-ROOT))
11227 ELSE
11228 RLN=LOG(4./EPS-2.)
11229 ENDIF
11230 PHIRE=0.25*(RLN**2-PARU(1)**2)
11231 PHIIM=0.5*PARU(1)*RLN
11232 ELSE
11233 PHIRE=-(ASIN(1./SQRT(EPS)))**2
11234 PHIIM=0.
11235 ENDIF
11236 ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)
11237 ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM
11238 140 CONTINUE
11239 ETA2=ETARE**2+ETAIM**2
11240 WDTP(I)=(AS/PARU(1))**2*ETA2
11241 WID2=1.
11242 ELSEIF(I.EQ.14) THEN
11243C...H0 -> gamma + gamma; quark, charged lepton and W loop contributions
11244 ETARE=0.
11245 ETAIM=0.
11246 DO 150 J=1,3*MSTP(1)+1
11247 IF(J.LE.2*MSTP(1)) THEN
11248 EJ=KCHG(J,1)/3.
11249 EPS=(2.*PMAS(J,1)/RMAS)**2
11250 ELSEIF(J.LE.3*MSTP(1)) THEN
11251 JL=2*(J-2*MSTP(1))-1
11252 EJ=KCHG(10+JL,1)/3.
11253 EPS=(2.*PMAS(10+JL,1)/RMAS)**2
11254 ELSE
11255 EPS=(2.*PMAS(24,1)/RMAS)**2
11256 ENDIF
11257 IF(EPS.LE.1.) THEN
11258 IF(EPS.GT.1.E-4) THEN
11259 ROOT=SQRT(1.-EPS)
11260 RLN=LOG((1.+ROOT)/(1.-ROOT))
11261 ELSE
11262 RLN=LOG(4./EPS-2.)
11263 ENDIF
11264 PHIRE=0.25*(RLN**2-PARU(1)**2)
11265 PHIIM=0.5*PARU(1)*RLN
11266 ELSE
11267 PHIRE=-(ASIN(1./SQRT(EPS)))**2
11268 PHIIM=0.
11269 ENDIF
11270 IF(J.LE.2*MSTP(1)) THEN
11271 ETARE=ETARE+0.5*3.*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)
11272 ETAIM=ETAIM+0.5*3.*EJ**2*EPS*(EPS-1.)*PHIIM
11273 ELSEIF(J.LE.3*MSTP(1)) THEN
11274 ETARE=ETARE+0.5*EJ**2*EPS*(1.+(EPS-1.)*PHIRE)
11275 ETAIM=ETAIM+0.5*EJ**2*EPS*(EPS-1.)*PHIIM
11276 ELSE
11277 ETARE=ETARE-0.5-0.75*EPS*(1.+(EPS-2.)*PHIRE)
11278 ETAIM=ETAIM+0.75*EPS*(EPS-2.)*PHIIM
11279 ENDIF
11280 150 CONTINUE
11281 ETA2=ETARE**2+ETAIM**2
11282 WDTP(I)=(AEM/PARU(1))**2*0.5*ETA2
11283 WID2=1.
11284 ELSEIF(I.EQ.15) THEN
11285C...H0 -> gamma + Z0; quark, charged lepton and W loop contributions
11286 ETARE=0.
11287 ETAIM=0.
11288 DO 160 J=1,3*MSTP(1)+1
11289 IF(J.LE.2*MSTP(1)) THEN
11290 EJ=KCHG(J,1)/3.
11291 AJ=SIGN(1.,EJ+0.1)
11292 VJ=AJ-4.*EJ*XW
11293 EPS=(2.*PMAS(J,1)/RMAS)**2
11294 EPSP=(2.*PMAS(J,1)/PMAS(23,1))**2
11295 ELSEIF(J.LE.3*MSTP(1)) THEN
11296 JL=2*(J-2*MSTP(1))-1
11297 EJ=KCHG(10+JL,1)/3.
11298 AJ=SIGN(1.,EJ+0.1)
11299 VJ=AI-4.*EJ*XW
11300 EPS=(2.*PMAS(10+JL,1)/RMAS)**2
11301 EPSP=(2.*PMAS(10+JL,1)/PMAS(23,1))**2
11302 ELSE
11303 EPS=(2.*PMAS(24,1)/RMAS)**2
11304 EPSP=(2.*PMAS(24,1)/PMAS(23,1))**2
11305 ENDIF
11306 IF(EPS.LE.1.) THEN
11307 ROOT=SQRT(1.-EPS)
11308 IF(EPS.GT.1.E-4) THEN
11309 RLN=LOG((1.+ROOT)/(1.-ROOT))
11310 ELSE
11311 RLN=LOG(4./EPS-2.)
11312 ENDIF
11313 PHIRE=0.25*(RLN**2-PARU(1)**2)
11314 PHIIM=0.5*PARU(1)*RLN
11315 PSIRE=-(1.+0.5*ROOT*RLN)
11316 PSIIM=0.5*PARU(1)*ROOT
11317 ELSE
11318 PHIRE=-(ASIN(1./SQRT(EPS)))**2
11319 PHIIM=0.
11320 PSIRE=-(1.+SQRT(EPS-1.)*ASIN(1./SQRT(EPS)))
11321 PSIIM=0.
11322 ENDIF
11323 IF(EPSP.LE.1.) THEN
11324 ROOT=SQRT(1.-EPSP)
11325 IF(EPSP.GT.1.E-4) THEN
11326 RLN=LOG((1.+ROOT)/(1.-ROOT))
11327 ELSE
11328 RLN=LOG(4./EPSP-2.)
11329 ENDIF
11330 PHIREP=0.25*(RLN**2-PARU(1)**2)
11331 PHIIMP=0.5*PARU(1)*RLN
11332 PSIREP=-(1.+0.5*ROOT*RLN)
11333 PSIIMP=0.5*PARU(1)*ROOT
11334 ELSE
11335 PHIREP=-(ASIN(1./SQRT(EPSP)))**2
11336 PHIIMP=0.
11337 PSIREP=-(1.+SQRT(EPSP-1.)*ASIN(1./SQRT(EPSP)))
11338 PSIIMP=0.
11339 ENDIF
11340 FXYRE=EPS*EPSP/(8.*(EPS-EPSP))*(1.-EPS*EPSP/(EPS-EPSP)*(PHIRE-
11341 & PHIREP)+2.*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
11342 FXYIM=EPS*EPSP/(8.*(EPS-EPSP))*(-EPS*EPSP/(EPS-EPSP)*(PHIIM-
11343 & PHIIMP)+2.*EPS/(EPS-EPSP)*(PSIIM-PSIIMP))
11344 F1RE=EPS*EPSP/(2.*(EPS-EPSP))*(PHIRE-PHIREP)
11345 F1IM=EPS*EPSP/(2.*(EPS-EPSP))*(PHIIM-PHIIMP)
11346 IF(J.LE.2*MSTP(1)) THEN
11347 ETARE=ETARE-3.*EJ*VJ*(FXYRE-0.25*F1RE)
11348 ETAIM=ETAIM-3.*EJ*VJ*(FXYIM-0.25*F1IM)
11349 ELSEIF(J.LE.3*MSTP(1)) THEN
11350 ETARE=ETARE-EJ*VJ*(FXYRE-0.25*F1RE)
11351 ETAIM=ETAIM-EJ*VJ*(FXYIM-0.25*F1IM)
11352 ELSE
11353 ETARE=ETARE-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-
11354 & (5.+2./EPS))*FXYRE+(3.-XW/SQRT(1.-XW))*F1RE)
11355 ETAIM=ETAIM-SQRT(1.-XW)*(((1.+2./EPS)*XW/SQRT(1.-XW)-
11356 & (5.+2./EPS))*FXYIM+(3.-XW/SQRT(1.-XW))*F1IM)
11357 ENDIF
11358 160 CONTINUE
11359 ETA2=ETARE**2+ETAIM**2
11360 WDTP(I)=(AEM/PARU(1))**2*(1.-(PMAS(23,1)/RMAS)**2)**3/XW*ETA2
11361 WID2=WIDS(23,2)
11362 ELSE
11363C...H0 -> Z0 + Z0, W+ + W-
11364 WDTP(I)=(1.-4.*RM1+12.*RM1**2)*SQRT(MAX(0.,1.-4.*RM1))/
11365 & (2.*(18-I))
11366 WID2=WIDS(7+I,1)
11367 ENDIF
11368 WDTP(0)=WDTP(0)+WDTP(I)
11369 IF(MDME(IDC,1).GT.0) THEN
11370 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11371 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11372 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11373 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11374 ENDIF
11375 170 CONTINUE
11376
11377 ELSEIF(KFLA.EQ.32) THEN
11378C...Z'0:
11379 IF(MINT(61).EQ.1) THEN
11380 EI=KCHG(IABS(MINT(15)),1)/3.
11381 AI=SIGN(1.,EI)
11382 VI=AI-4.*EI*XW
11383 SQMZ=PMAS(23,1)**2
11384 GZMZ=PMAS(23,2)*PMAS(23,1)
11385 API=SIGN(1.,EI)
11386 VPI=API-4.*EI*XW
11387 SQMZP=PMAS(32,1)**2
11388 GZPMZP=PMAS(32,2)*PMAS(32,1)
11389 GGI=EI**2
11390 GZI=EI*VI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZ)/
11391 & ((SQM-SQMZ)**2+GZMZ**2)
11392 GZPI=EI*VPI/(8.*XW*(1.-XW))*SQM*(SQM-SQMZP)/
11393 & ((SQM-SQMZP)**2+GZPMZP**2)
11394 ZZI=(VI**2+AI**2)/(16.*XW*(1.-XW))**2*SQM**2/
11395 & ((SQM-SQMZ)**2+GZMZ**2)
11396 ZZPI=2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*
11397 & SQM**2*((SQM-SQMZ)*(SQM-SQMZP)+GZMZ*GZPMZP)/
11398 & (((SQM-SQMZ)**2+GZMZ**2)*((SQM-SQMZP)**2+GZPMZP**2))
11399 ZPZPI=(VPI**2+API**2)/(16.*XW*(1.-XW))**2*SQM**2/
11400 & ((SQM-SQMZP)**2+GZPMZP**2)
11401 IF(MSTP(44).EQ.1) THEN
11402C...Only gamma* production included
11403 GZI=0.
11404 GZPI=0.
11405 ZZI=0.
11406 ZZPI=0.
11407 ZPZPI=0.
11408 ELSEIF(MSTP(44).EQ.2) THEN
11409C...Only Z0 production included
11410 GGI=0.
11411 GZI=0.
11412 GZPI=0.
11413 ZZPI=0.
11414 ZPZPI=0.
11415 ELSEIF(MSTP(44).EQ.3) THEN
11416C...Only Z'0 production included
11417 GGI=0.
11418 GZI=0.
11419 GZPI=0.
11420 ZZI=0.
11421 ZZPI=0.
11422 ELSEIF(MSTP(44).EQ.4) THEN
11423C...Only gamma*/Z0 production included
11424 GZPI=0.
11425 ZZPI=0.
11426 ZPZPI=0.
11427 ELSEIF(MSTP(44).EQ.5) THEN
11428C...Only gamma*/Z'0 production included
11429 GZI=0.
11430 ZZI=0.
11431 ZZPI=0.
11432 ELSEIF(MSTP(44).EQ.6) THEN
11433C...Only Z0/Z'0 production included
11434 GGI=0.
11435 GZI=0.
11436 GZPI=0.
11437 ENDIF
11438 ELSEIF(MINT(61).EQ.2) THEN
11439 VINT(111)=0.
11440 VINT(112)=0.
11441 VINT(113)=0.
11442 VINT(114)=0.
11443 VINT(115)=0.
11444 VINT(116)=0.
11445 ENDIF
11446 DO 180 I=1,MDCY(32,3)
11447 IDC=I+MDCY(32,2)-1
11448 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11449 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11450 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 180
11451 IF(I.LE.8) THEN
11452C...Z'0 -> q + qb
11453 EF=KCHG(I,1)/3.
11454 AF=SIGN(1.,EF+0.1)
11455 VF=AF-4.*EF*XW
11456 APF=SIGN(1.,EF+0.1)
11457 VPF=APF-4.*EF*XW
11458 IF(MINT(61).EQ.0) THEN
11459 WDTP(I)=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
11460 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11461 ELSEIF(MINT(61).EQ.1) THEN
11462 WDTP(I)=3.*((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+
11463 & ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+
11464 & ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))*
11465 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11466 ELSEIF(MINT(61).EQ.2) THEN
11467 GGF=3.*EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11468 GZF=3.*EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11469 GZPF=3.*EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))*RADC
11470 ZZF=3.*(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11471 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11472 ZZPF=3.*(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*
11473 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11474 ZPZPF=3.*(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
11475 & SQRT(MAX(0.,1.-4.*RM1))*RADC
11476 ENDIF
11477 WID2=1.
11478 ELSE
11479C...Z'0 -> l+ + l-, nu + nub
11480 EF=KCHG(I+2,1)/3.
11481 AF=SIGN(1.,EF+0.1)
11482 VF=AF-4.*EF*XW
11483clin-4/2008 modified above a la pythia6115.f to avoid undefined variable API:
11484c APF=SIGN(1.,EF+0.1)
11485c VPF=API-4.*EF*XW
11486 IF(I.LE.10) THEN
11487 VPF=PARU(127-2*MOD(I,2))
11488 APF=PARU(128-2*MOD(I,2))
11489 ELSEIF(I.LE.12) THEN
11490 VPF=PARJ(186-2*MOD(I,2))
11491 APF=PARJ(187-2*MOD(I,2))
11492 ELSE
11493 VPF=PARJ(194-2*MOD(I,2))
11494 APF=PARJ(195-2*MOD(I,2))
11495 ENDIF
11496clin-4/2008-end
11497 IF(MINT(61).EQ.0) THEN
11498 WDTP(I)=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
11499 & SQRT(MAX(0.,1.-4.*RM1))
11500 ELSEIF(MINT(61).EQ.1) THEN
11501 WDTP(I)=((GGI*EF**2+GZI*EF*VF+GZPI*EF*VPF+ZZI*VF**2+
11502 & ZZPI*VF*VPF+ZPZPI*VPF**2)*(1.+2.*RM1)+(ZZI*AF**2+
11503 & ZZPI*AF*APF+ZPZPI*APF**2)*(1.-4.*RM1))*
11504 & SQRT(MAX(0.,1.-4.*RM1))
11505 ELSEIF(MINT(61).EQ.2) THEN
11506 GGF=EF**2*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11507 GZF=EF*VF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11508 GZPF=EF*VPF*(1.+2.*RM1)*SQRT(MAX(0.,1.-4.*RM1))
11509 ZZF=(VF**2*(1.+2.*RM1)+AF**2*(1.-4.*RM1))*
11510 & SQRT(MAX(0.,1.-4.*RM1))
11511 ZZPF=(VF*VPF*(1.+2.*RM1)+AF*APF*(1.-4.*RM1))*
11512 & SQRT(MAX(0.,1.-4.*RM1))
11513 ZPZPF=(VPF**2*(1.+2.*RM1)+APF**2*(1.-4.*RM1))*
11514 & SQRT(MAX(0.,1.-4.*RM1))
11515 ENDIF
11516 WID2=1.
11517 ENDIF
11518 WDTP(0)=WDTP(0)+WDTP(I)
11519 IF(MDME(IDC,1).GT.0) THEN
11520 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11521 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11522 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11523 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11524clin-4/2008:
11525c VINT(111)=VINT(111)+GGF
11526c VINT(112)=VINT(112)+GZF
11527c VINT(113)=VINT(113)+GZPF
11528c VINT(114)=VINT(114)+ZZF
11529c VINT(115)=VINT(115)+ZZPF
11530c VINT(116)=VINT(116)+ZPZPF
11531 IF(MINT(61).EQ.2) THEN
11532 VINT(111)=VINT(111)+GGF
11533 VINT(112)=VINT(112)+GZF
11534 VINT(113)=VINT(113)+GZPF
11535 VINT(114)=VINT(114)+ZZF
11536 VINT(115)=VINT(115)+ZZPF
11537 VINT(116)=VINT(116)+ZPZPF
11538 ENDIF
11539clin-4/2008-end
11540 ENDIF
11541 180 CONTINUE
11542 IF(MSTP(44).EQ.1) THEN
11543C...Only gamma* production included
11544 VINT(112)=0.
11545 VINT(113)=0.
11546 VINT(114)=0.
11547 VINT(115)=0.
11548 VINT(116)=0.
11549 ELSEIF(MSTP(44).EQ.2) THEN
11550C...Only Z0 production included
11551 VINT(111)=0.
11552 VINT(112)=0.
11553 VINT(113)=0.
11554 VINT(115)=0.
11555 VINT(116)=0.
11556 ELSEIF(MSTP(44).EQ.3) THEN
11557C...Only Z'0 production included
11558 VINT(111)=0.
11559 VINT(112)=0.
11560 VINT(113)=0.
11561 VINT(114)=0.
11562 VINT(115)=0.
11563 ELSEIF(MSTP(44).EQ.4) THEN
11564C...Only gamma*/Z0 production included
11565 VINT(113)=0.
11566 VINT(115)=0.
11567 VINT(116)=0.
11568 ELSEIF(MSTP(44).EQ.5) THEN
11569C...Only gamma*/Z'0 production included
11570 VINT(112)=0.
11571 VINT(114)=0.
11572 VINT(115)=0.
11573 ELSEIF(MSTP(44).EQ.6) THEN
11574C...Only Z0/Z'0 production included
11575 VINT(111)=0.
11576 VINT(112)=0.
11577 VINT(113)=0.
11578 ENDIF
11579
11580 ELSEIF(KFLA.EQ.37) THEN
11581C...H+/-:
11582 DO 190 I=1,MDCY(37,3)
11583 IDC=I+MDCY(37,2)-1
11584 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11585 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11586 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 190
11587 IF(I.LE.4) THEN
11588C...H+/- -> q + qb'
11589 WDTP(I)=3.*((RM1*PARU(121)+RM2/PARU(121))*
11590 & (1.-RM1-RM2)-4.*RM1*RM2)*
11591 & SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))*RADC
11592 WID2=1.
11593 ELSE
11594C...H+/- -> l+/- + nu
11595 WDTP(I)=((RM1*PARU(121)+RM2/PARU(121))*
11596 & (1.-RM1-RM2)-4.*RM1*RM2)*
11597 & SQRT(MAX(0.,(1.-RM1-RM2)**2-4.*RM1*RM2))
11598 WID2=1.
11599 ENDIF
11600 WDTP(0)=WDTP(0)+WDTP(I)
11601 IF(MDME(IDC,1).GT.0) THEN
11602 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11603 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11604 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11605 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11606 ENDIF
11607 190 CONTINUE
11608
11609 ELSEIF(KFLA.EQ.40) THEN
11610C...R:
11611 DO 200 I=1,MDCY(40,3)
11612 IDC=I+MDCY(40,2)-1
11613 RM1=(PMAS(IABS(KFDP(IDC,1)),1)/RMAS)**2
11614 RM2=(PMAS(IABS(KFDP(IDC,2)),1)/RMAS)**2
11615 IF(SQRT(RM1)+SQRT(RM2).GT.1..OR.MDME(IDC,1).LT.0) GOTO 200
11616 IF(I.LE.4) THEN
11617C...R -> q + qb'
11618 WDTP(I)=3.*RADC
11619 WID2=1.
11620 ELSE
11621C...R -> l+ + l'-
11622 WDTP(I)=1.
11623 WID2=1.
11624 ENDIF
11625 WDTP(0)=WDTP(0)+WDTP(I)
11626 IF(MDME(IDC,1).GT.0) THEN
11627 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
11628 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
11629 WDTE(I,0)=WDTE(I,MDME(IDC,1))
11630 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
11631 ENDIF
11632 200 CONTINUE
11633
11634 ENDIF
11635 MINT(61)=0
11636
11637 RETURN
11638 END
11639
11640C***********************************************************************
11641
ce320da8 11642 SUBROUTINE PYKLIMA(ILIM)
0119ef9a 11643
11644C...Checks generated variables against pre-set kinematical limits;
11645C...also calculates limits on variables used in generation.
11646 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11647 SAVE /LUDAT1A/
11648 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11649 SAVE /LUDAT2A/
11650 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
11651 SAVE /LUDAT3A/
11652 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
11653 SAVE /PYPARSA/
11654 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
11655 SAVE /PYSUBSA/
11656 COMMON/PYINT1A/MINT(400),VINT(400)
11657 SAVE /PYINT1A/
11658 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11659 SAVE /PYINT2A/
11660
11661 tau=0.
11662 rm3=0.
11663 rm4=0.
11664 be34=0.
11665 st2eff=0.
11666
11667C...Common kinematical expressions.
11668 ISUB=MINT(1)
11669 IF(ISUB.EQ.96) GOTO 110
11670 SQM3=VINT(63)
11671 SQM4=VINT(64)
11672 IF(ILIM.NE.1) THEN
11673 TAU=VINT(21)
11674 RM3=SQM3/(TAU*VINT(2))
11675 RM4=SQM4/(TAU*VINT(2))
11676 BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)
11677 ENDIF
11678 PTHMIN=CKIN(3)
11679 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) PTHMIN=MAX(CKIN(3),CKIN(5))
11680 IF(ILIM.EQ.0) THEN
11681C...Check generated values of tau, y*, cos(theta-hat), and tau' against
11682C...pre-set kinematical limits.
11683 YST=VINT(22)
11684 CTH=VINT(23)
11685 TAUP=VINT(26)
11686 IF(ISET(ISUB).LE.2) THEN
11687 X1=SQRT(TAU)*EXP(YST)
11688 X2=SQRT(TAU)*EXP(-YST)
11689 ELSE
11690 X1=SQRT(TAUP)*EXP(YST)
11691 X2=SQRT(TAUP)*EXP(-YST)
11692 ENDIF
11693 XF=X1-X2
11694 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
11695 IF(CKIN(2).GE.0..AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
11696 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
11697 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
11698 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
11699 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
11700 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
11701 PTH=0.5*BE34*SQRT(TAU*VINT(2)*(1.-CTH**2))
11702 Y3=YST+0.5*LOG((1.+RM3-RM4+BE34*CTH)/(1.+RM3-RM4-BE34*CTH))
11703 Y4=YST+0.5*LOG((1.+RM4-RM3-BE34*CTH)/(1.+RM4-RM3+BE34*CTH))
11704 YLARGE=MAX(Y3,Y4)
11705 YSMALL=MIN(Y3,Y4)
11706 ETALAR=10.
11707 ETASMA=-10.
11708 STH=SQRT(1.-CTH**2)
11709 IF(STH.LT.1.E-6) GOTO 100
11710 EXPET3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+
11711 & SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3))/
11712 & (BE34*STH)
11713 EXPET4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+
11714 & SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4))/
11715 & (BE34*STH)
11716 ETA3=LOG(MIN(1.E10,MAX(1.E-10,EXPET3)))
11717 ETA4=LOG(MIN(1.E10,MAX(1.E-10,EXPET4)))
11718 ETALAR=MAX(ETA3,ETA4)
11719 ETASMA=MIN(ETA3,ETA4)
11720 100 CTS3=((1.+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/
11721 & SQRT(((1.+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*CTH)**2-4.*RM3)
11722 CTS4=((1.-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/
11723 & SQRT(((1.-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*CTH)**2-4.*RM4)
11724 CTSLAR=MAX(CTS3,CTS4)
11725 CTSSMA=MIN(CTS3,CTS4)
11726 IF(PTH.LT.PTHMIN) MINT(51)=1
11727 IF(CKIN(4).GE.0..AND.PTH.GT.CKIN(4)) MINT(51)=1
11728 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
11729 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
11730 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
11731 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
11732 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
11733 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
11734 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
11735 ENDIF
11736 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
11737 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
11738 IF(CKIN(32).GE.0..AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
11739 ENDIF
11740
11741 ELSEIF(ILIM.EQ.1) THEN
11742C...Calculate limits on tau
11743C...0) due to definition
11744 TAUMN0=0.
11745 TAUMX0=1.
11746C...1) due to limits on subsystem mass
11747 TAUMN1=CKIN(1)**2/VINT(2)
11748 TAUMX1=1.
11749 IF(CKIN(2).GE.0.) TAUMX1=CKIN(2)**2/VINT(2)
11750C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
11751 TM3=SQRT(SQM3+PTHMIN**2)
11752 TM4=SQRT(SQM4+PTHMIN**2)
11753 YDCOSH=1.
11754 IF(CKIN(9).GT.CKIN(12)) YDCOSH=COSH(CKIN(9)-CKIN(12))
11755 TAUMN2=(TM3**2+2.*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
11756 TAUMX2=1.
11757C...3) due to limits on pT-hat and cos(theta-hat)
11758 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
11759 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
11760 TAUMN3=0.
11761 IF(CKIN(27)*CKIN(28).GT.0.) TAUMN3=
11762 & (SQRT(SQM3+PTHMIN**2/(1.-CTH2MN))+
11763 & SQRT(SQM4+PTHMIN**2/(1.-CTH2MN)))**2/VINT(2)
11764 TAUMX3=1.
11765 IF(CKIN(4).GE.0..AND.CTH2MX.LT.1.) TAUMX3=
11766 & (SQRT(SQM3+CKIN(4)**2/(1.-CTH2MX))+
11767 & SQRT(SQM4+CKIN(4)**2/(1.-CTH2MX)))**2/VINT(2)
11768C...4) due to limits on x1 and x2
11769 TAUMN4=CKIN(21)*CKIN(23)
11770 TAUMX4=CKIN(22)*CKIN(24)
11771C...5) due to limits on xF
11772 TAUMN5=0.
11773 TAUMX5=MAX(1.-CKIN(25),1.+CKIN(26))
11774 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5)
11775 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5)
11776 IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN
11777 VINT(11)=0.99999
11778 VINT(31)=1.00001
11779 ENDIF
11780 IF(VINT(31).LE.VINT(11)) MINT(51)=1
11781
11782 ELSEIF(ILIM.EQ.2) THEN
11783C...Calculate limits on y*
11784 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) TAU=VINT(26)
11785 TAURT=SQRT(TAU)
11786C...0) due to kinematics
11787 YSTMN0=LOG(TAURT)
11788 YSTMX0=-YSTMN0
11789C...1) due to explicit limits
11790 YSTMN1=CKIN(7)
11791 YSTMX1=CKIN(8)
11792C...2) due to limits on x1
11793 YSTMN2=LOG(MAX(TAU,CKIN(21))/TAURT)
11794 YSTMX2=LOG(MAX(TAU,CKIN(22))/TAURT)
11795C...3) due to limits on x2
11796 YSTMN3=-LOG(MAX(TAU,CKIN(24))/TAURT)
11797 YSTMX3=-LOG(MAX(TAU,CKIN(23))/TAURT)
11798C...4) due to limits on xF
11799 YEPMN4=0.5*ABS(CKIN(25))/TAURT
11800 YSTMN4=SIGN(LOG(SQRT(1.+YEPMN4**2)+YEPMN4),CKIN(25))
11801 YEPMX4=0.5*ABS(CKIN(26))/TAURT
11802 YSTMX4=SIGN(LOG(SQRT(1.+YEPMX4**2)+YEPMX4),CKIN(26))
11803C...5) due to simultaneous limits on y-large and y-small
11804 YEPSMN=(RM3-RM4)*SINH(CKIN(9)-CKIN(11))
11805 YEPSMX=(RM3-RM4)*SINH(CKIN(10)-CKIN(12))
11806 YDIFMN=ABS(LOG(SQRT(1.+YEPSMN**2)-YEPSMN))
11807 YDIFMX=ABS(LOG(SQRT(1.+YEPSMX**2)-YEPSMX))
11808 YSTMN5=0.5*(CKIN(9)+CKIN(11)-YDIFMN)
11809 YSTMX5=0.5*(CKIN(10)+CKIN(12)+YDIFMX)
11810C...6) due to simultaneous limits on cos(theta-hat) and y-large or
11811C... y-small
11812 CTHLIM=SQRT(1.-4.*PTHMIN**2/(BE34*TAU*VINT(2)))
11813 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
11814 RZMX=BE34*MIN(CKIN(28),CTHLIM)
11815 YEX3MX=(1.+RM3-RM4+RZMX)/MAX(1E-10,1.+RM3-RM4-RZMX)
11816 YEX4MX=(1.+RM4-RM3-RZMN)/MAX(1E-10,1.+RM4-RM3+RZMN)
11817 YEX3MN=MAX(1E-10,1.+RM3-RM4+RZMN)/(1.+RM3-RM4-RZMN)
11818 YEX4MN=MAX(1E-10,1.+RM4-RM3-RZMX)/(1.+RM4-RM3+RZMX)
11819 YSTMN6=CKIN(9)-0.5*LOG(MAX(YEX3MX,YEX4MX))
11820 YSTMX6=CKIN(12)-0.5*LOG(MIN(YEX3MN,YEX4MN))
11821 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
11822 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
11823 IF(MINT(43).EQ.1) THEN
11824 VINT(12)=-0.00001
11825 VINT(32)=0.00001
11826 ELSEIF(MINT(43).EQ.2) THEN
11827 VINT(12)=0.99999*YSTMX0
11828 VINT(32)=1.00001*YSTMX0
11829 ELSEIF(MINT(43).EQ.3) THEN
11830 VINT(12)=-1.00001*YSTMX0
11831 VINT(32)=-0.99999*YSTMX0
11832 ENDIF
11833 IF(VINT(32).LE.VINT(12)) MINT(51)=1
11834
11835 ELSEIF(ILIM.EQ.3) THEN
11836C...Calculate limits on cos(theta-hat)
11837 YST=VINT(22)
11838C...0) due to definition
11839 CTNMN0=-1.
11840 CTNMX0=0.
11841 CTPMN0=0.
11842 CTPMX0=1.
11843C...1) due to explicit limits
11844 CTNMN1=MIN(0.,CKIN(27))
11845 CTNMX1=MIN(0.,CKIN(28))
11846 CTPMN1=MAX(0.,CKIN(27))
11847 CTPMX1=MAX(0.,CKIN(28))
11848C...2) due to limits on pT-hat
11849 CTNMN2=-SQRT(1.-4.*PTHMIN**2/(BE34**2*TAU*VINT(2)))
11850 CTPMX2=-CTNMN2
11851 CTNMX2=0.
11852 CTPMN2=0.
11853 IF(CKIN(4).GE.0.) THEN
11854 CTNMX2=-SQRT(MAX(0.,1.-4.*CKIN(4)**2/(BE34**2*TAU*VINT(2))))
11855 CTPMN2=-CTNMX2
11856 ENDIF
11857C...3) due to limits on y-large and y-small
11858 CTNMN3=MIN(0.,MAX((1.+RM3-RM4)/BE34*TANH(CKIN(11)-YST),
11859 & -(1.-RM3+RM4)/BE34*TANH(CKIN(10)-YST)))
11860 CTNMX3=MIN(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(12)-YST),
11861 & -(1.-RM3+RM4)/BE34*TANH(CKIN(9)-YST))
11862 CTPMN3=MAX(0.,(1.+RM3-RM4)/BE34*TANH(CKIN(9)-YST),
11863 & -(1.-RM3+RM4)/BE34*TANH(CKIN(12)-YST))
11864 CTPMX3=MAX(0.,MIN((1.+RM3-RM4)/BE34*TANH(CKIN(10)-YST),
11865 & -(1.-RM3+RM4)/BE34*TANH(CKIN(11)-YST)))
11866 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3)
11867 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3)
11868 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3)
11869 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3)
11870 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
11871
11872 ELSEIF(ILIM.EQ.4) THEN
11873C...Calculate limits on tau'
11874C...0) due to kinematics
11875 TAPMN0=TAU
11876 TAPMX0=1.
11877C...1) due to explicit limits
11878 TAPMN1=CKIN(31)**2/VINT(2)
11879 TAPMX1=1.
11880 IF(CKIN(32).GE.0.) TAPMX1=CKIN(32)**2/VINT(2)
11881 VINT(16)=MAX(TAPMN0,TAPMN1)
11882 VINT(36)=MIN(TAPMX0,TAPMX1)
11883 IF(MINT(43).EQ.1) THEN
11884 VINT(16)=0.99999
11885 VINT(36)=1.00001
11886 ENDIF
11887 IF(VINT(36).LE.VINT(16)) MINT(51)=1
11888
11889 ENDIF
11890 RETURN
11891
11892C...Special case for low-pT and multiple interactions:
11893C...effective kinematical limits for tau, y*, cos(theta-hat).
11894 110 IF(ILIM.EQ.0) THEN
11895 ELSEIF(ILIM.EQ.1) THEN
11896 IF(MSTP(82).LE.1) VINT(11)=4.*PARP(81)**2/VINT(2)
11897 IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
11898 VINT(31)=1.
11899 ELSEIF(ILIM.EQ.2) THEN
11900 VINT(12)=0.5*LOG(VINT(21))
11901 VINT(32)=-VINT(12)
11902 ELSEIF(ILIM.EQ.3) THEN
11903 IF(MSTP(82).LE.1) ST2EFF=4.*PARP(81)**2/(VINT(21)*VINT(2))
11904 IF(MSTP(82).GE.2) ST2EFF=0.01*PARP(82)**2/(VINT(21)*VINT(2))
11905 VINT(13)=-SQRT(MAX(0.,1.-ST2EFF))
11906 VINT(33)=0.
11907 VINT(14)=0.
11908 VINT(34)=-VINT(13)
11909 ENDIF
11910
11911 RETURN
11912 END
11913
11914C*********************************************************************
11915
ce320da8 11916 SUBROUTINE PYKMAPA(IVAR,MVAR,VVAR)
0119ef9a 11917
11918C...Maps a uniform distribution into a distribution of a kinematical
11919C...variable according to one of the possibilities allowed. It is
11920C...assumed that kinematical limits have been set by a PYKLIM call.
11921 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11922 SAVE /LUDAT2A/
11923 COMMON/PYINT1A/MINT(400),VINT(400)
11924 SAVE /PYINT1A/
11925 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
11926 SAVE /PYINT2A/
11927
11928 taure=0.
11929 gamre=0.
11930 cth=0.
11931
11932C...Convert VVAR to tau variable.
11933 ISUB=MINT(1)
11934 IF(IVAR.EQ.1) THEN
11935 TAUMIN=VINT(11)
11936 TAUMAX=VINT(31)
11937 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
11938 TAURE=VINT(73)
11939 GAMRE=VINT(74)
11940 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
11941 TAURE=VINT(75)
11942 GAMRE=VINT(76)
11943 ENDIF
11944 IF(MINT(43).EQ.1.AND.(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.2)) THEN
11945 TAU=1.
11946 ELSEIF(MVAR.EQ.1) THEN
11947 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
11948 ELSEIF(MVAR.EQ.2) THEN
11949 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
11950 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
11951 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
11952 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
11953 ELSE
11954 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
11955 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
11956 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
11957 ENDIF
11958 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
11959
11960C...Convert VVAR to y* variable.
11961 ELSEIF(IVAR.EQ.2) THEN
11962 YSTMIN=VINT(12)
11963 YSTMAX=VINT(32)
11964 IF(MINT(43).EQ.1) THEN
11965 YST=0.
11966 ELSEIF(MINT(43).EQ.2) THEN
11967 IF(ISET(ISUB).LE.2) YST=-0.5*LOG(VINT(21))
11968 IF(ISET(ISUB).GE.3) YST=-0.5*LOG(VINT(26))
11969 ELSEIF(MINT(43).EQ.3) THEN
11970 IF(ISET(ISUB).LE.2) YST=0.5*LOG(VINT(21))
11971 IF(ISET(ISUB).GE.3) YST=0.5*LOG(VINT(26))
11972 ELSEIF(MVAR.EQ.1) THEN
11973 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
11974 ELSEIF(MVAR.EQ.2) THEN
11975 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1.-VVAR)
11976 ELSE
11977 AUPP=ATAN(EXP(YSTMAX))
11978 ALOW=ATAN(EXP(YSTMIN))
11979 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
11980 ENDIF
11981 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
11982
11983C...Convert VVAR to cos(theta-hat) variable.
11984 ELSEIF(IVAR.EQ.3) THEN
11985 RM34=2.*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2
11986 RSQM=1.+RM34
11987 IF(2.*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001) RM34=MAX(RM34,
11988 & 2.*VINT(71)**2/(VINT(21)*VINT(2)))
11989 CTNMIN=VINT(13)
11990 CTNMAX=VINT(33)
11991 CTPMIN=VINT(14)
11992 CTPMAX=VINT(34)
11993 IF(MVAR.EQ.1) THEN
11994 ANEG=CTNMAX-CTNMIN
11995 APOS=CTPMAX-CTPMIN
11996 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
11997 VCTN=VVAR*(ANEG+APOS)/ANEG
11998 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
11999 ELSE
12000 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12001 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
12002 ENDIF
12003 ELSEIF(MVAR.EQ.2) THEN
12004 RMNMIN=MAX(RM34,RSQM-CTNMIN)
12005 RMNMAX=MAX(RM34,RSQM-CTNMAX)
12006 RMPMIN=MAX(RM34,RSQM-CTPMIN)
12007 RMPMAX=MAX(RM34,RSQM-CTPMAX)
12008 ANEG=LOG(RMNMIN/RMNMAX)
12009 APOS=LOG(RMPMIN/RMPMAX)
12010 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
12011 VCTN=VVAR*(ANEG+APOS)/ANEG
12012 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
12013 ELSE
12014 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12015 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
12016 ENDIF
12017 ELSEIF(MVAR.EQ.3) THEN
12018 RMNMIN=MAX(RM34,RSQM+CTNMIN)
12019 RMNMAX=MAX(RM34,RSQM+CTNMAX)
12020 RMPMIN=MAX(RM34,RSQM+CTPMIN)
12021 RMPMAX=MAX(RM34,RSQM+CTPMAX)
12022 ANEG=LOG(RMNMAX/RMNMIN)
12023 APOS=LOG(RMPMAX/RMPMIN)
12024 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
12025 VCTN=VVAR*(ANEG+APOS)/ANEG
12026 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
12027 ELSE
12028 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12029 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
12030 ENDIF
12031 ELSEIF(MVAR.EQ.4) THEN
12032 RMNMIN=MAX(RM34,RSQM-CTNMIN)
12033 RMNMAX=MAX(RM34,RSQM-CTNMAX)
12034 RMPMIN=MAX(RM34,RSQM-CTPMIN)
12035 RMPMAX=MAX(RM34,RSQM-CTPMAX)
12036 ANEG=1./RMNMAX-1./RMNMIN
12037 APOS=1./RMPMAX-1./RMPMIN
12038 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
12039 VCTN=VVAR*(ANEG+APOS)/ANEG
12040 CTH=RSQM-1./(1./RMNMIN+ANEG*VCTN)
12041 ELSE
12042 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12043 CTH=RSQM-1./(1./RMPMIN+APOS*VCTP)
12044 ENDIF
12045 ELSEIF(MVAR.EQ.5) THEN
12046 RMNMIN=MAX(RM34,RSQM+CTNMIN)
12047 RMNMAX=MAX(RM34,RSQM+CTNMAX)
12048 RMPMIN=MAX(RM34,RSQM+CTPMIN)
12049 RMPMAX=MAX(RM34,RSQM+CTPMAX)
12050 ANEG=1./RMNMIN-1./RMNMAX
12051 APOS=1./RMPMIN-1./RMPMAX
12052 IF(ANEG.GT.0..AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
12053 VCTN=VVAR*(ANEG+APOS)/ANEG
12054 CTH=1./(1./RMNMIN-ANEG*VCTN)-RSQM
12055 ELSE
12056 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
12057 CTH=1./(1./RMPMIN-APOS*VCTP)-RSQM
12058 ENDIF
12059 ENDIF
12060 IF(CTH.LT.0.) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
12061 IF(CTH.GT.0.) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
12062 VINT(23)=CTH
12063
12064C...Convert VVAR to tau' variable.
12065 ELSEIF(IVAR.EQ.4) THEN
12066 TAU=VINT(11)
12067 TAUPMN=VINT(16)
12068 TAUPMX=VINT(36)
12069 IF(MINT(43).EQ.1) THEN
12070 TAUP=1.
12071 ELSEIF(MVAR.EQ.1) THEN
12072 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
12073 ELSE
12074 AUPP=(1.-TAU/TAUPMX)**4
12075 ALOW=(1.-TAU/TAUPMN)**4
12076 TAUP=TAU/(1.-(ALOW+(AUPP-ALOW)*VVAR)**0.25)
12077 ENDIF
12078 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
12079 ENDIF
12080
12081 RETURN
12082 END
12083
12084C***********************************************************************
12085
ce320da8 12086 SUBROUTINE PYSIGHA(NCHN,SIGS)
0119ef9a 12087
12088C...Differential matrix elements for all included subprocesses.
12089C...Note that what is coded is (disregarding the COMFAC factor)
12090C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
12091C...when d(sigma-hat) is given in the zero-width limit, the delta
12092C...function in tau is replaced by a Breit-Wigner:
12093C...1/pi*(s*m_res*Gamma_res)/((s*tau-m_res^2)^2+(m_res*Gamma_res)^2);
12094C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
12095C...i.e., dimensionless quantities. COMFAC contains the factor
12096C...pi/s and the conversion factor from GeV^-2 to mb.
12097 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12098 SAVE /LUDAT1A/
12099 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
12100 SAVE /LUDAT2A/
12101 COMMON/LUDAT3A/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
12102 SAVE /LUDAT3A/
12103 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
12104 SAVE /PYSUBSA/
12105 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
12106 SAVE /PYPARSA/
12107 COMMON/PYINT1A/MINT(400),VINT(400)
12108 SAVE /PYINT1A/
12109 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
12110 SAVE /PYINT2A/
12111 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12112 SAVE /PYINT3A/
12113 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
12114 SAVE /PYINT4AA/
12115 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
12116 SAVE /PYINT5A/
12117 DIMENSION X(2),XPQ(-6:6),KFAC(2,-40:40),WDTP(0:40),WDTE(0:40,0:5)
12118
12119 as=0.
12120 faca=0.
12121 min1=0.
12122 max1=0.
12123 min2=0.
12124 max2=0.
12125 mina=0.
12126 maxa=0.
12127 sqmz=0.
12128 gmmz=0.
12129 sqmw=0.
12130 gmmw=0.
12131 sqmh=0.
12132 gmmh=0.
12133 sqmzp=0.
12134 gmmzp=0.
12135 sqmhc=0.
12136 gmmhc=0.
12137 sqmr=0.
12138 gmmr=0.
12139 aem=0.
12140 xw=0.
12141 comfac=0.
12142
12143C...Reset number of channels and cross-section.
12144 NCHN=0
12145 SIGS=0.
12146
12147C...Read kinematical variables and limits.
12148 ISUB=MINT(1)
12149 TAUMIN=VINT(11)
12150 YSTMIN=VINT(12)
12151 CTNMIN=VINT(13)
12152 CTPMIN=VINT(14)
12153 XT2MIN=VINT(15)
12154 TAUPMN=VINT(16)
12155 TAU=VINT(21)
12156 YST=VINT(22)
12157 CTH=VINT(23)
12158 XT2=VINT(25)
12159 TAUP=VINT(26)
12160 TAUMAX=VINT(31)
12161 YSTMAX=VINT(32)
12162 CTNMAX=VINT(33)
12163 CTPMAX=VINT(34)
12164 XT2MAX=VINT(35)
12165 TAUPMX=VINT(36)
12166
12167C...Derive kinematical quantities.
12168 IF(ISET(ISUB).LE.2.OR.ISET(ISUB).EQ.5) THEN
12169 X(1)=SQRT(TAU)*EXP(YST)
12170 X(2)=SQRT(TAU)*EXP(-YST)
12171 ELSE
12172 X(1)=SQRT(TAUP)*EXP(YST)
12173 X(2)=SQRT(TAUP)*EXP(-YST)
12174 ENDIF
12175 IF(MINT(43).EQ.4.AND.ISET(ISUB).GE.1.AND.
12176 &(X(1).GT.0.999.OR.X(2).GT.0.999)) RETURN
12177 SH=TAU*VINT(2)
12178 SQM3=VINT(63)
12179 SQM4=VINT(64)
12180 RM3=SQM3/SH
12181 RM4=SQM4/SH
12182 BE34=SQRT((1.-RM3-RM4)**2-4.*RM3*RM4)
12183 RPTS=4.*VINT(71)**2/SH
12184 BE34L=SQRT(MAX(0.,(1.-RM3-RM4)**2-4.*RM3*RM4-RPTS))
12185 RM34=2.*RM3*RM4
12186 RSQM=1.+RM34
12187 RTHM=(4.*RM3*RM4+RPTS)/(1.-RM3-RM4+BE34L)
12188 TH=-0.5*SH*MAX(RTHM,1.-RM3-RM4-BE34*CTH)
12189 UH=-0.5*SH*MAX(RTHM,1.-RM3-RM4+BE34*CTH)
12190 SQPTH=0.25*SH*BE34**2*(1.-CTH**2)
12191 SH2=SH**2
12192 TH2=TH**2
12193 UH2=UH**2
12194
12195C...Choice of Q2 scale.
12196 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12197 Q2=SH
12198 ELSEIF(MOD(ISET(ISUB),2).EQ.0.OR.ISET(ISUB).EQ.5) THEN
12199 IF(MSTP(32).EQ.1) THEN
12200 Q2=2.*SH*TH*UH/(SH**2+TH**2+UH**2)
12201 ELSEIF(MSTP(32).EQ.2) THEN
12202 Q2=SQPTH+0.5*(SQM3+SQM4)
12203 ELSEIF(MSTP(32).EQ.3) THEN
12204 Q2=MIN(-TH,-UH)
12205 ELSEIF(MSTP(32).EQ.4) THEN
12206 Q2=SH
12207 ENDIF
12208 IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2=Q2+PARP(82)**2
12209 ENDIF
12210
12211C...Store derived kinematical quantities.
12212 VINT(41)=X(1)
12213 VINT(42)=X(2)
12214 VINT(44)=SH
12215 VINT(43)=SQRT(SH)
12216 VINT(45)=TH
12217 VINT(46)=UH
12218 VINT(48)=SQPTH
12219 VINT(47)=SQRT(SQPTH)
12220 VINT(50)=TAUP*VINT(2)
12221 VINT(49)=SQRT(MAX(0.,VINT(50)))
12222 VINT(52)=Q2
12223 VINT(51)=SQRT(Q2)
12224
12225C...Calculate parton structure functions.
12226 IF(ISET(ISUB).LE.0) GOTO 145
12227 IF(MINT(43).GE.2) THEN
12228 Q2SF=Q2
12229 IF(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4) THEN
12230 Q2SF=PMAS(23,1)**2
12231 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77) Q2SF=PMAS(24,1)**2
12232 ENDIF
12233 DO 100 I=3-MINT(41),MINT(42)
12234 XSF=X(I)
12235 IF(ISET(ISUB).EQ.5) XSF=X(I)/VINT(142+I)
12236 CALL PYSTFU(MINT(10+I),XSF,Q2SF,XPQ,I)
12237 DO 100 KFL=-6,6
12238 100 XSFX(I,KFL)=XPQ(KFL)
12239 ENDIF
12240
12241C...Calculate alpha_strong and K-factor.
12242 IF(MSTP(33).NE.3) AS=ULALPS(Q2)
12243 FACK=1.
12244 FACA=1.
12245 IF(MSTP(33).EQ.1) THEN
12246 FACK=PARP(31)
12247 ELSEIF(MSTP(33).EQ.2) THEN
12248 FACK=PARP(31)
12249 FACA=PARP(32)/PARP(31)
12250 ELSEIF(MSTP(33).EQ.3) THEN
12251 Q2AS=PARP(33)*Q2
12252 IF(ISET(ISUB).EQ.5.AND.MSTP(82).GE.2) Q2AS=Q2AS+
12253 & PARU(112)*PARP(82)
12254 AS=ULALPS(Q2AS)
12255 ENDIF
12256 RADC=1.+AS/PARU(1)
12257
12258C...Set flags for allowed reacting partons/leptons.
12259 DO 130 I=1,2
12260 DO 110 J=-40,40
12261 110 KFAC(I,J)=0
12262 IF(MINT(40+I).EQ.1) THEN
12263 KFAC(I,MINT(10+I))=1
12264 ELSE
12265 DO 120 J=-40,40
12266 KFAC(I,J)=KFIN(I,J)
12267 IF(ABS(J).GT.MSTP(54).AND.J.NE.21) KFAC(I,J)=0
12268 IF(ABS(J).LE.6) THEN
12269 IF(XSFX(I,J).LT.1.E-10) KFAC(I,J)=0
12270 ELSEIF(J.EQ.21) THEN
12271 IF(XSFX(I,0).LT.1.E-10) KFAC(I,21)=0
12272 ENDIF
12273 120 CONTINUE
12274 ENDIF
12275 130 CONTINUE
12276
12277C...Lower and upper limit for flavour loops.
12278 MIN1=0
12279 MAX1=0
12280 MIN2=0
12281 MAX2=0
12282 DO 140 J=-20,20
12283 IF(KFAC(1,-J).EQ.1) MIN1=-J
12284 IF(KFAC(1,J).EQ.1) MAX1=J
12285 IF(KFAC(2,-J).EQ.1) MIN2=-J
12286 IF(KFAC(2,J).EQ.1) MAX2=J
12287 140 CONTINUE
12288 MINA=MIN(MIN1,MIN2)
12289 MAXA=MAX(MAX1,MAX2)
12290
12291C...Common conversion factors (including Jacobian) for subprocesses.
12292 SQMZ=PMAS(23,1)**2
12293 GMMZ=PMAS(23,1)*PMAS(23,2)
12294 SQMW=PMAS(24,1)**2
12295 GMMW=PMAS(24,1)*PMAS(24,2)
12296 SQMH=PMAS(25,1)**2
12297 GMMH=PMAS(25,1)*PMAS(25,2)
12298 SQMZP=PMAS(32,1)**2
12299 GMMZP=PMAS(32,1)*PMAS(32,2)
12300 SQMHC=PMAS(37,1)**2
12301 GMMHC=PMAS(37,1)*PMAS(37,2)
12302 SQMR=PMAS(40,1)**2
12303 GMMR=PMAS(40,1)*PMAS(40,2)
12304 AEM=PARU(101)
12305 XW=PARU(102)
12306
12307C...Phase space integral in tau and y*.
12308 COMFAC=PARU(1)*PARU(5)/VINT(2)
12309 IF(MINT(43).EQ.4) COMFAC=COMFAC*FACK
12310 IF((MINT(43).GE.2.OR.ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4).AND.
12311 &ISET(ISUB).NE.5) THEN
12312 ATAU0=LOG(TAUMAX/TAUMIN)
12313 ATAU1=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
12314 H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/TAU
12315 IF(MINT(72).GE.1) THEN
12316 TAUR1=VINT(73)
12317 GAMR1=VINT(74)
12318 ATAU2=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
12319 ATAU3=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
12320 & GAMR1
12321 H1=H1+(ATAU0/ATAU2)*COEF(ISUB,3)/(TAU+TAUR1)+
12322 & (ATAU0/ATAU3)*COEF(ISUB,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
12323 ENDIF
12324 IF(MINT(72).EQ.2) THEN
12325 TAUR2=VINT(75)
12326 GAMR2=VINT(76)
12327 ATAU4=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
12328 ATAU5=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
12329 & GAMR2
12330 H1=H1+(ATAU0/ATAU4)*COEF(ISUB,5)/(TAU+TAUR2)+
12331 & (ATAU0/ATAU5)*COEF(ISUB,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
12332 ENDIF
12333 COMFAC=COMFAC*ATAU0/(TAU*H1)
12334 ENDIF
12335 IF(MINT(43).EQ.4.AND.ISET(ISUB).NE.5) THEN
12336 AYST0=YSTMAX-YSTMIN
12337 AYST1=0.5*(YSTMAX-YSTMIN)**2
12338 AYST2=AYST1
12339 AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
12340 H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST2)*
12341 & COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)
12342 COMFAC=COMFAC*AYST0/H2
12343 ENDIF
12344
12345C...2 -> 1 processes: reduction in angular part of phase space integral
12346C...for case of decaying resonance.
12347 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
12348clin-4/2008 modified a la pythia6115.f to avoid invalid MDCY subcript#1,
12349c also break up compound IF statements:
12350c IF((ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3).AND.
12351c &MDCY(KFPR(ISUB,1),1).EQ.1) THEN
12352c IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN
12353c COMFAC=COMFAC*0.5*ACTH0
12354c ELSE
12355c COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+
12356c & CTPMAX**3-CTPMIN**3)
12357c ENDIF
12358 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12359 if(MDCY(LUCOMP(KFPR(ISUB,1)),1).EQ.1) then
12360 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37) THEN
12361 COMFAC=COMFAC*0.5*ACTH0
12362 ELSE
12363 COMFAC=COMFAC*0.125*(3.*ACTH0+CTNMAX**3-CTNMIN**3+
12364 & CTPMAX**3-CTPMIN**3)
12365 ENDIF
12366 endif
12367c
12368C...2 -> 2 processes: angular part of phase space integral.
12369 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
12370 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
12371 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
12372 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
12373 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
12374 ACTH3=1./MAX(RM34,RSQM-CTNMAX)-1./MAX(RM34,RSQM-CTNMIN)+
12375 & 1./MAX(RM34,RSQM-CTPMAX)-1./MAX(RM34,RSQM-CTPMIN)
12376 ACTH4=1./MAX(RM34,RSQM+CTNMIN)-1./MAX(RM34,RSQM+CTNMAX)+
12377 & 1./MAX(RM34,RSQM+CTPMIN)-1./MAX(RM34,RSQM+CTPMAX)
12378 H3=COEF(ISUB,10)+
12379 & (ACTH0/ACTH1)*COEF(ISUB,11)/MAX(RM34,RSQM-CTH)+
12380 & (ACTH0/ACTH2)*COEF(ISUB,12)/MAX(RM34,RSQM+CTH)+
12381 & (ACTH0/ACTH3)*COEF(ISUB,13)/MAX(RM34,RSQM-CTH)**2+
12382 & (ACTH0/ACTH4)*COEF(ISUB,14)/MAX(RM34,RSQM+CTH)**2
12383 COMFAC=COMFAC*ACTH0*0.5*BE34/H3
12384 ENDIF
12385
12386C...2 -> 3, 4 processes: phace space integral in tau'.
12387 IF(MINT(43).GE.2.AND.(ISET(ISUB).EQ.3.OR.ISET(ISUB).EQ.4)) THEN
12388 ATAUP0=LOG(TAUPMX/TAUPMN)
12389 ATAUP1=((1.-TAU/TAUPMX)**4-(1.-TAU/TAUPMN)**4)/(4.*TAU)
12390 H4=COEF(ISUB,15)+
12391 & ATAUP0/ATAUP1*COEF(ISUB,16)/TAUP*(1.-TAU/TAUP)**3
12392 IF(1.-TAU/TAUP.GT.1.E-4) THEN
12393 FZW=(1.+TAU/TAUP)*LOG(TAUP/TAU)-2.*(1.-TAU/TAUP)
12394 ELSE
12395 FZW=1./6.*(1.-TAU/TAUP)**3*TAU/TAUP
12396 ENDIF
12397 COMFAC=COMFAC*ATAUP0*FZW/H4
12398 ENDIF
12399
12400C...Phase space integral for low-pT and multiple interactions.
12401 IF(ISET(ISUB).EQ.5) THEN
12402 COMFAC=PARU(1)*PARU(5)*FACK*0.5*VINT(2)/SH2
12403 ATAU0=LOG(2.*(1.+SQRT(1.-XT2))/XT2-1.)
12404 ATAU1=2.*ATAN(1./XT2-1.)/SQRT(XT2)
12405 H1=COEF(ISUB,1)+(ATAU0/ATAU1)*COEF(ISUB,2)/SQRT(TAU)
12406 COMFAC=COMFAC*ATAU0/H1
12407 AYST0=YSTMAX-YSTMIN
12408 AYST1=0.5*(YSTMAX-YSTMIN)**2
12409 AYST3=2.*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
12410 H2=(AYST0/AYST1)*COEF(ISUB,7)*(YST-YSTMIN)+(AYST0/AYST1)*
12411 & COEF(ISUB,8)*(YSTMAX-YST)+(AYST0/AYST3)*COEF(ISUB,9)/COSH(YST)
12412 COMFAC=COMFAC*AYST0/H2
12413 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1./VINT(149)-1.)
12414C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
12415C...introduced to make cross-section finite for xT2 -> 0.
12416 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
12417 & (1.+VINT(149)))
12418 ENDIF
12419
12420C...A: 2 -> 1, tree diagrams.
12421
12422 145 IF(ISUB.LE.10) THEN
12423 IF(ISUB.EQ.1) THEN
12424C...f + fb -> gamma*/Z0.
12425 MINT(61)=2
ce320da8 12426 CALL PYWIDTA(23,SQRT(SH),WDTP,WDTE)
0119ef9a 12427 FACZ=COMFAC*AEM**2*4./3.
12428 DO 150 I=MINA,MAXA
12429 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
12430 EI=KCHG(IABS(I),1)/3.
12431 AI=SIGN(1.,EI)
12432 VI=AI-4.*EI*XW
12433 FACF=1.
12434 IF(IABS(I).LE.10) FACF=FACA/3.
12435 NCHN=NCHN+1
12436 ISIG(NCHN,1)=I
12437 ISIG(NCHN,2)=-I
12438 ISIG(NCHN,3)=1
12439 SIGH(NCHN)=FACF*FACZ*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*
12440 & SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+(VI**2+AI**2)/
12441 & (16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*VINT(114))
12442 150 CONTINUE
12443
12444 ELSEIF(ISUB.EQ.2) THEN
12445C...f + fb' -> W+/-.
ce320da8 12446 CALL PYWIDTA(24,SQRT(SH),WDTP,WDTE)
0119ef9a 12447 FACW=COMFAC*(AEM/XW)**2*1./24*SH2/((SH-SQMW)**2+GMMW**2)
12448 DO 170 I=MIN1,MAX1
12449 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 170
12450 IA=IABS(I)
12451 DO 160 J=MIN2,MAX2
12452 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 160
12453 JA=IABS(J)
12454 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
12455 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) GOTO 160
12456 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12457 FACF=1.
12458 IF(IA.LE.10) FACF=VCKM((IA+1)/2,(JA+1)/2)*FACA/3.
12459 NCHN=NCHN+1
12460 ISIG(NCHN,1)=I
12461 ISIG(NCHN,2)=J
12462 ISIG(NCHN,3)=1
12463 SIGH(NCHN)=FACF*FACW*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
12464 160 CONTINUE
12465 170 CONTINUE
12466
12467 ELSEIF(ISUB.EQ.3) THEN
12468C...f + fb -> H0.
ce320da8 12469 CALL PYWIDTA(25,SQRT(SH),WDTP,WDTE)
0119ef9a 12470 FACH=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*
12471 & SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
12472 DO 180 I=MINA,MAXA
12473 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
12474 RMQ=PMAS(IABS(I),1)**2/SH
12475 NCHN=NCHN+1
12476 ISIG(NCHN,1)=I
12477 ISIG(NCHN,2)=-I
12478 ISIG(NCHN,3)=1
12479 SIGH(NCHN)=FACH*RMQ*SQRT(MAX(0.,1.-4.*RMQ))
12480 180 CONTINUE
12481
12482 ELSEIF(ISUB.EQ.4) THEN
12483C...gamma + W+/- -> W+/-.
12484
12485 ELSEIF(ISUB.EQ.5) THEN
12486C...Z0 + Z0 -> H0.
ce320da8 12487 CALL PYWIDTA(25,SQRT(SH),WDTP,WDTE)
0119ef9a 12488 FACH=COMFAC*1./(128.*PARU(1)**2*16.*(1.-XW)**3)*(AEM/XW)**4*
12489 & (SH/SQMW)**2*SH2/((SH-SQMH)**2+GMMH**2)*
12490 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
12491 DO 200 I=MIN1,MAX1
12492 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
12493 DO 190 J=MIN2,MAX2
12494 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
12495 EI=KCHG(IABS(I),1)/3.
12496 AI=SIGN(1.,EI)
12497 VI=AI-4.*EI*XW
12498 EJ=KCHG(IABS(J),1)/3.
12499 AJ=SIGN(1.,EJ)
12500 VJ=AJ-4.*EJ*XW
12501 NCHN=NCHN+1
12502 ISIG(NCHN,1)=I
12503 ISIG(NCHN,2)=J
12504 ISIG(NCHN,3)=1
12505 SIGH(NCHN)=FACH*(VI**2+AI**2)*(VJ**2+AJ**2)
12506 190 CONTINUE
12507 200 CONTINUE
12508
12509 ELSEIF(ISUB.EQ.6) THEN
12510C...Z0 + W+/- -> W+/-.
12511
12512 ELSEIF(ISUB.EQ.7) THEN
12513C...W+ + W- -> Z0.
12514
12515 ELSEIF(ISUB.EQ.8) THEN
12516C...W+ + W- -> H0.
ce320da8 12517 CALL PYWIDTA(25,SQRT(SH),WDTP,WDTE)
0119ef9a 12518 FACH=COMFAC*1./(128*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
12519 & SH2/((SH-SQMH)**2+GMMH**2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
12520 DO 220 I=MIN1,MAX1
12521 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 220
12522 EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
12523 DO 210 J=MIN2,MAX2
12524 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 210
12525 EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
12526 IF(EI*EJ.GT.0.) GOTO 210
12527 NCHN=NCHN+1
12528 ISIG(NCHN,1)=I
12529 ISIG(NCHN,2)=J
12530 ISIG(NCHN,3)=1
12531 SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
12532 210 CONTINUE
12533 220 CONTINUE
12534 ENDIF
12535
12536C...B: 2 -> 2, tree diagrams.
12537
12538 ELSEIF(ISUB.LE.20) THEN
12539 IF(ISUB.EQ.11) THEN
12540C...f + f' -> f + f'.
12541 FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2
12542 FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-
12543 & MSTP(34)*2./3.*UH2/(SH*TH))
12544 FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-
12545 & MSTP(34)*2./3.*SH2/(TH*UH))
12546 DO 240 I=MIN1,MAX1
12547 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
12548 DO 230 J=MIN2,MAX2
12549 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
12550 NCHN=NCHN+1
12551 ISIG(NCHN,1)=I
12552 ISIG(NCHN,2)=J
12553 ISIG(NCHN,3)=1
12554 SIGH(NCHN)=FACQQ1
12555 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
12556 IF(I.EQ.J) THEN
12557 SIGH(NCHN)=0.5*SIGH(NCHN)
12558 NCHN=NCHN+1
12559 ISIG(NCHN,1)=I
12560 ISIG(NCHN,2)=J
12561 ISIG(NCHN,3)=2
12562 SIGH(NCHN)=0.5*FACQQ2
12563 ENDIF
12564 230 CONTINUE
12565 240 CONTINUE
12566
12567 ELSEIF(ISUB.EQ.12) THEN
12568C...f + fb -> f' + fb' (q + qb -> q' + qb' only).
ce320da8 12569 CALL PYWIDTA(21,SQRT(SH),WDTP,WDTE)
0119ef9a 12570 FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+
12571 & WDTE(0,3)+WDTE(0,4))
12572 DO 250 I=MINA,MAXA
12573 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 250
12574 NCHN=NCHN+1
12575 ISIG(NCHN,1)=I
12576 ISIG(NCHN,2)=-I
12577 ISIG(NCHN,3)=1
12578 SIGH(NCHN)=FACQQB
12579 250 CONTINUE
12580
12581 ELSEIF(ISUB.EQ.13) THEN
12582C...f + fb -> g + g (q + qb -> g + g only).
12583 FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)
12584 FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)
12585 DO 260 I=MINA,MAXA
12586 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
12587 NCHN=NCHN+1
12588 ISIG(NCHN,1)=I
12589 ISIG(NCHN,2)=-I
12590 ISIG(NCHN,3)=1
12591 SIGH(NCHN)=0.5*FACGG1
12592 NCHN=NCHN+1
12593 ISIG(NCHN,1)=I
12594 ISIG(NCHN,2)=-I
12595 ISIG(NCHN,3)=2
12596 SIGH(NCHN)=0.5*FACGG2
12597 260 CONTINUE
12598
12599 ELSEIF(ISUB.EQ.14) THEN
12600C...f + fb -> g + gamma (q + qb -> g + gamma only).
12601 FACGG=COMFAC*AS*AEM*8./9.*(TH2+UH2)/(TH*UH)
12602 DO 270 I=MINA,MAXA
12603 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
12604 EI=KCHG(IABS(I),1)/3.
12605 NCHN=NCHN+1
12606 ISIG(NCHN,1)=I
12607 ISIG(NCHN,2)=-I
12608 ISIG(NCHN,3)=1
12609 SIGH(NCHN)=FACGG*EI**2
12610 270 CONTINUE
12611
12612 ELSEIF(ISUB.EQ.15) THEN
12613C...f + fb -> g + Z0 (q + qb -> g + Z0 only).
12614 FACZG=COMFAC*AS*AEM/(XW*(1.-XW))*1./18.*
12615 & (TH2+UH2+2.*SQM4*SH)/(TH*UH)
12616 FACZG=FACZG*WIDS(23,2)
12617 DO 280 I=MINA,MAXA
12618 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280
12619 EI=KCHG(IABS(I),1)/3.
12620 AI=SIGN(1.,EI)
12621 VI=AI-4.*EI*XW
12622 NCHN=NCHN+1
12623 ISIG(NCHN,1)=I
12624 ISIG(NCHN,2)=-I
12625 ISIG(NCHN,3)=1
12626 SIGH(NCHN)=FACZG*(VI**2+AI**2)
12627 280 CONTINUE
12628
12629 ELSEIF(ISUB.EQ.16) THEN
12630C...f + fb' -> g + W+/- (q + qb' -> g + W+/- only).
12631 FACWG=COMFAC*AS*AEM/XW*2./9.*(TH2+UH2+2.*SQM4*SH)/(TH*UH)
12632 DO 300 I=MIN1,MAX1
12633 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
12634 IA=IABS(I)
12635 DO 290 J=MIN2,MAX2
12636 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
12637 JA=IABS(J)
12638 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
12639 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12640 FCKM=1.
12641 IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
12642 NCHN=NCHN+1
12643 ISIG(NCHN,1)=I
12644 ISIG(NCHN,2)=J
12645 ISIG(NCHN,3)=1
12646 SIGH(NCHN)=FACWG*FCKM*WIDS(24,(5-KCHW)/2)
12647 290 CONTINUE
12648 300 CONTINUE
12649
12650 ELSEIF(ISUB.EQ.17) THEN
12651C...f + fb -> g + H0 (q + qb -> g + H0 only).
12652
12653 ELSEIF(ISUB.EQ.18) THEN
12654C...f + fb -> gamma + gamma.
12655 FACGG=COMFAC*FACA*AEM**2*1./3.*(TH2+UH2)/(TH*UH)
12656 DO 310 I=MINA,MAXA
12657 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
12658 EI=KCHG(IABS(I),1)/3.
12659 NCHN=NCHN+1
12660 ISIG(NCHN,1)=I
12661 ISIG(NCHN,2)=-I
12662 ISIG(NCHN,3)=1
12663 SIGH(NCHN)=FACGG*EI**4
12664 310 CONTINUE
12665
12666 ELSEIF(ISUB.EQ.19) THEN
12667C...f + fb -> gamma + Z0.
12668 FACGZ=COMFAC*FACA*AEM**2/(XW*(1.-XW))*1./24.*
12669 & (TH2+UH2+2.*SQM4*SH)/(TH*UH)
12670 FACGZ=FACGZ*WIDS(23,2)
12671 DO 320 I=MINA,MAXA
12672 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
12673 EI=KCHG(IABS(I),1)/3.
12674 AI=SIGN(1.,EI)
12675 VI=AI-4.*EI*XW
12676 NCHN=NCHN+1
12677 ISIG(NCHN,1)=I
12678 ISIG(NCHN,2)=-I
12679 ISIG(NCHN,3)=1
12680 SIGH(NCHN)=FACGZ*EI**2*(VI**2+AI**2)
12681 320 CONTINUE
12682
12683 ELSEIF(ISUB.EQ.20) THEN
12684C...f + fb' -> gamma + W+/-.
12685 FACGW=COMFAC*FACA*AEM**2/XW*1./6.*
12686 & ((2.*UH-TH)/(3.*(SH-SQM4)))**2*(TH2+UH2+2.*SQM4*SH)/(TH*UH)
12687 DO 340 I=MIN1,MAX1
12688 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
12689 IA=IABS(I)
12690 DO 330 J=MIN2,MAX2
12691 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
12692 JA=IABS(J)
12693 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 330
12694 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12695 FCKM=1.
12696 IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
12697 NCHN=NCHN+1
12698 ISIG(NCHN,1)=I
12699 ISIG(NCHN,2)=J
12700 ISIG(NCHN,3)=1
12701 SIGH(NCHN)=FACGW*FCKM*WIDS(24,(5-KCHW)/2)
12702 330 CONTINUE
12703 340 CONTINUE
12704 ENDIF
12705
12706 ELSEIF(ISUB.LE.30) THEN
12707 IF(ISUB.EQ.21) THEN
12708C...f + fb -> gamma + H0.
12709
12710 ELSEIF(ISUB.EQ.22) THEN
12711C...f + fb -> Z0 + Z0.
12712 FACZZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./768.*
12713 & (UH/TH+TH/UH+2.*(SQM3+SQM4)*SH/(TH*UH)-
12714 & SQM3*SQM4*(1./TH2+1./UH2))
12715 FACZZ=FACZZ*WIDS(23,1)
12716 DO 350 I=MINA,MAXA
12717 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
12718 EI=KCHG(IABS(I),1)/3.
12719 AI=SIGN(1.,EI)
12720 VI=AI-4.*EI*XW
12721 NCHN=NCHN+1
12722 ISIG(NCHN,1)=I
12723 ISIG(NCHN,2)=-I
12724 ISIG(NCHN,3)=1
12725 SIGH(NCHN)=FACZZ*(VI**4+6.*VI**2*AI**2+AI**4)
12726 350 CONTINUE
12727
12728 ELSEIF(ISUB.EQ.23) THEN
12729C...f + fb' -> Z0 + W+/-.
12730 FACZW=COMFAC*FACA*(AEM/XW)**2*1./6.
12731 FACZW=FACZW*WIDS(23,2)
12732 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
12733 DO 370 I=MIN1,MAX1
12734 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
12735 IA=IABS(I)
12736 DO 360 J=MIN2,MAX2
12737 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
12738 JA=IABS(J)
12739 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
12740 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12741 EI=KCHG(IA,1)/3.
12742 AI=SIGN(1.,EI)
12743 VI=AI-4.*EI*XW
12744 EJ=KCHG(JA,1)/3.
12745 AJ=SIGN(1.,EJ)
12746 VJ=AJ-4.*EJ*XW
12747 IF(VI+AI.GT.0) THEN
12748 VISAV=VI
12749 AISAV=AI
12750 VI=VJ
12751 AI=AJ
12752 VJ=VISAV
12753 AJ=AISAV
12754 ENDIF
12755 FCKM=1.
12756 IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
12757 NCHN=NCHN+1
12758 ISIG(NCHN,1)=I
12759 ISIG(NCHN,2)=J
12760 ISIG(NCHN,3)=1
12761 SIGH(NCHN)=FACZW*FCKM*(1./(SH-SQMW)**2*
12762 & ((9.-8.*XW)/4.*THUH+(8.*XW-6.)/4.*SH*(SQM3+SQM4))+
12763 & (THUH-SH*(SQM3+SQM4))/(2.*(SH-SQMW))*((VJ+AJ)/TH-(VI+AI)/UH)+
12764 & THUH/(16.*(1.-XW))*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
12765 & SH*(SQM3+SQM4)/(8.*(1.-XW))*(VI+AI)*(VJ+AJ)/(TH*UH))*
12766 & WIDS(24,(5-KCHW)/2)
12767 360 CONTINUE
12768 370 CONTINUE
12769
12770 ELSEIF(ISUB.EQ.24) THEN
12771C...f + fb -> Z0 + H0.
12772 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
12773 FACHZ=COMFAC*FACA*(AEM/(XW*(1.-XW)))**2*1./96.*
12774 & (THUH+2.*SH*SQMZ)/(SH-SQMZ)**2
12775 FACHZ=FACHZ*WIDS(23,2)*WIDS(25,2)
12776 DO 380 I=MINA,MAXA
12777 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
12778 EI=KCHG(IABS(I),1)/3.
12779 AI=SIGN(1.,EI)
12780 VI=AI-4.*EI*XW
12781 NCHN=NCHN+1
12782 ISIG(NCHN,1)=I
12783 ISIG(NCHN,2)=-I
12784 ISIG(NCHN,3)=1
12785 SIGH(NCHN)=FACHZ*(VI**2+AI**2)
12786 380 CONTINUE
12787
12788 ELSEIF(ISUB.EQ.25) THEN
12789C...f + fb -> W+ + W-.
12790 FACWW=COMFAC*FACA*(AEM/XW)**2*1./12.
12791 FACWW=FACWW*WIDS(24,1)
12792 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
12793 DO 390 I=MINA,MAXA
12794 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
12795 EI=KCHG(IABS(I),1)/3.
12796 AI=SIGN(1.,EI)
12797 VI=AI-4.*EI*XW
12798 DSIGWW=THUH/SH2*(3.-(SH-3.*(SQM3+SQM4))/(SH-SQMZ)*
12799 & (VI+AI)/(2.*AI*(1.-XW))+(SH/(SH-SQMZ))**2*
12800 & (1.-2.*(SQM3+SQM4)/SH+12.*SQM3*SQM4/SH2)*(VI**2+AI**2)/
12801 & (8.*(1.-XW)**2))-2.*SQMZ/(SH-SQMZ)*(VI+AI)/AI+
12802 & SQMZ*SH/(SH-SQMZ)**2*(1.-2.*(SQM3+SQM4)/SH)*(VI**2+AI**2)/
12803 & (2.*(1.-XW))
12804 IF(KCHG(IABS(I),1).LT.0) THEN
12805 DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
12806 & (THUH/(SH*TH)-(SQM3+SQM4)/TH)+THUH/TH2
12807 ELSE
12808 DSIGWW=DSIGWW+2.*(1.+SQMZ/(SH-SQMZ)*(VI+AI)/(2.*AI))*
12809 & (THUH/(SH*UH)-(SQM3+SQM4)/UH)+THUH/UH2
12810 ENDIF
12811 NCHN=NCHN+1
12812 ISIG(NCHN,1)=I
12813 ISIG(NCHN,2)=-I
12814 ISIG(NCHN,3)=1
12815 SIGH(NCHN)=FACWW*DSIGWW
12816 390 CONTINUE
12817
12818 ELSEIF(ISUB.EQ.26) THEN
12819C...f + fb' -> W+/- + H0.
12820 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
12821 FACHW=COMFAC*FACA*(AEM/XW)**2*1./24.*(THUH+2.*SH*SQMW)/
12822 & (SH-SQMW)**2
12823 FACHW=FACHW*WIDS(25,2)
12824 DO 410 I=MIN1,MAX1
12825 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
12826 IA=IABS(I)
12827 DO 400 J=MIN2,MAX2
12828 IF(J.EQ.0.OR.KFAC(1,J).EQ.0) GOTO 400
12829 JA=IABS(J)
12830 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
12831 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
12832 FCKM=1.
12833 IF(MINT(43).EQ.4) FCKM=VCKM((IA+1)/2,(JA+1)/2)
12834 NCHN=NCHN+1
12835 ISIG(NCHN,1)=I
12836 ISIG(NCHN,2)=J
12837 ISIG(NCHN,3)=1
12838 SIGH(NCHN)=FACHW*FCKM*WIDS(24,(5-KCHW)/2)
12839 400 CONTINUE
12840 410 CONTINUE
12841
12842 ELSEIF(ISUB.EQ.27) THEN
12843C...f + fb -> H0 + H0.
12844
12845 ELSEIF(ISUB.EQ.28) THEN
12846C...f + g -> f + g (q + g -> q + g only).
12847 FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*
12848 & FACA
12849 FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)
12850 DO 430 I=MINA,MAXA
12851 IF(I.EQ.0) GOTO 430
12852 DO 420 ISDE=1,2
12853 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
12854 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
12855 NCHN=NCHN+1
12856 ISIG(NCHN,ISDE)=I
12857 ISIG(NCHN,3-ISDE)=21
12858 ISIG(NCHN,3)=1
12859 SIGH(NCHN)=FACQG1
12860 NCHN=NCHN+1
12861 ISIG(NCHN,ISDE)=I
12862 ISIG(NCHN,3-ISDE)=21
12863 ISIG(NCHN,3)=2
12864 SIGH(NCHN)=FACQG2
12865 420 CONTINUE
12866 430 CONTINUE
12867
12868 ELSEIF(ISUB.EQ.29) THEN
12869C...f + g -> f + gamma (q + g -> q + gamma only).
12870 FGQ=COMFAC*FACA*AS*AEM*1./3.*(SH2+UH2)/(-SH*UH)
12871 DO 450 I=MINA,MAXA
12872 IF(I.EQ.0) GOTO 450
12873 EI=KCHG(IABS(I),1)/3.
12874 FACGQ=FGQ*EI**2
12875 DO 440 ISDE=1,2
12876 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 440
12877 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 440
12878 NCHN=NCHN+1
12879 ISIG(NCHN,ISDE)=I
12880 ISIG(NCHN,3-ISDE)=21
12881 ISIG(NCHN,3)=1
12882 SIGH(NCHN)=FACGQ
12883 440 CONTINUE
12884 450 CONTINUE
12885
12886 ELSEIF(ISUB.EQ.30) THEN
12887C...f + g -> f + Z0 (q + g -> q + Z0 only).
12888 FZQ=COMFAC*FACA*AS*AEM/(XW*(1.-XW))*1./48.*
12889 & (SH2+UH2+2.*SQM4*TH)/(-SH*UH)
12890 FZQ=FZQ*WIDS(23,2)
12891 DO 470 I=MINA,MAXA
12892 IF(I.EQ.0) GOTO 470
12893 EI=KCHG(IABS(I),1)/3.
12894 AI=SIGN(1.,EI)
12895 VI=AI-4.*EI*XW
12896 FACZQ=FZQ*(VI**2+AI**2)
12897 DO 460 ISDE=1,2
12898 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 460
12899 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 460
12900 NCHN=NCHN+1
12901 ISIG(NCHN,ISDE)=I
12902 ISIG(NCHN,3-ISDE)=21
12903 ISIG(NCHN,3)=1
12904 SIGH(NCHN)=FACZQ
12905 460 CONTINUE
12906 470 CONTINUE
12907 ENDIF
12908
12909 ELSEIF(ISUB.LE.40) THEN
12910 IF(ISUB.EQ.31) THEN
12911C...f + g -> f' + W+/- (q + g -> q' + W+/- only).
12912 FACWQ=COMFAC*FACA*AS*AEM/XW*1./12.*
12913 & (SH2+UH2+2.*SQM4*TH)/(-SH*UH)
12914 DO 490 I=MINA,MAXA
12915 IF(I.EQ.0) GOTO 490
12916 IA=IABS(I)
12917 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
12918 DO 480 ISDE=1,2
12919 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 480
12920 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 480
12921 NCHN=NCHN+1
12922 ISIG(NCHN,ISDE)=I
12923 ISIG(NCHN,3-ISDE)=21
12924 ISIG(NCHN,3)=1
12925 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDS(24,(5-KCHW)/2)
12926 480 CONTINUE
12927 490 CONTINUE
12928
12929 ELSEIF(ISUB.EQ.32) THEN
12930C...f + g -> f + H0 (q + g -> q + H0 only).
12931
12932 ELSEIF(ISUB.EQ.33) THEN
12933C...f + gamma -> f + g (q + gamma -> q + g only).
12934
12935 ELSEIF(ISUB.EQ.34) THEN
12936C...f + gamma -> f + gamma.
12937
12938 ELSEIF(ISUB.EQ.35) THEN
12939C...f + gamma -> f + Z0.
12940
12941 ELSEIF(ISUB.EQ.36) THEN
12942C...f + gamma -> f' + W+/-.
12943
12944 ELSEIF(ISUB.EQ.37) THEN
12945C...f + gamma -> f + H0.
12946
12947 ELSEIF(ISUB.EQ.38) THEN
12948C...f + Z0 -> f + g (q + Z0 -> q + g only).
12949
12950 ELSEIF(ISUB.EQ.39) THEN
12951C...f + Z0 -> f + gamma.
12952
12953 ELSEIF(ISUB.EQ.40) THEN
12954C...f + Z0 -> f + Z0.
12955 ENDIF
12956
12957 ELSEIF(ISUB.LE.50) THEN
12958 IF(ISUB.EQ.41) THEN
12959C...f + Z0 -> f' + W+/-.
12960
12961 ELSEIF(ISUB.EQ.42) THEN
12962C...f + Z0 -> f + H0.
12963
12964 ELSEIF(ISUB.EQ.43) THEN
12965C...f + W+/- -> f' + g (q + W+/- -> q' + g only).
12966
12967 ELSEIF(ISUB.EQ.44) THEN
12968C...f + W+/- -> f' + gamma.
12969
12970 ELSEIF(ISUB.EQ.45) THEN
12971C...f + W+/- -> f' + Z0.
12972
12973 ELSEIF(ISUB.EQ.46) THEN
12974C...f + W+/- -> f' + W+/-.
12975
12976 ELSEIF(ISUB.EQ.47) THEN
12977C...f + W+/- -> f' + H0.
12978
12979 ELSEIF(ISUB.EQ.48) THEN
12980C...f + H0 -> f + g (q + H0 -> q + g only).
12981
12982 ELSEIF(ISUB.EQ.49) THEN
12983C...f + H0 -> f + gamma.
12984
12985 ELSEIF(ISUB.EQ.50) THEN
12986C...f + H0 -> f + Z0.
12987 ENDIF
12988
12989 ELSEIF(ISUB.LE.60) THEN
12990 IF(ISUB.EQ.51) THEN
12991C...f + H0 -> f' + W+/-.
12992
12993 ELSEIF(ISUB.EQ.52) THEN
12994C...f + H0 -> f + H0.
12995
12996 ELSEIF(ISUB.EQ.53) THEN
12997C...g + g -> f + fb (g + g -> q + qb only).
ce320da8 12998 CALL PYWIDTA(21,SQRT(SH),WDTP,WDTE)
0119ef9a 12999 FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*
13000 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
13001 FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*
13002 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
13003 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
13004 NCHN=NCHN+1
13005 ISIG(NCHN,1)=21
13006 ISIG(NCHN,2)=21
13007 ISIG(NCHN,3)=1
13008 SIGH(NCHN)=FACQQ1
13009 NCHN=NCHN+1
13010 ISIG(NCHN,1)=21
13011 ISIG(NCHN,2)=21
13012 ISIG(NCHN,3)=2
13013 SIGH(NCHN)=FACQQ2
13014 500 CONTINUE
13015
13016 ELSEIF(ISUB.EQ.54) THEN
13017C...g + gamma -> f + fb (g + gamma -> q + qb only).
13018
13019 ELSEIF(ISUB.EQ.55) THEN
13020C...g + gamma -> f + fb (g + gamma -> q + qb only).
13021
13022 ELSEIF(ISUB.EQ.56) THEN
13023C...g + gamma -> f + fb (g + gamma -> q + qb only).
13024
13025 ELSEIF(ISUB.EQ.57) THEN
13026C...g + gamma -> f + fb (g + gamma -> q + qb only).
13027
13028 ELSEIF(ISUB.EQ.58) THEN
13029C...gamma + gamma -> f + fb.
13030
13031 ELSEIF(ISUB.EQ.59) THEN
13032C...gamma + Z0 -> f + fb.
13033
13034 ELSEIF(ISUB.EQ.60) THEN
13035C...gamma + W+/- -> f + fb'.
13036 ENDIF
13037
13038 ELSEIF(ISUB.LE.70) THEN
13039 IF(ISUB.EQ.61) THEN
13040C...gamma + H0 -> f + fb.
13041
13042 ELSEIF(ISUB.EQ.62) THEN
13043C...Z0 + Z0 -> f + fb.
13044
13045 ELSEIF(ISUB.EQ.63) THEN
13046C...Z0 + W+/- -> f + fb'.
13047
13048 ELSEIF(ISUB.EQ.64) THEN
13049C...Z0 + H0 -> f + fb.
13050
13051 ELSEIF(ISUB.EQ.65) THEN
13052C...W+ + W- -> f + fb.
13053
13054 ELSEIF(ISUB.EQ.66) THEN
13055C...W+/- + H0 -> f + fb'.
13056
13057 ELSEIF(ISUB.EQ.67) THEN
13058C...H0 + H0 -> f + fb.
13059
13060 ELSEIF(ISUB.EQ.68) THEN
13061C...g + g -> g + g.
13062 FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+
13063 & TH2/SH2)*FACA
13064 FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+
13065 & SH2/UH2)*FACA
13066 FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2)
13067 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
13068 NCHN=NCHN+1
13069 ISIG(NCHN,1)=21
13070 ISIG(NCHN,2)=21
13071 ISIG(NCHN,3)=1
13072 SIGH(NCHN)=0.5*FACGG1
13073 NCHN=NCHN+1
13074 ISIG(NCHN,1)=21
13075 ISIG(NCHN,2)=21
13076 ISIG(NCHN,3)=2
13077 SIGH(NCHN)=0.5*FACGG2
13078 NCHN=NCHN+1
13079 ISIG(NCHN,1)=21
13080 ISIG(NCHN,2)=21
13081 ISIG(NCHN,3)=3
13082 SIGH(NCHN)=0.5*FACGG3
13083 510 CONTINUE
13084
13085 ELSEIF(ISUB.EQ.69) THEN
13086C...gamma + gamma -> W+ + W-.
13087
13088 ELSEIF(ISUB.EQ.70) THEN
13089C...gamma + W+/- -> gamma + W+/-.
13090 ENDIF
13091
13092 ELSEIF(ISUB.LE.80) THEN
13093 IF(ISUB.EQ.71) THEN
13094C...Z0 + Z0 -> Z0 + Z0.
13095 BE2=1.-4.*SQMZ/SH
13096 TH=-0.5*SH*BE2*(1.-CTH)
13097 UH=-0.5*SH*BE2*(1.+CTH)
13098 SHANG=1./(1.-XW)*SQMW/SQMZ*(1.+BE2)**2
13099 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
13100 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
13101 THANG=1./(1.-XW)*SQMW/SQMZ*(BE2-CTH)**2
13102 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
13103 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
13104 UHANG=1./(1.-XW)*SQMW/SQMZ*(BE2+CTH)**2
13105 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
13106 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
13107 FACH=0.5*COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*
13108 & (AEM/XW)**4*(SH/SQMW)**2*((ASHRE+ATHRE+AUHRE)**2+
13109 & (ASHIM+ATHIM+AUHIM)**2)*SQMZ/SQMW
13110 DO 530 I=MIN1,MAX1
13111 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
13112 EI=KCHG(IABS(I),1)/3.
13113 AI=SIGN(1.,EI)
13114 VI=AI-4.*EI*XW
13115 AVI=AI**2+VI**2
13116 DO 520 J=MIN2,MAX2
13117 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
13118 EJ=KCHG(IABS(J),1)/3.
13119 AJ=SIGN(1.,EJ)
13120 VJ=AJ-4.*EJ*XW
13121 AVJ=AJ**2+VJ**2
13122 NCHN=NCHN+1
13123 ISIG(NCHN,1)=I
13124 ISIG(NCHN,2)=J
13125 ISIG(NCHN,3)=1
13126 SIGH(NCHN)=FACH*AVI*AVJ
13127 520 CONTINUE
13128 530 CONTINUE
13129
13130 ELSEIF(ISUB.EQ.72) THEN
13131C...Z0 + Z0 -> W+ + W-.
13132 BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))
13133 CTH2=CTH**2
13134 TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)
13135 UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)
13136 SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)*
13137 & (1.-2.*SQMZ/SH)
13138 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
13139 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
13140 ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-
13141 & (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
13142 & (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
13143 & 4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))
13144 ATWIM=0.
13145 AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-
13146 & (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
13147 & (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
13148 & 4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))
13149 AUWIM=0.
13150 A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)
13151 A4IM=0.
13152 FACH=COMFAC*1./(4096.*PARU(1)**2*16.*(1.-XW)**2)*(AEM/XW)**4*
13153 & (SH/SQMW)**2*((ASHRE+ATWRE+AUWRE+A4RE)**2+
13154 & (ASHIM+ATWIM+AUWIM+A4IM)**2)*SQMZ/SQMW
13155 DO 550 I=MIN1,MAX1
13156 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 550
13157 EI=KCHG(IABS(I),1)/3.
13158 AI=SIGN(1.,EI)
13159 VI=AI-4.*EI*XW
13160 AVI=AI**2+VI**2
13161 DO 540 J=MIN2,MAX2
13162 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 540
13163 EJ=KCHG(IABS(J),1)/3.
13164 AJ=SIGN(1.,EJ)
13165 VJ=AJ-4.*EJ*XW
13166 AVJ=AJ**2+VJ**2
13167 NCHN=NCHN+1
13168 ISIG(NCHN,1)=I
13169 ISIG(NCHN,2)=J
13170 ISIG(NCHN,3)=1
13171 SIGH(NCHN)=FACH*AVI*AVJ
13172 540 CONTINUE
13173 550 CONTINUE
13174
13175 ELSEIF(ISUB.EQ.73) THEN
13176C...Z0 + W+/- -> Z0 + W+/-.
13177 BE2=1.-2.*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
13178 EP1=1.+(SQMZ-SQMW)/SH
13179 EP2=1.-(SQMZ-SQMW)/SH
13180 TH=-0.5*SH*BE2*(1.-CTH)
13181 UH=(SQMZ-SQMW)**2/SH-0.5*SH*BE2*(1.+CTH)
13182 THANG=SQRT(SQMW/(SQMZ*(1.-XW)))*(BE2-EP1*CTH)*(BE2-EP2*CTH)
13183 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
13184 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
13185 ASWRE=(1.-XW)/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
13186 & 1./4.*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4.*BE2*CTH)+
13187 & 2.*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
13188 & 1./16.*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
13189 ASWIM=0.
13190 AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
13191 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
13192 & (BE2+EP1*EP2*CTH)*(2.*EP2-EP2*CTH+EP1)-BE2*(EP2+EP1*CTH)**2*
13193 & (BE2-EP2**2*CTH)-1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+
13194 & 2.*BE2*(1.-CTH))+1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
13195 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
13196 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
13197 & (2.*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*(BE2-EP1**2*CTH)-
13198 & 1./8.*(BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2.*BE2*(1.-CTH))+
13199 & 1./32.*SH/SQMW*(BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
13200 AUWIM=0.
13201 A4RE=(1.-XW)/SQMZ*(EP1**2*EP2**2*(CTH**2-1.)-
13202 & 2.*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2.*BE2*EP1*EP2)
13203 A4IM=0.
13204 FACH=COMFAC*1./(4096.*PARU(1)**2*4.*(1.-XW))*(AEM/XW)**4*
13205 & (SH/SQMW)**2*((ATHRE+ASWRE+AUWRE+A4RE)**2+
13206 & (ATHIM+ASWIM+AUWIM+A4IM)**2)*SQRT(SQMZ/SQMW)
13207 DO 570 I=MIN1,MAX1
13208 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 570
13209 EI=KCHG(IABS(I),1)/3.
13210 AI=SIGN(1.,EI)
13211 VI=AI-4.*EI*XW
13212 AVI=AI**2+VI**2
13213 DO 560 J=MIN2,MAX2
13214 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 560
13215 EJ=KCHG(IABS(J),1)/3.
13216 AJ=SIGN(1.,EJ)
13217 VJ=AI-4.*EJ*XW
13218 AVJ=AJ**2+VJ**2
13219 NCHN=NCHN+1
13220 ISIG(NCHN,1)=I
13221 ISIG(NCHN,2)=J
13222 ISIG(NCHN,3)=1
13223 SIGH(NCHN)=FACH*(AVI*VINT(180+J)+VINT(180+I)*AVJ)
13224 560 CONTINUE
13225 570 CONTINUE
13226
13227 ELSEIF(ISUB.EQ.75) THEN
13228C...W+ + W- -> gamma + gamma.
13229
13230 ELSEIF(ISUB.EQ.76) THEN
13231C...W+ + W- -> Z0 + Z0.
13232 BE2=SQRT((1.-4.*SQMW/SH)*(1.-4.*SQMZ/SH))
13233 CTH2=CTH**2
13234 TH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH-BE2*CTH)
13235 UH=-0.5*SH*(1.-2.*(SQMW+SQMZ)/SH+BE2*CTH)
13236 SHANG=4.*SQRT(SQMW/(SQMZ*(1.-XW)))*(1.-2.*SQMW/SH)*
13237 & (1.-2.*SQMZ/SH)
13238 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
13239 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
13240 ATWRE=(1.-XW)/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3./2.+BE2/2.*CTH-
13241 & (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
13242 & (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
13243 & 4.*(SQMW**2+SQMZ**2)/SH2*CTH2+2.*(SQMW+SQMZ)/SH*BE2*CTH))
13244 ATWIM=0.
13245 AUWRE=(1.-XW)/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3./2.-BE2/2.*CTH-
13246 & (SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4.*((SQMW+SQMZ)/SH*
13247 & (1.-3.*CTH2)+8.*SQMW*SQMZ/SH2*(2.*CTH2-1.)+
13248 & 4.*(SQMW**2+SQMZ**2)/SH2*CTH2-2.*(SQMW+SQMZ)/SH*BE2*CTH))
13249 AUWIM=0.
13250 A4RE=2.*(1.-XW)/SQMZ*(3.-CTH2-4.*(SQMW+SQMZ)/SH)
13251 A4IM=0.
13252 FACH=0.5*COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
13253 & ((ASHRE+ATWRE+AUWRE+A4RE)**2+(ASHIM+ATWIM+AUWIM+A4IM)**2)
13254 DO 590 I=MIN1,MAX1
13255 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 590
13256 EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
13257 DO 580 J=MIN2,MAX2
13258 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 580
13259 EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
13260 IF(EI*EJ.GT.0.) GOTO 580
13261 NCHN=NCHN+1
13262 ISIG(NCHN,1)=I
13263 ISIG(NCHN,2)=J
13264 ISIG(NCHN,3)=1
13265 SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
13266 580 CONTINUE
13267 590 CONTINUE
13268
13269 ELSEIF(ISUB.EQ.77) THEN
13270C...W+/- + W+/- -> W+/- + W+/-.
13271 BE2=1.-4.*SQMW/SH
13272 BE4=BE2**2
13273 CTH2=CTH**2
13274 CTH3=CTH**3
13275 TH=-0.5*SH*BE2*(1.-CTH)
13276 UH=-0.5*SH*BE2*(1.+CTH)
13277 SHANG=(1.+BE2)**2
13278 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
13279 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
13280 THANG=(BE2-CTH)**2
13281 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
13282 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
13283 SGZANG=1./SQMW*BE2*(3.-BE2)**2*CTH
13284 ASGRE=XW*SGZANG
13285 ASGIM=0.
13286 ASZRE=(1.-XW)*SH/(SH-SQMZ)*SGZANG
13287 ASZIM=0.
13288 TGZANG=1./SQMW*(BE2*(4.-2.*BE2+BE4)+BE2*(4.-10.*BE2+BE4)*CTH+
13289 & (2.-11.*BE2+10.*BE4)*CTH2+BE2*CTH3)
13290 ATGRE=0.5*XW*SH/TH*TGZANG
13291 ATGIM=0.
13292 ATZRE=0.5*(1.-XW)*SH/(TH-SQMZ)*TGZANG
13293 ATZIM=0.
13294 A4RE=1./SQMW*(1.+2.*BE2-6.*BE2*CTH-CTH2)
13295 A4IM=0.
13296 FACH=COMFAC*1./(4096.*PARU(1)**2)*(AEM/XW)**4*(SH/SQMW)**2*
13297 & ((ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4RE)**2+
13298 & (ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4IM)**2)
13299 DO 610 I=MIN1,MAX1
13300 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 610
13301 EI=SIGN(1.,FLOAT(I))*KCHG(IABS(I),1)
13302 DO 600 J=MIN2,MAX2
13303 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 600
13304 EJ=SIGN(1.,FLOAT(J))*KCHG(IABS(J),1)
13305 IF(EI*EJ.GT.0.) GOTO 600
13306 NCHN=NCHN+1
13307 ISIG(NCHN,1)=I
13308 ISIG(NCHN,2)=J
13309 ISIG(NCHN,3)=1
13310 SIGH(NCHN)=FACH*VINT(180+I)*VINT(180+J)
13311 600 CONTINUE
13312 610 CONTINUE
13313
13314 ELSEIF(ISUB.EQ.78) THEN
13315C...W+/- + H0 -> W+/- + H0.
13316
13317 ELSEIF(ISUB.EQ.79) THEN
13318C...H0 + H0 -> H0 + H0.
13319
13320 ENDIF
13321
13322C...C: 2 -> 2, tree diagrams with masses.
13323
13324 ELSEIF(ISUB.LE.90) THEN
13325 IF(ISUB.EQ.81) THEN
13326C...q + qb -> Q + QB.
13327 FACQQB=COMFAC*AS**2*4./9.*(((TH-SQM3)**2+
13328 & (UH-SQM3)**2)/SH2+2.*SQM3/SH)
13329 IF(MSTP(35).GE.1) THEN
13330 IF(MSTP(35).EQ.1) THEN
13331 ALSSG=PARP(35)
13332 ELSE
13333 MST115=MSTU(115)
13334 MSTU(115)=MSTP(36)
13335 Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))
13336 ALSSG=ULALPS(Q2BN)
13337 MSTU(115)=MST115
13338 ENDIF
13339 XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
13340 FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.)
13341 PARI(81)=FREPU
13342 FACQQB=FACQQB*FREPU
13343 ENDIF
13344 DO 620 I=MINA,MAXA
13345 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 620
13346 NCHN=NCHN+1
13347 ISIG(NCHN,1)=I
13348 ISIG(NCHN,2)=-I
13349 ISIG(NCHN,3)=1
13350 SIGH(NCHN)=FACQQB
13351 620 CONTINUE
13352
13353 ELSEIF(ISUB.EQ.82) THEN
13354C...g + g -> Q + QB.
13355 FACQQ1=COMFAC*FACA*AS**2*1./6.*((UH-SQM3)/(TH-SQM3)-
13356 & 2.*(UH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(TH-SQM3)**2)
13357 FACQQ2=COMFAC*FACA*AS**2*1./6.*((TH-SQM3)/(UH-SQM3)-
13358 & 2.*(TH-SQM3)**2/SH2+4.*SQM3/SH*(TH*UH-SQM3**2)/(UH-SQM3)**2)
13359 IF(MSTP(35).GE.1) THEN
13360 IF(MSTP(35).EQ.1) THEN
13361 ALSSG=PARP(35)
13362 ELSE
13363 MST115=MSTU(115)
13364 MSTU(115)=MSTP(36)
13365 Q2BN=SQRT(SQM3*((SQRT(SH)-2.*SQRT(SQM3))**2+PARP(36)**2))
13366 ALSSG=ULALPS(Q2BN)
13367 MSTU(115)=MST115
13368 ENDIF
13369 XATTR=4.*PARU(1)*ALSSG/(3.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
13370 FATTR=XATTR/(1.-EXP(-MIN(100.,XATTR)))
13371 XREPU=PARU(1)*ALSSG/(6.*SQRT(MAX(1E-20,1.-4.*SQM3/SH)))
13372 FREPU=XREPU/(EXP(MIN(100.,XREPU))-1.)
13373 FATRE=(2.*FATTR+5.*FREPU)/7.
13374 PARI(81)=FATRE
13375 FACQQ1=FACQQ1*FATRE
13376 FACQQ2=FACQQ2*FATRE
13377 ENDIF
13378 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 630
13379 NCHN=NCHN+1
13380 ISIG(NCHN,1)=21
13381 ISIG(NCHN,2)=21
13382 ISIG(NCHN,3)=1
13383 SIGH(NCHN)=FACQQ1
13384 NCHN=NCHN+1
13385 ISIG(NCHN,1)=21
13386 ISIG(NCHN,2)=21
13387 ISIG(NCHN,3)=2
13388 SIGH(NCHN)=FACQQ2
13389 630 CONTINUE
13390
13391 ENDIF
13392
13393C...D: Mimimum bias processes.
13394
13395 ELSEIF(ISUB.LE.100) THEN
13396 IF(ISUB.EQ.91) THEN
13397C...Elastic scattering.
13398 SIGS=XSEC(ISUB,1)
13399
13400 ELSEIF(ISUB.EQ.92) THEN
13401C...Single diffractive scattering.
13402 SIGS=XSEC(ISUB,1)
13403
13404 ELSEIF(ISUB.EQ.93) THEN
13405C...Double diffractive scattering.
13406 SIGS=XSEC(ISUB,1)
13407
13408 ELSEIF(ISUB.EQ.94) THEN
13409C...Central diffractive scattering.
13410 SIGS=XSEC(ISUB,1)
13411
13412 ELSEIF(ISUB.EQ.95) THEN
13413C...Low-pT scattering.
13414 SIGS=XSEC(ISUB,1)
13415
13416 ELSEIF(ISUB.EQ.96) THEN
13417C...Multiple interactions: sum of QCD processes.
ce320da8 13418 CALL PYWIDTA(21,SQRT(SH),WDTP,WDTE)
0119ef9a 13419
13420C...q + q' -> q + q'.
13421 FACQQ1=COMFAC*AS**2*4./9.*(SH2+UH2)/TH2
13422 FACQQB=COMFAC*AS**2*4./9.*((SH2+UH2)/TH2*FACA-
13423 & MSTP(34)*2./3.*UH2/(SH*TH))
13424 FACQQ2=COMFAC*AS**2*4./9.*((SH2+TH2)/UH2-
13425 & MSTP(34)*2./3.*SH2/(TH*UH))
13426 DO 650 I=-3,3
13427 IF(I.EQ.0) GOTO 650
13428 DO 640 J=-3,3
13429 IF(J.EQ.0) GOTO 640
13430 NCHN=NCHN+1
13431 ISIG(NCHN,1)=I
13432 ISIG(NCHN,2)=J
13433 ISIG(NCHN,3)=111
13434 SIGH(NCHN)=FACQQ1
13435 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
13436 IF(I.EQ.J) THEN
13437 SIGH(NCHN)=0.5*SIGH(NCHN)
13438 NCHN=NCHN+1
13439 ISIG(NCHN,1)=I
13440 ISIG(NCHN,2)=J
13441 ISIG(NCHN,3)=112
13442 SIGH(NCHN)=0.5*FACQQ2
13443 ENDIF
13444 640 CONTINUE
13445 650 CONTINUE
13446
13447C...q + qb -> q' + qb' or g + g.
13448 FACQQB=COMFAC*AS**2*4./9.*(TH2+UH2)/SH2*(WDTE(0,1)+WDTE(0,2)+
13449 & WDTE(0,3)+WDTE(0,4))
13450 FACGG1=COMFAC*AS**2*32./27.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)
13451 FACGG2=COMFAC*AS**2*32./27.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)
13452 DO 660 I=-3,3
13453 IF(I.EQ.0) GOTO 660
13454 NCHN=NCHN+1
13455 ISIG(NCHN,1)=I
13456 ISIG(NCHN,2)=-I
13457 ISIG(NCHN,3)=121
13458 SIGH(NCHN)=FACQQB
13459 NCHN=NCHN+1
13460 ISIG(NCHN,1)=I
13461 ISIG(NCHN,2)=-I
13462 ISIG(NCHN,3)=131
13463 SIGH(NCHN)=0.5*FACGG1
13464 NCHN=NCHN+1
13465 ISIG(NCHN,1)=I
13466 ISIG(NCHN,2)=-I
13467 ISIG(NCHN,3)=132
13468 SIGH(NCHN)=0.5*FACGG2
13469 660 CONTINUE
13470
13471C...q + g -> q + g.
13472 FACQG1=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*UH2/TH2-UH/SH)*
13473 & FACA
13474 FACQG2=COMFAC*AS**2*4./9.*((2.+MSTP(34)*1./4.)*SH2/TH2-SH/UH)
13475 DO 680 I=-3,3
13476 IF(I.EQ.0) GOTO 680
13477 DO 670 ISDE=1,2
13478 NCHN=NCHN+1
13479 ISIG(NCHN,ISDE)=I
13480 ISIG(NCHN,3-ISDE)=21
13481 ISIG(NCHN,3)=281
13482 SIGH(NCHN)=FACQG1
13483 NCHN=NCHN+1
13484 ISIG(NCHN,ISDE)=I
13485 ISIG(NCHN,3-ISDE)=21
13486 ISIG(NCHN,3)=282
13487 SIGH(NCHN)=FACQG2
13488 670 CONTINUE
13489 680 CONTINUE
13490
13491C...g + g -> q + qb or g + g.
13492 FACQQ1=COMFAC*AS**2*1./6.*(UH/TH-(2.+MSTP(34)*1./4.)*UH2/SH2)*
13493 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
13494 FACQQ2=COMFAC*AS**2*1./6.*(TH/UH-(2.+MSTP(34)*1./4.)*TH2/SH2)*
13495 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
13496 FACGG1=COMFAC*AS**2*9./4.*(SH2/TH2+2.*SH/TH+3.+2.*TH/SH+
13497 & TH2/SH2)*FACA
13498 FACGG2=COMFAC*AS**2*9./4.*(UH2/SH2+2.*UH/SH+3.+2.*SH/UH+
13499 & SH2/UH2)*FACA
13500 FACGG3=COMFAC*AS**2*9./4.*(TH2/UH2+2.*TH/UH+3+2.*UH/TH+UH2/TH2)
13501 NCHN=NCHN+1
13502 ISIG(NCHN,1)=21
13503 ISIG(NCHN,2)=21
13504 ISIG(NCHN,3)=531
13505 SIGH(NCHN)=FACQQ1
13506 NCHN=NCHN+1
13507 ISIG(NCHN,1)=21
13508 ISIG(NCHN,2)=21
13509 ISIG(NCHN,3)=532
13510 SIGH(NCHN)=FACQQ2
13511 NCHN=NCHN+1
13512 ISIG(NCHN,1)=21
13513 ISIG(NCHN,2)=21
13514 ISIG(NCHN,3)=681
13515 SIGH(NCHN)=0.5*FACGG1
13516 NCHN=NCHN+1
13517 ISIG(NCHN,1)=21
13518 ISIG(NCHN,2)=21
13519 ISIG(NCHN,3)=682
13520 SIGH(NCHN)=0.5*FACGG2
13521 NCHN=NCHN+1
13522 ISIG(NCHN,1)=21
13523 ISIG(NCHN,2)=21
13524 ISIG(NCHN,3)=683
13525 SIGH(NCHN)=0.5*FACGG3
13526 ENDIF
13527
13528C...E: 2 -> 1, loop diagrams.
13529
13530 ELSEIF(ISUB.LE.110) THEN
13531 IF(ISUB.EQ.101) THEN
13532C...g + g -> gamma*/Z0.
13533
13534 ELSEIF(ISUB.EQ.102) THEN
13535C...g + g -> H0.
ce320da8 13536 CALL PYWIDTA(25,SQRT(SH),WDTP,WDTE)
0119ef9a 13537 ETARE=0.
13538 ETAIM=0.
13539 DO 690 I=1,2*MSTP(1)
13540 EPS=4.*PMAS(I,1)**2/SH
13541 IF(EPS.LE.1.) THEN
13542 IF(EPS.GT.1.E-4) THEN
13543 ROOT=SQRT(1.-EPS)
13544 RLN=LOG((1.+ROOT)/(1.-ROOT))
13545 ELSE
13546 RLN=LOG(4./EPS-2.)
13547 ENDIF
13548 PHIRE=0.25*(RLN**2-PARU(1)**2)
13549 PHIIM=0.5*PARU(1)*RLN
13550 ELSE
13551 PHIRE=-(ASIN(1./SQRT(EPS)))**2
13552 PHIIM=0.
13553 ENDIF
13554 ETARE=ETARE+0.5*EPS*(1.+(EPS-1.)*PHIRE)
13555 ETAIM=ETAIM+0.5*EPS*(EPS-1.)*PHIIM
13556 690 CONTINUE
13557 ETA2=ETARE**2+ETAIM**2
13558 FACH=COMFAC*FACA*(AS/PARU(1)*AEM/XW)**2*1./512.*
13559 & (SH/SQMW)**2*ETA2*SH2/((SH-SQMH)**2+GMMH**2)*
13560 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
13561 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 700
13562 NCHN=NCHN+1
13563 ISIG(NCHN,1)=21
13564 ISIG(NCHN,2)=21
13565 ISIG(NCHN,3)=1
13566 SIGH(NCHN)=FACH
13567 700 CONTINUE
13568
13569 ENDIF
13570
13571C...F: 2 -> 2, box diagrams.
13572
13573 ELSEIF(ISUB.LE.120) THEN
13574 IF(ISUB.EQ.111) THEN
13575C...f + fb -> g + H0 (q + qb -> g + H0 only).
13576 A5STUR=0.
13577 A5STUI=0.
13578 DO 710 I=1,2*MSTP(1)
13579 SQMQ=PMAS(I,1)**2
13580 EPSS=4.*SQMQ/SH
13581 EPSH=4.*SQMQ/SQMH
13582 A5STUR=A5STUR+SQMQ/SQMH*(4.+4.*SH/(TH+UH)*(PYW1AU(EPSS,1)-
13583 & PYW1AU(EPSH,1))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,1)-
13584 & PYW2AU(EPSH,1)))
13585 A5STUI=A5STUI+SQMQ/SQMH*(4.*SH/(TH+UH)*(PYW1AU(EPSS,2)-
13586 & PYW1AU(EPSH,2))+(1.-4.*SQMQ/(TH+UH))*(PYW2AU(EPSS,2)-
13587 & PYW2AU(EPSH,2)))
13588 710 CONTINUE
13589 FACGH=COMFAC*FACA/(144.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
13590 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
13591 FACGH=FACGH*WIDS(25,2)
13592 DO 720 I=MINA,MAXA
13593 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 720
13594 NCHN=NCHN+1
13595 ISIG(NCHN,1)=I
13596 ISIG(NCHN,2)=-I
13597 ISIG(NCHN,3)=1
13598 SIGH(NCHN)=FACGH
13599 720 CONTINUE
13600
13601 ELSEIF(ISUB.EQ.112) THEN
13602C...f + g -> f + H0 (q + g -> q + H0 only).
13603 A5TSUR=0.
13604 A5TSUI=0.
13605 DO 730 I=1,2*MSTP(1)
13606 SQMQ=PMAS(I,1)**2
13607 EPST=4.*SQMQ/TH
13608 EPSH=4.*SQMQ/SQMH
13609 A5TSUR=A5TSUR+SQMQ/SQMH*(4.+4.*TH/(SH+UH)*(PYW1AU(EPST,1)-
13610 & PYW1AU(EPSH,1))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,1)-
13611 & PYW2AU(EPSH,1)))
13612 A5TSUI=A5TSUI+SQMQ/SQMH*(4.*TH/(SH+UH)*(PYW1AU(EPST,2)-
13613 & PYW1AU(EPSH,2))+(1.-4.*SQMQ/(SH+UH))*(PYW2AU(EPST,2)-
13614 & PYW2AU(EPSH,2)))
13615 730 CONTINUE
13616 FACQH=COMFAC*FACA/(384.*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
13617 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
13618 FACQH=FACQH*WIDS(25,2)
13619 DO 750 I=MINA,MAXA
13620 IF(I.EQ.0) GOTO 750
13621 DO 740 ISDE=1,2
13622 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 740
13623 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 740
13624 NCHN=NCHN+1
13625 ISIG(NCHN,ISDE)=I
13626 ISIG(NCHN,3-ISDE)=21
13627 ISIG(NCHN,3)=1
13628 SIGH(NCHN)=FACQH
13629 740 CONTINUE
13630 750 CONTINUE
13631
13632 ELSEIF(ISUB.EQ.113) THEN
13633C...g + g -> g + H0.
13634 A2STUR=0.
13635 A2STUI=0.
13636 A2USTR=0.
13637 A2USTI=0.
13638 A2TUSR=0.
13639 A2TUSI=0.
13640 A4STUR=0.
13641 A4STUI=0.
13642 DO 760 I=6,2*MSTP(1)
13643C'''Only t-quarks yet included
13644 SQMQ=PMAS(I,1)**2
13645 EPSS=4.*SQMQ/SH
13646 EPST=4.*SQMQ/TH
13647 EPSU=4.*SQMQ/UH
13648 EPSH=4.*SQMQ/SQMH
13649 IF(EPSH.LT.1.E-6) GOTO 760
13650 BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))
13651 BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))
13652 BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))
13653 BEUTS=BESTU
13654 BETSU=BEUST
13655 BESUT=BETUS
ce320da8 13656 W3STUR=PYI3AA(BESTU,EPSH,1)-PYI3AA(BESTU,EPSS,1)-
13657 & PYI3AA(BESTU,EPSU,1)
13658 W3STUI=PYI3AA(BESTU,EPSH,2)-PYI3AA(BESTU,EPSS,2)-
13659 & PYI3AA(BESTU,EPSU,2)
13660 W3SUTR=PYI3AA(BESUT,EPSH,1)-PYI3AA(BESUT,EPSS,1)-
13661 & PYI3AA(BESUT,EPST,1)
13662 W3SUTI=PYI3AA(BESUT,EPSH,2)-PYI3AA(BESUT,EPSS,2)-
13663 & PYI3AA(BESUT,EPST,2)
13664 W3TSUR=PYI3AA(BETSU,EPSH,1)-PYI3AA(BETSU,EPST,1)-
13665 & PYI3AA(BETSU,EPSU,1)
13666 W3TSUI=PYI3AA(BETSU,EPSH,2)-PYI3AA(BETSU,EPST,2)-
13667 & PYI3AA(BETSU,EPSU,2)
13668 W3TUSR=PYI3AA(BETUS,EPSH,1)-PYI3AA(BETUS,EPST,1)-
13669 & PYI3AA(BETUS,EPSS,1)
13670 W3TUSI=PYI3AA(BETUS,EPSH,2)-PYI3AA(BETUS,EPST,2)-
13671 & PYI3AA(BETUS,EPSS,2)
13672 W3USTR=PYI3AA(BEUST,EPSH,1)-PYI3AA(BEUST,EPSU,1)-
13673 & PYI3AA(BEUST,EPST,1)
13674 W3USTI=PYI3AA(BEUST,EPSH,2)-PYI3AA(BEUST,EPSU,2)-
13675 & PYI3AA(BEUST,EPST,2)
13676 W3UTSR=PYI3AA(BEUTS,EPSH,1)-PYI3AA(BEUTS,EPSU,1)-
13677 & PYI3AA(BEUTS,EPSS,1)
13678 W3UTSI=PYI3AA(BEUTS,EPSH,2)-PYI3AA(BEUTS,EPSU,2)-
13679 & PYI3AA(BEUTS,EPSS,2)
0119ef9a 13680 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2.*TH*UH*(UH+2.*SH)/
13681 & (SH+UH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*
13682 & (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3STUR)+
13683 & SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,1)-
13684 & PYW2AU(EPSH,1))+0.5*TH*UH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+
13685 & 0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUR)
13686 B2STUI=SQMQ/SQMH**2*(2.*TH*UH*(UH+2.*SH)/(SH+UH)**2*
13687 & (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*
13688 & (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3STUI)+
13689 & SH**2*(2.*SQMQ/(SH+UH)**2-0.5/(SH+UH))*(PYW2AU(EPST,2)-
13690 & PYW2AU(EPSH,2))+0.5*TH*UH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+
13691 & 0.125*(SH-12.*SQMQ-4.*TH*UH/SH)*W3TSUI)
13692 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2.*UH*TH*(TH+2.*SH)/
13693 & (SH+TH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-SH/4.)*
13694 & (0.5*PYW2AU(EPSS,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3SUTR)+
13695 & SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,1)-
13696 & PYW2AU(EPSH,1))+0.5*UH*TH/SH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+
13697 & 0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTR)
13698 B2SUTI=SQMQ/SQMH**2*(2.*UH*TH*(TH+2.*SH)/(SH+TH)**2*
13699 & (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-SH/4.)*
13700 & (0.5*PYW2AU(EPSS,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3SUTI)+
13701 & SH**2*(2.*SQMQ/(SH+TH)**2-0.5/(SH+TH))*(PYW2AU(EPSU,2)-
13702 & PYW2AU(EPSH,2))+0.5*UH*TH/SH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+
13703 & 0.125*(SH-12.*SQMQ-4.*UH*TH/SH)*W3USTI)
13704 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2.*SH*UH*(UH+2.*TH)/
13705 & (TH+UH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*
13706 & (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3TSUR)+
13707 & TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,1)-
13708 & PYW2AU(EPSH,1))+0.5*SH*UH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+
13709 & 0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUR)
13710 B2TSUI=SQMQ/SQMH**2*(2.*SH*UH*(UH+2.*TH)/(TH+UH)**2*
13711 & (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*
13712 & (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3TSUI)+
13713 & TH**2*(2.*SQMQ/(TH+UH)**2-0.5/(TH+UH))*(PYW2AU(EPSS,2)-
13714 & PYW2AU(EPSH,2))+0.5*SH*UH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+
13715 & 0.125*(TH-12.*SQMQ-4.*SH*UH/TH)*W3STUI)
13716 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2.*UH*SH*(SH+2.*TH)/
13717 & (TH+SH)**2*(PYW1AU(EPSU,1)-PYW1AU(EPSH,1))+(SQMQ-TH/4.)*
13718 & (0.5*PYW2AU(EPST,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSU,1)+W3TUSR)+
13719 & TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,1)-
13720 & PYW2AU(EPSH,1))+0.5*UH*SH/TH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSU,1))+
13721 & 0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSR)
13722 B2TUSI=SQMQ/SQMH**2*(2.*UH*SH*(SH+2.*TH)/(TH+SH)**2*
13723 & (PYW1AU(EPSU,2)-PYW1AU(EPSH,2))+(SQMQ-TH/4.)*
13724 & (0.5*PYW2AU(EPST,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSU,2)+W3TUSI)+
13725 & TH**2*(2.*SQMQ/(TH+SH)**2-0.5/(TH+SH))*(PYW2AU(EPSU,2)-
13726 & PYW2AU(EPSH,2))+0.5*UH*SH/TH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSU,2))+
13727 & 0.125*(TH-12.*SQMQ-4.*UH*SH/TH)*W3UTSI)
13728 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2.*SH*TH*(TH+2.*UH)/
13729 & (UH+TH)**2*(PYW1AU(EPSS,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*
13730 & (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPSS,1)+W3USTR)+
13731 & UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,1)-
13732 & PYW2AU(EPSH,1))+0.5*SH*TH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPSS,1))+
13733 & 0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTR)
13734 B2USTI=SQMQ/SQMH**2*(2.*SH*TH*(TH+2.*UH)/(UH+TH)**2*
13735 & (PYW1AU(EPSS,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*
13736 & (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPSS,2)+W3USTI)+
13737 & UH**2*(2.*SQMQ/(UH+TH)**2-0.5/(UH+TH))*(PYW2AU(EPSS,2)-
13738 & PYW2AU(EPSH,2))+0.5*SH*TH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPSS,2))+
13739 & 0.125*(UH-12.*SQMQ-4.*SH*TH/UH)*W3SUTI)
13740 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2.*TH*SH*(SH+2.*UH)/
13741 & (UH+SH)**2*(PYW1AU(EPST,1)-PYW1AU(EPSH,1))+(SQMQ-UH/4.)*
13742 & (0.5*PYW2AU(EPSU,1)+0.5*PYW2AU(EPSH,1)-PYW2AU(EPST,1)+W3UTSR)+
13743 & UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,1)-
13744 & PYW2AU(EPSH,1))+0.5*TH*SH/UH*(PYW2AU(EPSH,1)-2.*PYW2AU(EPST,1))+
13745 & 0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSR)
13746 B2UTSI=SQMQ/SQMH**2*(2.*TH*SH*(SH+2.*UH)/(UH+SH)**2*
13747 & (PYW1AU(EPST,2)-PYW1AU(EPSH,2))+(SQMQ-UH/4.)*
13748 & (0.5*PYW2AU(EPSU,2)+0.5*PYW2AU(EPSH,2)-PYW2AU(EPST,2)+W3UTSI)+
13749 & UH**2*(2.*SQMQ/(UH+SH)**2-0.5/(UH+SH))*(PYW2AU(EPST,2)-
13750 & PYW2AU(EPSH,2))+0.5*TH*SH/UH*(PYW2AU(EPSH,2)-2.*PYW2AU(EPST,2))+
13751 & 0.125*(UH-12.*SQMQ-4.*TH*SH/UH)*W3TUSI)
13752 B4STUR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,1)-
13753 & PYW2AU(EPSH,1)+W3STUR))
13754 B4STUI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSS,2)-
13755 & PYW2AU(EPSH,2)+W3STUI)
13756 B4TUSR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,1)-
13757 & PYW2AU(EPSH,1)+W3TUSR))
13758 B4TUSI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPST,2)-
13759 & PYW2AU(EPSH,2)+W3TUSI)
13760 B4USTR=SQMQ/SQMH*(-2./3.+(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,1)-
13761 & PYW2AU(EPSH,1)+W3USTR))
13762 B4USTI=SQMQ/SQMH*(SQMQ/SQMH-1./4.)*(PYW2AU(EPSU,2)-
13763 & PYW2AU(EPSH,2)+W3USTI)
13764 A2STUR=A2STUR+B2STUR+B2SUTR
13765 A2STUI=A2STUI+B2STUI+B2SUTI
13766 A2USTR=A2USTR+B2USTR+B2UTSR
13767 A2USTI=A2USTI+B2USTI+B2UTSI
13768 A2TUSR=A2TUSR+B2TUSR+B2TSUR
13769 A2TUSI=A2TUSI+B2TUSI+B2TSUI
13770 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
13771 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
13772 760 CONTINUE
13773 FACGH=COMFAC*FACA*3./(128.*PARU(1)**2)*AEM/XW*AS**3*
13774 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
13775 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
13776 FACGH=FACGH*WIDS(25,2)
13777 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 770
13778 NCHN=NCHN+1
13779 ISIG(NCHN,1)=21
13780 ISIG(NCHN,2)=21
13781 ISIG(NCHN,3)=1
13782 SIGH(NCHN)=FACGH
13783 770 CONTINUE
13784
13785 ELSEIF(ISUB.EQ.114) THEN
13786C...g + g -> gamma + gamma.
13787 ASRE=0.
13788 ASIM=0.
13789 DO 780 I=1,2*MSTP(1)
13790 EI=KCHG(IABS(I),1)/3.
13791 SQMQ=PMAS(I,1)**2
13792 EPSS=4.*SQMQ/SH
13793 EPST=4.*SQMQ/TH
13794 EPSU=4.*SQMQ/UH
13795 IF(EPSS+ABS(EPST)+ABS(EPSU).LT.3.E-6) THEN
13796 A0STUR=1.+(TH-UH)/SH*LOG(TH/UH)+0.5*(TH2+UH2)/SH2*
13797 & (LOG(TH/UH)**2+PARU(1)**2)
13798 A0STUI=0.
13799 A0TSUR=1.+(SH-UH)/TH*LOG(-SH/UH)+0.5*(SH2+UH2)/TH2*
13800 & LOG(-SH/UH)**2
13801 A0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*LOG(-SH/UH))
13802 A0UTSR=1.+(TH-SH)/UH*LOG(-TH/SH)+0.5*(TH2+SH2)/UH2*
13803 & LOG(-TH/SH)**2
13804 A0UTSI=PARU(1)*((TH-SH)/UH+(TH2+SH2)/UH2*LOG(-TH/SH))
13805 A1STUR=-1.
13806 A1STUI=0.
13807 A2STUR=-1.
13808 A2STUI=0.
13809 ELSE
13810 BESTU=0.5*(1.+SQRT(1.+EPSS*TH/UH))
13811 BEUST=0.5*(1.+SQRT(1.+EPSU*SH/TH))
13812 BETUS=0.5*(1.+SQRT(1.+EPST*UH/SH))
13813 BEUTS=BESTU
13814 BETSU=BEUST
13815 BESUT=BETUS
13816 A0STUR=1.+(1.+2.*TH/SH)*PYW1AU(EPST,1)+(1.+2.*UH/SH)*
13817 & PYW1AU(EPSU,1)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,1)+
ce320da8 13818 & PYW2AU(EPSU,1))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AA(BESUT,EPSS,1)+
13819 & PYI3AA(BESUT,EPST,1))-0.25*EPSU*(1.-0.5*EPSS)*
13820 & (PYI3AA(BESTU,EPSS,1)+PYI3AA(BESTU,EPSU,1))+
0119ef9a 13821 & 0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)*
ce320da8 13822 & (PYI3AA(BETSU,EPST,1)+PYI3AA(BETSU,EPSU,1))
0119ef9a 13823 A0STUI=(1.+2.*TH/SH)*PYW1AU(EPST,2)+(1.+2.*UH/SH)*
13824 & PYW1AU(EPSU,2)+0.5*((TH2+UH2)/SH2-EPSS)*(PYW2AU(EPST,2)+
ce320da8 13825 & PYW2AU(EPSU,2))-0.25*EPST*(1.-0.5*EPSS)*(PYI3AA(BESUT,EPSS,2)+
13826 & PYI3AA(BESUT,EPST,2))-0.25*EPSU*(1.-0.5*EPSS)*
13827 & (PYI3AA(BESTU,EPSS,2)+PYI3AA(BESTU,EPSU,2))+
0119ef9a 13828 & 0.25*(-2.*(TH2+UH2)/SH2+4.*EPSS+EPST+EPSU+0.5*EPST*EPSU)*
ce320da8 13829 & (PYI3AA(BETSU,EPST,2)+PYI3AA(BETSU,EPSU,2))
0119ef9a 13830 A0TSUR=1.+(1.+2.*SH/TH)*PYW1AU(EPSS,1)+(1.+2.*UH/TH)*
13831 & PYW1AU(EPSU,1)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,1)+
ce320da8 13832 & PYW2AU(EPSU,1))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AA(BETUS,EPST,1)+
13833 & PYI3AA(BETUS,EPSS,1))-0.25*EPSU*(1.-0.5*EPST)*
13834 & (PYI3AA(BETSU,EPST,1)+PYI3AA(BETSU,EPSU,1))+
0119ef9a 13835 & 0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)*
ce320da8 13836 & (PYI3AA(BESTU,EPSS,1)+PYI3AA(BESTU,EPSU,1))
0119ef9a 13837 A0TSUI=(1.+2.*SH/TH)*PYW1AU(EPSS,2)+(1.+2.*UH/TH)*
13838 & PYW1AU(EPSU,2)+0.5*((SH2+UH2)/TH2-EPST)*(PYW2AU(EPSS,2)+
ce320da8 13839 & PYW2AU(EPSU,2))-0.25*EPSS*(1.-0.5*EPST)*(PYI3AA(BETUS,EPST,2)+
13840 & PYI3AA(BETUS,EPSS,2))-0.25*EPSU*(1.-0.5*EPST)*
13841 & (PYI3AA(BETSU,EPST,2)+PYI3AA(BETSU,EPSU,2))+
0119ef9a 13842 & 0.25*(-2.*(SH2+UH2)/TH2+4.*EPST+EPSS+EPSU+0.5*EPSS*EPSU)*
ce320da8 13843 & (PYI3AA(BESTU,EPSS,2)+PYI3AA(BESTU,EPSU,2))
0119ef9a 13844 A0UTSR=1.+(1.+2.*TH/UH)*PYW1AU(EPST,1)+(1.+2.*SH/UH)*
13845 & PYW1AU(EPSS,1)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,1)+
ce320da8 13846 & PYW2AU(EPSS,1))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AA(BEUST,EPSU,1)+
13847 & PYI3AA(BEUST,EPST,1))-0.25*EPSS*(1.-0.5*EPSU)*
13848 & (PYI3AA(BEUTS,EPSU,1)+PYI3AA(BEUTS,EPSS,1))+
0119ef9a 13849 & 0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)*
ce320da8 13850 & (PYI3AA(BETUS,EPST,1)+PYI3AA(BETUS,EPSS,1))
0119ef9a 13851 A0UTSI=(1.+2.*TH/UH)*PYW1AU(EPST,2)+(1.+2.*SH/UH)*
13852 & PYW1AU(EPSS,2)+0.5*((TH2+SH2)/UH2-EPSU)*(PYW2AU(EPST,2)+
ce320da8 13853 & PYW2AU(EPSS,2))-0.25*EPST*(1.-0.5*EPSU)*(PYI3AA(BEUST,EPSU,2)+
13854 & PYI3AA(BEUST,EPST,2))-0.25*EPSS*(1.-0.5*EPSU)*
13855 & (PYI3AA(BEUTS,EPSU,2)+PYI3AA(BEUTS,EPSS,2))+
0119ef9a 13856 & 0.25*(-2.*(TH2+SH2)/UH2+4.*EPSU+EPST+EPSS+0.5*EPST*EPSS)*
ce320da8 13857 & (PYI3AA(BETUS,EPST,2)+PYI3AA(BETUS,EPSS,2))
0119ef9a 13858 A1STUR=-1.-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,1)+
13859 & PYW2AU(EPST,1)+PYW2AU(EPSU,1))+0.25*(EPSU+0.5*EPSS*EPST)*
ce320da8 13860 & (PYI3AA(BESUT,EPSS,1)+PYI3AA(BESUT,EPST,1))+
13861 & 0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AA(BESTU,EPSS,1)+
13862 & PYI3AA(BESTU,EPSU,1))+0.25*(EPSS+0.5*EPST*EPSU)*
13863 & (PYI3AA(BETSU,EPST,1)+PYI3AA(BETSU,EPSU,1))
0119ef9a 13864 A1STUI=-0.25*(EPSS+EPST+EPSU)*(PYW2AU(EPSS,2)+PYW2AU(EPST,2)+
13865 & PYW2AU(EPSU,2))+0.25*(EPSU+0.5*EPSS*EPST)*
ce320da8 13866 & (PYI3AA(BESUT,EPSS,2)+PYI3AA(BESUT,EPST,2))+
13867 & 0.25*(EPST+0.5*EPSS*EPSU)*(PYI3AA(BESTU,EPSS,2)+
13868 & PYI3AA(BESTU,EPSU,2))+0.25*(EPSS+0.5*EPST*EPSU)*
13869 & (PYI3AA(BETSU,EPST,2)+PYI3AA(BETSU,EPSU,2))
13870 A2STUR=-1.+0.125*EPSS*EPST*(PYI3AA(BESUT,EPSS,1)+
13871 & PYI3AA(BESUT,EPST,1))+0.125*EPSS*EPSU*(PYI3AA(BESTU,EPSS,1)+
13872 & PYI3AA(BESTU,EPSU,1))+0.125*EPST*EPSU*(PYI3AA(BETSU,EPST,1)+
13873 & PYI3AA(BETSU,EPSU,1))
13874 A2STUI=0.125*EPSS*EPST*(PYI3AA(BESUT,EPSS,2)+
13875 & PYI3AA(BESUT,EPST,2))+0.125*EPSS*EPSU*(PYI3AA(BESTU,EPSS,2)+
13876 & PYI3AA(BESTU,EPSU,2))+0.125*EPST*EPSU*(PYI3AA(BETSU,EPST,2)+
13877 & PYI3AA(BETSU,EPSU,2))
0119ef9a 13878 ENDIF
13879 ASRE=ASRE+EI**2*(A0STUR+A0TSUR+A0UTSR+4.*A1STUR+A2STUR)
13880 ASIM=ASIM+EI**2*(A0STUI+A0TSUI+A0UTSI+4.*A1STUI+A2STUI)
13881 780 CONTINUE
13882 FACGG=COMFAC*FACA/(8.*PARU(1)**2)*AS**2*AEM**2*(ASRE**2+ASIM**2)
13883 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 790
13884 NCHN=NCHN+1
13885 ISIG(NCHN,1)=21
13886 ISIG(NCHN,2)=21
13887 ISIG(NCHN,3)=1
13888 SIGH(NCHN)=FACGG
13889 790 CONTINUE
13890
13891 ELSEIF(ISUB.EQ.115) THEN
13892C...g + g -> gamma + Z0.
13893
13894 ELSEIF(ISUB.EQ.116) THEN
13895C...g + g -> Z0 + Z0.
13896
13897 ELSEIF(ISUB.EQ.117) THEN
13898C...g + g -> W+ + W-.
13899
13900 ENDIF
13901
13902C...G: 2 -> 3, tree diagrams.
13903
13904 ELSEIF(ISUB.LE.140) THEN
13905 IF(ISUB.EQ.121) THEN
13906C...g + g -> f + fb + H0.
13907
13908 ENDIF
13909
13910C...H: 2 -> 1, tree diagrams, non-standard model processes.
13911
13912 ELSEIF(ISUB.LE.160) THEN
13913 IF(ISUB.EQ.141) THEN
13914C...f + fb -> gamma*/Z0/Z'0.
13915 MINT(61)=2
ce320da8 13916 CALL PYWIDTA(32,SQRT(SH),WDTP,WDTE)
0119ef9a 13917 FACZP=COMFAC*AEM**2*4./9.
13918 DO 800 I=MINA,MAXA
13919 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 800
13920 EI=KCHG(IABS(I),1)/3.
13921 AI=SIGN(1.,EI)
13922 VI=AI-4.*EI*XW
13923 API=SIGN(1.,EI)
13924 VPI=API-4.*EI*XW
13925 NCHN=NCHN+1
13926 ISIG(NCHN,1)=I
13927 ISIG(NCHN,2)=-I
13928 ISIG(NCHN,3)=1
13929 SIGH(NCHN)=FACZP*(EI**2*VINT(111)+EI*VI/(8.*XW*(1.-XW))*
13930 & SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)*VINT(112)+EI*VPI/(8.*XW*
13931 & (1.-XW))*SH*(SH-SQMZP)/((SH-SQMZP)**2+GMMZP**2)*VINT(113)+
13932 & (VI**2+AI**2)/(16.*XW*(1.-XW))**2*SH2/((SH-SQMZ)**2+GMMZ**2)*
13933 & VINT(114)+2.*(VI*VPI+AI*API)/(16.*XW*(1.-XW))**2*SH2*
13934 & ((SH-SQMZ)*(SH-SQMZP)+GMMZ*GMMZP)/(((SH-SQMZ)**2+GMMZ**2)*
13935 & ((SH-SQMZP)**2+GMMZP**2))*VINT(115)+(VPI**2+API**2)/
13936 & (16.*XW*(1.-XW))**2*SH2/((SH-SQMZP)**2+GMMZP**2)*VINT(116))
13937 800 CONTINUE
13938
13939 ELSEIF(ISUB.EQ.142) THEN
13940C...f + fb' -> H+/-.
ce320da8 13941 CALL PYWIDTA(37,SQRT(SH),WDTP,WDTE)
0119ef9a 13942 FHC=COMFAC*(AEM/XW)**2*1./48.*(SH/SQMW)**2*SH2/
13943 & ((SH-SQMHC)**2+GMMHC**2)
13944C'''No construction yet for leptons
13945 DO 840 I=1,MSTP(54)/2
13946 IL=2*I-1
13947 IU=2*I
13948 RMQL=PMAS(IL,1)**2/SH
13949 RMQU=PMAS(IU,1)**2/SH
13950 FACHC=FHC*((RMQL*PARU(121)+RMQU/PARU(121))*(1.-RMQL-RMQU)-
13951 & 4.*RMQL*RMQU)/SQRT(MAX(0.,(1.-RMQL-RMQU)**2-4.*RMQL*RMQU))
13952 IF(KFAC(1,IL)*KFAC(2,-IU).EQ.0) GOTO 810
13953 KCHHC=(KCHG(IL,1)-KCHG(IU,1))/3
13954 NCHN=NCHN+1
13955 ISIG(NCHN,1)=IL
13956 ISIG(NCHN,2)=-IU
13957 ISIG(NCHN,3)=1
13958 SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
13959 810 IF(KFAC(1,-IL)*KFAC(2,IU).EQ.0) GOTO 820
13960 KCHHC=(-KCHG(IL,1)+KCHG(IU,1))/3
13961 NCHN=NCHN+1
13962 ISIG(NCHN,1)=-IL
13963 ISIG(NCHN,2)=IU
13964 ISIG(NCHN,3)=1
13965 SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
13966 820 IF(KFAC(1,IU)*KFAC(2,-IL).EQ.0) GOTO 830
13967 KCHHC=(KCHG(IU,1)-KCHG(IL,1))/3
13968 NCHN=NCHN+1
13969 ISIG(NCHN,1)=IU
13970 ISIG(NCHN,2)=-IL
13971 ISIG(NCHN,3)=1
13972 SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
13973 830 IF(KFAC(1,-IU)*KFAC(2,IL).EQ.0) GOTO 840
13974 KCHHC=(-KCHG(IU,1)+KCHG(IL,1))/3
13975 NCHN=NCHN+1
13976 ISIG(NCHN,1)=-IU
13977 ISIG(NCHN,2)=IL
13978 ISIG(NCHN,3)=1
13979 SIGH(NCHN)=FACHC*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
13980 840 CONTINUE
13981
13982 ELSEIF(ISUB.EQ.143) THEN
13983C...f + fb -> R.
ce320da8 13984 CALL PYWIDTA(40,SQRT(SH),WDTP,WDTE)
0119ef9a 13985 FACR=COMFAC*(AEM/XW)**2*1./9.*SH2/((SH-SQMR)**2+GMMR**2)
13986 DO 860 I=MIN1,MAX1
13987 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
13988 IA=IABS(I)
13989 DO 850 J=MIN2,MAX2
13990 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
13991 JA=IABS(J)
13992 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 850
13993 NCHN=NCHN+1
13994 ISIG(NCHN,1)=I
13995 ISIG(NCHN,2)=J
13996 ISIG(NCHN,3)=1
13997 SIGH(NCHN)=FACR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
13998 850 CONTINUE
13999 860 CONTINUE
14000
14001 ENDIF
14002
14003C...I: 2 -> 2, tree diagrams, non-standard model processes.
14004
14005 ELSE
14006 IF(ISUB.EQ.161) THEN
14007C...f + g -> f' + H+/- (q + g -> q' + H+/- only).
14008 FHCQ=COMFAC*FACA*AS*AEM/XW*1./24
14009 DO 900 I=1,MSTP(54)
14010 IU=I+MOD(I,2)
14011 SQMQ=PMAS(IU,1)**2
14012 FACHCQ=FHCQ/PARU(121)*SQMQ/SQMW*(SH/(SQMQ-UH)+
14013 & 2.*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
14014 & 2.*SQMQ/(SQMQ-UH)+2.*(SQMHC-UH)/(SQMQ-UH)*(SQMHC-SQMQ-SH)/SH)
14015 IF(KFAC(1,-I)*KFAC(2,21).EQ.0) GOTO 870
14016 KCHHC=ISIGN(1,-KCHG(I,1))
14017 NCHN=NCHN+1
14018 ISIG(NCHN,1)=-I
14019 ISIG(NCHN,2)=21
14020 ISIG(NCHN,3)=1
14021 SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
14022 870 IF(KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 880
14023 KCHHC=ISIGN(1,KCHG(I,1))
14024 NCHN=NCHN+1
14025 ISIG(NCHN,1)=I
14026 ISIG(NCHN,2)=21
14027 ISIG(NCHN,3)=1
14028 SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
14029 880 IF(KFAC(1,21)*KFAC(2,-I).EQ.0) GOTO 890
14030 KCHHC=ISIGN(1,-KCHG(I,1))
14031 NCHN=NCHN+1
14032 ISIG(NCHN,1)=21
14033 ISIG(NCHN,2)=-I
14034 ISIG(NCHN,3)=1
14035 SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
14036 890 IF(KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 900
14037 KCHHC=ISIGN(1,KCHG(I,1))
14038 NCHN=NCHN+1
14039 ISIG(NCHN,1)=21
14040 ISIG(NCHN,2)=I
14041 ISIG(NCHN,3)=1
14042 SIGH(NCHN)=FACHCQ*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
14043 900 CONTINUE
14044
14045 ENDIF
14046 ENDIF
14047
14048C...Multiply with structure functions.
14049 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
14050 DO 910 ICHN=1,NCHN
14051 IF(MINT(41).EQ.2) THEN
14052 KFL1=ISIG(ICHN,1)
14053 IF(KFL1.EQ.21) KFL1=0
14054 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
14055 ENDIF
14056 IF(MINT(42).EQ.2) THEN
14057 KFL2=ISIG(ICHN,2)
14058 IF(KFL2.EQ.21) KFL2=0
14059 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
14060 ENDIF
14061 910 SIGS=SIGS+SIGH(ICHN)
14062 ENDIF
14063
14064 RETURN
14065 END
14066
14067C*********************************************************************
14068
14069 SUBROUTINE PYSTFU(KF,X,Q2,XPQ,JBT)
14070
14071C *******JBT specifies beam or target of the particle
14072C...Gives proton and pi+ parton structure functions according to a few
14073C...different parametrizations. Note that what is coded is x times the
14074C...probability distribution, i.e. xq(x,Q2) etc.
14075 COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
14076 SAVE /HPARNT/
14077 COMMON/hjcrdn/YP(3,300),YT(3,300)
14078 SAVE /hjcrdn/
14079C ********COMMON BLOCK FROM HIJING
14080 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14081 SAVE /LUDAT1A/
14082 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
14083 SAVE /LUDAT2A/
14084 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
14085 SAVE /PYPARSA/
14086 COMMON/PYINT1A/MINT(400),VINT(400)
14087 SAVE /PYINT1A/
14088 DIMENSION XPQ(-6:6),XQ(6),TX(6),TT(6),TS(6),NEHLQ(8,2),
14089 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2),COW(3,5,4,2)
14090
14091C...The following data lines are coefficients needed in the
14092C...Eichten, Hinchliffe, Lane, Quigg proton structure function
14093C...parametrizations, see below.
14094C...Powers of 1-x in different cases.
14095 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
14096C...Expansion coefficients for up valence quark distribution.
14097 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
14098 1 7.677E-01,-2.087E-01,-3.303E-01,-2.517E-02,-1.570E-02,-1.000E-04,
14099 2-5.326E-01,-2.661E-01, 3.201E-01, 1.192E-01, 2.434E-02, 7.620E-03,
14100 3 2.162E-01, 1.881E-01,-8.375E-02,-6.515E-02,-1.743E-02,-5.040E-03,
14101 4-9.211E-02,-9.952E-02, 1.373E-02, 2.506E-02, 8.770E-03, 2.550E-03,
14102 5 3.670E-02, 4.409E-02, 9.600E-04,-7.960E-03,-3.420E-03,-1.050E-03,
14103 6-1.549E-02,-2.026E-02,-3.060E-03, 2.220E-03, 1.240E-03, 4.100E-04,
14104 1 2.395E-01, 2.905E-01, 9.778E-02, 2.149E-02, 3.440E-03, 5.000E-04,
14105 2 1.751E-02,-6.090E-03,-2.687E-02,-1.916E-02,-7.970E-03,-2.750E-03,
14106 3-5.760E-03,-5.040E-03, 1.080E-03, 2.490E-03, 1.530E-03, 7.500E-04,
14107 4 1.740E-03, 1.960E-03, 3.000E-04,-3.400E-04,-2.900E-04,-1.800E-04,
14108 5-5.300E-04,-6.400E-04,-1.700E-04, 4.000E-05, 6.000E-05, 4.000E-05,
14109 6 1.700E-04, 2.200E-04, 8.000E-05, 1.000E-05,-1.000E-05,-1.000E-05/
14110 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
14111 1 7.237E-01,-2.189E-01,-2.995E-01,-1.909E-02,-1.477E-02, 2.500E-04,
14112 2-5.314E-01,-2.425E-01, 3.283E-01, 1.119E-01, 2.223E-02, 7.070E-03,
14113 3 2.289E-01, 1.890E-01,-9.859E-02,-6.900E-02,-1.747E-02,-5.080E-03,
14114 4-1.041E-01,-1.084E-01, 2.108E-02, 2.975E-02, 9.830E-03, 2.830E-03,
14115 5 4.394E-02, 5.116E-02,-1.410E-03,-1.055E-02,-4.230E-03,-1.270E-03,
14116 6-1.991E-02,-2.539E-02,-2.780E-03, 3.430E-03, 1.720E-03, 5.500E-04,
14117 1 2.410E-01, 2.884E-01, 9.369E-02, 1.900E-02, 2.530E-03, 2.400E-04,
14118 2 1.765E-02,-9.220E-03,-3.037E-02,-2.085E-02,-8.440E-03,-2.810E-03,
14119 3-6.450E-03,-5.260E-03, 1.720E-03, 3.110E-03, 1.830E-03, 8.700E-04,
14120 4 2.120E-03, 2.320E-03, 2.600E-04,-4.900E-04,-3.900E-04,-2.300E-04,
14121 5-6.900E-04,-8.200E-04,-2.000E-04, 7.000E-05, 9.000E-05, 6.000E-05,
14122 6 2.400E-04, 3.100E-04, 1.100E-04, 0.000E+00,-2.000E-05,-2.000E-05/
14123C...Expansion coefficients for down valence quark distribution.
14124 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
14125 1 3.813E-01,-8.090E-02,-1.634E-01,-2.185E-02,-8.430E-03,-6.200E-04,
14126 2-2.948E-01,-1.435E-01, 1.665E-01, 6.638E-02, 1.473E-02, 4.080E-03,
14127 3 1.252E-01, 1.042E-01,-4.722E-02,-3.683E-02,-1.038E-02,-2.860E-03,
14128 4-5.478E-02,-5.678E-02, 8.900E-03, 1.484E-02, 5.340E-03, 1.520E-03,
14129 5 2.220E-02, 2.567E-02,-3.000E-05,-4.970E-03,-2.160E-03,-6.500E-04,
14130 6-9.530E-03,-1.204E-02,-1.510E-03, 1.510E-03, 8.300E-04, 2.700E-04,
14131 1 1.261E-01, 1.354E-01, 3.958E-02, 8.240E-03, 1.660E-03, 4.500E-04,
14132 2 3.890E-03,-1.159E-02,-1.625E-02,-9.610E-03,-3.710E-03,-1.260E-03,
14133 3-1.910E-03,-5.600E-04, 1.590E-03, 1.590E-03, 8.400E-04, 3.900E-04,
14134 4 6.400E-04, 4.900E-04,-1.500E-04,-2.900E-04,-1.800E-04,-1.000E-04,
14135 5-2.000E-04,-1.900E-04, 0.000E+00, 6.000E-05, 4.000E-05, 3.000E-05,
14136 6 7.000E-05, 8.000E-05, 2.000E-05,-1.000E-05,-1.000E-05,-1.000E-05/
14137 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
14138 1 3.578E-01,-8.622E-02,-1.480E-01,-1.840E-02,-7.820E-03,-4.500E-04,
14139 2-2.925E-01,-1.304E-01, 1.696E-01, 6.243E-02, 1.353E-02, 3.750E-03,
14140 3 1.318E-01, 1.041E-01,-5.486E-02,-3.872E-02,-1.038E-02,-2.850E-03,
14141 4-6.162E-02,-6.143E-02, 1.303E-02, 1.740E-02, 5.940E-03, 1.670E-03,
14142 5 2.643E-02, 2.957E-02,-1.490E-03,-6.450E-03,-2.630E-03,-7.700E-04,
14143 6-1.218E-02,-1.497E-02,-1.260E-03, 2.240E-03, 1.120E-03, 3.500E-04,
14144 1 1.263E-01, 1.334E-01, 3.732E-02, 7.070E-03, 1.260E-03, 3.400E-04,
14145 2 3.660E-03,-1.357E-02,-1.795E-02,-1.031E-02,-3.880E-03,-1.280E-03,
14146 3-2.100E-03,-3.600E-04, 2.050E-03, 1.920E-03, 9.800E-04, 4.400E-04,
14147 4 7.700E-04, 5.400E-04,-2.400E-04,-3.900E-04,-2.400E-04,-1.300E-04,
14148 5-2.600E-04,-2.300E-04, 2.000E-05, 9.000E-05, 6.000E-05, 4.000E-05,
14149 6 9.000E-05, 1.000E-04, 2.000E-05,-2.000E-05,-2.000E-05,-1.000E-05/
14150C...Expansion coefficients for up and down sea quark distributions.
14151 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
14152 1 6.870E-02,-6.861E-02, 2.973E-02,-5.400E-03, 3.780E-03,-9.700E-04,
14153 2-1.802E-02, 1.400E-04, 6.490E-03,-8.540E-03, 1.220E-03,-1.750E-03,
14154 3-4.650E-03, 1.480E-03,-5.930E-03, 6.000E-04,-1.030E-03,-8.000E-05,
14155 4 6.440E-03, 2.570E-03, 2.830E-03, 1.150E-03, 7.100E-04, 3.300E-04,
14156 5-3.930E-03,-2.540E-03,-1.160E-03,-7.700E-04,-3.600E-04,-1.900E-04,
14157 6 2.340E-03, 1.930E-03, 5.300E-04, 3.700E-04, 1.600E-04, 9.000E-05,
14158 1 1.014E+00,-1.106E+00, 3.374E-01,-7.444E-02, 8.850E-03,-8.700E-04,
14159 2 9.233E-01,-1.285E+00, 4.475E-01,-9.786E-02, 1.419E-02,-1.120E-03,
14160 3 4.888E-02,-1.271E-01, 8.606E-02,-2.608E-02, 4.780E-03,-6.000E-04,
14161 4-2.691E-02, 4.887E-02,-1.771E-02, 1.620E-03, 2.500E-04,-6.000E-05,
14162 5 7.040E-03,-1.113E-02, 1.590E-03, 7.000E-04,-2.000E-04, 0.000E+00,
14163 6-1.710E-03, 2.290E-03, 3.800E-04,-3.500E-04, 4.000E-05, 1.000E-05/
14164 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
14165 1 1.008E-01,-7.100E-02, 1.973E-02,-5.710E-03, 2.930E-03,-9.900E-04,
14166 2-5.271E-02,-1.823E-02, 1.792E-02,-6.580E-03, 1.750E-03,-1.550E-03,
14167 3 1.220E-02, 1.763E-02,-8.690E-03,-8.800E-04,-1.160E-03,-2.100E-04,
14168 4-1.190E-03,-7.180E-03, 2.360E-03, 1.890E-03, 7.700E-04, 4.100E-04,
14169 5-9.100E-04, 2.040E-03,-3.100E-04,-1.050E-03,-4.000E-04,-2.400E-04,
14170 6 1.190E-03,-1.700E-04,-2.000E-04, 4.200E-04, 1.700E-04, 1.000E-04,
14171 1 1.081E+00,-1.189E+00, 3.868E-01,-8.617E-02, 1.115E-02,-1.180E-03,
14172 2 9.917E-01,-1.396E+00, 4.998E-01,-1.159E-01, 1.674E-02,-1.720E-03,
14173 3 5.099E-02,-1.338E-01, 9.173E-02,-2.885E-02, 5.890E-03,-6.500E-04,
14174 4-3.178E-02, 5.703E-02,-2.070E-02, 2.440E-03, 1.100E-04,-9.000E-05,
14175 5 8.970E-03,-1.392E-02, 2.050E-03, 6.500E-04,-2.300E-04, 2.000E-05,
14176 6-2.340E-03, 3.010E-03, 5.000E-04,-3.900E-04, 6.000E-05, 1.000E-05/
14177C...Expansion coefficients for gluon distribution.
14178 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
14179 1 9.482E-01,-9.578E-01, 1.009E-01,-1.051E-01, 3.456E-02,-3.054E-02,
14180 2-9.627E-01, 5.379E-01, 3.368E-01,-9.525E-02, 1.488E-02,-2.051E-02,
14181 3 4.300E-01,-8.306E-02,-3.372E-01, 4.902E-02,-9.160E-03, 1.041E-02,
14182 4-1.925E-01,-1.790E-02, 2.183E-01, 7.490E-03, 4.140E-03,-1.860E-03,
14183 5 8.183E-02, 1.926E-02,-1.072E-01,-1.944E-02,-2.770E-03,-5.200E-04,
14184 6-3.884E-02,-1.234E-02, 5.410E-02, 1.879E-02, 3.350E-03, 1.040E-03,
14185 1 2.948E+01,-3.902E+01, 1.464E+01,-3.335E+00, 5.054E-01,-5.915E-02,
14186 2 2.559E+01,-3.955E+01, 1.661E+01,-4.299E+00, 6.904E-01,-8.243E-02,
14187 3-1.663E+00, 1.176E+00, 1.118E+00,-7.099E-01, 1.948E-01,-2.404E-02,
14188 4-2.168E-01, 8.170E-01,-7.169E-01, 1.851E-01,-1.924E-02,-3.250E-03,
14189 5 2.088E-01,-4.355E-01, 2.239E-01,-2.446E-02,-3.620E-03, 1.910E-03,
14190 6-9.097E-02, 1.601E-01,-5.681E-02,-2.500E-03, 2.580E-03,-4.700E-04/
14191 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
14192 1 2.367E+00, 4.453E-01, 3.660E-01, 9.467E-02, 1.341E-01, 1.661E-02,
14193 2-3.170E+00,-1.795E+00, 3.313E-02,-2.874E-01,-9.827E-02,-7.119E-02,
14194 3 1.823E+00, 1.457E+00,-2.465E-01, 3.739E-02, 6.090E-03, 1.814E-02,
14195 4-1.033E+00,-9.827E-01, 2.136E-01, 1.169E-01, 5.001E-02, 1.684E-02,
14196 5 5.133E-01, 5.259E-01,-1.173E-01,-1.139E-01,-4.988E-02,-2.021E-02,
14197 6-2.881E-01,-3.145E-01, 5.667E-02, 9.161E-02, 4.568E-02, 1.951E-02,
14198 1 3.036E+01,-4.062E+01, 1.578E+01,-3.699E+00, 6.020E-01,-7.031E-02,
14199 2 2.700E+01,-4.167E+01, 1.770E+01,-4.804E+00, 7.862E-01,-1.060E-01,
14200 3-1.909E+00, 1.357E+00, 1.127E+00,-7.181E-01, 2.232E-01,-2.481E-02,
14201 4-2.488E-01, 9.781E-01,-8.127E-01, 2.094E-01,-2.997E-02,-4.710E-03,
14202 5 2.506E-01,-5.427E-01, 2.672E-01,-3.103E-02,-1.800E-03, 2.870E-03,
14203 6-1.128E-01, 2.087E-01,-6.972E-02,-2.480E-03, 2.630E-03,-8.400E-04/
14204C...Expansion coefficients for strange sea quark distribution.
14205 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
14206 1 4.968E-02,-4.173E-02, 2.102E-02,-3.270E-03, 3.240E-03,-6.700E-04,
14207 2-6.150E-03,-1.294E-02, 6.740E-03,-6.890E-03, 9.000E-04,-1.510E-03,
14208 3-8.580E-03, 5.050E-03,-4.900E-03,-1.600E-04,-9.400E-04,-1.500E-04,
14209 4 7.840E-03, 1.510E-03, 2.220E-03, 1.400E-03, 7.000E-04, 3.500E-04,
14210 5-4.410E-03,-2.220E-03,-8.900E-04,-8.500E-04,-3.600E-04,-2.000E-04,
14211 6 2.520E-03, 1.840E-03, 4.100E-04, 3.900E-04, 1.600E-04, 9.000E-05,
14212 1 9.235E-01,-1.085E+00, 3.464E-01,-7.210E-02, 9.140E-03,-9.100E-04,
14213 2 9.315E-01,-1.274E+00, 4.512E-01,-9.775E-02, 1.380E-02,-1.310E-03,
14214 3 4.739E-02,-1.296E-01, 8.482E-02,-2.642E-02, 4.760E-03,-5.700E-04,
14215 4-2.653E-02, 4.953E-02,-1.735E-02, 1.750E-03, 2.800E-04,-6.000E-05,
14216 5 6.940E-03,-1.132E-02, 1.480E-03, 6.500E-04,-2.100E-04, 0.000E+00,
14217 6-1.680E-03, 2.340E-03, 4.200E-04,-3.400E-04, 5.000E-05, 1.000E-05/
14218 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
14219 1 6.478E-02,-4.537E-02, 1.643E-02,-3.490E-03, 2.710E-03,-6.700E-04,
14220 2-2.223E-02,-2.126E-02, 1.247E-02,-6.290E-03, 1.120E-03,-1.440E-03,
14221 3-1.340E-03, 1.362E-02,-6.130E-03,-7.900E-04,-9.000E-04,-2.000E-04,
14222 4 5.080E-03,-3.610E-03, 1.700E-03, 1.830E-03, 6.800E-04, 4.000E-04,
14223 5-3.580E-03, 6.000E-05,-2.600E-04,-1.050E-03,-3.800E-04,-2.300E-04,
14224 6 2.420E-03, 9.300E-04,-1.000E-04, 4.500E-04, 1.700E-04, 1.100E-04,
14225 1 9.868E-01,-1.171E+00, 3.940E-01,-8.459E-02, 1.124E-02,-1.250E-03,
14226 2 1.001E+00,-1.383E+00, 5.044E-01,-1.152E-01, 1.658E-02,-1.830E-03,
14227 3 4.928E-02,-1.368E-01, 9.021E-02,-2.935E-02, 5.800E-03,-6.600E-04,
14228 4-3.133E-02, 5.785E-02,-2.023E-02, 2.630E-03, 1.600E-04,-8.000E-05,
14229 5 8.840E-03,-1.416E-02, 1.900E-03, 5.800E-04,-2.500E-04, 1.000E-05,
14230 6-2.300E-03, 3.080E-03, 5.500E-04,-3.700E-04, 7.000E-05, 1.000E-05/
14231C...Expansion coefficients for charm sea quark distribution.
14232 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
14233 1 9.270E-03,-1.817E-02, 9.590E-03,-6.390E-03, 1.690E-03,-1.540E-03,
14234 2 5.710E-03,-1.188E-02, 6.090E-03,-4.650E-03, 1.240E-03,-1.310E-03,
14235 3-3.960E-03, 7.100E-03,-3.590E-03, 1.840E-03,-3.900E-04, 3.400E-04,
14236 4 1.120E-03,-1.960E-03, 1.120E-03,-4.800E-04, 1.000E-04,-4.000E-05,
14237 5 4.000E-05,-3.000E-05,-1.800E-04, 9.000E-05,-5.000E-05,-2.000E-05,
14238 6-4.200E-04, 7.300E-04,-1.600E-04, 5.000E-05, 5.000E-05, 5.000E-05,
14239 1 8.098E-01,-1.042E+00, 3.398E-01,-6.824E-02, 8.760E-03,-9.000E-04,
14240 2 8.961E-01,-1.217E+00, 4.339E-01,-9.287E-02, 1.304E-02,-1.290E-03,
14241 3 3.058E-02,-1.040E-01, 7.604E-02,-2.415E-02, 4.600E-03,-5.000E-04,
14242 4-2.451E-02, 4.432E-02,-1.651E-02, 1.430E-03, 1.200E-04,-1.000E-04,
14243 5 1.122E-02,-1.457E-02, 2.680E-03, 5.800E-04,-1.200E-04, 3.000E-05,
14244 6-7.730E-03, 7.330E-03,-7.600E-04,-2.400E-04, 1.000E-05, 0.000E+00/
14245 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
14246 1 9.980E-03,-1.945E-02, 1.055E-02,-6.870E-03, 1.860E-03,-1.560E-03,
14247 2 5.700E-03,-1.203E-02, 6.250E-03,-4.860E-03, 1.310E-03,-1.370E-03,
14248 3-4.490E-03, 7.990E-03,-4.170E-03, 2.050E-03,-4.400E-04, 3.300E-04,
14249 4 1.470E-03,-2.480E-03, 1.460E-03,-5.700E-04, 1.200E-04,-1.000E-05,
14250 5-9.000E-05, 1.500E-04,-3.200E-04, 1.200E-04,-6.000E-05,-4.000E-05,
14251 6-4.200E-04, 7.600E-04,-1.400E-04, 4.000E-05, 7.000E-05, 5.000E-05,
14252 1 8.698E-01,-1.131E+00, 3.836E-01,-8.111E-02, 1.048E-02,-1.300E-03,
14253 2 9.626E-01,-1.321E+00, 4.854E-01,-1.091E-01, 1.583E-02,-1.700E-03,
14254 3 3.057E-02,-1.088E-01, 8.022E-02,-2.676E-02, 5.590E-03,-5.600E-04,
14255 4-2.845E-02, 5.164E-02,-1.918E-02, 2.210E-03,-4.000E-05,-1.500E-04,
14256 5 1.311E-02,-1.751E-02, 3.310E-03, 5.100E-04,-1.200E-04, 5.000E-05,
14257 6-8.590E-03, 8.380E-03,-9.200E-04,-2.600E-04, 1.000E-05,-1.000E-05/
14258C...Expansion coefficients for bottom sea quark distribution.
14259 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
14260 1 9.010E-03,-1.401E-02, 7.150E-03,-4.130E-03, 1.260E-03,-1.040E-03,
14261 2 6.280E-03,-9.320E-03, 4.780E-03,-2.890E-03, 9.100E-04,-8.200E-04,
14262 3-2.930E-03, 4.090E-03,-1.890E-03, 7.600E-04,-2.300E-04, 1.400E-04,
14263 4 3.900E-04,-1.200E-03, 4.400E-04,-2.500E-04, 2.000E-05,-2.000E-05,
14264 5 2.600E-04, 1.400E-04,-8.000E-05, 1.000E-04, 1.000E-05, 1.000E-05,
14265 6-2.600E-04, 3.200E-04, 1.000E-05,-1.000E-05, 1.000E-05,-1.000E-05,
14266 1 8.029E-01,-1.075E+00, 3.792E-01,-7.843E-02, 1.007E-02,-1.090E-03,
14267 2 7.903E-01,-1.099E+00, 4.153E-01,-9.301E-02, 1.317E-02,-1.410E-03,
14268 3-1.704E-02,-1.130E-02, 2.882E-02,-1.341E-02, 3.040E-03,-3.600E-04,
14269 4-7.200E-04, 7.230E-03,-5.160E-03, 1.080E-03,-5.000E-05,-4.000E-05,
14270 5 3.050E-03,-4.610E-03, 1.660E-03,-1.300E-04,-1.000E-05, 1.000E-05,
14271 6-4.360E-03, 5.230E-03,-1.610E-03, 2.000E-04,-2.000E-05, 0.000E+00/
14272 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
14273 1 8.980E-03,-1.459E-02, 7.510E-03,-4.410E-03, 1.310E-03,-1.070E-03,
14274 2 5.970E-03,-9.440E-03, 4.800E-03,-3.020E-03, 9.100E-04,-8.500E-04,
14275 3-3.050E-03, 4.440E-03,-2.100E-03, 8.500E-04,-2.400E-04, 1.400E-04,
14276 4 5.300E-04,-1.300E-03, 5.600E-04,-2.700E-04, 3.000E-05,-2.000E-05,
14277 5 2.000E-04, 1.400E-04,-1.100E-04, 1.000E-04, 0.000E+00, 0.000E+00,
14278 6-2.600E-04, 3.200E-04, 0.000E+00,-3.000E-05, 1.000E-05,-1.000E-05,
14279 1 8.672E-01,-1.174E+00, 4.265E-01,-9.252E-02, 1.244E-02,-1.460E-03,
14280 2 8.500E-01,-1.194E+00, 4.630E-01,-1.083E-01, 1.614E-02,-1.830E-03,
14281 3-2.241E-02,-5.630E-03, 2.815E-02,-1.425E-02, 3.520E-03,-4.300E-04,
14282 4-7.300E-04, 8.030E-03,-5.780E-03, 1.380E-03,-1.300E-04,-4.000E-05,
14283 5 3.460E-03,-5.380E-03, 1.960E-03,-2.100E-04, 1.000E-05, 1.000E-05,
14284 6-4.850E-03, 5.950E-03,-1.890E-03, 2.600E-04,-3.000E-05, 0.000E+00/
14285C...Expansion coefficients for top sea quark distribution.
14286 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
14287 1 4.410E-03,-7.480E-03, 3.770E-03,-2.580E-03, 7.300E-04,-7.100E-04,
14288 2 3.840E-03,-6.050E-03, 3.030E-03,-2.030E-03, 5.800E-04,-5.900E-04,
14289 3-8.800E-04, 1.660E-03,-7.500E-04, 4.700E-04,-1.000E-04, 1.000E-04,
14290 4-8.000E-05,-1.500E-04, 1.200E-04,-9.000E-05, 3.000E-05, 0.000E+00,
14291 5 1.300E-04,-2.200E-04,-2.000E-05,-2.000E-05,-2.000E-05,-2.000E-05,
14292 6-7.000E-05, 1.900E-04,-4.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
14293 1 6.623E-01,-9.248E-01, 3.519E-01,-7.930E-02, 1.110E-02,-1.180E-03,
14294 2 6.380E-01,-9.062E-01, 3.582E-01,-8.479E-02, 1.265E-02,-1.390E-03,
14295 3-2.581E-02, 2.125E-02, 4.190E-03,-4.980E-03, 1.490E-03,-2.100E-04,
14296 4 7.100E-04, 5.300E-04,-1.270E-03, 3.900E-04,-5.000E-05,-1.000E-05,
14297 5 3.850E-03,-5.060E-03, 1.860E-03,-3.500E-04, 4.000E-05, 0.000E+00,
14298 6-3.530E-03, 4.460E-03,-1.500E-03, 2.700E-04,-3.000E-05, 0.000E+00/
14299 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
14300 1 4.260E-03,-7.530E-03, 3.830E-03,-2.680E-03, 7.600E-04,-7.300E-04,
14301 2 3.640E-03,-6.050E-03, 3.030E-03,-2.090E-03, 5.900E-04,-6.000E-04,
14302 3-9.200E-04, 1.710E-03,-8.200E-04, 5.000E-04,-1.200E-04, 1.000E-04,
14303 4-5.000E-05,-1.600E-04, 1.300E-04,-9.000E-05, 3.000E-05, 0.000E+00,
14304 5 1.300E-04,-2.100E-04,-1.000E-05,-2.000E-05,-2.000E-05,-1.000E-05,
14305 6-8.000E-05, 1.800E-04,-5.000E-05, 2.000E-05, 0.000E+00, 0.000E+00,
14306 1 7.146E-01,-1.007E+00, 3.932E-01,-9.246E-02, 1.366E-02,-1.540E-03,
14307 2 6.856E-01,-9.828E-01, 3.977E-01,-9.795E-02, 1.540E-02,-1.790E-03,
14308 3-3.053E-02, 2.758E-02, 2.150E-03,-4.880E-03, 1.640E-03,-2.500E-04,
14309 4 9.200E-04, 4.200E-04,-1.340E-03, 4.600E-04,-8.000E-05,-1.000E-05,
14310 5 4.230E-03,-5.660E-03, 2.140E-03,-4.300E-04, 6.000E-05, 0.000E+00,
14311 6-3.890E-03, 5.000E-03,-1.740E-03, 3.300E-04,-4.000E-05, 0.000E+00/
14312
14313C...The following data lines are coefficients needed in the
14314C...Duke, Owens proton structure function parametrizations, see below.
14315C...Expansion coefficients for (up+down) valence quark distribution.
14316 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
14317 1 4.190E-01, 3.460E+00, 4.400E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14318 2 4.000E-03, 7.240E-01,-4.860E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14319 3-7.000E-03,-6.600E-02, 1.330E+00, 0.000E+00, 0.000E+00, 0.000E+00/
14320 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
14321 1 3.740E-01, 3.330E+00, 6.030E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14322 2 1.400E-02, 7.530E-01,-6.220E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14323 3 0.000E+00,-7.600E-02, 1.560E+00, 0.000E+00, 0.000E+00, 0.000E+00/
14324C...Expansion coefficients for down valence quark distribution.
14325 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
14326 1 7.630E-01, 4.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14327 2-2.370E-01, 6.270E-01,-4.210E-01, 0.000E+00, 0.000E+00, 0.000E+00,
14328 3 2.600E-02,-1.900E-02, 3.300E-02, 0.000E+00, 0.000E+00, 0.000E+00/
14329 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
14330 1 7.610E-01, 3.830E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14331 2-2.320E-01, 6.270E-01,-4.180E-01, 0.000E+00, 0.000E+00, 0.000E+00,
14332 3 2.300E-02,-1.900E-02, 3.600E-02, 0.000E+00, 0.000E+00, 0.000E+00/
14333C...Expansion coefficients for (up+down+strange) sea quark distribution.
14334 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
14335 1 1.265E+00, 0.000E+00, 8.050E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14336 2-1.132E+00,-3.720E-01, 1.590E+00, 6.310E+00,-1.050E+01, 1.470E+01,
14337 3 2.930E-01,-2.900E-02,-1.530E-01,-2.730E-01,-3.170E+00, 9.800E+00/
14338 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
14339 1 1.670E+00, 0.000E+00, 9.150E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14340 2-1.920E+00,-2.730E-01, 5.300E-01, 1.570E+01,-1.010E+02, 2.230E+02,
14341 3 5.820E-01,-1.640E-01,-7.630E-01,-2.830E+00, 4.470E+01,-1.170E+02/
14342C...Expansion coefficients for charm sea quark distribution.
14343 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
14344 1 0.000E+00,-3.600E-02, 6.350E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14345 2 1.350E-01,-2.220E-01, 3.260E+00,-3.030E+00, 1.740E+01,-1.790E+01,
14346 3-7.500E-02,-5.800E-02,-9.090E-01, 1.500E+00,-1.130E+01, 1.560E+01/
14347 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
14348 1 0.000E+00,-1.200E-01, 3.510E+00, 0.000E+00, 0.000E+00, 0.000E+00,
14349 2 6.700E-02,-2.330E-01, 3.660E+00,-4.740E-01, 9.500E+00,-1.660E+01,
14350 3-3.100E-02,-2.300E-02,-4.530E-01, 3.580E-01,-5.430E+00, 1.550E+01/
14351C...Expansion coefficients for gluon distribution.
14352 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
14353 1 1.560E+00, 0.000E+00, 6.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
14354 2-1.710E+00,-9.490E-01, 1.440E+00,-7.190E+00,-1.650E+01, 1.530E+01,
14355 3 6.380E-01, 3.250E-01,-1.050E+00, 2.550E-01, 1.090E+01,-1.010E+01/
14356 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
14357 1 8.790E-01, 0.000E+00, 4.000E+00, 9.000E+00, 0.000E+00, 0.000E+00,
14358 2-9.710E-01,-1.160E+00, 1.230E+00,-5.640E+00,-7.540E+00,-5.960E-01,
14359 3 4.340E-01, 4.760E-01,-2.540E-01,-8.170E-01, 5.500E+00, 1.260E-01/
14360
14361C...The following data lines are coefficients needed in the
14362C...Owens pion structure function parametrizations, see below.
14363C...Expansion coefficients for up and down valence quark distributions.
14364 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
14365 1 4.0000E-01, 7.0000E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00,
14366 2 -6.2120E-02, 6.4780E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00,
14367 3 -7.1090E-03, 1.3350E-02, 0.0000E+00, 0.0000E+00, 0.0000E+00/
14368 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
14369 1 4.0000E-01, 6.2800E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00,
14370 2 -5.9090E-02, 6.4360E-01, 0.0000E+00, 0.0000E+00, 0.0000E+00,
14371 3 -6.5240E-03, 1.4510E-02, 0.0000E+00, 0.0000E+00, 0.0000E+00/
14372C...Expansion coefficients for gluon distribution.
14373 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
14374 1 8.8800E-01, 0.0000E+00, 3.1100E+00, 6.0000E+00, 0.0000E+00,
14375 2 -1.8020E+00, -1.5760E+00, -1.3170E-01, 2.8010E+00, -1.7280E+01,
14376 3 1.8120E+00, 1.2000E+00, 5.0680E-01, -1.2160E+01, 2.0490E+01/
14377 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
14378 1 7.9400E-01, 0.0000E+00, 2.8900E+00, 6.0000E+00, 0.0000E+00,
14379 2 -9.1440E-01, -1.2370E+00, 5.9660E-01, -3.6710E+00, -8.1910E+00,
14380 3 5.9660E-01, 6.5820E-01, -2.5500E-01, -2.3040E+00, 7.7580E+00/
14381C...Expansion coefficients for (up+down+strange) quark sea distribution.
14382 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
14383 1 9.0000E-01, 0.0000E+00, 5.0000E+00, 0.0000E+00, 0.0000E+00,
14384 2 -2.4280E-01, -2.1200E-01, 8.6730E-01, 1.2660E+00, 2.3820E+00,
14385 3 1.3860E-01, 3.6710E-03, 4.7470E-02, -2.2150E+00, 3.4820E-01/
14386 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
14387 1 9.0000E-01, 0.0000E+00, 5.0000E+00, 0.0000E+00, 0.0000E+00,
14388 2 -1.4170E-01, -1.6970E-01, -2.4740E+00, -2.5340E+00, 5.6210E-01,
14389 3 -1.7400E-01, -9.6230E-02, 1.5750E+00, 1.3780E+00, -2.7010E-01/
14390C...Expansion coefficients for charm quark sea distribution.
14391 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
14392 1 0.0000E+00, -2.2120E-02, 2.8940E+00, 0.0000E+00, 0.0000E+00,
14393 2 7.9280E-02, -3.7850E-01, 9.4330E+00, 5.2480E+00, 8.3880E+00,
14394 3 -6.1340E-02, -1.0880E-01, -1.0852E+01, -7.1870E+00, -1.1610E+01/
14395 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
14396 1 0.0000E+00, -8.8200E-02, 1.9240E+00, 0.0000E+00, 0.0000E+00,
14397 2 6.2290E-02, -2.8920E-01, 2.4240E-01, -4.4630E+00, -8.3670E-01,
14398 3 -4.0990E-02, -1.0820E-01, 2.0360E+00, 5.2090E+00, -4.8400E-02/
14399
14400C...Euler's beta function, requires ordinary Gamma function
ce320da8 14401clin-10/25/02 get rid of argument usage mismatch in PYGAMMA():
14402c EULBT(X,Y)=PYGAMMA(X)*PYGAMMA(Y)/PYGAMMA(X+Y)
0119ef9a 14403
14404 vx=0.
14405 bbr2=0.
14406
14407C...Reset structure functions, check x and hadron flavour.
14408 ALAM=0.
14409 DO 100 KFL=-6,6
14410 100 XPQ(KFL)=0.
14411 IF(X.LT.0..OR.X.GT.1.) THEN
14412 WRITE(MSTU(11),1000) X
14413 RETURN
14414 ENDIF
14415 KFA=IABS(KF)
14416 IF(KFA.NE.211.AND.KFA.NE.2212.AND.KFA.NE.2112) THEN
14417 WRITE(MSTU(11),1100) KF
14418 RETURN
14419 ENDIF
14420
14421C...Call user-supplied structure function. Select proton/neutron/pion.
14422 IF(MSTP(51).EQ.0.OR.MSTP(52).GE.2) THEN
14423 KFE=KFA
14424 IF(KFA.EQ.2112) KFE=2212
14425 CALL PYSTFE(KFE,X,Q2,XPQ)
14426 GOTO 230
14427 ENDIF
14428 IF(KFA.EQ.211) GOTO 200
14429
14430 IF(MSTP(51).EQ.1.OR.MSTP(51).EQ.2) THEN
14431C...Proton structure functions from Eichten, Hinchliffe, Lane, Quigg.
14432C...Allowed variable range: 5 GeV2 < Q2 < 1E8 GeV2; 1E-4 < x < 1
14433
14434C...Determine set, Lamdba and x and t expansion variables.
14435 NSET=MSTP(51)
14436 IF(NSET.EQ.1) ALAM=0.2
14437 IF(NSET.EQ.2) ALAM=0.29
14438 TMIN=LOG(5./ALAM**2)
14439 TMAX=LOG(1E8/ALAM**2)
14440 IF(MSTP(52).EQ.0) THEN
14441 T=TMIN
14442 ELSE
14443 T=LOG(Q2/ALAM**2)
14444 ENDIF
14445 VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
14446 NX=1
14447 IF(X.LE.0.1) NX=2
14448 IF(NX.EQ.1) VX=(2.*X-1.1)/0.9
14449 IF(NX.EQ.2) VX=MAX(-1.,(2.*LOG(X)+11.51293)/6.90776)
14450 CXS=1.
14451 IF(X.LT.1E-4.AND.ABS(PARP(51)-1.).GT.0.01) CXS=
14452 & (1E-4/X)**(PARP(51)-1.)
14453
14454C...Chebyshev polynomials for x and t expansion.
14455 TX(1)=1.
14456 TX(2)=VX
14457 TX(3)=2.*VX**2-1.
14458 TX(4)=4.*VX**3-3.*VX
14459 TX(5)=8.*VX**4-8.*VX**2+1.
14460 TX(6)=16.*VX**5-20.*VX**3+5.*VX
14461 TT(1)=1.
14462 TT(2)=VT
14463 TT(3)=2.*VT**2-1.
14464 TT(4)=4.*VT**3-3.*VT
14465 TT(5)=8.*VT**4-8.*VT**2+1.
14466 TT(6)=16.*VT**5-20.*VT**3+5.*VT
14467
14468C...Calculate structure functions.
14469 DO 120 KFL=1,6
14470 XQSUM=0.
14471 DO 110 IT=1,6
14472 DO 110 IX=1,6
14473 110 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
14474 120 XQ(KFL)=XQSUM*(1.-X)**NEHLQ(KFL,NSET)*CXS
14475
14476C...Put into output array.
14477 XPQ(0)=XQ(4)
14478 XPQ(1)=XQ(2)+XQ(3)
14479 XPQ(2)=XQ(1)+XQ(3)
14480 XPQ(3)=XQ(5)
14481 XPQ(4)=XQ(6)
14482 XPQ(-1)=XQ(3)
14483 XPQ(-2)=XQ(3)
14484 XPQ(-3)=XQ(5)
14485 XPQ(-4)=XQ(6)
14486
14487C...Special expansion for bottom (thresh effects).
14488 IF(MSTP(54).GE.5) THEN
14489 IF(NSET.EQ.1) TMIN=8.1905
14490 IF(NSET.EQ.2) TMIN=7.4474
14491 IF(T.LE.TMIN) GOTO 140
14492 VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
14493 TT(1)=1.
14494 TT(2)=VT
14495 TT(3)=2.*VT**2-1.
14496 TT(4)=4.*VT**3-3.*VT
14497 TT(5)=8.*VT**4-8.*VT**2+1.
14498 TT(6)=16.*VT**5-20.*VT**3+5.*VT
14499 XQSUM=0.
14500 DO 130 IT=1,6
14501 DO 130 IX=1,6
14502 130 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
14503 XPQ(5)=XQSUM*(1.-X)**NEHLQ(7,NSET)
14504 XPQ(-5)=XPQ(5)
14505 140 CONTINUE
14506 ENDIF
14507
14508C...Special expansion for top (thresh effects).
14509 IF(MSTP(54).GE.6) THEN
14510 IF(NSET.EQ.1) TMIN=11.5528
14511 IF(NSET.EQ.2) TMIN=10.8097
14512 TMIN=TMIN+2.*LOG(PMAS(6,1)/30.)
14513 TMAX=TMAX+2.*LOG(PMAS(6,1)/30.)
14514 IF(T.LE.TMIN) GOTO 160
14515 VT=MAX(-1.,MIN(1.,(2.*T-TMAX-TMIN)/(TMAX-TMIN)))
14516 TT(1)=1.
14517 TT(2)=VT
14518 TT(3)=2.*VT**2-1.
14519 TT(4)=4.*VT**3-3.*VT
14520 TT(5)=8.*VT**4-8.*VT**2+1.
14521 TT(6)=16.*VT**5-20.*VT**3+5.*VT
14522 XQSUM=0.
14523 DO 150 IT=1,6
14524 DO 150 IX=1,6
14525 150 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
14526 XPQ(6)=XQSUM*(1.-X)**NEHLQ(8,NSET)
14527 XPQ(-6)=XPQ(6)
14528 160 CONTINUE
14529 ENDIF
14530
14531 ELSEIF(MSTP(51).EQ.3.OR.MSTP(51).EQ.4) THEN
14532C...Proton structure functions from Duke, Owens.
14533C...Allowed variable range: 4 GeV2 < Q2 < approx 1E6 GeV2.
14534
14535C...Determine set, Lambda and s expansion parameter.
14536 NSET=MSTP(51)-2
14537 IF(NSET.EQ.1) ALAM=0.2
14538 IF(NSET.EQ.2) ALAM=0.4
14539 IF(MSTP(52).LE.0) THEN
14540 SD=0.
14541 ELSE
14542 SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))
14543 ENDIF
14544
14545C...Calculate structure functions.
14546 DO 180 KFL=1,5
14547 DO 170 IS=1,6
14548 170 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
14549 & CDO(3,IS,KFL,NSET)*SD**2
14550 IF(KFL.LE.2) THEN
14551
14552clin-10/25/02 evaluate EULBT(TS(1),TS(2)+1.):
14553c XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBT(TS(1),
14554c & TS(2)+1.)*(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))
ce320da8 14555 eulbt1=PYGAMMA(TS(1))*PYGAMMA(TS(2)+1.)/
14556 & PYGAMMA(TS(1)+TS(2)+1.)
0119ef9a 14557 XQ(KFL)=X**TS(1)*(1.-X)**TS(2)*(1.+TS(3)*X)/(EULBT1
14558 & *(1.+TS(3)*TS(1)/(TS(1)+TS(2)+1.)))
14559 ELSE
14560 XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2+
14561 & TS(6)*X**3)
14562 ENDIF
14563
14564
14565 180 CONTINUE
14566
14567C...Put into output arrays.
14568 XPQ(0)=XQ(5)
14569 XPQ(1)=XQ(2)+XQ(3)/6.
14570 XPQ(2)=3.*XQ(1)-XQ(2)+XQ(3)/6.
14571 XPQ(3)=XQ(3)/6.
14572 XPQ(4)=XQ(4)
14573 XPQ(-1)=XQ(3)/6.
14574 XPQ(-2)=XQ(3)/6.
14575 XPQ(-3)=XQ(3)/6.
14576 XPQ(-4)=XQ(4)
14577
14578C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
14579C...These are accessed via PYSTFE since the files needed may not always
14580C...available.
14581 ELSEIF(MSTP(51).GE.11.AND.MSTP(51).LE.13) THEN
14582 CALL PYSTFE(2212,X,Q2,XPQ)
14583
14584C...Unknown proton parametrization.
14585 ELSE
14586 WRITE(MSTU(11),1200) MSTP(51)
14587 ENDIF
14588 GOTO 230
14589
14590 200 IF((MSTP(51).GE.1.AND.MSTP(51).LE.4).OR.
14591 &(MSTP(51).GE.11.AND.MSTP(51).LE.13)) THEN
14592C...Pion structure functions from Owens.
14593C...Allowed variable range: 4 GeV2 < Q2 < approx 2000 GeV2.
14594
14595C...Determine set, Lambda and s expansion variable.
14596 NSET=1
14597 IF(MSTP(51).EQ.2.OR.MSTP(51).EQ.4.OR.MSTP(51).EQ.13) NSET=2
14598 IF(NSET.EQ.1) ALAM=0.2
14599 IF(NSET.EQ.2) ALAM=0.4
14600 IF(MSTP(52).LE.0) THEN
14601 SD=0.
14602 ELSE
14603 SD=LOG(LOG(MAX(Q2,4.)/ALAM**2)/LOG(4./ALAM**2))
14604 ENDIF
14605
14606C...Calculate structure functions.
14607 DO 220 KFL=1,4
14608 DO 210 IS=1,5
14609 210 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
14610 & COW(3,IS,KFL,NSET)*SD**2
14611 IF(KFL.EQ.1) THEN
14612
ce320da8 14613clin-10/25/02 get rid of argument usage mismatch in PYGAMMA():
0119ef9a 14614c XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBT(TS(1),TS(2)+1.)
ce320da8 14615 eulbt2=PYGAMMA(TS(1))
14616 & *PYGAMMA(TS(2)+1.)/PYGAMMA(TS(1)+TS(2)+1.)
0119ef9a 14617 XQ(KFL)=X**TS(1)*(1.-X)**TS(2)/EULBT2
14618 ELSE
14619 XQ(KFL)=TS(1)*X**TS(2)*(1.-X)**TS(3)*(1.+TS(4)*X+TS(5)*X**2)
14620 ENDIF
14621 220 CONTINUE
14622
14623C...Put into output arrays.
14624 XPQ(0)=XQ(2)
14625 XPQ(1)=XQ(3)/6.
14626 XPQ(2)=XQ(1)+XQ(3)/6.
14627 XPQ(3)=XQ(3)/6.
14628 XPQ(4)=XQ(4)
14629 XPQ(-1)=XQ(1)+XQ(3)/6.
14630 XPQ(-2)=XQ(3)/6.
14631 XPQ(-3)=XQ(3)/6.
14632 XPQ(-4)=XQ(4)
14633
14634C...Unknown pion parametrization.
14635 ELSE
14636 WRITE(MSTU(11),1200) MSTP(51)
14637 ENDIF
14638
14639C...Isospin conjugation for neutron, charge conjugation for antipart.
14640 230 IF(KFA.EQ.2112) THEN
14641 XPS=XPQ(1)
14642 XPQ(1)=XPQ(2)
14643 XPQ(2)=XPS
14644 XPS=XPQ(-1)
14645 XPQ(-1)=XPQ(-2)
14646 XPQ(-2)=XPS
14647 ENDIF
14648 IF(KF.LT.0) THEN
14649 DO 240 KFL=1,4
14650 XPS=XPQ(KFL)
14651 XPQ(KFL)=XPQ(-KFL)
14652 240 XPQ(-KFL)=XPS
14653 ENDIF
14654
14655C...Check positivity and reset above maximum allowed flavour.
14656 DO 250 KFL=-6,6
14657 XPQ(KFL)=MAX(0.,XPQ(KFL))
14658 250 IF(IABS(KFL).GT.MSTP(54)) XPQ(KFL)=0.
14659
14660C...consider nuclear effect on the structure function
14661 IF((JBT.NE.1.AND.JBT.NE.2).OR.IHPR2(6).EQ.0
14662 & .OR.IHNT2(16).EQ.1) GO TO 400
14663 ATNM=IHNT2(2*JBT-1)
14664 IF(ATNM.LE.1.0) GO TO 400
14665 IF(JBT.EQ.1) THEN
14666 BBR2=(YP(1,IHNT2(11))**2+YP(2,IHNT2(11))**2)/1.44/
14667 1 ATNM**0.66666
14668 ELSEIF(JBT.EQ.2) THEN
14669 BBR2=(YT(1,IHNT2(12))**2+YT(2,IHNT2(12))**2)/1.44/
14670 1 ATNM**0.66666
14671 ENDIF
14672 BBR2=MIN(1.0,BBR2)
14673 ABX=(ATNM**0.33333333-1.0)
14674 APX=HIPR1(6)*4.0/3.0*ABX*SQRT(1.0-BBR2)
14675 AAX=1.192*ALOG(ATNM)**0.1666666
14676 RRX=AAX*(X**3-1.2*X**2+0.21*X)+1.0
14677 & -(APX-1.079*ABX*SQRT(X)/ALOG(ATNM+1.0))
14678 1 *EXP(-X**2.0/0.01)
14679 DO 300 KFL=-6,6
14680 XPQ(KFL)=XPQ(KFL)*RRX
14681300 CONTINUE
14682C ********consider the nuclear effect on the structure
14683C function which also depends on the impact
14684C parameter of the nuclear reaction
14685
14686 400 CONTINUE
14687C...Formats for error printouts.
14688 1000 FORMAT(' Error: x value outside physical range, x =',1P,E12.3)
14689 1100 FORMAT(' Error: illegal particle code for structure function,',
14690 &' KF =',I5)
14691 1200 FORMAT(' Error: bad value of parameter MSTP(51) in PYSTFU,',
14692 &' MSTP(51) =',I5)
14693
14694 RETURN
14695 END
14696
14697C*********************************************************************
14698
ce320da8 14699 SUBROUTINE PYSPLIA(KF,KFLIN,KFLCH,KFLSP)
0119ef9a 14700
14701C...In case of a hadron remnant which is more complicated than just a
14702C...quark or a diquark, split it into two (partons or hadron + parton).
14703 DIMENSION KFL(3)
14704
14705C...Preliminaries. Parton composition.
14706 KFA=IABS(KF)
14707 KFS=ISIGN(1,KF)
14708 KFL(1)=MOD(KFA/1000,10)
14709 KFL(2)=MOD(KFA/100,10)
14710 KFL(3)=MOD(KFA/10,10)
14711 KFLR=KFLIN*KFS
14712 KFLCH=0
14713
14714C...Subdivide meson.
14715 IF(KFL(1).EQ.0) THEN
14716 KFL(2)=KFL(2)*(-1)**KFL(2)
14717 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
14718 IF(KFLR.EQ.KFL(2)) THEN
14719 KFLSP=KFL(3)
14720 ELSEIF(KFLR.EQ.KFL(3)) THEN
14721 KFLSP=KFL(2)
14722 ELSEIF(IABS(KFLR).EQ.21.AND.RLU(0).GT.0.5) THEN
14723 KFLSP=KFL(2)
14724 KFLCH=KFL(3)
14725 ELSEIF(IABS(KFLR).EQ.21) THEN
14726 KFLSP=KFL(3)
14727 KFLCH=KFL(2)
14728 ELSEIF(KFLR*KFL(2).GT.0) THEN
14729 CALL LUKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
14730 KFLSP=KFL(3)
14731 ELSE
14732 CALL LUKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
14733 KFLSP=KFL(2)
14734 ENDIF
14735
14736C...Subdivide baryon.
14737 ELSE
14738 NAGR=0
14739 DO 100 J=1,3
14740 100 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
14741 IF(NAGR.GE.1) THEN
14742 RAGR=0.00001+(NAGR-0.00002)*RLU(0)
14743 IAGR=0
14744 DO 110 J=1,3
14745 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1.
14746 110 IF(IAGR.EQ.0.AND.RAGR.LE.0.) IAGR=J
14747 ELSE
14748 IAGR=int(1.00001+2.99998*RLU(0))
14749 ENDIF
14750 ID1=1
14751 IF(IAGR.EQ.1) ID1=2
14752 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
14753 ID2=6-IAGR-ID1
14754 KSP=3
14755 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
14756 IF(IAGR.NE.3.AND.RLU(0).GT.0.25) KSP=1
14757 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
14758 IF(IAGR.NE.1.AND.RLU(0).GT.0.25) KSP=1
14759 ELSEIF(MOD(KFA,10).EQ.2) THEN
14760 IF(IAGR.EQ.1) KSP=1
14761 IF(IAGR.NE.1.AND.RLU(0).GT.0.75) KSP=1
14762 ENDIF
14763 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
14764 IF(KFLIN.EQ.21) THEN
14765 KFLCH=KFL(IAGR)
14766 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
14767 CALL LUKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
14768 ELSEIF(NAGR.EQ.0) THEN
14769 CALL LUKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
14770 KFLSP=KFL(IAGR)
14771 ENDIF
14772 ENDIF
14773
14774C...Add on correct sign for result.
14775 KFLCH=KFLCH*KFS
14776 KFLSP=KFLSP*KFS
14777
14778 RETURN
14779 END
14780
14781C*********************************************************************
14782
ce320da8 14783 FUNCTION PYGAMMA(X)
0119ef9a 14784
14785C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
14786C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
14787C...(Dover, 1965) 6.1.36.
14788 DIMENSION B(8)
14789clin DATA B/-0.577191652,0.988205891,-0.897056937,0.918206857,
14790clin &-0.756704078,0.482199394,-0.193527818,0.035868343/
14791 DATA B/-0.57719165,0.98820589,-0.89705694,0.91820686,
14792 &-0.75670408,0.48219939,-0.19352782,0.03586834/
14793
14794 NX=INT(X)
14795 DX=X-NX
14796
ce320da8 14797 PYGAMMA=1.
0119ef9a 14798 DO 100 I=1,8
ce320da8 14799 100 PYGAMMA=PYGAMMA+B(I)*DX**I
0119ef9a 14800 IF(X.LT.1.) THEN
ce320da8 14801 PYGAMMA=PYGAMMA/X
0119ef9a 14802 ELSE
14803 DO 110 IX=1,NX-1
ce320da8 14804 110 PYGAMMA=(X-IX)*PYGAMMA
0119ef9a 14805 ENDIF
14806
14807 RETURN
14808 END
14809
14810C***********************************************************************
14811
14812 FUNCTION PYW1AU(EPS,IREIM)
14813
14814C...Calculates real and imaginary parts of the auxiliary function W1;
14815C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
14816C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
14817 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14818 SAVE /LUDAT1A/
14819
14820 ASINH(X)=LOG(X+SQRT(X**2+1.))
14821 ACOSH(X)=LOG(X+SQRT(X**2-1.))
14822
14823 pyw1au=0.
14824
14825 IF(EPS.LT.0.) THEN
14826 W1RE=2.*SQRT(1.-EPS)*ASINH(SQRT(-1./EPS))
14827 W1IM=0.
14828 ELSEIF(EPS.LT.1.) THEN
14829 W1RE=2.*SQRT(1.-EPS)*ACOSH(SQRT(1./EPS))
14830 W1IM=-PARU(1)*SQRT(1.-EPS)
14831 ELSE
14832 W1RE=2.*SQRT(EPS-1.)*ASIN(SQRT(1./EPS))
14833 W1IM=0.
14834 ENDIF
14835
14836 IF(IREIM.EQ.1) PYW1AU=W1RE
14837 IF(IREIM.EQ.2) PYW1AU=W1IM
14838
14839 RETURN
14840 END
14841
14842C***********************************************************************
14843
14844 FUNCTION PYW2AU(EPS,IREIM)
14845
14846C...Calculates real and imaginary parts of the auxiliary function W2;
14847C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
14848C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
14849 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14850 SAVE /LUDAT1A/
14851
14852 ASINH(X)=LOG(X+SQRT(X**2+1.))
14853 ACOSH(X)=LOG(X+SQRT(X**2-1.))
14854
14855 pyw2au=0.
14856
14857 IF(EPS.LT.0.) THEN
14858 W2RE=4.*(ASINH(SQRT(-1./EPS)))**2
14859 W2IM=0.
14860 ELSEIF(EPS.LT.1.) THEN
14861 W2RE=4.*(ACOSH(SQRT(1./EPS)))**2-PARU(1)**2
14862 W2IM=-4.*PARU(1)*ACOSH(SQRT(1./EPS))
14863 ELSE
14864 W2RE=-4.*(ASIN(SQRT(1./EPS)))**2
14865 W2IM=0.
14866 ENDIF
14867
14868 IF(IREIM.EQ.1) PYW2AU=W2RE
14869 IF(IREIM.EQ.2) PYW2AU=W2IM
14870
14871 RETURN
14872 END
14873
14874C***********************************************************************
14875
ce320da8 14876 FUNCTION PYI3AA(BE,EPS,IREIM)
0119ef9a 14877
14878C...Calculates real and imaginary parts of the auxiliary function I3;
14879C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
14880C...FERMILAB-Pub-87/100-T, LBL-23504, June, 1987
14881 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14882 SAVE /LUDAT1A/
14883
14884 pyi3au=0.
14885 ga=0.
14886
14887 IF(EPS.LT.1.) GA=0.5*(1.+SQRT(1.-EPS))
14888
14889 IF(EPS.LT.0.) THEN
ce320da8 14890 F3RE=PYSPEA((GA-1.)/(GA+BE-1.),0.,1)-PYSPEA(GA/(GA+BE-1.),0.,1)+
14891 & PYSPEA((BE-GA)/BE,0.,1)-PYSPEA((BE-GA)/(BE-1.),0.,1)+
0119ef9a 14892 & (LOG(BE)**2-LOG(BE-1.)**2)/2.+LOG(GA)*LOG((GA+BE-1.)/BE)+
14893 & LOG(GA-1.)*LOG((BE-1.)/(GA+BE-1.))
14894 F3IM=0.
14895 ELSEIF(EPS.LT.1.) THEN
ce320da8 14896 F3RE=PYSPEA((GA-1.)/(GA+BE-1.),0.,1)-PYSPEA(GA/(GA+BE-1.),0.,1)+
14897 & PYSPEA(GA/(GA-BE),0.,1)-PYSPEA((GA-1.)/(GA-BE),0.,1)+
0119ef9a 14898 & LOG(GA/(1.-GA))*LOG((GA+BE-1.)/(BE-GA))
14899 F3IM=-PARU(1)*LOG((GA+BE-1.)/(BE-GA))
14900 ELSE
14901 RSQ=EPS/(EPS-1.+(2.*BE-1.)**2)
14902 RCTHE=RSQ*(1.-2.*BE/EPS)
14903 RSTHE=SQRT(RSQ-RCTHE**2)
14904 RCPHI=RSQ*(1.+2.*(BE-1.)/EPS)
14905 RSPHI=SQRT(RSQ-RCPHI**2)
14906 R=SQRT(RSQ)
14907 THE=ACOS(RCTHE/R)
14908 PHI=ACOS(RCPHI/R)
ce320da8 14909 F3RE=PYSPEA(RCTHE,RSTHE,1)+PYSPEA(RCTHE,-RSTHE,1)-
14910 & PYSPEA(RCPHI,RSPHI,1)-PYSPEA(RCPHI,-RSPHI,1)+
0119ef9a 14911 & (PHI-THE)*(PHI+THE-PARU(1))
ce320da8 14912 F3IM=PYSPEA(RCTHE,RSTHE,2)+PYSPEA(RCTHE,-RSTHE,2)-
14913 & PYSPEA(RCPHI,RSPHI,2)-PYSPEA(RCPHI,-RSPHI,2)
0119ef9a 14914 ENDIF
14915
ce320da8 14916 IF(IREIM.EQ.1) PYI3AA=2./(2.*BE-1.)*F3RE
14917 IF(IREIM.EQ.2) PYI3AA=2./(2.*BE-1.)*F3IM
0119ef9a 14918
14919 RETURN
14920 END
14921
14922C***********************************************************************
14923
ce320da8 14924 FUNCTION PYSPEA(XREIN,XIMIN,IREIM)
0119ef9a 14925
14926C...Calculates real and imaginary part of Spence function; see
14927C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
14928 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14929 SAVE /LUDAT1A/
14930 DIMENSION B(0:14)
14931
14932 DATA B/
14933 & 1.000000E+00, -5.000000E-01, 1.666667E-01,
14934 & 0.000000E+00, -3.333333E-02, 0.000000E+00,
14935 & 2.380952E-02, 0.000000E+00, -3.333333E-02,
14936 & 0.000000E+00, 7.575757E-02, 0.000000E+00,
14937 &-2.531135E-01, 0.000000E+00, 1.166667E+00/
14938
ce320da8 14939 pyspea=0.
0119ef9a 14940
14941 XRE=XREIN
14942 XIM=XIMIN
14943 IF(ABS(1.-XRE).LT.1.E-6.AND.ABS(XIM).LT.1.E-6) THEN
ce320da8 14944 IF(IREIM.EQ.1) PYSPEA=PARU(1)**2/6.
14945 IF(IREIM.EQ.2) PYSPEA=0.
0119ef9a 14946 RETURN
14947 ENDIF
14948
14949 XMOD=SQRT(XRE**2+XIM**2)
14950 IF(XMOD.LT.1.E-6) THEN
ce320da8 14951 IF(IREIM.EQ.1) PYSPEA=0.
14952 IF(IREIM.EQ.2) PYSPEA=0.
0119ef9a 14953 RETURN
14954 ENDIF
14955
14956 XARG=SIGN(ACOS(XRE/XMOD),XIM)
14957 SP0RE=0.
14958 SP0IM=0.
14959 SGN=1.
14960 IF(XMOD.GT.1.) THEN
14961 ALGXRE=LOG(XMOD)
14962 ALGXIM=XARG-SIGN(PARU(1),XARG)
14963 SP0RE=-PARU(1)**2/6.-(ALGXRE**2-ALGXIM**2)/2.
14964 SP0IM=-ALGXRE*ALGXIM
14965 SGN=-1.
14966 XMOD=1./XMOD
14967 XARG=-XARG
14968 XRE=XMOD*COS(XARG)
14969 XIM=XMOD*SIN(XARG)
14970 ENDIF
14971 IF(XRE.GT.0.5) THEN
14972 ALGXRE=LOG(XMOD)
14973 ALGXIM=XARG
14974 XRE=1.-XRE
14975 XIM=-XIM
14976 XMOD=SQRT(XRE**2+XIM**2)
14977 XARG=SIGN(ACOS(XRE/XMOD),XIM)
14978 ALGYRE=LOG(XMOD)
14979 ALGYIM=XARG
14980 SP0RE=SP0RE+SGN*(PARU(1)**2/6.-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
14981 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
14982 SGN=-SGN
14983 ENDIF
14984
14985 XRE=1.-XRE
14986 XIM=-XIM
14987 XMOD=SQRT(XRE**2+XIM**2)
14988 XARG=SIGN(ACOS(XRE/XMOD),XIM)
14989 ZRE=-LOG(XMOD)
14990 ZIM=-XARG
14991
14992 SPRE=0.
14993 SPIM=0.
14994 SAVERE=1.
14995 SAVEIM=0.
14996 DO 100 I=0,14
14997 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/FLOAT(I+1)
14998 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/FLOAT(I+1)
14999 SAVERE=TERMRE
15000 SAVEIM=TERMIM
15001 SPRE=SPRE+B(I)*TERMRE
15002 100 SPIM=SPIM+B(I)*TERMIM
15003
ce320da8 15004 IF(IREIM.EQ.1) PYSPEA=SP0RE+SGN*SPRE
15005 IF(IREIM.EQ.2) PYSPEA=SP0IM+SGN*SPIM
0119ef9a 15006
15007 RETURN
15008 END
15009
15010C*********************************************************************
15011
15012 BLOCK DATA PYDATA
15013
15014C...Give sensible default values to all status codes and parameters.
15015 COMMON/PYSUBSA/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
15016 SAVE /PYSUBSA/
15017 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
15018 SAVE /PYPARSA/
15019 COMMON/PYINT1A/MINT(400),VINT(400)
15020 SAVE /PYINT1A/
15021 COMMON/PYINT2A/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
15022 SAVE /PYINT2A/
15023 COMMON/PYINT3A/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15024 SAVE /PYINT3A/
15025 COMMON/PYINT4AA/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
15026 SAVE /PYINT4AA/
15027 COMMON/PYINT5A/NGEN(0:200,3),XSEC(0:200,3)
15028 SAVE /PYINT5A/
15029 COMMON/PYINT6A/PROC(0:200)
15030 CHARACTER PROC*28
15031 SAVE /PYINT6A/
15032
15033C...Default values for allowed processes and kinematics constraints.
15034 DATA MSEL/1/
15035 DATA MSUB/200*0/
15036 DATA ((KFIN(I,J),J=-40,40),I=1,2)/40*1,0,80*1,0,40*1/
15037 DATA CKIN/
15038 & 2.0, -1.0, 0.0, -1.0, 1.0, 1.0, -10., 10., -10., 10.,
15039 1 -10., 10., -10., 10., -10., 10., -1.0, 1.0, -1.0, 1.0,
15040 2 0.0, 1.0, 0.0, 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0.,
15041 3 2.0, -1.0, 0., 0., 0., 0., 0., 0., 0., 0.,
15042 4 160*0./
15043
15044C...Default values for main switches and parameters. Reset information.
15045 DATA (MSTP(I),I=1,100)/
15046 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
15047 1 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15048 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15049 3 1, 2, 0, 0, 0, 2, 0, 0, 0, 0,
15050 4 1, 0, 3, 7, 1, 0, 0, 0, 0, 0,
15051 5 1, 1, 20, 6, 0, 0, 0, 0, 0, 0,
15052 6 1, 2, 2, 2, 1, 0, 0, 0, 0, 0,
15053 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15054 8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0,
15055 9 1, 4, 0, 0, 0, 0, 0, 0, 0, 0/
15056 DATA (MSTP(I),I=101,200)/
15057 & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15058 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
15059 2 0, 1, 2, 1, 1, 20, 0, 0, 0, 0,
15060 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
15061 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15062 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15063 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15064 7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15065 8 5, 3, 1989, 11, 24, 0, 0, 0, 0, 0,
15066 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
15067 DATA (PARP(I),I=1,100)/
15068 & 0.25, 10., 0., 0., 0., 0., 0., 0., 0., 0.,
15069 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15070 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15071 3 1.5, 2.0, 0.075, 0., 0.2, 0., 0., 0., 0., 0.,
15072 4 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15073 5 1.0, 2.26, 1.E4, 1.E-4, 0., 0., 0., 0., 0., 0.,
15074 6 0.25, 1.0, 0.25, 1.0, 2.0, 1.E-3, 4.0, 0., 0., 0.,
15075 7 4.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15076 8 1.6, 1.85, 0.5, 0.2, 0.33, 0.66, 0.7, 0.5, 0., 0.,
15077 9 0.44, 0.44, 2.0, 1.0, 0., 3.0, 1.0, 0.75, 0., 0./
15078 DATA (PARP(I),I=101,200)/
15079 & -0.02, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15080 1 2.0, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15081 2 0.4, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15082 3 0.01, 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15083 4 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15084 5 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15085 6 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15086 7 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15087 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
15088 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./
15089 DATA MSTI/200*0/
15090 DATA PARI/200*0./
15091 DATA MINT/400*0/
15092 DATA VINT/400*0./
15093
15094C...Constants for the generation of the various processes.
15095 DATA (ISET(I),I=1,100)/
15096 & 1, 1, 1, -1, 3, -1, -1, 3, -2, -2,
15097 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
15098 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
15099 3 2, -1, -1, -1, -1, -1, -1, -1, -1, -1,
15100 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
15101 5 -1, -1, 2, -1, -1, -1, -1, -1, -1, -1,
15102 6 -1, -1, -1, -1, -1, -1, -1, 2, -1, -1,
15103 7 4, 4, 4, -1, -1, 4, 4, -1, -1, -2,
15104 8 2, 2, -2, -2, -2, -2, -2, -2, -2, -2,
15105 9 0, 0, 0, -1, 0, 5, -2, -2, -2, -2/
15106 DATA (ISET(I),I=101,200)/
15107 & -1, 1, -2, -2, -2, -2, -2, -2, -2, -2,
15108 1 2, 2, 2, 2, -1, -1, -1, -2, -2, -2,
15109 2 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15110 3 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15111 4 1, 1, 1, -2, -2, -2, -2, -2, -2, -2,
15112 5 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15113 6 2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15114 7 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15115 8 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
15116 9 -2, -2, -2, -2, -2, -2, -2, -2, -2, -2/
15117 DATA ((KFPR(I,J),J=1,2),I=1,50)/
15118 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
15119 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
15120 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
15121 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
15122 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
15123 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
15124 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
15125 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
15126 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
15127 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
15128 DATA ((KFPR(I,J),J=1,2),I=51,100)/
15129 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
15130 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15131 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15132 6 0, 0, 0, 0, 21, 21, 24, 24, 22, 24,
15133 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
15134 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 0,
15135 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15136 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15137 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15138 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
15139 DATA ((KFPR(I,J),J=1,2),I=101,150)/
15140 & 23, 0, 25, 0, 0, 0, 0, 0, 0, 0,
15141 & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15142 1 21, 25, 0, 25, 21, 25, 22, 22, 22, 23,
15143 1 23, 23, 24, 24, 0, 0, 0, 0, 0, 0,
15144 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15145 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15146 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15147 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15148 4 32, 0, 37, 0, 40, 0, 0, 0, 0, 0,
15149 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
15150 DATA ((KFPR(I,J),J=1,2),I=151,200)/
15151 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15152 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15153 6 0, 37, 0, 0, 0, 0, 0, 0, 0, 0,
15154 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15155 7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15156 7 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15157 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15158 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15159 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
15160 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
15161 DATA COEF/4000*0./
15162 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
15163 1 4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
15164 2 3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
15165 3 3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
15166 4 3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
15167 5 4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
15168 6 2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
15169 7 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
15170 8 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
15171 9 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
15172 & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
15173
15174C...Character constants: name of processes.
15175 DATA PROC(0)/ 'All included subprocesses '/
15176 DATA (PROC(I),I=1,20)/
15177 1'f + fb -> gamma*/Z0 ', 'f + fb'' -> W+/- ',
15178 2'f + fb -> H0 ', 'gamma + W+/- -> W+/- ',
15179 3'Z0 + Z0 -> H0 ', 'Z0 + W+/- -> W+/- ',
15180 4' ', 'W+ + W- -> H0 ',
15181 5' ', ' ',
15182 6'f + f'' -> f + f'' ','f + fb -> f'' + fb'' ',
15183 7'f + fb -> g + g ', 'f + fb -> g + gamma ',
15184 8'f + fb -> g + Z0 ', 'f + fb'' -> g + W+/- ',
15185 9'f + fb -> g + H0 ', 'f + fb -> gamma + gamma ',
15186 &'f + fb -> gamma + Z0 ', 'f + fb'' -> gamma + W+/- '/
15187 DATA (PROC(I),I=21,40)/
15188 1'f + fb -> gamma + H0 ', 'f + fb -> Z0 + Z0 ',
15189 2'f + fb'' -> Z0 + W+/- ', 'f + fb -> Z0 + H0 ',
15190 3'f + fb -> W+ + W- ', 'f + fb'' -> W+/- + H0 ',
15191 4'f + fb -> H0 + H0 ', 'f + g -> f + g ',
15192 5'f + g -> f + gamma ', 'f + g -> f + Z0 ',
15193 6'f + g -> f'' + W+/- ', 'f + g -> f + H0 ',
15194 7'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
15195 8'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
15196 9'f + gamma -> f + H0 ', 'f + Z0 -> f + g ',
15197 &'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
15198 DATA (PROC(I),I=41,60)/
15199 1'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + H0 ',
15200 2'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
15201 3'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
15202 4'f + W+/- -> f'' + H0 ', 'f + H0 -> f + g ',
15203 5'f + H0 -> f + gamma ', 'f + H0 -> f + Z0 ',
15204 6'f + H0 -> f'' + W+/- ', 'f + H0 -> f + H0 ',
15205 7'g + g -> f + fb ', 'g + gamma -> f + fb ',
15206 8'g + Z0 -> f + fb ', 'g + W+/- -> f + fb'' ',
15207 9'g + H0 -> f + fb ', 'gamma + gamma -> f + fb ',
15208 &'gamma + Z0 -> f + fb ', 'gamma + W+/- -> f + fb'' '/
15209 DATA (PROC(I),I=61,80)/
15210 1'gamma + H0 -> f + fb ', 'Z0 + Z0 -> f + fb ',
15211 2'Z0 + W+/- -> f + fb'' ', 'Z0 + H0 -> f + fb ',
15212 3'W+ + W- -> f + fb ', 'W+/- + H0 -> f + fb'' ',
15213 4'H0 + H0 -> f + fb ', 'g + g -> g + g ',
15214 5'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> gamma + W+/-',
15215 6'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
15216 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + H0 ',
15217 8'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
15218 9'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + H0 -> W+/- + H0 ',
15219 &'H0 + H0 -> H0 + H0 ', ' '/
15220 DATA (PROC(I),I=81,100)/
15221 1'q + qb -> Q + QB, massive ', 'g + g -> Q + QB, massive ',
15222 2' ', ' ',
15223 3' ', ' ',
15224 4' ', ' ',
15225 5' ', ' ',
15226 6'Elastic scattering ', 'Single diffractive ',
15227 7'Double diffractive ', 'Central diffractive ',
15228 8'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
15229 9' ', ' ',
15230 &' ', ' '/
15231 DATA (PROC(I),I=101,120)/
15232 1'g + g -> gamma*/Z0 ', 'g + g -> H0 ',
15233 2' ', ' ',
15234 3' ', ' ',
15235 4' ', ' ',
15236 5' ', ' ',
15237 6'f + fb -> g + H0 ', 'q + g -> q + H0 ',
15238 7'g + g -> g + H0 ', 'g + g -> gamma + gamma ',
15239 8'g + g -> gamma + Z0 ', 'g + g -> Z0 + Z0 ',
15240 9'g + g -> W+ + W- ', ' ',
15241 &' ', ' '/
15242 DATA (PROC(I),I=121,140)/
15243 1'g + g -> f + fb + H0 ', ' ',
15244 2' ', ' ',
15245 3' ', ' ',
15246 4' ', ' ',
15247 5' ', ' ',
15248 6' ', ' ',
15249 7' ', ' ',
15250 8' ', ' ',
15251 9' ', ' ',
15252 &' ', ' '/
15253 DATA (PROC(I),I=141,160)/
15254 1'f + fb -> gamma*/Z0/Z''0 ', 'f + fb'' -> H+/- ',
15255 2'f + fb -> R ', ' ',
15256 3' ', ' ',
15257 4' ', ' ',
15258 5' ', ' ',
15259 6' ', ' ',
15260 7' ', ' ',
15261 8' ', ' ',
15262 9' ', ' ',
15263 &' ', ' '/
15264 DATA (PROC(I),I=161,180)/
15265 1'f + g -> f'' + H+/- ', ' ',
15266 2' ', ' ',
15267 3' ', ' ',
15268 4' ', ' ',
15269 5' ', ' ',
15270 6' ', ' ',
15271 7' ', ' ',
15272 8' ', ' ',
15273 9' ', ' ',
15274 &' ', ' '/
15275 DATA (PROC(I),I=181,200)/ 20*' '/
15276
15277 END
15278
15279C*********************************************************************
15280
ce320da8 15281 SUBROUTINE PYKCUTA(MCUT)
0119ef9a 15282
15283C...Dummy routine, which the user can replace in order to make cuts on
15284C...the kinematics on the parton level before the matrix elements are
15285C...evaluated and the event is generated. The cross-section estimates
15286C...will automatically take these cuts into account, so the given
15287C...values are for the allowed phase space region only. MCUT=0 means
15288C...that the event has passed the cuts, MCUT=1 that it has failed.
15289 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
15290 SAVE /PYPARSA/
15291
15292 MCUT=0
15293
15294 RETURN
15295 END
15296
15297C*********************************************************************
15298
15299 SUBROUTINE PYSTFE(KF,X,Q2,XPQ)
15300
15301C...This is a dummy routine, where the user can introduce an interface
15302C...to his own external structure function parametrization.
15303C...Arguments in:
15304C...KF : 2212 for p, 211 for pi+; isospin conjugation for n and charge
15305C... conjugation for pbar, nbar or pi- is performed by PYSTFU.
15306C...X : x value.
15307C...Q2 : Q^2 value.
15308C...Arguments out:
15309C...XPQ(-6:6) : x * f(x,Q2), with index according to KF code,
15310C... except that gluon is placed in 0. Thus XPQ(0) = xg,
15311C... XPQ(1) = xd, XPQ(-1) = xdbar, XPQ(2) = xu, XPQ(-2) = xubar,
15312C... XPQ(3) = xs, XPQ(-3) = xsbar, XPQ(4) = xc, XPQ(-4) = xcbar,
15313C... XPQ(5) = xb, XPQ(-5) = xbbar, XPQ(6) = xt, XPQ(-6) = xtbar.
15314C...
15315C...One such interface, to the Diemos, Ferroni, Longo, Martinelli
15316C...proton structure functions, already comes with the package. What
15317C...the user needs here is external files with the three routines
15318C...FXG160, FXG260 and FXG360 of the authors above, plus the
15319C...interpolation routine FINT, which is part of the CERN library
15320C...KERNLIB package. To avoid problems with unresolved external
15321C...references, the external calls are commented in the current
15322C...version. To enable this option, remove the C* at the beginning
15323C...of the relevant lines.
15324C...
15325C...Alternatively, the routine can be used as an interface to the
15326C...structure function evolution program of Tung. This can be achieved
15327C...by removing C* at the beginning of some of the lines below.
15328 COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15329 SAVE /LUDAT1A/
15330 COMMON/LUDAT2A/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
15331 SAVE /LUDAT2A/
15332 COMMON/PYPARSA/MSTP(200),PARP(200),MSTI(200),PARI(200)
15333 SAVE /PYPARSA/
15334 DIMENSION XPQ(-6:6),XFDFLM(9)
15335 CHARACTER CHDFLM(9)*5,HEADER*40
15336 DATA CHDFLM/'UPVAL','DOVAL','GLUON','QBAR ','UBAR ','SBAR ',
15337 &'CBAR ','BBAR ','TBAR '/
15338 DATA HEADER/'Tung evolution package has been invoked'/
15339 DATA INIT/0/
15340
15341 KF=KF
15342 HEADER=HEADER
15343 CHDFLM(1)=CHDFLM(1)
15344C...Proton structure functions from Diemoz, Ferroni, Longo, Martinelli.
15345C...Allowed variable range 10 GeV2 < Q2 < 1E8 GeV2, 5E-5 < x < .95.
15346 IF(MSTP(51).GE.11.AND.MSTP(51).LE.13.AND.MSTP(52).LE.1) THEN
15347 XDFLM=MAX(0.51E-4,X)
15348 Q2DFLM=MAX(10.,MIN(1E8,Q2))
15349 IF(MSTP(52).EQ.0) Q2DFLM=10.
15350 DO 100 J=1,9
15351 IF(MSTP(52).EQ.1.AND.J.EQ.9) THEN
15352 Q2DFLM=Q2DFLM*(40./PMAS(6,1))**2
15353 Q2DFLM=MAX(10.,MIN(1E8,Q2))
15354 ENDIF
15355 XFDFLM(J)=0.
15356C...Remove C* on following three lines to enable the DFLM options.
15357C* IF(MSTP(51).EQ.11) CALL FXG160(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
15358C* IF(MSTP(51).EQ.12) CALL FXG260(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
15359C* IF(MSTP(51).EQ.13) CALL FXG360(XDFLM,Q2DFLM,CHDFLM(J),XFDFLM(J))
15360 100 CONTINUE
15361 IF(X.LT.0.51E-4.AND.ABS(PARP(51)-1.).GT.0.01) THEN
15362 CXS=(0.51E-4/X)**(PARP(51)-1.)
15363 DO 110 J=1,7
15364 110 XFDFLM(J)=XFDFLM(J)*CXS
15365 ENDIF
15366 XPQ(0)=XFDFLM(3)
15367 XPQ(1)=XFDFLM(2)+XFDFLM(5)
15368 XPQ(2)=XFDFLM(1)+XFDFLM(5)
15369 XPQ(3)=XFDFLM(6)
15370 XPQ(4)=XFDFLM(7)
15371 XPQ(5)=XFDFLM(8)
15372 XPQ(6)=XFDFLM(9)
15373 XPQ(-1)=XFDFLM(5)
15374 XPQ(-2)=XFDFLM(5)
15375 XPQ(-3)=XFDFLM(6)
15376 XPQ(-4)=XFDFLM(7)
15377 XPQ(-5)=XFDFLM(8)
15378 XPQ(-6)=XFDFLM(9)
15379
15380C...Proton structure function evolution from Wu-Ki Tung: parton
15381C...distribution functions incorporating heavy quark mass effects.
15382C...Allowed variable range: PARP(52) < Q < PARP(53); PARP(54) < x < 1.
15383 ELSE
15384 IF(INIT.EQ.0) THEN
15385 I1=0
15386 IF(MSTP(52).EQ.4) I1=1
15387 IHDRN=1
15388 NU=MSTP(53)
15389 I2=MSTP(51)
15390 IF(MSTP(51).GE.11) I2=MSTP(51)-3
15391 I3=0
15392 IF(MSTP(52).EQ.3) I3=1
15393
15394C...Convert to Lambda in CWZ scheme (approximately linear relation).
15395 ALAM=0.75*PARP(1)
15396 TPMS=PMAS(6,1)
15397 QINI=PARP(52)
15398 QMAX=PARP(53)
15399 XMIN=PARP(54)
15400
15401C...Initialize evolution (perform calculation or read results from
15402C...file).
15403C...Remove C* on following two lines to enable Tung initialization.
15404C* CALL PDFSET(I1,IHDRN,ALAM,TPMS,QINI,QMAX,XMIN,NU,HEADER,
15405C* & I2,I3,IRET,IRR)
15406 INIT=1
15407 ENDIF
15408
15409C...Put into output array.
15410 Q=SQRT(Q2)
15411 DO 200 I=-6,6
15412 FIXQ=0.
15413C...Remove C* on following line to enable structure function call.
15414C* FIXQ=MAX(0.,PDF(10,1,I,X,Q,IR))
15415 200 XPQ(I)=X*FIXQ
15416
15417C...Change order of u and d quarks from Tung to PYTHIA convention.
15418 XPS=XPQ(1)
15419 XPQ(1)=XPQ(2)
15420 XPQ(2)=XPS
15421 XPS=XPQ(-1)
15422 XPQ(-1)=XPQ(-2)
15423 XPQ(-2)=XPS
15424 ENDIF
15425
15426 RETURN
15427 END
15428