]> git.uio.no Git - u/mrichter/AliRoot.git/blame - TEvtGen/EvtGenModels/jetset7410CDF.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
If default parameters are allowed and runNumber is provided, search first for the...
[u/mrichter/AliRoot.git] / TEvtGen / EvtGenModels / jetset7410CDF.F
CommitLineData
da0e9ce3 1C*********************************************************************
2C* This version of Jetset 7.4 was altered by
3C*
4C* Frank Wuerthwein (fkw@fnal.gov) 3/22/00
5C*
6C* to be compatible with Pythia 6.115 .
7C* Changes are in LYGIVE to adjust common blocks to PYTHIA 6.115
8C* This involves array sizes, double precision, and some rearrangement
9C* of common block content for the common blocks:
10C* PYSUBS, PYPARS, PYINT1,2,3,4,5,6,7
11C* LYLOGO is only affected by the switch to DOUBLE PRECISION.
12C*
13C* The switch to double precission is implemented such that only the
14C* REAL 's in PYxxxx commons are explicitly defined as DOUPLE PRECISION.
15C* All of Jetset remains REAL rather than DOUBLE PRECISION .
16C*
17C* WARNING
18C*
19C* All common blocks and symbol names were renamed to avoid possible
20C* conflicts with other instances of JETSET (J. Beringer, 4/6/2006).
21C*
22C*********************************************************************
23C* **
24C* December 1993 **
25C* **
26C* The Lund Monte Carlo for Jet Fragmentation and e+e- Physics **
27C* **
28C* JETSET version 7.4 **
29C* **
30C* Torbjorn Sjostrand **
31C* Department of theoretical physics 2 **
32C* University of Lund **
33C* Solvegatan 14A, S-223 62 Lund, Sweden **
34C* E-mail torbjorn@thep.lu.se **
35C* phone +46 - 46 - 222 48 16 **
36C* **
37C* LYSHOW is written together with Mats Bengtsson **
38C* **
39C* The latest program version and documentation is found on WWW **
40C* http://thep.lu.se/tf2/staff/torbjorn/Welcome.html **
41C* **
42C* Copyright Torbjorn Sjostrand and CERN, Geneva 1993 **
43C* **
44C*********************************************************************
45C*********************************************************************
46C *
47C List of subprograms in order of appearance, with main purpose *
48C (S = subroutine, F = function, B = block data) *
49C *
50C S LY1ENT to fill one entry (= parton or particle) *
51C S LY2ENT to fill two entries *
52C S LY3ENT to fill three entries *
53C S LY4ENT to fill four entries *
54C S LYJOIN to connect entries with colour flow information *
55C S LYGIVE to fill (or query) commonblock variables *
56C S LYEXEC to administrate fragmentation and decay chain *
57C S LYPREP to rearrange showered partons along strings *
58C S LYSTRF to do string fragmentation of jet system *
59C S LYINDF to do independent fragmentation of one or many jets *
60C S LYDECY to do the decay of a particle *
61C S LYKFDI to select parton and hadron flavours in fragm *
62C S LYPTDI to select transverse momenta in fragm *
63C S LYZDIS to select longitudinal scaling variable in fragm *
64C S LYSHOW to do timelike parton shower evolution *
65C S LYBOEI to include Bose-Einstein effects (crudely) *
66C F UYMASS to give the mass of a particle or parton *
67C S LYNAME to give the name of a particle or parton *
68C F LYCHGE to give three times the electric charge *
69C F LYCOMP to compress standard KF flavour code to internal KC *
70C S LYERRM to write error messages and abort faulty run *
71C F UYALEM to give the alpha_electromagnetic value *
72C F UYALPS to give the alpha_strong value *
73C F UYANGL to give the angle from known x and y components *
74C F RLY to provide a random number generator *
75C S RLYGET to save the state of the random number generator *
76C S RLYSET to set the state of the random number generator *
77C S LYROBO to rotate and/or boost an event *
78C S LYEDIT to remove unwanted entries from record *
79C S LYLIST to list event record or particle data *
80C S LYLOGO to write a logo for JETSET and PYTHIA *
81C S LYUPDA to update particle data *
82C F KLY to provide integer-valued event information *
83C F PLY to provide real-valued event information *
84C S LYSPHE to perform sphericity analysis *
85C S LYTHRU to perform thrust analysis *
86C S LYCLUS to perform three-dimensional cluster analysis *
87C S LYCELL to perform cluster analysis in (eta, phi, E_T) *
88C S LYJMAS to give high and low jet mass of event *
89C S LYFOWO to give Fox-Wolfram moments *
90C S LYTABU to analyze events, with tabular output *
91C *
92C S LYEEVT to administrate the generation of an e+e- event *
93C S LYXTOT to give the total cross-section at given CM energy *
94C S LYRADK to generate initial state photon radiation *
95C S LYXKFL to select flavour of primary qqbar pair *
96C S LYXJET to select (matrix element) jet multiplicity *
97C S LYX3JT to select kinematics of three-jet event *
98C S LYX4JT to select kinematics of four-jet event *
99C S LYXDIF to select angular orientation of event *
100C S LYONIA to perform generation of onium decay to gluons *
101C *
102C S LYHEPC to convert between /LYJETS/ and /XHEPEVT/ records *
103C S LYTEST to test the proper functioning of the package *
104C B LYDATA to contain default values and particle data *
105C *
106C*********************************************************************
107
108 SUBROUTINE LY1ENT(IP,KF,PE,THE,PHI)
109
110C...Purpose: to store one parton/particle in commonblock LUJETS.
111 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
112 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
113 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
114 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
115
116C...Standard checks.
117 MSTU(28)=0
118 IF(MSTU(12).GE.1) CALL LYLIST(0)
119 IPA=MAX(1,IABS(IP))
120 IF(IPA.GT.MSTU(4)) CALL LYERRM(21,
121 &'(LY1ENT:) writing outside LUJETS memory')
122 KC=LYCOMP(KF)
123 IF(KC.EQ.0) CALL LYERRM(12,'(LY1ENT:) unknown flavour code')
124
125C...Find mass. Reset K, P and V vectors.
126 PM=0.
127 IF(MSTU(10).EQ.1) PM=P(IPA,5)
128 IF(MSTU(10).GE.2) PM=UYMASS(KF)
129 DO 100 J=1,5
130 K(IPA,J)=0
131 P(IPA,J)=0.
132 V(IPA,J)=0.
133 100 CONTINUE
134
135C...Store parton/particle in K and P vectors.
136 K(IPA,1)=1
137 IF(IP.LT.0) K(IPA,1)=2
138 K(IPA,2)=KF
139 P(IPA,5)=PM
140 P(IPA,4)=MAX(PE,PM)
141 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
142 P(IPA,1)=PA*SIN(THE)*COS(PHI)
143 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
144 P(IPA,3)=PA*COS(THE)
145
146C...Set N. Optionally fragment/decay.
147 N=IPA
148 IF(IP.EQ.0) CALL LYEXEC
149
150 RETURN
151 END
152
153C*********************************************************************
154
155 SUBROUTINE LY2ENT(IP,KF1,KF2,PECM)
156
157C...Purpose: to store two partons/particles in their CM frame,
158C...with the first along the +z axis.
159 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
160 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
161 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
162 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
163
164C...Standard checks.
165 MSTU(28)=0
166 IF(MSTU(12).GE.1) CALL LYLIST(0)
167 IPA=MAX(1,IABS(IP))
168 IF(IPA.GT.MSTU(4)-1) CALL LYERRM(21,
169 &'(LY2ENT:) writing outside LUJETS memory')
170 KC1=LYCOMP(KF1)
171 KC2=LYCOMP(KF2)
172 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LYERRM(12,
173 &'(LY2ENT:) unknown flavour code')
174
175C...Find masses. Reset K, P and V vectors.
176 PM1=0.
177 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
178 IF(MSTU(10).GE.2) PM1=UYMASS(KF1)
179 PM2=0.
180 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
181 IF(MSTU(10).GE.2) PM2=UYMASS(KF2)
182 DO 110 I=IPA,IPA+1
183 DO 100 J=1,5
184 K(I,J)=0
185 P(I,J)=0.
186 V(I,J)=0.
187 100 CONTINUE
188 110 CONTINUE
189
190C...Check flavours.
191 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
192 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
193 IF(MSTU(19).EQ.1) THEN
194 MSTU(19)=0
195 ELSE
196 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LYERRM(2,
197 & '(LY2ENT:) unphysical flavour combination')
198 ENDIF
199 K(IPA,2)=KF1
200 K(IPA+1,2)=KF2
201
202C...Store partons/particles in K vectors for normal case.
203 IF(IP.GE.0) THEN
204 K(IPA,1)=1
205 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
206 K(IPA+1,1)=1
207
208C...Store partons in K vectors for parton shower evolution.
209 ELSE
210 K(IPA,1)=3
211 K(IPA+1,1)=3
212 K(IPA,4)=MSTU(5)*(IPA+1)
213 K(IPA,5)=K(IPA,4)
214 K(IPA+1,4)=MSTU(5)*IPA
215 K(IPA+1,5)=K(IPA+1,4)
216 ENDIF
217
218C...Check kinematics and store partons/particles in P vectors.
219 IF(PECM.LE.PM1+PM2) CALL LYERRM(13,
220 &'(LY2ENT:) energy smaller than sum of masses')
221 PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
222 &(2.*PECM)
223 P(IPA,3)=PA
224 P(IPA,4)=SQRT(PM1**2+PA**2)
225 P(IPA,5)=PM1
226 P(IPA+1,3)=-PA
227 P(IPA+1,4)=SQRT(PM2**2+PA**2)
228 P(IPA+1,5)=PM2
229
230C...Set N. Optionally fragment/decay.
231 N=IPA+1
232 IF(IP.EQ.0) CALL LYEXEC
233
234 RETURN
235 END
236
237C*********************************************************************
238
239 SUBROUTINE LY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
240
241C...Purpose: to store three partons or particles in their CM frame,
242C...with the first along the +z axis and the third in the (x,z)
243C...plane with x > 0.
244 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
245 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
246 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
247 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
248
249C...Standard checks.
250 MSTU(28)=0
251 IF(MSTU(12).GE.1) CALL LYLIST(0)
252 IPA=MAX(1,IABS(IP))
253 IF(IPA.GT.MSTU(4)-2) CALL LYERRM(21,
254 &'(LY3ENT:) writing outside LUJETS memory')
255 KC1=LYCOMP(KF1)
256 KC2=LYCOMP(KF2)
257 KC3=LYCOMP(KF3)
258 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LYERRM(12,
259 &'(LY3ENT:) unknown flavour code')
260
261C...Find masses. Reset K, P and V vectors.
262 PM1=0.
263 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
264 IF(MSTU(10).GE.2) PM1=UYMASS(KF1)
265 PM2=0.
266 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
267 IF(MSTU(10).GE.2) PM2=UYMASS(KF2)
268 PM3=0.
269 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
270 IF(MSTU(10).GE.2) PM3=UYMASS(KF3)
271 DO 110 I=IPA,IPA+2
272 DO 100 J=1,5
273 K(I,J)=0
274 P(I,J)=0.
275 V(I,J)=0.
276 100 CONTINUE
277 110 CONTINUE
278
279C...Check flavours.
280 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
281 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
282 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
283 IF(MSTU(19).EQ.1) THEN
284 MSTU(19)=0
285 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
286 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
287 &KQ1+KQ3.EQ.4)) THEN
288 ELSE
289 CALL LYERRM(2,'(LY3ENT:) unphysical flavour combination')
290 ENDIF
291 K(IPA,2)=KF1
292 K(IPA+1,2)=KF2
293 K(IPA+2,2)=KF3
294
295C...Store partons/particles in K vectors for normal case.
296 IF(IP.GE.0) THEN
297 K(IPA,1)=1
298 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
299 K(IPA+1,1)=1
300 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
301 K(IPA+2,1)=1
302
303C...Store partons in K vectors for parton shower evolution.
304 ELSE
305 K(IPA,1)=3
306 K(IPA+1,1)=3
307 K(IPA+2,1)=3
308 KCS=4
309 IF(KQ1.EQ.-1) KCS=5
310 K(IPA,KCS)=MSTU(5)*(IPA+1)
311 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
312 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
313 K(IPA+1,9-KCS)=MSTU(5)*IPA
314 K(IPA+2,KCS)=MSTU(5)*IPA
315 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
316 ENDIF
317
318C...Check kinematics.
319 MKERR=0
320 IF(0.5*X1*PECM.LE.PM1.OR.0.5*(2.-X1-X3)*PECM.LE.PM2.OR.
321 &0.5*X3*PECM.LE.PM3) MKERR=1
322 PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
323 PA2=SQRT(MAX(1E-10,(0.5*(2.-X1-X3)*PECM)**2-PM2**2))
324 PA3=SQRT(MAX(1E-10,(0.5*X3*PECM)**2-PM3**2))
325 CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2)
326 CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3)
327 IF(ABS(CTHE2).GE.1.001.OR.ABS(CTHE3).GE.1.001) MKERR=1
328 CTHE3=MAX(-1.,MIN(1.,CTHE3))
329 IF(MKERR.NE.0) CALL LYERRM(13,
330 &'(LY3ENT:) unphysical kinematical variable setup')
331
332C...Store partons/particles in P vectors.
333 P(IPA,3)=PA1
334 P(IPA,4)=SQRT(PA1**2+PM1**2)
335 P(IPA,5)=PM1
336 P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2)
337 P(IPA+2,3)=PA3*CTHE3
338 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
339 P(IPA+2,5)=PM3
340 P(IPA+1,1)=-P(IPA+2,1)
341 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
342 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
343 P(IPA+1,5)=PM2
344
345C...Set N. Optionally fragment/decay.
346 N=IPA+2
347 IF(IP.EQ.0) CALL LYEXEC
348
349 RETURN
350 END
351
352C*********************************************************************
353
354 SUBROUTINE LY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
355
356C...Purpose: to store four partons or particles in their CM frame, with
357C...the first along the +z axis, the last in the xz plane with x > 0
358C...and the second having y < 0 and y > 0 with equal probability.
359 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
360 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
361 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
362 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
363
364C...Standard checks.
365 MSTU(28)=0
366 IF(MSTU(12).GE.1) CALL LYLIST(0)
367 IPA=MAX(1,IABS(IP))
368 IF(IPA.GT.MSTU(4)-3) CALL LYERRM(21,
369 &'(LY4ENT:) writing outside LUJETS momory')
370 KC1=LYCOMP(KF1)
371 KC2=LYCOMP(KF2)
372 KC3=LYCOMP(KF3)
373 KC4=LYCOMP(KF4)
374 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL LYERRM(12,
375 &'(LY4ENT:) unknown flavour code')
376
377C...Find masses. Reset K, P and V vectors.
378 PM1=0.
379 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
380 IF(MSTU(10).GE.2) PM1=UYMASS(KF1)
381 PM2=0.
382 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
383 IF(MSTU(10).GE.2) PM2=UYMASS(KF2)
384 PM3=0.
385 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
386 IF(MSTU(10).GE.2) PM3=UYMASS(KF3)
387 PM4=0.
388 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
389 IF(MSTU(10).GE.2) PM4=UYMASS(KF4)
390 DO 110 I=IPA,IPA+3
391 DO 100 J=1,5
392 K(I,J)=0
393 P(I,J)=0.
394 V(I,J)=0.
395 100 CONTINUE
396 110 CONTINUE
397
398C...Check flavours.
399 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
400 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
401 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
402 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
403 IF(MSTU(19).EQ.1) THEN
404 MSTU(19)=0
405 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
406 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
407 &KQ1+KQ4.EQ.4)) THEN
408 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.)
409 &THEN
410 ELSE
411 CALL LYERRM(2,'(LY4ENT:) unphysical flavour combination')
412 ENDIF
413 K(IPA,2)=KF1
414 K(IPA+1,2)=KF2
415 K(IPA+2,2)=KF3
416 K(IPA+3,2)=KF4
417
418C...Store partons/particles in K vectors for normal case.
419 IF(IP.GE.0) THEN
420 K(IPA,1)=1
421 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
422 K(IPA+1,1)=1
423 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
424 & K(IPA+1,1)=2
425 K(IPA+2,1)=1
426 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
427 K(IPA+3,1)=1
428
429C...Store partons for parton shower evolution from q-g-g-qbar or
430C...g-g-g-g event.
431 ELSEIF(KQ1+KQ2.NE.0) THEN
432 K(IPA,1)=3
433 K(IPA+1,1)=3
434 K(IPA+2,1)=3
435 K(IPA+3,1)=3
436 KCS=4
437 IF(KQ1.EQ.-1) KCS=5
438 K(IPA,KCS)=MSTU(5)*(IPA+1)
439 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
440 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
441 K(IPA+1,9-KCS)=MSTU(5)*IPA
442 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
443 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
444 K(IPA+3,KCS)=MSTU(5)*IPA
445 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
446
447C...Store partons for parton shower evolution from q-qbar-q-qbar event.
448 ELSE
449 K(IPA,1)=3
450 K(IPA+1,1)=3
451 K(IPA+2,1)=3
452 K(IPA+3,1)=3
453 K(IPA,4)=MSTU(5)*(IPA+1)
454 K(IPA,5)=K(IPA,4)
455 K(IPA+1,4)=MSTU(5)*IPA
456 K(IPA+1,5)=K(IPA+1,4)
457 K(IPA+2,4)=MSTU(5)*(IPA+3)
458 K(IPA+2,5)=K(IPA+2,4)
459 K(IPA+3,4)=MSTU(5)*(IPA+2)
460 K(IPA+3,5)=K(IPA+3,4)
461 ENDIF
462
463C...Check kinematics.
464 MKERR=0
465 IF(0.5*X1*PECM.LE.PM1.OR.0.5*X2*PECM.LE.PM2.OR.0.5*(2.-X1-X2-X4)*
466 &PECM.LE.PM3.OR.0.5*X4*PECM.LE.PM4) MKERR=1
467 PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
468 PA2=SQRT(MAX(1E-10,(0.5*X2*PECM)**2-PM2**2))
469 PA4=SQRT(MAX(1E-10,(0.5*X4*PECM)**2-PM4**2))
470 X24=X1+X2+X4-1.-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
471 CTHE4=(X1*X4-2.*X14)*PECM**2/(4.*PA1*PA4)
472 IF(ABS(CTHE4).GE.1.002) MKERR=1
473 CTHE4=MAX(-1.,MIN(1.,CTHE4))
474 STHE4=SQRT(1.-CTHE4**2)
475 CTHE2=(X1*X2-2.*X12)*PECM**2/(4.*PA1*PA2)
476 IF(ABS(CTHE2).GE.1.002) MKERR=1
477 CTHE2=MAX(-1.,MIN(1.,CTHE2))
478 STHE2=SQRT(1.-CTHE2**2)
479 CPHI2=((X2*X4-2.*X24)*PECM**2-4.*PA2*CTHE2*PA4*CTHE4)/
480 &MAX(1E-8*PECM**2,4.*PA2*STHE2*PA4*STHE4)
481 IF(ABS(CPHI2).GE.1.05) MKERR=1
482 CPHI2=MAX(-1.,MIN(1.,CPHI2))
483 IF(MKERR.EQ.1) CALL LYERRM(13,
484 &'(LY4ENT:) unphysical kinematical variable setup')
485
486C...Store partons/particles in P vectors.
487 P(IPA,3)=PA1
488 P(IPA,4)=SQRT(PA1**2+PM1**2)
489 P(IPA,5)=PM1
490 P(IPA+3,1)=PA4*STHE4
491 P(IPA+3,3)=PA4*CTHE4
492 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
493 P(IPA+3,5)=PM4
494 P(IPA+1,1)=PA2*STHE2*CPHI2
495 P(IPA+1,2)=PA2*STHE2*SQRT(1.-CPHI2**2)*(-1.)**INT(RLY(0)+0.5)
496 P(IPA+1,3)=PA2*CTHE2
497 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
498 P(IPA+1,5)=PM2
499 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
500 P(IPA+2,2)=-P(IPA+1,2)
501 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
502 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
503 P(IPA+2,5)=PM3
504
505C...Set N. Optionally fragment/decay.
506 N=IPA+3
507 IF(IP.EQ.0) CALL LYEXEC
508
509 RETURN
510 END
511
512C*********************************************************************
513
514 SUBROUTINE LYJOIN(NJOIN,IJOIN)
515
516C...Purpose: to connect a sequence of partons with colour flow indices,
517C...as required for subsequent shower evolution (or other operations).
518 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
519 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
520 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
521 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
522 DIMENSION IJOIN(*)
523
524C...Check that partons are of right types to be connected.
525 IF(NJOIN.LT.2) GOTO 120
526 KQSUM=0
527 DO 100 IJN=1,NJOIN
528 I=IJOIN(IJN)
529 IF(I.LE.0.OR.I.GT.N) GOTO 120
530 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
531 KC=LYCOMP(K(I,2))
532 IF(KC.EQ.0) GOTO 120
533 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
534 IF(KQ.EQ.0) GOTO 120
535 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
536 IF(KQ.NE.2) KQSUM=KQSUM+KQ
537 IF(IJN.EQ.1) KQS=KQ
538 100 CONTINUE
539 IF(KQSUM.NE.0) GOTO 120
540
541C...Connect the partons sequentially (closing for gluon loop).
542 KCS=(9-KQS)/2
543 IF(KQS.EQ.2) KCS=INT(4.5+RLY(0))
544 DO 110 IJN=1,NJOIN
545 I=IJOIN(IJN)
546 K(I,1)=3
547 IF(IJN.NE.1) IP=IJOIN(IJN-1)
548 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
549 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
550 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
551 K(I,KCS)=MSTU(5)*IN
552 K(I,9-KCS)=MSTU(5)*IP
553 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
554 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
555 110 CONTINUE
556
557C...Error exit: no action taken.
558 RETURN
559 120 CALL LYERRM(12,
560 &'(LYJOIN:) given entries can not be joined by one string')
561
562 RETURN
563 END
564
565C*********************************************************************
566
567 SUBROUTINE LYGIVE(CHIN)
568
569C...Purpose: to set values of commonblock variables (also in PYTHIA!).
570 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
571 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
572 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
573 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
574 COMMON/LYDAT4/CHAF(500)
575 CHARACTER CHAF*8
576 COMMON/LYDATR/MRLU(6),RRLU(100)
577c DOUBLE PRECISION KFIN,CKIN
578c COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
579c DOUBLE PRECISION PARP,PARI
580c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
581c DOUBLE PRECISION VINT
582c COMMON/PYINT1/MINT(400),VINT(400)
583c DOUBLE PRECISION KFPR,COEF
584c COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
585c DOUBLE PRECISION XSFX,SIGH
586c COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
587c DOUBLE PRECISION WIDS
588c COMMON/PYINT4/MWID(500),WIDS(500,5)
589c DOUBLE PRECISION XSEC
590c COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
591c CHARACTER PROC*28
592c COMMON/PYINT6/PROC(0:500)
593c DOUBLE PRECISION SIGT
594c COMMON/PYINT7/SIGT(0:6,0:6,0:5)
595 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/,/LYDAT4/,/LYDATR/
596c SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
597c &/PYINT5/,/PYINT6/,/PYINT7/
598 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
599 &CHNEW2*28,CHNAM*4,CHVAR(19)*4,CHALP(2)*26,CHIND*8,CHINI*10,
600 &CHINR*16
601 DIMENSION MSVAR(43,8)
602
603C...For each variable to be translated give: name,
604C...integer/real/character, no. of indices, lower&upper index bounds.
605cfkw 3/29/00 I changed the dimension of CHVAR such that it includes only
606cfkw variables names from LUxxxx common blocks.
607cfkw However, I left MSVAR untouched out of fear of screwing it
608cfkw up royally !!!
609 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
610 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU',
611 &'RRLU'/
612c ,'MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
613c &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
614c &'WIDP','WIDE','WIDS','NGEN','XSEC','PROC','SIGT'/
615 DATA ((MSVAR(I,J),J=1,8),I=1,43)/ 1,7*0, 1,2,1,4000,1,5,2*0,
616 & 2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
617 & 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
618 & 1,2,1,500,1,3,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
619 & 2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,2000,1,2,2*0,
620 & 2,1,1,2000,4*0, 1,2,1,2000,1,5,2*0, 3,1,1,500,4*0,
621 & 1,1,1,6,4*0, 2,1,1,100,4*0,
622 & 1,7*0, 1,1,1,200,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
623 & 1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
624 & 1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,200,4*0,
625 & 1,2,1,200,1,2,2*0, 2,2,1,200,1,20,2*0, 1,3,1,40,1,4,1,2,
626 & 2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
627 & 2,2,21,40,0,40,2*0, 2,2,21,40,0,40,2*0, 2,2,21,40,1,3,2*0,
628 & 1,2,0,200,1,3,2*0, 2,2,0,200,1,3,2*0, 4,1,0,200,4*0,
629 & 2,3,0,6,0,6,0,5/
630 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
631 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
632
633C...Length of character variable. Subdivide it into instructions.
634 IF(MSTU(12).GE.1) CALL LYLIST(0)
635 CHBIT=CHIN//' '
636 LBIT=101
637 100 LBIT=LBIT-1
638 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
639 LTOT=0
640 DO 110 LCOM=1,LBIT
641 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
642 LTOT=LTOT+1
643 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
644 110 CONTINUE
645 LLOW=0
646 120 LHIG=LLOW+1
647 130 LHIG=LHIG+1
648 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
649 LBIT=LHIG-LLOW-1
650 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
651
652C...Identify commonblock variable.
653 LNAM=1
654 140 LNAM=LNAM+1
655 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
656 &LNAM.LE.4) GOTO 140
657 CHNAM=CHBIT(1:LNAM-1)//' '
658 DO 160 LCOM=1,LNAM-1
659 DO 150 LALP=1,26
660 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
661 &CHALP(2)(LALP:LALP)
662 150 CONTINUE
663 160 CONTINUE
664 IVAR=0
665c DO 170 IV=1,43
666 DO 170 IV=1,19
667 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
668 170 CONTINUE
669 IF(IVAR.EQ.0) THEN
670 CALL LYERRM(18,'(LYGIVE:) do not recognize variable '//CHNAM)
671 LLOW=LHIG
672 IF(LLOW.LT.LTOT) GOTO 120
673 RETURN
674 ENDIF
675
676C...Identify any indices.
677 I1=0
678 I2=0
679 I3=0
680 NINDX=0
681 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
682 LIND=LNAM
683 180 LIND=LIND+1
684 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
685 CHIND=' '
686 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
687 & AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
688 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
689 READ(CHIND,'(I8)') KF
690 I1=LYCOMP(KF)
691 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
692 & 'c') THEN
693 CALL LYERRM(18,'(LYGIVE:) not allowed to use C index for '//
694 & CHNAM)
695 LLOW=LHIG
696 IF(LLOW.LT.LTOT) GOTO 120
697 RETURN
698 ELSE
699 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
700 READ(CHIND,'(I8)') I1
701 ENDIF
702 LNAM=LIND
703 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
704 NINDX=1
705 ENDIF
706 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
707 LIND=LNAM
708 190 LIND=LIND+1
709 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
710 CHIND=' '
711 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
712 READ(CHIND,'(I8)') I2
713 LNAM=LIND
714 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
715 NINDX=2
716 ENDIF
717 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
718 LIND=LNAM
719 200 LIND=LIND+1
720 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
721 CHIND=' '
722 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
723 READ(CHIND,'(I8)') I3
724 LNAM=LIND+1
725 NINDX=3
726 ENDIF
727
728C...Check that indices allowed.
729 IERR=0
730 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
731 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
732 &IERR=2
733 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
734 &IERR=3
735 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
736 &IERR=4
737 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
738 IF(IERR.GE.1) THEN
739 CALL LYERRM(18,'(LYGIVE:) unallowed indices for '//
740 & CHBIT(1:LNAM-1))
741 LLOW=LHIG
742 IF(LLOW.LT.LTOT) GOTO 120
743 RETURN
744 ENDIF
745
746C...Save old value of variable.
747 IF(IVAR.EQ.1) THEN
748 IOLD=N
749 ELSEIF(IVAR.EQ.2) THEN
750 IOLD=K(I1,I2)
751 ELSEIF(IVAR.EQ.3) THEN
752 ROLD=P(I1,I2)
753 ELSEIF(IVAR.EQ.4) THEN
754 ROLD=V(I1,I2)
755 ELSEIF(IVAR.EQ.5) THEN
756 IOLD=MSTU(I1)
757 ELSEIF(IVAR.EQ.6) THEN
758 ROLD=PARU(I1)
759 ELSEIF(IVAR.EQ.7) THEN
760 IOLD=MSTJ(I1)
761 ELSEIF(IVAR.EQ.8) THEN
762 ROLD=PARJ(I1)
763 ELSEIF(IVAR.EQ.9) THEN
764 IOLD=KCHG(I1,I2)
765 ELSEIF(IVAR.EQ.10) THEN
766 ROLD=PMAS(I1,I2)
767 ELSEIF(IVAR.EQ.11) THEN
768 ROLD=PARF(I1)
769 ELSEIF(IVAR.EQ.12) THEN
770 ROLD=VCKM(I1,I2)
771 ELSEIF(IVAR.EQ.13) THEN
772 IOLD=MDCY(I1,I2)
773 ELSEIF(IVAR.EQ.14) THEN
774 IOLD=MDME(I1,I2)
775 ELSEIF(IVAR.EQ.15) THEN
776 ROLD=BRAT(I1)
777 ELSEIF(IVAR.EQ.16) THEN
778 IOLD=KFDP(I1,I2)
779 ELSEIF(IVAR.EQ.17) THEN
780 CHOLD=CHAF(I1)
781 ELSEIF(IVAR.EQ.18) THEN
782 IOLD=MRLU(I1)
783 ELSEIF(IVAR.EQ.19) THEN
784 ROLD=RRLU(I1)
785cfkw 3/29/00 comment out all variables that exist only in PYxxxx commons
786cfkw as those commons are commented above anyway.
787c ELSEIF(IVAR.EQ.20) THEN
788c IOLD=MSEL
789c ELSEIF(IVAR.EQ.21) THEN
790c IOLD=MSUB(I1)
791c ELSEIF(IVAR.EQ.22) THEN
792c IOLD=KFIN(I1,I2)
793c ELSEIF(IVAR.EQ.23) THEN
794c ROLD=CKIN(I1)
795c ELSEIF(IVAR.EQ.24) THEN
796c IOLD=MSTP(I1)
797c ELSEIF(IVAR.EQ.25) THEN
798c ROLD=PARP(I1)
799c ELSEIF(IVAR.EQ.26) THEN
800c IOLD=MSTI(I1)
801c ELSEIF(IVAR.EQ.27) THEN
802c ROLD=PARI(I1)
803c ELSEIF(IVAR.EQ.28) THEN
804c IOLD=MINT(I1)
805c ELSEIF(IVAR.EQ.29) THEN
806c ROLD=VINT(I1)
807c ELSEIF(IVAR.EQ.30) THEN
808c IOLD=ISET(I1)
809c ELSEIF(IVAR.EQ.31) THEN
810c IOLD=KFPR(I1,I2)
811c ELSEIF(IVAR.EQ.32) THEN
812c ROLD=COEF(I1,I2)
813c ELSEIF(IVAR.EQ.33) THEN
814c IOLD=ICOL(I1,I2,I3)
815c ELSEIF(IVAR.EQ.34) THEN
816c ROLD=XSFX(I1,I2)
817c ELSEIF(IVAR.EQ.35) THEN
818c IOLD=ISIG(I1,I2)
819c ELSEIF(IVAR.EQ.36) THEN
820c ROLD=SIGH(I1)
821c ELSEIF(IVAR.EQ.37) THEN
822c ROLD=WIDP(I1,I2)
823c ELSEIF(IVAR.EQ.38) THEN
824c ROLD=WIDE(I1,I2)
825c ELSEIF(IVAR.EQ.39) THEN
826c ROLD=WIDS(I1,I2)
827c ELSEIF(IVAR.EQ.40) THEN
828c IOLD=NGEN(I1,I2)
829c ELSEIF(IVAR.EQ.41) THEN
830c ROLD=XSEC(I1,I2)
831c ELSEIF(IVAR.EQ.42) THEN
832c CHOLD2=PROC(I1)
833c ELSEIF(IVAR.EQ.43) THEN
834c ROLD=SIGT(I1,I2,I3)
835 ELSE
836 CALL LYERRM(18,'(LYGIVE:) IVAR screwup '//CHNAM)
837 ENDIF
838
839C...Print current value of variable. Loop back.
840 IF(LNAM.GE.LBIT) THEN
841 CHBIT(LNAM:14)=' '
842 CHBIT(15:60)=' has the value '
843 IF(MSVAR(IVAR,1).EQ.1) THEN
844 WRITE(CHBIT(51:60),'(I10)') IOLD
845 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
846 WRITE(CHBIT(47:60),'(F14.5)') ROLD
847 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
848 CHBIT(53:60)=CHOLD
849 ELSE
850 CHBIT(33:60)=CHOLD
851 ENDIF
852 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
853 LLOW=LHIG
854 IF(LLOW.LT.LTOT) GOTO 120
855 RETURN
856 ENDIF
857
858C...Read in new variable value.
859 IF(MSVAR(IVAR,1).EQ.1) THEN
860 CHINI=' '
861 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
862 READ(CHINI,'(I10)') INEW
863 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
864 CHINR=' '
865 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
866 READ(CHINR,'(F16.2)') RNEW
867 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
868 CHNEW=CHBIT(LNAM+1:LBIT)//' '
869 ELSE
870 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
871 ENDIF
872
873C...Store new variable value.
874 IF(IVAR.EQ.1) THEN
875 N=INEW
876 ELSEIF(IVAR.EQ.2) THEN
877 K(I1,I2)=INEW
878 ELSEIF(IVAR.EQ.3) THEN
879 P(I1,I2)=RNEW
880 ELSEIF(IVAR.EQ.4) THEN
881 V(I1,I2)=RNEW
882 ELSEIF(IVAR.EQ.5) THEN
883 MSTU(I1)=INEW
884 ELSEIF(IVAR.EQ.6) THEN
885 PARU(I1)=RNEW
886 ELSEIF(IVAR.EQ.7) THEN
887 MSTJ(I1)=INEW
888 ELSEIF(IVAR.EQ.8) THEN
889 PARJ(I1)=RNEW
890 ELSEIF(IVAR.EQ.9) THEN
891 KCHG(I1,I2)=INEW
892 ELSEIF(IVAR.EQ.10) THEN
893 PMAS(I1,I2)=RNEW
894 ELSEIF(IVAR.EQ.11) THEN
895 PARF(I1)=RNEW
896 ELSEIF(IVAR.EQ.12) THEN
897 VCKM(I1,I2)=RNEW
898 ELSEIF(IVAR.EQ.13) THEN
899 MDCY(I1,I2)=INEW
900 ELSEIF(IVAR.EQ.14) THEN
901 MDME(I1,I2)=INEW
902 ELSEIF(IVAR.EQ.15) THEN
903 BRAT(I1)=RNEW
904 ELSEIF(IVAR.EQ.16) THEN
905 KFDP(I1,I2)=INEW
906 ELSEIF(IVAR.EQ.17) THEN
907 CHAF(I1)=CHNEW
908 ELSEIF(IVAR.EQ.18) THEN
909 MRLU(I1)=INEW
910 ELSEIF(IVAR.EQ.19) THEN
911 RRLU(I1)=RNEW
912cfkw 3/29/00 comment out all variables that exist only in PYxxxx commons
913cfkw as those commons are commented above anyway.
914c ELSEIF(IVAR.EQ.20) THEN
915c MSEL=INEW
916c ELSEIF(IVAR.EQ.21) THEN
917c MSUB(I1)=INEW
918c ELSEIF(IVAR.EQ.22) THEN
919c KFIN(I1,I2)=INEW
920c ELSEIF(IVAR.EQ.23) THEN
921c CKIN(I1)=RNEW
922c ELSEIF(IVAR.EQ.24) THEN
923c MSTP(I1)=INEW
924c ELSEIF(IVAR.EQ.25) THEN
925c PARP(I1)=RNEW
926c ELSEIF(IVAR.EQ.26) THEN
927c MSTI(I1)=INEW
928c ELSEIF(IVAR.EQ.27) THEN
929c PARI(I1)=RNEW
930c ELSEIF(IVAR.EQ.28) THEN
931c MINT(I1)=INEW
932c ELSEIF(IVAR.EQ.29) THEN
933c VINT(I1)=RNEW
934c ELSEIF(IVAR.EQ.30) THEN
935c ISET(I1)=INEW
936c ELSEIF(IVAR.EQ.31) THEN
937c KFPR(I1,I2)=INEW
938c ELSEIF(IVAR.EQ.32) THEN
939c COEF(I1,I2)=RNEW
940c ELSEIF(IVAR.EQ.33) THEN
941c ICOL(I1,I2,I3)=INEW
942c ELSEIF(IVAR.EQ.34) THEN
943c XSFX(I1,I2)=RNEW
944c ELSEIF(IVAR.EQ.35) THEN
945c ISIG(I1,I2)=INEW
946c ELSEIF(IVAR.EQ.36) THEN
947c SIGH(I1)=RNEW
948c ELSEIF(IVAR.EQ.37) THEN
949c WIDP(I1,I2)=RNEW
950c ELSEIF(IVAR.EQ.38) THEN
951c WIDE(I1,I2)=RNEW
952c ELSEIF(IVAR.EQ.39) THEN
953c WIDS(I1,I2)=RNEW
954c ELSEIF(IVAR.EQ.40) THEN
955c NGEN(I1,I2)=INEW
956c ELSEIF(IVAR.EQ.41) THEN
957c XSEC(I1,I2)=RNEW
958c ELSEIF(IVAR.EQ.42) THEN
959c PROC(I1)=CHNEW2
960c ELSEIF(IVAR.EQ.43) THEN
961c SIGT(I1,I2,I3)=RNEW
962 ELSE
963 CALL LYERRM(18,'(LYGIVE:) IVAR screwup '//CHNAM)
964 ENDIF
965
966C...Write old and new value. Loop back.
967 CHBIT(LNAM:14)=' '
968 CHBIT(15:60)=' changed from to '
969 IF(MSVAR(IVAR,1).EQ.1) THEN
970 WRITE(CHBIT(33:42),'(I10)') IOLD
971 WRITE(CHBIT(51:60),'(I10)') INEW
972 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
973 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
974 WRITE(CHBIT(29:42),'(F14.5)') ROLD
975 WRITE(CHBIT(47:60),'(F14.5)') RNEW
976 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
977 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
978 CHBIT(35:42)=CHOLD
979 CHBIT(53:60)=CHNEW
980 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
981 ELSE
982 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
983 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
984 ENDIF
985 LLOW=LHIG
986 IF(LLOW.LT.LTOT) GOTO 120
987
988C...Format statement for output on unit MSTU(11) (by default 6).
989 5000 FORMAT(5X,A60)
990 5100 FORMAT(5X,A88)
991
992 RETURN
993 END
994
995C*********************************************************************
996
997 SUBROUTINE LYEXEC
998
999C...Purpose: to administrate the fragmentation and decay chain.
1000 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
1001 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1002 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1003 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
1004 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
1005 DIMENSION PS(2,6)
1006
1007C...Initialize and reset.
1008 MSTU(24)=0
1009 IF(MSTU(12).GE.1) CALL LYLIST(0)
1010 MSTU(31)=MSTU(31)+1
1011 MSTU(1)=0
1012 MSTU(2)=0
1013 MSTU(3)=0
1014 IF(MSTU(17).LE.0) MSTU(90)=0
1015 MCONS=1
1016
1017C...Sum up momentum, energy and charge for starting entries.
1018 NSAV=N
1019 DO 110 I=1,2
1020 DO 100 J=1,6
1021 PS(I,J)=0.
1022 100 CONTINUE
1023 110 CONTINUE
1024 DO 130 I=1,N
1025 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
1026 DO 120 J=1,4
1027 PS(1,J)=PS(1,J)+P(I,J)
1028 120 CONTINUE
1029 PS(1,6)=PS(1,6)+LYCHGE(K(I,2))
1030 130 CONTINUE
1031 PARU(21)=PS(1,4)
1032
1033C...Prepare system for subsequent fragmentation/decay.
1034 CALL LYPREP(0)
1035
1036C...Loop through jet fragmentation and particle decays.
1037 MBE=0
1038 140 MBE=MBE+1
1039 IP=0
1040 150 IP=IP+1
1041 KC=0
1042 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LYCOMP(K(IP,2))
1043 IF(KC.EQ.0) THEN
1044
1045C...Particle decay if unstable and allowed. Save long-lived particle
1046C...decays until second pass after Bose-Einstein effects.
1047 ELSEIF(KCHG(KC,2).EQ.0) THEN
1048 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
1049 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
1050 & CALL LYDECY(IP)
1051
1052C...Decay products may develop a shower.
1053 IF(MSTJ(92).GT.0) THEN
1054 IP1=MSTJ(92)
1055 QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
1056 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
1057 CALL LYSHOW(IP1,IP1+1,QMAX)
1058 CALL LYPREP(IP1)
1059 MSTJ(92)=0
1060 ELSEIF(MSTJ(92).LT.0) THEN
1061 IP1=-MSTJ(92)
1062 CALL LYSHOW(IP1,-3,P(IP,5))
1063 CALL LYPREP(IP1)
1064 MSTJ(92)=0
1065 ENDIF
1066
1067C...Jet fragmentation: string or independent fragmentation.
1068 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
1069 MFRAG=MSTJ(1)
1070 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
1071 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
1072 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
1073 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
1074 IF(KCHG(LYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
1075 ENDIF
1076 ENDIF
1077 IF(MFRAG.EQ.1) CALL LYSTRF(IP)
1078 IF(MFRAG.EQ.2) CALL LYINDF(IP)
1079 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
1080 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
1081 ENDIF
1082
1083C...Loop back if enough space left in LUJETS and no error abort.
1084 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
1085 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
1086 GOTO 150
1087 ELSEIF(IP.LT.N) THEN
1088 CALL LYERRM(11,'(LYEXEC:) no more memory left in LUJETS')
1089 ENDIF
1090
1091C...Include simple Bose-Einstein effect parametrization if desired.
1092 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
1093 CALL LYBOEI(NSAV)
1094 GOTO 140
1095 ENDIF
1096
1097C...Check that momentum, energy and charge were conserved.
1098 DO 170 I=1,N
1099 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
1100 DO 160 J=1,4
1101 PS(2,J)=PS(2,J)+P(I,J)
1102 160 CONTINUE
1103 PS(2,6)=PS(2,6)+LYCHGE(K(I,2))
1104 170 CONTINUE
1105 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
1106 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
1107 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LYERRM(15,
1108 &'(LYEXEC:) four-momentum was not conserved')
1109 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LYERRM(15,
1110 &'(LYEXEC:) charge was not conserved')
1111
1112 RETURN
1113 END
1114
1115C*********************************************************************
1116
1117 SUBROUTINE LYPREP(IP)
1118
1119C...Purpose: to rearrange partons along strings, to allow small systems
1120C...to collapse into one or two particles and to check flavours.
1121 IMPLICIT DOUBLE PRECISION(D)
1122 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
1123 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1124 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1125 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
1126 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
1127 DIMENSION DPS(5),DPC(5),UE(3)
1128
1129C...Rearrange parton shower product listing along strings: begin loop.
1130 I1=N
1131 DO 130 MQGST=1,2
1132 DO 120 I=MAX(1,IP),N
1133 IF(K(I,1).NE.3) GOTO 120
1134 KC=LYCOMP(K(I,2))
1135 IF(KC.EQ.0) GOTO 120
1136 KQ=KCHG(KC,2)
1137 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
1138
1139C...Pick up loose string end.
1140 KCS=4
1141 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
1142 IA=I
1143 NSTP=0
1144 100 NSTP=NSTP+1
1145 IF(NSTP.GT.4*N) THEN
1146 CALL LYERRM(14,'(LYPREP:) caught in infinite loop')
1147 RETURN
1148 ENDIF
1149
1150C...Copy undecayed parton.
1151 IF(K(IA,1).EQ.3) THEN
1152 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
1153 CALL LYERRM(11,'(LYPREP:) no more memory left in LUJETS')
1154 RETURN
1155 ENDIF
1156 I1=I1+1
1157 K(I1,1)=2
1158 IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
1159 K(I1,2)=K(IA,2)
1160 K(I1,3)=IA
1161 K(I1,4)=0
1162 K(I1,5)=0
1163 DO 110 J=1,5
1164 P(I1,J)=P(IA,J)
1165 V(I1,J)=V(IA,J)
1166 110 CONTINUE
1167 K(IA,1)=K(IA,1)+10
1168 IF(K(I1,1).EQ.1) GOTO 120
1169 ENDIF
1170
1171C...Go to next parton in colour space.
1172 IB=IA
1173 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
1174 &.NE.0) THEN
1175 IA=MOD(K(IB,KCS),MSTU(5))
1176 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
1177 MREV=0
1178 ELSE
1179 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5))
1180 & .EQ.0) KCS=9-KCS
1181 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
1182 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
1183 MREV=1
1184 ENDIF
1185 IF(IA.LE.0.OR.IA.GT.N) THEN
1186 CALL LYERRM(12,'(LYPREP:) colour rearrangement failed')
1187 RETURN
1188 ENDIF
1189 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
1190 &MSTU(5)).EQ.IB) THEN
1191 IF(MREV.EQ.1) KCS=9-KCS
1192 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
1193 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
1194 ELSE
1195 IF(MREV.EQ.0) KCS=9-KCS
1196 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
1197 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
1198 ENDIF
1199 IF(IA.NE.I) GOTO 100
1200 K(I1,1)=1
1201 120 CONTINUE
1202 130 CONTINUE
1203 N=I1
1204 IF(MSTJ(14).LT.0) RETURN
1205
1206C...Find lowest-mass colour singlet jet system, OK if above threshold.
1207 IF(MSTJ(14).EQ.0) GOTO 320
1208 NS=N
1209 140 NSIN=N-NS
1210 PDM=1.+PARJ(32)
1211 IC=0
1212 DO 190 I=MAX(1,IP),NS
1213 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
1214 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
1215 NSIN=NSIN+1
1216 IC=I
1217 DO 150 J=1,4
1218 DPS(J)=P(I,J)
1219 150 CONTINUE
1220 MSTJ(93)=1
1221 DPS(5)=UYMASS(K(I,2))
1222 ELSEIF(K(I,1).EQ.2) THEN
1223 DO 160 J=1,4
1224 DPS(J)=DPS(J)+P(I,J)
1225 160 CONTINUE
1226 ELSEIF(IC.NE.0.AND.KCHG(LYCOMP(K(I,2)),2).NE.0) THEN
1227 DO 170 J=1,4
1228 DPS(J)=DPS(J)+P(I,J)
1229 170 CONTINUE
1230 MSTJ(93)=1
1231 DPS(5)=DPS(5)+UYMASS(K(I,2))
1232 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5)
1233 IF(PD.LT.PDM) THEN
1234 PDM=PD
1235 DO 180 J=1,5
1236 DPC(J)=DPS(J)
1237 180 CONTINUE
1238 IC1=IC
1239 IC2=I
1240 ENDIF
1241 IC=0
1242 ELSE
1243 NSIN=NSIN+1
1244 ENDIF
1245 190 CONTINUE
1246 IF(PDM.GE.PARJ(32)) GOTO 320
1247
1248C...Fill small-mass system as cluster.
1249 NSAV=N
1250 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
1251 K(N+1,1)=11
1252 K(N+1,2)=91
1253 K(N+1,3)=IC1
1254 K(N+1,4)=N+2
1255 K(N+1,5)=N+3
1256 P(N+1,1)=DPC(1)
1257 P(N+1,2)=DPC(2)
1258 P(N+1,3)=DPC(3)
1259 P(N+1,4)=DPC(4)
1260 P(N+1,5)=PECM
1261
1262C...Form two particles from flavours of lowest-mass system, if feasible.
1263 K(N+2,1)=1
1264 K(N+3,1)=1
1265 IF(MSTU(16).NE.2) THEN
1266 K(N+2,3)=N+1
1267 K(N+3,3)=N+1
1268 ELSE
1269 K(N+2,3)=IC1
1270 K(N+3,3)=IC2
1271 ENDIF
1272 K(N+2,4)=0
1273 K(N+3,4)=0
1274 K(N+2,5)=0
1275 K(N+3,5)=0
1276 IF(IABS(K(IC1,2)).NE.21) THEN
1277 KC1=LYCOMP(K(IC1,2))
1278 KC2=LYCOMP(K(IC2,2))
1279 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
1280 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
1281 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
1282 IF(KQ1+KQ2.NE.0) GOTO 320
1283 200 CALL LYKFDI(K(IC1,2),0,KFLN,K(N+2,2))
1284 CALL LYKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
1285 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
1286 ELSE
1287 IF(IABS(K(IC2,2)).NE.21) GOTO 320
1288 210 CALL LYKFDI(1+INT((2.+PARJ(2))*RLY(0)),0,KFLN,KFDMP)
1289 CALL LYKFDI(KFLN,0,KFLM,K(N+2,2))
1290 CALL LYKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
1291 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
1292 ENDIF
1293 P(N+2,5)=UYMASS(K(N+2,2))
1294 P(N+3,5)=UYMASS(K(N+3,2))
1295 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
1296 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
1297
1298C...Perform two-particle decay of jet system, if possible.
1299 IF(PECM.GE.0.02*DPC(4)) THEN
1300 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
1301 & (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
1302 UE(3)=2.*RLY(0)-1.
1303 PHI=PARU(2)*RLY(0)
1304 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
1305 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
1306 DO 220 J=1,3
1307 P(N+2,J)=PA*UE(J)
1308 P(N+3,J)=-PA*UE(J)
1309 220 CONTINUE
1310 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
1311 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
1312 MSTU(33)=1
1313 CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
1314 & DPC(3)/DPC(4))
1315 ELSE
1316 NP=0
1317 DO 230 I=IC1,IC2
1318 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
1319 230 CONTINUE
1320 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
1321 & P(IC1,3)*P(IC2,3)
1322 IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
1323 HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
1324 HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
1325 HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
1326 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
1327 HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
1328 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
1329 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
1330 DO 240 J=1,4
1331 P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
1332 P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
1333 240 CONTINUE
1334 ENDIF
1335 DO 250 J=1,4
1336 V(N+1,J)=V(IC1,J)
1337 V(N+2,J)=V(IC1,J)
1338 V(N+3,J)=V(IC2,J)
1339 250 CONTINUE
1340 V(N+1,5)=0.
1341 V(N+2,5)=0.
1342 V(N+3,5)=0.
1343 N=N+3
1344 GOTO 300
1345
1346C...Else form one particle from the flavours available, if possible.
1347 260 K(N+1,5)=N+2
1348 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
1349 GOTO 320
1350 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
1351 CALL LYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
1352 ELSE
1353 KFLN=1+INT((2.+PARJ(2))*RLY(0))
1354 CALL LYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
1355 ENDIF
1356 IF(K(N+2,2).EQ.0) GOTO 260
1357 P(N+2,5)=UYMASS(K(N+2,2))
1358
1359C...Find parton/particle which combines to largest extra mass.
1360 IR=0
1361 HA=0.
1362 HSM=0.
1363 DO 280 MCOMB=1,3
1364 IF(IR.NE.0) GOTO 280
1365 DO 270 I=MAX(1,IP),N
1366 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
1367 &.AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
1368 IF(MCOMB.EQ.1) KCI=LYCOMP(K(I,2))
1369 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
1370 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
1371 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
1372 &GOTO 270
1373 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
1374 HSR=2.*HCR+PECM**2-P(N+2,5)**2-2.*P(N+2,5)*P(I,5)
1375 IF(HSR.GT.HSM) THEN
1376 IR=I
1377 HA=HCR
1378 HSM=HSR
1379 ENDIF
1380 270 CONTINUE
1381 280 CONTINUE
1382
1383C...Shuffle energy and momentum to put new particle on mass shell.
1384 IF(IR.NE.0) THEN
1385 HB=PECM**2+HA
1386 HC=P(N+2,5)**2+HA
1387 HD=P(IR,5)**2+HA
1388 HK2=0.5*(HB*SQRT(MAX(0.,((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
1389 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
1390 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
1391 DO 290 J=1,4
1392 P(N+2,J)=(1.+HK1)*DPC(J)-HK2*P(IR,J)
1393 P(IR,J)=(1.+HK2)*P(IR,J)-HK1*DPC(J)
1394 V(N+1,J)=V(IC1,J)
1395 V(N+2,J)=V(IC1,J)
1396 290 CONTINUE
1397 V(N+1,5)=0.
1398 V(N+2,5)=0.
1399 N=N+2
1400 ELSE
1401 CALL LYERRM(3,'(LYPREP:) no match for collapsing cluster')
1402 RETURN
1403 ENDIF
1404
1405C...Mark collapsed system and store daughter pointers. Iterate.
1406 300 DO 310 I=IC1,IC2
1407 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LYCOMP(K(I,2)),2).NE.0)
1408 &THEN
1409 K(I,1)=K(I,1)+10
1410 IF(MSTU(16).NE.2) THEN
1411 K(I,4)=NSAV+1
1412 K(I,5)=NSAV+1
1413 ELSE
1414 K(I,4)=NSAV+2
1415 K(I,5)=N
1416 ENDIF
1417 ENDIF
1418 310 CONTINUE
1419 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
1420
1421C...Check flavours and invariant masses in parton systems.
1422 320 NP=0
1423 KFN=0
1424 KQS=0
1425 NJU=0
1426 DO 330 J=1,5
1427 DPS(J)=0.
1428 330 CONTINUE
1429 DO 360 I=MAX(1,IP),N
1430 IF(K(I,1).EQ.41) NJU=NJU+1
1431 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
1432 KC=LYCOMP(K(I,2))
1433 IF(KC.EQ.0) GOTO 360
1434 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1435 IF(KQ.EQ.0) GOTO 360
1436 NP=NP+1
1437 IF(KQ.NE.2) THEN
1438 KFN=KFN+1
1439 KQS=KQS+KQ
1440 MSTJ(93)=1
1441 DPS(5)=DPS(5)+UYMASS(K(I,2))
1442 ENDIF
1443 DO 340 J=1,4
1444 DPS(J)=DPS(J)+P(I,J)
1445 340 CONTINUE
1446 IF(K(I,1).EQ.1) THEN
1447 NFERR=0
1448 IF(NJU.EQ.0.AND.NP.NE.1) THEN
1449 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
1450 ELSEIF(NJU.EQ.1) THEN
1451 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
1452 ELSEIF(NJU.EQ.2) THEN
1453 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
1454 ELSEIF(NJU.GE.3) THEN
1455 NFERR=1
1456 ENDIF
1457 IF(NFERR.EQ.1) CALL
1458 & LYERRM(2,'(LYPREP:) unphysical flavour combination')
1459 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
1460 & (0.9*PARJ(32)+DPS(5))**2) CALL LYERRM(3,
1461 & '(LYPREP:) too small mass in jet system')
1462 NP=0
1463 KFN=0
1464 KQS=0
1465 NJU=0
1466 DO 350 J=1,5
1467 DPS(J)=0.
1468 350 CONTINUE
1469 ENDIF
1470 360 CONTINUE
1471
1472 RETURN
1473 END
1474
1475C*********************************************************************
1476
1477 SUBROUTINE LYSTRF(IP)
1478C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1479C...jet system according to the Lund string fragmentation model.
1480 IMPLICIT DOUBLE PRECISION(D)
1481 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
1482 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1483 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1484 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
1485 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
1486 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
1487 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8)
1488
1489C...Function: four-product of two vectors.
1490 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)
1491 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
1492 &DP(I,3)*DP(J,3)
1493
1494C...Reset counters. Identify parton system.
1495 MSTJ(91)=0
1496 NSAV=N
1497 MSTU90=MSTU(90)
1498 NP=0
1499 KQSUM=0
1500 DO 100 J=1,5
1501 DPS(J)=0D0
1502 100 CONTINUE
1503 MJU(1)=0
1504 MJU(2)=0
1505 I=IP-1
1506 110 I=I+1
1507 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1508 CALL LYERRM(12,'(LYSTRF:) failed to reconstruct jet system')
1509 IF(MSTU(21).GE.1) RETURN
1510 ENDIF
1511 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
1512 KC=LYCOMP(K(I,2))
1513 IF(KC.EQ.0) GOTO 110
1514 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1515 IF(KQ.EQ.0) GOTO 110
1516 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
1517 CALL LYERRM(11,'(LYSTRF:) no more memory left in LUJETS')
1518 IF(MSTU(21).GE.1) RETURN
1519 ENDIF
1520
1521C...Take copy of partons to be considered. Check flavour sum.
1522 NP=NP+1
1523 DO 120 J=1,5
1524 K(N+NP,J)=K(I,J)
1525 P(N+NP,J)=P(I,J)
1526 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
1527 120 CONTINUE
1528 DPS(4)=DPS(4)+SQRT(DBLE(P(I,1))**2+DBLE(P(I,2))**2+
1529 &DBLE(P(I,3))**2+DBLE(P(I,5))**2)
1530 K(N+NP,3)=I
1531 IF(KQ.NE.2) KQSUM=KQSUM+KQ
1532 IF(K(I,1).EQ.41) THEN
1533 KQSUM=KQSUM+2*KQ
1534 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
1535 IF(KQSUM.NE.KQ) MJU(2)=N+NP
1536 ENDIF
1537 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
1538 IF(KQSUM.NE.0) THEN
1539 CALL LYERRM(12,'(LYSTRF:) unphysical flavour combination')
1540 IF(MSTU(21).GE.1) RETURN
1541 ENDIF
1542
1543C...Boost copied system to CM frame (for better numerical precision).
1544 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
1545 MBST=0
1546 MSTU(33)=1
1547 CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
1548 & -DPS(3)/DPS(4))
1549 ELSE
1550 MBST=1
1551 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
1552 DO 130 I=N+1,N+NP
1553 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
1554 IF(P(I,3).GT.0.) THEN
1555 HHPEZ=(P(I,4)+P(I,3))/HHBZ
1556 P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
1557 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1558 ELSE
1559 HHPEZ=(P(I,4)-P(I,3))*HHBZ
1560 P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
1561 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1562 ENDIF
1563 130 CONTINUE
1564 ENDIF
1565
1566C...Search for very nearby partons that may be recombined.
1567 NTRYR=0
1568 PARU12=PARU(12)
1569 PARU13=PARU(13)
1570 MJU(3)=MJU(1)
1571 MJU(4)=MJU(2)
1572 NR=NP
1573 140 IF(NR.GE.3) THEN
1574 PDRMIN=2.*PARU12
1575 DO 150 I=N+1,N+NR
1576 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
1577 I1=I+1
1578 IF(I.EQ.N+NR) I1=N+1
1579 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
1580 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
1581 & GOTO 150
1582 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 150
1583 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
1584 & P(I1,2)**2+P(I1,3)**2))
1585 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
1586 PDR=4.*(PAP-PVP)**2/MAX(1E-6,PARU13**2*PAP+2.*(PAP-PVP))
1587 IF(PDR.LT.PDRMIN) THEN
1588 IR=I
1589 PDRMIN=PDR
1590 ENDIF
1591 150 CONTINUE
1592
1593C...Recombine very nearby partons to avoid machine precision problems.
1594 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
1595 DO 160 J=1,4
1596 P(N+1,J)=P(N+1,J)+P(N+NR,J)
1597 160 CONTINUE
1598 P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
1599 & P(N+1,3)**2))
1600 NR=NR-1
1601 GOTO 140
1602 ELSEIF(PDRMIN.LT.PARU12) THEN
1603 DO 170 J=1,4
1604 P(IR,J)=P(IR,J)+P(IR+1,J)
1605 170 CONTINUE
1606 P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
1607 & P(IR,3)**2))
1608 DO 190 I=IR+1,N+NR-1
1609 K(I,2)=K(I+1,2)
1610 DO 180 J=1,5
1611 P(I,J)=P(I+1,J)
1612 180 CONTINUE
1613 190 CONTINUE
1614 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
1615 NR=NR-1
1616 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
1617 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
1618 GOTO 140
1619 ENDIF
1620 ENDIF
1621 NTRYR=NTRYR+1
1622
1623C...Reset particle counter. Skip ahead if no junctions are present;
1624C...this is usually the case!
1625 NRS=MAX(5*NR+11,NP)
1626 NTRY=0
1627 200 NTRY=NTRY+1
1628 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1629 PARU12=4.*PARU12
1630 PARU13=2.*PARU13
1631 GOTO 140
1632 ELSEIF(NTRY.GT.100) THEN
1633 CALL LYERRM(14,'(LYSTRF:) caught in infinite loop')
1634 IF(MSTU(21).GE.1) RETURN
1635 ENDIF
1636 I=N+NRS
1637 MSTU(90)=MSTU90
1638 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
1639 DO 570 JT=1,2
1640 NJS(JT)=0
1641 IF(MJU(JT).EQ.0) GOTO 570
1642 JS=3-2*JT
1643
1644C...Find and sum up momentum on three sides of junction. Check flavours.
1645 DO 220 IU=1,3
1646 IJU(IU)=0
1647 DO 210 J=1,5
1648 PJU(IU,J)=0.
1649 210 CONTINUE
1650 220 CONTINUE
1651 IU=0
1652 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
1653 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
1654 IU=IU+1
1655 IJU(IU)=I1
1656 ENDIF
1657 DO 230 J=1,4
1658 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1659 230 CONTINUE
1660 240 CONTINUE
1661 DO 250 IU=1,3
1662 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1663 250 CONTINUE
1664 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1665 &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1666 CALL LYERRM(12,'(LYSTRF:) unphysical flavour combination')
1667 IF(MSTU(21).GE.1) RETURN
1668 ENDIF
1669
1670C...Calculate (approximate) boost to rest frame of junction.
1671 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1672 &(PJU(1,5)*PJU(2,5))
1673 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1674 &(PJU(1,5)*PJU(3,5))
1675 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1676 &(PJU(2,5)*PJU(3,5))
1677 T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1678 T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1679 TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1680 T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1681 T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1682 DO 260 J=1,3
1683 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1684 260 CONTINUE
1685 TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1686 DO 270 IU=1,3
1687 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1688 &TJU(3)*PJU(IU,3)
1689 270 CONTINUE
1690
1691C...Put junction at rest if motion could give inconsistencies.
1692 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1693 DO 280 J=1,3
1694 TJU(J)=0.
1695 280 CONTINUE
1696 TJU(4)=1.
1697 PJU(1,5)=PJU(1,4)
1698 PJU(2,5)=PJU(2,4)
1699 PJU(3,5)=PJU(3,4)
1700 ENDIF
1701
1702C...Start preparing for fragmentation of two strings from junction.
1703 ISTA=I
1704 DO 550 IU=1,2
1705 NS=JS*(IJU(IU+1)-IJU(IU))
1706
1707C...Junction strings: find longitudinal string directions.
1708 DO 310 IS=1,NS
1709 IS1=IJU(IU)+IS-1
1710 IS2=IJU(IU)+IS
1711 DO 290 J=1,5
1712 DP(1,J)=0.5*P(IS1,J)
1713 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
1714 DP(2,J)=0.5*P(IS2,J)
1715 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
1716 290 CONTINUE
1717 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1718 IF(IS.EQ.NS) DP(2,5)=0.
1719 DP(3,5)=DFOUR(1,1)
1720 DP(4,5)=DFOUR(2,2)
1721 DHKC=DFOUR(1,2)
1722 IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1723 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1724 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1725 DP(3,5)=0D0
1726 DP(4,5)=0D0
1727 DHKC=DFOUR(1,2)
1728 ENDIF
1729 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1730 DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1731 DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1732 IN1=N+NR+4*IS-3
1733 P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1734 DO 300 J=1,4
1735 P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1736 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1737 300 CONTINUE
1738 310 CONTINUE
1739
1740C...Junction strings: initialize flavour, momentum and starting pos.
1741 ISAV=I
1742 MSTU91=MSTU(90)
1743 320 NTRY=NTRY+1
1744 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1745 PARU12=4.*PARU12
1746 PARU13=2.*PARU13
1747 GOTO 140
1748 ELSEIF(NTRY.GT.100) THEN
1749 CALL LYERRM(14,'(LYSTRF:) caught in infinite loop')
1750 IF(MSTU(21).GE.1) RETURN
1751 ENDIF
1752 I=ISAV
1753 MSTU(90)=MSTU91
1754 IRANKJ=0
1755 IE(1)=K(N+1+(JT/2)*(NP-1),3)
1756 IN(4)=N+NR+1
1757 IN(5)=IN(4)+1
1758 IN(6)=N+NR+4*NS+1
1759 DO 340 JQ=1,2
1760 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1761 P(IN1,1)=2-JQ
1762 P(IN1,2)=JQ-1
1763 P(IN1,3)=1.
1764 330 CONTINUE
1765 340 CONTINUE
1766 KFL(1)=K(IJU(IU),2)
1767 PX(1)=0.
1768 PY(1)=0.
1769 GAM(1)=0.
1770 DO 350 J=1,5
1771 PJU(IU+3,J)=0.
1772 350 CONTINUE
1773
1774C...Junction strings: find initial transverse directions.
1775 DO 360 J=1,4
1776 DP(1,J)=P(IN(4),J)
1777 DP(2,J)=P(IN(4)+1,J)
1778 DP(3,J)=0.
1779 DP(4,J)=0.
1780 360 CONTINUE
1781 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1782 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1783 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1784 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1785 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1786 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1787 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1788 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1789 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1790 DHC12=DFOUR(1,2)
1791 DHCX1=DFOUR(3,1)/DHC12
1792 DHCX2=DFOUR(3,2)/DHC12
1793 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1794 DHCY1=DFOUR(4,1)/DHC12
1795 DHCY2=DFOUR(4,2)/DHC12
1796 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1797 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1798 DO 370 J=1,4
1799 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1800 P(IN(6),J)=DP(3,J)
1801 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1802 &DHCYX*DP(3,J))
1803 370 CONTINUE
1804
1805C...Junction strings: produce new particle, origin.
1806 380 I=I+1
1807 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1808 CALL LYERRM(11,'(LYSTRF:) no more memory left in LUJETS')
1809 IF(MSTU(21).GE.1) RETURN
1810 ENDIF
1811 IRANKJ=IRANKJ+1
1812 K(I,1)=1
1813 K(I,3)=IE(1)
1814 K(I,4)=0
1815 K(I,5)=0
1816
1817C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1818 390 CALL LYKFDI(KFL(1),0,KFL(3),K(I,2))
1819 IF(K(I,2).EQ.0) GOTO 320
1820 IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1821 &IABS(KFL(3)).GT.10) THEN
1822 IF(RLY(0).GT.PARJ(19)) GOTO 390
1823 ENDIF
1824 P(I,5)=UYMASS(K(I,2))
1825 CALL LYPTDI(KFL(1),PX(3),PY(3))
1826 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1827 CALL LYZDIS(KFL(1),KFL(3),PR(1),Z)
1828 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
1829 &MSTU(90).LT.8) THEN
1830 MSTU(90)=MSTU(90)+1
1831 MSTU(90+MSTU(90))=I
1832 PARU(90+MSTU(90))=Z
1833 ENDIF
1834 GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1835 DO 400 J=1,3
1836 IN(J)=IN(3+J)
1837 400 CONTINUE
1838
1839C...Junction strings: stepping within or from 'low' string region easy.
1840 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1841 &P(IN(1),5)**2.GE.PR(1)) THEN
1842 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1843 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1844 DO 410 J=1,4
1845 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1846 410 CONTINUE
1847 GOTO 500
1848 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1849 P(IN(2)+2,4)=P(IN(2)+2,3)
1850 P(IN(2)+2,1)=1.
1851 IN(2)=IN(2)+4
1852 IF(IN(2).GT.N+NR+4*NS) GOTO 320
1853 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1854 P(IN(1)+2,4)=P(IN(1)+2,3)
1855 P(IN(1)+2,1)=0.
1856 IN(1)=IN(1)+4
1857 ENDIF
1858 ENDIF
1859
1860C...Junction strings: find new transverse directions.
1861 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1862 &IN(1).GT.IN(2)) GOTO 320
1863 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1864 DO 430 J=1,4
1865 DP(1,J)=P(IN(1),J)
1866 DP(2,J)=P(IN(2),J)
1867 DP(3,J)=0.
1868 DP(4,J)=0.
1869 430 CONTINUE
1870 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1871 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1872 DHC12=DFOUR(1,2)
1873 IF(DHC12.LE.1E-2) THEN
1874 P(IN(1)+2,4)=P(IN(1)+2,3)
1875 P(IN(1)+2,1)=0.
1876 IN(1)=IN(1)+4
1877 GOTO 420
1878 ENDIF
1879 IN(3)=N+NR+4*NS+5
1880 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1881 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1882 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1883 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1884 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1885 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1886 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1887 DHCX1=DFOUR(3,1)/DHC12
1888 DHCX2=DFOUR(3,2)/DHC12
1889 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1890 DHCY1=DFOUR(4,1)/DHC12
1891 DHCY2=DFOUR(4,2)/DHC12
1892 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1893 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1894 DO 440 J=1,4
1895 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1896 P(IN(3),J)=DP(3,J)
1897 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1898 & DHCYX*DP(3,J))
1899 440 CONTINUE
1900C...Express pT with respect to new axes, if sensible.
1901 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
1902 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
1903 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1904 PX(3)=PXP
1905 PY(3)=PYP
1906 ENDIF
1907 ENDIF
1908
1909C...Junction strings: sum up known four-momentum, coefficients for m2.
1910 DO 470 J=1,4
1911 DHG(J)=0.
1912 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1913 &PY(3)*P(IN(3)+1,J)
1914 DO 450 IN1=IN(4),IN(1)-4,4
1915 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1916 450 CONTINUE
1917 DO 460 IN2=IN(5),IN(2)-4,4
1918 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1919 460 CONTINUE
1920 470 CONTINUE
1921 DHM(1)=FOUR(I,I)
1922 DHM(2)=2.*FOUR(I,IN(1))
1923 DHM(3)=2.*FOUR(I,IN(2))
1924 DHM(4)=2.*FOUR(IN(1),IN(2))
1925
1926C...Junction strings: find coefficients for Gamma expression.
1927 DO 490 IN2=IN(1)+1,IN(2),4
1928 DO 480 IN1=IN(1),IN2-1,4
1929 DHC=2.*FOUR(IN1,IN2)
1930 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
1931 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
1932 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
1933 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1934 480 CONTINUE
1935 490 CONTINUE
1936
1937C...Junction strings: solve (m2, Gamma) equation system for energies.
1938 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1939 IF(ABS(DHS1).LT.1E-4) GOTO 320
1940 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1941 &(P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
1942 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
1943 P(IN(2)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
1944 &DHS2/DHS1)
1945 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0.) GOTO 320
1946 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
1947 &(DHM(2)+DHM(4)*P(IN(2)+2,4))
1948
1949C...Junction strings: step to new region if necessary.
1950 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1951 P(IN(2)+2,4)=P(IN(2)+2,3)
1952 P(IN(2)+2,1)=1.
1953 IN(2)=IN(2)+4
1954 IF(IN(2).GT.N+NR+4*NS) GOTO 320
1955 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1956 P(IN(1)+2,4)=P(IN(1)+2,3)
1957 P(IN(1)+2,1)=0.
1958 IN(1)=IN(1)+4
1959 ENDIF
1960 GOTO 420
1961 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1962 P(IN(1)+2,4)=P(IN(1)+2,3)
1963 P(IN(1)+2,1)=0.
1964 IN(1)=IN(1)+JS
1965 GOTO 820
1966 ENDIF
1967
1968C...Junction strings: particle four-momentum, remainder, loop back.
1969 500 DO 510 J=1,4
1970 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1971 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1972 510 CONTINUE
1973 IF(P(I,4).LT.P(I,5)) GOTO 320
1974 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1975 &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1976 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1977 KFL(1)=-KFL(3)
1978 PX(1)=-PX(3)
1979 PY(1)=-PY(3)
1980 GAM(1)=GAM(3)
1981 IF(IN(3).NE.IN(6)) THEN
1982 DO 520 J=1,4
1983 P(IN(6),J)=P(IN(3),J)
1984 P(IN(6)+1,J)=P(IN(3)+1,J)
1985 520 CONTINUE
1986 ENDIF
1987 DO 530 JQ=1,2
1988 IN(3+JQ)=IN(JQ)
1989 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1990 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1991 530 CONTINUE
1992 GOTO 380
1993 ENDIF
1994
1995C...Junction strings: save quantities left after each string.
1996 IF(IABS(KFL(1)).GT.10) GOTO 320
1997 I=I-1
1998 KFJH(IU)=KFL(1)
1999 DO 540 J=1,4
2000 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
2001 540 CONTINUE
2002 550 CONTINUE
2003
2004C...Junction strings: put together to new effective string endpoint.
2005 NJS(JT)=I-ISTA
2006 KFJS(JT)=K(K(MJU(JT+2),3),2)
2007 KFLS=2*INT(RLY(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
2008 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
2009 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
2010 &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
2011 &KFLS,KFJH(1))
2012 DO 560 J=1,4
2013 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
2014 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
2015 560 CONTINUE
2016 PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
2017 &PJS(JT,3)**2))
2018 570 CONTINUE
2019
2020C...Open versus closed strings. Choose breakup region for latter.
2021 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
2022 NS=MJU(2)-MJU(1)
2023 NB=MJU(1)-N
2024 ELSEIF(MJU(1).NE.0) THEN
2025 NS=N+NR-MJU(1)
2026 NB=MJU(1)-N
2027 ELSEIF(MJU(2).NE.0) THEN
2028 NS=MJU(2)-N
2029 NB=1
2030 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
2031 NS=NR-1
2032 NB=1
2033 ELSE
2034 NS=NR+1
2035 W2SUM=0.
2036 DO 590 IS=1,NR
2037 P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
2038 W2SUM=W2SUM+P(N+NR+IS,1)
2039 590 CONTINUE
2040 W2RAN=RLY(0)*W2SUM
2041 NB=0
2042 600 NB=NB+1
2043 W2SUM=W2SUM-P(N+NR+NB,1)
2044 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
2045 ENDIF
2046
2047C...Find longitudinal string directions (i.e. lightlike four-vectors).
2048 DO 630 IS=1,NS
2049 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
2050 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
2051 DO 610 J=1,5
2052 DP(1,J)=P(IS1,J)
2053 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5*DP(1,J)
2054 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
2055 DP(2,J)=P(IS2,J)
2056 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5*DP(2,J)
2057 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
2058 610 CONTINUE
2059 DP(3,5)=DFOUR(1,1)
2060 DP(4,5)=DFOUR(2,2)
2061 DHKC=DFOUR(1,2)
2062 IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
2063 DP(3,5)=DP(1,5)**2
2064 DP(4,5)=DP(2,5)**2
2065 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
2066 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
2067 DHKC=DFOUR(1,2)
2068 ENDIF
2069 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
2070 DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
2071 DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
2072 IN1=N+NR+4*IS-3
2073 P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
2074 DO 620 J=1,4
2075 P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
2076 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
2077 620 CONTINUE
2078 630 CONTINUE
2079
2080C...Begin initialization: sum up energy, set starting position.
2081 ISAV=I
2082 MSTU91=MSTU(90)
2083 640 NTRY=NTRY+1
2084 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
2085 PARU12=4.*PARU12
2086 PARU13=2.*PARU13
2087 GOTO 140
2088 ELSEIF(NTRY.GT.100) THEN
2089 CALL LYERRM(14,'(LYSTRF:) caught in infinite loop')
2090 IF(MSTU(21).GE.1) RETURN
2091 ENDIF
2092 I=ISAV
2093 MSTU(90)=MSTU91
2094 DO 660 J=1,4
2095 P(N+NRS,J)=0.
2096 DO 650 IS=1,NR
2097 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
2098 650 CONTINUE
2099 660 CONTINUE
2100 DO 680 JT=1,2
2101 IRANK(JT)=0
2102 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
2103 IF(NS.GT.NR) IRANK(JT)=1
2104 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
2105 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
2106 IN(3*JT+2)=IN(3*JT+1)+1
2107 IN(3*JT+3)=N+NR+4*NS+2*JT-1
2108 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
2109 P(IN1,1)=2-JT
2110 P(IN1,2)=JT-1
2111 P(IN1,3)=1.
2112 670 CONTINUE
2113 680 CONTINUE
2114
2115C...Initialize flavour and pT variables for open string.
2116 IF(NS.LT.NR) THEN
2117 PX(1)=0.
2118 PY(1)=0.
2119 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LYPTDI(0,PX(1),PY(1))
2120 PX(2)=-PX(1)
2121 PY(2)=-PY(1)
2122 DO 690 JT=1,2
2123 KFL(JT)=K(IE(JT),2)
2124 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
2125 MSTJ(93)=1
2126 PMQ(JT)=UYMASS(KFL(JT))
2127 GAM(JT)=0.
2128 690 CONTINUE
2129
2130C...Closed string: random initial breakup flavour, pT and vertex.
2131 ELSE
2132 KFL(3)=INT(1.+(2.+PARJ(2))*RLY(0))*(-1)**INT(RLY(0)+0.5)
2133 CALL LYKFDI(KFL(3),0,KFL(1),KDUMP)
2134 KFL(2)=-KFL(1)
2135 IF(IABS(KFL(1)).GT.10.AND.RLY(0).GT.0.5) THEN
2136 KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
2137 ELSEIF(IABS(KFL(1)).GT.10) THEN
2138 KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
2139 ENDIF
2140 CALL LYPTDI(KFL(1),PX(1),PY(1))
2141 PX(2)=-PX(1)
2142 PY(2)=-PY(1)
2143 PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
2144 700 CALL LYZDIS(KFL(1),KFL(2),PR3,Z)
2145 ZR=PR3/(Z*P(N+NR+1,5)**2)
2146 IF(ZR.GE.1.) GOTO 700
2147 DO 710 JT=1,2
2148 MSTJ(93)=1
2149 PMQ(JT)=UYMASS(KFL(JT))
2150 GAM(JT)=PR3*(1.-Z)/Z
2151 IN1=N+NR+3+4*(JT/2)*(NS-1)
2152 P(IN1,JT)=1.-Z
2153 P(IN1,3-JT)=JT-1
2154 P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
2155 P(IN1+1,JT)=ZR
2156 P(IN1+1,3-JT)=2-JT
2157 P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
2158 710 CONTINUE
2159 ENDIF
2160
2161C...Find initial transverse directions (i.e. spacelike four-vectors).
2162 DO 750 JT=1,2
2163 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
2164 IN1=IN(3*JT+1)
2165 IN3=IN(3*JT+3)
2166 DO 720 J=1,4
2167 DP(1,J)=P(IN1,J)
2168 DP(2,J)=P(IN1+1,J)
2169 DP(3,J)=0.
2170 DP(4,J)=0.
2171 720 CONTINUE
2172 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2173 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2174 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2175 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2176 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2177 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2178 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2179 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2180 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2181 DHC12=DFOUR(1,2)
2182 DHCX1=DFOUR(3,1)/DHC12
2183 DHCX2=DFOUR(3,2)/DHC12
2184 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2185 DHCY1=DFOUR(4,1)/DHC12
2186 DHCY2=DFOUR(4,2)/DHC12
2187 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2188 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2189 DO 730 J=1,4
2190 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2191 P(IN3,J)=DP(3,J)
2192 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2193 & DHCYX*DP(3,J))
2194 730 CONTINUE
2195 ELSE
2196 DO 740 J=1,4
2197 P(IN3+2,J)=P(IN3,J)
2198 P(IN3+3,J)=P(IN3+1,J)
2199 740 CONTINUE
2200 ENDIF
2201 750 CONTINUE
2202
2203C...Remove energy used up in junction string fragmentation.
2204 IF(MJU(1)+MJU(2).GT.0) THEN
2205 DO 770 JT=1,2
2206 IF(NJS(JT).EQ.0) GOTO 770
2207 DO 760 J=1,4
2208 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
2209 760 CONTINUE
2210 770 CONTINUE
2211 ENDIF
2212
2213C...Produce new particle: side, origin.
2214 780 I=I+1
2215 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
2216 CALL LYERRM(11,'(LYSTRF:) no more memory left in LUJETS')
2217 IF(MSTU(21).GE.1) RETURN
2218 ENDIF
2219 JT=1.5+RLY(0)
2220 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
2221 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
2222 JR=3-JT
2223 JS=3-2*JT
2224 IRANK(JT)=IRANK(JT)+1
2225 K(I,1)=1
2226 K(I,3)=IE(JT)
2227 K(I,4)=0
2228 K(I,5)=0
2229
2230C...Generate flavour, hadron and pT.
2231 790 CALL LYKFDI(KFL(JT),0,KFL(3),K(I,2))
2232 IF(K(I,2).EQ.0) GOTO 640
2233 IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
2234 &IABS(KFL(3)).GT.10) THEN
2235 IF(RLY(0).GT.PARJ(19)) GOTO 790
2236 ENDIF
2237 P(I,5)=UYMASS(K(I,2))
2238 CALL LYPTDI(KFL(JT),PX(3),PY(3))
2239 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
2240
2241C...Final hadrons for small invariant mass.
2242 MSTJ(93)=1
2243 PMQ(3)=UYMASS(KFL(3))
2244 PARJST=PARJ(33)
2245 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
2246 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
2247 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
2248 &WMIN-0.5*PARJ(36)*PMQ(3)
2249 WREM2=FOUR(N+NRS,N+NRS)
2250 IF(WREM2.LT.0.10) GOTO 640
2251 IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLY(0)-1.)*PARJ(37)),
2252 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 940
2253
2254C...Choose z, which gives Gamma. Shift z for heavy flavours.
2255 CALL LYZDIS(KFL(JT),KFL(3),PR(JT),Z)
2256 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
2257 &MSTU(90).LT.8) THEN
2258 MSTU(90)=MSTU(90)+1
2259 MSTU(90+MSTU(90))=I
2260 PARU(90+MSTU(90))=Z
2261 ENDIF
2262 KFL1A=IABS(KFL(1))
2263 KFL2A=IABS(KFL(2))
2264 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2265 &MOD(KFL2A/1000,10)).GE.4) THEN
2266 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2267 PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
2268 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
2269 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2270 IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 940
2271 ENDIF
2272 GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
2273 DO 800 J=1,3
2274 IN(J)=IN(3*JT+J)
2275 800 CONTINUE
2276
2277C...Stepping within or from 'low' string region easy.
2278 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
2279 &P(IN(1),5)**2.GE.PR(JT)) THEN
2280 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
2281 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
2282 DO 810 J=1,4
2283 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
2284 810 CONTINUE
2285 GOTO 900
2286 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
2287 P(IN(JR)+2,4)=P(IN(JR)+2,3)
2288 P(IN(JR)+2,JT)=1.
2289 IN(JR)=IN(JR)+4*JS
2290 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
2291 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2292 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2293 P(IN(JT)+2,JT)=0.
2294 IN(JT)=IN(JT)+4*JS
2295 ENDIF
2296 ENDIF
2297
2298C...Find new transverse directions (i.e. spacelike string vectors).
2299 820 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
2300 &IN(1).GT.IN(2)) GOTO 640
2301 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
2302 DO 830 J=1,4
2303 DP(1,J)=P(IN(1),J)
2304 DP(2,J)=P(IN(2),J)
2305 DP(3,J)=0.
2306 DP(4,J)=0.
2307 830 CONTINUE
2308 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2309 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2310 DHC12=DFOUR(1,2)
2311 IF(DHC12.LE.1E-2) THEN
2312 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2313 P(IN(JT)+2,JT)=0.
2314 IN(JT)=IN(JT)+4*JS
2315 GOTO 820
2316 ENDIF
2317 IN(3)=N+NR+4*NS+5
2318 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2319 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2320 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2321 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2322 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2323 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2324 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2325 DHCX1=DFOUR(3,1)/DHC12
2326 DHCX2=DFOUR(3,2)/DHC12
2327 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2328 DHCY1=DFOUR(4,1)/DHC12
2329 DHCY2=DFOUR(4,2)/DHC12
2330 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2331 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2332 DO 840 J=1,4
2333 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2334 P(IN(3),J)=DP(3,J)
2335 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2336 & DHCYX*DP(3,J))
2337 840 CONTINUE
2338C...Express pT with respect to new axes, if sensible.
2339 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
2340 & FOUR(IN(3*JT+3)+1,IN(3)))
2341 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
2342 & FOUR(IN(3*JT+3)+1,IN(3)+1))
2343 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
2344 PX(3)=PXP
2345 PY(3)=PYP
2346 ENDIF
2347 ENDIF
2348
2349C...Sum up known four-momentum. Gives coefficients for m2 expression.
2350 DO 870 J=1,4
2351 DHG(J)=0.
2352 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
2353 &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
2354 DO 850 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
2355 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
2356 850 CONTINUE
2357 DO 860 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
2358 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
2359 860 CONTINUE
2360 870 CONTINUE
2361 DHM(1)=FOUR(I,I)
2362 DHM(2)=2.*FOUR(I,IN(1))
2363 DHM(3)=2.*FOUR(I,IN(2))
2364 DHM(4)=2.*FOUR(IN(1),IN(2))
2365
2366C...Find coefficients for Gamma expression.
2367 DO 890 IN2=IN(1)+1,IN(2),4
2368 DO 880 IN1=IN(1),IN2-1,4
2369 DHC=2.*FOUR(IN1,IN2)
2370 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
2371 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
2372 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
2373 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
2374 880 CONTINUE
2375 890 CONTINUE
2376
2377C...Solve (m2, Gamma) equation system for energies taken.
2378 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
2379 IF(ABS(DHS1).LT.1E-4) GOTO 640
2380 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
2381 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
2382 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
2383 P(IN(JR)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
2384 &DHS2/DHS1)
2385 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0.) GOTO 640
2386 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
2387 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
2388
2389C...Step to new region if necessary.
2390 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
2391 P(IN(JR)+2,4)=P(IN(JR)+2,3)
2392 P(IN(JR)+2,JT)=1.
2393 IN(JR)=IN(JR)+4*JS
2394 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
2395 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2396 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2397 P(IN(JT)+2,JT)=0.
2398 IN(JT)=IN(JT)+4*JS
2399 ENDIF
2400 GOTO 820
2401 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
2402 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2403 P(IN(JT)+2,JT)=0.
2404 IN(JT)=IN(JT)+4*JS
2405 GOTO 820
2406 ENDIF
2407
2408C...Four-momentum of particle. Remaining quantities. Loop back.
2409 900 DO 910 J=1,4
2410 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
2411 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
2412 910 CONTINUE
2413 IF(P(I,4).LT.P(I,5)) GOTO 640
2414 KFL(JT)=-KFL(3)
2415 PMQ(JT)=PMQ(3)
2416 PX(JT)=-PX(3)
2417 PY(JT)=-PY(3)
2418 GAM(JT)=GAM(3)
2419 IF(IN(3).NE.IN(3*JT+3)) THEN
2420 DO 920 J=1,4
2421 P(IN(3*JT+3),J)=P(IN(3),J)
2422 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
2423 920 CONTINUE
2424 ENDIF
2425 DO 930 JQ=1,2
2426 IN(3*JT+JQ)=IN(JQ)
2427 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
2428 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
2429 930 CONTINUE
2430 GOTO 780
2431
2432C...Final hadron: side, flavour, hadron, mass.
2433 940 I=I+1
2434 K(I,1)=1
2435 K(I,3)=IE(JR)
2436 K(I,4)=0
2437 K(I,5)=0
2438 CALL LYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
2439 IF(K(I,2).EQ.0) GOTO 640
2440 P(I,5)=UYMASS(K(I,2))
2441 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2442
2443C...Final two hadrons: find common setup of four-vectors.
2444 JQ=1
2445 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
2446 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
2447 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
2448 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
2449 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
2450 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
2451 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
2452 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
2453 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
2454 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
2455 ENDIF
2456
2457C...Solve kinematics for final two hadrons, if possible.
2458 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
2459 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
2460 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 200
2461 IF(FD.GE.1.) GOTO 640
2462 FA=WREM2+PR(JT)-PR(JR)
2463 IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-50.,LOG(FD)*PARJ(38)*
2464 &(PR(1)+PR(2))**2))
2465 IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(39)
2466 FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLY(0)-PREV))
2467 KFL1A=IABS(KFL(1))
2468 KFL2A=IABS(KFL(2))
2469 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2470 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
2471 &4.*WREM2*PR(JT))),FLOAT(JS))
2472 DO 950 J=1,4
2473 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
2474 &P(IN(3*JQ+3)+1,J)+0.5*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
2475 &DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
2476 P(I,J)=P(N+NRS,J)-P(I-1,J)
2477 950 CONTINUE
2478 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
2479
2480C...Mark jets as fragmented and give daughter pointers.
2481 N=I-NRS+1
2482 DO 960 I=NSAV+1,NSAV+NP
2483 IM=K(I,3)
2484 K(IM,1)=K(IM,1)+10
2485 IF(MSTU(16).NE.2) THEN
2486 K(IM,4)=NSAV+1
2487 K(IM,5)=NSAV+1
2488 ELSE
2489 K(IM,4)=NSAV+2
2490 K(IM,5)=N
2491 ENDIF
2492 960 CONTINUE
2493
2494C...Document string system. Move up particles.
2495 NSAV=NSAV+1
2496 K(NSAV,1)=11
2497 K(NSAV,2)=92
2498 K(NSAV,3)=IP
2499 K(NSAV,4)=NSAV+1
2500 K(NSAV,5)=N
2501 DO 970 J=1,4
2502 P(NSAV,J)=DPS(J)
2503 V(NSAV,J)=V(IP,J)
2504 970 CONTINUE
2505 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2506 V(NSAV,5)=0.
2507 DO 990 I=NSAV+1,N
2508 DO 980 J=1,5
2509 K(I,J)=K(I+NRS-1,J)
2510 P(I,J)=P(I+NRS-1,J)
2511 V(I,J)=0.
2512 980 CONTINUE
2513 990 CONTINUE
2514 MSTU91=MSTU(90)
2515 DO 1000 IZ=MSTU90+1,MSTU91
2516 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
2517 PARU9T(IZ)=PARU(90+IZ)
2518 1000 CONTINUE
2519 MSTU(90)=MSTU90
2520
2521C...Order particles in rank along the chain. Update mother pointer.
2522 DO 1020 I=NSAV+1,N
2523 DO 1010 J=1,5
2524 K(I-NSAV+N,J)=K(I,J)
2525 P(I-NSAV+N,J)=P(I,J)
2526 1010 CONTINUE
2527 1020 CONTINUE
2528 I1=NSAV
2529 DO 1050 I=N+1,2*N-NSAV
2530 IF(K(I,3).NE.IE(1)) GOTO 1050
2531 I1=I1+1
2532 DO 1030 J=1,5
2533 K(I1,J)=K(I,J)
2534 P(I1,J)=P(I,J)
2535 1030 CONTINUE
2536 IF(MSTU(16).NE.2) K(I1,3)=NSAV
2537 DO 1040 IZ=MSTU90+1,MSTU91
2538 IF(MSTU9T(IZ).EQ.I) THEN
2539 MSTU(90)=MSTU(90)+1
2540 MSTU(90+MSTU(90))=I1
2541 PARU(90+MSTU(90))=PARU9T(IZ)
2542 ENDIF
2543 1040 CONTINUE
2544 1050 CONTINUE
2545 DO 1080 I=2*N-NSAV,N+1,-1
2546 IF(K(I,3).EQ.IE(1)) GOTO 1080
2547 I1=I1+1
2548 DO 1060 J=1,5
2549 K(I1,J)=K(I,J)
2550 P(I1,J)=P(I,J)
2551 1060 CONTINUE
2552 IF(MSTU(16).NE.2) K(I1,3)=NSAV
2553 DO 1070 IZ=MSTU90+1,MSTU91
2554 IF(MSTU9T(IZ).EQ.I) THEN
2555 MSTU(90)=MSTU(90)+1
2556 MSTU(90+MSTU(90))=I1
2557 PARU(90+MSTU(90))=PARU9T(IZ)
2558 ENDIF
2559 1070 CONTINUE
2560 1080 CONTINUE
2561
2562C...Boost back particle system. Set production vertices.
2563 IF(MBST.EQ.0) THEN
2564 MSTU(33)=1
2565 CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
2566 & DPS(3)/DPS(4))
2567 ELSE
2568 DO 1090 I=NSAV+1,N
2569 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
2570 IF(P(I,3).GT.0.) THEN
2571 HHPEZ=(P(I,4)+P(I,3))*HHBZ
2572 P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
2573 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2574 ELSE
2575 HHPEZ=(P(I,4)-P(I,3))/HHBZ
2576 P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
2577 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2578 ENDIF
2579 1090 CONTINUE
2580 ENDIF
2581 DO 1110 I=NSAV+1,N
2582 DO 1100 J=1,4
2583 V(I,J)=V(IP,J)
2584 1100 CONTINUE
2585 1110 CONTINUE
2586
2587 RETURN
2588 END
2589
2590C*********************************************************************
2591
2592 SUBROUTINE LYINDF(IP)
2593
2594C...Purpose: to handle the fragmentation of a jet system (or a single
2595C...jet) according to independent fragmentation models.
2596 IMPLICIT DOUBLE PRECISION(D)
2597 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
2598 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2599 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2600 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
2601 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
2602 &KFLO(2),PXO(2),PYO(2),WO(2)
2603
2604C...Reset counters. Identify parton system and take copy. Check flavour.
2605 NSAV=N
2606 MSTU90=MSTU(90)
2607 NJET=0
2608 KQSUM=0
2609 DO 100 J=1,5
2610 DPS(J)=0.
2611 100 CONTINUE
2612 I=IP-1
2613 110 I=I+1
2614 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
2615 CALL LYERRM(12,'(LYINDF:) failed to reconstruct jet system')
2616 IF(MSTU(21).GE.1) RETURN
2617 ENDIF
2618 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
2619 KC=LYCOMP(K(I,2))
2620 IF(KC.EQ.0) GOTO 110
2621 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2622 IF(KQ.EQ.0) GOTO 110
2623 NJET=NJET+1
2624 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2625 DO 120 J=1,5
2626 K(NSAV+NJET,J)=K(I,J)
2627 P(NSAV+NJET,J)=P(I,J)
2628 DPS(J)=DPS(J)+P(I,J)
2629 120 CONTINUE
2630 K(NSAV+NJET,3)=I
2631 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
2632 &K(I+1,1).EQ.2)) GOTO 110
2633 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
2634 CALL LYERRM(12,'(LYINDF:) unphysical flavour combination')
2635 IF(MSTU(21).GE.1) RETURN
2636 ENDIF
2637
2638C...Boost copied system to CM frame. Find CM energy and sum flavours.
2639 IF(NJET.NE.1) THEN
2640 MSTU(33)=1
2641 CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
2642 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
2643 ENDIF
2644 PECM=0.
2645 DO 130 J=1,3
2646 NFI(J)=0
2647 130 CONTINUE
2648 DO 140 I=NSAV+1,NSAV+NJET
2649 PECM=PECM+P(I,4)
2650 KFA=IABS(K(I,2))
2651 IF(KFA.LE.3) THEN
2652 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
2653 ELSEIF(KFA.GT.1000) THEN
2654 KFLA=MOD(KFA/1000,10)
2655 KFLB=MOD(KFA/100,10)
2656 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
2657 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
2658 ENDIF
2659 140 CONTINUE
2660
2661C...Loop over attempts made. Reset counters.
2662 NTRY=0
2663 150 NTRY=NTRY+1
2664 IF(NTRY.GT.200) THEN
2665 CALL LYERRM(14,'(LYINDF:) caught in infinite loop')
2666 IF(MSTU(21).GE.1) RETURN
2667 ENDIF
2668 N=NSAV+NJET
2669 MSTU(90)=MSTU90
2670 DO 160 J=1,3
2671 NFL(J)=NFI(J)
2672 IFET(J)=0
2673 KFLF(J)=0
2674 160 CONTINUE
2675
2676C...Loop over jets to be fragmented.
2677 DO 230 IP1=NSAV+1,NSAV+NJET
2678 MSTJ(91)=0
2679 NSAV1=N
2680 MSTU91=MSTU(90)
2681
2682C...Initial flavour and momentum values. Jet along +z axis.
2683 KFLH=IABS(K(IP1,2))
2684 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
2685 KFLO(2)=0
2686 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
2687
2688C...Initial values for quark or diquark jet.
2689 170 IF(IABS(K(IP1,2)).NE.21) THEN
2690 NSTR=1
2691 KFLO(1)=K(IP1,2)
2692 CALL LYPTDI(0,PXO(1),PYO(1))
2693 WO(1)=WF
2694
2695C...Initial values for gluon treated like random quark jet.
2696 ELSEIF(MSTJ(2).LE.2) THEN
2697 NSTR=1
2698 IF(MSTJ(2).EQ.2) MSTJ(91)=1
2699 KFLO(1)=INT(1.+(2.+PARJ(2))*RLY(0))*(-1)**INT(RLY(0)+0.5)
2700 CALL LYPTDI(0,PXO(1),PYO(1))
2701 WO(1)=WF
2702
2703C...Initial values for gluon treated like quark-antiquark jet pair,
2704C...sharing energy according to Altarelli-Parisi splitting function.
2705 ELSE
2706 NSTR=2
2707 IF(MSTJ(2).EQ.4) MSTJ(91)=1
2708 KFLO(1)=INT(1.+(2.+PARJ(2))*RLY(0))*(-1)**INT(RLY(0)+0.5)
2709 KFLO(2)=-KFLO(1)
2710 CALL LYPTDI(0,PXO(1),PYO(1))
2711 PXO(2)=-PXO(1)
2712 PYO(2)=-PYO(1)
2713 WO(1)=WF*RLY(0)**(1./3.)
2714 WO(2)=WF-WO(1)
2715 ENDIF
2716
2717C...Initial values for rank, flavour, pT and W+.
2718 DO 220 ISTR=1,NSTR
2719 180 I=N
2720 MSTU(90)=MSTU91
2721 IRANK=0
2722 KFL1=KFLO(ISTR)
2723 PX1=PXO(ISTR)
2724 PY1=PYO(ISTR)
2725 W=WO(ISTR)
2726
2727C...New hadron. Generate flavour and hadron species.
2728 190 I=I+1
2729 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
2730 CALL LYERRM(11,'(LYINDF:) no more memory left in LUJETS')
2731 IF(MSTU(21).GE.1) RETURN
2732 ENDIF
2733 IRANK=IRANK+1
2734 K(I,1)=1
2735 K(I,3)=IP1
2736 K(I,4)=0
2737 K(I,5)=0
2738 200 CALL LYKFDI(KFL1,0,KFL2,K(I,2))
2739 IF(K(I,2).EQ.0) GOTO 180
2740 IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
2741 &IABS(KFL2).GT.10) THEN
2742 IF(RLY(0).GT.PARJ(19)) GOTO 200
2743 ENDIF
2744
2745C...Find hadron mass. Generate four-momentum.
2746 P(I,5)=UYMASS(K(I,2))
2747 CALL LYPTDI(KFL1,PX2,PY2)
2748 P(I,1)=PX1+PX2
2749 P(I,2)=PY1+PY2
2750 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
2751 CALL LYZDIS(KFL1,KFL2,PR,Z)
2752 MZSAV=0
2753 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
2754 MZSAV=1
2755 MSTU(90)=MSTU(90)+1
2756 MSTU(90+MSTU(90))=I
2757 PARU(90+MSTU(90))=Z
2758 ENDIF
2759 P(I,3)=0.5*(Z*W-PR/MAX(1E-4,Z*W))
2760 P(I,4)=0.5*(Z*W+PR/MAX(1E-4,Z*W))
2761 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
2762 &P(I,3).LE.0.001) THEN
2763 IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
2764 P(I,3)=0.0001
2765 P(I,4)=SQRT(PR)
2766 Z=P(I,4)/W
2767 ENDIF
2768
2769C...Remaining flavour and momentum.
2770 KFL1=-KFL2
2771 PX1=-PX2
2772 PY1=-PY2
2773 W=(1.-Z)*W
2774 DO 210 J=1,5
2775 V(I,J)=0.
2776 210 CONTINUE
2777
2778C...Check if pL acceptable. Go back for new hadron if enough energy.
2779 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) THEN
2780 I=I-1
2781 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
2782 ENDIF
2783 IF(W.GT.PARJ(31)) GOTO 190
2784 N=I
2785 220 CONTINUE
2786 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2787 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2788
2789C...Rotate jet to new direction.
2790 THE=UYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2791 PHI=UYANGL(P(IP1,1),P(IP1,2))
2792 MSTU(33)=1
2793 CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2794 K(K(IP1,3),4)=NSAV1+1
2795 K(K(IP1,3),5)=N
2796
2797C...End of jet generation loop. Skip conservation in some cases.
2798 230 CONTINUE
2799 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
2800 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2801
2802C...Subtract off produced hadron flavours, finished if zero.
2803 DO 240 I=NSAV+NJET+1,N
2804 KFA=IABS(K(I,2))
2805 KFLA=MOD(KFA/1000,10)
2806 KFLB=MOD(KFA/100,10)
2807 KFLC=MOD(KFA/10,10)
2808 IF(KFLA.EQ.0) THEN
2809 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2810 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2811 ELSE
2812 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2813 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2814 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2815 ENDIF
2816 240 CONTINUE
2817 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2818 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2819 IF(NREQ.EQ.0) GOTO 320
2820
2821C...Take away flavour of low-momentum particles until enough freedom.
2822 NREM=0
2823 250 IREM=0
2824 P2MIN=PECM**2
2825 DO 260 I=NSAV+NJET+1,N
2826 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2827 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2828 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2829 260 CONTINUE
2830 IF(IREM.EQ.0) GOTO 150
2831 K(IREM,1)=7
2832 KFA=IABS(K(IREM,2))
2833 KFLA=MOD(KFA/1000,10)
2834 KFLB=MOD(KFA/100,10)
2835 KFLC=MOD(KFA/10,10)
2836 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2837 IF(K(IREM,1).EQ.8) GOTO 250
2838 IF(KFLA.EQ.0) THEN
2839 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2840 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2841 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2842 ELSE
2843 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2844 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2845 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2846 ENDIF
2847 NREM=NREM+1
2848 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2849 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2850 IF(NREQ.GT.NREM) GOTO 250
2851 DO 270 I=NSAV+NJET+1,N
2852 IF(K(I,1).EQ.8) K(I,1)=1
2853 270 CONTINUE
2854
2855C...Find combination of existing and new flavours for hadron.
2856 280 NFET=2
2857 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2858 IF(NREQ.LT.NREM) NFET=1
2859 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2860 DO 290 J=1,NFET
2861 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLY(0)
2862 KFLF(J)=ISIGN(1,NFL(1))
2863 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2864 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2865 290 CONTINUE
2866 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2867 &GOTO 280
2868 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2869 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
2870 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2871 IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLY(0))
2872 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2873 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLY(0)),-KFLF(1))
2874 IF(NFET.LE.2) KFLF(3)=0
2875 IF(KFLF(3).NE.0) THEN
2876 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2877 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2878 IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLY(0).GT.1.)
2879 & KFLFC=KFLFC+ISIGN(2,KFLFC)
2880 ELSE
2881 KFLFC=KFLF(1)
2882 ENDIF
2883 CALL LYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2884 IF(KF.EQ.0) GOTO 280
2885 DO 300 J=1,MAX(2,NFET)
2886 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2887 300 CONTINUE
2888
2889C...Store hadron at random among free positions.
2890 NPOS=MIN(1+INT(RLY(0)*NREM),NREM)
2891 DO 310 I=NSAV+NJET+1,N
2892 IF(K(I,1).EQ.7) NPOS=NPOS-1
2893 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2894 K(I,1)=1
2895 K(I,2)=KF
2896 P(I,5)=UYMASS(K(I,2))
2897 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2898 310 CONTINUE
2899 NREM=NREM-1
2900 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2901 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2902 IF(NREM.GT.0) GOTO 280
2903
2904C...Compensate for missing momentum in global scheme (3 options).
2905 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
2906 DO 340 J=1,3
2907 PSI(J)=0.
2908 DO 330 I=NSAV+NJET+1,N
2909 PSI(J)=PSI(J)+P(I,J)
2910 330 CONTINUE
2911 340 CONTINUE
2912 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2913 PWS=0.
2914 DO 350 I=NSAV+NJET+1,N
2915 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2916 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2917 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2918 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2919 350 CONTINUE
2920 DO 370 I=NSAV+NJET+1,N
2921 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2922 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2923 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2924 IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2925 DO 360 J=1,3
2926 P(I,J)=P(I,J)-PSI(J)*PW/PWS
2927 360 CONTINUE
2928 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2929 370 CONTINUE
2930
2931C...Compensate for missing momentum withing each jet separately.
2932 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2933 DO 390 I=N+1,N+NJET
2934 K(I,1)=0
2935 DO 380 J=1,5
2936 P(I,J)=0.
2937 380 CONTINUE
2938 390 CONTINUE
2939 DO 410 I=NSAV+NJET+1,N
2940 IR1=K(I,3)
2941 IR2=N+IR1-NSAV
2942 K(IR2,1)=K(IR2,1)+1
2943 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2944 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2945 DO 400 J=1,3
2946 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2947 400 CONTINUE
2948 P(IR2,4)=P(IR2,4)+P(I,4)
2949 P(IR2,5)=P(IR2,5)+PLS
2950 410 CONTINUE
2951 PSS=0.
2952 DO 420 I=N+1,N+NJET
2953 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2954 420 CONTINUE
2955 DO 440 I=NSAV+NJET+1,N
2956 IR1=K(I,3)
2957 IR2=N+IR1-NSAV
2958 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2959 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2960 DO 430 J=1,3
2961 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2962 & P(IR1,J)
2963 430 CONTINUE
2964 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2965 440 CONTINUE
2966 ENDIF
2967
2968C...Scale momenta for energy conservation.
2969 IF(MOD(MSTJ(3),5).NE.0) THEN
2970 PMS=0.
2971 PES=0.
2972 PQS=0.
2973 DO 450 I=NSAV+NJET+1,N
2974 PMS=PMS+P(I,5)
2975 PES=PES+P(I,4)
2976 PQS=PQS+P(I,5)**2/P(I,4)
2977 450 CONTINUE
2978 IF(PMS.GE.PECM) GOTO 150
2979 NECO=0
2980 460 NECO=NECO+1
2981 PFAC=(PECM-PQS)/(PES-PQS)
2982 PES=0.
2983 PQS=0.
2984 DO 480 I=NSAV+NJET+1,N
2985 DO 470 J=1,3
2986 P(I,J)=PFAC*P(I,J)
2987 470 CONTINUE
2988 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2989 PES=PES+P(I,4)
2990 PQS=PQS+P(I,5)**2/P(I,4)
2991 480 CONTINUE
2992 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 460
2993 ENDIF
2994
2995C...Origin of produced particles and parton daughter pointers.
2996 490 DO 500 I=NSAV+NJET+1,N
2997 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2998 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
2999 500 CONTINUE
3000 DO 510 I=NSAV+1,NSAV+NJET
3001 I1=K(I,3)
3002 K(I1,1)=K(I1,1)+10
3003 IF(MSTU(16).NE.2) THEN
3004 K(I1,4)=NSAV+1
3005 K(I1,5)=NSAV+1
3006 ELSE
3007 K(I1,4)=K(I1,4)-NJET+1
3008 K(I1,5)=K(I1,5)-NJET+1
3009 IF(K(I1,5).LT.K(I1,4)) THEN
3010 K(I1,4)=0
3011 K(I1,5)=0
3012 ENDIF
3013 ENDIF
3014 510 CONTINUE
3015
3016C...Document independent fragmentation system. Remove copy of jets.
3017 NSAV=NSAV+1
3018 K(NSAV,1)=11
3019 K(NSAV,2)=93
3020 K(NSAV,3)=IP
3021 K(NSAV,4)=NSAV+1
3022 K(NSAV,5)=N-NJET+1
3023 DO 520 J=1,4
3024 P(NSAV,J)=DPS(J)
3025 V(NSAV,J)=V(IP,J)
3026 520 CONTINUE
3027 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
3028 V(NSAV,5)=0.
3029 DO 540 I=NSAV+NJET,N
3030 DO 530 J=1,5
3031 K(I-NJET+1,J)=K(I,J)
3032 P(I-NJET+1,J)=P(I,J)
3033 V(I-NJET+1,J)=V(I,J)
3034 530 CONTINUE
3035 540 CONTINUE
3036 N=N-NJET+1
3037 DO 550 IZ=MSTU90+1,MSTU(90)
3038 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
3039 550 CONTINUE
3040
3041C...Boost back particle system. Set production vertices.
3042 IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
3043 &DPS(2)/DPS(4),DPS(3)/DPS(4))
3044 DO 570 I=NSAV+1,N
3045 DO 560 J=1,4
3046 V(I,J)=V(IP,J)
3047 560 CONTINUE
3048 570 CONTINUE
3049
3050 RETURN
3051 END
3052
3053C*********************************************************************
3054
3055 SUBROUTINE LYDECY(IP)
3056
3057C...Purpose: to handle the decay of unstable particles.
3058 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
3059 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3060 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3061 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
3062 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
3063 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
3064 &WTCOR(10),PTAU(4),PCMTAU(4)
3065 DOUBLE PRECISION DBETAU(3)
3066 DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
3067
3068C...Functions: momentum in two-particle decays, four-product and
3069C...matrix element times phase space in weak decays.
3070 PAWT(A,B,C)=SQRT(ABS((A**2-(B+C)**2)*(A**2-(B-C)**2)))/(2.*A)
3071C...........added ABS because would go 10**-7 LT 0 (precision thing?)
3072C...........once per few 10**5 events -- jmiles 22.June.02
3073 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)
3074 HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
3075 &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
3076
3077C...Initial values.
3078 NTRY=0
3079 NSAV=N
3080 KFA=IABS(K(IP,2))
3081 KFS=ISIGN(1,K(IP,2))
3082 KC=LYCOMP(KFA)
3083 MSTJ(92)=0
3084
3085C...Choose lifetime and determine decay vertex.
3086 IF(K(IP,1).EQ.5) THEN
3087 V(IP,5)=0.
3088 ELSEIF(K(IP,1).NE.4) THEN
3089 V(IP,5)=-PMAS(KC,4)*LOG(RLY(0))
3090 ENDIF
3091 DO 100 J=1,4
3092 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
3093 100 CONTINUE
3094
3095C...Determine whether decay allowed or not.
3096 MOUT=0
3097 IF(MSTJ(22).EQ.2) THEN
3098 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
3099 ELSEIF(MSTJ(22).EQ.3) THEN
3100 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
3101 ELSEIF(MSTJ(22).EQ.4) THEN
3102 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
3103 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
3104 ENDIF
3105 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
3106 K(IP,1)=4
3107 RETURN
3108 ENDIF
3109
3110C...Interface to external tau decay library (for tau polarization).
3111 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
3112
3113C...Starting values for pointers and momenta.
3114 ITAU=IP
3115 DO 110 J=1,4
3116 PTAU(J)=P(ITAU,J)
3117 PCMTAU(J)=P(ITAU,J)
3118 110 CONTINUE
3119
3120C...Iterate to find position and code of mother of tau.
3121 IMTAU=ITAU
3122 120 IMTAU=K(IMTAU,3)
3123
3124 IF(IMTAU.EQ.0) THEN
3125C...If no known origin then impossible to do anything further.
3126 KFORIG=0
3127 IORIG=0
3128
3129 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
3130C...If tau -> tau + gamma then add gamma energy and loop.
3131 IF(K(K(IMTAU,4),2).EQ.22) THEN
3132 DO 130 J=1,4
3133 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
3134 130 CONTINUE
3135 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
3136 DO 140 J=1,4
3137 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
3138 140 CONTINUE
3139 ENDIF
3140 GOTO 120
3141
3142 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
3143C...If coming from weak decay of hadron then W is not stored in record,
3144C...but can be reconstructed by adding neutrino momentum.
3145 KFORIG=-ISIGN(24,K(ITAU,2))
3146 IORIG=0
3147 DO 160 II=K(IMTAU,4),K(IMTAU,5)
3148 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
3149 DO 150 J=1,4
3150 PCMTAU(J)=PCMTAU(J)+P(II,J)
3151 150 CONTINUE
3152 ENDIF
3153 160 CONTINUE
3154
3155 ELSE
3156C...If coming from resonance decay then find latest copy of this
3157C...resonance (may not completely agree).
3158 KFORIG=K(IMTAU,2)
3159 IORIG=IMTAU
3160 DO 170 II=IMTAU+1,IP-1
3161 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
3162 & ABS(P(II,5)-P(IORIG,5)).LT.1E-5*P(IORIG,5)) IORIG=II
3163 170 CONTINUE
3164 DO 180 J=1,4
3165 PCMTAU(J)=P(IORIG,J)
3166 180 CONTINUE
3167 ENDIF
3168
3169C...Boost tau to rest frame of production process (where known)
3170C...and rotate it to sit along +z axis.
3171 DO 190 J=1,3
3172 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
3173 190 CONTINUE
3174 IF(KFORIG.NE.0) CALL LUDBRB(ITAU,ITAU,0.,0.,-DBETAU(1),
3175 & -DBETAU(2),-DBETAU(3))
3176 PHITAU=UYANGL(P(ITAU,1),P(ITAU,2))
3177 CALL LUDBRB(ITAU,ITAU,0.,-PHITAU,0D0,0D0,0D0)
3178 THETAU=UYANGL(P(ITAU,3),P(ITAU,1))
3179 CALL LUDBRB(ITAU,ITAU,-THETAU,0.,0D0,0D0,0D0)
3180
3181C...Call tau decay routine (if meaningful) and fill extra info.
3182 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
3183 CALL LYTAUD(ITAU,IORIG,KFORIG,NDECAY)
3184 DO 200 II=NSAV+1,NSAV+NDECAY
3185 K(II,1)=1
3186 K(II,3)=IP
3187 K(II,4)=0
3188 K(II,5)=0
3189 200 CONTINUE
3190 N=NSAV+NDECAY
3191 ENDIF
3192
3193C...Boost back decay tau and decay products.
3194 DO 210 J=1,4
3195 P(ITAU,J)=PTAU(J)
3196 210 CONTINUE
3197 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
3198 CALL LUDBRB(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
3199 IF(KFORIG.NE.0) CALL LUDBRB(NSAV+1,N,0.,0.,DBETAU(1),
3200 & DBETAU(2),DBETAU(3))
3201
3202C...Skip past ordinary tau decay treatment.
3203 MMAT=0
3204 MBST=0
3205 ND=0
3206 GOTO 660
3207 ENDIF
3208 ENDIF
3209
3210C...B-B~ mixing: flip sign of meson appropriately.
3211 MMIX=0
3212 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
3213 XBBMIX=PARJ(76)
3214 IF(KFA.EQ.531) XBBMIX=PARJ(77)
3215 IF(SIN(0.5*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.RLY(0)) MMIX=1
3216 IF(MMIX.EQ.1) KFS=-KFS
3217 ENDIF
3218
3219C...Check existence of decay channels. Particle/antiparticle rules.
3220 KCA=KC
3221 IF(MDCY(KC,2).GT.0) THEN
3222 MDMDCY=MDME(MDCY(KC,2),2)
3223 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
3224 ENDIF
3225 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
3226 CALL LYERRM(9,'(LYDECY:) no decay channel defined')
3227 RETURN
3228 ENDIF
3229 IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
3230 IF(KCHG(KC,3).EQ.0) THEN
3231 KFSP=1
3232 KFSN=0
3233 IF(RLY(0).GT.0.5) KFS=-KFS
3234 ELSEIF(KFS.GT.0) THEN
3235 KFSP=1
3236 KFSN=0
3237 ELSE
3238 KFSP=0
3239 KFSN=1
3240 ENDIF
3241
3242C...Sum branching ratios of allowed decay channels.
3243 220 NOPE=0
3244 BRSU=0.
3245 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
3246 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
3247 &KFSN*MDME(IDL,1).NE.3) GOTO 230
3248 IF(MDME(IDL,2).GT.100) GOTO 230
3249 NOPE=NOPE+1
3250 BRSU=BRSU+BRAT(IDL)
3251 230 CONTINUE
3252 IF(NOPE.EQ.0) THEN
3253 CALL LYERRM(2,'(LYDECY:) all decay channels closed by user')
3254 RETURN
3255 ENDIF
3256
3257C...Select decay channel among allowed ones.
3258 240 RBR=BRSU*RLY(0)
3259 IDL=MDCY(KCA,2)-1
3260 250 IDL=IDL+1
3261 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
3262 &KFSN*MDME(IDL,1).NE.3) THEN
3263 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
3264 ELSEIF(MDME(IDL,2).GT.100) THEN
3265 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
3266 ELSE
3267 IDC=IDL
3268 RBR=RBR-BRAT(IDL)
3269 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 250
3270 ENDIF
3271
3272C...Start readout of decay channel: matrix element, reset counters.
3273 MMAT=MDME(IDC,2)
3274 260 NTRY=NTRY+1
3275 IF(NTRY.GT.1000) THEN
3276 CALL LYERRM(14,'(LYDECY:) caught in infinite loop')
3277 IF(MSTU(21).GE.1) RETURN
3278 ENDIF
3279 I=N
3280 NP=0
3281 NQ=0
3282 MBST=0
3283 IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
3284 DO 270 J=1,4
3285 PV(1,J)=0.
3286 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
3287 270 CONTINUE
3288 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
3289 PV(1,5)=P(IP,5)
3290 PS=0.
3291 PSQ=0.
3292 MREM=0
3293 MHADDY=0
3294 IF(KFA.GT.80) MHADDY=1
3295
3296C...Read out decay products. Convert to standard flavour code.
3297 JTMAX=5
3298 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
3299 DO 280 JT=1,JTMAX
3300 IF(JT.LE.5) KP=KFDP(IDC,JT)
3301 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
3302 IF(KP.EQ.0) GOTO 280
3303 KPA=IABS(KP)
3304 KCP=LYCOMP(KPA)
3305 IF(KPA.GT.80) MHADDY=1
3306 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
3307 KFP=KP
3308 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
3309 KFP=KFS*KP
3310 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
3311 KFP=-KFS*MOD(KFA/10,10)
3312 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
3313 KFP=KFS*(100*MOD(KFA/10,100)+3)
3314 ELSEIF(KPA.EQ.81) THEN
3315 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
3316 ELSEIF(KP.EQ.82) THEN
3317 CALL LYKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLY(0)),0,KFP,KDUMP)
3318 IF(KFP.EQ.0) GOTO 260
3319 MSTJ(93)=1
3320 IF(PV(1,5).LT.PARJ(32)+2.*UYMASS(KFP)) GOTO 260
3321 ELSEIF(KP.EQ.-82) THEN
3322 KFP=-KFP
3323 IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
3324 ENDIF
3325 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LYCOMP(KFP)
3326
3327C...Add decay product to event record or to quark flavour list.
3328 KFPA=IABS(KFP)
3329 KQP=KCHG(KCP,2)
3330 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
3331 NQ=NQ+1
3332 KFLO(NQ)=KFP
3333 MSTJ(93)=2
3334 PSQ=PSQ+UYMASS(KFLO(NQ))
3335 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
3336 &MOD(NQ,2).EQ.1) THEN
3337 NQ=NQ-1
3338 PS=PS-P(I,5)
3339 K(I,1)=1
3340 KFI=K(I,2)
3341 CALL LYKFDI(KFP,KFI,KFLDMP,K(I,2))
3342 IF(K(I,2).EQ.0) GOTO 260
3343 MSTJ(93)=1
3344 P(I,5)=UYMASS(K(I,2))
3345 PS=PS+P(I,5)
3346 ELSE
3347 I=I+1
3348 NP=NP+1
3349 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
3350 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
3351 K(I,1)=1+MOD(NQ,2)
3352 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
3353 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
3354 K(I,2)=KFP
3355 K(I,3)=IP
3356 K(I,4)=0
3357 K(I,5)=0
3358 P(I,5)=UYMASS(KFP)
3359 IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
3360 PS=PS+P(I,5)
3361 ENDIF
3362 280 CONTINUE
3363
3364C...Check masses for resonance decays.
3365 IF(MHADDY.EQ.0) THEN
3366 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
3367 ENDIF
3368
3369C...Choose decay multiplicity in phase space model.
3370 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
3371 PSP=PS
3372 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
3373 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
3374 300 NTRY=NTRY+1
3375 IF(NTRY.GT.1000) THEN
3376 CALL LYERRM(14,'(LYDECY:) caught in infinite loop')
3377 IF(MSTU(21).GE.1) RETURN
3378 ENDIF
3379 IF(MMAT.LE.20) THEN
3380 GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLY(0))))*
3381 & SIN(PARU(2)*RLY(0))
3382 ND=0.5+0.5*NP+0.25*NQ+CNDE+GAUSS
3383 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
3384 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
3385 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
3386 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
3387 ELSE
3388 ND=MMAT-20
3389 ENDIF
3390
3391C...Form hadrons from flavour content.
3392 DO 310 JT=1,4
3393 KFL1(JT)=KFLO(JT)
3394 310 CONTINUE
3395 IF(ND.EQ.NP+NQ/2) GOTO 330
3396 DO 320 I=N+NP+1,N+ND-NQ/2
3397 JT=1+INT((NQ-1)*RLY(0))
3398 CALL LYKFDI(KFL1(JT),0,KFL2,K(I,2))
3399 IF(K(I,2).EQ.0) GOTO 300
3400 KFL1(JT)=-KFL2
3401 320 CONTINUE
3402 330 JT=2
3403 JT2=3
3404 JT3=4
3405 IF(NQ.EQ.4.AND.RLY(0).LT.PARJ(66)) JT=4
3406 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
3407 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
3408 IF(JT.EQ.3) JT2=2
3409 IF(JT.EQ.4) JT3=2
3410 CALL LYKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
3411 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
3412 IF(NQ.EQ.4) CALL LYKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
3413 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
3414
3415C...Check that sum of decay product masses not too large.
3416 PS=PSP
3417 DO 340 I=N+NP+1,N+ND
3418 K(I,1)=1
3419 K(I,3)=IP
3420 K(I,4)=0
3421 K(I,5)=0
3422 P(I,5)=UYMASS(K(I,2))
3423 PS=PS+P(I,5)
3424 340 CONTINUE
3425 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
3426
3427C...Rescale energy to subtract off spectator quark mass.
3428 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45)
3429 &.AND.NP.GE.3) THEN
3430 PS=PS-P(N+NP,5)
3431 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
3432 DO 350 J=1,5
3433 P(N+NP,J)=PQT*PV(1,J)
3434 PV(1,J)=(1.-PQT)*PV(1,J)
3435 350 CONTINUE
3436 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
3437 ND=NP-1
3438 MREM=1
3439
3440C...Phase space factors imposed in W decay.
3441 ELSEIF(MMAT.EQ.46) THEN
3442 MSTJ(93)=1
3443 PSMC=UYMASS(K(N+1,2))
3444 MSTJ(93)=1
3445 PSMC=PSMC+UYMASS(K(N+2,2))
3446 IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 240
3447 HR1=(P(N+1,5)/PV(1,5))**2
3448 HR2=(P(N+2,5)/PV(1,5))**2
3449 IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2)
3450 & .LT.2.*RLY(0)) GOTO 240
3451 ND=NP
3452
3453C...Fully specified final state: check mass broadening effects.
3454 ELSE
3455 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
3456 ND=NP
3457 ENDIF
3458
3459C...Select W mass in decay Q -> W + q, without W propagator.
3460 IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
3461 HLQ=(PARJ(32)/PV(1,5))**2
3462 HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
3463 HRQ=(P(N+2,5)/PV(1,5))**2
3464 360 HW=HLQ+RLY(0)*(HUQ-HLQ)
3465 IF(HMEPS(HW).LT.RLY(0)) GOTO 360
3466 P(N+1,5)=PV(1,5)*SQRT(HW)
3467
3468C...Ditto, including W propagator. Divide mass range into three regions.
3469 ELSEIF(MMAT.EQ.45) THEN
3470 HQW=(PV(1,5)/PMAS(24,1))**2
3471 HLW=(PARJ(32)/PMAS(24,1))**2
3472 HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
3473 HRQ=(P(N+2,5)/PV(1,5))**2
3474 HG=PMAS(24,2)/PMAS(24,1)
3475 HATL=ATAN((HLW-1.)/HG)
3476 HM=MIN(1.,HUW-0.001)
3477 HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3478 370 HM=HM-HG
3479 HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3480 IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
3481 HMV1=HMV2
3482 GOTO 370
3483 ENDIF
3484 HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
3485 HM1=1.-SQRT(1./HMV-HG**2)
3486 IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
3487 HM=HM1
3488 ELSEIF(HMV2.LE.HMV1) THEN
3489 HM=MAX(HLW,HM-MIN(0.1,1.-HM))
3490 ENDIF
3491 HATM=ATAN((HM-1.)/HG)
3492 HWT1=(HATM-HATL)/HG
3493 HWT2=HMV*(MIN(1.,HUW)-HM)
3494 HWT3=0.
3495 IF(HUW.GT.1.) THEN
3496 HATU=ATAN((HUW-1.)/HG)
3497 HMP1=HMEPS(1./HQW)
3498 HWT3=HMP1*HATU/HG
3499 ENDIF
3500
3501C...Select mass region and W mass there. Accept according to weight.
3502 380 HREG=RLY(0)*(HWT1+HWT2+HWT3)
3503 IF(HREG.LE.HWT1) THEN
3504 HW=1.+HG*TAN(HATL+RLY(0)*(HATM-HATL))
3505 HACC=HMEPS(HW/HQW)
3506 ELSEIF(HREG.LE.HWT1+HWT2) THEN
3507 HW=HM+RLY(0)*(MIN(1.,HUW)-HM)
3508 HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
3509 ELSE
3510 HW=1.+HG*TAN(RLY(0)*HATU)
3511 HACC=HMEPS(HW/HQW)/HMP1
3512 ENDIF
3513 IF(HACC.LT.RLY(0)) GOTO 380
3514 P(N+1,5)=PMAS(24,1)*SQRT(HW)
3515 ENDIF
3516
3517C...Determine position of grandmother, number of sisters, Q -> W sign.
3518 NM=0
3519 KFAS=0
3520 MSGN=0
3521 IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
3522 IM=K(IP,3)
3523 IF(IM.LT.0.OR.IM.GE.IP) IM=0
3524 IF(MMAT.EQ.46.AND.MSTJ(27).EQ.1) THEN
3525 IM=0
3526 ELSEIF(MMAT.EQ.46.AND.MSTJ(27).GE.2.AND.IM.NE.0) THEN
3527 IF(K(IM,2).EQ.94) THEN
3528 IM=K(K(IM,3),3)
3529 IF(IM.LT.0.OR.IM.GE.IP) IM=0
3530 ENDIF
3531 ENDIF
3532 IF(IM.NE.0) KFAM=IABS(K(IM,2))
3533 IF(IM.NE.0.AND.MMAT.EQ.3) THEN
3534 DO 390 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
3535 IF(K(IL,3).EQ.IM) NM=NM+1
3536 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
3537 390 CONTINUE
3538 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
3539 & MOD(KFAM/1000,10).NE.0) NM=0
3540 IF(NM.EQ.2) THEN
3541 KFAS=IABS(K(ISIS,2))
3542 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
3543 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
3544 ENDIF
3545 ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
3546 MSGN=ISIGN(1,K(IM,2)*K(IP,2))
3547 IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
3548 & MSGN*(-1)**MOD(KFAM/100,10)
3549 ENDIF
3550 ENDIF
3551
3552C...Kinematics of one-particle decays.
3553 IF(ND.EQ.1) THEN
3554 DO 400 J=1,4
3555 P(N+1,J)=P(IP,J)
3556 400 CONTINUE
3557 GOTO 660
3558 ENDIF
3559
3560C...Calculate maximum weight ND-particle decay.
3561 PV(ND,5)=P(N+ND,5)
3562 IF(ND.GE.3) THEN
3563 WTMAX=1./WTCOR(ND-2)
3564 PMAX=PV(1,5)-PS+P(N+ND,5)
3565 PMIN=0.
3566 DO 410 IL=ND-1,1,-1
3567 PMAX=PMAX+P(N+IL,5)
3568 PMIN=PMIN+P(N+IL+1,5)
3569 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
3570 410 CONTINUE
3571 ENDIF
3572
3573C...Find virtual gamma mass in Dalitz decay.
3574 420 IF(ND.EQ.2) THEN
3575 ELSEIF(MMAT.EQ.2) THEN
3576 PMES=4.*PMAS(11,1)**2
3577 PMRHO2=PMAS(131,1)**2
3578 PGRHO2=PMAS(131,2)**2
3579 430 PMST=PMES*(P(IP,5)**2/PMES)**RLY(0)
3580 WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
3581 & (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
3582 & ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
3583 IF(WT.LT.RLY(0)) GOTO 430
3584 PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
3585
3586C...M-generator gives weight. If rejected, try again.
3587 ELSE
3588 440 RORD(1)=1.
3589 DO 470 IL1=2,ND-1
3590 RSAV=RLY(0)
3591 DO 450 IL2=IL1-1,1,-1
3592 IF(RSAV.LE.RORD(IL2)) GOTO 460
3593 RORD(IL2+1)=RORD(IL2)
3594 450 CONTINUE
3595 460 RORD(IL2+1)=RSAV
3596 470 CONTINUE
3597 RORD(ND)=0.
3598 WT=1.
3599 DO 480 IL=ND-1,1,-1
3600 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
3601 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3602 480 CONTINUE
3603 IF(WT.LT.RLY(0)*WTMAX) GOTO 440
3604 ENDIF
3605
3606C...Perform two-particle decays in respective CM frame.
3607 490 DO 510 IL=1,ND-1
3608 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3609 UE(3)=2.*RLY(0)-1.
3610 PHI=PARU(2)*RLY(0)
3611 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
3612 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
3613 DO 500 J=1,3
3614 P(N+IL,J)=PA*UE(J)
3615 PV(IL+1,J)=-PA*UE(J)
3616 500 CONTINUE
3617 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
3618 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
3619 510 CONTINUE
3620
3621C...Lorentz transform decay products to lab frame.
3622 DO 520 J=1,4
3623 P(N+ND,J)=PV(ND,J)
3624 520 CONTINUE
3625 DO 560 IL=ND-1,1,-1
3626 DO 530 J=1,3
3627 BE(J)=PV(IL,J)/PV(IL,4)
3628 530 CONTINUE
3629 GA=PV(IL,4)/PV(IL,5)
3630 DO 550 I=N+IL,N+ND
3631 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3632 DO 540 J=1,3
3633 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3634 540 CONTINUE
3635 P(I,4)=GA*(P(I,4)+BEP)
3636 550 CONTINUE
3637 560 CONTINUE
3638
3639C...Check that no infinite loop in matrix element weight.
3640 NTRY=NTRY+1
3641 IF(NTRY.GT.800) GOTO 590
3642
3643C...Matrix elements for omega and phi decays.
3644 IF(MMAT.EQ.1) THEN
3645 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
3646 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
3647 & +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
3648 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLY(0)) GOTO 420
3649
3650C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3651 ELSEIF(MMAT.EQ.2) THEN
3652 FOUR12=FOUR(N+1,N+2)
3653 FOUR13=FOUR(N+1,N+3)
3654 WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
3655 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
3656 IF(WT.LT.RLY(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 490
3657
3658C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3659C...V vector), of form cos**2(theta02) in V1 rest frame, and for
3660C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
3661 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
3662 FOUR10=FOUR(IP,IM)
3663 FOUR12=FOUR(IP,N+1)
3664 FOUR02=FOUR(IM,N+1)
3665 PMS1=P(IP,5)**2
3666 PMS0=P(IM,5)**2
3667 PMS2=P(N+1,5)**2
3668 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
3669 IF(KFAS.EQ.22) HNUM=PMS1*(2.*FOUR10*FOUR12*FOUR02-
3670 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
3671 HNUM=MAX(1E-6*PMS1**2*PMS0*PMS2,HNUM)
3672 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
3673 IF(HNUM.LT.RLY(0)*HDEN) GOTO 490
3674
3675C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3676 ELSEIF(MMAT.EQ.4) THEN
3677 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3678 HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
3679 HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
3680 WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
3681 & ((1.-HX3)/(HX1*HX2))**2
3682 IF(WT.LT.2.*RLY(0)) GOTO 420
3683 IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
3684 & GOTO 420
3685
3686C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3687 ELSEIF(MMAT.EQ.41) THEN
3688 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3689 HXM=MIN(0.75,2.*(1.-PS/P(IP,5)))
3690 IF(HX1*(3.-2.*HX1).LT.RLY(0)*HXM*(3.-2.*HXM)) GOTO 420
3691
3692C...Matrix elements for weak decays (only semileptonic for c and b)
3693 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
3694 &.AND.ND.EQ.3) THEN
3695 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
3696 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
3697 IF(WT.LT.RLY(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 420
3698 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
3699 DO 580 J=1,4
3700 P(N+NP+1,J)=0.
3701 DO 570 IS=N+3,N+NP
3702 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
3703 570 CONTINUE
3704 580 CONTINUE
3705 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
3706 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
3707 IF(WT.LT.RLY(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 420
3708
3709C...Angular distribution in W decay.
3710 ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
3711 IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
3712 IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
3713 IF(WT.LT.RLY(0)*P(IM,5)**4/WTCOR(10)) GOTO 490
3714 ENDIF
3715
3716C...Scale back energy and reattach spectator.
3717 590 IF(MREM.EQ.1) THEN
3718 DO 600 J=1,5
3719 PV(1,J)=PV(1,J)/(1.-PQT)
3720 600 CONTINUE
3721 ND=ND+1
3722 MREM=0
3723 ENDIF
3724
3725C...Low invariant mass for system with spectator quark gives particle,
3726C...not two jets. Readjust momenta accordingly.
3727 IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
3728 MSTJ(93)=1
3729 PM2=UYMASS(K(N+2,2))
3730 MSTJ(93)=1
3731 PM3=UYMASS(K(N+3,2))
3732 IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
3733 & (PARJ(32)+PM2+PM3)**2) GOTO 660
3734 K(N+2,1)=1
3735 KFTEMP=K(N+2,2)
3736 CALL LYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
3737 IF(K(N+2,2).EQ.0) GOTO 260
3738 P(N+2,5)=UYMASS(K(N+2,2))
3739 PS=P(N+1,5)+P(N+2,5)
3740 PV(2,5)=P(N+2,5)
3741 MMAT=0
3742 ND=2
3743 GOTO 490
3744 ELSEIF(MMAT.EQ.44) THEN
3745 MSTJ(93)=1
3746 PM3=UYMASS(K(N+3,2))
3747 MSTJ(93)=1
3748 PM4=UYMASS(K(N+4,2))
3749 IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
3750 & (PARJ(32)+PM3+PM4)**2) GOTO 630
3751 K(N+3,1)=1
3752 KFTEMP=K(N+3,2)
3753 CALL LYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
3754 IF(K(N+3,2).EQ.0) GOTO 260
3755 P(N+3,5)=UYMASS(K(N+3,2))
3756 DO 610 J=1,3
3757 P(N+3,J)=P(N+3,J)+P(N+4,J)
3758 610 CONTINUE
3759 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)
3760 HA=P(N+1,4)**2-P(N+2,4)**2
3761 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
3762 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
3763 & (P(N+1,3)-P(N+2,3))**2
3764 HD=(PV(1,4)-P(N+3,4))**2
3765 HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
3766 HF=HD*HC-HB**2
3767 HG=HD*HC-HA*HB
3768 HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
3769 DO 620 J=1,3
3770 PCOR=HH*(P(N+1,J)-P(N+2,J))
3771 P(N+1,J)=P(N+1,J)+PCOR
3772 P(N+2,J)=P(N+2,J)-PCOR
3773 620 CONTINUE
3774 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)
3775 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)
3776 ND=ND-1
3777 ENDIF
3778
3779C...Check invariant mass of W jets. May give one particle or start over.
3780 630 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
3781 &.AND.IABS(K(N+1,2)).LT.10) THEN
3782 PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
3783 MSTJ(93)=1
3784 PM1=UYMASS(K(N+1,2))
3785 MSTJ(93)=1
3786 PM2=UYMASS(K(N+2,2))
3787 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 640
3788 KFLDUM=INT(1.5+RLY(0))
3789 CALL LYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
3790 CALL LYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
3791 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
3792 PSM=UYMASS(KF1)+UYMASS(KF2)
3793 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 640
3794 IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 640
3795 IF(MMAT.EQ.48) GOTO 420
3796 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
3797 K(N+1,1)=1
3798 KFTEMP=K(N+1,2)
3799 CALL LYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
3800 IF(K(N+1,2).EQ.0) GOTO 260
3801 P(N+1,5)=UYMASS(K(N+1,2))
3802 K(N+2,2)=K(N+3,2)
3803 P(N+2,5)=P(N+3,5)
3804 PS=P(N+1,5)+P(N+2,5)
3805 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
3806 PV(2,5)=P(N+3,5)
3807 MMAT=0
3808 ND=2
3809 GOTO 490
3810 ENDIF
3811
3812C...Phase space decay of partons from W decay.
3813 640 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
3814 KFLO(1)=K(N+1,2)
3815 KFLO(2)=K(N+2,2)
3816 K(N+1,1)=K(N+3,1)
3817 K(N+1,2)=K(N+3,2)
3818 DO 650 J=1,5
3819 PV(1,J)=P(N+1,J)+P(N+2,J)
3820 P(N+1,J)=P(N+3,J)
3821 650 CONTINUE
3822 PV(1,5)=PMR
3823 N=N+1
3824 NP=0
3825 NQ=2
3826 PS=0.
3827 MSTJ(93)=2
3828 PSQ=UYMASS(KFLO(1))
3829 MSTJ(93)=2
3830 PSQ=PSQ+UYMASS(KFLO(2))
3831 MMAT=11
3832 GOTO 290
3833 ENDIF
3834
3835C...Boost back for rapidly moving particle.
3836 660 N=N+ND
3837 IF(MBST.EQ.1) THEN
3838 DO 670 J=1,3
3839 BE(J)=P(IP,J)/P(IP,4)
3840 670 CONTINUE
3841 GA=P(IP,4)/P(IP,5)
3842 DO 690 I=NSAV+1,N
3843 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3844 DO 680 J=1,3
3845 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3846 680 CONTINUE
3847 P(I,4)=GA*(P(I,4)+BEP)
3848 690 CONTINUE
3849 ENDIF
3850
3851C...Fill in position of decay vertex.
3852 DO 710 I=NSAV+1,N
3853 DO 700 J=1,4
3854 V(I,J)=VDCY(J)
3855 700 CONTINUE
3856 V(I,5)=0.
3857 710 CONTINUE
3858
3859C...Set up for parton shower evolution from jets.
3860 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
3861 K(NSAV+1,1)=3
3862 K(NSAV+2,1)=3
3863 K(NSAV+3,1)=3
3864 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3865 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3866 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3867 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3868 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3869 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3870 MSTJ(92)=-(NSAV+1)
3871 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
3872 K(NSAV+2,1)=3
3873 K(NSAV+3,1)=3
3874 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3875 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
3876 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
3877 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3878 MSTJ(92)=NSAV+2
3879 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46)
3880 &.AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
3881 K(NSAV+1,1)=3
3882 K(NSAV+2,1)=3
3883 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3884 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
3885 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
3886 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3887 MSTJ(92)=NSAV+1
3888 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46)
3889 &.AND.IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
3890 MSTJ(92)=NSAV+1
3891 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
3892 &THEN
3893 K(NSAV+1,1)=3
3894 K(NSAV+2,1)=3
3895 K(NSAV+3,1)=3
3896 KCP=LYCOMP(K(NSAV+1,2))
3897 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
3898 JCON=4
3899 IF(KQP.LT.0) JCON=5
3900 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
3901 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
3902 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
3903 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
3904 MSTJ(92)=NSAV+1
3905 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
3906 K(NSAV+1,1)=3
3907 K(NSAV+3,1)=3
3908 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
3909 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3910 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3911 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
3912 MSTJ(92)=NSAV+1
3913
3914C...Set up for parton shower evolution in t -> W + b.
3915 ELSEIF(MSTJ(27).GE.1.AND.MMAT.EQ.45.AND.ND.EQ.3) THEN
3916 K(NSAV+2,1)=3
3917 K(NSAV+3,1)=3
3918 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3919 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
3920 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
3921 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3922 MSTJ(92)=NSAV+1
3923 ENDIF
3924
3925C...Mark decayed particle; special option for B-B~ mixing.
3926 IF(K(IP,1).EQ.5) K(IP,1)=15
3927 IF(K(IP,1).LE.10) K(IP,1)=11
3928 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
3929 K(IP,4)=NSAV+1
3930 K(IP,5)=N
3931
3932 RETURN
3933 END
3934
3935C*********************************************************************
3936
3937 SUBROUTINE LYKFDI(KFL1,KFL2,KFL3,KF)
3938
3939C...Purpose: to generate a new flavour pair and combine off a hadron.
3940 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3941 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3942 SAVE /LYDAT1/,/LYDAT2/
3943
3944C...Default flavour values. Input consistency checks.
3945 KF1A=IABS(KFL1)
3946 KF2A=IABS(KFL2)
3947 KFL3=0
3948 KF=0
3949 IF(KF1A.EQ.0) RETURN
3950 IF(KF2A.NE.0) THEN
3951 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
3952 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
3953 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
3954 ENDIF
3955
3956C...Check if tabulated flavour probabilities are to be used.
3957 IF(MSTJ(15).EQ.1) THEN
3958 KTAB1=-1
3959 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
3960 KFL1A=MOD(KF1A/1000,10)
3961 KFL1B=MOD(KF1A/100,10)
3962 KFL1S=MOD(KF1A,10)
3963 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
3964 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
3965 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
3966 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
3967 KTAB2=0
3968 IF(KF2A.NE.0) THEN
3969 KTAB2=-1
3970 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
3971 KFL2A=MOD(KF2A/1000,10)
3972 KFL2B=MOD(KF2A/100,10)
3973 KFL2S=MOD(KF2A,10)
3974 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
3975 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
3976 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
3977 ENDIF
3978 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 150
3979 ENDIF
3980
3981C...Parameters and breaking diquark parameter combinations.
3982 100 PAR2=PARJ(2)
3983 PAR3=PARJ(3)
3984 PAR4=3.*PARJ(4)
3985 IF(MSTJ(12).GE.2) THEN
3986 PAR3M=SQRT(PARJ(3))
3987 PAR4M=1./(3.*SQRT(PARJ(4)))
3988 PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3989 PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3990 PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3991 & PAR2*PAR3M*PARJ(6)*PARJ(7))
3992 PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3993 PARSM=MAX(PARS0,PARS1,PARS2)
3994 PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3995 ENDIF
3996
3997C...Choice of whether to generate meson or baryon.
3998 110 MBARY=0
3999 KFDA=0
4000 IF(KF1A.LE.10) THEN
4001 IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLY(0).GT.1.)
4002 & MBARY=1
4003 IF(KF2A.GT.10) MBARY=2
4004 IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
4005 ELSE
4006 MBARY=2
4007 IF(KF1A.LE.10000) KFDA=KF1A
4008 ENDIF
4009
4010C...Possibility of process diquark -> meson + new diquark.
4011 IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
4012 KFLDA=MOD(KFDA/1000,10)
4013 KFLDB=MOD(KFDA/100,10)
4014 KFLDS=MOD(KFDA,10)
4015 WTDQ=PARS0
4016 IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
4017 IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
4018 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
4019 IF((1.+WTDQ)*RLY(0).GT.1.) MBARY=-1
4020 IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
4021 ENDIF
4022
4023C...Flavour for meson, possibly with new flavour.
4024 IF(MBARY.LE.0) THEN
4025 KFS=ISIGN(1,KFL1)
4026 IF(MBARY.EQ.0) THEN
4027 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLY(0)),-KFL1)
4028 KFLA=MAX(KF1A,KF2A+IABS(KFL3))
4029 KFLB=MIN(KF1A,KF2A+IABS(KFL3))
4030 IF(KFLA.NE.KF1A) KFS=-KFS
4031
4032C...Splitting of diquark into meson plus new diquark.
4033 ELSE
4034 KFL1A=MOD(KF1A/1000,10)
4035 KFL1B=MOD(KF1A/100,10)
4036 120 KFL1D=KFL1A+INT(RLY(0)+0.5)*(KFL1B-KFL1A)
4037 KFL1E=KFL1A+KFL1B-KFL1D
4038 IF((KFL1D.EQ.3.AND.RLY(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
4039 & RLY(0).LT.PARDM)) THEN
4040 KFL1D=KFL1A+KFL1B-KFL1D
4041 KFL1E=KFL1A+KFL1B-KFL1E
4042 ENDIF
4043 KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLY(0))
4044 IF((KFL1E.NE.KFL3A.AND.RLY(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M))
4045 & .OR.(KFL1E.EQ.KFL3A.AND.RLY(0).GT.2./MAX(2.,1.+PAR4M)))
4046 & GOTO 120
4047 KFLDS=3
4048 IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLY(0)+1./(1.+PAR4M))+1
4049 KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
4050 & KFLDS,-KFL1)
4051 KFLA=MAX(KFL1D,KFL3A)
4052 KFLB=MIN(KFL1D,KFL3A)
4053 IF(KFLA.NE.KFL1D) KFS=-KFS
4054 ENDIF
4055
4056C...Form meson, with spin and flavour mixing for diagonal states.
4057 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLY(0))
4058 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLY(0))
4059 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLY(0))
4060 IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
4061 IF(RLY(0).LT.PARJ(14)) KMUL=2
4062 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
4063 RMUL=RLY(0)
4064 IF(RMUL.LT.PARJ(15)) KMUL=3
4065 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
4066 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
4067 ENDIF
4068 KFLS=3
4069 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
4070 IF(KMUL.EQ.5) KFLS=5
4071 IF(KFLA.NE.KFLB) THEN
4072 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
4073 ELSE
4074 RMIX=RLY(0)
4075 IMIX=2*KFLA+10*KMUL
4076 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
4077 & INT(RMIX+PARF(IMIX)))+KFLS
4078 IF(KFLA.GE.4) KF=110*KFLA+KFLS
4079 ENDIF
4080 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
4081 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
4082
4083C...Optional extra suppression of eta and eta'.
4084 IF(KF.EQ.221) THEN
4085 IF(RLY(0).GT.PARJ(25)) GOTO 110
4086 ELSEIF(KF.EQ.331) THEN
4087 IF(RLY(0).GT.PARJ(26)) GOTO 110
4088 ENDIF
4089
4090C...Generate diquark flavour.
4091 ELSE
4092 130 IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
4093 KFLA=KF1A
4094 140 KFLB=1+INT((2.+PAR2*PAR3)*RLY(0))
4095 KFLC=1+INT((2.+PAR2*PAR3)*RLY(0))
4096 KFLDS=1
4097 IF(KFLB.GE.KFLC) KFLDS=3
4098 IF(KFLDS.EQ.1.AND.PAR4*RLY(0).GT.1.) GOTO 140
4099 IF(KFLDS.EQ.3.AND.PAR4.LT.RLY(0)) GOTO 140
4100 KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
4101
4102C...Take diquark flavour from input.
4103 ELSEIF(KF1A.LE.10) THEN
4104 KFLA=KF1A
4105 KFLB=MOD(KF2A/1000,10)
4106 KFLC=MOD(KF2A/100,10)
4107 KFLDS=MOD(KF2A,10)
4108
4109C...Generate (or take from input) quark to go with diquark.
4110 ELSE
4111 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLY(0)),KFL1)
4112 KFLA=KF2A+IABS(KFL3)
4113 KFLB=MOD(KF1A/1000,10)
4114 KFLC=MOD(KF1A/100,10)
4115 KFLDS=MOD(KF1A,10)
4116 ENDIF
4117
4118C...SU(6) factors for formation of baryon. Try again if fails.
4119 KBARY=KFLDS
4120 IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
4121 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
4122 WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
4123 IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
4124 WTDQ=PARS0
4125 IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
4126 IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
4127 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
4128 IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
4129 IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
4130 ENDIF
4131 IF(KF2A.EQ.0.AND.WT.LT.RLY(0)) GOTO 130
4132
4133C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
4134 KFLD=MAX(KFLA,KFLB,KFLC)
4135 KFLF=MIN(KFLA,KFLB,KFLC)
4136 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
4137 KFLS=2
4138 IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLY(0).GT.
4139 & PARF(60+KBARY)) KFLS=4
4140 KFLL=0
4141 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
4142 IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
4143 IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLY(0))
4144 IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLY(0))
4145 ENDIF
4146 IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
4147 IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
4148 ENDIF
4149 RETURN
4150
4151C...Use tabulated probabilities to select new flavour and hadron.
4152 150 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
4153 KT3L=1
4154 KT3U=6
4155 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
4156 KT3L=1
4157 KT3U=6
4158 ELSEIF(KTAB2.EQ.0) THEN
4159 KT3L=1
4160 KT3U=22
4161 ELSE
4162 KT3L=KTAB2
4163 KT3U=KTAB2
4164 ENDIF
4165 RFL=0.
4166 DO 170 KTS=0,2
4167 DO 160 KT3=KT3L,KT3U
4168 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
4169 160 CONTINUE
4170 170 CONTINUE
4171 RFL=RLY(0)*RFL
4172 DO 190 KTS=0,2
4173 KTABS=KTS
4174 DO 180 KT3=KT3L,KT3U
4175 KTAB3=KT3
4176 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
4177 IF(RFL.LE.0.) GOTO 200
4178 180 CONTINUE
4179 190 CONTINUE
4180 200 CONTINUE
4181
4182C...Reconstruct flavour of produced quark/diquark.
4183 IF(KTAB3.LE.6) THEN
4184 KFL3A=KTAB3
4185 KFL3B=0
4186 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
4187 ELSE
4188 KFL3A=1
4189 IF(KTAB3.GE.8) KFL3A=2
4190 IF(KTAB3.GE.11) KFL3A=3
4191 IF(KTAB3.GE.16) KFL3A=4
4192 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
4193 KFL3=1000*KFL3A+100*KFL3B+1
4194 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
4195 & KFL3+2
4196 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
4197 ENDIF
4198
4199C...Reconstruct meson code.
4200 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
4201 &KFL3B.NE.0)) THEN
4202 RFL=RLY(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
4203 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
4204 KF=110+2*KTABS+1
4205 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
4206 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
4207 & 25*KTABS)) KF=330+2*KTABS+1
4208 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
4209 KFLA=MAX(KTAB1,KTAB3)
4210 KFLB=MIN(KTAB1,KTAB3)
4211 KFS=ISIGN(1,KFL1)
4212 IF(KFLA.NE.KF1A) KFS=-KFS
4213 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
4214 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
4215 KFS=ISIGN(1,KFL1)
4216 IF(KFL1A.EQ.KFL3A) THEN
4217 KFLA=MAX(KFL1B,KFL3B)
4218 KFLB=MIN(KFL1B,KFL3B)
4219 IF(KFLA.NE.KFL1B) KFS=-KFS
4220 ELSEIF(KFL1A.EQ.KFL3B) THEN
4221 KFLA=KFL3A
4222 KFLB=KFL1B
4223 KFS=-KFS
4224 ELSEIF(KFL1B.EQ.KFL3A) THEN
4225 KFLA=KFL1A
4226 KFLB=KFL3B
4227 ELSEIF(KFL1B.EQ.KFL3B) THEN
4228 KFLA=MAX(KFL1A,KFL3A)
4229 KFLB=MIN(KFL1A,KFL3A)
4230 IF(KFLA.NE.KFL1A) KFS=-KFS
4231 ELSE
4232 CALL LYERRM(2,'(LYKFDI:) no matching flavours for qq -> qq')
4233 GOTO 100
4234 ENDIF
4235 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
4236
4237C...Reconstruct baryon code.
4238 ELSE
4239 IF(KTAB1.GE.7) THEN
4240 KFLA=KFL3A
4241 KFLB=KFL1A
4242 KFLC=KFL1B
4243 ELSE
4244 KFLA=KFL1A
4245 KFLB=KFL3A
4246 KFLC=KFL3B
4247 ENDIF
4248 KFLD=MAX(KFLA,KFLB,KFLC)
4249 KFLF=MIN(KFLA,KFLB,KFLC)
4250 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
4251 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
4252 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
4253 ENDIF
4254
4255C...Check that constructed flavour code is an allowed one.
4256 IF(KFL2.NE.0) KFL3=0
4257 KC=LYCOMP(KF)
4258 IF(KC.EQ.0) THEN
4259 CALL LYERRM(2,'(LYKFDI:) user-defined flavour probabilities '//
4260 & 'failed')
4261 GOTO 100
4262 ENDIF
4263
4264 RETURN
4265 END
4266
4267C*********************************************************************
4268
4269 SUBROUTINE LYPTDI(KFL,PX,PY)
4270
4271C...Purpose: to generate transverse momentum according to a Gaussian.
4272 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4273 SAVE /LYDAT1/
4274
4275C...Generate p_T and azimuthal angle, gives p_x and p_y.
4276 KFLA=IABS(KFL)
4277 PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLY(0))))
4278 IF(PARJ(23).GT.RLY(0)) PT=PARJ(24)*PT
4279 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
4280 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
4281 PHI=PARU(2)*RLY(0)
4282 PX=PT*COS(PHI)
4283 PY=PT*SIN(PHI)
4284
4285 RETURN
4286 END
4287
4288C*********************************************************************
4289
4290 SUBROUTINE LYZDIS(KFL1,KFL2,PR,Z)
4291
4292C...Purpose: to generate the longitudinal splitting variable z.
4293 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4294 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4295 SAVE /LYDAT1/,/LYDAT2/
4296
4297C...Check if heavy flavour fragmentation.
4298 KFLA=IABS(KFL1)
4299 KFLB=IABS(KFL2)
4300 KFLH=KFLA
4301 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
4302
4303C...Lund symmetric scaling function: determine parameters of shape.
4304 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
4305 &MSTJ(11).GE.4) THEN
4306 FA=PARJ(41)
4307 IF(MSTJ(91).EQ.1) FA=PARJ(43)
4308 IF(KFLB.GE.10) FA=FA+PARJ(45)
4309 FBB=PARJ(42)
4310 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
4311 FB=FBB*PR
4312 FC=1.
4313 IF(KFLA.GE.10) FC=FC-PARJ(45)
4314 IF(KFLB.GE.10) FC=FC+PARJ(45)
4315 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
4316 FRED=PARJ(46)
4317 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
4318 FC=FC+FRED*FBB*PARF(100+KFLH)**2
4319 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
4320 FRED=PARJ(46)
4321 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
4322 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
4323 ENDIF
4324 MC=1
4325 IF(ABS(FC-1.).GT.0.01) MC=2
4326
4327C...Determine position of maximum. Special cases for a = 0 or a = c.
4328 IF(FA.LT.0.02) THEN
4329 MA=1
4330 ZMAX=1.
4331 IF(FC.GT.FB) ZMAX=FB/FC
4332 ELSEIF(ABS(FC-FA).LT.0.01) THEN
4333 MA=2
4334 ZMAX=FB/(FB+FC)
4335 ELSE
4336 MA=3
4337 ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
4338 IF(ZMAX.GT.0.9999.AND.FB.GT.100.) ZMAX=MIN(ZMAX,1.-FA/FB)
4339 ENDIF
4340
4341C...Subdivide z range if distribution very peaked near endpoint.
4342 MMAX=2
4343 IF(ZMAX.LT.0.1) THEN
4344 MMAX=1
4345 ZDIV=2.75*ZMAX
4346 IF(MC.EQ.1) THEN
4347 FINT=1.-LOG(ZDIV)
4348 ELSE
4349 ZDIVC=ZDIV**(1.-FC)
4350 FINT=1.+(1.-1./ZDIVC)/(FC-1.)
4351 ENDIF
4352 ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
4353 MMAX=3
4354 FSCB=SQRT(4.+(FC/FB)**2)
4355 ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
4356 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
4357 ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
4358 FINT=1.+FB*(1.-ZDIV)
4359 ENDIF
4360
4361C...Choice of z, preweighted for peaks at low or high z.
4362 100 Z=RLY(0)
4363 FPRE=1.
4364 IF(MMAX.EQ.1) THEN
4365 IF(FINT*RLY(0).LE.1.) THEN
4366 Z=ZDIV*Z
4367 ELSEIF(MC.EQ.1) THEN
4368 Z=ZDIV**Z
4369 FPRE=ZDIV/Z
4370 ELSE
4371 Z=(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
4372 FPRE=(ZDIV/Z)**FC
4373 ENDIF
4374 ELSEIF(MMAX.EQ.3) THEN
4375 IF(FINT*RLY(0).LE.1.) THEN
4376 Z=ZDIV+LOG(Z)/FB
4377 FPRE=EXP(FB*(Z-ZDIV))
4378 ELSE
4379 Z=ZDIV+Z*(1.-ZDIV)
4380 ENDIF
4381 ENDIF
4382
4383C...Weighting according to correct formula.
4384 IF(Z.LE.0..OR.Z.GE.1.) GOTO 100
4385 FEXP=FC*LOG(ZMAX/Z)+FB*(1./ZMAX-1./Z)
4386 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1.-Z)/(1.-ZMAX))
4387 FVAL=EXP(MAX(-50.,MIN(50.,FEXP)))
4388 IF(FVAL.LT.RLY(0)*FPRE) GOTO 100
4389
4390C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
4391 ELSE
4392 FC=PARJ(50+MAX(1,KFLH))
4393 IF(MSTJ(91).EQ.1) FC=PARJ(59)
4394 110 Z=RLY(0)
4395 IF(FC.GE.0..AND.FC.LE.1.) THEN
4396 IF(FC.GT.RLY(0)) Z=1.-Z**(1./3.)
4397 ELSEIF(FC.GT.-1.AND.FC.LT.0.) THEN
4398 IF(-4.*FC*Z*(1.-Z)**2.LT.RLY(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
4399 ELSE
4400 IF(FC.GT.0.) Z=1.-Z**(1./FC)
4401 IF(FC.LT.0.) Z=Z**(-1./FC)
4402 ENDIF
4403 ENDIF
4404
4405 RETURN
4406 END
4407
4408C*********************************************************************
4409
4410 SUBROUTINE LYSHOW(IP1,IP2,QMAX)
4411
4412C...Purpose: to generate timelike parton showers from given partons.
4413 IMPLICIT DOUBLE PRECISION(D)
4414 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
4415 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4416 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4417 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
4418 DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
4419 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
4420 &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
4421 &ISII(2)
4422
4423C...Initialization of cutoff masses etc.
4424 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
4425 &QMAX.LE.MIN(PARJ(82),PARJ(83))) RETURN
4426 DO 100 IFL=0,40
4427 KSH(IFL)=0
4428 100 CONTINUE
4429 KSH(21)=1
4430 PMTH(1,21)=UYMASS(21)
4431 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
4432 PMTH(3,21)=2.*PMTH(2,21)
4433 PMTH(4,21)=PMTH(3,21)
4434 PMTH(5,21)=PMTH(3,21)
4435 PMTH(1,22)=UYMASS(22)
4436 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
4437 PMTH(3,22)=2.*PMTH(2,22)
4438 PMTH(4,22)=PMTH(3,22)
4439 PMTH(5,22)=PMTH(3,22)
4440 PMQTH1=PARJ(82)
4441 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
4442 PMQTH2=PMTH(2,21)
4443 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
4444 DO 110 IFL=1,8
4445 KSH(IFL)=1
4446 PMTH(1,IFL)=UYMASS(IFL)
4447 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PMQTH1**2)
4448 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
4449 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PARJ(82)**2)+PMTH(2,21)
4450 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PARJ(83)**2)+PMTH(2,22)
4451 110 CONTINUE
4452 DO 120 IFL=11,17,2
4453 IF(MSTJ(41).GE.2) KSH(IFL)=1
4454 PMTH(1,IFL)=UYMASS(IFL)
4455 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25*PARJ(83)**2)
4456 PMTH(3,IFL)=PMTH(2,IFL)+PMTH(2,22)
4457 PMTH(4,IFL)=PMTH(3,IFL)
4458 PMTH(5,IFL)=PMTH(3,IFL)
4459 120 CONTINUE
4460 PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
4461 ALAMS=PARJ(81)**2
4462 ALFM=LOG(PT2MIN/ALAMS)
4463
4464C...Store positions of shower initiating partons.
4465 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
4466 NPA=1
4467 IPA(1)=IP1
4468 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
4469 &MSTU(32))) THEN
4470 NPA=2
4471 IPA(1)=IP1
4472 IPA(2)=IP2
4473 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
4474 &.AND.IP2.GE.-3) THEN
4475 NPA=IABS(IP2)
4476 DO 130 I=1,NPA
4477 IPA(I)=IP1+I-1
4478 130 CONTINUE
4479 ELSE
4480 CALL LYERRM(12,
4481 & '(LYSHOW:) failed to reconstruct showering system')
4482 IF(MSTU(21).GE.1) RETURN
4483 ENDIF
4484
4485C...Check on phase space available for emission.
4486 IREJ=0
4487 DO 140 J=1,5
4488 PS(J)=0.
4489 140 CONTINUE
4490 PM=0.
4491 DO 160 I=1,NPA
4492 KFLA(I)=IABS(K(IPA(I),2))
4493 PMA(I)=P(IPA(I),5)
4494C...Special cutoff masses for t, l, h with variable masses.
4495 IFLA=KFLA(I)
4496 IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
4497 IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
4498 PMTH(1,IFLA)=PMA(I)
4499 PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25*PMQTH1**2)
4500 PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
4501 PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25*PARJ(82)**2)+PMTH(2,21)
4502 PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25*PARJ(83)**2)+PMTH(2,22)
4503 ENDIF
4504 IF(KFLA(I).LE.40) THEN
4505 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
4506 ENDIF
4507 PM=PM+PMA(I)
4508 IF(KFLA(I).GT.40) THEN
4509 IREJ=IREJ+1
4510 ELSE
4511 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
4512 ENDIF
4513 DO 150 J=1,4
4514 PS(J)=PS(J)+P(IPA(I),J)
4515 150 CONTINUE
4516 160 CONTINUE
4517 IF(IREJ.EQ.NPA) RETURN
4518 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
4519 IF(NPA.EQ.1) PS(5)=PS(4)
4520 IF(PS(5).LE.PM+PMQTH1) RETURN
4521
4522C...Check if 3-jet matrix elements to be used.
4523 M3JC=0
4524 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
4525 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
4526 & KFLA(2).LE.8) M3JC=1
4527 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4528 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
4529 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4530 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
4531 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
4532 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
4533 IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
4534 M3JCM=0
4535 IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
4536 M3JCM=1
4537 QME=(2.*PMTH(1,KFLA(1))/PS(5))**2
4538 ENDIF
4539 ENDIF
4540
4541C...Find if interference with initial state partons.
4542 MIIS=0
4543 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50)
4544 IF(MIIS.NE.0) THEN
4545 DO 180 I=1,2
4546 KCII(I)=0
4547 KCA=LYCOMP(KFLA(I))
4548 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
4549 NIIS(I)=0
4550 IF(KCII(I).NE.0) THEN
4551 DO 170 J=1,2
4552 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
4553 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
4554 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
4555 NIIS(I)=NIIS(I)+1
4556 IIIS(I,NIIS(I))=ICSI
4557 ENDIF
4558 170 CONTINUE
4559 ENDIF
4560 180 CONTINUE
4561 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
4562 ENDIF
4563
4564C...Boost interfering initial partons to rest frame
4565C...and reconstruct their polar and azimuthal angles.
4566 IF(MIIS.NE.0) THEN
4567 DO 200 I=1,2
4568 DO 190 J=1,5
4569 K(N+I,J)=K(IPA(I),J)
4570 P(N+I,J)=P(IPA(I),J)
4571 V(N+I,J)=0.
4572 190 CONTINUE
4573 200 CONTINUE
4574 DO 220 I=3,2+NIIS(1)
4575 DO 210 J=1,5
4576 K(N+I,J)=K(IIIS(1,I-2),J)
4577 P(N+I,J)=P(IIIS(1,I-2),J)
4578 V(N+I,J)=0.
4579 210 CONTINUE
4580 220 CONTINUE
4581 DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
4582 DO 230 J=1,5
4583 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
4584 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
4585 V(N+I,J)=0.
4586 230 CONTINUE
4587 240 CONTINUE
4588 CALL LUDBRB(N+1,N+2+NIIS(1)+NIIS(2),0.,0.,-DBLE(PS(1)/PS(4)),
4589 & -DBLE(PS(2)/PS(4)),-DBLE(PS(3)/PS(4)))
4590 PHI=UYANGL(P(N+1,1),P(N+1,2))
4591 CALL LUDBRB(N+1,N+2+NIIS(1)+NIIS(2),0.,-PHI,0D0,0D0,0D0)
4592 THE=UYANGL(P(N+1,3),P(N+1,1))
4593 CALL LUDBRB(N+1,N+2+NIIS(1)+NIIS(2),-THE,0.,0D0,0D0,0D0)
4594 DO 250 I=3,2+NIIS(1)
4595 THEIIS(1,I-2)=UYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
4596 PHIIIS(1,I-2)=UYANGL(P(N+I,1),P(N+I,2))
4597 250 CONTINUE
4598 DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
4599 THEIIS(2,I-2-NIIS(1))=PARU(1)-UYANGL(P(N+I,3),
4600 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
4601 PHIIIS(2,I-2-NIIS(1))=UYANGL(P(N+I,1),P(N+I,2))
4602 260 CONTINUE
4603 ENDIF
4604
4605C...Define imagined single initiator of shower for parton system.
4606 NS=N
4607 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4608 CALL LYERRM(11,'(LYSHOW:) no more memory left in LUJETS')
4609 IF(MSTU(21).GE.1) RETURN
4610 ENDIF
4611 IF(NPA.GE.2) THEN
4612 K(N+1,1)=11
4613 K(N+1,2)=21
4614 K(N+1,3)=0
4615 K(N+1,4)=0
4616 K(N+1,5)=0
4617 P(N+1,1)=0.
4618 P(N+1,2)=0.
4619 P(N+1,3)=0.
4620 P(N+1,4)=PS(5)
4621 P(N+1,5)=PS(5)
4622 V(N+1,5)=PS(5)**2
4623 N=N+1
4624 ENDIF
4625
4626C...Loop over partons that may branch.
4627 NEP=NPA
4628 IM=NS
4629 IF(NPA.EQ.1) IM=NS-1
4630 270 IM=IM+1
4631 IF(N.GT.NS) THEN
4632 IF(IM.GT.N) GOTO 510
4633 KFLM=IABS(K(IM,2))
4634 IF(KFLM.GT.40) GOTO 270
4635 IF(KSH(KFLM).EQ.0) GOTO 270
4636 IFLM=KFLM
4637 IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
4638 IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
4639 IGM=K(IM,3)
4640 ELSE
4641 IGM=-1
4642 ENDIF
4643 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
4644 CALL LYERRM(11,'(LYSHOW:) no more memory left in LUJETS')
4645 IF(MSTU(21).GE.1) RETURN
4646 ENDIF
4647
4648C...Position of aunt (sister to branching parton).
4649C...Origin and flavour of daughters.
4650 IAU=0
4651 IF(IGM.GT.0) THEN
4652 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
4653 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
4654 ENDIF
4655 IF(IGM.GE.0) THEN
4656 K(IM,4)=N+1
4657 DO 280 I=1,NEP
4658 K(N+I,3)=IM
4659 280 CONTINUE
4660 ELSE
4661 K(N+1,3)=IPA(1)
4662 ENDIF
4663 IF(IGM.LE.0) THEN
4664 DO 290 I=1,NEP
4665 K(N+I,2)=K(IPA(I),2)
4666 290 CONTINUE
4667 ELSEIF(KFLM.NE.21) THEN
4668 K(N+1,2)=K(IM,2)
4669 K(N+2,2)=K(IM,5)
4670 ELSEIF(K(IM,5).EQ.21) THEN
4671 K(N+1,2)=21
4672 K(N+2,2)=21
4673 ELSE
4674 K(N+1,2)=K(IM,5)
4675 K(N+2,2)=-K(IM,5)
4676 ENDIF
4677
4678C...Reset flags on daughers and tries made.
4679 DO 300 IP=1,NEP
4680 K(N+IP,1)=3
4681 K(N+IP,4)=0
4682 K(N+IP,5)=0
4683 KFLD(IP)=IABS(K(N+IP,2))
4684 IF(KCHG(LYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
4685 ITRY(IP)=0
4686 ISL(IP)=0
4687 ISI(IP)=0
4688 IF(KFLD(IP).LE.40) THEN
4689 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
4690 ENDIF
4691 300 CONTINUE
4692 ISLM=0
4693
4694C...Maximum virtuality of daughters.
4695 IF(IGM.LE.0) THEN
4696 DO 310 I=1,NPA
4697 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
4698 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
4699 P(N+I,5)=MIN(QMAX,PS(5))
4700 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
4701 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
4702 310 CONTINUE
4703 ELSE
4704 IF(MSTJ(43).LE.2) PEM=V(IM,2)
4705 IF(MSTJ(43).GE.3) PEM=P(IM,4)
4706 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
4707 P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)
4708 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
4709 ENDIF
4710 DO 320 I=1,NEP
4711 PMSD(I)=P(N+I,5)
4712 IF(ISI(I).EQ.1) THEN
4713 IFLD=KFLD(I)
4714 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
4715 & ISIGN(2,K(N+I,2))
4716 IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
4717 ENDIF
4718 V(N+I,5)=P(N+I,5)**2
4719 320 CONTINUE
4720
4721C...Choose one of the daughters for evolution.
4722 330 INUM=0
4723 IF(NEP.EQ.1) INUM=1
4724 DO 340 I=1,NEP
4725 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
4726 340 CONTINUE
4727 DO 350 I=1,NEP
4728 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
4729 IFLD=KFLD(I)
4730 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
4731 & ISIGN(2,K(N+I,2))
4732 IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
4733 ENDIF
4734 350 CONTINUE
4735 IF(INUM.EQ.0) THEN
4736 RMAX=0.
4737 DO 360 I=1,NEP
4738 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
4739 RPM=P(N+I,5)/PMSD(I)
4740 IFLD=KFLD(I)
4741 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
4742 & ISIGN(2,K(N+I,2))
4743 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
4744 RMAX=RPM
4745 INUM=I
4746 ENDIF
4747 ENDIF
4748 360 CONTINUE
4749 ENDIF
4750
4751C...Store information on choice of evolving daughter.
4752 INUM=MAX(1,INUM)
4753 IEP(1)=N+INUM
4754 DO 370 I=2,NEP
4755 IEP(I)=IEP(I-1)+1
4756 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
4757 370 CONTINUE
4758 DO 380 I=1,NEP
4759 KFL(I)=IABS(K(IEP(I),2))
4760 380 CONTINUE
4761 ITRY(INUM)=ITRY(INUM)+1
4762 IF(ITRY(INUM).GT.200) THEN
4763 CALL LYERRM(14,'(LYSHOW:) caught in infinite loop')
4764 IF(MSTU(21).GE.1) RETURN
4765 ENDIF
4766 Z=0.5
4767 IF(KFL(1).GT.40) GOTO 430
4768 IF(KSH(KFL(1)).EQ.0) GOTO 430
4769 IFL=KFL(1)
4770 IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
4771 &ISIGN(2,K(IEP(1),2))
4772 IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
4773
4774C...Select side for interference with initial state partons.
4775 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
4776 III=IEP(1)-NS-1
4777 ISII(III)=0
4778 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
4779 ISII(III)=1
4780 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
4781 IF(RLY(0).GT.0.5) ISII(III)=1
4782 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
4783 ISII(III)=1
4784 IF(RLY(0).GT.0.5) ISII(III)=2
4785 ENDIF
4786 ENDIF
4787
4788C...Calculate allowed z range.
4789 IF(NEP.EQ.1) THEN
4790 PMED=PS(4)
4791 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4792 PMED=P(IM,5)
4793 ELSE
4794 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
4795 IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
4796 ENDIF
4797 IF(MOD(MSTJ(43),2).EQ.1) THEN
4798 ZC=PMTH(2,21)/PMED
4799 ZCE=PMTH(2,22)/PMED
4800 ELSE
4801 ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
4802 IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
4803 ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
4804 IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
4805 ENDIF
4806 ZC=MIN(ZC,0.491)
4807 ZCE=MIN(ZCE,0.491)
4808 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).GE.2.AND.
4809 &MIN(ZC,ZCE).GT.0.49)) THEN
4810 P(IEP(1),5)=PMTH(1,IFL)
4811 V(IEP(1),5)=P(IEP(1),5)**2
4812 GOTO 430
4813 ENDIF
4814
4815C...Integral of Altarelli-Parisi z kernel for QCD.
4816 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
4817 FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
4818 ELSEIF(MSTJ(49).EQ.0) THEN
4819 FBR=(8./3.)*LOG((1.-ZC)/ZC)
4820
4821C...Integral of Altarelli-Parisi z kernel for scalar gluon.
4822 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
4823 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
4824 ELSEIF(MSTJ(49).EQ.1) THEN
4825 FBR=(1.-2.*ZC)/3.
4826 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
4827
4828C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
4829 ELSEIF(KFL(1).EQ.21) THEN
4830 FBR=6.*MSTJ(45)*(0.5-ZC)
4831 ELSE
4832 FBR=2.*LOG((1.-ZC)/ZC)
4833 ENDIF
4834
4835C...Reset QCD probability for lepton.
4836 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0.
4837
4838C...Integral of Altarelli-Parisi kernel for photon emission.
4839 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
4840 FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
4841 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
4842 ENDIF
4843
4844C...Inner veto algorithm starts. Find maximum mass for evolution.
4845 390 PMS=V(IEP(1),5)
4846 IF(IGM.GE.0) THEN
4847 PM2=0.
4848 DO 400 I=2,NEP
4849 PM=P(IEP(I),5)
4850 IF(KFL(I).LE.40) THEN
4851 IFLI=KFL(I)
4852 IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
4853 & ISIGN(2,K(IEP(I),2))
4854 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
4855 ENDIF
4856 PM2=PM2+PM
4857 400 CONTINUE
4858 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
4859 ENDIF
4860
4861C...Select mass for daughter in QCD evolution.
4862 B0=27./6.
4863 DO 410 IFF=4,MSTJ(45)
4864 IF(PMS.GT.4.*PMTH(2,IFF)**2) B0=(33.-2.*IFF)/6.
4865 410 CONTINUE
4866 IF(FBR.LT.1E-3) THEN
4867 PMSQCD=0.
4868 ELSEIF(MSTJ(44).LE.0) THEN
4869 PMSQCD=PMS*EXP(MAX(-50.,LOG(RLY(0))*PARU(2)/(PARU(111)*FBR)))
4870 ELSEIF(MSTJ(44).EQ.1) THEN
4871 PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLY(0)**(B0/FBR))
4872 ELSE
4873 PMSQCD=PMS*EXP(MAX(-50.,ALFM*B0*LOG(RLY(0))/FBR))
4874 ENDIF
4875 IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2
4876 V(IEP(1),5)=PMSQCD
4877 MCE=1
4878
4879C...Select mass for daughter in QED evolution.
4880 IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
4881 PMSQED=PMS*EXP(MAX(-50.,LOG(RLY(0))*PARU(2)/(PARU(101)*FBRE)))
4882 IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
4883 & PMTH(2,IFL)**2
4884 IF(PMSQED.GT.PMSQCD) THEN
4885 V(IEP(1),5)=PMSQED
4886 MCE=2
4887 ENDIF
4888 ENDIF
4889
4890C...Check whether daughter mass below cutoff.
4891 P(IEP(1),5)=SQRT(V(IEP(1),5))
4892 IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
4893 P(IEP(1),5)=PMTH(1,IFL)
4894 V(IEP(1),5)=P(IEP(1),5)**2
4895 GOTO 430
4896 ENDIF
4897
4898C...Select z value of branching: q -> qgamma.
4899 IF(MCE.EQ.2) THEN
4900 Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLY(0)
4901 IF(1.+Z**2.LT.2.*RLY(0)) GOTO 390
4902 K(IEP(1),5)=22
4903
4904C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4905 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
4906 Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLY(0)
4907 IF(1.+Z**2.LT.2.*RLY(0)) GOTO 390
4908 K(IEP(1),5)=21
4909 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLY(0)*FBR) THEN
4910 Z=(1.-ZC)*(ZC/(1.-ZC))**RLY(0)
4911 IF(RLY(0).GT.0.5) Z=1.-Z
4912 IF((1.-Z*(1.-Z))**2.LT.RLY(0)) GOTO 390
4913 K(IEP(1),5)=21
4914 ELSEIF(MSTJ(49).NE.1) THEN
4915 Z=ZC+(1.-2.*ZC)*RLY(0)
4916 IF(Z**2+(1.-Z)**2.LT.RLY(0)) GOTO 390
4917 KFLB=1+INT(MSTJ(45)*RLY(0))
4918 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4919 IF(PMQ.GE.1.) GOTO 390
4920 PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
4921 IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
4922 & RLY(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 390
4923 K(IEP(1),5)=KFLB
4924
4925C...Ditto for scalar gluon model.
4926 ELSEIF(KFL(1).NE.21) THEN
4927 Z=1.-SQRT(ZC**2+RLY(0)*(1.-2.*ZC))
4928 K(IEP(1),5)=21
4929 ELSEIF(RLY(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
4930 Z=ZC+(1.-2.*ZC)*RLY(0)
4931 K(IEP(1),5)=21
4932 ELSE
4933 Z=ZC+(1.-2.*ZC)*RLY(0)
4934 KFLB=1+INT(MSTJ(45)*RLY(0))
4935 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4936 IF(PMQ.GE.1.) GOTO 390
4937 K(IEP(1),5)=KFLB
4938 ENDIF
4939 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
4940 IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
4941 IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLY(0)) GOTO 390
4942 ENDIF
4943
4944C...Check if z consistent with chosen m.
4945 IF(KFL(1).EQ.21) THEN
4946 KFLGD1=IABS(K(IEP(1),5))
4947 KFLGD2=KFLGD1
4948 ELSE
4949 KFLGD1=KFL(1)
4950 KFLGD2=IABS(K(IEP(1),5))
4951 ENDIF
4952 IF(NEP.EQ.1) THEN
4953 PED=PS(4)
4954 ELSEIF(NEP.GE.3) THEN
4955 PED=P(IEP(1),4)
4956 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4957 PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
4958 ELSE
4959 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
4960 IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
4961 ENDIF
4962 IF(MOD(MSTJ(43),2).EQ.1) THEN
4963 IFLGD1=KFLGD1
4964 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
4965 PMQTH3=0.5*PARJ(82)
4966 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4967 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
4968 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
4969 ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4970 & 4.*PMQ1*PMQ2)))
4971 ZH=1.+PMQ1-PMQ2
4972 ELSE
4973 ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
4974 ZH=1.
4975 ENDIF
4976 ZL=0.5*(ZH-ZD)
4977 ZU=0.5*(ZH+ZD)
4978 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
4979 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
4980 &(1.-ZU)))
4981 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4982
4983C...Width suppression for q -> q + g.
4984 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN
4985 IF(IGM.EQ.0) THEN
4986 EGLU=0.5*PS(5)*(1.-Z)*(1.+V(IEP(1),5)/V(NS+1,5))
4987 ELSE
4988 EGLU=PMED*(1.-Z)
4989 ENDIF
4990 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
4991 IF(MSTJ(40).EQ.1) THEN
4992 IF(CHI.LT.RLY(0)) GOTO 390
4993 ELSEIF(MSTJ(40).EQ.2) THEN
4994 IF(1.-CHI.LT.RLY(0)) GOTO 390
4995 ENDIF
4996 ENDIF
4997
4998C...Three-jet matrix element correction.
4999 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
5000 X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
5001 X2=1.-V(IEP(1),5)/V(NS+1,5)
5002 X3=(1.-X1)+(1.-X2)
5003 IF(MCE.EQ.2) THEN
5004 KI1=K(IPA(INUM),2)
5005 KI2=K(IPA(3-INUM),2)
5006 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
5007 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
5008 WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
5009 & QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
5010 WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
5011 ELSEIF(MSTJ(49).NE.1) THEN
5012 WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
5013 & (1.-X2)/X3*(X2/(2.-X1))**2
5014 WME=X1**2+X2**2
5015 IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5*QME**2-
5016 & (0.5*QME+0.25*QME**2)*((1.-X2)/MAX(1E-7,1.-X1)+
5017 & (1.-X1)/MAX(1E-7,1.-X2))
5018 ELSE
5019 WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
5020 WME=X3**2
5021 IF(MSTJ(102).GE.2) WME=X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*
5022 & PARJ(171)
5023 ENDIF
5024 IF(WME.LT.RLY(0)*WSHOW) GOTO 390
5025
5026C...Impose angular ordering by rejection of nonordered emission.
5027 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
5028 MAOM=1
5029 ZM=V(IM,1)
5030 IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
5031 THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
5032 IAOM=IM
5033 420 IF(K(IAOM,5).EQ.22) THEN
5034 IAOM=K(IAOM,3)
5035 IF(K(IAOM,3).LE.NS) MAOM=0
5036 IF(MAOM.EQ.1) GOTO 420
5037 ENDIF
5038 IF(MAOM.EQ.1) THEN
5039 THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
5040 IF(THE2ID.LT.THE2IM) GOTO 390
5041 ENDIF
5042 ENDIF
5043
5044C...Impose user-defined maximum angle at first branching.
5045 IF(MSTJ(48).EQ.1) THEN
5046 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
5047 THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
5048 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 390
5049 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
5050 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
5051 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 390
5052 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
5053 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
5054 IF(THE2ID.LT.1./PARJ(86)**2) GOTO 390
5055 ENDIF
5056 ENDIF
5057
5058C...Impose angular constraint in first branching from interference
5059C...with initial state partons.
5060 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
5061 THE2D=MAX((1.-Z)/Z,Z/(1.-Z))*V(IEP(1),5)/(0.5*P(IM,4))**2
5062 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
5063 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
5064 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
5065 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
5066 ENDIF
5067 ENDIF
5068
5069C...End of inner veto algorithm. Check if only one leg evolved so far.
5070 430 V(IEP(1),1)=Z
5071 ISL(1)=0
5072 ISL(2)=0
5073 IF(NEP.EQ.1) GOTO 460
5074 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
5075 DO 440 I=1,NEP
5076 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
5077 IF(KSH(KFLD(I)).EQ.1) THEN
5078 IFLD=KFLD(I)
5079 IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
5080 & ISIGN(2,K(N+I,2))
5081 IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
5082 ENDIF
5083 ENDIF
5084 440 CONTINUE
5085
5086C...Check if chosen multiplet m1,m2,z1,z2 is physical.
5087 IF(NEP.EQ.3) THEN
5088 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
5089 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
5090 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
5091 PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
5092 & PA1S**2-PA2S**2-PA3S**2)/PA1S
5093 IF(PTS.LE.0.) GOTO 330
5094 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
5095 DO 450 I1=N+1,N+2
5096 KFLDA=IABS(K(I1,2))
5097 IF(KFLDA.GT.40) GOTO 450
5098 IF(KSH(KFLDA).EQ.0) GOTO 450
5099 IFLDA=KFLDA
5100 IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
5101 & ISIGN(2,K(I1,2))
5102 IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
5103 IF(KFLDA.EQ.21) THEN
5104 KFLGD1=IABS(K(I1,5))
5105 KFLGD2=KFLGD1
5106 ELSE
5107 KFLGD1=KFLDA
5108 KFLGD2=IABS(K(I1,5))
5109 ENDIF
5110 I2=2*N+3-I1
5111 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
5112 PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
5113 ELSE
5114 IF(I1.EQ.N+1) ZM=V(IM,1)
5115 IF(I1.EQ.N+2) ZM=1.-V(IM,1)
5116 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
5117 & 4.*V(N+1,5)*V(N+2,5))
5118 PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
5119 ENDIF
5120 IF(MOD(MSTJ(43),2).EQ.1) THEN
5121 PMQTH3=0.5*PARJ(82)
5122 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
5123 IFLGD1=KFLGD1
5124 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
5125 PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
5126 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
5127 ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
5128 & 4.*PMQ1*PMQ2)))
5129 ZH=1.+PMQ1-PMQ2
5130 ELSE
5131 ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
5132 ZH=1.
5133 ENDIF
5134 ZL=0.5*(ZH-ZD)
5135 ZU=0.5*(ZH+ZD)
5136 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
5137 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
5138 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
5139 IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
5140 450 CONTINUE
5141 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
5142 ISL(3-ISLM)=0
5143 ISLM=3-ISLM
5144 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
5145 ZDR1=MAX(0.,V(N+1,3)/MAX(1E-6,V(N+1,4))-1.)
5146 ZDR2=MAX(0.,V(N+2,3)/MAX(1E-6,V(N+2,4))-1.)
5147 IF(ZDR2.GT.RLY(0)*(ZDR1+ZDR2)) ISL(1)=0
5148 IF(ISL(1).EQ.1) ISL(2)=0
5149 IF(ISL(1).EQ.0) ISLM=1
5150 IF(ISL(2).EQ.0) ISLM=2
5151 ENDIF
5152 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
5153 ENDIF
5154 IFLD1=KFLD(1)
5155 IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
5156 &ISIGN(2,K(N+1,2))
5157 IFLD2=KFLD(2)
5158 IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
5159 &ISIGN(2,K(N+2,2))
5160 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
5161 &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
5162 PMQ1=V(N+1,5)/V(IM,5)
5163 PMQ2=V(N+2,5)/V(IM,5)
5164 ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
5165 & 4.*PMQ1*PMQ2)))
5166 ZH=1.+PMQ1-PMQ2
5167 ZL=0.5*(ZH-ZD)
5168 ZU=0.5*(ZH+ZD)
5169 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
5170 ENDIF
5171
5172C...Accepted branch. Construct four-momentum for initial partons.
5173 460 MAZIP=0
5174 MAZIC=0
5175 IF(NEP.EQ.1) THEN
5176 P(N+1,1)=0.
5177 P(N+1,2)=0.
5178 P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
5179 & P(N+1,5))))
5180 P(N+1,4)=P(IPA(1),4)
5181 V(N+1,2)=P(N+1,4)
5182 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
5183 PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
5184 P(N+1,1)=0.
5185 P(N+1,2)=0.
5186 P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
5187 P(N+1,4)=PED1
5188 P(N+2,1)=0.
5189 P(N+2,2)=0.
5190 P(N+2,3)=-P(N+1,3)
5191 P(N+2,4)=P(IM,5)-PED1
5192 V(N+1,2)=P(N+1,4)
5193 V(N+2,2)=P(N+2,4)
5194 ELSEIF(NEP.EQ.3) THEN
5195 P(N+1,1)=0.
5196 P(N+1,2)=0.
5197 P(N+1,3)=SQRT(MAX(0.,PA1S))
5198 P(N+2,1)=SQRT(PTS)
5199 P(N+2,2)=0.
5200 P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
5201 P(N+3,1)=-P(N+2,1)
5202 P(N+3,2)=0.
5203 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
5204 V(N+1,2)=P(N+1,4)
5205 V(N+2,2)=P(N+2,4)
5206 V(N+3,2)=P(N+3,4)
5207
5208C...Construct transverse momentum for ordinary branching in shower.
5209 ELSE
5210 ZM=V(IM,1)
5211 PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
5212 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
5213 IF(PZM.LE.0.) THEN
5214 PTS=0.
5215 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
5216 PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
5217 & ZM*V(N+2,5))-0.25*PMLS)/PZM**2
5218 ELSE
5219 PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
5220 ENDIF
5221 PT=SQRT(MAX(0.,PTS))
5222
5223C...Find coefficient of azimuthal asymmetry due to gluon polarization.
5224 HAZIP=0.
5225 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
5226 & AND.IAU.NE.0) THEN
5227 IF(K(IGM,3).NE.0) MAZIP=1
5228 ZAU=V(IGM,1)
5229 IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
5230 IF(MAZIP.EQ.0) ZAU=0.
5231 IF(K(IGM,2).NE.21) THEN
5232 HAZIP=2.*ZAU/(1.+ZAU**2)
5233 ELSE
5234 HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
5235 ENDIF
5236 IF(K(N+1,2).NE.21) THEN
5237 HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
5238 ELSE
5239 HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
5240 ENDIF
5241 ENDIF
5242
5243C...Find coefficient of azimuthal asymmetry due to soft gluon
5244C...interference.
5245 HAZIC=0.
5246 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
5247 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
5248 IF(K(IGM,3).NE.0) MAZIC=N+1
5249 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
5250 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
5251 & ZM.GT.0.5) MAZIC=N+2
5252 IF(K(IAU,2).EQ.22) MAZIC=0
5253 ZS=ZM
5254 IF(MAZIC.EQ.N+2) ZS=1.-ZM
5255 ZGM=V(IGM,1)
5256 IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
5257 IF(MAZIC.EQ.0) ZGM=1.
5258 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
5259 & SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
5260 HAZIC=MIN(0.95,HAZIC)
5261 ENDIF
5262 ENDIF
5263
5264C...Construct kinematics for ordinary branching in shower.
5265 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
5266 IF(MOD(MSTJ(43),2).EQ.1) THEN
5267 P(N+1,4)=PEM*V(IM,1)
5268 ELSE
5269 P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
5270 & SQRT(PMLS)*ZM)/V(IM,5)
5271 ENDIF
5272 PHI=PARU(2)*RLY(0)
5273 P(N+1,1)=PT*COS(PHI)
5274 P(N+1,2)=PT*SIN(PHI)
5275 IF(PZM.GT.0.) THEN
5276 P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
5277 ELSE
5278 P(N+1,3)=0.
5279 ENDIF
5280 P(N+2,1)=-P(N+1,1)
5281 P(N+2,2)=-P(N+1,2)
5282 P(N+2,3)=PZM-P(N+1,3)
5283 P(N+2,4)=PEM-P(N+1,4)
5284 IF(MSTJ(43).LE.2) THEN
5285 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
5286 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
5287 ENDIF
5288 ENDIF
5289
5290C...Rotate and boost daughters.
5291 IF(IGM.GT.0) THEN
5292 IF(MSTJ(43).LE.2) THEN
5293 BEX=P(IGM,1)/P(IGM,4)
5294 BEY=P(IGM,2)/P(IGM,4)
5295 BEZ=P(IGM,3)/P(IGM,4)
5296 GA=P(IGM,4)/P(IGM,5)
5297 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
5298 & P(IM,4))
5299 ELSE
5300 BEX=0.
5301 BEY=0.
5302 BEZ=0.
5303 GA=1.
5304 GABEP=0.
5305 ENDIF
5306 THE=UYANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
5307 & (P(IM,2)+GABEP*BEY)**2))
5308 PHI=UYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
5309 DO 480 I=N+1,N+2
5310 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
5311 & SIN(THE)*COS(PHI)*P(I,3)
5312 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
5313 & SIN(THE)*SIN(PHI)*P(I,3)
5314 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
5315 DP(4)=P(I,4)
5316 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
5317 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
5318 P(I,1)=DP(1)+DGABP*BEX
5319 P(I,2)=DP(2)+DGABP*BEY
5320 P(I,3)=DP(3)+DGABP*BEZ
5321 P(I,4)=GA*(DP(4)+DBP)
5322 480 CONTINUE
5323 ENDIF
5324
5325C...Weight with azimuthal distribution, if required.
5326 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
5327 DO 490 J=1,3
5328 DPT(1,J)=P(IM,J)
5329 DPT(2,J)=P(IAU,J)
5330 DPT(3,J)=P(N+1,J)
5331 490 CONTINUE
5332 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
5333 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
5334 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
5335 DO 500 J=1,3
5336 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
5337 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
5338 500 CONTINUE
5339 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
5340 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
5341 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN
5342 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
5343 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
5344 IF(MAZIP.NE.0) THEN
5345 IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLY(0)*(1.+ABS(HAZIP)))
5346 & GOTO 470
5347 ENDIF
5348 IF(MAZIC.NE.0) THEN
5349 IF(MAZIC.EQ.N+2) CAD=-CAD
5350 IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD)
5351 & .LT.RLY(0)) GOTO 470
5352 ENDIF
5353 ENDIF
5354 ENDIF
5355
5356C...Azimuthal anisotropy due to interference with initial state partons.
5357 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
5358 &K(N+2,2).EQ.21)) THEN
5359 III=IM-NS-1
5360 IF(ISII(III).GE.1) THEN
5361 IAZIID=N+1
5362 IF(K(N+1,2).NE.21) IAZIID=N+2
5363 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
5364 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
5365 THEIID=UYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
5366 IF(III.EQ.2) THEIID=PARU(1)-THEIID
5367 PHIIID=UYANGL(P(IAZIID,1),P(IAZIID,2))
5368 HAZII=MIN(0.95,THEIID/THEIIS(III,ISII(III)))
5369 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
5370 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
5371 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
5372 IF((1.-HAZII)*(1.-HAZII*CAD)/(1.+HAZII**2-2.*HAZII*CAD)
5373 & .LT.RLY(0)) GOTO 470
5374 ENDIF
5375 ENDIF
5376
5377C...Continue loop over partons that may branch, until none left.
5378 IF(IGM.GE.0) K(IM,1)=14
5379 N=N+NEP
5380 NEP=2
5381 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
5382 CALL LYERRM(11,'(LYSHOW:) no more memory left in LUJETS')
5383 IF(MSTU(21).GE.1) N=NS
5384 IF(MSTU(21).GE.1) RETURN
5385 ENDIF
5386 GOTO 270
5387
5388C...Set information on imagined shower initiator.
5389 510 IF(NPA.GE.2) THEN
5390 K(NS+1,1)=11
5391 K(NS+1,2)=94
5392 K(NS+1,3)=IP1
5393 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
5394 K(NS+1,4)=NS+2
5395 K(NS+1,5)=NS+1+NPA
5396 IIM=1
5397 ELSE
5398 IIM=0
5399 ENDIF
5400
5401C...Reconstruct string drawing information.
5402 DO 520 I=NS+1+IIM,N
5403 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
5404 K(I,1)=1
5405 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
5406 &IABS(K(I,2)).LE.18) THEN
5407 K(I,1)=1
5408 ELSEIF(K(I,1).LE.10) THEN
5409 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
5410 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
5411 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
5412 ID1=MOD(K(I,4),MSTU(5))
5413 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
5414 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
5415 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
5416 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
5417 K(ID1,4)=K(ID1,4)+MSTU(5)*I
5418 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
5419 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
5420 K(ID2,5)=K(ID2,5)+MSTU(5)*I
5421 ELSE
5422 ID1=MOD(K(I,4),MSTU(5))
5423 ID2=ID1+1
5424 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
5425 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
5426 IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
5427 K(ID1,4)=K(ID1,4)+MSTU(5)*I
5428 K(ID1,5)=K(ID1,5)+MSTU(5)*I
5429 ELSE
5430 K(ID1,4)=0
5431 K(ID1,5)=0
5432 ENDIF
5433 K(ID2,4)=0
5434 K(ID2,5)=0
5435 ENDIF
5436 520 CONTINUE
5437
5438C...Transformation from CM frame.
5439 IF(NPA.GE.2) THEN
5440 BEX=PS(1)/PS(4)
5441 BEY=PS(2)/PS(4)
5442 BEZ=PS(3)/PS(4)
5443 GA=PS(4)/PS(5)
5444 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
5445 & /(1.+GA)-P(IPA(1),4))
5446 ELSE
5447 BEX=0.
5448 BEY=0.
5449 BEZ=0.
5450 GABEP=0.
5451 ENDIF
5452 THE=UYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
5453 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
5454 PHI=UYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
5455 IF(NPA.EQ.3) THEN
5456 CHI=UYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
5457 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
5458 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
5459 & GABEP*BEY))
5460 MSTU(33)=1
5461 CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
5462 ENDIF
5463 DBEX=DBLE(BEX)
5464 DBEY=DBLE(BEY)
5465 DBEZ=DBLE(BEZ)
5466 MSTU(33)=1
5467 CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
5468
5469C...Decay vertex of shower.
5470 DO 540 I=NS+1,N
5471 DO 530 J=1,5
5472 V(I,J)=V(IP1,J)
5473 530 CONTINUE
5474 540 CONTINUE
5475
5476C...Delete trivial shower, else connect initiators.
5477 IF(N.EQ.NS+NPA+IIM) THEN
5478 N=NS
5479 ELSE
5480 DO 550 IP=1,NPA
5481 K(IPA(IP),1)=14
5482 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
5483 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
5484 K(NS+IIM+IP,3)=IPA(IP)
5485 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
5486 IF(K(NS+IIM+IP,1).NE.1) THEN
5487 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
5488 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
5489 ENDIF
5490 550 CONTINUE
5491 ENDIF
5492
5493 RETURN
5494 END
5495
5496C*********************************************************************
5497
5498 SUBROUTINE LYBOEI(NSAV)
5499
5500C...Purpose: to modify event so as to approximately take into account
5501C...Bose-Einstein effects according to a simple phenomenological
5502C...parametrization.
5503 IMPLICIT DOUBLE PRECISION(D)
5504 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
5505 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5506 SAVE /LYJETS/,/LYDAT1/
5507 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
5508 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
5509
5510C...Boost event to overall CM frame. Calculate CM energy.
5511 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
5512 DO 100 J=1,4
5513 DPS(J)=0.
5514 100 CONTINUE
5515 DO 120 I=1,N
5516 KFA=IABS(K(I,2))
5517 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22).AND.
5518 &K(I,3).GT.0) THEN
5519 KFMA=IABS(K(K(I,3),2))
5520 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
5521 ELSEIF(KFA.EQ.22.AND.K(I,3).EQ.0) THEN
5522 K(I,1)=-K(I,1)
5523 ENDIF
5524 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
5525 DO 110 J=1,4
5526 DPS(J)=DPS(J)+P(I,J)
5527 110 CONTINUE
5528 120 CONTINUE
5529 CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
5530 &-DPS(3)/DPS(4))
5531 PECM=0.
5532 DO 130 I=1,N
5533 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
5534 130 CONTINUE
5535
5536C...Reserve copy of particles by species at end of record.
5537 NBE(0)=N+MSTU(3)
5538 DO 160 IBE=1,MIN(9,MSTJ(52))
5539 NBE(IBE)=NBE(IBE-1)
5540 DO 150 I=NSAV+1,N
5541 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
5542 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
5543 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
5544 CALL LYERRM(11,'(LYBOEI:) no more memory left in LUJETS')
5545 RETURN
5546 ENDIF
5547 NBE(IBE)=NBE(IBE)+1
5548 K(NBE(IBE),1)=I
5549 DO 140 J=1,3
5550 P(NBE(IBE),J)=0.
5551 140 CONTINUE
5552 150 CONTINUE
5553 160 CONTINUE
5554 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280
5555
5556C...Tabulate integral for subsequent momentum shift.
5557 DO 220 IBE=1,MIN(9,MSTJ(52))
5558 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
5559 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
5560 &.LE.1) GOTO 180
5561 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
5562 &NBE(7)-NBE(6)).LE.1) GOTO 180
5563 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
5564 IF(IBE.EQ.1) PMHQ=2.*UYMASS(211)
5565 IF(IBE.EQ.4) PMHQ=2.*UYMASS(321)
5566 IF(IBE.EQ.8) PMHQ=2.*UYMASS(221)
5567 IF(IBE.EQ.9) PMHQ=2.*UYMASS(331)
5568 QDEL=0.1*MIN(PMHQ,PARJ(93))
5569 IF(MSTJ(51).EQ.1) THEN
5570 NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
5571 BEEX=EXP(0.5*QDEL/PARJ(93))
5572 BERT=EXP(-QDEL/PARJ(93))
5573 ELSE
5574 NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
5575 ENDIF
5576 DO 170 IBIN=1,NBIN
5577 QBIN=QDEL*(IBIN-0.5)
5578 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
5579 IF(MSTJ(51).EQ.1) THEN
5580 BEEX=BEEX*BERT
5581 BEI(IBIN)=BEI(IBIN)*BEEX
5582 ELSE
5583 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
5584 ENDIF
5585 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
5586 170 CONTINUE
5587
5588C...Loop through particle pairs and find old relative momentum.
5589 180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1
5590 I1=K(I1M,1)
5591 DO 200 I2M=I1M+1,NBE(IBE)
5592 I2=K(I2M,1)
5593 Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
5594 &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
5595 QOLD=SQRT(Q2OLD)
5596
5597C...Calculate new relative momentum.
5598 IF(QOLD.LT.1E-3*QDEL) THEN
5599 GOTO 200
5600 ELSEIF(QOLD.LE.QDEL) THEN
5601 QMOV=QOLD/3.
5602 ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
5603 RBIN=QOLD/QDEL
5604 IBIN=RBIN
5605 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
5606 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
5607 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
5608 ELSE
5609 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
5610 ENDIF
5611 Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
5612
5613C...Calculate and save shift to be performed on three-momenta.
5614 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
5615 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
5616 HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
5617 DO 190 J=1,3
5618 PD=HA*(P(I2,J)-P(I1,J))
5619 P(I1M,J)=P(I1M,J)+PD
5620 P(I2M,J)=P(I2M,J)-PD
5621 190 CONTINUE
5622 200 CONTINUE
5623 210 CONTINUE
5624 220 CONTINUE
5625
5626C...Shift momenta and recalculate energies.
5627 DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
5628 I=K(IM,1)
5629 DO 230 J=1,3
5630 P(I,J)=P(I,J)+P(IM,J)
5631 230 CONTINUE
5632 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5633 240 CONTINUE
5634
5635C...Rescale all momenta for energy conservation.
5636 PES=0.
5637 PQS=0.
5638 DO 250 I=1,N
5639 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250
5640 PES=PES+P(I,4)
5641 PQS=PQS+P(I,5)**2/P(I,4)
5642 250 CONTINUE
5643 FAC=(PECM-PQS)/(PES-PQS)
5644 DO 270 I=1,N
5645 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
5646 DO 260 J=1,3
5647 P(I,J)=FAC*P(I,J)
5648 260 CONTINUE
5649 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5650 270 CONTINUE
5651
5652C...Boost back to correct reference frame.
5653 280 CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
5654 DO 290 I=1,N
5655 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
5656 290 CONTINUE
5657
5658 RETURN
5659 END
5660
5661C*********************************************************************
5662
5663 FUNCTION UYMASS(KF)
5664
5665C...Purpose: to give the mass of a particle/parton.
5666 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5667 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5668 SAVE /LYDAT1/,/LYDAT2/
5669
5670C...Reset variables. Compressed code.
5671 UYMASS=0.
5672 KFA=IABS(KF)
5673 KC=LYCOMP(KF)
5674 IF(KC.EQ.0) RETURN
5675 PARF(106)=PMAS(6,1)
5676 PARF(107)=PMAS(7,1)
5677 PARF(108)=PMAS(8,1)
5678
5679C...Guarantee use of constituent masses for internal checks.
5680 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
5681 UYMASS=PARF(100+KFA)
5682 IF(MSTJ(93).EQ.2) UYMASS=MAX(0.,UYMASS-PARF(121))
5683
5684C...Masses that can be read directly off table.
5685 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5686 UYMASS=PMAS(KC,1)
5687
5688C...Find constituent partons and their masses.
5689 ELSE
5690 KFLA=MOD(KFA/1000,10)
5691 KFLB=MOD(KFA/100,10)
5692 KFLC=MOD(KFA/10,10)
5693 KFLS=MOD(KFA,10)
5694 KFLR=MOD(KFA/10000,10)
5695 PMA=PARF(100+KFLA)
5696 PMB=PARF(100+KFLB)
5697 PMC=PARF(100+KFLC)
5698
5699C...Construct masses for various meson, diquark and baryon cases.
5700 IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5701 IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
5702 IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
5703 UYMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
5704 ELSEIF(KFLA.EQ.0) THEN
5705 KMUL=2
5706 IF(KFLS.EQ.1) KMUL=3
5707 IF(KFLR.EQ.2) KMUL=4
5708 IF(KFLS.EQ.5) KMUL=5
5709 UYMASS=PARF(113+KMUL)+PMB+PMC
5710 ELSEIF(KFLC.EQ.0) THEN
5711 IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
5712 IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
5713 UYMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
5714 IF(MSTJ(93).EQ.1) UYMASS=PMA+PMB
5715 IF(MSTJ(93).EQ.2) UYMASS=MAX(0.,UYMASS-PARF(122)-
5716 & 2.*PARF(112)/3.)
5717 ELSE
5718 IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
5719 PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
5720 ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
5721 PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
5722 ELSEIF(KFLS.EQ.2) THEN
5723 PMSPL=-3./(PMB*PMC)
5724 ELSE
5725 PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
5726 ENDIF
5727 UYMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
5728 ENDIF
5729 ENDIF
5730
5731C...Optional mass broadening according to truncated Breit-Wigner
5732C...(either in m or in m^2).
5733 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
5734 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
5735 UYMASS=UYMASS+0.5*PMAS(KC,2)*TAN((2.*RLY(0)-1.)*
5736 & ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
5737 ELSE
5738 PM0=UYMASS
5739 PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
5740 & (PM0*PMAS(KC,2)))
5741 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
5742 UYMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
5743 & (PMUPP-PMLOW)*RLY(0))))
5744 ENDIF
5745 ENDIF
5746 MSTJ(93)=0
5747
5748 RETURN
5749 END
5750
5751C*********************************************************************
5752
5753 SUBROUTINE LYNAME(KF,CHAU)
5754
5755C...Purpose: to give the particle/parton name as a character string.
5756 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5757 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5758 COMMON/LYDAT4/CHAF(500)
5759 CHARACTER CHAF*8
5760 SAVE /LYDAT1/,/LYDAT2/,/LYDAT4/
5761 CHARACTER CHAU*16
5762
5763C...Initial values. Charge. Subdivide code.
5764 CHAU=' '
5765 KFA=IABS(KF)
5766 KC=LYCOMP(KF)
5767 IF(KC.EQ.0) RETURN
5768 KQ=LYCHGE(KF)
5769 KFLA=MOD(KFA/1000,10)
5770 KFLB=MOD(KFA/100,10)
5771 KFLC=MOD(KFA/10,10)
5772 KFLS=MOD(KFA,10)
5773 KFLR=MOD(KFA/10000,10)
5774
5775C...Read out root name and spin for simple particle.
5776 IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
5777 CHAU=CHAF(KC)
5778 LEN=0
5779 DO 100 LEM=1,8
5780 IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
5781 100 CONTINUE
5782
5783C...Construct root name for diquark. Add on spin.
5784 ELSEIF(KFLC.EQ.0) THEN
5785 CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
5786 IF(KFLS.EQ.1) CHAU(3:4)='_0'
5787 IF(KFLS.EQ.3) CHAU(3:4)='_1'
5788 LEN=4
5789
5790C...Construct root name for heavy meson. Add on spin and heavy flavour.
5791 ELSEIF(KFLA.EQ.0) THEN
5792 IF(KFLB.EQ.5) CHAU(1:1)='B'
5793 IF(KFLB.EQ.6) CHAU(1:1)='T'
5794 IF(KFLB.EQ.7) CHAU(1:1)='L'
5795 IF(KFLB.EQ.8) CHAU(1:1)='H'
5796 LEN=1
5797 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5798 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5799 CHAU(2:2)='*'
5800 LEN=2
5801 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5802 CHAU(2:3)='_1'
5803 LEN=3
5804 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5805 CHAU(2:4)='*_0'
5806 LEN=4
5807 ELSEIF(KFLR.EQ.2) THEN
5808 CHAU(2:4)='*_1'
5809 LEN=4
5810 ELSEIF(KFLS.EQ.5) THEN
5811 CHAU(2:4)='*_2'
5812 LEN=4
5813 ENDIF
5814 IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5815 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
5816 LEN=LEN+2
5817 ELSEIF(KFLC.GE.3) THEN
5818 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5819 LEN=LEN+1
5820 ENDIF
5821
5822C...Construct root name and spin for heavy baryon.
5823 ELSE
5824 IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
5825 CHAU='Sigma '
5826 IF(KFLC.GT.KFLB) CHAU='Lambda'
5827 IF(KFLS.EQ.4) CHAU='Sigma*'
5828 LEN=5
5829 IF(CHAU(6:6).NE.' ') LEN=6
5830 ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
5831 CHAU='Xi '
5832 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
5833 IF(KFLS.EQ.4) CHAU='Xi*'
5834 LEN=2
5835 IF(CHAU(3:3).NE.' ') LEN=3
5836 ELSE
5837 CHAU='Omega '
5838 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
5839 IF(KFLS.EQ.4) CHAU='Omega*'
5840 LEN=5
5841 IF(CHAU(6:6).NE.' ') LEN=6
5842 ENDIF
5843
5844C...Add on heavy flavour content for heavy baryon.
5845 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
5846 LEN=LEN+2
5847 IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
5848 CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
5849 LEN=LEN+2
5850 ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
5851 CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
5852 LEN=LEN+1
5853 ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
5854 CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
5855 LEN=LEN+2
5856 ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
5857 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5858 LEN=LEN+1
5859 ENDIF
5860 ENDIF
5861
5862C...Add on bar sign for antiparticle (where necessary).
5863 IF(KF.GT.0.OR.LEN.EQ.0) THEN
5864 ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0.AND.MOD(KQ,3).EQ.0)
5865 &THEN
5866 ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
5867 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
5868 ELSEIF(MSTU(15).LE.1) THEN
5869 CHAU(LEN+1:LEN+1)='~'
5870 LEN=LEN+1
5871 ELSE
5872 CHAU(LEN+1:LEN+3)='bar'
5873 LEN=LEN+3
5874 ENDIF
5875
5876C...Add on charge where applicable (conventional cases skipped).
5877 IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
5878 IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
5879 IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
5880 IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
5881 IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
5882 ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
5883 ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
5884 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
5885 &KFLB.NE.1) THEN
5886 ELSEIF(KQ.EQ.0) THEN
5887 CHAU(LEN+1:LEN+1)='0'
5888 ENDIF
5889
5890 RETURN
5891 END
5892
5893C*********************************************************************
5894
5895 FUNCTION LYCHGE(KF)
5896
5897C...Purpose: to give three times the charge for a particle/parton.
5898 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5899 SAVE /LYDAT2/
5900
5901C...Initial values. Simple case of direct readout.
5902 LYCHGE=0
5903 KFA=IABS(KF)
5904 KC=LYCOMP(KFA)
5905 IF(KC.EQ.0) THEN
5906 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5907 LYCHGE=KCHG(KC,1)
5908
5909C...Construction from quark content for heavy meson, diquark, baryon.
5910 ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
5911 LYCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
5912 & (-1)**MOD(KFA/100,10)
5913 ELSEIF(MOD(KFA/10,10).EQ.0) THEN
5914 LYCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
5915 ELSE
5916 LYCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
5917 & KCHG(MOD(KFA/10,10),1)
5918 ENDIF
5919
5920C...Add on correct sign.
5921 LYCHGE=LYCHGE*ISIGN(1,KF)
5922
5923 RETURN
5924 END
5925
5926C*********************************************************************
5927 integer function lycomp_beg(kfa)
5928*
5929*
5930* called by modified LYCOMP_BEG to add user defined particles
5931*
5932* added ASLUND backward compatibility Dec 1994
5933* added LYCOMP_BEG=410+abs(KF)/100 000 July 1994
5934* added UPS 4S,5S Jan 1994
5935* added all bb-onia below threshold Jun 97 RW
5936*
5937* NOTE: ASLUND version maps LYCOMP_BEG = 400 + KFA/1 000 000
5938*
5939* Doug Wright Oct 1994
5940* R.Waldi Nov 1997
5941
5942 implicit none
5943
5944C #include "beget.inc" (Don't need beget.inc) 1/16/98
5945
5946 integer N_BB
5947 PARAMETER (N_BB = 22)
5948 integer KF_BB(N_BB),KC_BB(N_BB),I
5949
5950 DATA KF_BB
5951* UPS(3S),UPS(4S),UPS(5S),UPS_1(1D),UPS_2(1D),UPS_3(1D)
5952 1 / 60553, 70553, 80553, 120553, 30555, 557,
5953* UPS_1(2D),UPS_2(2D),UPS_3(2D),chi_0b(2P),chi_1b(2P),chi_2b(2P)
5954 1 130553, 50555, 10557, 30551, 50553, 10555,
5955* h_b(2P),chi_0b(3P),chi_1b(3P),chi_2b(3P),h_b(3P),eta_b(2S),
5956 1 40553, 50551, 110553, 20555, 100553, 20551,
5957* eta_b(3S),eta_2b(1D),eta_2b(2D),eta_c(2S)
5958 1 40551, 40555, 60555, 20441/
5959 DATA KC_BB
5960* UPS(3S),UPS(4S),UPS(5S),UPS_1(1D),UPS_2(1D),UPS_3(1D)
5961 1 / 403, 404, 405, 416, 417, 418,
5962* UPS_1(2D),UPS_2(2D),UPS_3(2D),chi_0b(2P),chi_1b(2P),chi_2b(2P)
5963 1 419, 420, 421, 410, 411, 412,
5964* h_b(2P),chi_0b(3P),chi_1b(3P),chi_2b(3P),h_b(3P),eta_b(2S),
5965 1 422, 413, 414, 415, 423, 401,
5966* eta_b(3S),eta_2b(1D),eta_2b(2D),eta_c(2S)
5967 1 402, 424, 425, 460/
5968
5969 integer kfa
5970
5971 LYCOMP_BEG = 0
5972 IF( KFA.GE.1000000) THEN ! for ASLUND backward compatibility
5973 LYCOMP_BEG = 400 + MOD(KFA/1 000 000,100)
5974c ELSEIF(KFA.GE.100000) THEN
5975c LYCOMP_BEG = 410 + MOD(KFA/100 000, 90)
5976 ELSE
5977 DO 100 I=1,N_BB
5978 IF(KFA.eq.KF_BB(I)) THEN
5979 LYCOMP_BEG = KC_BB(I)
5980 GOTO 110
5981 ENDIF
5982 100 CONTINUE
5983 110 CONTINUE
5984 ENDIF
5985 end
5986
5987C*********************************************************************
5988
5989 FUNCTION LYCOMP(KF)
5990 implicit none
5991*****-*****************************************************************-*******
5992C...Purpose: to compress the standard KF codes for use in mass and decay
5993C...arrays; also to check whether a given code actually is defined.
5994C.. History:
5995C
5996C 12-Aug-1997 - Lockman : implicit none added; save KFTAB, KCTAB
5997C... modified R.Waldi/92-07.v7.4:97-06 beget conv./stdhep, 97/11 evtgen
5998C 11-Sep-2000 - Mark Ian Williams added X_su/d/s for BtoXsgamma model
5999*****-*****************************************************************-*******
6000 integer kf
6001 integer lycomp, lycomp_beg
6002 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6003 SAVE /LYDAT2/
6004 integer kchg
6005 real*4 pmas, parf, vckm
6006* DIMENSION KFTAB(25),KCTAB(25)
6007 integer KFTAB(25),KCTAB(25)
6008 save KFTAB, KCTAB
6009 integer kfa, ikf, kfla, kflb, kflc, kfls, kflr
6010 DATA KFTAB/211,111,221,311,321,130,310,213,113,223,
6011 &313,323,2112,2212,210,2110,2210,110,220,330,440,30443,30553,0,0/
6012 DATA KCTAB/101,111,112,102,103,221,222,121,131,132,
6013 &122,123,332,333,281,282,283,284,285,286,287,231,235,0,0/
6014
6015C...Starting values.
6016 LYCOMP=lycomp_beg(KF)
6017 IF (LYCOMP .NE. 0) RETURN
6018
6019 KFA=IABS(KF)
6020
6021C...Subdivide KF code into constituent pieces.
6022
6023 KFLR=MOD(KFA/10000,10)
6024 KFLA=MOD(KFA/1000,10)
6025 KFLB=MOD(KFA/100,10)
6026 KFLC=MOD(KFA/10,10)
6027 KFLS=MOD(KFA,10)
6028
6029C...Hardwire the return code for -42 since EvtJetSet updates the particles
6030C too late for the Xu- decays to be recognized
6031 IF (KF.EQ.-42) THEN
6032 LYCOMP=KFA
6033 RETURN
6034 ENDIF
6035
6036C...Allow for massive sbar-u, sbar-d, sbar-s systems
6037 IF (KFA.EQ.30343.OR.KFA.EQ.30353.OR.KFA.EQ.30363) THEN
6038 LYCOMP=451+KFLC
6039 RETURN
6040 ENDIF
6041
6042C...Simple cases: direct translation or table.
6043 IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
6044 RETURN
6045 ELSEIF(KFA.LE.100) THEN
6046 LYCOMP=KFA
6047 IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LYCOMP=0
6048 RETURN
6049 ELSE
6050 DO 100 IKF=1,23
6051 IF(KFA.EQ.KFTAB(IKF)) THEN
6052 LYCOMP=KCTAB(IKF)
6053 IF(KF.LT.0.AND.KCHG(LYCOMP,3).EQ.0) LYCOMP=0
6054 RETURN
6055 ENDIF
6056 100 CONTINUE
6057 ENDIF
6058
6059C...Mesons.
6060 IF(KFA-10000*KFLR.LT.1000) THEN
6061 IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
6062 ELSEIF(KFLB.LT.KFLC) THEN
6063 ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
6064 ELSEIF(KFLB.EQ.KFLC) THEN
6065 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
6066 LYCOMP=110+KFLB
6067 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
6068 LYCOMP=130+KFLB
6069 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
6070 LYCOMP=150+KFLB
6071 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
6072 LYCOMP=170+KFLB
6073 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
6074 LYCOMP=190+KFLB
6075 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
6076 LYCOMP=210+KFLB
6077 ENDIF
6078 ELSEIF(KFLB.LE.5) THEN
6079 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
6080 LYCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
6081 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
6082 LYCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
6083 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
6084 LYCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
6085 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
6086 LYCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
6087 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
6088 LYCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
6089 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
6090 LYCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
6091 ENDIF
6092 ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2)
6093 & .OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
6094 LYCOMP=80+KFLB
6095 ENDIF
6096
6097C...Diquarks.
6098 ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
6099 IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
6100 ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
6101 ELSEIF(KFLA.LT.KFLB) THEN
6102 ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
6103 ELSE
6104 LYCOMP=90
6105 ENDIF
6106
6107C...Spin 1/2 baryons.
6108 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
6109 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
6110 ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
6111 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
6112 LYCOMP=80+KFLA
6113 ELSEIF(KFLB.LT.KFLC) THEN
6114 LYCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
6115 ELSE
6116 LYCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
6117 ENDIF
6118
6119C...Spin 3/2 baryons.
6120 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
6121 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
6122 ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
6123 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
6124 LYCOMP=80+KFLA
6125 ELSE
6126 LYCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
6127 ENDIF
6128 ENDIF
6129
6130 RETURN
6131 END
6132
6133C*********************************************************************
6134
6135 SUBROUTINE LYERRM(MERR,CHMESS)
6136
6137C...Purpose: to inform user of errors in program execution.
6138 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
6139 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6140 SAVE /LYJETS/,/LYDAT1/
6141 CHARACTER CHMESS*(*)
6142
6143C...Write first few warnings, then be silent.
6144 IF(MERR.LE.10) THEN
6145 MSTU(27)=MSTU(27)+1
6146 MSTU(28)=MERR
6147 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
6148 & MERR,MSTU(31),CHMESS
6149
6150C...Write first few errors, then be silent or stop program.
6151 ELSEIF(MERR.LE.20) THEN
6152 MSTU(23)=MSTU(23)+1
6153 MSTU(24)=MERR-10
6154 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
6155 & MERR-10,MSTU(31),CHMESS
6156 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
6157 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
6158 WRITE(MSTU(11),5200)
6159 IF(MERR.NE.17) CALL LYLIST(2)
6160 STOP
6161 ENDIF
6162
6163C...Stop program in case of irreparable error.
6164 ELSE
6165 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
6166 STOP
6167 ENDIF
6168
6169C...Formats for output.
6170 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
6171 &' LYEXEC calls:'/5X,A)
6172 5100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
6173 &' LYEXEC calls:'/5X,A)
6174 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
6175 &'event!')
6176 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
6177 &' LYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
6178
6179 RETURN
6180 END
6181
6182C*********************************************************************
6183
6184 FUNCTION UYALEM(Q2)
6185
6186C...Purpose: to calculate the running alpha_electromagnetic.
6187 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6188 SAVE /LYDAT1/
6189
6190C...Calculate real part of photon vacuum polarization.
6191C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
6192C...For hadrons use parametrization of H. Burkhardt et al.
6193C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
6194 AEMPI=PARU(101)/(3.*PARU(1))
6195 IF(MSTU(101).LE.0.OR.Q2.LT.2E-6) THEN
6196 RPIGG=0.
6197 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
6198 RPIGG=0.
6199 ELSEIF(MSTU(101).EQ.2) THEN
6200 RPIGG=1.-PARU(101)/PARU(103)
6201 ELSEIF(Q2.LT.0.09) THEN
6202 RPIGG=AEMPI*(13.4916+LOG(Q2))+0.00835*LOG(1.+Q2)
6203 ELSEIF(Q2.LT.9.) THEN
6204 RPIGG=AEMPI*(16.3200+2.*LOG(Q2))+0.00238*LOG(1.+3.927*Q2)
6205 ELSEIF(Q2.LT.1E4) THEN
6206 RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00165+0.00299*LOG(1.+Q2)
6207 ELSE
6208 RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00221+0.00293*LOG(1.+Q2)
6209 ENDIF
6210
6211C...Calculate running alpha_em.
6212 UYALEM=PARU(101)/(1.-RPIGG)
6213 PARU(108)=UYALEM
6214
6215 RETURN
6216 END
6217
6218C*********************************************************************
6219
6220 FUNCTION UYALPS(Q2)
6221
6222C...Purpose: to give the value of alpha_strong.
6223 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6224 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6225 SAVE /LYDAT1/,/LYDAT2/
6226
6227C...Constant alpha_strong trivial.
6228 IF(MSTU(111).LE.0) THEN
6229 UYALPS=PARU(111)
6230 MSTU(118)=MSTU(112)
6231 PARU(117)=0.
6232 PARU(118)=PARU(111)
6233 RETURN
6234 ENDIF
6235
6236C...Find effective Q2, number of flavours and Lambda.
6237 Q2EFF=Q2
6238 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
6239 NF=MSTU(112)
6240 ALAM2=PARU(112)**2
6241 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
6242 Q2THR=PARU(113)*PMAS(NF,1)**2
6243 IF(Q2EFF.LT.Q2THR) THEN
6244 NF=NF-1
6245 ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
6246 GOTO 100
6247 ENDIF
6248 ENDIF
6249 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
6250 Q2THR=PARU(113)*PMAS(NF+1,1)**2
6251 IF(Q2EFF.GT.Q2THR) THEN
6252 NF=NF+1
6253 ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
6254 GOTO 110
6255 ENDIF
6256 ENDIF
6257 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
6258 PARU(117)=SQRT(ALAM2)
6259
6260C...Evaluate first or second order alpha_strong.
6261 B0=(33.-2.*NF)/6.
6262 ALGQ=LOG(MAX(1.0001,Q2EFF/ALAM2))
6263 IF(MSTU(111).EQ.1) THEN
6264 UYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
6265 ELSE
6266 B1=(153.-19.*NF)/6.
6267 UYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/
6268 & (B0**2*ALGQ)))
6269 ENDIF
6270 MSTU(118)=NF
6271 PARU(118)=UYALPS
6272
6273 RETURN
6274 END
6275
6276C*********************************************************************
6277
6278 FUNCTION UYANGL(X,Y)
6279
6280C...Purpose: to reconstruct an angle from given x and y coordinates.
6281 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6282 SAVE /LYDAT1/
6283
6284 UYANGL=0.
6285 R=SQRT(X**2+Y**2)
6286 IF(R.LT.1E-20) RETURN
6287 IF(ABS(X)/R.LT.0.8) THEN
6288 UYANGL=SIGN(ACOS(X/R),Y)
6289 ELSE
6290 UYANGL=ASIN(Y/R)
6291 IF(X.LT.0..AND.UYANGL.GE.0.) THEN
6292 UYANGL=PARU(1)-UYANGL
6293 ELSEIF(X.LT.0.) THEN
6294 UYANGL=-PARU(1)-UYANGL
6295 ENDIF
6296 ENDIF
6297
6298 RETURN
6299 END
6300
6301C*********************************************************************
6302c
6303c FUNCTION RLU(IDUMMY)
6304c
6305cC...Purpose: to generate random numbers uniformly distributed between
6306cC...0 and 1, excluding the endpoints.
6307c COMMON/LYDATR/MRLU(6),RRLU(100)
6308c SAVE /LYDATR/
6309c EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
6310c &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
6311c &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
6312c
6313cC...Initialize generation from given seed.
6314c IF(MRLU2.EQ.0) THEN
6315c IJ=MOD(MRLU1/30082,31329)
6316c KL=MOD(MRLU1,30082)
6317c I=MOD(IJ/177,177)+2
6318c J=MOD(IJ,177)+2
6319c K=MOD(KL/169,178)+1
6320c L=MOD(KL,169)
6321c DO 110 II=1,97
6322c S=0.
6323c T=0.5
6324c DO 100 JJ=1,24
6325c M=MOD(MOD(I*J,179)*K,179)
6326c I=J
6327c J=K
6328c K=M
6329c L=MOD(53*L+1,169)
6330c IF(MOD(L*M,64).GE.32) S=S+T
6331c T=0.5*T
6332c 100 CONTINUE
6333c RRLU(II)=S
6334c 110 CONTINUE
6335c TWOM24=1.
6336c DO 120 I24=1,24
6337c TWOM24=0.5*TWOM24
6338c 120 CONTINUE
6339c RRLU98=362436.*TWOM24
6340c RRLU99=7654321.*TWOM24
6341c RRLU00=16777213.*TWOM24
6342c MRLU2=1
6343c MRLU3=0
6344c MRLU4=97
6345c MRLU5=33
6346c ENDIF
6347c
6348cC...Generate next random number.
6349c 130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
6350c IF(RUNI.LT.0.) RUNI=RUNI+1.
6351c RRLU(MRLU4)=RUNI
6352c MRLU4=MRLU4-1
6353c IF(MRLU4.EQ.0) MRLU4=97
6354c MRLU5=MRLU5-1
6355c IF(MRLU5.EQ.0) MRLU5=97
6356c RRLU98=RRLU98-RRLU99
6357c IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
6358c RUNI=RUNI-RRLU98
6359c IF(RUNI.LT.0.) RUNI=RUNI+1.
6360c IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
6361c
6362cC...Update counters. Random number to output.
6363c MRLU3=MRLU3+1
6364c IF(MRLU3.EQ.1000000000) THEN
6365c MRLU2=MRLU2+1
6366c MRLU3=0
6367c ENDIF
6368c RLU=RUNI
6369c
6370c RETURN
6371c END
6372c
6373C*********************************************************************
6374
6375 SUBROUTINE RLYGET(LFN,MOVE)
6376
6377C...Purpose: to dump the state of the random number generator on a file
6378C...for subsequent startup from this state onwards.
6379 COMMON/LYDATR/MRLU(6),RRLU(100)
6380 SAVE /LYDATR/
6381 CHARACTER CHERR*8
6382
6383C...Backspace required number of records (or as many as there are).
6384 IF(MOVE.LT.0) THEN
6385 NBCK=MIN(MRLU(6),-MOVE)
6386 DO 100 IBCK=1,NBCK
6387 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
6388 100 CONTINUE
6389 MRLU(6)=MRLU(6)-NBCK
6390 ENDIF
6391
6392C...Unformatted write on unit LFN.
6393 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRLU(I1),I1=1,5),
6394 &(RRLU(I2),I2=1,100)
6395 MRLU(6)=MRLU(6)+1
6396 RETURN
6397
6398C...Write error.
6399 110 WRITE(CHERR,'(I8)') IERR
6400 CALL LYERRM(18,'(RLYGET:) error when accessing file, IOSTAT ='//
6401 &CHERR)
6402
6403 RETURN
6404 END
6405
6406C*********************************************************************
6407
6408 SUBROUTINE RLYSET(LFN,MOVE)
6409
6410C...Purpose: to read a state of the random number generator from a file
6411C...for subsequent generation from this state onwards.
6412 COMMON/LYDATR/MRLU(6),RRLU(100)
6413 SAVE /LYDATR/
6414 CHARACTER CHERR*8
6415
6416C...Backspace required number of records (or as many as there are).
6417 IF(MOVE.LT.0) THEN
6418 NBCK=MIN(MRLU(6),-MOVE)
6419 DO 100 IBCK=1,NBCK
6420 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
6421 100 CONTINUE
6422 MRLU(6)=MRLU(6)-NBCK
6423 ENDIF
6424
6425C...Unformatted read from unit LFN.
6426 NFOR=1+MAX(0,MOVE)
6427 DO 110 IFOR=1,NFOR
6428 READ(LFN,ERR=120,IOSTAT=IERR) (MRLU(I1),I1=1,5),
6429 &(RRLU(I2),I2=1,100)
6430 110 CONTINUE
6431 MRLU(6)=MRLU(6)+NFOR
6432 RETURN
6433
6434C...Write error.
6435 120 WRITE(CHERR,'(I8)') IERR
6436 CALL LYERRM(18,'(RLYSET:) error when accessing file, IOSTAT ='//
6437 &CHERR)
6438
6439 RETURN
6440 END
6441
6442C*********************************************************************
6443
6444 SUBROUTINE LYROBO(THE,PHI,BEX,BEY,BEZ)
6445
6446C...Purpose: to perform rotations and boosts.
6447 IMPLICIT DOUBLE PRECISION(D)
6448 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
6449 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6450 SAVE /LYJETS/,/LYDAT1/
6451 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
6452
6453C...Find range of rotation/boost. Convert boost to double precision.
6454 IMIN=1
6455 IF(MSTU(1).GT.0) IMIN=MSTU(1)
6456 IMAX=N
6457 IF(MSTU(2).GT.0) IMAX=MSTU(2)
6458 DBX=BEX
6459 DBY=BEY
6460 DBZ=BEZ
6461 GOTO 120
6462
6463C...Entry for specific range and double precision boost.
6464 ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
6465 IMIN=IMI
6466 IF(IMIN.LE.0) IMIN=1
6467 IMAX=IMA
6468 IF(IMAX.LE.0) IMAX=N
6469 DBX=DBEX
6470 DBY=DBEY
6471 DBZ=DBEZ
6472
6473C...Optional resetting of V (when not set before.)
6474 IF(MSTU(33).NE.0) THEN
6475 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
6476 DO 100 J=1,5
6477 V(I,J)=0.
6478 100 CONTINUE
6479 110 CONTINUE
6480 MSTU(33)=0
6481 ENDIF
6482
6483C...Check range of rotation/boost.
6484 120 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
6485 CALL LYERRM(11,'(LYROBO:) range outside LUJETS memory')
6486 RETURN
6487 ENDIF
6488
6489C...Rotate, typically from z axis to direction (theta,phi).
6490 IF(THE**2+PHI**2.GT.1E-20) THEN
6491 ROT(1,1)=COS(THE)*COS(PHI)
6492 ROT(1,2)=-SIN(PHI)
6493 ROT(1,3)=SIN(THE)*COS(PHI)
6494 ROT(2,1)=COS(THE)*SIN(PHI)
6495 ROT(2,2)=COS(PHI)
6496 ROT(2,3)=SIN(THE)*SIN(PHI)
6497 ROT(3,1)=-SIN(THE)
6498 ROT(3,2)=0.
6499 ROT(3,3)=COS(THE)
6500 DO 150 I=IMIN,IMAX
6501 IF(K(I,1).LE.0) GOTO 150
6502 DO 130 J=1,3
6503 PR(J)=P(I,J)
6504 VR(J)=V(I,J)
6505 130 CONTINUE
6506 DO 140 J=1,3
6507 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
6508 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
6509 140 CONTINUE
6510 150 CONTINUE
6511 ENDIF
6512
6513C...Boost, typically from rest to momentum/energy=beta.
6514 IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
6515 DB=SQRT(DBX**2+DBY**2+DBZ**2)
6516 IF(DB.GT.0.99999999D0) THEN
6517C...Rescale boost vector if too close to unity.
6518 CALL LYERRM(3,'(LYROBO:) boost vector too large')
6519 DBX=DBX*(0.99999999D0/DB)
6520 DBY=DBY*(0.99999999D0/DB)
6521 DBZ=DBZ*(0.99999999D0/DB)
6522 DB=0.99999999D0
6523 ENDIF
6524 DGA=1D0/SQRT(1D0-DB**2)
6525 DO 170 I=IMIN,IMAX
6526 IF(K(I,1).LE.0) GOTO 170
6527 DO 160 J=1,4
6528 DP(J)=P(I,J)
6529 DV(J)=V(I,J)
6530 160 CONTINUE
6531 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
6532 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
6533 P(I,1)=DP(1)+DGABP*DBX
6534 P(I,2)=DP(2)+DGABP*DBY
6535 P(I,3)=DP(3)+DGABP*DBZ
6536 P(I,4)=DGA*(DP(4)+DBP)
6537 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
6538 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
6539 V(I,1)=DV(1)+DGABV*DBX
6540 V(I,2)=DV(2)+DGABV*DBY
6541 V(I,3)=DV(3)+DGABV*DBZ
6542 V(I,4)=DGA*(DV(4)+DBV)
6543 170 CONTINUE
6544 ENDIF
6545
6546 RETURN
6547 END
6548
6549C*********************************************************************
6550
6551 SUBROUTINE LYEDIT(MEDIT)
6552
6553C...Purpose: to perform global manipulations on the event record,
6554C...in particular to exclude unstable or undetectable partons/particles.
6555 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
6556 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6557 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6558 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
6559 DIMENSION NS(2),PTS(2),PLS(2)
6560
6561C...Remove unwanted partons/particles.
6562 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
6563 IMAX=N
6564 IF(MSTU(2).GT.0) IMAX=MSTU(2)
6565 I1=MAX(1,MSTU(1))-1
6566 DO 110 I=MAX(1,MSTU(1)),IMAX
6567 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
6568 IF(MEDIT.EQ.1) THEN
6569 IF(K(I,1).GT.10) GOTO 110
6570 ELSEIF(MEDIT.EQ.2) THEN
6571 IF(K(I,1).GT.10) GOTO 110
6572 KC=LYCOMP(K(I,2))
6573 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
6574 & GOTO 110
6575 ELSEIF(MEDIT.EQ.3) THEN
6576 IF(K(I,1).GT.10) GOTO 110
6577 KC=LYCOMP(K(I,2))
6578 IF(KC.EQ.0) GOTO 110
6579 IF(KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0) GOTO 110
6580 ELSEIF(MEDIT.EQ.5) THEN
6581 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
6582 KC=LYCOMP(K(I,2))
6583 IF(KC.EQ.0) GOTO 110
6584 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
6585 ENDIF
6586
6587C...Pack remaining partons/particles. Origin no longer known.
6588 I1=I1+1
6589 DO 100 J=1,5
6590 K(I1,J)=K(I,J)
6591 P(I1,J)=P(I,J)
6592 V(I1,J)=V(I,J)
6593 100 CONTINUE
6594 K(I1,3)=0
6595 110 CONTINUE
6596 IF(I1.LT.N) MSTU(3)=0
6597 IF(I1.LT.N) MSTU(70)=0
6598 N=I1
6599
6600C...Selective removal of class of entries. New position of retained.
6601 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
6602 I1=0
6603 DO 120 I=1,N
6604 K(I,3)=MOD(K(I,3),MSTU(5))
6605 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
6606 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
6607 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
6608 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
6609 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
6610 & K(I,2).EQ.94)) GOTO 120
6611 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
6612 I1=I1+1
6613 K(I,3)=K(I,3)+MSTU(5)*I1
6614 120 CONTINUE
6615
6616C...Find new event history information and replace old.
6617 DO 140 I=1,N
6618 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
6619 ID=I
6620 130 IM=MOD(K(ID,3),MSTU(5))
6621 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
6622 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
6623 & K(IM,2).NE.94) THEN
6624 ID=IM
6625 GOTO 130
6626 ENDIF
6627 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
6628 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
6629 ID=IM
6630 GOTO 130
6631 ENDIF
6632 ENDIF
6633 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
6634 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
6635 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
6636 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
6637 & K(K(I,4),3)/MSTU(5)
6638 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
6639 & K(K(I,5),3)/MSTU(5)
6640 ELSE
6641 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
6642 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
6643 KCD=MOD(K(I,4),MSTU(5))
6644 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
6645 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
6646 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
6647 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
6648 KCD=MOD(K(I,5),MSTU(5))
6649 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
6650 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
6651 ENDIF
6652 140 CONTINUE
6653
6654C...Pack remaining entries.
6655 I1=0
6656 MSTU90=MSTU(90)
6657 MSTU(90)=0
6658 DO 170 I=1,N
6659 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
6660 I1=I1+1
6661 DO 150 J=1,5
6662 K(I1,J)=K(I,J)
6663 P(I1,J)=P(I,J)
6664 V(I1,J)=V(I,J)
6665 150 CONTINUE
6666 K(I1,3)=MOD(K(I1,3),MSTU(5))
6667 DO 160 IZ=1,MSTU90
6668 IF(I.EQ.MSTU(90+IZ)) THEN
6669 MSTU(90)=MSTU(90)+1
6670 MSTU(90+MSTU(90))=I1
6671 PARU(90+MSTU(90))=PARU(90+IZ)
6672 ENDIF
6673 160 CONTINUE
6674 170 CONTINUE
6675 IF(I1.LT.N) MSTU(3)=0
6676 IF(I1.LT.N) MSTU(70)=0
6677 N=I1
6678
6679C...Fill in some missing daughter pointers (lost in colour flow).
6680 ELSEIF(MEDIT.EQ.16) THEN
6681 DO 190 I=1,N
6682 IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 190
6683 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 190
6684C...Find daughters who point to mother.
6685 DO 180 I1=I+1,N
6686 IF(K(I1,3).NE.I) THEN
6687 ELSEIF(K(I,4).EQ.0) THEN
6688 K(I,4)=I1
6689 ELSE
6690 K(I,5)=I1
6691 ENDIF
6692 180 CONTINUE
6693 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
6694 IF(K(I,4).NE.0) GOTO 190
6695C...Find daughters who point to documentation version of mother.
6696 IM=K(I,3)
6697 IF(IM.LE.0.OR.IM.GE.I) GOTO 190
6698 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 190
6699 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1E-2) GOTO 190
6700 DO 182 I1=I+1,N
6701 IF(K(I1,3).NE.IM) THEN
6702 ELSEIF(K(I,4).EQ.0) THEN
6703 K(I,4)=I1
6704 ELSE
6705 K(I,5)=I1
6706 ENDIF
6707 182 CONTINUE
6708 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
6709 IF(K(I,4).NE.0) GOTO 190
6710C...Find daughters who point to documentation daughters who,
6711C...in their turn, point to documentation mother.
6712 ID1=IM
6713 ID2=IM
6714 DO 184 I1=IM+1,I-1
6715 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
6716 ID2=I1
6717 IF(ID1.EQ.IM) ID1=I1
6718 ENDIF
6719 184 CONTINUE
6720 DO 186 I1=I+1,N
6721 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
6722 ELSEIF(K(I,4).EQ.0) THEN
6723 K(I,4)=I1
6724 ELSE
6725 K(I,5)=I1
6726 ENDIF
6727 186 CONTINUE
6728 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
6729 190 CONTINUE
6730
6731C...Save top entries at bottom of LUJETS commonblock.
6732 ELSEIF(MEDIT.EQ.21) THEN
6733 IF(2*N.GE.MSTU(4)) THEN
6734 CALL LYERRM(11,'(LYEDIT:) no more memory left in LUJETS')
6735 RETURN
6736 ENDIF
6737 DO 210 I=1,N
6738 DO 200 J=1,5
6739 K(MSTU(4)-I,J)=K(I,J)
6740 P(MSTU(4)-I,J)=P(I,J)
6741 V(MSTU(4)-I,J)=V(I,J)
6742 200 CONTINUE
6743 210 CONTINUE
6744 MSTU(32)=N
6745
6746C...Restore bottom entries of commonblock LUJETS to top.
6747 ELSEIF(MEDIT.EQ.22) THEN
6748 DO 230 I=1,MSTU(32)
6749 DO 220 J=1,5
6750 K(I,J)=K(MSTU(4)-I,J)
6751 P(I,J)=P(MSTU(4)-I,J)
6752 V(I,J)=V(MSTU(4)-I,J)
6753 220 CONTINUE
6754 230 CONTINUE
6755 N=MSTU(32)
6756
6757C...Mark primary entries at top of commonblock LUJETS as untreated.
6758 ELSEIF(MEDIT.EQ.23) THEN
6759 I1=0
6760 DO 240 I=1,N
6761 KH=K(I,3)
6762 IF(KH.GE.1) THEN
6763 IF(K(KH,1).GT.20) KH=0
6764 ENDIF
6765 IF(KH.NE.0) GOTO 250
6766 I1=I1+1
6767 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
6768 240 CONTINUE
6769 250 N=I1
6770
6771C...Place largest axis along z axis and second largest in xy plane.
6772 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
6773 CALL LUDBRB(1,N+MSTU(3),0.,-UYANGL(P(MSTU(61),1),
6774 & P(MSTU(61),2)),0D0,0D0,0D0)
6775 CALL LUDBRB(1,N+MSTU(3),-UYANGL(P(MSTU(61),3),
6776 & P(MSTU(61),1)),0.,0D0,0D0,0D0)
6777 CALL LUDBRB(1,N+MSTU(3),0.,-UYANGL(P(MSTU(61)+1,1),
6778 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
6779 IF(MEDIT.EQ.31) RETURN
6780
6781C...Rotate to put slim jet along +z axis.
6782 DO 260 IS=1,2
6783 NS(IS)=0
6784 PTS(IS)=0.
6785 PLS(IS)=0.
6786 260 CONTINUE
6787 DO 270 I=1,N
6788 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
6789 IF(MSTU(41).GE.2) THEN
6790 KC=LYCOMP(K(I,2))
6791 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6792 & KC.EQ.18) GOTO 270
6793 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
6794 & GOTO 270
6795 ENDIF
6796 IS=2.-SIGN(0.5,P(I,3))
6797 NS(IS)=NS(IS)+1
6798 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
6799 270 CONTINUE
6800 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
6801 & CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
6802
6803C...Rotate to put second largest jet into -z,+x quadrant.
6804 DO 280 I=1,N
6805 IF(P(I,3).GE.0.) GOTO 280
6806 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 280
6807 IF(MSTU(41).GE.2) THEN
6808 KC=LYCOMP(K(I,2))
6809 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6810 & KC.EQ.18) GOTO 280
6811 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
6812 & GOTO 280
6813 ENDIF
6814 IS=2.-SIGN(0.5,P(I,1))
6815 PLS(IS)=PLS(IS)-P(I,3)
6816 280 CONTINUE
6817 IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
6818 & 0D0,0D0,0D0)
6819 ENDIF
6820
6821 RETURN
6822 END
6823
6824C*********************************************************************
6825
6826 SUBROUTINE LYLIST(MLIST)
6827
6828C...Purpose: to give program heading, or list an event, or particle
6829C...data, or current parameter values.
6830 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
6831 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6832 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6833 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6834 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
6835 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
6836 DIMENSION PS(6)
6837 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
6838
6839C...Initialization printout: version number and date of last change.
6840 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
6841 CALL LYLOGO
6842 MSTU(12)=0
6843 IF(MLIST.EQ.0) RETURN
6844 ENDIF
6845
6846C...List event data, including additional lines after N.
6847 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
6848 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
6849 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
6850 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
6851 LMX=12
6852 IF(MLIST.GE.2) LMX=16
6853 ISTR=0
6854 IMAX=N
6855 IF(MSTU(2).GT.0) IMAX=MSTU(2)
6856 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
6857 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
6858
6859C...Get particle name, pad it and check it is not too long.
6860 CALL LYNAME(K(I,2),CHAP)
6861 LEN=0
6862 DO 100 LEM=1,16
6863 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
6864 100 CONTINUE
6865 MDL=(K(I,1)+19)/10
6866 LDL=0
6867 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
6868 CHAC=CHAP
6869 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
6870 ELSE
6871 LDL=1
6872 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
6873 IF(LEN.EQ.0) THEN
6874 CHAC=CHDL(MDL)(1:2*LDL)//' '
6875 ELSE
6876 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
6877 & CHDL(MDL)(LDL+1:2*LDL)//' '
6878 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
6879 ENDIF
6880 ENDIF
6881
6882C...Add information on string connection.
6883 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
6884 & THEN
6885 KC=LYCOMP(K(I,2))
6886 KCC=0
6887 IF(KC.NE.0) KCC=KCHG(KC,2)
6888 IF(IABS(K(I,2)).EQ.39) THEN
6889 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
6890 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
6891 ISTR=1
6892 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
6893 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
6894 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
6895 ELSEIF(KCC.NE.0) THEN
6896 ISTR=0
6897 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
6898 ENDIF
6899 ENDIF
6900
6901C...Write data for particle/jet.
6902 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
6903 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
6904 & (P(I,J2),J2=1,5)
6905 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
6906 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
6907 & (P(I,J2),J2=1,5)
6908 ELSEIF(MLIST.EQ.1) THEN
6909 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
6910 & (P(I,J2),J2=1,5)
6911 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
6912 & K(I,1).EQ.14)) THEN
6913 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
6914 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
6915 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
6916 & (P(I,J2),J2=1,5)
6917 ELSE
6918 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
6919 ENDIF
6920 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
6921
6922C...Insert extra separator lines specified by user.
6923 IF(MSTU(70).GE.1) THEN
6924 ISEP=0
6925 DO 110 J=1,MIN(10,MSTU(70))
6926 IF(I.EQ.MSTU(70+J)) ISEP=1
6927 110 CONTINUE
6928 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
6929 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
6930 ENDIF
6931 120 CONTINUE
6932
6933C...Sum of charges and momenta.
6934 DO 130 J=1,6
6935 PS(J)=PLY(0,J)
6936 130 CONTINUE
6937 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
6938 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
6939 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
6940 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
6941 ELSEIF(MLIST.EQ.1) THEN
6942 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
6943 ELSE
6944 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
6945 ENDIF
6946
6947C...Give simple list of KF codes defined in program.
6948 ELSEIF(MLIST.EQ.11) THEN
6949 WRITE(MSTU(11),6600)
6950 DO 140 KF=1,40
6951 CALL LYNAME(KF,CHAP)
6952 CALL LYNAME(-KF,CHAN)
6953 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
6954 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6955 140 CONTINUE
6956 DO 170 KFLS=1,3,2
6957 DO 160 KFLA=1,8
6958 DO 150 KFLB=1,KFLA-(3-KFLS)/2
6959 KF=1000*KFLA+100*KFLB+KFLS
6960 CALL LYNAME(KF,CHAP)
6961 CALL LYNAME(-KF,CHAN)
6962 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6963 150 CONTINUE
6964 160 CONTINUE
6965 170 CONTINUE
6966 KF=130
6967 CALL LYNAME(KF,CHAP)
6968 WRITE(MSTU(11),6700) KF,CHAP
6969 KF=310
6970 CALL LYNAME(KF,CHAP)
6971 WRITE(MSTU(11),6700) KF,CHAP
6972 DO 200 KMUL=0,5
6973 KFLS=3
6974 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
6975 IF(KMUL.EQ.5) KFLS=5
6976 KFLR=0
6977 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
6978 IF(KMUL.EQ.4) KFLR=2
6979 DO 190 KFLB=1,8
6980 DO 180 KFLC=1,KFLB-1
6981 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
6982 CALL LYNAME(KF,CHAP)
6983 CALL LYNAME(-KF,CHAN)
6984 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6985 180 CONTINUE
6986 KF=10000*KFLR+110*KFLB+KFLS
6987 CALL LYNAME(KF,CHAP)
6988 WRITE(MSTU(11),6700) KF,CHAP
6989 190 CONTINUE
6990 200 CONTINUE
6991 KF=30443
6992 CALL LYNAME(KF,CHAP)
6993 WRITE(MSTU(11),6700) KF,CHAP
6994 KF=30553
6995 CALL LYNAME(KF,CHAP)
6996 WRITE(MSTU(11),6700) KF,CHAP
6997 DO 240 KFLSP=1,3
6998 KFLS=2+2*(KFLSP/3)
6999 DO 230 KFLA=1,8
7000 DO 220 KFLB=1,KFLA
7001 DO 210 KFLC=1,KFLB
7002 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 210
7003 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
7004 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
7005 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
7006 CALL LYNAME(KF,CHAP)
7007 CALL LYNAME(-KF,CHAN)
7008 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
7009 210 CONTINUE
7010 220 CONTINUE
7011 230 CONTINUE
7012 240 CONTINUE
7013
7014C...List parton/particle data table. Check whether to be listed.
7015 ELSEIF(MLIST.EQ.12) THEN
7016 WRITE(MSTU(11),6800)
7017 MSTJ24=MSTJ(24)
7018 MSTJ(24)=0
7019 KFMAX=30553
7020 IF(MSTU(2).NE.0) KFMAX=MSTU(2)
7021 DO 270 KF=MAX(1,MSTU(1)),KFMAX
7022 KC=LYCOMP(KF)
7023 IF(KC.EQ.0) GOTO 270
7024 IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 270
7025 IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
7026 & MOD(KF/100,10)).GT.MSTU(14)) GOTO 270
7027 IF(MSTU(14).GT.0.AND.KF.GT.100.AND.KC.EQ.90) GOTO 270
7028
7029C...Find particle name and mass. Print information.
7030 CALL LYNAME(KF,CHAP)
7031 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 270
7032 CALL LYNAME(-KF,CHAN)
7033 PM=UYMASS(KF)
7034 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
7035 & KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
7036
7037C...Particle decay: channel number, branching ration, matrix element,
7038C...decay products.
7039 IF(KF.GT.100.AND.KC.LE.100) GOTO 270
7040 DO 260 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
7041 DO 250 J=1,5
7042 CALL LYNAME(KFDP(IDC,J),CHAD(J))
7043 250 CONTINUE
7044 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
7045 & (CHAD(J),J=1,5)
7046 260 CONTINUE
7047 270 CONTINUE
7048 MSTJ(24)=MSTJ24
7049
7050C...List parameter value table.
7051 ELSEIF(MLIST.EQ.13) THEN
7052 WRITE(MSTU(11),7100)
7053 DO 280 I=1,200
7054 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
7055 280 CONTINUE
7056 ENDIF
7057
7058C...Format statements for output on unit MSTU(11) (by default 6).
7059 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
7060 &5X,'KF orig p_x p_y p_z E m'/)
7061 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
7062 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
7063 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
7064 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
7065 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
7066 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
7067 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
7068 5400 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
7069 5500 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
7070 5600 FORMAT(1X,I4,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
7071 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
7072 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
7073 5900 FORMAT(66X,5(1X,F12.3))
7074 6000 FORMAT(1X,78('='))
7075 6100 FORMAT(1X,130('='))
7076 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
7077 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
7078 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
7079 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
7080 &5F13.5)
7081 6600 FORMAT(///20X,'List of KF codes in program'/)
7082 6700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
7083 6800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
7084 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
7085 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
7086 &1X,'ME',3X,'Br.rat.',4X,'decay products')
7087 6900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
7088 &2X,F12.5,3X,I2)
7089 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
7090 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
7091 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
7092 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
7093
7094 RETURN
7095 END
7096
7097C*********************************************************************
7098
7099 SUBROUTINE LYLOGO
7100
7101C...Purpose: to write logo for JETSET and PYTHIA programs.
7102 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7103c DOUBLE PRECISION PARP,PARI
7104c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7105 SAVE /LYDAT1/
7106c SAVE /PYPARS/
7107 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(22)*36, LINE*79,
7108 &VERS*1, SUBV*3, DATE*2, YEAR*4
7109
7110C...Data on months, logo, titles, and references.
7111 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
7112 &'Oct','Nov','Dec'/
7113 DATA (LOGO(J),J=1,10)/
7114 &'PPP Y Y TTTTT H H III A ',
7115 &'P P Y Y T H H I A A ',
7116 &'PPP Y T HHHHH I AAAAA',
7117 &'P Y T H H I A A',
7118 &'P Y T H H III A A',
7119 &'JJJJ EEEE TTTTT SSS EEEE TTTTT',
7120 &' J E T S E T ',
7121 &' J EEE T SSS EEE T ',
7122 &'J J E T S E T ',
7123 &' JJ EEEE T SSS EEEE T '/
7124 DATA (LOGO(J),J=11,29)/
7125 &' *......* ',
7126 &' *:::!!:::::::::::* ',
7127 &' *::::::!!::::::::::::::* ',
7128 &' *::::::::!!::::::::::::::::* ',
7129 &' *:::::::::!!:::::::::::::::::* ',
7130 &' *:::::::::!!:::::::::::::::::* ',
7131 &' *::::::::!!::::::::::::::::*! ',
7132 &' *::::::!!::::::::::::::* !! ',
7133 &' !! *:::!!:::::::::::* !! ',
7134 &' !! !* -><- * !! ',
7135 &' !! !! !! ',
7136 &' !! !! !! ',
7137 &' !! !! ',
7138 &' !! ep !! ',
7139 &' !! !! ',
7140 &' !! pp !! ',
7141 &' !! e+e- !! ',
7142 &' !! !! ',
7143 &' !! '/
7144 DATA (LOGO(J),J=30,48)/
7145 &'Welcome to the Lund Monte Carlo!',
7146 &' ',
7147 &' This jetset version x.xxx ',
7148 &'can coexist with xx xxx 199x',
7149 &' PYTHIA !!! ',
7150 &' it was altered by fkw x.xxx ',
7151 &' on 3.29.00 xx xxx 199x',
7152 &' to this effect !!! ',
7153 &' Main author: ',
7154 &' Torbjorn Sjostrand ',
7155 &' Dept. of theoretical physics 2 ',
7156 &' University of Lund ',
7157 &' Solvegatan 14A ',
7158 &' S-223 62 Lund, Sweden ',
7159 &' phone: +46 - 46 - 222 48 16 ',
7160 &' E-mail: torbjorn@thep.lu.se ',
7161 &' ',
7162 &' Copyright Torbjorn Sjostrand ',
7163 &' and CERN, Geneva 1993 '/
7164 DATA (REFER(J),J=1,6)/
7165 &'The latest program versions and docu',
7166 &'mentation is found on WWW address ',
7167 &'http://thep.lu.se/tf2/staff/torbjorn',
7168 &'/Welcome.html ',
7169 &' ',
7170 &' This is fkw version !!! '/
7171 DATA (REFER(J),J=7,22)/
7172 &'When you cite these programs, priori',
7173 &'ty should always be given to the ',
7174 &'latest published description. Curren',
7175 &'tly this is ',
7176 &'T. Sjostrand, Computer Physics Commu',
7177 &'n. 82 (1994) 74. ',
7178 &'The most recent long description (un',
7179 &'published) is ',
7180 &'T. Sjostrand, LU TP 95-20 and CERN-T',
7181 &'H.7112/93 (revised August 1995). ',
7182 &'Also remember that the programs, to ',
7183 &'a large extent, represent original ',
7184 &'physics research. Other publications',
7185 &' of special relevance to your ',
7186 &'studies may therefore deserve separa',
7187 &'te mention. '/
7188
7189C...Check if PYTHIA linked.
7190c IF(MSTP(183)/10.NE.199) THEN
7191 LOGO(32)=' Warning: this is jetset7.4_fkw '
7192 LOGO(33)='All refs to pythia were excised!'
7193c ELSE
7194c WRITE(VERS,'(I1)') MSTP(181)
7195c LOGO(32)(26:26)=VERS
7196c WRITE(SUBV,'(I3)') MSTP(182)
7197c LOGO(32)(28:30)=SUBV
7198c WRITE(DATE,'(I2)') MSTP(185)
7199c LOGO(33)(22:23)=DATE
7200c LOGO(33)(25:27)=MONTH(MSTP(184))
7201c WRITE(YEAR,'(I4)') MSTP(183)
7202c LOGO(33)(29:32)=YEAR
7203c ENDIF
7204
7205C...Check if JETSET linked.
7206 IF(MSTU(183)/10.NE.199) THEN
7207 LOGO(35)=' Error: JETSET is not loaded! '
7208 LOGO(36)='Did you remember to link LYDATA?'
7209 ELSE
7210 WRITE(VERS,'(I1)') MSTU(181)
7211 LOGO(35)(26:26)=VERS
7212 WRITE(SUBV,'(I3)') MSTU(182)
7213 LOGO(35)(28:30)=SUBV
7214 WRITE(DATE,'(I2)') MSTU(185)
7215 LOGO(36)(22:23)=DATE
7216 LOGO(36)(25:27)=MONTH(MSTU(184))
7217 WRITE(YEAR,'(I4)') MSTU(183)
7218 LOGO(36)(29:32)=YEAR
7219 ENDIF
7220
7221C...Loop over lines in header. Define page feed and side borders.
7222 DO 100 ILIN=1,48
7223 LINE=' '
7224 IF(ILIN.EQ.1) THEN
7225 LINE(1:1)='1'
7226 ELSE
7227 LINE(2:3)='**'
7228 LINE(78:79)='**'
7229 ENDIF
7230
7231C...Separator lines and logos.
7232 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.EQ.47.OR.ILIN.EQ.48) THEN
7233 LINE(4:77)='***********************************************'//
7234 & '***************************'
7235 ELSEIF(ILIN.GE.6.AND.ILIN.LE.10) THEN
7236 LINE(6:37)=LOGO(ILIN-5)
7237 LINE(44:75)=LOGO(ILIN)
7238 ELSEIF(ILIN.GE.13.AND.ILIN.LE.31) THEN
7239 LINE(6:37)=LOGO(ILIN-2)
7240 LINE(44:75)=LOGO(ILIN+17)
7241 ELSEIF(ILIN.GE.34.AND.ILIN.LE.44) THEN
7242 LINE(5:40)=REFER(2*ILIN-67)
7243 LINE(41:76)=REFER(2*ILIN-66)
7244 ENDIF
7245
7246C...Write lines to appropriate unit.
7247 IF(MSTU(183)/10.EQ.199) THEN
7248 WRITE(MSTU(11),'(A79)') LINE
7249 ELSE
7250 WRITE(*,'(A79)') LINE
7251 ENDIF
7252 100 CONTINUE
7253
7254C...Check that matching subversions are linked.
7255c IF(MSTU(183)/10.EQ.199.AND.MSTP(183)/10.EQ.199) THEN
7256c IF(MSTU(182).LT.MSTP(186)) WRITE(MSTU(11),
7257 WRITE(MSTU(11),
7258 & '(/'' Warning: Jetset7.4_fkw independent of PYTHIA!''/)')
7259c IF(MSTP(182).LT.MSTU(186)) WRITE(MSTU(11),
7260c & '(/'' Warning: PYTHIA subversion too old for JETSET''/)')
7261c ENDIF
7262
7263 RETURN
7264 END
7265
7266C*********************************************************************
7267
7268 SUBROUTINE LYUPDA(MUPDA,LFN)
7269
7270C...Purpose: to facilitate the updating of particle and decay data.
7271 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7272 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7273 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
7274 COMMON/LYDAT4/CHAF(500)
7275 CHARACTER CHAF*8
7276 SAVE /LYDAT1/,/LYDAT2/,/LYDAT3/,/LYDAT4/
7277 CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
7278 &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
7279 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
7280 &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
7281 &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
7282 &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
7283
7284C...Write information on file for editing.
7285 IF(MSTU(12).GE.1) CALL LYLIST(0)
7286 IF(MUPDA.EQ.1) THEN
7287 DO 110 KC=1,MSTU(6)
7288 WRITE(LFN,5000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),
7289 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
7290 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
7291 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
7292 & (KFDP(IDC,J),J=1,5)
7293 100 CONTINUE
7294 110 CONTINUE
7295
7296C...Reset variables and read information from edited file.
7297 ELSEIF(MUPDA.EQ.2) THEN
7298 DO 130 I=1,MSTU(7)
7299 MDME(I,1)=1
7300 MDME(I,2)=0
7301 BRAT(I)=0.
7302 DO 120 J=1,5
7303 KFDP(I,J)=0
7304 120 CONTINUE
7305 130 CONTINUE
7306 KC=0
7307 IDC=0
7308 NDC=0
7309 140 READ(LFN,5200,END=150) CHINL
7310 IF(CHINL(2:5).NE.' ') THEN
7311 CHKC=CHINL(2:5)
7312 IF(KC.NE.0) THEN
7313 MDCY(KC,2)=0
7314 IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
7315 MDCY(KC,3)=NDC
7316 ENDIF
7317 READ(CHKC,5300) KC
7318 IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LYERRM(27,
7319 & '(LYUPDA:) Read KC code illegal, KC ='//CHKC)
7320 READ(CHINL,5000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),
7321 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
7322 NDC=0
7323 ELSE
7324 IDC=IDC+1
7325 NDC=NDC+1
7326 IF(IDC.GE.MSTU(7)) CALL LYERRM(27,
7327 & '(LYUPDA:) Decay data arrays full by KC ='//CHKC)
7328 READ(CHINL,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
7329 & (KFDP(IDC,J),J=1,5)
7330 ENDIF
7331 GOTO 140
7332 150 MDCY(KC,2)=0
7333 IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
7334 MDCY(KC,3)=NDC
7335
7336C...Perform possible tests that new information is consistent.
7337 MSTJ24=MSTJ(24)
7338 MSTJ(24)=0
7339 DO 180 KC=1,MSTU(6)
7340 WRITE(CHKC,5300) KC
7341 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
7342 & PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LYERRM(17,
7343 & '(LYUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)
7344 BRSUM=0.
7345 DO 170 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
7346 IF(MDME(IDC,2).GT.80) GOTO 170
7347 KQ=KCHG(KC,1)
7348 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
7349 MERR=0
7350 DO 160 J=1,5
7351 KP=KFDP(IDC,J)
7352 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
7353 ELSEIF(LYCOMP(KP).EQ.0) THEN
7354 MERR=3
7355 ELSE
7356 KQ=KQ-LYCHGE(KP)
7357 PMS=PMS-UYMASS(KP)
7358 ENDIF
7359 160 CONTINUE
7360 IF(KQ.NE.0) MERR=MAX(2,MERR)
7361 IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND.
7362 & (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.
7363 & MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)
7364 IF(MERR.EQ.3) CALL LYERRM(17,
7365 & '(LYUPDA:) Unknown particle code in decay of KC ='//CHKC)
7366 IF(MERR.EQ.2) CALL LYERRM(17,
7367 & '(LYUPDA:) Charge not conserved in decay of KC ='//CHKC)
7368 IF(MERR.EQ.1) CALL LYERRM(7,
7369 & '(LYUPDA:) Kinematically unallowed decay of KC ='//CHKC)
7370 BRSUM=BRSUM+BRAT(IDC)
7371 170 CONTINUE
7372 WRITE(CHTMP,5500) BRSUM
7373 IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL
7374 & LYERRM(7,'(LYUPDA:) Sum of branching ratios is '//CHTMP(5:12)//
7375 & ' for KC ='//CHKC)
7376 180 CONTINUE
7377 MSTJ(24)=MSTJ24
7378
7379C...Initialize writing of DATA statements for inclusion in program.
7380 ELSEIF(MUPDA.EQ.3) THEN
7381 DO 250 IVAR=1,19
7382 NDIM=MSTU(6)
7383 IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
7384 NLIN=1
7385 CHLIN=' '
7386 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
7387 LLIN=35
7388 CHOLD='START'
7389
7390C...Loop through variables for conversion to characters.
7391 DO 230 IDIM=1,NDIM
7392 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
7393 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
7394 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
7395 IF(IVAR.EQ.4) WRITE(CHTMP,5500) PMAS(IDIM,1)
7396 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,2)
7397 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,3)
7398 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,4)
7399 IF(IVAR.EQ.8) WRITE(CHTMP,5400) MDCY(IDIM,1)
7400 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,2)
7401 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,3)
7402 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDME(IDIM,1)
7403 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,2)
7404 IF(IVAR.EQ.13) WRITE(CHTMP,5500) BRAT(IDIM)
7405 IF(IVAR.EQ.14) WRITE(CHTMP,5400) KFDP(IDIM,1)
7406 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,2)
7407 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,3)
7408 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,4)
7409 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,5)
7410 IF(IVAR.EQ.19) CHTMP=CHAF(IDIM)
7411
7412C...Length of variable, trailing decimal zeros, quotation marks.
7413 LLOW=1
7414 LHIG=1
7415 DO 190 LL=1,12
7416 IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
7417 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
7418 190 CONTINUE
7419 CHNEW=CHTMP(LLOW:LHIG)//' '
7420 LNEW=1+LHIG-LLOW
7421 IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
7422 LNEW=LNEW+1
7423 200 LNEW=LNEW-1
7424 IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 200
7425 IF(LNEW.EQ.1) CHNEW(1:2)='0.'
7426 IF(LNEW.EQ.1) LNEW=2
7427 ELSEIF(IVAR.EQ.19) THEN
7428 DO 210 LL=LNEW,1,-1
7429 IF(CHNEW(LL:LL).EQ.'''') THEN
7430 CHTMP=CHNEW
7431 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
7432 LNEW=LNEW+1
7433 ENDIF
7434 210 CONTINUE
7435 CHTMP=CHNEW
7436 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
7437 LNEW=LNEW+2
7438 ENDIF
7439
7440C...Form composite character string, often including repetition counter.
7441 IF(CHNEW.NE.CHOLD) THEN
7442 NRPT=1
7443 CHOLD=CHNEW
7444 CHCOM=CHNEW
7445 LCOM=LNEW
7446 ELSE
7447 LRPT=LNEW+1
7448 IF(NRPT.GE.2) LRPT=LNEW+3
7449 IF(NRPT.GE.10) LRPT=LNEW+4
7450 IF(NRPT.GE.100) LRPT=LNEW+5
7451 IF(NRPT.GE.1000) LRPT=LNEW+6
7452 LLIN=LLIN-LRPT
7453 NRPT=NRPT+1
7454 WRITE(CHTMP,5400) NRPT
7455 LRPT=1
7456 IF(NRPT.GE.10) LRPT=2
7457 IF(NRPT.GE.100) LRPT=3
7458 IF(NRPT.GE.1000) LRPT=4
7459 CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)
7460 LCOM=LRPT+1+LNEW
7461 ENDIF
7462
7463C...Add characters to end of line, to new line (after storing old line),
7464C...or to new block of lines (after writing old block).
7465 IF(LLIN+LCOM.LE.70) THEN
7466 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
7467 LLIN=LLIN+LCOM+1
7468 ELSEIF(NLIN.LE.19) THEN
7469 CHLIN(LLIN+1:72)=' '
7470 CHBLK(NLIN)=CHLIN
7471 NLIN=NLIN+1
7472 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
7473 LLIN=6+LCOM+1
7474 ELSE
7475 CHLIN(LLIN:72)='/'//' '
7476 CHBLK(NLIN)=CHLIN
7477 WRITE(CHTMP,5400) IDIM-NRPT
7478 CHBLK(1)(30:33)=CHTMP(9:12)
7479 DO 220 ILIN=1,NLIN
7480 WRITE(LFN,5600) CHBLK(ILIN)
7481 220 CONTINUE
7482 NLIN=1
7483 CHLIN=' '
7484 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I= , )/'//
7485 & CHCOM(1:LCOM)//','
7486 WRITE(CHTMP,5400) IDIM-NRPT+1
7487 CHLIN(25:28)=CHTMP(9:12)
7488 LLIN=35+LCOM+1
7489 ENDIF
7490 230 CONTINUE
7491
7492C...Write final block of lines.
7493 CHLIN(LLIN:72)='/'//' '
7494 CHBLK(NLIN)=CHLIN
7495 WRITE(CHTMP,5400) NDIM
7496 CHBLK(1)(30:33)=CHTMP(9:12)
7497 DO 240 ILIN=1,NLIN
7498 WRITE(LFN,5600) CHBLK(ILIN)
7499 240 CONTINUE
7500 250 CONTINUE
7501 ENDIF
7502
7503C...Formats for reading and writing particle data.
7504 5000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)
7505 5100 FORMAT(5X,2I5,F12.5,5I8)
7506 5200 FORMAT(A80)
7507 5300 FORMAT(I4)
7508 5400 FORMAT(I12)
7509 5500 FORMAT(F12.5)
7510 5600 FORMAT(A72)
7511
7512 RETURN
7513 END
7514
7515C*********************************************************************
7516
7517 FUNCTION KLY(I,J)
7518
7519C...Purpose: to provide various integer-valued event related data.
7520 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
7521 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7522 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7523 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
7524
7525C...Default value. For I=0 number of entries, number of stable entries
7526C...or 3 times total charge.
7527 KLY=0
7528 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
7529 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
7530 KLY=N
7531 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
7532 DO 100 I1=1,N
7533 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLY=KLY+1
7534 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLY=KLY+
7535 & LYCHGE(K(I1,2))
7536 100 CONTINUE
7537 ELSEIF(I.EQ.0) THEN
7538
7539C...For I > 0 direct readout of K matrix or charge.
7540 ELSEIF(J.LE.5) THEN
7541 KLY=K(I,J)
7542 ELSEIF(J.EQ.6) THEN
7543 KLY=LYCHGE(K(I,2))
7544
7545C...Status (existing/fragmented/decayed), parton/hadron separation.
7546 ELSEIF(J.LE.8) THEN
7547 IF(K(I,1).GE.1.AND.K(I,1).LE.10) KLY=1
7548 IF(J.EQ.8) KLY=KLY*K(I,2)
7549 ELSEIF(J.LE.12) THEN
7550 KFA=IABS(K(I,2))
7551 KC=LYCOMP(KFA)
7552 KQ=0
7553 IF(KC.NE.0) KQ=KCHG(KC,2)
7554 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) KLY=K(I,2)
7555 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) KLY=K(I,2)
7556 IF(J.EQ.11) KLY=KC
7557 IF(J.EQ.12) KLY=KQ*ISIGN(1,K(I,2))
7558
7559C...Heaviest flavour in hadron/diquark.
7560 ELSEIF(J.EQ.13) THEN
7561 KFA=IABS(K(I,2))
7562 KLY=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
7563 IF(KFA.LT.10) KLY=KFA
7564 IF(MOD(KFA/1000,10).NE.0) KLY=MOD(KFA/1000,10)
7565 KLY=KLY*ISIGN(1,K(I,2))
7566
7567C...Particle history: generation, ancestor, rank.
7568 ELSEIF(J.LE.15) THEN
7569 I2=I
7570 I1=I
7571 110 KLY=KLY+1
7572 I2=I1
7573 I1=K(I1,3)
7574 IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
7575 IF(J.EQ.15) KLY=I2
7576 ELSEIF(J.EQ.16) THEN
7577 KFA=IABS(K(I,2))
7578 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
7579 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
7580 I1=I
7581 120 I2=I1
7582 I1=K(I1,3)
7583 IF(I1.GT.0) THEN
7584 KFAM=IABS(K(I1,2))
7585 ILP=1
7586 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
7587 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
7588 & ILP=0
7589 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
7590 IF(ILP.EQ.1) GOTO 120
7591 ENDIF
7592 IF(K(I1,1).EQ.12) THEN
7593 DO 130 I3=I1+1,I2
7594 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
7595 & .AND.K(I3,2).NE.93) KLY=KLY+1
7596 130 CONTINUE
7597 ELSE
7598 I3=I2
7599 140 KLY=KLY+1
7600 I3=I3+1
7601 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
7602 ENDIF
7603 ENDIF
7604
7605C...Particle coming from collapsing jet system or not.
7606 ELSEIF(J.EQ.17) THEN
7607 I1=I
7608 150 KLY=KLY+1
7609 I3=I1
7610 I1=K(I1,3)
7611 I0=MAX(1,I1)
7612 KC=LYCOMP(K(I0,2))
7613 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
7614 IF(KLY.EQ.1) KLY=-1
7615 IF(KLY.GT.1) KLY=0
7616 RETURN
7617 ENDIF
7618 IF(KCHG(KC,2).EQ.0) GOTO 150
7619 IF(K(I1,1).NE.12) KLY=0
7620 IF(K(I1,1).NE.12) RETURN
7621 I2=I1
7622 160 I2=I2+1
7623 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
7624 K3M=K(I3-1,3)
7625 IF(K3M.GE.I1.AND.K3M.LE.I2) KLY=0
7626 K3P=K(I3+1,3)
7627 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLY=0
7628
7629C...Number of decay products. Colour flow.
7630 ELSEIF(J.EQ.18) THEN
7631 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) KLY=MAX(0,K(I,5)-K(I,4)+1)
7632 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) KLY=0
7633 ELSEIF(J.LE.22) THEN
7634 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
7635 IF(J.EQ.19) KLY=MOD(K(I,4)/MSTU(5),MSTU(5))
7636 IF(J.EQ.20) KLY=MOD(K(I,5)/MSTU(5),MSTU(5))
7637 IF(J.EQ.21) KLY=MOD(K(I,4),MSTU(5))
7638 IF(J.EQ.22) KLY=MOD(K(I,5),MSTU(5))
7639 ELSE
7640 ENDIF
7641
7642 RETURN
7643 END
7644
7645C*********************************************************************
7646
7647 FUNCTION PLY(I,J)
7648
7649C...Purpose: to provide various real-valued event related data.
7650 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
7651 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7652 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7653 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
7654 DIMENSION PSUM(4)
7655
7656C...Set default value. For I = 0 sum of momenta or charges,
7657C...or invariant mass of system.
7658 PLY=0.
7659 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
7660 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
7661 DO 100 I1=1,N
7662 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLY=PLY+P(I1,J)
7663 100 CONTINUE
7664 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
7665 DO 120 J1=1,4
7666 PSUM(J1)=0.
7667 DO 110 I1=1,N
7668 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
7669 110 CONTINUE
7670 120 CONTINUE
7671 PLY=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
7672 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
7673 DO 130 I1=1,N
7674 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLY=PLY+LYCHGE(K(I1,2))/3.
7675 130 CONTINUE
7676 ELSEIF(I.EQ.0) THEN
7677
7678C...Direct readout of P matrix.
7679 ELSEIF(J.LE.5) THEN
7680 PLY=P(I,J)
7681
7682C...Charge, total momentum, transverse momentum, transverse mass.
7683 ELSEIF(J.LE.12) THEN
7684 IF(J.EQ.6) PLY=LYCHGE(K(I,2))/3.
7685 IF(J.EQ.7.OR.J.EQ.8) PLY=P(I,1)**2+P(I,2)**2+P(I,3)**2
7686 IF(J.EQ.9.OR.J.EQ.10) PLY=P(I,1)**2+P(I,2)**2
7687 IF(J.EQ.11.OR.J.EQ.12) PLY=P(I,5)**2+P(I,1)**2+P(I,2)**2
7688 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLY=SQRT(PLY)
7689
7690C...Theta and phi angle in radians or degrees.
7691 ELSEIF(J.LE.16) THEN
7692 IF(J.LE.14) PLY=UYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
7693 IF(J.GE.15) PLY=UYANGL(P(I,1),P(I,2))
7694 IF(J.EQ.14.OR.J.EQ.16) PLY=PLY*180./PARU(1)
7695
7696C...True rapidity, rapidity with pion mass, pseudorapidity.
7697 ELSEIF(J.LE.19) THEN
7698 PMR=0.
7699 IF(J.EQ.17) PMR=P(I,5)
7700 IF(J.EQ.18) PMR=UYMASS(211)
7701 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
7702 PLY=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
7703 & 1E20)),P(I,3))
7704
7705C...Energy and momentum fractions (only to be used in CM frame).
7706 ELSEIF(J.LE.25) THEN
7707 IF(J.EQ.20) PLY=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
7708 IF(J.EQ.21) PLY=2.*P(I,3)/PARU(21)
7709 IF(J.EQ.22) PLY=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
7710 IF(J.EQ.23) PLY=2.*P(I,4)/PARU(21)
7711 IF(J.EQ.24) PLY=(P(I,4)+P(I,3))/PARU(21)
7712 IF(J.EQ.25) PLY=(P(I,4)-P(I,3))/PARU(21)
7713 ENDIF
7714
7715 RETURN
7716 END
7717
7718C*********************************************************************
7719
7720 SUBROUTINE LYSPHE(SPH,APL)
7721
7722C...Purpose: to perform sphericity tensor analysis to give sphericity,
7723C...aplanarity and the related event axes.
7724 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
7725 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7726 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7727 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
7728 DIMENSION SM(3,3),SV(3,3)
7729
7730C...Calculate matrix to be diagonalized.
7731 NP=0
7732 DO 110 J1=1,3
7733 DO 100 J2=J1,3
7734 SM(J1,J2)=0.
7735 100 CONTINUE
7736 110 CONTINUE
7737 PS=0.
7738 DO 140 I=1,N
7739 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
7740 IF(MSTU(41).GE.2) THEN
7741 KC=LYCOMP(K(I,2))
7742 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7743 & KC.EQ.18) GOTO 140
7744 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
7745 & GOTO 140
7746 ENDIF
7747 NP=NP+1
7748 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7749 PWT=1.
7750 IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1E-10,PA)**(PARU(41)-2.)
7751 DO 130 J1=1,3
7752 DO 120 J2=J1,3
7753 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
7754 120 CONTINUE
7755 130 CONTINUE
7756 PS=PS+PWT*PA**2
7757 140 CONTINUE
7758
7759C...Very low multiplicities (0 or 1) not considered.
7760 IF(NP.LE.1) THEN
7761 CALL LYERRM(8,'(LYSPHE:) too few particles for analysis')
7762 SPH=-1.
7763 APL=-1.
7764 RETURN
7765 ENDIF
7766 DO 160 J1=1,3
7767 DO 150 J2=J1,3
7768 SM(J1,J2)=SM(J1,J2)/PS
7769 150 CONTINUE
7770 160 CONTINUE
7771
7772C...Find eigenvalues to matrix (third degree equation).
7773 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
7774 &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
7775 SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
7776 &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
7777 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
7778 P(N+1,4)=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
7779 P(N+3,4)=1./3.+SQRT(-SQ)*MIN(2.*SP,-SQRT(3.*(1.-SP**2))-SP)
7780 P(N+2,4)=1.-P(N+1,4)-P(N+3,4)
7781 IF(P(N+2,4).LT.1E-5) THEN
7782 CALL LYERRM(8,'(LYSPHE:) all particles back-to-back')
7783 SPH=-1.
7784 APL=-1.
7785 RETURN
7786 ENDIF
7787
7788C...Find first and last eigenvector by solving equation system.
7789 DO 240 I=1,3,2
7790 DO 180 J1=1,3
7791 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
7792 DO 170 J2=J1+1,3
7793 SV(J1,J2)=SM(J1,J2)
7794 SV(J2,J1)=SM(J1,J2)
7795 170 CONTINUE
7796 180 CONTINUE
7797 SMAX=0.
7798 DO 200 J1=1,3
7799 DO 190 J2=1,3
7800 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
7801 JA=J1
7802 JB=J2
7803 SMAX=ABS(SV(J1,J2))
7804 190 CONTINUE
7805 200 CONTINUE
7806 SMAX=0.
7807 DO 220 J3=JA+1,JA+2
7808 J1=J3-3*((J3-1)/3)
7809 RL=SV(J1,JB)/SV(JA,JB)
7810 DO 210 J2=1,3
7811 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
7812 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
7813 JC=J1
7814 SMAX=ABS(SV(J1,J2))
7815 210 CONTINUE
7816 220 CONTINUE
7817 JB1=JB+1-3*(JB/3)
7818 JB2=JB+2-3*((JB+1)/3)
7819 P(N+I,JB1)=-SV(JC,JB2)
7820 P(N+I,JB2)=SV(JC,JB1)
7821 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
7822 &SV(JA,JB)
7823 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
7824 SGN=(-1.)**INT(RLY(0)+0.5)
7825 DO 230 J=1,3
7826 P(N+I,J)=SGN*P(N+I,J)/PA
7827 230 CONTINUE
7828 240 CONTINUE
7829
7830C...Middle axis orthogonal to other two. Fill other codes.
7831 SGN=(-1.)**INT(RLY(0)+0.5)
7832 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
7833 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
7834 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
7835 DO 260 I=1,3
7836 K(N+I,1)=31
7837 K(N+I,2)=95
7838 K(N+I,3)=I
7839 K(N+I,4)=0
7840 K(N+I,5)=0
7841 P(N+I,5)=0.
7842 DO 250 J=1,5
7843 V(I,J)=0.
7844 250 CONTINUE
7845 260 CONTINUE
7846
7847C...Calculate sphericity and aplanarity. Select storing option.
7848 SPH=1.5*(P(N+2,4)+P(N+3,4))
7849 APL=1.5*P(N+3,4)
7850 MSTU(61)=N+1
7851 MSTU(62)=NP
7852 IF(MSTU(43).LE.1) MSTU(3)=3
7853 IF(MSTU(43).GE.2) N=N+3
7854
7855 RETURN
7856 END
7857
7858C*********************************************************************
7859
7860 SUBROUTINE LYTHRU(THR,OBL)
7861
7862C...Purpose: to perform thrust analysis to give thrust, oblateness
7863C...and the related event axes.
7864 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
7865 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7866 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7867 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
7868 DIMENSION TDI(3),TPR(3)
7869
7870C...Take copy of particles that are to be considered in thrust analysis.
7871 NP=0
7872 PS=0.
7873 DO 100 I=1,N
7874 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
7875 IF(MSTU(41).GE.2) THEN
7876 KC=LYCOMP(K(I,2))
7877 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7878 & KC.EQ.18) GOTO 100
7879 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
7880 & GOTO 100
7881 ENDIF
7882 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
7883 CALL LYERRM(11,'(LYTHRU:) no more memory left in LUJETS')
7884 THR=-2.
7885 OBL=-2.
7886 RETURN
7887 ENDIF
7888 NP=NP+1
7889 K(N+NP,1)=23
7890 P(N+NP,1)=P(I,1)
7891 P(N+NP,2)=P(I,2)
7892 P(N+NP,3)=P(I,3)
7893 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7894 P(N+NP,5)=1.
7895 IF(ABS(PARU(42)-1.).GT.0.001) P(N+NP,5)=P(N+NP,4)**(PARU(42)-1.)
7896 PS=PS+P(N+NP,4)*P(N+NP,5)
7897 100 CONTINUE
7898
7899C...Very low multiplicities (0 or 1) not considered.
7900 IF(NP.LE.1) THEN
7901 CALL LYERRM(8,'(LYTHRU:) too few particles for analysis')
7902 THR=-1.
7903 OBL=-1.
7904 RETURN
7905 ENDIF
7906
7907C...Loop over thrust and major. T axis along z direction in latter case.
7908 DO 320 ILD=1,2
7909 IF(ILD.EQ.2) THEN
7910 K(N+NP+1,1)=31
7911 PHI=UYANGL(P(N+NP+1,1),P(N+NP+1,2))
7912 MSTU(33)=1
7913 CALL LUDBRB(N+1,N+NP+1,0.,-PHI,0D0,0D0,0D0)
7914 THE=UYANGL(P(N+NP+1,3),P(N+NP+1,1))
7915 CALL LUDBRB(N+1,N+NP+1,-THE,0.,0D0,0D0,0D0)
7916 ENDIF
7917
7918C...Find and order particles with highest p (pT for major).
7919 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
7920 P(ILF,4)=0.
7921 110 CONTINUE
7922 DO 160 I=N+1,N+NP
7923 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
7924 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
7925 IF(P(I,4).LE.P(ILF,4)) GOTO 140
7926 DO 120 J=1,5
7927 P(ILF+1,J)=P(ILF,J)
7928 120 CONTINUE
7929 130 CONTINUE
7930 ILF=N+NP+3
7931 140 DO 150 J=1,5
7932 P(ILF+1,J)=P(I,J)
7933 150 CONTINUE
7934 160 CONTINUE
7935
7936C...Find and order initial axes with highest thrust (major).
7937 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
7938 P(ILG,4)=0.
7939 170 CONTINUE
7940 NC=2**(MIN(MSTU(44),NP)-1)
7941 DO 250 ILC=1,NC
7942 DO 180 J=1,3
7943 TDI(J)=0.
7944 180 CONTINUE
7945 DO 200 ILF=1,MIN(MSTU(44),NP)
7946 SGN=P(N+NP+ILF+3,5)
7947 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
7948 DO 190 J=1,4-ILD
7949 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
7950 190 CONTINUE
7951 200 CONTINUE
7952 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
7953 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
7954 IF(TDS.LE.P(ILG,4)) GOTO 230
7955 DO 210 J=1,4
7956 P(ILG+1,J)=P(ILG,J)
7957 210 CONTINUE
7958 220 CONTINUE
7959 ILG=N+NP+MSTU(44)+4
7960 230 DO 240 J=1,3
7961 P(ILG+1,J)=TDI(J)
7962 240 CONTINUE
7963 P(ILG+1,4)=TDS
7964 250 CONTINUE
7965
7966C...Iterate direction of axis until stable maximum.
7967 P(N+NP+ILD,4)=0.
7968 ILG=0
7969 260 ILG=ILG+1
7970 THP=0.
7971 270 THPS=THP
7972 DO 280 J=1,3
7973 IF(THP.LE.1E-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
7974 IF(THP.GT.1E-10) TDI(J)=TPR(J)
7975 TPR(J)=0.
7976 280 CONTINUE
7977 DO 300 I=N+1,N+NP
7978 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
7979 DO 290 J=1,4-ILD
7980 TPR(J)=TPR(J)+SGN*P(I,J)
7981 290 CONTINUE
7982 300 CONTINUE
7983 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
7984 IF(THP.GE.THPS+PARU(48)) GOTO 270
7985
7986C...Save good axis. Try new initial axis until a number of tries agree.
7987 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
7988 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
7989 IAGR=0
7990 SGN=(-1.)**INT(RLY(0)+0.5)
7991 DO 310 J=1,3
7992 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
7993 310 CONTINUE
7994 P(N+NP+ILD,4)=THP
7995 P(N+NP+ILD,5)=0.
7996 ENDIF
7997 IAGR=IAGR+1
7998 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
7999 320 CONTINUE
8000
8001C...Find minor axis and value by orthogonality.
8002 SGN=(-1.)**INT(RLY(0)+0.5)
8003 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
8004 P(N+NP+3,2)=SGN*P(N+NP+2,1)
8005 P(N+NP+3,3)=0.
8006 THP=0.
8007 DO 330 I=N+1,N+NP
8008 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
8009 330 CONTINUE
8010 P(N+NP+3,4)=THP/PS
8011 P(N+NP+3,5)=0.
8012
8013C...Fill axis information. Rotate back to original coordinate system.
8014 DO 350 ILD=1,3
8015 K(N+ILD,1)=31
8016 K(N+ILD,2)=96
8017 K(N+ILD,3)=ILD
8018 K(N+ILD,4)=0
8019 K(N+ILD,5)=0
8020 DO 340 J=1,5
8021 P(N+ILD,J)=P(N+NP+ILD,J)
8022 V(N+ILD,J)=0.
8023 340 CONTINUE
8024 350 CONTINUE
8025 CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0)
8026
8027C...Calculate thrust and oblateness. Select storing option.
8028 THR=P(N+1,4)
8029 OBL=P(N+2,4)-P(N+3,4)
8030 MSTU(61)=N+1
8031 MSTU(62)=NP
8032 IF(MSTU(43).LE.1) MSTU(3)=3
8033 IF(MSTU(43).GE.2) N=N+3
8034
8035 RETURN
8036 END
8037
8038C*********************************************************************
8039
8040 SUBROUTINE LYCLUS(NJET)
8041
8042C...Purpose: to subdivide the particle content of an event into
8043C...jets/clusters.
8044 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8045 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8046 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8047 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
8048 DIMENSION PS(5)
8049 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
8050
8051C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
8052 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
8053 &P(I1,3)*P(I2,3))*2.*P(I1,5)*P(I2,5)/(0.0001+P(I1,5)+P(I2,5))**2
8054 R2M(I1,I2)=2.*P(I1,4)*P(I2,4)*(1.-(P(I1,1)*P(I2,1)+P(I1,2)*
8055 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
8056 R2D(I1,I2)=2.*MIN(P(I1,4),P(I2,4))**2*(1.-(P(I1,1)*P(I2,1)+
8057 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
8058
8059C...If first time, reset. If reentering, skip preliminaries.
8060 IF(MSTU(48).LE.0) THEN
8061 NP=0
8062 DO 100 J=1,5
8063 PS(J)=0.
8064 100 CONTINUE
8065 PSS=0.
8066 ELSE
8067 NJET=NSAV
8068 IF(MSTU(43).GE.2) N=N-NJET
8069 DO 110 I=N+1,N+NJET
8070 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8071 110 CONTINUE
8072 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
8073 R2ACC=PARU(44)**2
8074 ELSE
8075 R2ACC=PARU(45)*PS(5)**2
8076 ENDIF
8077 NLOOP=0
8078 GOTO 300
8079 ENDIF
8080
8081C...Find which particles are to be considered in cluster search.
8082 DO 140 I=1,N
8083 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
8084 IF(MSTU(41).GE.2) THEN
8085 KC=LYCOMP(K(I,2))
8086 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8087 & KC.EQ.18) GOTO 140
8088 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
8089 & GOTO 140
8090 ENDIF
8091 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
8092 CALL LYERRM(11,'(LYCLUS:) no more memory left in LUJETS')
8093 NJET=-1
8094 RETURN
8095 ENDIF
8096
8097C...Take copy of these particles, with space left for jets later on.
8098 NP=NP+1
8099 K(N+NP,3)=I
8100 DO 120 J=1,5
8101 P(N+NP,J)=P(I,J)
8102 120 CONTINUE
8103 IF(MSTU(42).EQ.0) P(N+NP,5)=0.
8104 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
8105 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
8106 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8107 DO 130 J=1,4
8108 PS(J)=PS(J)+P(N+NP,J)
8109 130 CONTINUE
8110 PSS=PSS+P(N+NP,5)
8111 140 CONTINUE
8112 DO 160 I=N+1,N+NP
8113 K(I+NP,3)=K(I,3)
8114 DO 150 J=1,5
8115 P(I+NP,J)=P(I,J)
8116 150 CONTINUE
8117 160 CONTINUE
8118 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
8119
8120C...Very low multiplicities not considered.
8121 IF(NP.LT.MSTU(47)) THEN
8122 CALL LYERRM(8,'(LYCLUS:) too few particles for analysis')
8123 NJET=-1
8124 RETURN
8125 ENDIF
8126
8127C...Find precluster configuration. If too few jets, make harder cuts.
8128 NLOOP=0
8129 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
8130 R2ACC=PARU(44)**2
8131 ELSE
8132 R2ACC=PARU(45)*PS(5)**2
8133 ENDIF
8134 RINIT=1.25*PARU(43)
8135 IF(NP.LE.MSTU(47)+2) RINIT=0.
8136 170 RINIT=0.8*RINIT
8137 NPRE=0
8138 NREM=NP
8139 DO 180 I=N+NP+1,N+2*NP
8140 K(I,4)=0
8141 180 CONTINUE
8142
8143C...Sum up small momentum region. Jet if enough absolute momentum.
8144 IF(MSTU(46).LE.2) THEN
8145 DO 190 J=1,4
8146 P(N+1,J)=0.
8147 190 CONTINUE
8148 DO 210 I=N+NP+1,N+2*NP
8149 IF(P(I,5).GT.2.*RINIT) GOTO 210
8150 NREM=NREM-1
8151 K(I,4)=1
8152 DO 200 J=1,4
8153 P(N+1,J)=P(N+1,J)+P(I,J)
8154 200 CONTINUE
8155 210 CONTINUE
8156 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
8157 IF(P(N+1,5).GT.2.*RINIT) NPRE=1
8158 IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
8159 IF(NREM.EQ.0) GOTO 170
8160 ENDIF
8161
8162C...Find fastest remaining particle.
8163 220 NPRE=NPRE+1
8164 PMAX=0.
8165 DO 230 I=N+NP+1,N+2*NP
8166 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
8167 IMAX=I
8168 PMAX=P(I,5)
8169 230 CONTINUE
8170 DO 240 J=1,5
8171 P(N+NPRE,J)=P(IMAX,J)
8172 240 CONTINUE
8173 NREM=NREM-1
8174 K(IMAX,4)=NPRE
8175
8176C...Sum up precluster around it according to pT separation.
8177 IF(MSTU(46).LE.2) THEN
8178 DO 260 I=N+NP+1,N+2*NP
8179 IF(K(I,4).NE.0) GOTO 260
8180 R2=R2T(I,IMAX)
8181 IF(R2.GT.RINIT**2) GOTO 260
8182 NREM=NREM-1
8183 K(I,4)=NPRE
8184 DO 250 J=1,4
8185 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
8186 250 CONTINUE
8187 260 CONTINUE
8188 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
8189
8190C...Sum up precluster around it according to mass or
8191C...Durham pT separation.
8192 ELSE
8193 270 IMIN=0
8194 R2MIN=RINIT**2
8195 DO 280 I=N+NP+1,N+2*NP
8196 IF(K(I,4).NE.0) GOTO 280
8197 IF(MSTU(46).LE.4) THEN
8198 R2=R2M(I,N+NPRE)
8199 ELSE
8200 R2=R2D(I,N+NPRE)
8201 ENDIF
8202 IF(R2.GE.R2MIN) GOTO 280
8203 IMIN=I
8204 R2MIN=R2
8205 280 CONTINUE
8206 IF(IMIN.NE.0) THEN
8207 DO 290 J=1,4
8208 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
8209 290 CONTINUE
8210 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
8211 NREM=NREM-1
8212 K(IMIN,4)=NPRE
8213 GOTO 270
8214 ENDIF
8215 ENDIF
8216
8217C...Check if more preclusters to be found. Start over if too few.
8218 IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
8219 IF(NREM.GT.0) GOTO 220
8220 NJET=NPRE
8221
8222C...Reassign all particles to nearest jet. Sum up new jet momenta.
8223 300 TSAV=0.
8224 PSJT=0.
8225 310 IF(MSTU(46).LE.1) THEN
8226 DO 330 I=N+1,N+NJET
8227 DO 320 J=1,4
8228 V(I,J)=0.
8229 320 CONTINUE
8230 330 CONTINUE
8231 DO 360 I=N+NP+1,N+2*NP
8232 R2MIN=PSS**2
8233 DO 340 IJET=N+1,N+NJET
8234 IF(P(IJET,5).LT.RINIT) GOTO 340
8235 R2=R2T(I,IJET)
8236 IF(R2.GE.R2MIN) GOTO 340
8237 IMIN=IJET
8238 R2MIN=R2
8239 340 CONTINUE
8240 K(I,4)=IMIN-N
8241 DO 350 J=1,4
8242 V(IMIN,J)=V(IMIN,J)+P(I,J)
8243 350 CONTINUE
8244 360 CONTINUE
8245 PSJT=0.
8246 DO 380 I=N+1,N+NJET
8247 DO 370 J=1,4
8248 P(I,J)=V(I,J)
8249 370 CONTINUE
8250 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8251 PSJT=PSJT+P(I,5)
8252 380 CONTINUE
8253 ENDIF
8254
8255C...Find two closest jets.
8256 R2MIN=2.*MAX(R2ACC,PS(5)**2)
8257 DO 400 ITRY1=N+1,N+NJET-1
8258 DO 390 ITRY2=ITRY1+1,N+NJET
8259 IF(MSTU(46).LE.2) THEN
8260 R2=R2T(ITRY1,ITRY2)
8261 ELSEIF(MSTU(46).LE.4) THEN
8262 R2=R2M(ITRY1,ITRY2)
8263 ELSE
8264 R2=R2D(ITRY1,ITRY2)
8265 ENDIF
8266 IF(R2.GE.R2MIN) GOTO 390
8267 IMIN1=ITRY1
8268 IMIN2=ITRY2
8269 R2MIN=R2
8270 390 CONTINUE
8271 400 CONTINUE
8272
8273C...If allowed, join two closest jets and start over.
8274 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
8275 IREC=MIN(IMIN1,IMIN2)
8276 IDEL=MAX(IMIN1,IMIN2)
8277 DO 410 J=1,4
8278 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
8279 410 CONTINUE
8280 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
8281 DO 430 I=IDEL+1,N+NJET
8282 DO 420 J=1,5
8283 P(I-1,J)=P(I,J)
8284 420 CONTINUE
8285 430 CONTINUE
8286 IF(MSTU(46).GE.2) THEN
8287 DO 440 I=N+NP+1,N+2*NP
8288 IORI=N+K(I,4)
8289 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
8290 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
8291 440 CONTINUE
8292 ENDIF
8293 NJET=NJET-1
8294 GOTO 300
8295
8296C...Divide up broad jet if empty cluster in list of final ones.
8297 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
8298 DO 450 I=N+1,N+NJET
8299 K(I,5)=0
8300 450 CONTINUE
8301 DO 460 I=N+NP+1,N+2*NP
8302 K(N+K(I,4),5)=K(N+K(I,4),5)+1
8303 460 CONTINUE
8304 IEMP=0
8305 DO 470 I=N+1,N+NJET
8306 IF(K(I,5).EQ.0) IEMP=I
8307 470 CONTINUE
8308 IF(IEMP.NE.0) THEN
8309 NLOOP=NLOOP+1
8310 ISPL=0
8311 R2MAX=0.
8312 DO 480 I=N+NP+1,N+2*NP
8313 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
8314 IJET=N+K(I,4)
8315 R2=R2T(I,IJET)
8316 IF(R2.LE.R2MAX) GOTO 480
8317 ISPL=I
8318 R2MAX=R2
8319 480 CONTINUE
8320 IF(ISPL.NE.0) THEN
8321 IJET=N+K(ISPL,4)
8322 DO 490 J=1,4
8323 P(IEMP,J)=P(ISPL,J)
8324 P(IJET,J)=P(IJET,J)-P(ISPL,J)
8325 490 CONTINUE
8326 P(IEMP,5)=P(ISPL,5)
8327 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
8328 IF(NLOOP.LE.2) GOTO 300
8329 ENDIF
8330 ENDIF
8331 ENDIF
8332
8333C...If generalized thrust has not yet converged, continue iteration.
8334 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
8335 &THEN
8336 TSAV=PSJT/PSS
8337 GOTO 310
8338 ENDIF
8339
8340C...Reorder jets according to energy.
8341 DO 510 I=N+1,N+NJET
8342 DO 500 J=1,5
8343 V(I,J)=P(I,J)
8344 500 CONTINUE
8345 510 CONTINUE
8346 DO 540 INEW=N+1,N+NJET
8347 PEMAX=0.
8348 DO 520 ITRY=N+1,N+NJET
8349 IF(V(ITRY,4).LE.PEMAX) GOTO 520
8350 IMAX=ITRY
8351 PEMAX=V(ITRY,4)
8352 520 CONTINUE
8353 K(INEW,1)=31
8354 K(INEW,2)=97
8355 K(INEW,3)=INEW-N
8356 K(INEW,4)=0
8357 DO 530 J=1,5
8358 P(INEW,J)=V(IMAX,J)
8359 530 CONTINUE
8360 V(IMAX,4)=-1.
8361 K(IMAX,5)=INEW
8362 540 CONTINUE
8363
8364C...Clean up particle-jet assignments and jet information.
8365 DO 550 I=N+NP+1,N+2*NP
8366 IORI=K(N+K(I,4),5)
8367 K(I,4)=IORI-N
8368 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
8369 K(IORI,4)=K(IORI,4)+1
8370 550 CONTINUE
8371 IEMP=0
8372 PSJT=0.
8373 DO 570 I=N+1,N+NJET
8374 K(I,5)=0
8375 PSJT=PSJT+P(I,5)
8376 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.))
8377 DO 560 J=1,5
8378 V(I,J)=0.
8379 560 CONTINUE
8380 IF(K(I,4).EQ.0) IEMP=I
8381 570 CONTINUE
8382
8383C...Select storing option. Output variables. Check for failure.
8384 MSTU(61)=N+1
8385 MSTU(62)=NP
8386 MSTU(63)=NPRE
8387 PARU(61)=PS(5)
8388 PARU(62)=PSJT/PSS
8389 PARU(63)=SQRT(R2MIN)
8390 IF(NJET.LE.1) PARU(63)=0.
8391 IF(IEMP.NE.0) THEN
8392 CALL LYERRM(8,'(LYCLUS:) failed to reconstruct as requested')
8393 NJET=-1
8394 ENDIF
8395 IF(MSTU(43).LE.1) MSTU(3)=NJET
8396 IF(MSTU(43).GE.2) N=N+NJET
8397 NSAV=NJET
8398
8399 RETURN
8400 END
8401
8402C*********************************************************************
8403
8404 SUBROUTINE LYCELL(NJET)
8405
8406C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
8407C...coordinate frame, as used for calorimeters at hadron colliders.
8408 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8409 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8410 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8411 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
8412
8413C...Loop over all particles. Find cell that was hit by given particle.
8414 PTLRAT=1./SINH(PARU(51))**2
8415 NP=0
8416 NC=N
8417 DO 110 I=1,N
8418 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
8419 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
8420 IF(MSTU(41).GE.2) THEN
8421 KC=LYCOMP(K(I,2))
8422 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8423 & KC.EQ.18) GOTO 110
8424 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
8425 & GOTO 110
8426 ENDIF
8427 NP=NP+1
8428 PT=SQRT(P(I,1)**2+P(I,2)**2)
8429 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
8430 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5*(ETA/PARU(51)+1.))))
8431 PHI=UYANGL(P(I,1),P(I,2))
8432 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5*(PHI/PARU(1)+1.))))
8433 IETPH=MSTU(52)*IETA+IPHI
8434
8435C...Add to cell already hit, or book new cell.
8436 DO 100 IC=N+1,NC
8437 IF(IETPH.EQ.K(IC,3)) THEN
8438 K(IC,4)=K(IC,4)+1
8439 P(IC,5)=P(IC,5)+PT
8440 GOTO 110
8441 ENDIF
8442 100 CONTINUE
8443 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
8444 CALL LYERRM(11,'(LYCELL:) no more memory left in LUJETS')
8445 NJET=-2
8446 RETURN
8447 ENDIF
8448 NC=NC+1
8449 K(NC,3)=IETPH
8450 K(NC,4)=1
8451 K(NC,5)=2
8452 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
8453 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
8454 P(NC,5)=PT
8455 110 CONTINUE
8456
8457C...Smear true bin content by calorimeter resolution.
8458 IF(MSTU(53).GE.1) THEN
8459 DO 130 IC=N+1,NC
8460 PEI=P(IC,5)
8461 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
8462 120 PEF=PEI+PARU(55)*SQRT(-2.*LOG(MAX(1E-10,RLY(0)))*PEI)*
8463 & COS(PARU(2)*RLY(0))
8464 IF(PEF.LT.0..OR.PEF.GT.PARU(56)*PEI) GOTO 120
8465 P(IC,5)=PEF
8466 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
8467 130 CONTINUE
8468 ENDIF
8469
8470C...Remove cells below threshold.
8471 IF(PARU(58).GT.0.) THEN
8472 NCC=NC
8473 NC=N
8474 DO 140 IC=N+1,NCC
8475 IF(P(IC,5).GT.PARU(58)) THEN
8476 NC=NC+1
8477 K(NC,3)=K(IC,3)
8478 K(NC,4)=K(IC,4)
8479 K(NC,5)=K(IC,5)
8480 P(NC,1)=P(IC,1)
8481 P(NC,2)=P(IC,2)
8482 P(NC,5)=P(IC,5)
8483 ENDIF
8484 140 CONTINUE
8485 ENDIF
8486
8487C...Find initiator cell: the one with highest pT of not yet used ones.
8488 NJ=NC
8489 150 ETMAX=0.
8490 DO 160 IC=N+1,NC
8491 IF(K(IC,5).NE.2) GOTO 160
8492 IF(P(IC,5).LE.ETMAX) GOTO 160
8493 ICMAX=IC
8494 ETA=P(IC,1)
8495 PHI=P(IC,2)
8496 ETMAX=P(IC,5)
8497 160 CONTINUE
8498 IF(ETMAX.LT.PARU(52)) GOTO 220
8499 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
8500 CALL LYERRM(11,'(LYCELL:) no more memory left in LUJETS')
8501 NJET=-2
8502 RETURN
8503 ENDIF
8504 K(ICMAX,5)=1
8505 NJ=NJ+1
8506 K(NJ,4)=0
8507 K(NJ,5)=1
8508 P(NJ,1)=ETA
8509 P(NJ,2)=PHI
8510 P(NJ,3)=0.
8511 P(NJ,4)=0.
8512 P(NJ,5)=0.
8513
8514C...Sum up unused cells within required distance of initiator.
8515 DO 170 IC=N+1,NC
8516 IF(K(IC,5).EQ.0) GOTO 170
8517 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
8518 DPHIA=ABS(P(IC,2)-PHI)
8519 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
8520 PHIC=P(IC,2)
8521 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
8522 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
8523 K(IC,5)=-K(IC,5)
8524 K(NJ,4)=K(NJ,4)+K(IC,4)
8525 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
8526 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
8527 P(NJ,5)=P(NJ,5)+P(IC,5)
8528 170 CONTINUE
8529
8530C...Reject cluster below minimum ET, else accept.
8531 IF(P(NJ,5).LT.PARU(53)) THEN
8532 NJ=NJ-1
8533 DO 180 IC=N+1,NC
8534 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
8535 180 CONTINUE
8536 ELSEIF(MSTU(54).LE.2) THEN
8537 P(NJ,3)=P(NJ,3)/P(NJ,5)
8538 P(NJ,4)=P(NJ,4)/P(NJ,5)
8539 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
8540 & P(NJ,4))
8541 DO 190 IC=N+1,NC
8542 IF(K(IC,5).LT.0) K(IC,5)=0
8543 190 CONTINUE
8544 ELSE
8545 DO 200 J=1,4
8546 P(NJ,J)=0.
8547 200 CONTINUE
8548 DO 210 IC=N+1,NC
8549 IF(K(IC,5).GE.0) GOTO 210
8550 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
8551 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
8552 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
8553 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
8554 K(IC,5)=0
8555 210 CONTINUE
8556 ENDIF
8557 GOTO 150
8558
8559C...Arrange clusters in falling ET sequence.
8560 220 DO 250 I=1,NJ-NC
8561 ETMAX=0.
8562 DO 230 IJ=NC+1,NJ
8563 IF(K(IJ,5).EQ.0) GOTO 230
8564 IF(P(IJ,5).LT.ETMAX) GOTO 230
8565 IJMAX=IJ
8566 ETMAX=P(IJ,5)
8567 230 CONTINUE
8568 K(IJMAX,5)=0
8569 K(N+I,1)=31
8570 K(N+I,2)=98
8571 K(N+I,3)=I
8572 K(N+I,4)=K(IJMAX,4)
8573 K(N+I,5)=0
8574 DO 240 J=1,5
8575 P(N+I,J)=P(IJMAX,J)
8576 V(N+I,J)=0.
8577 240 CONTINUE
8578 250 CONTINUE
8579 NJET=NJ-NC
8580
8581C...Convert to massless or massive four-vectors.
8582 IF(MSTU(54).EQ.2) THEN
8583 DO 260 I=N+1,N+NJET
8584 ETA=P(I,3)
8585 P(I,1)=P(I,5)*COS(P(I,4))
8586 P(I,2)=P(I,5)*SIN(P(I,4))
8587 P(I,3)=P(I,5)*SINH(ETA)
8588 P(I,4)=P(I,5)*COSH(ETA)
8589 P(I,5)=0.
8590 260 CONTINUE
8591 ELSEIF(MSTU(54).GE.3) THEN
8592 DO 270 I=N+1,N+NJET
8593 P(I,5)=SQRT(MAX(0.,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
8594 270 CONTINUE
8595 ENDIF
8596
8597C...Information about storage.
8598 MSTU(61)=N+1
8599 MSTU(62)=NP
8600 MSTU(63)=NC-N
8601 IF(MSTU(43).LE.1) MSTU(3)=NJET
8602 IF(MSTU(43).GE.2) N=N+NJET
8603
8604 RETURN
8605 END
8606
8607C*********************************************************************
8608
8609 SUBROUTINE LYJMAS(PMH,PML)
8610
8611C...Purpose: to determine, approximately, the two jet masses that
8612C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
8613 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8614 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8615 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8616 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
8617 DIMENSION SM(3,3),SAX(3),PS(3,5)
8618
8619C...Reset.
8620 NP=0
8621 DO 120 J1=1,3
8622 DO 100 J2=J1,3
8623 SM(J1,J2)=0.
8624 100 CONTINUE
8625 DO 110 J2=1,4
8626 PS(J1,J2)=0.
8627 110 CONTINUE
8628 120 CONTINUE
8629 PSS=0.
8630
8631C...Take copy of particles that are to be considered in mass analysis.
8632 DO 170 I=1,N
8633 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
8634 IF(MSTU(41).GE.2) THEN
8635 KC=LYCOMP(K(I,2))
8636 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8637 & KC.EQ.18) GOTO 170
8638 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
8639 & GOTO 170
8640 ENDIF
8641 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
8642 CALL LYERRM(11,'(LYJMAS:) no more memory left in LUJETS')
8643 PMH=-2.
8644 PML=-2.
8645 RETURN
8646 ENDIF
8647 NP=NP+1
8648 DO 130 J=1,5
8649 P(N+NP,J)=P(I,J)
8650 130 CONTINUE
8651 IF(MSTU(42).EQ.0) P(N+NP,5)=0.
8652 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
8653 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
8654
8655C...Fill information in sphericity tensor and total momentum vector.
8656 DO 150 J1=1,3
8657 DO 140 J2=J1,3
8658 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
8659 140 CONTINUE
8660 150 CONTINUE
8661 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8662 DO 160 J=1,4
8663 PS(3,J)=PS(3,J)+P(N+NP,J)
8664 160 CONTINUE
8665 170 CONTINUE
8666
8667C...Very low multiplicities (0 or 1) not considered.
8668 IF(NP.LE.1) THEN
8669 CALL LYERRM(8,'(LYJMAS:) too few particles for analysis')
8670 PMH=-1.
8671 PML=-1.
8672 RETURN
8673 ENDIF
8674 PARU(61)=SQRT(MAX(0.,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2))
8675
8676C...Find largest eigenvalue to matrix (third degree equation).
8677 DO 190 J1=1,3
8678 DO 180 J2=J1,3
8679 SM(J1,J2)=SM(J1,J2)/PSS
8680 180 CONTINUE
8681 190 CONTINUE
8682 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
8683 &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
8684 SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
8685 &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
8686 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
8687 SMA=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
8688
8689C...Find largest eigenvector by solving equation system.
8690 DO 210 J1=1,3
8691 SM(J1,J1)=SM(J1,J1)-SMA
8692 DO 200 J2=J1+1,3
8693 SM(J2,J1)=SM(J1,J2)
8694 200 CONTINUE
8695 210 CONTINUE
8696 SMAX=0.
8697 DO 230 J1=1,3
8698 DO 220 J2=1,3
8699 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
8700 JA=J1
8701 JB=J2
8702 SMAX=ABS(SM(J1,J2))
8703 220 CONTINUE
8704 230 CONTINUE
8705 SMAX=0.
8706 DO 250 J3=JA+1,JA+2
8707 J1=J3-3*((J3-1)/3)
8708 RL=SM(J1,JB)/SM(JA,JB)
8709 DO 240 J2=1,3
8710 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
8711 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
8712 JC=J1
8713 SMAX=ABS(SM(J1,J2))
8714 240 CONTINUE
8715 250 CONTINUE
8716 JB1=JB+1-3*(JB/3)
8717 JB2=JB+2-3*((JB+1)/3)
8718 SAX(JB1)=-SM(JC,JB2)
8719 SAX(JB2)=SM(JC,JB1)
8720 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
8721
8722C...Divide particles into two initial clusters by hemisphere.
8723 DO 270 I=N+1,N+NP
8724 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
8725 IS=1
8726 IF(PSAX.LT.0.) IS=2
8727 K(I,3)=IS
8728 DO 260 J=1,4
8729 PS(IS,J)=PS(IS,J)+P(I,J)
8730 260 CONTINUE
8731 270 CONTINUE
8732 PMS=MAX(1E-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
8733 &MAX(1E-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
8734
8735C...Reassign one particle at a time; find maximum decrease of m^2 sum.
8736 280 PMD=0.
8737 IM=0
8738 DO 290 J=1,4
8739 PS(3,J)=PS(1,J)-PS(2,J)
8740 290 CONTINUE
8741 DO 300 I=N+1,N+NP
8742 PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3)
8743 IF(K(I,3).EQ.1) PMDI=2.*(P(I,5)**2-PPS)
8744 IF(K(I,3).EQ.2) PMDI=2.*(P(I,5)**2+PPS)
8745 IF(PMDI.LT.PMD) THEN
8746 PMD=PMDI
8747 IM=I
8748 ENDIF
8749 300 CONTINUE
8750
8751C...Loop back if significant reduction in sum of m^2.
8752 IF(PMD.LT.-PARU(48)*PMS) THEN
8753 PMS=PMS+PMD
8754 IS=K(IM,3)
8755 DO 310 J=1,4
8756 PS(IS,J)=PS(IS,J)-P(IM,J)
8757 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
8758 310 CONTINUE
8759 K(IM,3)=3-IS
8760 GOTO 280
8761 ENDIF
8762
8763C...Final masses and output.
8764 MSTU(61)=N+1
8765 MSTU(62)=NP
8766 PS(1,5)=SQRT(MAX(0.,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
8767 PS(2,5)=SQRT(MAX(0.,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
8768 PMH=MAX(PS(1,5),PS(2,5))
8769 PML=MIN(PS(1,5),PS(2,5))
8770
8771 RETURN
8772 END
8773
8774C*********************************************************************
8775
8776 SUBROUTINE LYFOWO(H10,H20,H30,H40)
8777
8778C...Purpose: to calculate the first few Fox-Wolfram moments.
8779 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8780 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8781 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8782 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
8783
8784C...Copy momenta for particles and calculate H0.
8785 NP=0
8786 H0=0.
8787 HD=0.
8788 DO 110 I=1,N
8789 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
8790 IF(MSTU(41).GE.2) THEN
8791 KC=LYCOMP(K(I,2))
8792 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8793 & KC.EQ.18) GOTO 110
8794 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
8795 & GOTO 110
8796 ENDIF
8797 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
8798 CALL LYERRM(11,'(LYFOWO:) no more memory left in LUJETS')
8799 H10=-1.
8800 H20=-1.
8801 H30=-1.
8802 H40=-1.
8803 RETURN
8804 ENDIF
8805 NP=NP+1
8806 DO 100 J=1,3
8807 P(N+NP,J)=P(I,J)
8808 100 CONTINUE
8809 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
8810 H0=H0+P(N+NP,4)
8811 HD=HD+P(N+NP,4)**2
8812 110 CONTINUE
8813 H0=H0**2
8814
8815C...Very low multiplicities (0 or 1) not considered.
8816 IF(NP.LE.1) THEN
8817 CALL LYERRM(8,'(LYFOWO:) too few particles for analysis')
8818 H10=-1.
8819 H20=-1.
8820 H30=-1.
8821 H40=-1.
8822 RETURN
8823 ENDIF
8824
8825C...Calculate H1 - H4.
8826 H10=0.
8827 H20=0.
8828 H30=0.
8829 H40=0.
8830 DO 130 I1=N+1,N+NP
8831 DO 120 I2=I1+1,N+NP
8832 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
8833 &(P(I1,4)*P(I2,4))
8834 H10=H10+P(I1,4)*P(I2,4)*CTHE
8835 H20=H20+P(I1,4)*P(I2,4)*(1.5*CTHE**2-0.5)
8836 H30=H30+P(I1,4)*P(I2,4)*(2.5*CTHE**3-1.5*CTHE)
8837 H40=H40+P(I1,4)*P(I2,4)*(4.375*CTHE**4-3.75*CTHE**2+0.375)
8838 120 CONTINUE
8839 130 CONTINUE
8840
8841C...Calculate H1/H0 - H4/H0. Output.
8842 MSTU(61)=N+1
8843 MSTU(62)=NP
8844 H10=(HD+2.*H10)/H0
8845 H20=(HD+2.*H20)/H0
8846 H30=(HD+2.*H30)/H0
8847 H40=(HD+2.*H40)/H0
8848
8849 RETURN
8850 END
8851
8852C*********************************************************************
8853
8854 SUBROUTINE LYTABU(MTABU)
8855
8856C...Purpose: to evaluate various properties of an event, with
8857C...statistics accumulated during the course of the run and
8858C...printed at the end.
8859 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
8860 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8861 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8862 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
8863 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/,/LYDAT3/
8864 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
8865 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
8866 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
8867 &KFDM(8),KFDC(200,0:8),NPDC(200)
8868 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
8869 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
8870 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
8871 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
8872 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
8873 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0./,FM2FM/120*0./,
8874 &NEVEE/0/,FE1EC/50*0./,FE2EC/50*0./,FE1EA/25*0./,FE2EA/25*0./,
8875 &NEVDC/0/,NKFDC/0/,NREDC/0/
8876
8877C...Reset statistics on initial parton state.
8878 IF(MTABU.EQ.10) THEN
8879 NEVIS=0
8880 NKFIS=0
8881
8882C...Identify and order flavour content of initial state.
8883 ELSEIF(MTABU.EQ.11) THEN
8884 NEVIS=NEVIS+1
8885 KFM1=2*IABS(MSTU(161))
8886 IF(MSTU(161).GT.0) KFM1=KFM1-1
8887 KFM2=2*IABS(MSTU(162))
8888 IF(MSTU(162).GT.0) KFM2=KFM2-1
8889 KFMN=MIN(KFM1,KFM2)
8890 KFMX=MAX(KFM1,KFM2)
8891 DO 100 I=1,NKFIS
8892 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
8893 IKFIS=-I
8894 GOTO 110
8895 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
8896 & KFMX.LT.KFIS(I,2))) THEN
8897 IKFIS=I
8898 GOTO 110
8899 ENDIF
8900 100 CONTINUE
8901 IKFIS=NKFIS+1
8902 110 IF(IKFIS.LT.0) THEN
8903 IKFIS=-IKFIS
8904 ELSE
8905 IF(NKFIS.GE.100) RETURN
8906 DO 130 I=NKFIS,IKFIS,-1
8907 KFIS(I+1,1)=KFIS(I,1)
8908 KFIS(I+1,2)=KFIS(I,2)
8909 DO 120 J=0,10
8910 NPIS(I+1,J)=NPIS(I,J)
8911 120 CONTINUE
8912 130 CONTINUE
8913 NKFIS=NKFIS+1
8914 KFIS(IKFIS,1)=KFMN
8915 KFIS(IKFIS,2)=KFMX
8916 DO 140 J=0,10
8917 NPIS(IKFIS,J)=0
8918 140 CONTINUE
8919 ENDIF
8920 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
8921
8922C...Count number of partons in initial state.
8923 NP=0
8924 DO 160 I=1,N
8925 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
8926 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
8927 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
8928 & THEN
8929 ELSE
8930 IM=I
8931 150 IM=K(IM,3)
8932 IF(IM.LE.0.OR.IM.GT.N) THEN
8933 NP=NP+1
8934 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
8935 NP=NP+1
8936 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
8937 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10).NE.0)
8938 & THEN
8939 ELSE
8940 GOTO 150
8941 ENDIF
8942 ENDIF
8943 160 CONTINUE
8944 NPCO=MAX(NP,1)
8945 IF(NP.GE.6) NPCO=6
8946 IF(NP.GE.8) NPCO=7
8947 IF(NP.GE.11) NPCO=8
8948 IF(NP.GE.16) NPCO=9
8949 IF(NP.GE.26) NPCO=10
8950 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
8951 MSTU(62)=NP
8952
8953C...Write statistics on initial parton state.
8954 ELSEIF(MTABU.EQ.12) THEN
8955 FAC=1./MAX(1,NEVIS)
8956 WRITE(MSTU(11),5000) NEVIS
8957 DO 170 I=1,NKFIS
8958 KFMN=KFIS(I,1)
8959 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
8960 KFM1=(KFMN+1)/2
8961 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
8962 CALL LYNAME(KFM1,CHAU)
8963 CHIS(1)=CHAU(1:12)
8964 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
8965 KFMX=KFIS(I,2)
8966 IF(KFIS(I,1).EQ.0) KFMX=0
8967 KFM2=(KFMX+1)/2
8968 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
8969 CALL LYNAME(KFM2,CHAU)
8970 CHIS(2)=CHAU(1:12)
8971 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
8972 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
8973 & (NPIS(I,J)/FLOAT(NPIS(I,0)),J=1,10)
8974 170 CONTINUE
8975
8976C...Copy statistics on initial parton state into /LYJETS/.
8977 ELSEIF(MTABU.EQ.13) THEN
8978 FAC=1./MAX(1,NEVIS)
8979 DO 190 I=1,NKFIS
8980 KFMN=KFIS(I,1)
8981 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
8982 KFM1=(KFMN+1)/2
8983 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
8984 KFMX=KFIS(I,2)
8985 IF(KFIS(I,1).EQ.0) KFMX=0
8986 KFM2=(KFMX+1)/2
8987 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
8988 K(I,1)=32
8989 K(I,2)=99
8990 K(I,3)=KFM1
8991 K(I,4)=KFM2
8992 K(I,5)=NPIS(I,0)
8993 DO 180 J=1,5
8994 P(I,J)=FAC*NPIS(I,J)
8995 V(I,J)=FAC*NPIS(I,J+5)
8996 180 CONTINUE
8997 190 CONTINUE
8998 N=NKFIS
8999 DO 200 J=1,5
9000 K(N+1,J)=0
9001 P(N+1,J)=0.
9002 V(N+1,J)=0.
9003 200 CONTINUE
9004 K(N+1,1)=32
9005 K(N+1,2)=99
9006 K(N+1,5)=NEVIS
9007 MSTU(3)=1
9008
9009C...Reset statistics on number of particles/partons.
9010 ELSEIF(MTABU.EQ.20) THEN
9011 NEVFS=0
9012 NPRFS=0
9013 NFIFS=0
9014 NCHFS=0
9015 NKFFS=0
9016
9017C...Identify whether particle/parton is primary or not.
9018 ELSEIF(MTABU.EQ.21) THEN
9019 NEVFS=NEVFS+1
9020 MSTU(62)=0
9021 DO 260 I=1,N
9022 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
9023 MSTU(62)=MSTU(62)+1
9024 KC=LYCOMP(K(I,2))
9025 MPRI=0
9026 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
9027 MPRI=1
9028 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
9029 MPRI=1
9030 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
9031 MPRI=1
9032 ELSEIF(KC.EQ.0) THEN
9033 ELSEIF(K(K(I,3),1).EQ.13) THEN
9034 IM=K(K(I,3),3)
9035 IF(IM.LE.0.OR.IM.GT.N) THEN
9036 MPRI=1
9037 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
9038 MPRI=1
9039 ENDIF
9040 ELSEIF(KCHG(KC,2).EQ.0) THEN
9041 KCM=LYCOMP(K(K(I,3),2))
9042 IF(KCM.NE.0) THEN
9043 IF(KCHG(KCM,2).NE.0) MPRI=1
9044 ENDIF
9045 ENDIF
9046 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
9047 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
9048 ENDIF
9049 IF(K(I,1).LE.10) THEN
9050 NFIFS=NFIFS+1
9051 IF(LYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
9052 ENDIF
9053
9054C...Fill statistics on number of particles/partons in event.
9055 KFA=IABS(K(I,2))
9056 KFS=3-ISIGN(1,K(I,2))-MPRI
9057 DO 210 IP=1,NKFFS
9058 IF(KFA.EQ.KFFS(IP)) THEN
9059 IKFFS=-IP
9060 GOTO 220
9061 ELSEIF(KFA.LT.KFFS(IP)) THEN
9062 IKFFS=IP
9063 GOTO 220
9064 ENDIF
9065 210 CONTINUE
9066 IKFFS=NKFFS+1
9067 220 IF(IKFFS.LT.0) THEN
9068 IKFFS=-IKFFS
9069 ELSE
9070 IF(NKFFS.GE.400) RETURN
9071 DO 240 IP=NKFFS,IKFFS,-1
9072 KFFS(IP+1)=KFFS(IP)
9073 DO 230 J=1,4
9074 NPFS(IP+1,J)=NPFS(IP,J)
9075 230 CONTINUE
9076 240 CONTINUE
9077 NKFFS=NKFFS+1
9078 KFFS(IKFFS)=KFA
9079 DO 250 J=1,4
9080 NPFS(IKFFS,J)=0
9081 250 CONTINUE
9082 ENDIF
9083 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
9084 260 CONTINUE
9085
9086C...Write statistics on particle/parton composition of events.
9087 ELSEIF(MTABU.EQ.22) THEN
9088 FAC=1./MAX(1,NEVFS)
9089 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
9090 DO 270 I=1,NKFFS
9091 CALL LYNAME(KFFS(I),CHAU)
9092 KC=LYCOMP(KFFS(I))
9093 MDCYF=0
9094 IF(KC.NE.0) MDCYF=MDCY(KC,1)
9095 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
9096 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
9097 270 CONTINUE
9098
9099C...Copy particle/parton composition information into /LYJETS/.
9100 ELSEIF(MTABU.EQ.23) THEN
9101 FAC=1./MAX(1,NEVFS)
9102 DO 290 I=1,NKFFS
9103 K(I,1)=32
9104 K(I,2)=99
9105 K(I,3)=KFFS(I)
9106 K(I,4)=0
9107 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
9108 DO 280 J=1,4
9109 P(I,J)=FAC*NPFS(I,J)
9110 V(I,J)=0.
9111 280 CONTINUE
9112 P(I,5)=FAC*K(I,5)
9113 V(I,5)=0.
9114 290 CONTINUE
9115 N=NKFFS
9116 DO 300 J=1,5
9117 K(N+1,J)=0
9118 P(N+1,J)=0.
9119 V(N+1,J)=0.
9120 300 CONTINUE
9121 K(N+1,1)=32
9122 K(N+1,2)=99
9123 K(N+1,5)=NEVFS
9124 P(N+1,1)=FAC*NPRFS
9125 P(N+1,2)=FAC*NFIFS
9126 P(N+1,3)=FAC*NCHFS
9127 MSTU(3)=1
9128
9129C...Reset factorial moments statistics.
9130 ELSEIF(MTABU.EQ.30) THEN
9131 NEVFM=0
9132 NMUFM=0
9133 DO 330 IM=1,3
9134 DO 320 IB=1,10
9135 DO 310 IP=1,4
9136 FM1FM(IM,IB,IP)=0.
9137 FM2FM(IM,IB,IP)=0.
9138 310 CONTINUE
9139 320 CONTINUE
9140 330 CONTINUE
9141
9142C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
9143 ELSEIF(MTABU.EQ.31) THEN
9144 NEVFM=NEVFM+1
9145 NLOW=N+MSTU(3)
9146 NUPP=NLOW
9147 DO 410 I=1,N
9148 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
9149 IF(MSTU(41).GE.2) THEN
9150 KC=LYCOMP(K(I,2))
9151 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
9152 & KC.EQ.18) GOTO 410
9153 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
9154 & GOTO 410
9155 ENDIF
9156 PMR=0.
9157 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=UYMASS(211)
9158 IF(MSTU(42).GE.2) PMR=P(I,5)
9159 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
9160 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
9161 & 1E20)),P(I,3))
9162 IF(ABS(YETA).GT.PARU(57)) GOTO 410
9163 PHI=UYANGL(P(I,1),P(I,2))
9164 IYETA=512.*(YETA+PARU(57))/(2.*PARU(57))
9165 IYETA=MAX(0,MIN(511,IYETA))
9166 IPHI=512.*(PHI+PARU(1))/PARU(2)
9167 IPHI=MAX(0,MIN(511,IPHI))
9168 IYEP=0
9169 DO 340 IB=0,9
9170 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
9171 340 CONTINUE
9172
9173C...Order particles in (pseudo)rapidity and/or azimuth.
9174 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
9175 CALL LYERRM(11,'(LYTABU:) no more memory left in LUJETS')
9176 RETURN
9177 ENDIF
9178 NUPP=NUPP+1
9179 IF(NUPP.EQ.NLOW+1) THEN
9180 K(NUPP,1)=IYETA
9181 K(NUPP,2)=IPHI
9182 K(NUPP,3)=IYEP
9183 ELSE
9184 DO 350 I1=NUPP-1,NLOW+1,-1
9185 IF(IYETA.GE.K(I1,1)) GOTO 360
9186 K(I1+1,1)=K(I1,1)
9187 350 CONTINUE
9188 360 K(I1+1,1)=IYETA
9189 DO 370 I1=NUPP-1,NLOW+1,-1
9190 IF(IPHI.GE.K(I1,2)) GOTO 380
9191 K(I1+1,2)=K(I1,2)
9192 370 CONTINUE
9193 380 K(I1+1,2)=IPHI
9194 DO 390 I1=NUPP-1,NLOW+1,-1
9195 IF(IYEP.GE.K(I1,3)) GOTO 400
9196 K(I1+1,3)=K(I1,3)
9197 390 CONTINUE
9198 400 K(I1+1,3)=IYEP
9199 ENDIF
9200 410 CONTINUE
9201 K(NUPP+1,1)=2**10
9202 K(NUPP+1,2)=2**10
9203 K(NUPP+1,3)=4**10
9204
9205C...Calculate sum of factorial moments in event.
9206 DO 480 IM=1,3
9207 DO 430 IB=1,10
9208 DO 420 IP=1,4
9209 FEVFM(IB,IP)=0.
9210 420 CONTINUE
9211 430 CONTINUE
9212 DO 450 IB=1,10
9213 IF(IM.LE.2) IBIN=2**(10-IB)
9214 IF(IM.EQ.3) IBIN=4**(10-IB)
9215 IAGR=K(NLOW+1,IM)/IBIN
9216 NAGR=1
9217 DO 440 I=NLOW+2,NUPP+1
9218 ICUT=K(I,IM)/IBIN
9219 IF(ICUT.EQ.IAGR) THEN
9220 NAGR=NAGR+1
9221 ELSE
9222 IF(NAGR.EQ.1) THEN
9223 ELSEIF(NAGR.EQ.2) THEN
9224 FEVFM(IB,1)=FEVFM(IB,1)+2.
9225 ELSEIF(NAGR.EQ.3) THEN
9226 FEVFM(IB,1)=FEVFM(IB,1)+6.
9227 FEVFM(IB,2)=FEVFM(IB,2)+6.
9228 ELSEIF(NAGR.EQ.4) THEN
9229 FEVFM(IB,1)=FEVFM(IB,1)+12.
9230 FEVFM(IB,2)=FEVFM(IB,2)+24.
9231 FEVFM(IB,3)=FEVFM(IB,3)+24.
9232 ELSE
9233 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1.)
9234 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1.)*(NAGR-2.)
9235 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)
9236 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)*
9237 & (NAGR-4.)
9238 ENDIF
9239 IAGR=ICUT
9240 NAGR=1
9241 ENDIF
9242 440 CONTINUE
9243 450 CONTINUE
9244
9245C...Add results to total statistics.
9246 DO 470 IB=10,1,-1
9247 DO 460 IP=1,4
9248 IF(FEVFM(1,IP).LT.0.5) THEN
9249 FEVFM(IB,IP)=0.
9250 ELSEIF(IM.LE.2) THEN
9251 FEVFM(IB,IP)=2.**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
9252 ELSE
9253 FEVFM(IB,IP)=4.**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
9254 ENDIF
9255 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
9256 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
9257 460 CONTINUE
9258 470 CONTINUE
9259 480 CONTINUE
9260 NMUFM=NMUFM+(NUPP-NLOW)
9261 MSTU(62)=NUPP-NLOW
9262
9263C...Write accumulated statistics on factorial moments.
9264 ELSEIF(MTABU.EQ.32) THEN
9265 FAC=1./MAX(1,NEVFM)
9266 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
9267 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
9268 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
9269 DO 510 IM=1,3
9270 WRITE(MSTU(11),5500)
9271 DO 500 IB=1,10
9272 BYETA=2.*PARU(57)
9273 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
9274 BPHI=PARU(2)
9275 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
9276 IF(IM.LE.2) BNAVE=FAC*NMUFM/FLOAT(2**(IB-1))
9277 IF(IM.EQ.3) BNAVE=FAC*NMUFM/FLOAT(4**(IB-1))
9278 DO 490 IP=1,4
9279 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
9280 FMOMS(IP)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2)))
9281 490 CONTINUE
9282 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
9283 & IP=1,4)
9284 500 CONTINUE
9285 510 CONTINUE
9286
9287C...Copy statistics on factorial moments into /LYJETS/.
9288 ELSEIF(MTABU.EQ.33) THEN
9289 FAC=1./MAX(1,NEVFM)
9290 DO 540 IM=1,3
9291 DO 530 IB=1,10
9292 I=10*(IM-1)+IB
9293 K(I,1)=32
9294 K(I,2)=99
9295 K(I,3)=1
9296 IF(IM.NE.2) K(I,3)=2**(IB-1)
9297 K(I,4)=1
9298 IF(IM.NE.1) K(I,4)=2**(IB-1)
9299 K(I,5)=0
9300 P(I,1)=2.*PARU(57)/K(I,3)
9301 V(I,1)=PARU(2)/K(I,4)
9302 DO 520 IP=1,4
9303 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
9304 V(I,IP+1)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-P(I,IP+1)**2)))
9305 520 CONTINUE
9306 530 CONTINUE
9307 540 CONTINUE
9308 N=30
9309 DO 550 J=1,5
9310 K(N+1,J)=0
9311 P(N+1,J)=0.
9312 V(N+1,J)=0.
9313 550 CONTINUE
9314 K(N+1,1)=32
9315 K(N+1,2)=99
9316 K(N+1,5)=NEVFM
9317 MSTU(3)=1
9318
9319C...Reset statistics on Energy-Energy Correlation.
9320 ELSEIF(MTABU.EQ.40) THEN
9321 NEVEE=0
9322 DO 560 J=1,25
9323 FE1EC(J)=0.
9324 FE2EC(J)=0.
9325 FE1EC(51-J)=0.
9326 FE2EC(51-J)=0.
9327 FE1EA(J)=0.
9328 FE2EA(J)=0.
9329 560 CONTINUE
9330
9331C...Find particles to include, with proper assumed mass.
9332 ELSEIF(MTABU.EQ.41) THEN
9333 NEVEE=NEVEE+1
9334 NLOW=N+MSTU(3)
9335 NUPP=NLOW
9336 ECM=0.
9337 DO 570 I=1,N
9338 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
9339 IF(MSTU(41).GE.2) THEN
9340 KC=LYCOMP(K(I,2))
9341 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
9342 & KC.EQ.18) GOTO 570
9343 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LYCHGE(K(I,2)).EQ.0)
9344 & GOTO 570
9345 ENDIF
9346 PMR=0.
9347 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=UYMASS(211)
9348 IF(MSTU(42).GE.2) PMR=P(I,5)
9349 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
9350 CALL LYERRM(11,'(LYTABU:) no more memory left in LUJETS')
9351 RETURN
9352 ENDIF
9353 NUPP=NUPP+1
9354 P(NUPP,1)=P(I,1)
9355 P(NUPP,2)=P(I,2)
9356 P(NUPP,3)=P(I,3)
9357 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
9358 P(NUPP,5)=MAX(1E-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
9359 ECM=ECM+P(NUPP,4)
9360 570 CONTINUE
9361 IF(NUPP.EQ.NLOW) RETURN
9362
9363C...Analyze Energy-Energy Correlation in event.
9364 FAC=(2./ECM**2)*50./PARU(1)
9365 DO 580 J=1,50
9366 FEVEE(J)=0.
9367 580 CONTINUE
9368 DO 600 I1=NLOW+2,NUPP
9369 DO 590 I2=NLOW+1,I1-1
9370 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
9371 & (P(I1,5)*P(I2,5))
9372 THE=ACOS(MAX(-1.,MIN(1.,CTHE)))
9373 ITHE=MAX(1,MIN(50,1+INT(50.*THE/PARU(1))))
9374 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
9375 590 CONTINUE
9376 600 CONTINUE
9377 DO 610 J=1,25
9378 FE1EC(J)=FE1EC(J)+FEVEE(J)
9379 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
9380 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
9381 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
9382 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
9383 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
9384 610 CONTINUE
9385 MSTU(62)=NUPP-NLOW
9386
9387C...Write statistics on Energy-Energy Correlation.
9388 ELSEIF(MTABU.EQ.42) THEN
9389 FAC=1./MAX(1,NEVEE)
9390 WRITE(MSTU(11),5700) NEVEE
9391 DO 620 J=1,25
9392 FEEC1=FAC*FE1EC(J)
9393 FEES1=SQRT(MAX(0.,FAC*(FAC*FE2EC(J)-FEEC1**2)))
9394 FEEC2=FAC*FE1EC(51-J)
9395 FEES2=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
9396 FEECA=FAC*FE1EA(J)
9397 FEESA=SQRT(MAX(0.,FAC*(FAC*FE2EA(J)-FEECA**2)))
9398 WRITE(MSTU(11),5800) 3.6*(J-1),3.6*J,FEEC1,FEES1,FEEC2,FEES2,
9399 & FEECA,FEESA
9400 620 CONTINUE
9401
9402C...Copy statistics on Energy-Energy Correlation into /LYJETS/.
9403 ELSEIF(MTABU.EQ.43) THEN
9404 FAC=1./MAX(1,NEVEE)
9405 DO 630 I=1,25
9406 K(I,1)=32
9407 K(I,2)=99
9408 K(I,3)=0
9409 K(I,4)=0
9410 K(I,5)=0
9411 P(I,1)=FAC*FE1EC(I)
9412 V(I,1)=SQRT(MAX(0.,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
9413 P(I,2)=FAC*FE1EC(51-I)
9414 V(I,2)=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
9415 P(I,3)=FAC*FE1EA(I)
9416 V(I,3)=SQRT(MAX(0.,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
9417 P(I,4)=PARU(1)*(I-1)/50.
9418 P(I,5)=PARU(1)*I/50.
9419 V(I,4)=3.6*(I-1)
9420 V(I,5)=3.6*I
9421 630 CONTINUE
9422 N=25
9423 DO 640 J=1,5
9424 K(N+1,J)=0
9425 P(N+1,J)=0.
9426 V(N+1,J)=0.
9427 640 CONTINUE
9428 K(N+1,1)=32
9429 K(N+1,2)=99
9430 K(N+1,5)=NEVEE
9431 MSTU(3)=1
9432
9433C...Reset statistics on decay channels.
9434 ELSEIF(MTABU.EQ.50) THEN
9435 NEVDC=0
9436 NKFDC=0
9437 NREDC=0
9438
9439C...Identify and order flavour content of final state.
9440 ELSEIF(MTABU.EQ.51) THEN
9441 NEVDC=NEVDC+1
9442 NDS=0
9443 DO 670 I=1,N
9444 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
9445 NDS=NDS+1
9446 IF(NDS.GT.8) THEN
9447 NREDC=NREDC+1
9448 RETURN
9449 ENDIF
9450 KFM=2*IABS(K(I,2))
9451 IF(K(I,2).LT.0) KFM=KFM-1
9452 DO 650 IDS=NDS-1,1,-1
9453 IIN=IDS+1
9454 IF(KFM.LT.KFDM(IDS)) GOTO 660
9455 KFDM(IDS+1)=KFDM(IDS)
9456 650 CONTINUE
9457 IIN=1
9458 660 KFDM(IIN)=KFM
9459 670 CONTINUE
9460
9461C...Find whether old or new final state.
9462 DO 690 IDC=1,NKFDC
9463 IF(NDS.LT.KFDC(IDC,0)) THEN
9464 IKFDC=IDC
9465 GOTO 700
9466 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
9467 DO 680 I=1,NDS
9468 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
9469 IKFDC=IDC
9470 GOTO 700
9471 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
9472 GOTO 690
9473 ENDIF
9474 680 CONTINUE
9475 IKFDC=-IDC
9476 GOTO 700
9477 ENDIF
9478 690 CONTINUE
9479 IKFDC=NKFDC+1
9480 700 IF(IKFDC.LT.0) THEN
9481 IKFDC=-IKFDC
9482 ELSEIF(NKFDC.GE.200) THEN
9483 NREDC=NREDC+1
9484 RETURN
9485 ELSE
9486 DO 720 IDC=NKFDC,IKFDC,-1
9487 NPDC(IDC+1)=NPDC(IDC)
9488 DO 710 I=0,8
9489 KFDC(IDC+1,I)=KFDC(IDC,I)
9490 710 CONTINUE
9491 720 CONTINUE
9492 NKFDC=NKFDC+1
9493 KFDC(IKFDC,0)=NDS
9494 DO 730 I=1,NDS
9495 KFDC(IKFDC,I)=KFDM(I)
9496 730 CONTINUE
9497 NPDC(IKFDC)=0
9498 ENDIF
9499 NPDC(IKFDC)=NPDC(IKFDC)+1
9500
9501C...Write statistics on decay channels.
9502 ELSEIF(MTABU.EQ.52) THEN
9503 FAC=1./MAX(1,NEVDC)
9504 WRITE(MSTU(11),5900) NEVDC
9505 DO 750 IDC=1,NKFDC
9506 DO 740 I=1,KFDC(IDC,0)
9507 KFM=KFDC(IDC,I)
9508 KF=(KFM+1)/2
9509 IF(2*KF.NE.KFM) KF=-KF
9510 CALL LYNAME(KF,CHAU)
9511 CHDC(I)=CHAU(1:12)
9512 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
9513 740 CONTINUE
9514 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
9515 750 CONTINUE
9516 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
9517
9518C...Copy statistics on decay channels into /LYJETS/.
9519 ELSEIF(MTABU.EQ.53) THEN
9520 FAC=1./MAX(1,NEVDC)
9521 DO 780 IDC=1,NKFDC
9522 K(IDC,1)=32
9523 K(IDC,2)=99
9524 K(IDC,3)=0
9525 K(IDC,4)=0
9526 K(IDC,5)=KFDC(IDC,0)
9527 DO 760 J=1,5
9528 P(IDC,J)=0.
9529 V(IDC,J)=0.
9530 760 CONTINUE
9531 DO 770 I=1,KFDC(IDC,0)
9532 KFM=KFDC(IDC,I)
9533 KF=(KFM+1)/2
9534 IF(2*KF.NE.KFM) KF=-KF
9535 IF(I.LE.5) P(IDC,I)=KF
9536 IF(I.GE.6) V(IDC,I-5)=KF
9537 770 CONTINUE
9538 V(IDC,5)=FAC*NPDC(IDC)
9539 780 CONTINUE
9540 N=NKFDC
9541 DO 790 J=1,5
9542 K(N+1,J)=0
9543 P(N+1,J)=0.
9544 V(N+1,J)=0.
9545 790 CONTINUE
9546 K(N+1,1)=32
9547 K(N+1,2)=99
9548 K(N+1,5)=NEVDC
9549 V(N+1,5)=FAC*NREDC
9550 MSTU(3)=1
9551 ENDIF
9552
9553C...Format statements for output on unit MSTU(11) (default 6).
9554 5000 FORMAT(///20X,'Event statistics - initial state'/
9555 &20X,'based on an analysis of ',I6,' events'//
9556 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
9557 &'according to fragmenting system multiplicity'/
9558 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
9559 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
9560 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
9561 5200 FORMAT(///20X,'Event statistics - final state'/
9562 &20X,'based on an analysis of ',I7,' events'//
9563 &5X,'Mean primary multiplicity =',F10.4/
9564 &5X,'Mean final multiplicity =',F10.4/
9565 &5X,'Mean charged multiplicity =',F10.4//
9566 &5X,'Number of particles produced per event (directly and via ',
9567 &'decays/branchings)'/
9568 &5X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
9569 &8X,'Total'/35X,'prim seco prim seco'/)
9570 5300 FORMAT(1X,I6,4X,A16,I2,5(1X,F11.6))
9571 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
9572 &20X,'based on an analysis of ',I6,' events'//
9573 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
9574 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
9575 5500 FORMAT(10X)
9576 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
9577 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
9578 &20X,'based on an analysis of ',I6,' events'//
9579 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
9580 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
9581 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
9582 5900 FORMAT(///20X,'Decay channel analysis - final state'/
9583 &20X,'based on an analysis of ',I6,' events'//
9584 &2X,'Probability',10X,'Complete final state'/)
9585 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
9586 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
9587 &'or table overflow)')
9588
9589 RETURN
9590 END
9591
9592C*********************************************************************
9593
9594 SUBROUTINE LYEEVT(KFL,ECM)
9595
9596C...Purpose: to handle the generation of an e+e- annihilation jet event.
9597 IMPLICIT DOUBLE PRECISION(D)
9598 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
9599 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9600 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9601 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
9602
9603C...Check input parameters.
9604 IF(MSTU(12).GE.1) CALL LYLIST(0)
9605 IF(KFL.LT.0.OR.KFL.GT.8) THEN
9606 CALL LYERRM(16,'(LYEEVT:) called with unknown flavour code')
9607 IF(MSTU(21).GE.1) RETURN
9608 ENDIF
9609 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02*PARF(100+MAX(1,KFL))
9610 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02*PMAS(KFL,1)
9611 IF(ECM.LT.ECMMIN) THEN
9612 CALL LYERRM(16,'(LYEEVT:) called with too small CM energy')
9613 IF(MSTU(21).GE.1) RETURN
9614 ENDIF
9615
9616C...Check consistency of MSTJ options set.
9617 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
9618 CALL LYERRM(6,
9619 & '(LYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
9620 MSTJ(110)=1
9621 ENDIF
9622 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
9623 CALL LYERRM(6,
9624 & '(LYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
9625 MSTJ(111)=0
9626 ENDIF
9627
9628C...Initialize alpha_strong and total cross-section.
9629 MSTU(111)=MSTJ(108)
9630 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9631 &MSTU(111)=1
9632 PARU(112)=PARJ(121)
9633 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9634 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
9635 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL LYXTOT(KFL,ECM,
9636 &XTOT)
9637 IF(MSTJ(116).GE.3) MSTJ(116)=1
9638 PARJ(171)=0.
9639
9640C...Add initial e+e- to event record (documentation only).
9641 NTRY=0
9642 100 NTRY=NTRY+1
9643 IF(NTRY.GT.100) THEN
9644 CALL LYERRM(14,'(LYEEVT:) caught in an infinite loop')
9645 RETURN
9646 ENDIF
9647 MSTU(24)=0
9648 NC=0
9649 IF(MSTJ(115).GE.2) THEN
9650 NC=NC+2
9651 CALL LY1ENT(NC-1,11,0.5*ECM,0.,0.)
9652 K(NC-1,1)=21
9653 CALL LY1ENT(NC,-11,0.5*ECM,PARU(1),0.)
9654 K(NC,1)=21
9655 ENDIF
9656
9657C...Radiative photon (in initial state).
9658 MK=0
9659 ECMC=ECM
9660 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LYRADK(ECM,MK,PAK,
9661 &THEK,PHIK,ALPK)
9662 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK))
9663 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
9664 NC=NC+1
9665 CALL LY1ENT(NC,22,PAK,THEK,PHIK)
9666 K(NC,3)=MIN(MSTJ(115)/2,1)
9667 ENDIF
9668
9669C...Virtual exchange boson (gamma or Z0).
9670 IF(MSTJ(115).GE.3) THEN
9671 NC=NC+1
9672 KF=22
9673 IF(MSTJ(102).EQ.2) KF=23
9674 MSTU10=MSTU(10)
9675 MSTU(10)=1
9676 P(NC,5)=ECMC
9677 CALL LY1ENT(NC,KF,ECMC,0.,0.)
9678 K(NC,1)=21
9679 K(NC,3)=1
9680 MSTU(10)=MSTU10
9681 ENDIF
9682
9683C...Choice of flavour and jet configuration.
9684 CALL LYXKFL(KFL,ECM,ECMC,KFLC)
9685 IF(KFLC.EQ.0) GOTO 100
9686 CALL LYXJET(ECMC,NJET,CUT)
9687 KFLN=21
9688 IF(NJET.EQ.4) CALL LYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
9689 &X12,X14)
9690 IF(NJET.EQ.3) CALL LYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
9691 IF(NJET.EQ.2) MSTJ(120)=1
9692
9693C...Fill jet configuration and origin.
9694 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL LY2ENT(NC+1,KFLC,-KFLC,ECMC)
9695 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL LY2ENT(-(NC+1),KFLC,-KFLC,
9696 &ECMC)
9697 IF(NJET.EQ.3) CALL LY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
9698 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL LY4ENT(NC+1,KFLC,KFLN,KFLN,
9699 &-KFLC,ECMC,X1,X2,X4,X12,X14)
9700 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL LY4ENT(NC+1,KFLC,-KFLN,KFLN,
9701 &-KFLC,ECMC,X1,X2,X4,X12,X14)
9702 IF(MSTU(24).NE.0) GOTO 100
9703 DO 110 IP=NC+1,N
9704 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
9705 110 CONTINUE
9706
9707C...Angular orientation according to matrix element.
9708 IF(MSTJ(106).EQ.1) THEN
9709 CALL LYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
9710 CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
9711 CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
9712 ENDIF
9713
9714C...Rotation and boost from radiative photon.
9715 IF(MK.EQ.1) THEN
9716 DBEK=-PAK/(ECM-PAK)
9717 NMIN=NC+1-MSTJ(115)/3
9718 CALL LUDBRB(NMIN,N,0.,-PHIK,0D0,0D0,0D0)
9719 CALL LUDBRB(NMIN,N,ALPK,0.,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
9720 CALL LUDBRB(NMIN,N,0.,PHIK,0D0,0D0,0D0)
9721 ENDIF
9722
9723C...Generate parton shower. Rearrange along strings and check.
9724 IF(MSTJ(101).EQ.5) THEN
9725 CALL LYSHOW(N-1,N,ECMC)
9726 MSTJ14=MSTJ(14)
9727 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
9728 IF(MSTJ(105).GE.0) MSTU(28)=0
9729 CALL LYPREP(0)
9730 MSTJ(14)=MSTJ14
9731 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
9732 ENDIF
9733
9734C...Fragmentation/decay generation. Information for LYTABU.
9735 IF(MSTJ(105).EQ.1) CALL LYEXEC
9736 MSTU(161)=KFLC
9737 MSTU(162)=-KFLC
9738
9739 RETURN
9740 END
9741
9742C*********************************************************************
9743
9744 SUBROUTINE LYXTOT(KFL,ECM,XTOT)
9745
9746C...Purpose: to calculate total cross-section, including initial
9747C...state radiation effects.
9748 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9749 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9750 SAVE /LYDAT1/,/LYDAT2/
9751
9752C...Status, (optimized) Q^2 scale, alpha_strong.
9753 PARJ(151)=ECM
9754 MSTJ(119)=10*MSTJ(102)+KFL
9755 IF(MSTJ(111).EQ.0) THEN
9756 Q2R=ECM**2
9757 ELSEIF(MSTU(111).EQ.0) THEN
9758 PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
9759 & ((33.-2.*MSTU(112))*PARU(111)))))
9760 Q2R=PARJ(168)*ECM**2
9761 ELSE
9762 PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
9763 & (2.*PARU(112)/ECM)**2))
9764 Q2R=PARJ(168)*ECM**2
9765 ENDIF
9766 ALSPI=UYALPS(Q2R)/PARU(1)
9767
9768C...QCD corrections factor in R.
9769 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
9770 RQCD=1.
9771 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
9772 RQCD=1.+ALSPI
9773 ELSEIF(MSTJ(109).EQ.0) THEN
9774 RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
9775 IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
9776 & LOG(PARJ(168))*ALSPI**2)
9777 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
9778 RQCD=1.+(3./4.)*ALSPI
9779 ELSE
9780 RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2
9781 ENDIF
9782
9783C...Calculate Z0 width if default value not acceptable.
9784 IF(MSTJ(102).GE.3) THEN
9785 RVA=3.*(3.+(4.*PARU(102)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARU(102)/
9786 & 3.)**2+(4.*PARU(102)/3.-1.)**2)
9787 DO 100 KFLC=5,6
9788 VQ=1.
9789 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*UYMASS(KFLC)/
9790 & ECM)**2))
9791 IF(KFLC.EQ.5) VF=4.*PARU(102)/3.-1.
9792 IF(KFLC.EQ.6) VF=1.-8.*PARU(102)/3.
9793 RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3)
9794 100 CONTINUE
9795 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102)))
9796 ENDIF
9797
9798C...Calculate propagator and related constants for QFD case.
9799 POLL=1.-PARJ(131)*PARJ(132)
9800 IF(MSTJ(102).GE.2) THEN
9801 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
9802 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
9803 SFI=SFW*(1.-(PARJ(123)/ECM)**2)
9804 VE=4.*PARU(102)-1.
9805 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
9806 SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
9807 HF1I=SFI*SF1I
9808 HF1W=SFW*SF1W
9809 ENDIF
9810
9811C...Loop over different flavours: charge, velocity.
9812 RTOT=0.
9813 RQQ=0.
9814 RQV=0.
9815 RVA=0.
9816 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
9817 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
9818 MSTJ(93)=1
9819 PMQ=UYMASS(KFLC)
9820 IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110
9821 QF=KCHG(KFLC,1)/3.
9822 VQ=1.
9823 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2)
9824
9825C...Calculate R and sum of charges for QED or QFD case.
9826 RQQ=RQQ+3.*QF**2*POLL
9827 IF(MSTJ(102).LE.1) THEN
9828 RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL
9829 ELSE
9830 VF=SIGN(1.,QF)-4.*QF*PARU(102)
9831 RQV=RQV-6.*QF*VF*SF1I
9832 RVA=RVA+3.*(VF**2+1.)*SF1W
9833 RTOT=RTOT+3.*(0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+
9834 & VF**2*HF1W)+VQ**3*HF1W)
9835 ENDIF
9836 110 CONTINUE
9837 RSUM=RQQ
9838 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
9839
9840C...Calculate cross-section, including QCD corrections.
9841 PARJ(141)=RQQ
9842 PARJ(142)=RTOT
9843 PARJ(143)=RTOT*RQCD
9844 PARJ(144)=PARJ(143)
9845 PARJ(145)=PARJ(141)*86.8/ECM**2
9846 PARJ(146)=PARJ(142)*86.8/ECM**2
9847 PARJ(147)=PARJ(143)*86.8/ECM**2
9848 PARJ(148)=PARJ(147)
9849 PARJ(157)=RSUM*RQCD
9850 PARJ(158)=0.
9851 PARJ(159)=0.
9852 XTOT=PARJ(147)
9853 IF(MSTJ(107).LE.0) RETURN
9854
9855C...Virtual cross-section.
9856 XKL=PARJ(135)
9857 XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
9858 ALE=2.*LOG(ECM/UYMASS(11))-1.
9859 SIGV=ALE/3.+2.*LOG(ECM**2/(UYMASS(13)*UYMASS(15)))/3.-4./3.+
9860 &1.526*LOG(ECM**2/0.932)
9861
9862C...Soft and hard radiative cross-section in QED case.
9863 IF(MSTJ(102).LE.1) THEN
9864 SIGV=1.5*ALE-0.5+PARU(1)**2/3.+2.*SIGV
9865 SIGS=ALE*(2.*LOG(XKL)-LOG(1.-XKL)-XKL)
9866 SIGH=ALE*(2.*LOG(XKU/XKL)-LOG((1.-XKU)/(1.-XKL))-(XKU-XKL))
9867
9868C...Soft and hard radiative cross-section in QFD case.
9869 ELSE
9870 SZM=1.-(PARJ(123)/ECM)**2
9871 SZW=PARJ(123)*PARJ(124)/ECM**2
9872 PARJ(161)=-RQQ/RSUM
9873 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
9874 PARJ(163)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM
9875 PARJ(164)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM-
9876 & SZM**2))/(SZW*RSUM)
9877 SIGV=1.5*ALE-0.5+PARU(1)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+
9878 & (SZW*SFW*RQV/RSUM)*PARU(1)*20./9.
9879 SIGS=ALE*(2.*LOG(XKL)+PARJ(161)*LOG(1.-XKL)+PARJ(162)*XKL+
9880 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
9881 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
9882 SIGH=ALE*(2.*LOG(XKU/XKL)+PARJ(161)*LOG((1.-XKU)/(1.-XKL))+
9883 & PARJ(162)*(XKU-XKL)+PARJ(163)*LOG(((XKU-SZM)**2+SZW**2)/
9884 & ((XKL-SZM)**2+SZW**2))+PARJ(164)*(ATAN((XKU-SZM)/SZW)-
9885 & ATAN((XKL-SZM)/SZW)))
9886 ENDIF
9887
9888C...Total cross-section and fraction of hard photon events.
9889 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
9890 PARJ(157)=RSUM*(1.+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
9891 PARJ(144)=PARJ(157)
9892 PARJ(148)=PARJ(144)*86.8/ECM**2
9893 XTOT=PARJ(148)
9894
9895 RETURN
9896 END
9897
9898C*********************************************************************
9899
9900 SUBROUTINE LYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
9901
9902C...Purpose: to generate initial state photon radiation.
9903 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9904 SAVE /LYDAT1/
9905
9906C...Function: cumulative hard photon spectrum in QFD case.
9907 FXK(XX)=2.*LOG(XX)+PARJ(161)*LOG(1.-XX)+PARJ(162)*XX+
9908 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
9909
9910C...Determine whether radiative photon or not.
9911 MK=0
9912 PAK=0.
9913 IF(PARJ(160).LT.RLY(0)) RETURN
9914 MK=1
9915
9916C...Photon energy range. Find photon momentum in QED case.
9917 XKL=PARJ(135)
9918 XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
9919 IF(MSTJ(102).LE.1) THEN
9920 100 XK=1./(1.+(1./XKL-1.)*((1./XKU-1.)/(1./XKL-1.))**RLY(0))
9921 IF(1.+(1.-XK)**2.LT.2.*RLY(0)) GOTO 100
9922
9923C...Ditto in QFD case, by numerical inversion of integrated spectrum.
9924 ELSE
9925 SZM=1.-(PARJ(123)/ECM)**2
9926 SZW=PARJ(123)*PARJ(124)/ECM**2
9927 FXKL=FXK(XKL)
9928 FXKU=FXK(XKU)
9929 FXKD=1E-4*(FXKU-FXKL)
9930 FXKR=FXKL+RLY(0)*(FXKU-FXKL)
9931 NXK=0
9932 110 NXK=NXK+1
9933 XK=0.5*(XKL+XKU)
9934 FXKV=FXK(XK)
9935 IF(FXKV.GT.FXKR) THEN
9936 XKU=XK
9937 FXKU=FXKV
9938 ELSE
9939 XKL=XK
9940 FXKL=FXKV
9941 ENDIF
9942 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
9943 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
9944 ENDIF
9945 PAK=0.5*ECM*XK
9946
9947C...Photon polar and azimuthal angle.
9948 PME=2.*(UYMASS(11)/ECM)**2
9949 120 CTHM=PME*(2./PME)**RLY(0)
9950 IF(1.-(XK**2*CTHM*(1.-0.5*CTHM)+2.*(1.-XK)*PME/MAX(PME,
9951 &CTHM*(1.-0.5*CTHM)))/(1.+(1.-XK)**2).LT.RLY(0)) GOTO 120
9952 CTHE=1.-CTHM
9953 IF(RLY(0).GT.0.5) CTHE=-CTHE
9954 STHE=SQRT(MAX(0.,(CTHM-PME)*(2.-CTHM)))
9955 THEK=UYANGL(CTHE,STHE)
9956 PHIK=PARU(2)*RLY(0)
9957
9958C...Rotation angle for hadronic system.
9959 SGN=1.
9960 IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT.
9961 &RLY(0)) SGN=-1.
9962 ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/
9963 &(2.-XK*(1.-SGN*CTHE)))
9964
9965 RETURN
9966 END
9967
9968C*********************************************************************
9969
9970 SUBROUTINE LYXKFL(KFL,ECM,ECMC,KFLC)
9971
9972C...Purpose: to select flavour for produced qqbar pair.
9973 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9974 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9975 SAVE /LYDAT1/,/LYDAT2/
9976
9977C...Calculate maximum weight in QED or QFD case.
9978 IF(MSTJ(102).LE.1) THEN
9979 RFMAX=4./9.
9980 ELSE
9981 POLL=1.-PARJ(131)*PARJ(132)
9982 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
9983 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
9984 SFI=SFW*(1.-(PARJ(123)/ECMC)**2)
9985 VE=4.*PARU(102)-1.
9986 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
9987 HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
9988 RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARU(102)/3.)*HF1I+
9989 & ((1.-8.*PARU(102)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.*
9990 & (-1.+4.*PARU(102)/3.)*HF1I+((-1.+4.*PARU(102)/3.)**2+1.)*HF1W)
9991 ENDIF
9992
9993C...Choose flavour. Gives charge and velocity.
9994 NTRY=0
9995 100 NTRY=NTRY+1
9996 IF(NTRY.GT.100) THEN
9997 CALL LYERRM(14,'(LYXKFL:) caught in an infinite loop')
9998 KFLC=0
9999 RETURN
10000 ENDIF
10001 KFLC=KFL
10002 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLY(0))
10003 MSTJ(93)=1
10004 PMQ=UYMASS(KFLC)
10005 IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100
10006 QF=KCHG(KFLC,1)/3.
10007 VQ=1.
10008 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2))
10009
10010C...Calculate weight in QED or QFD case.
10011 IF(MSTJ(102).LE.1) THEN
10012 RF=QF**2
10013 RFV=0.5*VQ*(3.-VQ**2)*QF**2
10014 ELSE
10015 VF=SIGN(1.,QF)-4.*QF*PARU(102)
10016 RF=QF**2*POLL-2.*QF*VF*HF1I+(VF**2+1.)*HF1W
10017 RFV=0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+VF**2*HF1W)+
10018 & VQ**3*HF1W
10019 IF(RFV.GT.0.) PARJ(171)=MIN(1.,VQ**3*HF1W/RFV)
10020 ENDIF
10021
10022C...Weighting or new event (radiative photon). Cross-section update.
10023 IF(KFL.LE.0.AND.RF.LT.RLY(0)*RFMAX) GOTO 100
10024 PARJ(158)=PARJ(158)+1.
10025 IF(ECMC.LT.2.*PMQ+PARJ(127).OR.RFV.LT.RLY(0)*RF) KFLC=0
10026 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
10027 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1.
10028 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
10029 PARJ(148)=PARJ(144)*86.8/ECM**2
10030
10031 RETURN
10032 END
10033
10034C*********************************************************************
10035
10036 SUBROUTINE LYXJET(ECM,NJET,CUT)
10037
10038C...Purpose: to select number of jets in matrix element approach.
10039 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10040 SAVE /LYDAT1/
10041 DIMENSION ZHUT(5)
10042
10043C...Relative three-jet rate in Zhu second order parametrization.
10044 DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
10045
10046C...Trivial result for two-jets only, including parton shower.
10047 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
10048 CUT=0.
10049
10050C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
10051 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
10052 CF=4./3.
10053 IF(MSTJ(109).EQ.2) CF=1.
10054 IF(MSTJ(111).EQ.0) THEN
10055 Q2=ECM**2
10056 Q2R=ECM**2
10057 ELSEIF(MSTU(111).EQ.0) THEN
10058 PARJ(169)=MIN(1.,PARJ(129))
10059 Q2=PARJ(169)*ECM**2
10060 PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
10061 & ((33.-2.*MSTU(112))*PARU(111)))))
10062 Q2R=PARJ(168)*ECM**2
10063 ELSE
10064 PARJ(169)=MIN(1.,MAX(PARJ(129),(2.*PARU(112)/ECM)**2))
10065 Q2=PARJ(169)*ECM**2
10066 PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
10067 & (2.*PARU(112)/ECM)**2))
10068 Q2R=PARJ(168)*ECM**2
10069 ENDIF
10070
10071C...alpha_strong for R and R itself.
10072 ALSPI=(3./4.)*CF*UYALPS(Q2R)/PARU(1)
10073 IF(IABS(MSTJ(101)).EQ.1) THEN
10074 RQCD=1.+ALSPI
10075 ELSEIF(MSTJ(109).EQ.0) THEN
10076 RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
10077 IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
10078 & LOG(PARJ(168))*ALSPI**2)
10079 ELSE
10080 RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2
10081 ENDIF
10082
10083C...alpha_strong for jet rate. Initial value for y cut.
10084 ALSPI=(3./4.)*CF*UYALPS(Q2)/PARU(1)
10085 CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2)
10086 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
10087 & CUT=MAX(CUT,EXP(-SQRT(0.75/ALSPI))/2.)
10088 IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
10089
10090C...Parametrization of first order three-jet cross-section.
10091 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN
10092 PARJ(152)=0.
10093 ELSE
10094 PARJ(152)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*LOG(CUT))*
10095 & LOG(CUT/(1.-2.*CUT))+(2.5+1.5*CUT-6.571)*(1.-3.*CUT)+
10096 & 5.833*(1.-3.*CUT)**2-3.894*(1.-3.*CUT)**3+
10097 & 1.342*(1.-3.*CUT)**4)/RQCD
10098 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
10099 & PARJ(152)=0.
10100 ENDIF
10101
10102C...Parametrization of second order three-jet cross-section.
10103 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
10104 & CUT.GE.0.25) THEN
10105 PARJ(153)=0.
10106 ELSEIF(MSTJ(110).LE.1) THEN
10107 CT=LOG(1./CUT-2.)
10108 PARJ(153)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2-
10109 & 0.2661*CT**3+0.01159*CT**4)/RQCD
10110
10111C...Interpolation in second/first order ratio for Zhu parametrization.
10112 ELSEIF(MSTJ(110).EQ.2) THEN
10113 IZA=0
10114 DO 110 IY=1,5
10115 IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
10116 110 CONTINUE
10117 IF(IZA.NE.0) THEN
10118 ZHURAT=ZHUT(IZA)
10119 ELSE
10120 IZ=100.*CUT
10121 ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
10122 ENDIF
10123 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
10124 ENDIF
10125
10126C...Shift in second order three-jet cross-section with optimized Q^2.
10127 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3.
10128 & AND.CUT.LT.0.25) PARJ(153)=PARJ(153)+(33.-2.*MSTU(112))/12.*
10129 & LOG(PARJ(169))*ALSPI*PARJ(152)
10130
10131C...Parametrization of second order four-jet cross-section.
10132 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN
10133 PARJ(154)=0.
10134 ELSE
10135 CT=LOG(1./CUT-5.)
10136 IF(CUT.LE.0.018) THEN
10137 XQQGG=6.349-4.330*CT+0.8304*CT**2
10138 IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(3.035-2.091*CT+
10139 & 0.4059*CT**2)
10140 XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2)
10141 IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
10142 ELSE
10143 XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3
10144 IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(-0.04079+0.1340*CT-
10145 & 0.1326*CT**2+0.04365*CT**3)
10146 XQQQQ=1.25*(0.003661-0.004888*CT-0.001081*CT**2+0.002093*
10147 & CT**3)
10148 IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
10149 ENDIF
10150 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
10151 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
10152 ENDIF
10153
10154C...If negative three-jet rate, change y' optimization parameter.
10155 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0..AND.
10156 & PARJ(169).LT.0.99) THEN
10157 PARJ(169)=MIN(1.,1.2*PARJ(169))
10158 Q2=PARJ(169)*ECM**2
10159 ALSPI=(3./4.)*CF*UYALPS(Q2)/PARU(1)
10160 GOTO 100
10161 ENDIF
10162
10163C...If too high cross-section, use harder cuts, or fail.
10164 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
10165 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499.AND.MSTJ(111).EQ.1.AND.
10166 & PARJ(169).LT.0.99) THEN
10167 PARJ(169)=MIN(1.,1.2*PARJ(169))
10168 Q2=PARJ(169)*ECM**2
10169 ALSPI=(3./4.)*CF*UYALPS(Q2)/PARU(1)
10170 GOTO 100
10171 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN
10172 CALL LYERRM(26,
10173 & '(LYXJET:) no allowed y cut value for Zhu parametrization')
10174 ENDIF
10175 CUT=0.26*(4.*CUT)**(PARJ(152)+PARJ(153)+PARJ(154))**(-1./3.)
10176 IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
10177 GOTO 100
10178 ENDIF
10179
10180C...Scalar gluon (first order only).
10181 ELSE
10182 ALSPI=UYALPS(ECM**2)/PARU(1)
10183 CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI))
10184 PARJ(152)=0.
10185 IF(CUT.LT.0.25) PARJ(152)=(ALSPI/3.)*((1.-2.*CUT)*
10186 & LOG((1.-2.*CUT)/CUT)+0.5*(9.*CUT**2-1.))
10187 PARJ(153)=0.
10188 PARJ(154)=0.
10189 ENDIF
10190
10191C...Select number of jets.
10192 PARJ(150)=CUT
10193 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
10194 NJET=2
10195 ELSEIF(MSTJ(101).LE.0) THEN
10196 NJET=MIN(4,2-MSTJ(101))
10197 ELSE
10198 RNJ=RLY(0)
10199 NJET=2
10200 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
10201 IF(PARJ(154).GT.RNJ) NJET=4
10202 ENDIF
10203
10204 RETURN
10205 END
10206
10207C*********************************************************************
10208
10209 SUBROUTINE LYX3JT(NJET,CUT,KFL,ECM,X1,X2)
10210
10211C...Purpose: to select the kinematical variables of three-jet events.
10212 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10213 SAVE /LYDAT1/
10214 DIMENSION ZHUP(5,12)
10215
10216C...Coefficients of Zhu second order parametrization.
10217 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
10218 & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90,
10219 & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537,
10220 & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855,
10221 & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095,
10222 & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806,
10223 & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062,
10224 & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19,
10225 & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439,
10226 & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99,
10227 & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/
10228
10229C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
10230 DILOG(X)=X+X**2/4.+X**3/9.+X**4/16.+X**5/25.+X**6/36.+X**7/49.
10231
10232C...Event type. Mass effect factors and other common constants.
10233 MSTJ(120)=2
10234 MSTJ(121)=0
10235 PMQ=UYMASS(KFL)
10236 QME=(2.*PMQ/ECM)**2
10237 IF(MSTJ(109).NE.1) THEN
10238 CUTL=LOG(CUT)
10239 CUTD=LOG(1./CUT-2.)
10240 IF(MSTJ(109).EQ.0) THEN
10241 CF=4./3.
10242 CN=3.
10243 TR=2.
10244 WTMX=MIN(20.,37.-6.*CUTD)
10245 IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT)
10246 ELSE
10247 CF=1.
10248 CN=0.
10249 TR=12.
10250 WTMX=0.
10251 ENDIF
10252
10253C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
10254 ALS2PI=PARU(118)/PARU(2)
10255 WTOPT=0.
10256 IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))*
10257 & ALS2PI
10258 WTMAX=MAX(0.,1.+WTOPT+ALS2PI*WTMX)
10259
10260C...Choose three-jet events in allowed region.
10261 100 NJET=3
10262 110 Y13L=CUTL+CUTD*RLY(0)
10263 Y23L=CUTL+CUTD*RLY(0)
10264 Y13=EXP(Y13L)
10265 Y23=EXP(Y23L)
10266 Y12=1.-Y13-Y23
10267 IF(Y12.LE.CUT) GOTO 110
10268 IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLY(0)) GOTO 110
10269
10270C...Second order corrections.
10271 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
10272 Y12L=LOG(Y12)
10273 Y13M=LOG(1.-Y13)
10274 Y23M=LOG(1.-Y23)
10275 Y12M=LOG(1.-Y12)
10276 IF(Y13.LE.0.5) Y13I=DILOG(Y13)
10277 IF(Y13.GE.0.5) Y13I=1.644934-Y13L*Y13M-DILOG(1.-Y13)
10278 IF(Y23.LE.0.5) Y23I=DILOG(Y23)
10279 IF(Y23.GE.0.5) Y23I=1.644934-Y23L*Y23M-DILOG(1.-Y23)
10280 IF(Y12.LE.0.5) Y12I=DILOG(Y12)
10281 IF(Y12.GE.0.5) Y12I=1.644934-Y12L*Y12M-DILOG(1.-Y12)
10282 WT1=(Y13**2+Y23**2+2.*Y12)/(Y13*Y23)
10283 WT2=CF*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+
10284 & 2.*(2.*CUTL-Y12L)*CUT/Y12)+
10285 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-11.*CUTL/6.+
10286 & 67./18.+1.644934-(2.*CUTL-Y12L)*CUT/Y12+(2.*CUTL-Y13L)*
10287 & CUT/Y13+(2.*CUTL-Y23L)*CUT/Y23)+
10288 & TR*(2.*CUTL/3.-10./9.)+
10289 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
10290 & Y13L*(4.*Y12**2+2.*Y12*Y13+4.*Y12*Y23+Y13*Y23)/(Y12+Y23)**2+
10291 & Y23L*(4.*Y12**2+2.*Y12*Y23+4.*Y12*Y13+Y13*Y23)/(Y12+Y13)**2)/
10292 & WT1+
10293 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+
10294 & (CN-2.*CF)*((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
10295 & Y23M+1.644934-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
10296 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934-Y12I-Y13I)/
10297 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
10298 & 2.*Y12L*Y12**2/(Y13+Y23)**2-4.*Y12L*Y12/(Y13+Y23))/WT1-
10299 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I)
10300 IF(1.+WTOPT+ALS2PI*WT2.LE.0.) MSTJ(121)=1
10301 IF(1.+WTOPT+ALS2PI*WT2.LE.WTMAX*RLY(0)) GOTO 110
10302 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1.+WTOPT+ALS2PI*WT2)
10303
10304 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
10305C...Second order corrections; Zhu parametrization of ERT.
10306 ZX=(Y23-Y13)**2
10307 ZY=1.-Y12
10308 IZA=0
10309 DO 120 IY=1,5
10310 IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
10311 120 CONTINUE
10312 IF(IZA.NE.0) THEN
10313 IZ=IZA
10314 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
10315 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
10316 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
10317 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
10318 ELSE
10319 IZ=100.*CUT
10320 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
10321 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
10322 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
10323 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
10324 IZ=IZ+1
10325 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
10326 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
10327 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
10328 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
10329 WT2=WTL+(WTU-WTL)*(100.*CUT+1.-IZ)
10330 ENDIF
10331 IF(1.+WTOPT+2.*ALS2PI*WT2.LE.0.) MSTJ(121)=1
10332 IF(1.+WTOPT+2.*ALS2PI*WT2.LE.WTMAX*RLY(0)) GOTO 110
10333 PARJ(156)=(WTOPT+2.*ALS2PI*WT2)/(1.+WTOPT+2.*ALS2PI*WT2)
10334 ENDIF
10335
10336C...Impose mass cuts (gives two jets). For fixed jet number new try.
10337 X1=1.-Y23
10338 X2=1.-Y13
10339 X3=1.-Y12
10340 IF(4.*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
10341 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
10342 & 0.5*QME**2+(0.5*QME+0.25*QME**2)*((1.-X2)/(1.-X1)+
10343 & (1.-X1)/(1.-X2)).GT.(X1**2+X2**2)*RLY(0)) NJET=2
10344 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
10345
10346C...Scalar gluon model (first order only, no mass effects).
10347 ELSE
10348 130 NJET=3
10349 140 X3=SQRT(4.*CUT**2+RLY(0)*((1.-CUT)**2-4.*CUT**2))
10350 IF(LOG((X3-CUT)/CUT).LE.RLY(0)*LOG((1.-2.*CUT)/CUT)) GOTO 140
10351 YD=SIGN(2.*CUT*((X3-CUT)/CUT)**RLY(0)-X3,RLY(0)-0.5)
10352 X1=1.-0.5*(X3+YD)
10353 X2=1.-0.5*(X3-YD)
10354 IF(4.*(1.-X1)*(1.-X2)*(1.-X3)/X3**2.LE.QME) NJET=2
10355 IF(MSTJ(102).GE.2) THEN
10356 IF(X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*PARJ(171).LT.
10357 & X3**2*RLY(0)) NJET=2
10358 ENDIF
10359 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
10360 ENDIF
10361
10362 RETURN
10363 END
10364
10365C*********************************************************************
10366
10367 SUBROUTINE LYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
10368
10369C...Purpose: to select the kinematical variables of four-jet events.
10370 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10371 SAVE /LYDAT1/
10372 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
10373
10374C...Common constants. Colour factors for QCD and Abelian gluon theory.
10375 PMQ=UYMASS(KFL)
10376 QME=(2.*PMQ/ECM)**2
10377 CT=LOG(1./CUT-5.)
10378 IF(MSTJ(109).EQ.0) THEN
10379 CF=4./3.
10380 CN=3.
10381 TR=2.5
10382 ELSE
10383 CF=1.
10384 CN=0.
10385 TR=15.
10386 ENDIF
10387
10388C...Choice of process (qqbargg or qqbarqqbar).
10389 100 NJET=4
10390 IT=1
10391 IF(PARJ(155).GT.RLY(0)) IT=2
10392 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
10393 IF(IT.EQ.1) WTMX=0.7/CUT**2
10394 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6/CUT**2
10395 IF(IT.EQ.2) WTMX=0.1125*CF*TR/CUT**2
10396 ID=1
10397
10398C...Sample the five kinematical variables (for qqgg preweighted in y34).
10399 110 Y134=3.*CUT+(1.-6.*CUT)*RLY(0)
10400 Y234=3.*CUT+(1.-6.*CUT)*RLY(0)
10401 IF(IT.EQ.1) Y34=(1.-5.*CUT)*EXP(-CT*RLY(0))
10402 IF(IT.EQ.2) Y34=CUT+(1.-6.*CUT)*RLY(0)
10403 IF(Y34.LE.Y134+Y234-1..OR.Y34.GE.Y134*Y234) GOTO 110
10404 VT=RLY(0)
10405 CP=COS(PARU(1)*RLY(0))
10406 Y14=(Y134-Y34)*VT
10407 Y13=Y134-Y14-Y34
10408 VB=Y34*(1.-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
10409 Y24=0.5*(Y234-Y34)*(1.-4.*SQRT(MAX(0.,VT*(1.-VT)*VB*(1.-VB)))*
10410 &CP-(1.-2.*VT)*(1.-2.*VB))
10411 Y23=Y234-Y34-Y24
10412 Y12=1.-Y134-Y23-Y24
10413 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
10414 Y123=Y12+Y13+Y23
10415 Y124=Y12+Y14+Y24
10416
10417C...Calculate matrix elements for qqgg or qqqq process.
10418 IC=0
10419 WTTOT=0.
10420 120 IC=IC+1
10421 IF(IT.EQ.1) THEN
10422 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3.*Y12*Y23*Y34+
10423 & 3.*Y12*Y14*Y34+4.*Y12**2*Y34-Y13*Y23*Y24+2.*Y12*Y23*Y24-
10424 & Y13*Y14*Y24-2.*Y12*Y13*Y24+2.*Y12**2*Y24+Y14*Y23**2+2.*Y12*
10425 & Y23**2+Y14**2*Y23+4.*Y12*Y14*Y23+4.*Y12**2*Y23+2.*Y12*Y14**2+
10426 & 2.*Y12*Y13*Y14+4.*Y12**2*Y14+2.*Y12**2*Y13+2.*Y12**3)/(2.*Y13*
10427 & Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-Y14*Y23+Y12*Y13)/(Y13*
10428 & Y134**2)+2.*Y23*(1.-Y13)/(Y13*Y134*Y24)+Y34/(2.*Y13*Y24)
10429 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2.*Y12*
10430 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1.+Y34)*Y124/(Y134*Y234*Y14*
10431 & Y24)-(2.*Y13*Y24+Y14**2+Y13*Y23+2.*Y12*Y13)/(Y13*Y134*Y14)+
10432 & Y12*Y123*Y124/(2.*Y13*Y14*Y23*Y24)
10433 WTC(IC)=-(5.*Y12*Y34**2+2.*Y12*Y24*Y34+2.*Y12*Y23*Y34+2.*Y12*
10434 & Y14*Y34+2.*Y12*Y13*Y34+4.*Y12**2*Y34-Y13*Y24**2+Y14*Y23*Y24+
10435 & Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-3.*Y12*Y13*Y24-
10436 & Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-3.*Y12*Y14*Y23-Y12*Y13*Y23)/
10437 & (4.*Y134*Y234*Y34**2)+(3.*Y12*Y34**2-3.*Y13*Y24*Y34+3.*Y12*Y24*
10438 & Y34+3.*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6.*Y12*Y14*Y34+2.*Y12*
10439 & Y13*Y34-2.*Y12**2*Y34+Y14*Y23*Y24-3.*Y13*Y23*Y24-2.*Y13*Y14*
10440 & Y24+4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+3.*Y14*Y23**2+2.*Y14**2*Y23+
10441 & 2.*Y14**2*Y12+2.*Y12**2*Y14+6.*Y12*Y14*Y23-2.*Y12*Y13**2-
10442 & 2.*Y12**2*Y13)/(4.*Y13*Y134*Y234*Y34)
10443 WTC(IC)=WTC(IC)+(2.*Y12*Y34**2-2.*Y13*Y24*Y34+Y12*Y24*Y34+
10444 & 4.*Y13*Y23*Y34+4.*Y12*Y14*Y34+2.*Y12*Y13*Y34+2.*Y12**2*Y34-
10445 & Y13*Y24**2+3.*Y14*Y23*Y24+4.*Y13*Y23*Y24-2.*Y13*Y14*Y24+
10446 & 4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+2.*Y14*Y23**2+4.*Y13*Y23**2+
10447 & 2.*Y13*Y14*Y23+2.*Y12*Y14*Y23+4.*Y12*Y13*Y23+2.*Y12*Y14**2+4.*
10448 & Y12**2*Y13+4.*Y12*Y13*Y14+2.*Y12**2*Y14)/(4.*Y13*Y134*Y24*Y34)-
10449 & (Y12*Y34**2-2.*Y14*Y24*Y34-2.*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*
10450 & Y34+Y12*Y14*Y34+2.*Y12*Y13*Y34-2.*Y14**2*Y24-4.*Y13*Y14*Y24-
10451 & 4.*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-Y12*Y13**2)/
10452 & (2.*Y13*Y34*Y134**2)+(Y12*Y34**2-4.*Y14*Y24*Y34-2.*Y13*Y24*Y34-
10453 & 2.*Y14*Y23*Y34-4.*Y13*Y23*Y34-4.*Y12*Y14*Y34-4.*Y12*Y13*Y34-
10454 & 2.*Y13*Y14*Y24+2.*Y13**2*Y24+2.*Y14**2*Y23-2.*Y13*Y14*Y23-
10455 & Y12*Y14**2-6.*Y12*Y13*Y14-Y12*Y13**2)/(4.*Y34**2*Y134**2)
10456 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5*CN)*WTB(IC)+CN*WTC(IC))/
10457 & 8.
10458 ELSE
10459 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2.*Y12*
10460 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
10461 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
10462 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
10463 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
10464 & Y13*Y14*Y24+2.*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
10465 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
10466 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
10467 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
10468 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
10469 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
10470 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
10471 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
10472 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
10473 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
10474 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
10475 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
10476 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5*CN)*WTE(IC))/16.
10477 ENDIF
10478
10479C...Permutations of momenta in matrix element. Weighting.
10480 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
10481 YSAV=Y13
10482 Y13=Y14
10483 Y14=YSAV
10484 YSAV=Y23
10485 Y23=Y24
10486 Y24=YSAV
10487 YSAV=Y123
10488 Y123=Y124
10489 Y124=YSAV
10490 ENDIF
10491 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
10492 YSAV=Y13
10493 Y13=Y23
10494 Y23=YSAV
10495 YSAV=Y14
10496 Y14=Y24
10497 Y24=YSAV
10498 YSAV=Y134
10499 Y134=Y234
10500 Y234=YSAV
10501 ENDIF
10502 IF(IC.LE.3) GOTO 120
10503 IF(ID.EQ.1.AND.WTTOT.LT.RLY(0)*WTMX) GOTO 110
10504 IC=5
10505
10506C...qqgg events: string configuration and event type.
10507 IF(IT.EQ.1) THEN
10508 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
10509 PARJ(156)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+
10510 & WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT)
10511 IF(WTA(2)+WTA(4)+2.*(WTC(2)+WTC(4)).GT.RLY(0)*(WTA(1)+WTA(2)+
10512 & WTA(3)+WTA(4)+2.*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
10513 IF(ID.EQ.2) GOTO 130
10514 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
10515 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8.*WTTOT)
10516 IF(WTA(2)+WTA(4).GT.RLY(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
10517 IF(ID.EQ.2) GOTO 130
10518 ENDIF
10519 MSTJ(120)=3
10520 IF(MSTJ(109).EQ.0.AND.0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT.
10521 & RLY(0)*WTTOT) MSTJ(120)=4
10522 KFLN=21
10523
10524C...Mass cuts. Kinematical variables out.
10525 IF(Y12.LE.CUT+QME) NJET=2
10526 IF(NJET.EQ.2) GOTO 150
10527 Q12=0.5*(1.-SQRT(1.-QME/Y12))
10528 X1=1.-(1.-Q12)*Y234-Q12*Y134
10529 X4=1.-(1.-Q12)*Y134-Q12*Y234
10530 X2=1.-Y124
10531 X12=(1.-Q12)*Y13+Q12*Y23
10532 X14=Y12-0.5*QME
10533 IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLY(0)) NJET=2
10534
10535C...qqbarqqbar events: string configuration, choose new flavour.
10536 ELSE
10537 IF(ID.EQ.1) THEN
10538 WTR=RLY(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
10539 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
10540 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
10541 IF(WTR.LT.WTD(4)) ID=4
10542 IF(ID.GE.2) GOTO 130
10543 ENDIF
10544 MSTJ(120)=5
10545 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16.*WTTOT)
10546 140 KFLN=1+INT(5.*RLY(0))
10547 IF(KFLN.NE.KFL.AND.0.2*PARJ(156).LE.RLY(0)) GOTO 140
10548 IF(KFLN.EQ.KFL.AND.1.-0.8*PARJ(156).LE.RLY(0)) GOTO 140
10549 IF(KFLN.GT.MSTJ(104)) NJET=2
10550 PMQN=UYMASS(KFLN)
10551 QMEN=(2.*PMQN/ECM)**2
10552
10553C...Mass cuts. Kinematical variables out.
10554 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1*QMEN) NJET=2
10555 IF(NJET.EQ.2) GOTO 150
10556 Q24=0.5*(1.-SQRT(1.-QME/Y24))
10557 Q13=0.5*(1.-SQRT(1.-QMEN/Y13))
10558 X1=1.-(1.-Q24)*Y123-Q24*Y134
10559 X4=1.-(1.-Q24)*Y134-Q24*Y123
10560 X2=1.-(1.-Q13)*Y234-Q13*Y124
10561 X12=(1.-Q24)*((1.-Q13)*Y14+Q13*Y34)+Q24*((1.-Q13)*Y12+Q13*Y23)
10562 X14=Y24-0.5*QME
10563 X34=(1.-Q24)*((1.-Q13)*Y23+Q13*Y12)+Q24*((1.-Q13)*Y34+Q13*Y14)
10564 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
10565 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
10566 IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLY(0)) NJET=2
10567 ENDIF
10568 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
10569
10570 RETURN
10571 END
10572
10573C*********************************************************************
10574
10575 SUBROUTINE LYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
10576
10577C...Purpose: to give the angular orientation of events.
10578 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
10579 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10580 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10581 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
10582
10583C...Charge. Factors depending on polarization for QED case.
10584 QF=KCHG(KFL,1)/3.
10585 POLL=1.-PARJ(131)*PARJ(132)
10586 POLD=PARJ(132)-PARJ(131)
10587 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
10588 HF1=POLL
10589 HF2=0.
10590 HF3=PARJ(133)**2
10591 HF4=0.
10592
10593C...Factors depending on flavour, energy and polarization for QFD case.
10594 ELSE
10595 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
10596 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
10597 SFI=SFW*(1.-(PARJ(123)/ECM)**2)
10598 AE=-1.
10599 VE=4.*PARU(102)-1.
10600 AF=SIGN(1.,QF)
10601 VF=AF-4.*QF*PARU(102)
10602 HF1=QF**2*POLL-2.*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
10603 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2.*VE*AE*POLD)
10604 HF2=-2.*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2.*VF*AF*SFW*SFF**2*
10605 & (2.*VE*AE*POLL-(VE**2+AE**2)*POLD)
10606 HF3=PARJ(133)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
10607 & SFW*SFF**2*(VE**2-AE**2))
10608 HF4=-PARJ(133)**2*2.*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
10609 & SFF*AE
10610 ENDIF
10611
10612C...Mass factor. Differential cross-sections for two-jet events.
10613 SQ2=SQRT(2.)
10614 QME=0.
10615 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
10616 &MSTJ(109).NE.1) QME=(2.*UYMASS(KFL)/ECM)**2
10617 IF(NJET.EQ.2) THEN
10618 SIGU=4.*SQRT(1.-QME)
10619 SIGL=2.*QME*SQRT(1.-QME)
10620 SIGT=0.
10621 SIGI=0.
10622 SIGA=0.
10623 SIGP=4.
10624
10625C...Kinematical variables. Reduce four-jet event to three-jet one.
10626 ELSE
10627 IF(NJET.EQ.3) THEN
10628 X1=2.*P(NC+1,4)/ECM
10629 X2=2.*P(NC+3,4)/ECM
10630 ELSE
10631 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
10632 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
10633 X1=2.*P(NC+1,4)/ECMR
10634 X2=2.*P(NC+4,4)/ECMR
10635 ENDIF
10636
10637C...Differential cross-sections for three-jet (or reduced four-jet).
10638 XQ=(1.-X1)/(1.-X2)
10639 CT12=(X1*X2-2.*X1-2.*X2+2.+QME)/SQRT((X1**2-QME)*(X2**2-QME))
10640 ST12=SQRT(1.-CT12**2)
10641 IF(MSTJ(109).NE.1) THEN
10642 SIGU=2.*X1**2+X2**2*(1.+CT12**2)-QME*(3.+CT12**2-X1-X2)-
10643 & QME*X1/XQ+0.5*QME*((X2**2-QME)*ST12**2-2.*X2)*XQ
10644 SIGL=(X2*ST12)**2-QME*(3.-CT12**2-2.5*(X1+X2)+X1*X2+QME)+
10645 & 0.5*QME*(X1**2-X1-QME)/XQ+0.5*QME*((X2**2-QME)*CT12**2-X2)*XQ
10646 SIGT=0.5*(X2**2-QME-0.5*QME*(X2**2-QME)/XQ)*ST12**2
10647 SIGI=((1.-0.5*QME*XQ)*(X2**2-QME)*ST12*CT12+QME*(1.-X1-X2+
10648 & 0.5*X1*X2+0.5*QME)*ST12/CT12)/SQ2
10649 SIGA=X2**2*ST12/SQ2
10650 SIGP=2.*(X1**2-X2**2*CT12)
10651
10652C...Differential cross-sect for scalar gluons (no mass effects).
10653 ELSE
10654 X3=2.-X1-X2
10655 XT=X2*ST12
10656 CT13=SQRT(MAX(0.,1.-(XT/X3)**2))
10657 SIGU=(1.-PARJ(171))*(X3**2-0.5*XT**2)+
10658 & PARJ(171)*(X3**2-0.5*XT**2-4.*(1.-X1)*(1.-X2)**2/X1)
10659 SIGL=(1.-PARJ(171))*0.5*XT**2+
10660 & PARJ(171)*0.5*(1.-X1)**2*XT**2
10661 SIGT=(1.-PARJ(171))*0.25*XT**2+
10662 & PARJ(171)*0.25*XT**2*(1.-2.*X1)
10663 SIGI=-(0.5/SQ2)*((1.-PARJ(171))*XT*X3*CT13+
10664 & PARJ(171)*XT*((1.-2.*X1)*X3*CT13-X1*(X1-X2)))
10665 SIGA=(0.25/SQ2)*XT*(2.*(1.-X1)-X1*X3)
10666 SIGP=X3**2-2.*(1.-X1)*(1.-X2)/X1
10667 ENDIF
10668 ENDIF
10669
10670C...Upper bounds for differential cross-section.
10671 HF1A=ABS(HF1)
10672 HF2A=ABS(HF2)
10673 HF3A=ABS(HF3)
10674 HF4A=ABS(HF4)
10675 SIGMAX=(2.*HF1A+HF3A+HF4A)*ABS(SIGU)+2.*(HF1A+HF3A+HF4A)*
10676 &ABS(SIGL)+2.*(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGT)+2.*SQ2*
10677 &(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGI)+4.*SQ2*HF2A*ABS(SIGA)+
10678 &2.*HF2A*ABS(SIGP)
10679
10680C...Generate angular orientation according to differential cross-sect.
10681 100 CHI=PARU(2)*RLY(0)
10682 CTHE=2.*RLY(0)-1.
10683 PHI=PARU(2)*RLY(0)
10684 CCHI=COS(CHI)
10685 SCHI=SIN(CHI)
10686 C2CHI=COS(2.*CHI)
10687 S2CHI=SIN(2.*CHI)
10688 THE=ACOS(CTHE)
10689 STHE=SIN(THE)
10690 C2PHI=COS(2.*(PHI-PARJ(134)))
10691 S2PHI=SIN(2.*(PHI-PARJ(134)))
10692 SIG=((1.+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
10693 &2.*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
10694 &2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*C2CHI*C2PHI-2.*CTHE*S2CHI*
10695 &S2PHI)*HF3-((1.+CTHE**2)*C2CHI*S2PHI+2.*CTHE*S2CHI*C2PHI)*HF4)*
10696 &SIGT-2.*SQ2*(2.*STHE*CTHE*CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-
10697 &SCHI*S2PHI)*HF3+2.*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
10698 &4.*SQ2*STHE*CCHI*HF2*SIGA+2.*CTHE*HF2*SIGP
10699 IF(SIG.LT.SIGMAX*RLY(0)) GOTO 100
10700
10701 RETURN
10702 END
10703
10704C*********************************************************************
10705
10706 SUBROUTINE LYONIA(KFL,ECM)
10707
10708C...Purpose: to generate Upsilon and toponium decays into three
10709C...gluons or two gluons and a photon.
10710 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
10711 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10712 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10713 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
10714
10715C...Printout. Check input parameters.
10716 IF(MSTU(12).GE.1) CALL LYLIST(0)
10717 IF(KFL.LT.0.OR.KFL.GT.8) THEN
10718 CALL LYERRM(16,'(LYONIA:) called with unknown flavour code')
10719 IF(MSTU(21).GE.1) RETURN
10720 ENDIF
10721 IF(ECM.LT.PARJ(127)+2.02*PARF(101)) THEN
10722 CALL LYERRM(16,'(LYONIA:) called with too small CM energy')
10723 IF(MSTU(21).GE.1) RETURN
10724 ENDIF
10725
10726C...Initial e+e- and onium state (optional).
10727 NC=0
10728 IF(MSTJ(115).GE.2) THEN
10729 NC=NC+2
10730 CALL LY1ENT(NC-1,11,0.5*ECM,0.,0.)
10731 K(NC-1,1)=21
10732 CALL LY1ENT(NC,-11,0.5*ECM,PARU(1),0.)
10733 K(NC,1)=21
10734 ENDIF
10735 KFLC=IABS(KFL)
10736 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
10737 NC=NC+1
10738 KF=110*KFLC+3
10739 MSTU10=MSTU(10)
10740 MSTU(10)=1
10741 P(NC,5)=ECM
10742 CALL LY1ENT(NC,KF,ECM,0.,0.)
10743 K(NC,1)=21
10744 K(NC,3)=1
10745 MSTU(10)=MSTU10
10746 ENDIF
10747
10748C...Choose x1 and x2 according to matrix element.
10749 NTRY=0
10750 100 X1=RLY(0)
10751 X2=RLY(0)
10752 X3=2.-X1-X2
10753 IF(X3.GE.1..OR.((1.-X1)/(X2*X3))**2+((1.-X2)/(X1*X3))**2+
10754 &((1.-X3)/(X1*X2))**2.LE.2.*RLY(0)) GOTO 100
10755 NTRY=NTRY+1
10756 NJET=3
10757 IF(MSTJ(101).LE.4) CALL LY3ENT(NC+1,21,21,21,ECM,X1,X3)
10758 IF(MSTJ(101).GE.5) CALL LY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
10759
10760C...Photon-gluon-gluon events. Small system modifications. Jet origin.
10761 MSTU(111)=MSTJ(108)
10762 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
10763 &MSTU(111)=1
10764 PARU(112)=PARJ(121)
10765 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
10766 QF=0.
10767 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3.
10768 RGAM=7.2*QF**2*PARU(101)/UYALPS(ECM**2)
10769 MK=0
10770 ECMC=ECM
10771 IF(RLY(0).GT.RGAM/(1.+RGAM)) THEN
10772 IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
10773 & NJET=2
10774 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL LY2ENT(NC+1,21,21,ECM)
10775 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL LY2ENT(-(NC+1),21,21,ECM)
10776 ELSE
10777 MK=1
10778 ECMC=SQRT(1.-X1)*ECM
10779 IF(ECMC.LT.2.*PARJ(127)) GOTO 100
10780 K(NC+1,1)=1
10781 K(NC+1,2)=22
10782 K(NC+1,4)=0
10783 K(NC+1,5)=0
10784 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
10785 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
10786 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
10787 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
10788 NJET=2
10789 IF(ECMC.LT.4.*PARJ(127)) THEN
10790 MSTU10=MSTU(10)
10791 MSTU(10)=1
10792 P(NC+2,5)=ECMC
10793 CALL LY1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.)
10794 MSTU(10)=MSTU10
10795 NJET=0
10796 ENDIF
10797 ENDIF
10798 DO 110 IP=NC+1,N
10799 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
10800 110 CONTINUE
10801
10802C...Differential cross-sections. Upper limit for cross-section.
10803 IF(MSTJ(106).EQ.1) THEN
10804 SQ2=SQRT(2.)
10805 HF1=1.-PARJ(131)*PARJ(132)
10806 HF3=PARJ(133)**2
10807 CT13=(X1*X3-2.*X1-2.*X3+2.)/(X1*X3)
10808 ST13=SQRT(1.-CT13**2)
10809 SIGL=0.5*X3**2*((1.-X2)**2+(1.-X3)**2)*ST13**2
10810 SIGU=(X1*(1.-X1))**2+(X2*(1.-X2))**2+(X3*(1.-X3))**2-SIGL
10811 SIGT=0.5*SIGL
10812 SIGI=(SIGL*CT13/ST13+0.5*X1*X3*(1.-X2)**2*ST13)/SQ2
10813 SIGMAX=(2.*HF1+HF3)*ABS(SIGU)+2.*(HF1+HF3)*ABS(SIGL)+2.*(HF1+
10814 & 2.*HF3)*ABS(SIGT)+2.*SQ2*(HF1+2.*HF3)*ABS(SIGI)
10815
10816C...Angular orientation of event.
10817 120 CHI=PARU(2)*RLY(0)
10818 CTHE=2.*RLY(0)-1.
10819 PHI=PARU(2)*RLY(0)
10820 CCHI=COS(CHI)
10821 SCHI=SIN(CHI)
10822 C2CHI=COS(2.*CHI)
10823 S2CHI=SIN(2.*CHI)
10824 THE=ACOS(CTHE)
10825 STHE=SIN(THE)
10826 C2PHI=COS(2.*(PHI-PARJ(134)))
10827 S2PHI=SIN(2.*(PHI-PARJ(134)))
10828 SIG=((1.+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2.*(STHE**2*HF1-
10829 & STHE**2*C2PHI*HF3)*SIGL+2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*
10830 & C2CHI*C2PHI-2.*CTHE*S2CHI*S2PHI)*HF3)*SIGT-2.*SQ2*(2.*STHE*CTHE*
10831 & CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
10832 IF(SIG.LT.SIGMAX*RLY(0)) GOTO 120
10833 CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
10834 CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
10835 ENDIF
10836
10837C...Generate parton shower. Rearrange along strings and check.
10838 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
10839 CALL LYSHOW(NC+MK+1,-NJET,ECMC)
10840 MSTJ14=MSTJ(14)
10841 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
10842 IF(MSTJ(105).GE.0) MSTU(28)=0
10843 CALL LYPREP(0)
10844 MSTJ(14)=MSTJ14
10845 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
10846 ENDIF
10847
10848C...Generate fragmentation. Information for LYTABU:
10849 IF(MSTJ(105).EQ.1) CALL LYEXEC
10850 MSTU(161)=110*KFLC+3
10851 MSTU(162)=0
10852
10853 RETURN
10854 END
10855
10856C*********************************************************************
10857
10858 SUBROUTINE LYHEPC(MCONV)
10859
10860C...Purpose: to convert JETSET event record contents to or from
10861C...the standard event record commonblock.
10862C...Note that HEPEVT is in double precision according to LEP 2 standard.
10863C...W. H. Bell --- Changed HEPEVT common block to match EvtGen.
10864 PARAMETER (NMXHEP=4000)
10865 COMMON/XHEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
10866 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
10867 REAL*8 PHEP,VHEP
10868 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
10869 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10870 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10871 SAVE /XHEPEVT/
10872 SAVE /LYJETS/,/LYDAT1/,/LYDAT2/
10873
10874C...Conversion from JETSET to standard, the easy part.
10875 IF(MCONV.EQ.1) THEN
10876 NEVHEP=0
10877 IF(N.GT.NMXHEP) CALL LYERRM(8,
10878 & '(LYHEPC:) no more space in /HEPEVT/')
10879 NHEP=MIN(N,NMXHEP)
10880 DO 140 I=1,NHEP
10881 ISTHEP(I)=0
10882 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
10883 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
10884 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
10885 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
10886 IDHEP(I)=K(I,2)
10887 JMOHEP(1,I)=K(I,3)
10888 JMOHEP(2,I)=0
10889 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
10890 JDAHEP(1,I)=K(I,4)
10891 JDAHEP(2,I)=K(I,5)
10892 ELSE
10893 JDAHEP(1,I)=0
10894 JDAHEP(2,I)=0
10895 ENDIF
10896 DO 100 J=1,5
10897 PHEP(J,I)=P(I,J)
10898 100 CONTINUE
10899 DO 110 J=1,4
10900 VHEP(J,I)=V(I,J)
10901 110 CONTINUE
10902
10903C...Check if new event (from pileup).
10904 IF(I.EQ.1) THEN
10905 INEW=1
10906 ELSE
10907 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
10908 ENDIF
10909
10910C...Fill in missing mother information.
10911 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
10912 IMO1=I-2
10913 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
10914 & IMO1=IMO1-1
10915 JMOHEP(1,I)=IMO1
10916 JMOHEP(2,I)=IMO1+1
10917 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
10918 I1=K(I,3)-1
10919 120 I1=I1+1
10920 IF(I1.GE.I) CALL LYERRM(8,
10921 & '(LYHEPC:) translation of inconsistent event history')
10922 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
10923 KC=LYCOMP(K(I1,2))
10924 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
10925 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
10926 JMOHEP(2,I)=I1
10927 ELSEIF(K(I,2).EQ.94) THEN
10928 NJET=2
10929 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
10930 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
10931 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
10932 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
10933 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
10934 ENDIF
10935
10936C...Fill in missing daughter information.
10937 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
10938 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
10939 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
10940 JDAHEP(1,I2)=I
10941 130 CONTINUE
10942 ENDIF
10943 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
10944 I1=JMOHEP(1,I)
10945 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
10946 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
10947 IF(JDAHEP(1,I1).EQ.0) THEN
10948 JDAHEP(1,I1)=I
10949 ELSE
10950 JDAHEP(2,I1)=I
10951 ENDIF
10952 140 CONTINUE
10953 DO 150 I=1,NHEP
10954 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
10955 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
10956 150 CONTINUE
10957
10958C...Conversion from standard to JETSET, the easy part.
10959 ELSE
10960 IF(NHEP.GT.MSTU(4)) CALL LYERRM(8,
10961 & '(LYHEPC:) no more space in /LYJETS/')
10962 N=MIN(NHEP,MSTU(4))
10963 NKQ=0
10964 KQSUM=0
10965 DO 180 I=1,N
10966 K(I,1)=0
10967 IF(ISTHEP(I).EQ.1) K(I,1)=1
10968 IF(ISTHEP(I).EQ.2) K(I,1)=11
10969 IF(ISTHEP(I).EQ.3) K(I,1)=21
10970 K(I,2)=IDHEP(I)
10971 K(I,3)=JMOHEP(1,I)
10972 K(I,4)=JDAHEP(1,I)
10973 K(I,5)=JDAHEP(2,I)
10974 DO 160 J=1,5
10975 P(I,J)=PHEP(J,I)
10976 160 CONTINUE
10977 DO 170 J=1,4
10978 V(I,J)=VHEP(J,I)
10979 170 CONTINUE
10980 V(I,5)=0.
10981 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
10982 I1=JDAHEP(1,I)
10983 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
10984 & PHEP(5,I)/PHEP(4,I)
10985 ENDIF
10986
10987C...Fill in missing information on colour connection in jet systems.
10988 IF(ISTHEP(I).EQ.1) THEN
10989 KC=LYCOMP(K(I,2))
10990 KQ=0
10991 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
10992 IF(KQ.NE.0) NKQ=NKQ+1
10993 IF(KQ.NE.2) KQSUM=KQSUM+KQ
10994 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
10995 K(I,1)=2
10996 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
10997 IF(K(I+1,2).EQ.21) K(I,1)=2
10998 ENDIF
10999 ENDIF
11000 180 CONTINUE
11001 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LYERRM(8,
11002 & '(LYHEPC:) input parton configuration not colour singlet')
11003 ENDIF
11004
11005 END
11006
11007C*********************************************************************
11008
11009 SUBROUTINE LYTEST(MTEST)
11010
11011C...Purpose: to provide a simple program (disguised as subroutine) to
11012C...run at installation as a check that the program works as intended.
11013 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
11014 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11015 SAVE /LYJETS/,/LYDAT1/
11016 DIMENSION PSUM(5),PINI(6),PFIN(6)
11017
11018C...Loop over events to be generated.
11019 IF(MTEST.GE.1) CALL LYTABU(20)
11020 NERR=0
11021 DO 180 IEV=1,600
11022
11023C...Reset parameter values. Switch on some nonstandard features.
11024 MSTJ(1)=1
11025 MSTJ(3)=0
11026 MSTJ(11)=1
11027 MSTJ(42)=2
11028 MSTJ(43)=4
11029 MSTJ(44)=2
11030 PARJ(17)=0.1
11031 PARJ(22)=1.5
11032 PARJ(43)=1.
11033 PARJ(54)=-0.05
11034 MSTJ(101)=5
11035 MSTJ(104)=5
11036 MSTJ(105)=0
11037 MSTJ(107)=1
11038 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
11039
11040C...Ten events each for some single jets configurations.
11041 IF(IEV.LE.50) THEN
11042 ITY=(IEV+9)/10
11043 MSTJ(3)=-1
11044 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
11045 IF(ITY.EQ.1) CALL LY1ENT(1,1,15.,0.,0.)
11046 IF(ITY.EQ.2) CALL LY1ENT(1,3101,15.,0.,0.)
11047 IF(ITY.EQ.3) CALL LY1ENT(1,-2203,15.,0.,0.)
11048 IF(ITY.EQ.4) CALL LY1ENT(1,-4,30.,0.,0.)
11049 IF(ITY.EQ.5) CALL LY1ENT(1,21,15.,0.,0.)
11050
11051C...Ten events each for some simple jet systems; string fragmentation.
11052 ELSEIF(IEV.LE.130) THEN
11053 ITY=(IEV-41)/10
11054 IF(ITY.EQ.1) CALL LY2ENT(1,1,-1,40.)
11055 IF(ITY.EQ.2) CALL LY2ENT(1,4,-4,30.)
11056 IF(ITY.EQ.3) CALL LY2ENT(1,2,2103,100.)
11057 IF(ITY.EQ.4) CALL LY2ENT(1,21,21,40.)
11058 IF(ITY.EQ.5) CALL LY3ENT(1,2101,21,-3203,30.,0.6,0.8)
11059 IF(ITY.EQ.6) CALL LY3ENT(1,5,21,-5,40.,0.9,0.8)
11060 IF(ITY.EQ.7) CALL LY3ENT(1,21,21,21,60.,0.7,0.5)
11061 IF(ITY.EQ.8) CALL LY4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
11062
11063C...Seventy events with independent fragmentation and momentum cons.
11064 ELSEIF(IEV.LE.200) THEN
11065 ITY=1+(IEV-131)/16
11066 MSTJ(2)=1+MOD(IEV-131,4)
11067 MSTJ(3)=1+MOD((IEV-131)/4,4)
11068 IF(ITY.EQ.1) CALL LY2ENT(1,4,-5,40.)
11069 IF(ITY.EQ.2) CALL LY3ENT(1,3,21,-3,40.,0.9,0.4)
11070 IF(ITY.EQ.3) CALL LY4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
11071 IF(ITY.GE.4) CALL LY4ENT(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
11072
11073C...A hundred events with random jets (check invariant mass).
11074 ELSEIF(IEV.LE.300) THEN
11075 100 DO 110 J=1,5
11076 PSUM(J)=0.
11077 110 CONTINUE
11078 NJET=2.+6.*RLY(0)
11079 DO 130 I=1,NJET
11080 KFL=21
11081 IF(I.EQ.1) KFL=INT(1.+4.*RLY(0))
11082 IF(I.EQ.NJET) KFL=-INT(1.+4.*RLY(0))
11083 EJET=5.+20.*RLY(0)
11084 THETA=ACOS(2.*RLY(0)-1.)
11085 PHI=6.2832*RLY(0)
11086 IF(I.LT.NJET) CALL LY1ENT(-I,KFL,EJET,THETA,PHI)
11087 IF(I.EQ.NJET) CALL LY1ENT(I,KFL,EJET,THETA,PHI)
11088 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
11089 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+UYMASS(KFL)
11090 DO 120 J=1,4
11091 PSUM(J)=PSUM(J)+P(I,J)
11092 120 CONTINUE
11093 130 CONTINUE
11094 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
11095 & (PSUM(5)+PARJ(32))**2) GOTO 100
11096
11097C...Fifty e+e- continuum events with matrix elements.
11098 ELSEIF(IEV.LE.350) THEN
11099 MSTJ(101)=2
11100 CALL LYEEVT(0,40.)
11101
11102C...Fifty e+e- continuum event with varying shower options.
11103 ELSEIF(IEV.LE.400) THEN
11104 MSTJ(42)=1+MOD(IEV,2)
11105 MSTJ(43)=1+MOD(IEV/2,4)
11106 MSTJ(44)=MOD(IEV/8,3)
11107 CALL LYEEVT(0,90.)
11108
11109C...Fifty e+e- continuum events with coherent shower, including top.
11110 ELSEIF(IEV.LE.450) THEN
11111 MSTJ(104)=6
11112 CALL LYEEVT(0,500.)
11113
11114C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
11115 ELSEIF(IEV.LE.500) THEN
11116 CALL LYONIA(5,9.46)
11117
11118C...One decay each for some heavy mesons.
11119 ELSEIF(IEV.LE.560) THEN
11120 ITY=IEV-501
11121 KFLS=2*(ITY/20)+1
11122 KFLB=8-MOD(ITY/5,4)
11123 KFLC=KFLB-MOD(ITY,5)
11124 CALL LY1ENT(1,100*KFLB+10*KFLC+KFLS,0.,0.,0.)
11125
11126C...One decay each for some heavy baryons.
11127 ELSEIF(IEV.LE.600) THEN
11128 ITY=IEV-561
11129 KFLS=2*(ITY/20)+2
11130 KFLA=8-MOD(ITY/5,4)
11131 KFLB=KFLA-MOD(ITY,5)
11132 KFLC=MAX(1,KFLB-1)
11133 CALL LY1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.,0.,0.)
11134 ENDIF
11135
11136C...Generate event. Find total momentum, energy and charge.
11137 DO 140 J=1,4
11138 PINI(J)=PLY(0,J)
11139 140 CONTINUE
11140 PINI(6)=PLY(0,6)
11141 CALL LYEXEC
11142 DO 150 J=1,4
11143 PFIN(J)=PLY(0,J)
11144 150 CONTINUE
11145 PFIN(6)=PLY(0,6)
11146
11147C...Check conservation of energy, momentum and charge;
11148C...usually exact, but only approximate for single jets.
11149 MERR=0
11150 IF(IEV.LE.50) THEN
11151 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4.) MERR=MERR+1
11152 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
11153 IF(EPZREM.LT.0..OR.EPZREM.GT.2.*PARJ(31)) MERR=MERR+1
11154 IF(ABS(PFIN(6)-PINI(6)).GT.2.1) MERR=MERR+1
11155 ELSE
11156 DO 160 J=1,4
11157 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001*PINI(4)) MERR=MERR+1
11158 160 CONTINUE
11159 IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1
11160 ENDIF
11161 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
11162 &(PFIN(J),J=1,4),PFIN(6)
11163
11164C...Check that all KF codes are known ones, and that partons/particles
11165C...satisfy energy-momentum-mass relation. Store particle statistics.
11166 DO 170 I=1,N
11167 IF(K(I,1).GT.20) GOTO 170
11168 IF(LYCOMP(K(I,2)).EQ.0) THEN
11169 WRITE(MSTU(11),5100) I
11170 MERR=MERR+1
11171 ENDIF
11172 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
11173 IF(ABS(PD).GT.MAX(0.1,0.001*P(I,4)**2).OR.P(I,4).LT.0.) THEN
11174 WRITE(MSTU(11),5200) I
11175 MERR=MERR+1
11176 ENDIF
11177 170 CONTINUE
11178 IF(MTEST.GE.1) CALL LYTABU(21)
11179
11180C...List all erroneous events and some normal ones.
11181 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
11182 CALL LYLIST(2)
11183 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
11184 CALL LYLIST(1)
11185 ENDIF
11186
11187C...Stop execution if too many errors.
11188 IF(MERR.NE.0) NERR=NERR+1
11189 IF(NERR.GE.10) THEN
11190 WRITE(MSTU(11),5300) IEV
11191 STOP
11192 ENDIF
11193 180 CONTINUE
11194
11195C...Summarize result of run.
11196 IF(MTEST.GE.1) CALL LYTABU(22)
11197 IF(NERR.EQ.0) WRITE(MSTU(11),5400)
11198 IF(NERR.GT.0) WRITE(MSTU(11),5500) NERR
11199
11200C...Reset commonblock variables changed during run.
11201 MSTJ(2)=3
11202 PARJ(17)=0.
11203 PARJ(22)=1.
11204 PARJ(43)=0.5
11205 PARJ(54)=0.
11206 MSTJ(105)=1
11207 MSTJ(107)=0
11208
11209C...Format statements for output.
11210 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
11211 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
11212 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
11213 &4(1X,F12.5),1X,F8.2)
11214 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
11215 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
11216 &'kinematics')
11217 5300 FORMAT(/5X,'Ten errors experienced by event ',I3/
11218 &5X,'Something is seriously wrong! Execution stopped now!')
11219 5400 FORMAT(//5X,'End result of LYTEST: no errors detected.')
11220 5500 FORMAT(//5X,'End result of LYTEST:',I2,' errors detected.'/
11221 &5X,'This should not have happened!')
11222
11223 RETURN
11224 END
11225
11226C*********************************************************************
11227
11228 BLOCK DATA LYDATA
11229
11230C...Purpose: to give default values to parameters and particle and
11231C...decay data.
11232 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11233 COMMON/LYDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
11234 COMMON/LYDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
11235 COMMON/LYDAT4/CHAF(500)
11236 CHARACTER CHAF*8
11237 COMMON/LYDATR/MRLU(6),RRLU(100)
11238 SAVE /LYDAT1/,/LYDAT2/,/LYDAT3/,/LYDAT4/,/LYDATR/
11239
11240C...LUDAT1, containing status codes and most parameters.
11241 DATA MSTU/
11242 & 0, 0, 0, 4000,10000, 500, 2000, 0, 0, 2,
11243 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
11244 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
11245 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11246 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
11247 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
11248 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11249 7 30*0,
11250 & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11251 1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
11252 2 60*0,
11253 8 7, 410, 1997, 01, 20, 700, 0, 0, 0, 0,
11254 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
11255 DATA PARU/
11256 & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
11257 1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
11258 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11259 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11260 4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
11261 5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
11262 6 40*0.,
11263 & 0.00729735, 0.232, 0.007764, 1.0, 1.16639E-5, 0., 0., 0.,
11264 & 0., 0.,
11265 1 0.20, 0.25, 1.0, 4.0, 10., 0., 0., 0., 0., 0.,
11266 2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0, 0.,
11267 3 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 0., 0., 0.,
11268 4 5.0, 1.0, 1.0, 0., 1.0, 1.0, 0., 0., 0., 0.,
11269 5 1.0, 0., 0., 0., 1000., 1.0, 1.0, 1.0, 1.0, 0.,
11270 6 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., 0., 0.,
11271 7 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0.,
11272 8 1.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.,
11273 9 0., 0., 0., 0., 1.0, 0., 0., 0., 0., 0./
11274 DATA MSTJ/
11275 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
11276 1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
11277 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
11278 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
11279 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
11280 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
11281 6 40*0,
11282 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
11283 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
11284 2 80*0/
11285 DATA PARJ/
11286 & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
11287 1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
11288 2 0.36, 1.0, 0.01, 2.0, 1.0, 0.4, 0., 0., 0., 0.,
11289 3 0.10, 1.0, 0.8, 1.5, 0., 2.0, 0.2, 2.5, 0.6, 0.,
11290 4 0.3, 0.58, 0.5, 0.9, 0.5, 1.0, 1.0, 1.0, 0., 0.,
11291 5 0.77,0.77,0.77,-0.05,-0.005,-0.00001,-0.00001,-0.00001,1.0,0.,
11292 6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
11293 7 10., 1000., 100., 1000., 0., 0.7, 10., 0., 0., 0.,
11294 8 0.29, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
11295 9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
11296 & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11297 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11298 2 1.0, 0.25,91.187,2.489, 0.01, 2.0, 1.0, 0.25,0.002, 0.,
11299 3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
11300 4 60*0./
11301
11302C...LUDAT2, with particle data and flavour treatment parameters.
11303 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
11304 &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,44*0,2,-1,2,-1,2,3,11*0,3,0,2*3,0,
11305 &3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,
11306 &3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,
11307 &3,0,3,70*0,3,0,3,28*0,3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,
11308 &3,5*0,-3,0,3,-3,0,-3,4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,
11309 &-3,0,3,-3,0,-3,114*0/
11310 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,50*0,-1,410*0/
11311 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1,
11312 &41*0,1,0,7*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1,
11313 &10*0,10*1,70*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,
11314 &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
11315 DATA (PMAS(I,1),I= 1, 500)/0.0099,0.0056,0.199,1.35,5.,160.,
11316 &2*250.,2*0.,0.00051,0.,0.1057,0.,1.777,0.,250.,5*0.,91.187,80.25,
11317 &80.,6*0.,500.,900.,500.,3*300.,350.,200.,5000.,60*0.,0.1396,
11318 &0.4977,0.4936,1.8693,1.8645,1.9688,5.2787,5.2786,5.47972,6.594,
11319 &0.135,0.5475,0.9578,2.9788,9.4,320.,2*500.,2*0.,0.7669,0.8961,
11320 &0.8916,2.0101,2.0071,2.11,2*5.325,5.5068,6.602,0.7683,0.782,
11321 &1.0194,3.0969,9.4603,320.,2*500.,2*0.,1.232,2*1.29,2*2.424,2.536,
11322 &2*5.73,5.97,7.3,1.232,1.17,1.4,3.46,9.875,320.,2*500.,2*0.,0.983,
11323 &2*1.429,2*2.272,2.5,2*5.68,5.92,7.25,0.9827,1.,1.4,3.4151,9.8598,
11324 &320.,2*500.,2*0.,1.26,2*1.402,2*2.372,2.56,2*5.78,6.02,7.3,1.26,
11325 &1.282,1.42,3.5106,9.8919,320.,2*500.,2*0.,1.318,1.432,1.425,
11326 &2*2.46,2.61,2*5.83,6.07,7.35,1.318,1.275,1.525,3.5562,9.9132,
11327 &320.,2*500.,2*0.,2*0.4977,8*0.,3.686,3*0.,10.0233,70*0.,1.1156,
11328 &5*0.,2.2849,0.,2.473,2.466,6*0.,5.641,0.,2*5.84,6*0.,0.9396,
11329 &0.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.4525,2.4529,
11330 &2.4527,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,1.233,1.232,
11331 &1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8,
11332 &4*0.,3*5.81,2*5.97,6.13,114*0./
11333 DATA (PMAS(I,2),I= 1, 500)/22*0.,2.489,2.066,88*0.,0.0002,
11334 &0.001,6*0.,0.149,0.0505,0.0498,7*0.,0.151,0.00843,0.0044,7*0.,
11335 &0.155,2*0.09,2*0.02,0.,4*0.05,0.155,0.36,0.08,2*0.01,5*0.,0.057,
11336 &2*0.287,7*0.05,0.057,0.,0.25,0.014,6*0.,0.4,2*0.174,7*0.05,0.4,
11337 &0.024,0.06,0.0009,6*0.,0.11,0.109,0.098,2*0.019,5*0.02,0.11,
11338 &0.185,0.076,0.002,146*0.,4*0.12,0.0394,0.036,0.0358,0.0099,
11339 &0.0091,131*0./
11340 DATA (PMAS(I,3),I= 1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0.,
11341 &0.4,2*0.2,7*0.,0.4,0.1,0.015,7*0.,0.25,0.005,0.01,2*0.08,0.,
11342 &4*0.1,0.25,0.2,0.001,2*0.02,5*0.,0.05,2*0.4,6*0.1,2*0.05,0.,0.35,
11343 &0.05,6*0.,3*0.3,2*0.1,0.03,4*0.1,0.3,0.05,0.02,0.001,6*0.,0.25,
11344 &4*0.12,5*0.05,0.25,0.17,0.2,0.01,146*0.,4*0.14,0.04,2*0.035,
11345 &2*0.05,131*0./
11346 DATA (PMAS(I,4),I= 1, 500)/12*0.,658650.,0.,0.0914,68*0.,0.1,
11347 &0.387,15*0.,7804.,0.,3709.,0.32,0.1259,0.135,3*0.387,0.15,110*0.,
11348 &15500.,26.75,83*0.,78.88,5*0.,0.057,0.,0.025,0.09,6*0.,0.387,0.,
11349 &2*0.387,9*0.,44.3,0.,23.95,49.1,86.9,6*0.,0.13,9*0.,0.387,13*0.,
11350 &24.60001,130*0./
11351 DATA PARF/
11352 & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
11353 1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11354 2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11355 3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11356 4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11357 5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
11358 6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
11359 7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
11360 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11361 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
11362 & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
11363 1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
11364 2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
11365 3 1870*0./
11366 DATA ((VCKM(I,J),J=1,4),I=1,4)/
11367 1 0.95113, 0.04884, 0.00003, 0.00000,
11368 2 0.04884, 0.94940, 0.00176, 0.00000,
11369 3 0.00003, 0.00176, 0.99821, 0.00000,
11370 4 0.00000, 0.00000, 0.00000, 1.00000/
11371
11372C...LUDAT3, with particle decay parameters and data.
11373 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,1,
11374 &2*0,4*1,42*0,7*1,12*0,1,0,15*1,2*0,18*1,2*0,18*1,2*0,18*1,2*0,
11375 &18*1,2*0,18*1,3*0,1,8*0,1,3*0,1,70*0,1,5*0,1,0,2*1,6*0,1,0,2*1,
11376 &9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
11377 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,50,60,2*0,70,74,76,
11378 &81,83,124,126,132,2*0,135,144,156,172,192,6*0,209,0,231,254,274,
11379 &292,301,304,305,42*0,314,315,319,328,331,336,338,11*0,358,359,
11380 &361,367,430,491,524,560,596,635,666,668,675,681,682,683,684,685,
11381 &2*0,686,688,691,694,697,699,700,701,702,703,704,708,713,721,724,
11382 &733,734,735,2*0,736,737,742,747,749,751,753,755,757,759,761,762,
11383 &765,769,770,771,772,773,2*0,774,775,777,779,781,783,785,787,789,
11384 &791,793,794,799,804,806,808,809,810,2*0,811,813,815,817,819,821,
11385 &823,825,827,829,831,833,846,850,852,854,855,856,2*0,857,863,873,
11386 &884,892,900,904,912,920,924,928,936,945,951,953,955,956,957,2*0,
11387 &958,966,8*0,968,3*0,979,70*0,993,5*0,997,0,1073,1074,6*0,1075,0,
11388 &1092,1093,9*0,1094,1096,1097,1100,1101,0,1103,1104,1105,1106,
11389 &1107,1108,4*0,1109,1110,1111,1112,1113,1114,4*0,1115,1116,1119,
11390 &1122,1123,1126,1129,1132,1134,1136,1140,1141,1142,1143,1145,1147,
11391 &4*0,1148,1149,1150,1151,1152,1153,114*0/
11392 DATA (MDCY(I,3),I= 1, 500)/5*8,9,2*10,2*0,4,2,5,2,41,2,6,3,2*0,
11393 &9,12,16,20,17,6*0,22,0,23,20,18,9,3,1,9,42*0,1,4,9,3,5,2,20,11*0,
11394 &1,2,6,63,61,33,2*36,39,31,2,7,6,5*1,2*0,2,3*3,2,5*1,4,5,8,3,9,
11395 &3*1,2*0,1,2*5,7*2,1,3,4,5*1,2*0,1,9*2,1,2*5,2*2,3*1,2*0,11*2,13,
11396 &4,2*2,3*1,2*0,6,10,11,2*8,4,2*8,2*4,8,9,6,2*2,3*1,2*0,8,2,8*0,11,
11397 &3*0,14,70*0,4,5*0,76,0,2*1,6*0,17,0,2*1,9*0,2,1,3,1,2,0,6*1,4*0,
11398 &6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
11399 DATA (MDME(I,1),I= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
11400 &7*1,-1,1,-1,8*1,2*-1,8*1,2*-1,61*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
11401 &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,2*-1,
11402 &3*1,-1,11*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,6*1,
11403 &2*-1,3*1,-1,5*1,-1,8*1,2*-1,3*1,-1,9*1,-1,3*1,-1,9*1,2*-1,2*1,-1,
11404 &16*1,-1,2*1,3*-1,1665*1/
11405 DATA (MDME(I,2),I= 1,2000)/75*102,42,6*102,2*42,2*0,7*41,2*0,
11406 &24*41,6*102,45,29*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
11407 &14*0,16*32,7*0,8*32,4*0,32,7*0,8*32,4*0,32,5*0,4*32,5*0,3*32,0,
11408 &6*32,3*0,12,2*42,2*11,9*42,2*45,31,2*45,2*33,31,2*45,20*46,7*0,
11409 &24*42,41*0,16*42,46*0,10*42,20*0,2*13,14*42,16*0,48,3*13,16*42,
11410 &16*0,48,3*13,16*42,19*0,48,3*13,2*42,0,2*11,28*42,0,2,4*0,2,8*0,
11411 &12,32,86,87,88,3,0,2*3,0,2*3,0,2*3,0,3,6*0,3,3*0,1,0,3,2*0,2*3,
11412 &3*0,1,4*0,12,3*0,4*32,2*4,86,87,88,33*0,12,32,86,87,88,31*0,12,0,
11413 &32,86,87,88,40*0,12,0,32,86,87,88,95*0,12,0,32,86,87,88,2*0,4*42,
11414 &6*0,12,11*0,4*32,2*4,9*0,14*42,52*0,10*13,2*84,3*42,8*0,48,3*13,
11415 &2*42,2*85,14*0,84,5*0,85,886*0/
11416 DATA (BRAT(I) ,I= 1, 439)/75*0.,1.,6*0.,0.179,0.178,0.116,
11417 &0.235,0.005,0.056,0.018,0.023,0.011,2*0.004,0.0067,0.014,2*0.002,
11418 &2*0.001,0.0022,0.054,0.002,0.016,0.005,0.011,0.0101,5*0.006,
11419 &0.002,2*0.001,5*0.002,6*0.,1.,29*0.,0.15394,0.11936,0.15394,
11420 &0.11926,0.15254,3*0.,0.03368,0.06664,0.03368,0.06664,0.03368,
11421 &0.06664,2*0.,0.3214,0.0165,2*0.,0.0165,0.3207,2*0.,0.00001,
11422 &0.00059,6*0.,3*0.1081,3*0.,0.0003,0.048,0.8705,4*0.,0.0002,
11423 &0.0603,0.,0.0199,0.0008,3*0.,0.143,0.111,0.143,0.111,0.143,0.085,
11424 &2*0.,0.03,0.058,0.03,0.058,0.03,0.058,8*0.,0.25,0.01,2*0.,0.01,
11425 &0.25,4*0.,0.24,5*0.,3*0.08,6*0.,0.01,0.08,0.82,5*0.,0.09,11*0.,
11426 &0.01,0.08,0.82,5*0.,0.09,9*0.,1.,6*0.,0.01,0.98,0.01,1.,4*0.215,
11427 &2*0.,2*0.07,0.,1.,2*0.08,0.76,0.08,2*0.105,0.04,0.5,0.08,0.14,
11428 &0.01,0.015,0.005,1.,3*0.,1.,4*0.,1.,0.25,0.01,2*0.,0.01,0.25,
11429 &4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,0.017,0.048,
11430 &0.032,0.07,0.065,2*0.005,2*0.011,5*0.001,0.07,0.065,2*0.005,
11431 &2*0.011,5*0.001,0.026,0.019,0.066,0.041,0.045,0.076,0.0073,
11432 &2*0.0047,0.026,0.001,0.0006,0.0066,0.005,2*0.003,2*0.0006,
11433 &2*0.001,0.006,0.005,0.012,0.0057,0.067,0.008,0.0022,0.027,0.004,
11434 &0.019,0.012,0.002,0.009,0.0218,0.001,0.022,0.087,0.001,0.0019,
11435 &0.0015,0.0028,0.034,0.027,2*0.002,2*0.004,2*0.002,0.034,0.027/
11436 DATA (BRAT(I) ,I= 440, 655)/2*0.002,2*0.004,2*0.002,0.0365,
11437 &0.045,0.073,0.062,3*0.021,0.0061,0.015,0.025,0.0088,0.074,0.0109,
11438 &0.0041,0.002,0.0035,0.0011,0.001,0.0027,2*0.0016,0.0018,0.011,
11439 &0.0063,0.0052,0.018,0.016,0.0034,0.0036,0.0009,0.0006,0.015,
11440 &0.0923,0.018,0.022,0.0077,0.009,0.0075,0.024,0.0085,0.067,0.0511,
11441 &0.017,0.0004,0.0028,0.01,2*0.02,0.03,2*0.005,2*0.02,0.03,2*0.005,
11442 &0.015,0.037,0.028,0.079,0.095,0.052,0.0078,4*0.001,0.028,0.033,
11443 &0.026,0.05,0.01,4*0.005,0.25,0.0952,0.02,0.055,2*0.005,0.008,
11444 &0.012,0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,
11445 &0.0055,0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,0.0004,
11446 &0.0007,0.0008,0.0014,0.0019,0.0025,0.4291,0.08,0.07,0.02,0.015,
11447 &0.005,0.02,0.055,2*0.005,0.008,0.012,0.02,0.055,2*0.005,0.008,
11448 &0.012,0.01,0.03,0.0035,0.011,0.0055,0.0042,0.009,0.018,0.015,
11449 &0.0185,0.0135,0.025,0.0004,0.0007,0.0008,0.0014,0.0019,0.0025,
11450 &0.4291,0.08,0.07,0.02,0.015,0.005,0.02,0.055,2*0.005,0.008,0.012,
11451 &0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,0.0055,
11452 &0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,2*0.0002,0.0007,
11453 &2*0.0004,0.0014,0.001,0.0009,0.0025,0.4291,0.08,0.07,0.02,0.015,
11454 &0.005,0.047,0.122,0.006,0.012,0.035,0.012,0.035,0.003,0.007,0.15,
11455 &0.037,0.008,0.002,0.05,0.015,0.003,0.001,0.014,0.042,0.014,0.042/
11456 DATA (BRAT(I) ,I= 656, 931)/0.24,0.065,0.012,0.003,0.001,0.002,
11457 &0.001,0.002,0.014,0.003,0.988,0.012,0.389,0.319,0.2367,0.049,
11458 &0.005,0.001,0.0003,0.441,0.206,0.3,0.03,0.022,0.001,5*1.,0.99955,
11459 &0.00045,0.665,0.333,0.002,0.666,0.333,0.001,0.65,0.3,0.05,0.56,
11460 &0.44,5*1.,0.99912,0.00079,0.00005,0.00004,0.888,0.085,0.021,
11461 &2*0.003,0.49,0.344,3*0.043,0.023,0.013,0.001,0.0627,0.0597,
11462 &0.8776,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,4*1.,0.28,0.14,
11463 &0.313,0.157,0.11,0.28,0.14,0.313,0.157,0.11,0.667,0.333,0.667,
11464 &0.333,2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.333,0.334,0.333,
11465 &4*0.25,6*1.,0.667,0.333,0.667,0.333,0.667,0.333,0.667,0.333,
11466 &2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.52,0.26,0.11,2*0.055,
11467 &0.62,0.31,0.035,2*0.0175,0.007,0.993,0.02,0.98,3*1.,2*0.5,0.667,
11468 &0.333,0.667,0.333,0.667,0.333,0.667,0.333,2*0.5,0.667,0.333,
11469 &0.667,0.333,6*0.5,3*0.12,0.097,0.043,4*0.095,4*0.03,4*0.25,0.273,
11470 &0.727,0.35,0.65,3*1.,2*0.35,0.144,0.105,0.048,0.003,0.333,0.166,
11471 &0.168,0.084,0.087,0.043,0.059,2*0.029,0.002,0.332,0.166,0.168,
11472 &0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,0.15,0.16,0.08,0.13,
11473 &0.06,0.08,0.04,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,2*0.3,
11474 &2*0.2,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,0.3,0.15,0.16,0.08,
11475 &0.13,0.06,0.08,0.04,2*0.3,2*0.2,2*0.3,2*0.2,2*0.35,0.144,0.105/
11476 DATA (BRAT(I) ,I= 932,2000)/0.024,2*0.012,0.003,0.566,0.283,
11477 &0.069,0.028,0.023,2*0.0115,0.005,0.003,0.356,2*0.178,0.28,
11478 &2*0.004,0.135,0.865,0.22,0.78,3*1.,0.217,0.124,2*0.193,2*0.135,
11479 &0.002,0.001,0.686,0.314,2*0.0083,0.1866,0.324,0.184,0.027,0.001,
11480 &0.093,0.087,0.078,0.0028,3*0.014,0.008,0.024,0.008,0.024,0.425,
11481 &0.02,0.185,0.088,0.043,0.067,0.066,0.641,0.357,2*0.001,0.018,
11482 &2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,2*0.006,
11483 &0.0066,0.025,0.016,0.0088,2*0.005,0.0058,0.005,0.0055,4*0.004,
11484 &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002,
11485 &2*0.001,2*0.002,0.0013,0.0018,5*0.001,4*0.003,2*0.005,2*0.002,
11486 &2*0.001,2*0.002,2*0.001,0.2432,0.057,2*0.035,0.15,2*0.075,0.03,
11487 &2*0.015,2*1.,2*0.105,0.04,0.0077,0.02,0.0235,0.0285,0.0435,
11488 &0.0011,0.0022,0.0044,0.4291,0.08,0.07,0.02,0.015,0.005,2*1.,
11489 &0.999,0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331,
11490 &0.663,0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88,
11491 &2*0.06,0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5,
11492 &7*1.,847*0./
11493 DATA (KFDP(I,1),I= 1, 507)/21,22,23,4*-24,25,21,22,23,4*24,25,
11494 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
11495 &4*24,25,37,21,22,23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,
11496 &-24,25,23,24,-12,22,23,-24,25,23,24,-12,-14,35*16,22,23,-24,25,
11497 &23,24,-89,22,23,-24,25,-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,
11498 &6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,
11499 &4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,
11500 &2*22,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,24,37,2*23,25,
11501 &35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11,
11502 &13,15,17,21,2*22,23,24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21,
11503 &2*22,23,24,23,-1,-3,-5,-7,-11,-13,-15,-17,24,5,6,21,2,1,2,3,4,5,
11504 &6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37,
11505 &2*-89,2*5,-37,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
11506 &310,-13,3*211,12,14,11*-11,11*-13,-311,-313,-311,-313,-20313,
11507 &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,
11508 &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311,
11509 &-321,211,113,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
11510 &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
11511 &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
11512 &-321,3*-311,211,113,321,-15,5*-11,5*-13,221,331,333,221,331,333/
11513 DATA (KFDP(I,1),I= 508, 924)/10221,211,213,211,213,321,323,321,
11514 &323,2212,221,331,333,221,2*2,6*12,6*14,2*16,3*-411,3*-413,2*-411,
11515 &2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,2*16,3*-421,
11516 &3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,
11517 &2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,
11518 &16,2*4,2*12,2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,
11519 &2*-1,3*22,111,211,2*22,211,22,211,111,3*22,111,82,21,3*0,2*211,
11520 &321,3*311,2*321,421,2*411,2*421,431,511,521,531,541,211,111,13,
11521 &11,211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,82,11,
11522 &13,15,1,2,3,4,21,22,3*0,223,321,311,323,313,2*311,321,313,323,
11523 &321,423,2*413,2*423,413,523,2*513,2*523,2*513,523,223,213,113,
11524 &-213,313,-313,323,-323,82,21,3*0,221,321,2*311,321,421,2*411,421,
11525 &411,421,521,2*511,2*521,2*511,521,221,211,111,321,130,310,211,
11526 &111,321,130,310,443,82,553,21,3*0,113,213,323,2*313,323,423,
11527 &2*413,2*423,413,523,2*513,2*523,2*513,523,213,-213,10211,10111,
11528 &-10211,2*221,213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82,
11529 &553,21,3*0,213,113,221,223,321,211,321,311,323,313,323,313,321,
11530 &4*311,321,313,323,313,323,311,4*321,421,411,423,413,423,413,421,
11531 &2*411,421,413,423,413,423,411,2*421,411,423,413,521,511,523,513,
11532 &523,513,521,2*511,521,513,523,513,523,511,2*521,511,523,513,511/
11533 DATA (KFDP(I,1),I= 925,2000)/521,513,523,213,-213,221,223,321,
11534 &130,310,111,211,111,2*211,321,130,310,221,111,321,130,310,221,
11535 &211,111,443,82,553,21,3*0,111,211,-12,12,-14,14,211,111,211,111,
11536 &11,13,82,4*443,10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,
11537 &10551,20553,555,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
11538 &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,7*2212,
11539 &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
11540 &2*2,1,2*2,2*0,-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,
11541 &2*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,4232,0,
11542 &3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,3212,
11543 &3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,3322,
11544 &3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,847*0/
11545 DATA (KFDP(I,2),I= 1, 476)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
11546 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,3*7,2,4,6,8,7,
11547 &4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,
11548 &-211,-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,3*-321,
11549 &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
11550 &16,15,16,15,18,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
11551 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
11552 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
11553 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
11554 &-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
11555 &-37,22,25,2*36,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,
11556 &25,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,
11557 &36,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4,
11558 &6,8,12,14,16,18,25,-5,-6,21,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,
11559 &12,14,-1,-3,11,13,15,1,4,3,4,1,3,5,3,5,6,4,21,22,4,7,5,2,4,6,8,2,
11560 &4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,
11561 &11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,213,211,213,
11562 &211,213,211,213,211,213,211,213,3*211,213,211,2*321,8*211,2*113,
11563 &2*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,211,
11564 &2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,211/
11565 DATA (KFDP(I,2),I= 477, 857)/-211,4*211,321,4*211,113,2*211,-321,
11566 &16,5*12,5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,
11567 &3*321,323,2*-1,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,
11568 &433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,6*-11,
11569 &6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,321,323,
11570 &321,323,321,323,-1,-4,-3,-4,-1,-3,6*-11,6*-13,2*-15,211,213,
11571 &20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,221,
11572 &331,333,-1,-4,-3,-4,-1,-3,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,
11573 &-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,11,22,111,-211,
11574 &211,11,-211,13,-211,111,113,223,22,111,-82,21,3*0,111,22,-211,
11575 &111,22,211,111,22,211,111,22,111,6*22,-211,22,-13,-11,-211,111,
11576 &-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,-11,-13,
11577 &-15,-1,-2,-3,-4,2*21,3*0,211,-213,113,-211,111,223,213,113,211,
11578 &111,223,211,111,-211,111,321,311,-211,111,211,111,-321,-311,411,
11579 &421,111,-211,111,211,-311,311,-321,321,-82,21,3*0,211,-211,111,
11580 &211,111,211,111,-211,111,311,321,-211,111,211,111,-321,-311,411,
11581 &421,111,-211,111,-321,130,310,-211,111,-321,130,310,22,-82,22,21,
11582 &3*0,211,111,-211,111,211,111,211,111,-211,111,321,311,-211,111,
11583 &211,111,-321,-311,411,421,-211,211,-211,111,2*211,111,-211,211,
11584 &111,211,-321,2*-311,-321,-311,311,-321,321,22,-82,22,21,3*0,111/
11585 DATA (KFDP(I,2),I= 858,2000)/3*211,-311,22,-211,111,-211,111,
11586 &-211,211,-213,113,223,221,211,111,211,111,2*211,213,113,223,221,
11587 &22,211,111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,
11588 &311,321,311,-211,111,-211,111,-211,211,-211,2*211,111,211,111,
11589 &4*211,-321,-311,-321,-311,411,421,411,421,-211,211,111,211,-321,
11590 &130,310,22,-211,111,2*-211,-321,130,310,221,111,-321,130,310,221,
11591 &-211,111,22,-82,22,21,3*0,111,-211,11,-11,13,-13,-211,111,-211,
11592 &111,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
11593 &2*21,211,111,3*22,-211,111,22,11,7*12,7*14,-321,-323,-311,-313,
11594 &-311,-313,211,213,211,213,211,213,111,221,331,113,223,111,221,
11595 &113,223,321,323,321,-211,-213,111,221,331,113,223,333,10221,111,
11596 &221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,313,
11597 &311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,2*0,11,13,15,
11598 &-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,2*0,-211,11,22,111,
11599 &211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,0,
11600 &2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211,
11601 &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22,
11602 &-211,111,211,3*22,847*0/
11603 DATA (KFDP(I,3),I= 1, 944)/75*0,14,6*0,2*16,2*0,5*111,310,130,
11604 &2*0,2*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
11605 &2*113,221,113,2*213,-213,195*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211,
11606 &3*111,-311,-313,-311,-321,-313,-323,111,221,331,113,223,-311,
11607 &-313,-311,-321,-313,-323,111,221,331,113,223,22*0,111,113,2*211,
11608 &-211,-311,211,111,3*211,-211,7*211,-321,-323,-311,-321,-313,-323,
11609 &-211,-213,-321,-323,-311,-321,-313,-323,-211,-213,22*0,111,113,
11610 &-311,2*-211,211,-211,310,-211,2*111,211,2*-211,-321,-211,2*211,
11611 &-211,111,-211,2*211,0,221,331,333,321,311,221,331,333,321,311,
11612 &20*0,3,0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
11613 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,-421,-423,
11614 &-10423,-10421,-20423,-425,-421,-423,-10423,-10421,-20423,-425,
11615 &-421,-423,16*0,-4,-1,-4,-3,2*-2,-431,-433,-10433,-10431,-20433,
11616 &-435,-431,-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,
11617 &-3,2*-2,3*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,
11618 &533,531,533,3,2,3,2,511,513,511,513,1,2,0,-11,0,2*111,-211,-11,
11619 &11,-13,2*221,3*0,111,27*0,111,2*0,22,111,5*0,111,12*0,2*21,103*0,
11620 &-211,2*111,-211,3*111,-211,111,211,14*0,111,6*0,111,-211,8*0,111,
11621 &-211,9*0,111,-211,111,-211,4*0,111,-211,111,-211,8*0,111,-211,
11622 &111,-211,4*0,111,-211,111,-211,11*0,-211,6*0,111,211,4*0,111/
11623 DATA (KFDP(I,3),I= 945,2000)/13*0,2*111,211,-211,211,-211,7*0,
11624 &-211,111,13*0,2*21,-211,111,6*0,2212,3122,3212,3214,2112,2114,
11625 &2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,8*0,
11626 &3*4122,8*0,4,1,4,3,2*2,3*0,2112,43*0,3322,861*0/
11627 DATA (KFDP(I,4),I= 1,2000)/88*0,3*111,8*0,-211,0,-211,3*0,111,
11628 &2*-211,0,111,0,2*111,113,221,111,-213,-211,211,195*0,13*81,41*0,
11629 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
11630 &-211,2*211,2*-211,2*0,-211,111,-211,111,4*0,-211,111,-211,111,
11631 &34*0,111,-211,3*111,3*-211,2*111,3*-211,4*0,-321,-311,3*0,-321,
11632 &-311,20*0,-3,31*0,6*1,30*0,6*2,33*0,6*3,9*0,8*4,4*0,4*-5,4*0,
11633 &2*-5,7*0,-11,264*0,111,-211,4*0,111,57*0,-211,111,5*0,-211,111,
11634 &52*0,2101,2103,2*2101,19*0,6*2101,909*0/
11635 DATA (KFDP(I,5),I= 1,2000)/90*0,111,16*0,111,7*0,111,0,2*111,
11636 &303*0,-211,2*111,-211,111,-211,111,54*0,111,-211,3*111,-211,111,
11637 &1510*0/
11638
11639C...LUDAT4, with character strings.
11640 DATA (CHAF(I) ,I= 1, 281)/'d','u','s','c','b','t','l','h',
11641 &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
11642 &2*' ','g','gamma','Z','W','H',2*' ','reggeon','pomeron',2*' ',
11643 &'Z''','Z"','W''','H''','A','H','eta_tech','LQ_ue','R',40*' ',
11644 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',
11645 &'t-hadron','l-hadron','h-hadron','Wvirt','diquark','cluster',
11646 &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
11647 &'CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B','B_s','B_c',
11648 &'pi','eta','eta''','eta_c','eta_b','eta_t','eta_l','eta_h',2*' ',
11649 &'rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s','B*_c','rho','omega',
11650 &'phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',2*' ','b_1',
11651 &2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s','B_1c','b_1','h_1','h''_1',
11652 &'h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',2*'K*_0',2*'D*_0',
11653 &'D*_0s',2*'B*_0','B*_0s','B*_0c','a_0','f_0','f''_0','chi_0c',
11654 &'chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',2*'K*_1',
11655 &2*'D*_1','D*_1s',2*'B*_1','B*_1s','B*_1c','a_1','f_1','f''_1',
11656 &'chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
11657 &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s','B*_2c','a_2','f_2',
11658 &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
11659 &'K_S',8*' ','psi''',3*' ','Upsilon''',45*' ','pi_diffr'/
11660 DATA (CHAF(I) ,I= 282, 500)/'n_diffr','p_diffr','rho_diff',
11661 &'omega_di','phi_diff','J/psi_di',18*' ','Lambda',5*' ',
11662 &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' ','n',
11663 &'p',' ',3*'Sigma',2*'Xi',' ',3*'Sigma_c',2*'Xi''_c','Omega_c',
11664 &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
11665 &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
11666 &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
11667
11668C...LUDATR, with initial values for the random number generator.
11669 DATA MRLU/19780503,0,0,97,33,0/
11670
11671 END
11672
11673C*********************************************************************
11674
11675 SUBROUTINE LYTAUD(ITAU,IORIG,KFORIG,NDECAY)
11676
11677C...Dummy routine, to be replaced by user, to handle the decay of a
11678C...polarized tau lepton.
11679C...Input:
11680C...ITAU is the position where the decaying tau is stored in /LYJETS/.
11681C...IORIG is the position where the mother of the tau is stored;
11682C... is 0 when the mother is not stored.
11683C...KFORIG is the flavour of the mother of the tau;
11684C... is 0 when the mother is not known.
11685C...Note that IORIG=0 does not necessarily imply KFORIG=0;
11686C... e.g. in B hadron semileptonic decays the W propagator
11687C... is not explicitly stored but the W code is still unambiguous.
11688C...Output:
11689C...NDECAY is the number of decay products in the current tau decay.
11690C...These decay products should be added to the /LYJETS/ common block,
11691C...in positions N+1 through N+NDECAY. For each product I you must
11692C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
11693C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
11694
11695 COMMON/LYJETS/N,K(4000,5),P(4000,5),V(4000,5)
11696 COMMON/LYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11697 SAVE /LYJETS/,/LYDAT1/
11698
11699C...Stop program if this routine is ever called.
11700C...You should not copy these lines to your own routine.
11701 NDECAY=ITAU+IORIG+KFORIG
11702 WRITE(MSTU(11),5000)
11703 IF(RLY(0).LT.10.) STOP
11704
11705C...Format for error printout.
11706 5000 FORMAT(1X,'Error: you did not link your LYTAUD routine ',
11707 &'correctly.'/1X,'Dummy routine in JETSET file called instead.'/
11708 &1X,'Execution stopped!')
11709
11710
11711 RETURN
11712 END