]> git.uio.no Git - u/mrichter/AliRoot.git/blame - THydjet/hydjet1_1/jetset_73.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
- implemented function that allows selection of HLT triggered events (Hege)
[u/mrichter/AliRoot.git] / THydjet / hydjet1_1 / jetset_73.f
CommitLineData
cb220f83 1C*********************************************************************
2CCPH This file has enlarged event record, LUJETS size=30000
3C*********************************************************************
4C*********************************************************************
5C*********************************************************************
6C* **
7C* June 1991 **
8C* **
9C* The Lund Monte Carlo for Jet Fragmentation and e+e- Physics **
10C* **
11C* JETSET version 7.3 **
12C* **
13C* Torbjorn Sjostrand **
14C* **
15C* CERN/TH, CH-1211 Geneva 23 **
16C* BITNET/EARN address TORSJO@CERNVM **
17C* Tel. +22 - 767 28 20 **
18C* **
19C* LUSHOW is written together with Mats Bengtsson **
20C* **
21C* A complete manual exists on a separate file **
22C* Please report any program errors to the author! **
23C* **
24C* Copyright Torbjorn Sjostrand **
25C* **
26C*********************************************************************
27C*********************************************************************
28C *
29C List of subprograms in order of appearance, with main purpose *
30C (S = subroutine, F = function, B = block data) *
31C *
32C S LU1ENT to fill one entry (= parton or particle) *
33C S LU2ENT to fill two entries *
34C S LU3ENT to fill three entries *
35C S LU4ENT to fill four entries *
36C S LUJOIN to connect entries with colour flow information *
37C S LUGIVE to fill (or query) commonblock variables *
38C S LUEXEC to administrate fragmentation and decay chain *
39C S LUPREP to rearrange showered partons along strings *
40C S LUSTRF to do string fragmentation of jet system *
41C S LUINDF to do independent fragmentation of one or many jets *
42C S LUDECY to do the decay of a particle *
43C S LUKFDI to select parton and hadron flavours in fragm *
44C S LUPTDI to select transverse momenta in fragm *
45C S LUZDIS to select longitudinal scaling variable in fragm *
46C S LUSHOW to do timelike parton shower evolution *
47C S LUBOEI to include Bose-Einstein effects (crudely) *
48C F ULMASS to give the mass of a particle or parton *
49C S LUNAME to give the name of a particle or parton *
50C F LUCHGE to give three times the electric charge *
51C F LUCOMP to compress standard KF flavour code to internal KC *
52C S LUERRM to write error messages and abort faulty run *
53C F ULALEM to give the alpha_electromagnetic value *
54C F ULALPS to give the alpha_strong value *
55C F ULANGL to give the angle from known x and y components *
56C F RLU to provide a random number generator *
57C S RLUGET to save the state of the random number generator *
58C S RLUSET to set the state of the random number generator *
59C S LUROBO to rotate and/or boost an event *
60C S LUEDIT to remove unwanted entries from record *
61C S LULIST to list event record or particle data *
62C S LUUPDA to update particle data *
63C F KLU to provide integer-valued event information *
64C F PLU to provide real-valued event information *
65C S LUSPHE to perform sphericity analysis *
66C S LUTHRU to perform thrust analysis *
67C S LUCLUS to perform three-dimensional cluster analysis *
68C S LUCELL to perform cluster analysis in (eta, phi, E_T) *
69C S LUJMAS to give high and low jet mass of event *
70C S LUFOWO to give Fox-Wolfram moments *
71C S LUTABU to analyze events, with tabular output *
72C *
73C S LUEEVT to administrate the generation of an e+e- event *
74C S LUXTOT to give the total cross-section at given CM energy *
75C S LURADK to generate initial state photon radiation *
76C S LUXKFL to select flavour of primary qqbar pair *
77C S LUXJET to select (matrix element) jet multiplicity *
78C S LUX3JT to select kinematics of three-jet event *
79C S LUX4JT to select kinematics of four-jet event *
80C S LUXDIF to select angular orientation of event *
81C S LUONIA to perform generation of onium decay to gluons *
82C *
83C S LUHEPC to convert between /LUJETS/ and /HEPEVT/ records *
84C S LUTEST to test the proper functioning of the package *
85C B LUDATA to contain default values and particle data *
86C *
87C*********************************************************************
88
89 SUBROUTINE LU1ENT(IP,KF,PE,THE,PHI)
90
91C...Purpose: to store one parton/particle in commonblock LUJETS.
92 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
93 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
94 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
95 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
96
97C...Standard checks.
98 MSTU(28)=0
99 IF(MSTU(12).GE.1) CALL LULIST(0)
100 IPA=MAX(1,IABS(IP))
101 IF(IPA.GT.MSTU(4)) CALL LUERRM(21,
102 &'(LU1ENT:) writing outside LUJETS memory')
103 KC=LUCOMP(KF)
104 IF(KC.EQ.0) CALL LUERRM(12,'(LU1ENT:) unknown flavour code')
105
106C...Find mass. Reset K, P and V vectors.
107 PM=0.
108 IF(MSTU(10).EQ.1) PM=P(IPA,5)
109 IF(MSTU(10).GE.2) PM=ULMASS(KF)
110 DO 100 J=1,5
111 K(IPA,J)=0
112 P(IPA,J)=0.
113 100 V(IPA,J)=0.
114
115C...Store parton/particle in K and P vectors.
116 K(IPA,1)=1
117 IF(IP.LT.0) K(IPA,1)=2
118 K(IPA,2)=KF
119 P(IPA,5)=PM
120 P(IPA,4)=MAX(PE,PM)
121 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
122 P(IPA,1)=PA*SIN(THE)*COS(PHI)
123 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
124 P(IPA,3)=PA*COS(THE)
125
126C...Set N. Optionally fragment/decay.
127 N=IPA
128 IF(IP.EQ.0) CALL LUEXEC
129
130 RETURN
131 END
132
133C*********************************************************************
134
135 SUBROUTINE LU2ENT(IP,KF1,KF2,PECM)
136
137C...Purpose: to store two partons/particles in their CM frame,
138C...with the first along the +z axis.
139 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
140 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
141 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
142 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
143
144C...Standard checks.
145 MSTU(28)=0
146 IF(MSTU(12).GE.1) CALL LULIST(0)
147 IPA=MAX(1,IABS(IP))
148 IF(IPA.GT.MSTU(4)-1) CALL LUERRM(21,
149 &'(LU2ENT:) writing outside LUJETS memory')
150 KC1=LUCOMP(KF1)
151 KC2=LUCOMP(KF2)
152 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL LUERRM(12,
153 &'(LU2ENT:) unknown flavour code')
154
155C...Find masses. Reset K, P and V vectors.
156 PM1=0.
157 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
158 IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
159 PM2=0.
160 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
161 IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
162 DO 100 I=IPA,IPA+1
163 DO 100 J=1,5
164 K(I,J)=0
165 P(I,J)=0.
166 100 V(I,J)=0.
167
168C...Check flavours.
169 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
170 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
171 IF(MSTU(19).EQ.1) THEN
172 MSTU(19)=0
173 ELSE
174 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL LUERRM(2,
175 & '(LU2ENT:) unphysical flavour combination')
176 ENDIF
177 K(IPA,2)=KF1
178 K(IPA+1,2)=KF2
179
180C...Store partons/particles in K vectors for normal case.
181 IF(IP.GE.0) THEN
182 K(IPA,1)=1
183 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
184 K(IPA+1,1)=1
185
186C...Store partons in K vectors for parton shower evolution.
187 ELSE
188 K(IPA,1)=3
189 K(IPA+1,1)=3
190 K(IPA,4)=MSTU(5)*(IPA+1)
191 K(IPA,5)=K(IPA,4)
192 K(IPA+1,4)=MSTU(5)*IPA
193 K(IPA+1,5)=K(IPA+1,4)
194 ENDIF
195
196C...Check kinematics and store partons/particles in P vectors.
197 IF(PECM.LE.PM1+PM2) CALL LUERRM(13,
198 &'(LU2ENT:) energy smaller than sum of masses')
199 PA=SQRT(MAX(0.,(PECM**2-PM1**2-PM2**2)**2-(2.*PM1*PM2)**2))/
200 &(2.*PECM)
201 P(IPA,3)=PA
202 P(IPA,4)=SQRT(PM1**2+PA**2)
203 P(IPA,5)=PM1
204 P(IPA+1,3)=-PA
205 P(IPA+1,4)=SQRT(PM2**2+PA**2)
206 P(IPA+1,5)=PM2
207
208C...Set N. Optionally fragment/decay.
209 N=IPA+1
210 IF(IP.EQ.0) CALL LUEXEC
211
212 RETURN
213 END
214
215C*********************************************************************
216
217 SUBROUTINE LU3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
218
219C...Purpose: to store three partons or particles in their CM frame,
220C...with the first along the +z axis and the third in the (x,z)
221C...plane with x > 0.
222 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
223 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
224 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
225 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
226
227C...Standard checks.
228 MSTU(28)=0
229 IF(MSTU(12).GE.1) CALL LULIST(0)
230 IPA=MAX(1,IABS(IP))
231 IF(IPA.GT.MSTU(4)-2) CALL LUERRM(21,
232 &'(LU3ENT:) writing outside LUJETS memory')
233 KC1=LUCOMP(KF1)
234 KC2=LUCOMP(KF2)
235 KC3=LUCOMP(KF3)
236 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL LUERRM(12,
237 &'(LU3ENT:) unknown flavour code')
238
239C...Find masses. Reset K, P and V vectors.
240 PM1=0.
241 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
242 IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
243 PM2=0.
244 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
245 IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
246 PM3=0.
247 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
248 IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
249 DO 100 I=IPA,IPA+2
250 DO 100 J=1,5
251 K(I,J)=0
252 P(I,J)=0.
253 100 V(I,J)=0.
254
255C...Check flavours.
256 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
257 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
258 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
259 IF(MSTU(19).EQ.1) THEN
260 MSTU(19)=0
261 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
262 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
263 &KQ1+KQ3.EQ.4)) THEN
264 ELSE
265 CALL LUERRM(2,'(LU3ENT:) unphysical flavour combination')
266 ENDIF
267 K(IPA,2)=KF1
268 K(IPA+1,2)=KF2
269 K(IPA+2,2)=KF3
270
271C...Store partons/particles in K vectors for normal case.
272 IF(IP.GE.0) THEN
273 K(IPA,1)=1
274 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
275 K(IPA+1,1)=1
276 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
277 K(IPA+2,1)=1
278
279C...Store partons in K vectors for parton shower evolution.
280 ELSE
281 K(IPA,1)=3
282 K(IPA+1,1)=3
283 K(IPA+2,1)=3
284 KCS=4
285 IF(KQ1.EQ.-1) KCS=5
286 K(IPA,KCS)=MSTU(5)*(IPA+1)
287 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
288 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
289 K(IPA+1,9-KCS)=MSTU(5)*IPA
290 K(IPA+2,KCS)=MSTU(5)*IPA
291 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
292 ENDIF
293
294C...Check kinematics.
295 MKERR=0
296 IF(0.5*X1*PECM.LE.PM1.OR.0.5*(2.-X1-X3)*PECM.LE.PM2.OR.
297 &0.5*X3*PECM.LE.PM3) MKERR=1
298 PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
299 PA2=SQRT(MAX(1E-10,(0.5*(2.-X1-X3)*PECM)**2-PM2**2))
300 PA3=SQRT(MAX(1E-10,(0.5*X3*PECM)**2-PM3**2))
301 CTHE2=(PA3**2-PA1**2-PA2**2)/(2.*PA1*PA2)
302 CTHE3=(PA2**2-PA1**2-PA3**2)/(2.*PA1*PA3)
303 IF(ABS(CTHE2).GE.1.001.OR.ABS(CTHE3).GE.1.001) MKERR=1
304 CTHE3=MAX(-1.,MIN(1.,CTHE3))
305 IF(MKERR.NE.0) CALL LUERRM(13,
306 &'(LU3ENT:) unphysical kinematical variable setup')
307
308C...Store partons/particles in P vectors.
309 P(IPA,3)=PA1
310 P(IPA,4)=SQRT(PA1**2+PM1**2)
311 P(IPA,5)=PM1
312 P(IPA+2,1)=PA3*SQRT(1.-CTHE3**2)
313 P(IPA+2,3)=PA3*CTHE3
314 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
315 P(IPA+2,5)=PM3
316 P(IPA+1,1)=-P(IPA+2,1)
317 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
318 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
319 P(IPA+1,5)=PM2
320
321C...Set N. Optionally fragment/decay.
322 N=IPA+2
323 IF(IP.EQ.0) CALL LUEXEC
324
325 RETURN
326 END
327
328C*********************************************************************
329
330 SUBROUTINE LU4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
331
332C...Purpose: to store four partons or particles in their CM frame, with
333C...the first along the +z axis, the last in the xz plane with x > 0
334C...and the second having y < 0 and y > 0 with equal probability.
335 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
336 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
337 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
338 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
339
340C...Standard checks.
341 MSTU(28)=0
342 IF(MSTU(12).GE.1) CALL LULIST(0)
343 IPA=MAX(1,IABS(IP))
344 IF(IPA.GT.MSTU(4)-3) CALL LUERRM(21,
345 &'(LU4ENT:) writing outside LUJETS momory')
346 KC1=LUCOMP(KF1)
347 KC2=LUCOMP(KF2)
348 KC3=LUCOMP(KF3)
349 KC4=LUCOMP(KF4)
350 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL LUERRM(12,
351 &'(LU4ENT:) unknown flavour code')
352
353C...Find masses. Reset K, P and V vectors.
354 PM1=0.
355 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
356 IF(MSTU(10).GE.2) PM1=ULMASS(KF1)
357 PM2=0.
358 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
359 IF(MSTU(10).GE.2) PM2=ULMASS(KF2)
360 PM3=0.
361 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
362 IF(MSTU(10).GE.2) PM3=ULMASS(KF3)
363 PM4=0.
364 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
365 IF(MSTU(10).GE.2) PM4=ULMASS(KF4)
366 DO 100 I=IPA,IPA+3
367 DO 100 J=1,5
368 K(I,J)=0
369 P(I,J)=0.
370 100 V(I,J)=0.
371
372C...Check flavours.
373 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
374 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
375 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
376 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
377 IF(MSTU(19).EQ.1) THEN
378 MSTU(19)=0
379 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
380 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
381 &KQ1+KQ4.EQ.4)) THEN
382 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0.)
383 &THEN
384 ELSE
385 CALL LUERRM(2,'(LU4ENT:) unphysical flavour combination')
386 ENDIF
387 K(IPA,2)=KF1
388 K(IPA+1,2)=KF2
389 K(IPA+2,2)=KF3
390 K(IPA+3,2)=KF4
391
392C...Store partons/particles in K vectors for normal case.
393 IF(IP.GE.0) THEN
394 K(IPA,1)=1
395 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
396 K(IPA+1,1)=1
397 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
398 & K(IPA+1,1)=2
399 K(IPA+2,1)=1
400 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
401 K(IPA+3,1)=1
402
403C...Store partons for parton shower evolution from q-g-g-qbar or
404C...g-g-g-g event.
405 ELSEIF(KQ1+KQ2.NE.0) THEN
406 K(IPA,1)=3
407 K(IPA+1,1)=3
408 K(IPA+2,1)=3
409 K(IPA+3,1)=3
410 KCS=4
411 IF(KQ1.EQ.-1) KCS=5
412 K(IPA,KCS)=MSTU(5)*(IPA+1)
413 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
414 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
415 K(IPA+1,9-KCS)=MSTU(5)*IPA
416 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
417 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
418 K(IPA+3,KCS)=MSTU(5)*IPA
419 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
420
421C...Store partons for parton shower evolution from q-qbar-q-qbar event.
422 ELSE
423 K(IPA,1)=3
424 K(IPA+1,1)=3
425 K(IPA+2,1)=3
426 K(IPA+3,1)=3
427 K(IPA,4)=MSTU(5)*(IPA+1)
428 K(IPA,5)=K(IPA,4)
429 K(IPA+1,4)=MSTU(5)*IPA
430 K(IPA+1,5)=K(IPA+1,4)
431 K(IPA+2,4)=MSTU(5)*(IPA+3)
432 K(IPA+2,5)=K(IPA+2,4)
433 K(IPA+3,4)=MSTU(5)*(IPA+2)
434 K(IPA+3,5)=K(IPA+3,4)
435 ENDIF
436
437C...Check kinematics.
438 MKERR=0
439 IF(0.5*X1*PECM.LE.PM1.OR.0.5*X2*PECM.LE.PM2.OR.0.5*(2.-X1-X2-X4)*
440 &PECM.LE.PM3.OR.0.5*X4*PECM.LE.PM4) MKERR=1
441 PA1=SQRT(MAX(1E-10,(0.5*X1*PECM)**2-PM1**2))
442 PA2=SQRT(MAX(1E-10,(0.5*X2*PECM)**2-PM2**2))
443 PA4=SQRT(MAX(1E-10,(0.5*X4*PECM)**2-PM4**2))
444 X24=X1+X2+X4-1.-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
445 CTHE4=(X1*X4-2.*X14)*PECM**2/(4.*PA1*PA4)
446 IF(ABS(CTHE4).GE.1.002) MKERR=1
447 CTHE4=MAX(-1.,MIN(1.,CTHE4))
448 STHE4=SQRT(1.-CTHE4**2)
449 CTHE2=(X1*X2-2.*X12)*PECM**2/(4.*PA1*PA2)
450 IF(ABS(CTHE2).GE.1.002) MKERR=1
451 CTHE2=MAX(-1.,MIN(1.,CTHE2))
452 STHE2=SQRT(1.-CTHE2**2)
453 CPHI2=((X2*X4-2.*X24)*PECM**2-4.*PA2*CTHE2*PA4*CTHE4)/
454 &MAX(1E-8*PECM**2,4.*PA2*STHE2*PA4*STHE4)
455 IF(ABS(CPHI2).GE.1.05) MKERR=1
456 CPHI2=MAX(-1.,MIN(1.,CPHI2))
457 IF(MKERR.EQ.1) CALL LUERRM(13,
458 &'(LU4ENT:) unphysical kinematical variable setup')
459
460C...Store partons/particles in P vectors.
461 P(IPA,3)=PA1
462 P(IPA,4)=SQRT(PA1**2+PM1**2)
463 P(IPA,5)=PM1
464 P(IPA+3,1)=PA4*STHE4
465 P(IPA+3,3)=PA4*CTHE4
466 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
467 P(IPA+3,5)=PM4
468 P(IPA+1,1)=PA2*STHE2*CPHI2
469 P(IPA+1,2)=PA2*STHE2*SQRT(1.-CPHI2**2)*(-1.)**INT(RLU(0)+0.5)
470 P(IPA+1,3)=PA2*CTHE2
471 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
472 P(IPA+1,5)=PM2
473 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
474 P(IPA+2,2)=-P(IPA+1,2)
475 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
476 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
477 P(IPA+2,5)=PM3
478
479C...Set N. Optionally fragment/decay.
480 N=IPA+3
481 IF(IP.EQ.0) CALL LUEXEC
482
483 RETURN
484 END
485
486C*********************************************************************
487
488 SUBROUTINE LUJOIN(NJOIN,IJOIN)
489
490C...Purpose: to connect a sequence of partons with colour flow indices,
491C...as required for subsequent shower evolution (or other operations).
492 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
493 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
494 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
495 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
496 DIMENSION IJOIN(*)
497
498C...Check that partons are of right types to be connected.
499 IF(NJOIN.LT.2) GOTO 120
500 KQSUM=0
501 DO 100 IJN=1,NJOIN
502 I=IJOIN(IJN)
503 IF(I.LE.0.OR.I.GT.N) GOTO 120
504 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
505 KC=LUCOMP(K(I,2))
506 IF(KC.EQ.0) GOTO 120
507 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
508 IF(KQ.EQ.0) GOTO 120
509 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
510 IF(KQ.NE.2) KQSUM=KQSUM+KQ
511 100 IF(IJN.EQ.1) KQS=KQ
512 IF(KQSUM.NE.0) GOTO 120
513
514C...Connect the partons sequentially (closing for gluon loop).
515 KCS=(9-KQS)/2
516 IF(KQS.EQ.2) KCS=INT(4.5+RLU(0))
517 DO 110 IJN=1,NJOIN
518 I=IJOIN(IJN)
519 K(I,1)=3
520 IF(IJN.NE.1) IP=IJOIN(IJN-1)
521 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
522 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
523 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
524 K(I,KCS)=MSTU(5)*IN
525 K(I,9-KCS)=MSTU(5)*IP
526 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
527 110 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
528
529C...Error exit: no action taken.
530 RETURN
531 120 CALL LUERRM(12,
532 &'(LUJOIN:) given entries can not be joined by one string')
533
534 RETURN
535 END
536
537C*********************************************************************
538
539 SUBROUTINE LUGIVE(CHIN)
540
541C...Purpose: to set values of commonblock variables (also in PYTHIA!).
542 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
543 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
544 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
545 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
546 COMMON/LUDAT4/CHAF(500)
547 CHARACTER CHAF*8
548 COMMON/LUDATR/MRLU(6),RRLU(100)
549 COMMON/PYSUBS/MSEL,MSUB(200),KFIN(2,-40:40),CKIN(200)
550 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
551 COMMON/PYINT1/MINT(400),VINT(400)
552 COMMON/PYINT2/ISET(200),KFPR(200,2),COEF(200,20),ICOL(40,4,2)
553 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
554 COMMON/PYINT4/WIDP(21:40,0:40),WIDE(21:40,0:40),WIDS(21:40,3)
555 COMMON/PYINT5/NGEN(0:200,3),XSEC(0:200,3)
556 COMMON/PYINT6/PROC(0:200)
557 CHARACTER PROC*28
558 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/,/LUDATR/
559 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
560 &/PYINT5/,/PYINT6/
561 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
562 &CHNEW2*28,CHNAM*4,CHVAR(42)*4,CHALP(2)*26,CHIND*8,CHINI*10,
563 &CHINR*16
564 DIMENSION MSVAR(42,8)
565
566C...For each variable to be translated give: name,
567C...integer/real/character, no. of indices, lower&upper index bounds.
568 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
569 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU',
570 &'RRLU','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
571 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
572 &'WIDP','WIDE','WIDS','NGEN','XSEC','PROC'/
573 DATA ((MSVAR(I,J),J=1,8),I=1,42)/ 1,7*0, 1,2,1,4000,1,5,2*0,
574 & 2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
575 & 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
576 & 1,2,1,500,1,3,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
577 & 2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,2000,1,2,2*0,
578 & 2,1,1,2000,4*0, 1,2,1,2000,1,5,2*0, 3,1,1,500,4*0,
579 & 1,1,1,6,4*0, 2,1,1,100,4*0,
580 & 1,7*0, 1,1,1,200,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
581 & 1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
582 & 1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,200,4*0,
583 & 1,2,1,200,1,2,2*0, 2,2,1,200,1,20,2*0, 1,3,1,40,1,4,1,2,
584 & 2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
585 & 2,2,21,40,0,40,2*0, 2,2,21,40,0,40,2*0, 2,2,21,40,1,3,2*0,
586 & 1,2,0,200,1,3,2*0, 2,2,0,200,1,3,2*0, 4,1,0,200,4*0/
587 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
588 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
589
590C...Length of character variable. Subdivide it into instructions.
591 IF(MSTU(12).GE.1) CALL LULIST(0)
592 CHBIT=CHIN//' '
593 LBIT=101
594 100 LBIT=LBIT-1
595 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
596 LTOT=0
597 DO 110 LCOM=1,LBIT
598 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
599 LTOT=LTOT+1
600 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
601 110 CONTINUE
602 LLOW=0
603 120 LHIG=LLOW+1
604 130 LHIG=LHIG+1
605 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
606 LBIT=LHIG-LLOW-1
607 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
608
609C...Identify commonblock variable.
610 LNAM=1
611 140 LNAM=LNAM+1
612 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
613 &LNAM.LE.4) GOTO 140
614 CHNAM=CHBIT(1:LNAM-1)//' '
615 DO 150 LCOM=1,LNAM-1
616 DO 150 LALP=1,26
617 150 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
618 &CHALP(2)(LALP:LALP)
619 IVAR=0
620 DO 160 IV=1,42
621 160 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
622 IF(IVAR.EQ.0) THEN
623 CALL LUERRM(18,'(LUGIVE:) do not recognize variable '//CHNAM)
624 LLOW=LHIG
625 IF(LLOW.LT.LTOT) GOTO 120
626 RETURN
627 ENDIF
628
629C...Identify any indices.
630 I1=0
631 I2=0
632 I3=0
633 NINDX=0
634 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
635 LIND=LNAM
636 170 LIND=LIND+1
637 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 170
638 CHIND=' '
639 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c').
640 & AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) THEN
641 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
642 READ(CHIND,'(I8)') KF
643 I1=LUCOMP(KF)
644 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
645 & 'c') THEN
646 CALL LUERRM(18,'(LUGIVE:) not allowed to use C index for '//
647 & CHNAM)
648 LLOW=LHIG
649 IF(LLOW.LT.LTOT) GOTO 120
650 RETURN
651 ELSE
652 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
653 READ(CHIND,'(I8)') I1
654 ENDIF
655 LNAM=LIND
656 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
657 NINDX=1
658 ENDIF
659 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
660 LIND=LNAM
661 180 LIND=LIND+1
662 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
663 CHIND=' '
664 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
665 READ(CHIND,'(I8)') I2
666 LNAM=LIND
667 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
668 NINDX=2
669 ENDIF
670 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
671 LIND=LNAM
672 190 LIND=LIND+1
673 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
674 CHIND=' '
675 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
676 READ(CHIND,'(I8)') I3
677 LNAM=LIND+1
678 NINDX=3
679 ENDIF
680
681C...Check that indices allowed.
682 IERR=0
683 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
684 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
685 &IERR=2
686 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
687 &IERR=3
688 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
689 &IERR=4
690 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
691 IF(IERR.GE.1) THEN
692 CALL LUERRM(18,'(LUGIVE:) unallowed indices for '//
693 & CHBIT(1:LNAM-1))
694 LLOW=LHIG
695 IF(LLOW.LT.LTOT) GOTO 120
696 RETURN
697 ENDIF
698
699C...Save old value of variable.
700 IF(IVAR.EQ.1) THEN
701 IOLD=N
702 ELSEIF(IVAR.EQ.2) THEN
703 IOLD=K(I1,I2)
704 ELSEIF(IVAR.EQ.3) THEN
705 ROLD=P(I1,I2)
706 ELSEIF(IVAR.EQ.4) THEN
707 ROLD=V(I1,I2)
708 ELSEIF(IVAR.EQ.5) THEN
709 IOLD=MSTU(I1)
710 ELSEIF(IVAR.EQ.6) THEN
711 ROLD=PARU(I1)
712 ELSEIF(IVAR.EQ.7) THEN
713 IOLD=MSTJ(I1)
714 ELSEIF(IVAR.EQ.8) THEN
715 ROLD=PARJ(I1)
716 ELSEIF(IVAR.EQ.9) THEN
717 IOLD=KCHG(I1,I2)
718 ELSEIF(IVAR.EQ.10) THEN
719 ROLD=PMAS(I1,I2)
720 ELSEIF(IVAR.EQ.11) THEN
721 ROLD=PARF(I1)
722 ELSEIF(IVAR.EQ.12) THEN
723 ROLD=VCKM(I1,I2)
724 ELSEIF(IVAR.EQ.13) THEN
725 IOLD=MDCY(I1,I2)
726 ELSEIF(IVAR.EQ.14) THEN
727 IOLD=MDME(I1,I2)
728 ELSEIF(IVAR.EQ.15) THEN
729 ROLD=BRAT(I1)
730 ELSEIF(IVAR.EQ.16) THEN
731 IOLD=KFDP(I1,I2)
732 ELSEIF(IVAR.EQ.17) THEN
733 CHOLD=CHAF(I1)
734 ELSEIF(IVAR.EQ.18) THEN
735 IOLD=MRLU(I1)
736 ELSEIF(IVAR.EQ.19) THEN
737 ROLD=RRLU(I1)
738 ELSEIF(IVAR.EQ.20) THEN
739 IOLD=MSEL
740 ELSEIF(IVAR.EQ.21) THEN
741 IOLD=MSUB(I1)
742 ELSEIF(IVAR.EQ.22) THEN
743 IOLD=KFIN(I1,I2)
744 ELSEIF(IVAR.EQ.23) THEN
745 ROLD=CKIN(I1)
746 ELSEIF(IVAR.EQ.24) THEN
747 IOLD=MSTP(I1)
748 ELSEIF(IVAR.EQ.25) THEN
749 ROLD=PARP(I1)
750 ELSEIF(IVAR.EQ.26) THEN
751 IOLD=MSTI(I1)
752 ELSEIF(IVAR.EQ.27) THEN
753 ROLD=PARI(I1)
754 ELSEIF(IVAR.EQ.28) THEN
755 IOLD=MINT(I1)
756 ELSEIF(IVAR.EQ.29) THEN
757 ROLD=VINT(I1)
758 ELSEIF(IVAR.EQ.30) THEN
759 IOLD=ISET(I1)
760 ELSEIF(IVAR.EQ.31) THEN
761 IOLD=KFPR(I1,I2)
762 ELSEIF(IVAR.EQ.32) THEN
763 ROLD=COEF(I1,I2)
764 ELSEIF(IVAR.EQ.33) THEN
765 IOLD=ICOL(I1,I2,I3)
766 ELSEIF(IVAR.EQ.34) THEN
767 ROLD=XSFX(I1,I2)
768 ELSEIF(IVAR.EQ.35) THEN
769 IOLD=ISIG(I1,I2)
770 ELSEIF(IVAR.EQ.36) THEN
771 ROLD=SIGH(I1)
772 ELSEIF(IVAR.EQ.37) THEN
773 ROLD=WIDP(I1,I2)
774 ELSEIF(IVAR.EQ.38) THEN
775 ROLD=WIDE(I1,I2)
776 ELSEIF(IVAR.EQ.39) THEN
777 ROLD=WIDS(I1,I2)
778 ELSEIF(IVAR.EQ.40) THEN
779 IOLD=NGEN(I1,I2)
780 ELSEIF(IVAR.EQ.41) THEN
781 ROLD=XSEC(I1,I2)
782 ELSEIF(IVAR.EQ.42) THEN
783 CHOLD2=PROC(I1)
784 ENDIF
785
786C...Print current value of variable. Loop back.
787 IF(LNAM.GE.LBIT) THEN
788 CHBIT(LNAM:14)=' '
789 CHBIT(15:60)=' has the value '
790 IF(MSVAR(IVAR,1).EQ.1) THEN
791 WRITE(CHBIT(51:60),'(I10)') IOLD
792 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
793 WRITE(CHBIT(47:60),'(F14.5)') ROLD
794 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
795 CHBIT(53:60)=CHOLD
796 ELSE
797 CHBIT(33:60)=CHOLD
798 ENDIF
799 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
800 LLOW=LHIG
801 IF(LLOW.LT.LTOT) GOTO 120
802 RETURN
803 ENDIF
804
805C...Read in new variable value.
806 IF(MSVAR(IVAR,1).EQ.1) THEN
807 CHINI=' '
808 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
809 READ(CHINI,'(I10)') INEW
810 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
811 CHINR=' '
812 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
813 READ(CHINR,'(F16.2)') RNEW
814 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
815 CHNEW=CHBIT(LNAM+1:LBIT)//' '
816 ELSE
817 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
818 ENDIF
819
820C...Store new variable value.
821 IF(IVAR.EQ.1) THEN
822 N=INEW
823 ELSEIF(IVAR.EQ.2) THEN
824 K(I1,I2)=INEW
825 ELSEIF(IVAR.EQ.3) THEN
826 P(I1,I2)=RNEW
827 ELSEIF(IVAR.EQ.4) THEN
828 V(I1,I2)=RNEW
829 ELSEIF(IVAR.EQ.5) THEN
830 MSTU(I1)=INEW
831 ELSEIF(IVAR.EQ.6) THEN
832 PARU(I1)=RNEW
833 ELSEIF(IVAR.EQ.7) THEN
834 MSTJ(I1)=INEW
835 ELSEIF(IVAR.EQ.8) THEN
836 PARJ(I1)=RNEW
837 ELSEIF(IVAR.EQ.9) THEN
838 KCHG(I1,I2)=INEW
839 ELSEIF(IVAR.EQ.10) THEN
840 PMAS(I1,I2)=RNEW
841 ELSEIF(IVAR.EQ.11) THEN
842 PARF(I1)=RNEW
843 ELSEIF(IVAR.EQ.12) THEN
844 VCKM(I1,I2)=RNEW
845 ELSEIF(IVAR.EQ.13) THEN
846 MDCY(I1,I2)=INEW
847 ELSEIF(IVAR.EQ.14) THEN
848 MDME(I1,I2)=INEW
849 ELSEIF(IVAR.EQ.15) THEN
850 BRAT(I1)=RNEW
851 ELSEIF(IVAR.EQ.16) THEN
852 KFDP(I1,I2)=INEW
853 ELSEIF(IVAR.EQ.17) THEN
854 CHAF(I1)=CHNEW
855 ELSEIF(IVAR.EQ.18) THEN
856 MRLU(I1)=INEW
857 ELSEIF(IVAR.EQ.19) THEN
858 RRLU(I1)=RNEW
859 ELSEIF(IVAR.EQ.20) THEN
860 MSEL=INEW
861 ELSEIF(IVAR.EQ.21) THEN
862 MSUB(I1)=INEW
863 ELSEIF(IVAR.EQ.22) THEN
864 KFIN(I1,I2)=INEW
865 ELSEIF(IVAR.EQ.23) THEN
866 CKIN(I1)=RNEW
867 ELSEIF(IVAR.EQ.24) THEN
868 MSTP(I1)=INEW
869 ELSEIF(IVAR.EQ.25) THEN
870 PARP(I1)=RNEW
871 ELSEIF(IVAR.EQ.26) THEN
872 MSTI(I1)=INEW
873 ELSEIF(IVAR.EQ.27) THEN
874 PARI(I1)=RNEW
875 ELSEIF(IVAR.EQ.28) THEN
876 MINT(I1)=INEW
877 ELSEIF(IVAR.EQ.29) THEN
878 VINT(I1)=RNEW
879 ELSEIF(IVAR.EQ.30) THEN
880 ISET(I1)=INEW
881 ELSEIF(IVAR.EQ.31) THEN
882 KFPR(I1,I2)=INEW
883 ELSEIF(IVAR.EQ.32) THEN
884 COEF(I1,I2)=RNEW
885 ELSEIF(IVAR.EQ.33) THEN
886 ICOL(I1,I2,I3)=INEW
887 ELSEIF(IVAR.EQ.34) THEN
888 XSFX(I1,I2)=RNEW
889 ELSEIF(IVAR.EQ.35) THEN
890 ISIG(I1,I2)=INEW
891 ELSEIF(IVAR.EQ.36) THEN
892 SIGH(I1)=RNEW
893 ELSEIF(IVAR.EQ.37) THEN
894 WIDP(I1,I2)=RNEW
895 ELSEIF(IVAR.EQ.38) THEN
896 WIDE(I1,I2)=RNEW
897 ELSEIF(IVAR.EQ.39) THEN
898 WIDS(I1,I2)=RNEW
899 ELSEIF(IVAR.EQ.40) THEN
900 NGEN(I1,I2)=INEW
901 ELSEIF(IVAR.EQ.41) THEN
902 XSEC(I1,I2)=RNEW
903 ELSEIF(IVAR.EQ.42) THEN
904 PROC(I1)=CHNEW2
905 ENDIF
906
907C...Write old and new value. Loop back.
908 CHBIT(LNAM:14)=' '
909 CHBIT(15:60)=' changed from to '
910 IF(MSVAR(IVAR,1).EQ.1) THEN
911 WRITE(CHBIT(33:42),'(I10)') IOLD
912 WRITE(CHBIT(51:60),'(I10)') INEW
913 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
914 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
915 WRITE(CHBIT(29:42),'(F14.5)') ROLD
916 WRITE(CHBIT(47:60),'(F14.5)') RNEW
917 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
918 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
919 CHBIT(35:42)=CHOLD
920 CHBIT(53:60)=CHNEW
921 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
922 ELSE
923 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
924 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
925 ENDIF
926 LLOW=LHIG
927 IF(LLOW.LT.LTOT) GOTO 120
928
929C...Format statement for output on unit MSTU(11) (by default 6).
930 5000 FORMAT(5X,A60)
931 5100 FORMAT(5X,A88)
932
933 RETURN
934 END
935
936C*********************************************************************
937
938 SUBROUTINE LUEXEC
939
940C...Purpose: to administrate the fragmentation and decay chain.
941 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
942 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
943 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
944 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
945 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
946 DIMENSION PS(2,6)
947
948C...Initialize and reset.
949 MSTU(24)=0
950 IF(MSTU(12).GE.1) CALL LULIST(0)
951 MSTU(31)=MSTU(31)+1
952 MSTU(1)=0
953 MSTU(2)=0
954 MSTU(3)=0
955 IF(MSTU(17).LE.0) MSTU(90)=0
956 MCONS=1
957
958C...Sum up momentum, energy and charge for starting entries.
959 NSAV=N
960 DO 100 I=1,2
961 DO 100 J=1,6
962 100 PS(I,J)=0.
963 DO 120 I=1,N
964 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
965 DO 110 J=1,4
966 110 PS(1,J)=PS(1,J)+P(I,J)
967 PS(1,6)=PS(1,6)+LUCHGE(K(I,2))
968 120 CONTINUE
969 PARU(21)=PS(1,4)
970
971C...Prepare system for subsequent fragmentation/decay.
972 CALL LUPREP(0)
973
974C...Loop through jet fragmentation and particle decays.
975 MBE=0
976 130 MBE=MBE+1
977 IP=0
978 140 IP=IP+1
979 KC=0
980 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=LUCOMP(K(IP,2))
981 IF(KC.EQ.0) THEN
982
983C...Particle decay if unstable and allowed. Save long-lived particle
984C...decays until second pass after Bose-Einstein effects.
985 ELSEIF(KCHG(KC,2).EQ.0) THEN
986 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE.
987 & EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
988 & CALL LUDECY(IP)
989
990C...Decay products may develop a shower.
991 IF(MSTJ(92).GT.0) THEN
992 IP1=MSTJ(92)
993 QMAX=SQRT(MAX(0.,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
994 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
995 CALL LUSHOW(IP1,IP1+1,QMAX)
996 CALL LUPREP(IP1)
997 MSTJ(92)=0
998 ELSEIF(MSTJ(92).LT.0) THEN
999 IP1=-MSTJ(92)
1000 CALL LUSHOW(IP1,-3,P(IP,5))
1001 CALL LUPREP(IP1)
1002 MSTJ(92)=0
1003 ENDIF
1004
1005C...Jet fragmentation: string or independent fragmentation.
1006 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
1007 MFRAG=MSTJ(1)
1008 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
1009 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
1010 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
1011 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
1012 IF(KCHG(LUCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
1013 ENDIF
1014 ENDIF
1015 IF(MFRAG.EQ.1) CALL LUSTRF(IP)
1016 IF(MFRAG.EQ.2) CALL LUINDF(IP)
1017 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
1018 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
1019 ENDIF
1020
1021C...Loop back if enough space left in LUJETS and no error abort.
1022 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
1023 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
1024 GOTO 140
1025 ELSEIF(IP.LT.N) THEN
1026 CALL LUERRM(11,'(LUEXEC:) no more memory left in LUJETS')
1027 ENDIF
1028
1029C...Include simple Bose-Einstein effect parametrization if desired.
1030 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
1031 CALL LUBOEI(NSAV)
1032 GOTO 130
1033 ENDIF
1034
1035C...Check that momentum, energy and charge were conserved.
1036 DO 160 I=1,N
1037 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 160
1038 DO 150 J=1,4
1039 150 PS(2,J)=PS(2,J)+P(I,J)
1040 PS(2,6)=PS(2,6)+LUCHGE(K(I,2))
1041 160 CONTINUE
1042 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
1043 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1.+ABS(PS(2,4))+ABS(PS(1,4)))
1044 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL LUERRM(15,
1045 &'(LUEXEC:) four-momentum was not conserved')
1046 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1) CALL LUERRM(15,
1047 &'(LUEXEC:) charge was not conserved')
1048
1049 RETURN
1050 END
1051
1052C*********************************************************************
1053
1054 SUBROUTINE LUPREP(IP)
1055
1056C...Purpose: to rearrange partons along strings, to allow small systems
1057C...to collapse into one or two particles and to check flavours.
1058 IMPLICIT DOUBLE PRECISION(D)
1059 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
1060 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1061 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1062 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
1063 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
1064 DIMENSION DPS(5),DPC(5),UE(3)
1065
1066C...Rearrange parton shower product listing along strings: begin loop.
1067 I1=N
1068 DO 130 MQGST=1,2
1069 DO 120 I=MAX(1,IP),N
1070 IF(K(I,1).NE.3) GOTO 120
1071 KC=LUCOMP(K(I,2))
1072 IF(KC.EQ.0) GOTO 120
1073 KQ=KCHG(KC,2)
1074 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
1075
1076C...Pick up loose string end.
1077 KCS=4
1078 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
1079 IA=I
1080 NSTP=0
1081 100 NSTP=NSTP+1
1082 IF(NSTP.GT.4*N) THEN
1083 CALL LUERRM(14,'(LUPREP:) caught in infinite loop')
1084 RETURN
1085 ENDIF
1086
1087C...Copy undecayed parton.
1088 IF(K(IA,1).EQ.3) THEN
1089 IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
1090 CALL LUERRM(11,'(LUPREP:) no more memory left in LUJETS')
1091 RETURN
1092 ENDIF
1093 I1=I1+1
1094 K(I1,1)=2
1095 IF(NSTP.GE.2.AND.IABS(K(IA,2)).NE.21) K(I1,1)=1
1096 K(I1,2)=K(IA,2)
1097 K(I1,3)=IA
1098 K(I1,4)=0
1099 K(I1,5)=0
1100 DO 110 J=1,5
1101 P(I1,J)=P(IA,J)
1102 110 V(I1,J)=V(IA,J)
1103 K(IA,1)=K(IA,1)+10
1104 IF(K(I1,1).EQ.1) GOTO 120
1105 ENDIF
1106
1107C...Go to next parton in colour space.
1108 IB=IA
1109 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)).
1110 &NE.0) THEN
1111 IA=MOD(K(IB,KCS),MSTU(5))
1112 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
1113 MREV=0
1114 ELSE
1115 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),MSTU(5)).
1116 & EQ.0) KCS=9-KCS
1117 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
1118 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
1119 MREV=1
1120 ENDIF
1121 IF(IA.LE.0.OR.IA.GT.N) THEN
1122 CALL LUERRM(12,'(LUPREP:) colour rearrangement failed')
1123 RETURN
1124 ENDIF
1125 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
1126 &MSTU(5)).EQ.IB) THEN
1127 IF(MREV.EQ.1) KCS=9-KCS
1128 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
1129 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
1130 ELSE
1131 IF(MREV.EQ.0) KCS=9-KCS
1132 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
1133 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
1134 ENDIF
1135 IF(IA.NE.I) GOTO 100
1136 K(I1,1)=1
1137 120 CONTINUE
1138 130 CONTINUE
1139 N=I1
1140 IF(MSTJ(14).LT.0) RETURN
1141
1142C...Find lowest-mass colour singlet jet system, OK if above threshold.
1143 IF(MSTJ(14).EQ.0) GOTO 320
1144 NS=N
1145 140 NSIN=N-NS
1146 PDM=1.+PARJ(32)
1147 IC=0
1148 DO 190 I=MAX(1,IP),NS
1149 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
1150 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
1151 NSIN=NSIN+1
1152 IC=I
1153 DO 150 J=1,4
1154 150 DPS(J)=P(I,J)
1155 MSTJ(93)=1
1156 DPS(5)=ULMASS(K(I,2))
1157 ELSEIF(K(I,1).EQ.2) THEN
1158 DO 160 J=1,4
1159 160 DPS(J)=DPS(J)+P(I,J)
1160 ELSEIF(IC.NE.0.AND.KCHG(LUCOMP(K(I,2)),2).NE.0) THEN
1161 DO 170 J=1,4
1162 170 DPS(J)=DPS(J)+P(I,J)
1163 MSTJ(93)=1
1164 DPS(5)=DPS(5)+ULMASS(K(I,2))
1165 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-DPS(5)
1166 IF(PD.LT.PDM) THEN
1167 PDM=PD
1168 DO 180 J=1,5
1169 180 DPC(J)=DPS(J)
1170 IC1=IC
1171 IC2=I
1172 ENDIF
1173 IC=0
1174 ELSE
1175 NSIN=NSIN+1
1176 ENDIF
1177 190 CONTINUE
1178 IF(PDM.GE.PARJ(32)) GOTO 320
1179
1180C...Fill small-mass system as cluster.
1181 NSAV=N
1182 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
1183 K(N+1,1)=11
1184 K(N+1,2)=91
1185 K(N+1,3)=IC1
1186 K(N+1,4)=N+2
1187 K(N+1,5)=N+3
1188 P(N+1,1)=DPC(1)
1189 P(N+1,2)=DPC(2)
1190 P(N+1,3)=DPC(3)
1191 P(N+1,4)=DPC(4)
1192 P(N+1,5)=PECM
1193
1194C...Form two particles from flavours of lowest-mass system, if feasible.
1195 K(N+2,1)=1
1196 K(N+3,1)=1
1197 IF(MSTU(16).NE.2) THEN
1198 K(N+2,3)=N+1
1199 K(N+3,3)=N+1
1200 ELSE
1201 K(N+2,3)=IC1
1202 K(N+3,3)=IC2
1203 ENDIF
1204 K(N+2,4)=0
1205 K(N+3,4)=0
1206 K(N+2,5)=0
1207 K(N+3,5)=0
1208 IF(IABS(K(IC1,2)).NE.21) THEN
1209 KC1=LUCOMP(K(IC1,2))
1210 KC2=LUCOMP(K(IC2,2))
1211 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
1212 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
1213 KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
1214 IF(KQ1+KQ2.NE.0) GOTO 320
1215 200 CALL LUKFDI(K(IC1,2),0,KFLN,K(N+2,2))
1216 CALL LUKFDI(K(IC2,2),-KFLN,KFLDMP,K(N+3,2))
1217 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
1218 ELSE
1219 IF(IABS(K(IC2,2)).NE.21) GOTO 320
1220 210 CALL LUKFDI(1+INT((2.+PARJ(2))*RLU(0)),0,KFLN,KFDMP)
1221 CALL LUKFDI(KFLN,0,KFLM,K(N+2,2))
1222 CALL LUKFDI(-KFLN,-KFLM,KFLDMP,K(N+3,2))
1223 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
1224 ENDIF
1225 P(N+2,5)=ULMASS(K(N+2,2))
1226 P(N+3,5)=ULMASS(K(N+3,2))
1227 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
1228 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
1229
1230C...Perform two-particle decay of jet system, if possible.
1231 IF(PECM.GE.0.02*DPC(4)) THEN
1232 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
1233 & (P(N+2,5)-P(N+3,5))**2))/(2.*PECM)
1234 UE(3)=2.*RLU(0)-1.
1235 PHI=PARU(2)*RLU(0)
1236 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
1237 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
1238 DO 220 J=1,3
1239 P(N+2,J)=PA*UE(J)
1240 220 P(N+3,J)=-PA*UE(J)
1241 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
1242 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
1243 MSTU(33)=1
1244 CALL LUDBRB(N+2,N+3,0.,0.,DPC(1)/DPC(4),DPC(2)/DPC(4),
1245 & DPC(3)/DPC(4))
1246 ELSE
1247 NP=0
1248 DO 230 I=IC1,IC2
1249 230 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
1250 HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
1251 & P(IC1,3)*P(IC2,3)
1252 IF(NP.GE.3.OR.HA.LE.1.25*P(IC1,5)*P(IC2,5)) GOTO 260
1253 HD1=0.5*(P(N+2,5)**2-P(IC1,5)**2)
1254 HD2=0.5*(P(N+3,5)**2-P(IC2,5)**2)
1255 HR=SQRT(MAX(0.,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
1256 & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1.
1257 HC=P(IC1,5)**2+2.*HA+P(IC2,5)**2
1258 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
1259 HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
1260 DO 240 J=1,4
1261 P(N+2,J)=(1.+HK1)*P(IC1,J)-HK2*P(IC2,J)
1262 240 P(N+3,J)=(1.+HK2)*P(IC2,J)-HK1*P(IC1,J)
1263 ENDIF
1264 DO 250 J=1,4
1265 V(N+1,J)=V(IC1,J)
1266 V(N+2,J)=V(IC1,J)
1267 250 V(N+3,J)=V(IC2,J)
1268 V(N+1,5)=0.
1269 V(N+2,5)=0.
1270 V(N+3,5)=0.
1271 N=N+3
1272 GOTO 300
1273
1274C...Else form one particle from the flavours available, if possible.
1275 260 K(N+1,5)=N+2
1276 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
1277 GOTO 320
1278 ELSEIF(IABS(K(IC1,2)).NE.21) THEN
1279 CALL LUKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
1280 ELSE
1281 KFLN=1+INT((2.+PARJ(2))*RLU(0))
1282 CALL LUKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
1283 ENDIF
1284 IF(K(N+2,2).EQ.0) GOTO 260
1285 P(N+2,5)=ULMASS(K(N+2,2))
1286
1287C...Find parton/particle which combines to largest extra mass.
1288 IR=0
1289 HA=0.
1290 HSM=0.
1291 DO 280 MCOMB=1,3
1292 IF(IR.NE.0) GOTO 280
1293 DO 270 I=MAX(1,IP),N
1294 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2.
1295 &AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
1296 IF(MCOMB.EQ.1) KCI=LUCOMP(K(I,2))
1297 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
1298 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
1299 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
1300 &GOTO 270
1301 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
1302 HSR=2.*HCR+PECM**2-P(N+2,5)**2-2.*P(N+2,5)*P(I,5)
1303 IF(HSR.GT.HSM) THEN
1304 IR=I
1305 HA=HCR
1306 HSM=HSR
1307 ENDIF
1308 270 CONTINUE
1309 280 CONTINUE
1310
1311C...Shuffle energy and momentum to put new particle on mass shell.
1312 IF(IR.NE.0) THEN
1313 HB=PECM**2+HA
1314 HC=P(N+2,5)**2+HA
1315 HD=P(IR,5)**2+HA
1316 HK2=0.5*(HB*SQRT(MAX(0.,((HB+HC)**2-4.*(HB+HD)*P(N+2,5)**2)/
1317 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
1318 HK1=(0.5*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
1319 DO 290 J=1,4
1320 P(N+2,J)=(1.+HK1)*DPC(J)-HK2*P(IR,J)
1321 P(IR,J)=(1.+HK2)*P(IR,J)-HK1*DPC(J)
1322 V(N+1,J)=V(IC1,J)
1323 290 V(N+2,J)=V(IC1,J)
1324 V(N+1,5)=0.
1325 V(N+2,5)=0.
1326 N=N+2
1327 ELSE
1328 CALL LUERRM(3,'(LUPREP:) no match for collapsing cluster')
1329 RETURN
1330 ENDIF
1331
1332C...Mark collapsed system and store daughter pointers. Iterate.
1333 300 DO 310 I=IC1,IC2
1334 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(LUCOMP(K(I,2)),2).NE.0)
1335 &THEN
1336 K(I,1)=K(I,1)+10
1337 IF(MSTU(16).NE.2) THEN
1338 K(I,4)=NSAV+1
1339 K(I,5)=NSAV+1
1340 ELSE
1341 K(I,4)=NSAV+2
1342 K(I,5)=N
1343 ENDIF
1344 ENDIF
1345 310 CONTINUE
1346 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
1347
1348C...Check flavours and invariant masses in parton systems.
1349 320 NP=0
1350 KFN=0
1351 KQS=0
1352 DO 330 J=1,5
1353 330 DPS(J)=0.
1354 DO 360 I=MAX(1,IP),N
1355 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
1356 KC=LUCOMP(K(I,2))
1357 IF(KC.EQ.0) GOTO 360
1358 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1359 IF(KQ.EQ.0) GOTO 360
1360 NP=NP+1
1361 IF(KQ.NE.2) THEN
1362 KFN=KFN+1
1363 KQS=KQS+KQ
1364 MSTJ(93)=1
1365 DPS(5)=DPS(5)+ULMASS(K(I,2))
1366 ENDIF
1367 DO 340 J=1,4
1368 340 DPS(J)=DPS(J)+P(I,J)
1369 IF(K(I,1).EQ.1) THEN
1370 IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
1371 & LUERRM(2,'(LUPREP:) unphysical flavour combination')
1372 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
1373 & (0.9*PARJ(32)+DPS(5))**2) CALL LUERRM(3,
1374 & '(LUPREP:) too small mass in jet system')
1375 NP=0
1376 KFN=0
1377 KQS=0
1378 DO 350 J=1,5
1379 350 DPS(J)=0.
1380 ENDIF
1381 360 CONTINUE
1382
1383 RETURN
1384 END
1385
1386C*********************************************************************
1387
1388 SUBROUTINE LUSTRF(IP)
1389C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1390C...jet system according to the Lund string fragmentation model.
1391 IMPLICIT DOUBLE PRECISION(D)
1392 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
1393 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1394 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
1395 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
1396 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
1397 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
1398 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8)
1399
1400C...Function: four-product of two vectors.
1401 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)
1402 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
1403 &DP(I,3)*DP(J,3)
1404
1405C...Reset counters. Identify parton system.
1406 MSTJ(91)=0
1407 NSAV=N
1408 MSTU90=MSTU(90)
1409 NP=0
1410 KQSUM=0
1411 DO 100 J=1,5
1412 100 DPS(J)=0D0
1413 MJU(1)=0
1414 MJU(2)=0
1415 I=IP-1
1416 110 I=I+1
1417 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
1418 CALL LUERRM(12,'(LUSTRF:) failed to reconstruct jet system')
1419 IF(MSTU(21).GE.1) RETURN
1420 ENDIF
1421 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
1422 KC=LUCOMP(K(I,2))
1423 IF(KC.EQ.0) GOTO 110
1424 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
1425 IF(KQ.EQ.0) GOTO 110
1426 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
1427 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1428 IF(MSTU(21).GE.1) RETURN
1429 ENDIF
1430
1431C...Take copy of partons to be considered. Check flavour sum.
1432 NP=NP+1
1433 DO 120 J=1,5
1434 K(N+NP,J)=K(I,J)
1435 P(N+NP,J)=P(I,J)
1436 120 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
1437 DPS(4)=DPS(4)+SQRT(DBLE(P(I,1))**2+DBLE(P(I,2))**2+
1438 &DBLE(P(I,3))**2+DBLE(P(I,5))**2)
1439 K(N+NP,3)=I
1440 IF(KQ.NE.2) KQSUM=KQSUM+KQ
1441 IF(K(I,1).EQ.41) THEN
1442 KQSUM=KQSUM+2*KQ
1443 IF(KQSUM.EQ.KQ) MJU(1)=N+NP
1444 IF(KQSUM.NE.KQ) MJU(2)=N+NP
1445 ENDIF
1446 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
1447 IF(KQSUM.NE.0) THEN
1448 CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1449 IF(MSTU(21).GE.1) RETURN
1450 ENDIF
1451
1452C...Boost copied system to CM frame (for better numerical precision).
1453 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
1454 MBST=0
1455 MSTU(33)=1
1456 CALL LUDBRB(N+1,N+NP,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
1457 & -DPS(3)/DPS(4))
1458 ELSE
1459 MBST=1
1460 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
1461 DO 130 I=N+1,N+NP
1462 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
1463 IF(P(I,3).GT.0.) THEN
1464 HHPEZ=(P(I,4)+P(I,3))/HHBZ
1465 P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
1466 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1467 ELSE
1468 HHPEZ=(P(I,4)-P(I,3))*HHBZ
1469 P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
1470 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
1471 ENDIF
1472 130 CONTINUE
1473 ENDIF
1474
1475C...Search for very nearby partons that may be recombined.
1476 NTRYR=0
1477 PARU12=PARU(12)
1478 PARU13=PARU(13)
1479 MJU(3)=MJU(1)
1480 MJU(4)=MJU(2)
1481 NR=NP
1482 140 IF(NR.GE.3) THEN
1483 PDRMIN=2.*PARU12
1484 DO 150 I=N+1,N+NR
1485 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
1486 I1=I+1
1487 IF(I.EQ.N+NR) I1=N+1
1488 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
1489 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
1490 & GOTO 150
1491 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) GOTO 150
1492 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
1493 & P(I1,2)**2+P(I1,3)**2))
1494 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
1495 PDR=4.*(PAP-PVP)**2/MAX(1E-6,PARU13**2*PAP+2.*(PAP-PVP))
1496 IF(PDR.LT.PDRMIN) THEN
1497 IR=I
1498 PDRMIN=PDR
1499 ENDIF
1500 150 CONTINUE
1501
1502C...Recombine very nearby partons to avoid machine precision problems.
1503 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
1504 DO 160 J=1,4
1505 160 P(N+1,J)=P(N+1,J)+P(N+NR,J)
1506 P(N+1,5)=SQRT(MAX(0.,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
1507 & P(N+1,3)**2))
1508 NR=NR-1
1509 GOTO 140
1510 ELSEIF(PDRMIN.LT.PARU12) THEN
1511 DO 170 J=1,4
1512 170 P(IR,J)=P(IR,J)+P(IR+1,J)
1513 P(IR,5)=SQRT(MAX(0.,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
1514 & P(IR,3)**2))
1515 DO 180 I=IR+1,N+NR-1
1516 K(I,2)=K(I+1,2)
1517 DO 180 J=1,5
1518 180 P(I,J)=P(I+1,J)
1519 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
1520 NR=NR-1
1521 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
1522 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
1523 GOTO 140
1524 ENDIF
1525 ENDIF
1526 NTRYR=NTRYR+1
1527
1528C...Reset particle counter. Skip ahead if no junctions are present;
1529C...this is usually the case!
1530 NRS=MAX(5*NR+11,NP)
1531 NTRY=0
1532 190 NTRY=NTRY+1
1533 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1534 PARU12=4.*PARU12
1535 PARU13=2.*PARU13
1536 GOTO 140
1537 ELSEIF(NTRY.GT.100) THEN
1538 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1539 IF(MSTU(21).GE.1) RETURN
1540 ENDIF
1541 I=N+NRS
1542 MSTU(90)=MSTU90
1543 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 510
1544 DO 500 JT=1,2
1545 NJS(JT)=0
1546 IF(MJU(JT).EQ.0) GOTO 500
1547 JS=3-2*JT
1548
1549C...Find and sum up momentum on three sides of junction. Check flavours.
1550 DO 200 IU=1,3
1551 IJU(IU)=0
1552 DO 200 J=1,5
1553 200 PJU(IU,J)=0.
1554 IU=0
1555 DO 210 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
1556 IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
1557 IU=IU+1
1558 IJU(IU)=I1
1559 ENDIF
1560 DO 210 J=1,4
1561 210 PJU(IU,J)=PJU(IU,J)+P(I1,J)
1562 DO 220 IU=1,3
1563 220 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1564 IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
1565 &K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
1566 CALL LUERRM(12,'(LUSTRF:) unphysical flavour combination')
1567 IF(MSTU(21).GE.1) RETURN
1568 ENDIF
1569
1570C...Calculate (approximate) boost to rest frame of junction.
1571 T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
1572 &(PJU(1,5)*PJU(2,5))
1573 T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
1574 &(PJU(1,5)*PJU(3,5))
1575 T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
1576 &(PJU(2,5)*PJU(3,5))
1577 T11=SQRT((2./3.)*(1.-T12)*(1.-T13)/(1.-T23))
1578 T22=SQRT((2./3.)*(1.-T12)*(1.-T23)/(1.-T13))
1579 TSQ=SQRT((2.*T11*T22+T12-1.)*(1.+T12))
1580 T1F=(TSQ-T22*(1.+T12))/(1.-T12**2)
1581 T2F=(TSQ-T11*(1.+T12))/(1.-T12**2)
1582 DO 230 J=1,3
1583 230 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
1584 TJU(4)=SQRT(1.+TJU(1)**2+TJU(2)**2+TJU(3)**2)
1585 DO 240 IU=1,3
1586 240 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
1587 &TJU(3)*PJU(IU,3)
1588
1589C...Put junction at rest if motion could give inconsistencies.
1590 IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
1591 DO 250 J=1,3
1592 250 TJU(J)=0.
1593 TJU(4)=1.
1594 PJU(1,5)=PJU(1,4)
1595 PJU(2,5)=PJU(2,4)
1596 PJU(3,5)=PJU(3,4)
1597 ENDIF
1598
1599C...Start preparing for fragmentation of two strings from junction.
1600 ISTA=I
1601 DO 480 IU=1,2
1602 NS=IJU(IU+1)-IJU(IU)
1603
1604C...Junction strings: find longitudinal string directions.
1605 DO 270 IS=1,NS
1606 IS1=IJU(IU)+IS-1
1607 IS2=IJU(IU)+IS
1608 DO 260 J=1,5
1609 DP(1,J)=0.5*P(IS1,J)
1610 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
1611 DP(2,J)=0.5*P(IS2,J)
1612 260 IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
1613 IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
1614 IF(IS.EQ.NS) DP(2,5)=0.
1615 DP(3,5)=DFOUR(1,1)
1616 DP(4,5)=DFOUR(2,2)
1617 DHKC=DFOUR(1,2)
1618 IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1619 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1620 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1621 DP(3,5)=0D0
1622 DP(4,5)=0D0
1623 DHKC=DFOUR(1,2)
1624 ENDIF
1625 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1626 DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1627 DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1628 IN1=N+NR+4*IS-3
1629 P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1630 DO 270 J=1,4
1631 P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1632 270 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1633
1634C...Junction strings: initialize flavour, momentum and starting pos.
1635 ISAV=I
1636 MSTU91=MSTU(90)
1637 280 NTRY=NTRY+1
1638 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1639 PARU12=4.*PARU12
1640 PARU13=2.*PARU13
1641 GOTO 140
1642 ELSEIF(NTRY.GT.100) THEN
1643 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1644 IF(MSTU(21).GE.1) RETURN
1645 ENDIF
1646 I=ISAV
1647 MSTU(90)=MSTU91
1648 IRANKJ=0
1649 IE(1)=K(N+1+(JT/2)*(NP-1),3)
1650 IN(4)=N+NR+1
1651 IN(5)=IN(4)+1
1652 IN(6)=N+NR+4*NS+1
1653 DO 290 JQ=1,2
1654 DO 290 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
1655 P(IN1,1)=2-JQ
1656 P(IN1,2)=JQ-1
1657 290 P(IN1,3)=1.
1658 KFL(1)=K(IJU(IU),2)
1659 PX(1)=0.
1660 PY(1)=0.
1661 GAM(1)=0.
1662 DO 300 J=1,5
1663 300 PJU(IU+3,J)=0.
1664
1665C...Junction strings: find initial transverse directions.
1666 DO 310 J=1,4
1667 DP(1,J)=P(IN(4),J)
1668 DP(2,J)=P(IN(4)+1,J)
1669 DP(3,J)=0.
1670 310 DP(4,J)=0.
1671 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1672 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1673 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1674 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1675 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1676 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1677 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1678 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1679 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1680 DHC12=DFOUR(1,2)
1681 DHCX1=DFOUR(3,1)/DHC12
1682 DHCX2=DFOUR(3,2)/DHC12
1683 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1684 DHCY1=DFOUR(4,1)/DHC12
1685 DHCY2=DFOUR(4,2)/DHC12
1686 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1687 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1688 DO 320 J=1,4
1689 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1690 P(IN(6),J)=DP(3,J)
1691 320 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1692 &DHCYX*DP(3,J))
1693
1694C...Junction strings: produce new particle, origin.
1695 330 I=I+1
1696 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
1697 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
1698 IF(MSTU(21).GE.1) RETURN
1699 ENDIF
1700 IRANKJ=IRANKJ+1
1701 K(I,1)=1
1702 K(I,3)=IE(1)
1703 K(I,4)=0
1704 K(I,5)=0
1705
1706C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1707 340 CALL LUKFDI(KFL(1),0,KFL(3),K(I,2))
1708 IF(K(I,2).EQ.0) GOTO 280
1709 IF(MSTJ(12).GE.3.AND.IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
1710 &IABS(KFL(3)).GT.10) THEN
1711 IF(RLU(0).GT.PARJ(19)) GOTO 340
1712 ENDIF
1713 P(I,5)=ULMASS(K(I,2))
1714 CALL LUPTDI(KFL(1),PX(3),PY(3))
1715 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
1716 CALL LUZDIS(KFL(1),KFL(3),PR(1),Z)
1717 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
1718 &MSTU(90).LT.8) THEN
1719 MSTU(90)=MSTU(90)+1
1720 MSTU(90+MSTU(90))=I
1721 PARU(90+MSTU(90))=Z
1722 ENDIF
1723 GAM(3)=(1.-Z)*(GAM(1)+PR(1)/Z)
1724 DO 350 J=1,3
1725 350 IN(J)=IN(3+J)
1726
1727C...Junction strings: stepping within or from 'low' string region easy.
1728 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
1729 &P(IN(1),5)**2.GE.PR(1)) THEN
1730 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
1731 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
1732 DO 360 J=1,4
1733 360 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
1734 GOTO 430
1735 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
1736 P(IN(2)+2,4)=P(IN(2)+2,3)
1737 P(IN(2)+2,1)=1.
1738 IN(2)=IN(2)+4
1739 IF(IN(2).GT.N+NR+4*NS) GOTO 280
1740 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1741 P(IN(1)+2,4)=P(IN(1)+2,3)
1742 P(IN(1)+2,1)=0.
1743 IN(1)=IN(1)+4
1744 ENDIF
1745 ENDIF
1746
1747C...Junction strings: find new transverse directions.
1748 370 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
1749 &IN(1).GT.IN(2)) GOTO 280
1750 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
1751 DO 380 J=1,4
1752 DP(1,J)=P(IN(1),J)
1753 DP(2,J)=P(IN(2),J)
1754 DP(3,J)=0.
1755 380 DP(4,J)=0.
1756 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
1757 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
1758 DHC12=DFOUR(1,2)
1759 IF(DHC12.LE.1E-2) THEN
1760 P(IN(1)+2,4)=P(IN(1)+2,3)
1761 P(IN(1)+2,1)=0.
1762 IN(1)=IN(1)+4
1763 GOTO 370
1764 ENDIF
1765 IN(3)=N+NR+4*NS+5
1766 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
1767 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
1768 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
1769 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
1770 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
1771 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
1772 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
1773 DHCX1=DFOUR(3,1)/DHC12
1774 DHCX2=DFOUR(3,2)/DHC12
1775 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
1776 DHCY1=DFOUR(4,1)/DHC12
1777 DHCY2=DFOUR(4,2)/DHC12
1778 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
1779 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
1780 DO 390 J=1,4
1781 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
1782 P(IN(3),J)=DP(3,J)
1783 390 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
1784 & DHCYX*DP(3,J))
1785C...Express pT with respect to new axes, if sensible.
1786 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
1787 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
1788 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
1789 PX(3)=PXP
1790 PY(3)=PYP
1791 ENDIF
1792 ENDIF
1793
1794C...Junction strings: sum up known four-momentum, coefficients for m2.
1795 DO 410 J=1,4
1796 DHG(J)=0.
1797 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
1798 &PY(3)*P(IN(3)+1,J)
1799 DO 400 IN1=IN(4),IN(1)-4,4
1800 400 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
1801 DO 410 IN2=IN(5),IN(2)-4,4
1802 410 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
1803 DHM(1)=FOUR(I,I)
1804 DHM(2)=2.*FOUR(I,IN(1))
1805 DHM(3)=2.*FOUR(I,IN(2))
1806 DHM(4)=2.*FOUR(IN(1),IN(2))
1807
1808C...Junction strings: find coefficients for Gamma expression.
1809 DO 420 IN2=IN(1)+1,IN(2),4
1810 DO 420 IN1=IN(1),IN2-1,4
1811 DHC=2.*FOUR(IN1,IN2)
1812 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
1813 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
1814 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
1815 420 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
1816
1817C...Junction strings: solve (m2, Gamma) equation system for energies.
1818 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
1819 IF(ABS(DHS1).LT.1E-4) GOTO 280
1820 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
1821 &(P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
1822 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
1823 P(IN(2)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
1824 &DHS2/DHS1)
1825 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0.) GOTO 280
1826 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
1827 &(DHM(2)+DHM(4)*P(IN(2)+2,4))
1828
1829C...Junction strings: step to new region if necessary.
1830 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
1831 P(IN(2)+2,4)=P(IN(2)+2,3)
1832 P(IN(2)+2,1)=1.
1833 IN(2)=IN(2)+4
1834 IF(IN(2).GT.N+NR+4*NS) GOTO 280
1835 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
1836 P(IN(1)+2,4)=P(IN(1)+2,3)
1837 P(IN(1)+2,1)=0.
1838 IN(1)=IN(1)+4
1839 ENDIF
1840 GOTO 370
1841 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
1842 P(IN(1)+2,4)=P(IN(1)+2,3)
1843 P(IN(1)+2,1)=0.
1844 IN(1)=IN(1)+JS
1845 GOTO 720
1846 ENDIF
1847
1848C...Junction strings: particle four-momentum, remainder, loop back.
1849 430 DO 440 J=1,4
1850 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
1851 440 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
1852 IF(P(I,4).LT.P(I,5)) GOTO 280
1853 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
1854 &TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
1855 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
1856 KFL(1)=-KFL(3)
1857 PX(1)=-PX(3)
1858 PY(1)=-PY(3)
1859 GAM(1)=GAM(3)
1860 IF(IN(3).NE.IN(6)) THEN
1861 DO 450 J=1,4
1862 P(IN(6),J)=P(IN(3),J)
1863 450 P(IN(6)+1,J)=P(IN(3)+1,J)
1864 ENDIF
1865 DO 460 JQ=1,2
1866 IN(3+JQ)=IN(JQ)
1867 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
1868 460 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
1869 GOTO 330
1870 ENDIF
1871
1872C...Junction strings: save quantities left after each string.
1873 IF(IABS(KFL(1)).GT.10) GOTO 280
1874 I=I-1
1875 KFJH(IU)=KFL(1)
1876 DO 470 J=1,4
1877 470 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
1878 480 CONTINUE
1879
1880C...Junction strings: put together to new effective string endpoint.
1881 NJS(JT)=I-ISTA
1882 KFJS(JT)=K(K(MJU(JT+2),3),2)
1883 KFLS=2*INT(RLU(0)+3.*PARJ(4)/(1.+3.*PARJ(4)))+1
1884 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
1885 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
1886 &IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
1887 &KFLS,KFJH(1))
1888 DO 490 J=1,4
1889 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
1890 490 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
1891 PJS(JT,5)=SQRT(MAX(0.,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
1892 &PJS(JT,3)**2))
1893 500 CONTINUE
1894
1895C...Open versus closed strings. Choose breakup region for latter.
1896 510 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
1897 NS=MJU(2)-MJU(1)
1898 NB=MJU(1)-N
1899 ELSEIF(MJU(1).NE.0) THEN
1900 NS=N+NR-MJU(1)
1901 NB=MJU(1)-N
1902 ELSEIF(MJU(2).NE.0) THEN
1903 NS=MJU(2)-N
1904 NB=1
1905 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
1906 NS=NR-1
1907 NB=1
1908 ELSE
1909 NS=NR+1
1910 W2SUM=0.
1911 DO 520 IS=1,NR
1912 P(N+NR+IS,1)=0.5*FOUR(N+IS,N+IS+1-NR*(IS/NR))
1913 520 W2SUM=W2SUM+P(N+NR+IS,1)
1914 W2RAN=RLU(0)*W2SUM
1915 NB=0
1916 530 NB=NB+1
1917 W2SUM=W2SUM-P(N+NR+NB,1)
1918 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 530
1919 ENDIF
1920
1921C...Find longitudinal string directions (i.e. lightlike four-vectors).
1922 DO 550 IS=1,NS
1923 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
1924 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
1925 DO 540 J=1,5
1926 DP(1,J)=P(IS1,J)
1927 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5*DP(1,J)
1928 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
1929 DP(2,J)=P(IS2,J)
1930 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5*DP(2,J)
1931 540 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
1932 DP(3,5)=DFOUR(1,1)
1933 DP(4,5)=DFOUR(2,2)
1934 DHKC=DFOUR(1,2)
1935 IF(DP(3,5)+2.*DHKC+DP(4,5).LE.0.) THEN
1936 DP(3,5)=DP(1,5)**2
1937 DP(4,5)=DP(2,5)**2
1938 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
1939 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
1940 DHKC=DFOUR(1,2)
1941 ENDIF
1942 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
1943 DHK1=0.5*((DP(4,5)+DHKC)/DHKS-1.)
1944 DHK2=0.5*((DP(3,5)+DHKC)/DHKS-1.)
1945 IN1=N+NR+4*IS-3
1946 P(IN1,5)=SQRT(DP(3,5)+2.*DHKC+DP(4,5))
1947 DO 550 J=1,4
1948 P(IN1,J)=(1.+DHK1)*DP(1,J)-DHK2*DP(2,J)
1949 550 P(IN1+1,J)=(1.+DHK2)*DP(2,J)-DHK1*DP(1,J)
1950
1951C...Begin initialization: sum up energy, set starting position.
1952 ISAV=I
1953 MSTU91=MSTU(90)
1954 560 NTRY=NTRY+1
1955 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
1956 PARU12=4.*PARU12
1957 PARU13=2.*PARU13
1958 GOTO 140
1959 ELSEIF(NTRY.GT.100) THEN
1960 CALL LUERRM(14,'(LUSTRF:) caught in infinite loop')
1961 IF(MSTU(21).GE.1) RETURN
1962 ENDIF
1963 I=ISAV
1964 MSTU(90)=MSTU91
1965 DO 570 J=1,4
1966 P(N+NRS,J)=0.
1967 DO 570 IS=1,NR
1968 570 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
1969 DO 580 JT=1,2
1970 IRANK(JT)=0
1971 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
1972 IF(NS.GT.NR) IRANK(JT)=1
1973 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
1974 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
1975 IN(3*JT+2)=IN(3*JT+1)+1
1976 IN(3*JT+3)=N+NR+4*NS+2*JT-1
1977 DO 580 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
1978 P(IN1,1)=2-JT
1979 P(IN1,2)=JT-1
1980 580 P(IN1,3)=1.
1981
1982C...Initialize flavour and pT variables for open string.
1983 IF(NS.LT.NR) THEN
1984 PX(1)=0.
1985 PY(1)=0.
1986 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL LUPTDI(0,PX(1),PY(1))
1987 PX(2)=-PX(1)
1988 PY(2)=-PY(1)
1989 DO 590 JT=1,2
1990 KFL(JT)=K(IE(JT),2)
1991 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
1992 MSTJ(93)=1
1993 PMQ(JT)=ULMASS(KFL(JT))
1994 590 GAM(JT)=0.
1995
1996C...Closed string: random initial breakup flavour, pT and vertex.
1997 ELSE
1998 KFL(3)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
1999 CALL LUKFDI(KFL(3),0,KFL(1),KDUMP)
2000 KFL(2)=-KFL(1)
2001 IF(IABS(KFL(1)).GT.10.AND.RLU(0).GT.0.5) THEN
2002 KFL(2)=-(KFL(1)+ISIGN(10000,KFL(1)))
2003 ELSEIF(IABS(KFL(1)).GT.10) THEN
2004 KFL(1)=-(KFL(2)+ISIGN(10000,KFL(2)))
2005 ENDIF
2006 CALL LUPTDI(KFL(1),PX(1),PY(1))
2007 PX(2)=-PX(1)
2008 PY(2)=-PY(1)
2009 PR3=MIN(25.,0.1*P(N+NR+1,5)**2)
2010 600 CALL LUZDIS(KFL(1),KFL(2),PR3,Z)
2011 ZR=PR3/(Z*P(N+NR+1,5)**2)
2012 IF(ZR.GE.1.) GOTO 600
2013 DO 610 JT=1,2
2014 MSTJ(93)=1
2015 PMQ(JT)=ULMASS(KFL(JT))
2016 GAM(JT)=PR3*(1.-Z)/Z
2017 IN1=N+NR+3+4*(JT/2)*(NS-1)
2018 P(IN1,JT)=1.-Z
2019 P(IN1,3-JT)=JT-1
2020 P(IN1,3)=(2-JT)*(1.-Z)+(JT-1)*Z
2021 P(IN1+1,JT)=ZR
2022 P(IN1+1,3-JT)=2-JT
2023 610 P(IN1+1,3)=(2-JT)*(1.-ZR)+(JT-1)*ZR
2024 ENDIF
2025
2026C...Find initial transverse directions (i.e. spacelike four-vectors).
2027 DO 650 JT=1,2
2028 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
2029 IN1=IN(3*JT+1)
2030 IN3=IN(3*JT+3)
2031 DO 620 J=1,4
2032 DP(1,J)=P(IN1,J)
2033 DP(2,J)=P(IN1+1,J)
2034 DP(3,J)=0.
2035 620 DP(4,J)=0.
2036 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2037 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2038 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2039 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2040 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2041 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2042 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2043 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2044 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2045 DHC12=DFOUR(1,2)
2046 DHCX1=DFOUR(3,1)/DHC12
2047 DHCX2=DFOUR(3,2)/DHC12
2048 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2049 DHCY1=DFOUR(4,1)/DHC12
2050 DHCY2=DFOUR(4,2)/DHC12
2051 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2052 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2053 DO 630 J=1,4
2054 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2055 P(IN3,J)=DP(3,J)
2056 630 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2057 & DHCYX*DP(3,J))
2058 ELSE
2059 DO 640 J=1,4
2060 P(IN3+2,J)=P(IN3,J)
2061 640 P(IN3+3,J)=P(IN3+1,J)
2062 ENDIF
2063 650 CONTINUE
2064
2065C...Remove energy used up in junction string fragmentation.
2066 IF(MJU(1)+MJU(2).GT.0) THEN
2067 DO 670 JT=1,2
2068 IF(NJS(JT).EQ.0) GOTO 670
2069 DO 660 J=1,4
2070 660 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
2071 670 CONTINUE
2072 ENDIF
2073
2074C...Produce new particle: side, origin.
2075 680 I=I+1
2076 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
2077 CALL LUERRM(11,'(LUSTRF:) no more memory left in LUJETS')
2078 IF(MSTU(21).GE.1) RETURN
2079 ENDIF
2080 JT=1.5+RLU(0)
2081 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
2082 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
2083 JR=3-JT
2084 JS=3-2*JT
2085 IRANK(JT)=IRANK(JT)+1
2086 K(I,1)=1
2087 K(I,3)=IE(JT)
2088 K(I,4)=0
2089 K(I,5)=0
2090
2091C...Generate flavour, hadron and pT.
2092 690 CALL LUKFDI(KFL(JT),0,KFL(3),K(I,2))
2093 IF(K(I,2).EQ.0) GOTO 560
2094 IF(MSTJ(12).GE.3.AND.IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
2095 &IABS(KFL(3)).GT.10) THEN
2096 IF(RLU(0).GT.PARJ(19)) GOTO 690
2097 ENDIF
2098 P(I,5)=ULMASS(K(I,2))
2099 CALL LUPTDI(KFL(JT),PX(3),PY(3))
2100 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
2101
2102C...Final hadrons for small invariant mass.
2103 MSTJ(93)=1
2104 PMQ(3)=ULMASS(KFL(3))
2105 PARJST=PARJ(33)
2106 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
2107 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
2108 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
2109 &WMIN-0.5*PARJ(36)*PMQ(3)
2110 WREM2=FOUR(N+NRS,N+NRS)
2111 IF(WREM2.LT.0.10) GOTO 560
2112 IF(WREM2.LT.MAX(WMIN*(1.+(2.*RLU(0)-1.)*PARJ(37)),
2113 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 820
2114
2115C...Choose z, which gives Gamma. Shift z for heavy flavours.
2116 CALL LUZDIS(KFL(JT),KFL(3),PR(JT),Z)
2117 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
2118 &MSTU(90).LT.8) THEN
2119 MSTU(90)=MSTU(90)+1
2120 MSTU(90+MSTU(90))=I
2121 PARU(90+MSTU(90))=Z
2122 ENDIF
2123 KFL1A=IABS(KFL(1))
2124 KFL2A=IABS(KFL(2))
2125 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2126 &MOD(KFL2A/1000,10)).GE.4) THEN
2127 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2128 PW12=SQRT(MAX(0.,(WREM2-PR(1)-PR(2))**2-4.*PR(1)*PR(2)))
2129 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2.*Z-1.))/(2.*WREM2)
2130 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2131 IF((1.-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 820
2132 ENDIF
2133 GAM(3)=(1.-Z)*(GAM(JT)+PR(JT)/Z)
2134 DO 700 J=1,3
2135 700 IN(J)=IN(3*JT+J)
2136
2137C...Stepping within or from 'low' string region easy.
2138 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
2139 &P(IN(1),5)**2.GE.PR(JT)) THEN
2140 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
2141 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
2142 DO 710 J=1,4
2143 710 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
2144 GOTO 780
2145 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
2146 P(IN(JR)+2,4)=P(IN(JR)+2,3)
2147 P(IN(JR)+2,JT)=1.
2148 IN(JR)=IN(JR)+4*JS
2149 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 560
2150 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2151 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2152 P(IN(JT)+2,JT)=0.
2153 IN(JT)=IN(JT)+4*JS
2154 ENDIF
2155 ENDIF
2156
2157C...Find new transverse directions (i.e. spacelike string vectors).
2158 720 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
2159 &IN(1).GT.IN(2)) GOTO 560
2160 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
2161 DO 730 J=1,4
2162 DP(1,J)=P(IN(1),J)
2163 DP(2,J)=P(IN(2),J)
2164 DP(3,J)=0.
2165 730 DP(4,J)=0.
2166 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
2167 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
2168 DHC12=DFOUR(1,2)
2169 IF(DHC12.LE.1E-2) THEN
2170 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2171 P(IN(JT)+2,JT)=0.
2172 IN(JT)=IN(JT)+4*JS
2173 GOTO 720
2174 ENDIF
2175 IN(3)=N+NR+4*NS+5
2176 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
2177 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
2178 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
2179 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1.
2180 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1.
2181 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1.
2182 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1.
2183 DHCX1=DFOUR(3,1)/DHC12
2184 DHCX2=DFOUR(3,2)/DHC12
2185 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
2186 DHCY1=DFOUR(4,1)/DHC12
2187 DHCY2=DFOUR(4,2)/DHC12
2188 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
2189 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
2190 DO 740 J=1,4
2191 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
2192 P(IN(3),J)=DP(3,J)
2193 740 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
2194 & DHCYX*DP(3,J))
2195C...Express pT with respect to new axes, if sensible.
2196 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
2197 & FOUR(IN(3*JT+3)+1,IN(3)))
2198 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
2199 & FOUR(IN(3*JT+3)+1,IN(3)+1))
2200 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01) THEN
2201 PX(3)=PXP
2202 PY(3)=PYP
2203 ENDIF
2204 ENDIF
2205
2206C...Sum up known four-momentum. Gives coefficients for m2 expression.
2207 DO 760 J=1,4
2208 DHG(J)=0.
2209 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
2210 &PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
2211 DO 750 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
2212 750 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
2213 DO 760 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
2214 760 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
2215 DHM(1)=FOUR(I,I)
2216 DHM(2)=2.*FOUR(I,IN(1))
2217 DHM(3)=2.*FOUR(I,IN(2))
2218 DHM(4)=2.*FOUR(IN(1),IN(2))
2219
2220C...Find coefficients for Gamma expression.
2221 DO 770 IN2=IN(1)+1,IN(2),4
2222 DO 770 IN1=IN(1),IN2-1,4
2223 DHC=2.*FOUR(IN1,IN2)
2224 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
2225 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
2226 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
2227 770 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
2228
2229C...Solve (m2, Gamma) equation system for energies taken.
2230 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
2231 IF(ABS(DHS1).LT.1E-4) GOTO 560
2232 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
2233 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
2234 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
2235 P(IN(JR)+2,4)=0.5*(SQRT(MAX(0D0,DHS2**2-4.*DHS1*DHS3))/ABS(DHS1)-
2236 &DHS2/DHS1)
2237 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0.) GOTO 560
2238 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
2239 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
2240
2241C...Step to new region if necessary.
2242 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
2243 P(IN(JR)+2,4)=P(IN(JR)+2,3)
2244 P(IN(JR)+2,JT)=1.
2245 IN(JR)=IN(JR)+4*JS
2246 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 560
2247 IF(FOUR(IN(1),IN(2)).LE.1E-2) THEN
2248 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2249 P(IN(JT)+2,JT)=0.
2250 IN(JT)=IN(JT)+4*JS
2251 ENDIF
2252 GOTO 720
2253 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
2254 P(IN(JT)+2,4)=P(IN(JT)+2,3)
2255 P(IN(JT)+2,JT)=0.
2256 IN(JT)=IN(JT)+4*JS
2257 GOTO 720
2258 ENDIF
2259
2260C...Four-momentum of particle. Remaining quantities. Loop back.
2261 780 DO 790 J=1,4
2262 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
2263 790 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
2264 IF(P(I,4).LT.P(I,5)) GOTO 560
2265 KFL(JT)=-KFL(3)
2266 PMQ(JT)=PMQ(3)
2267 PX(JT)=-PX(3)
2268 PY(JT)=-PY(3)
2269 GAM(JT)=GAM(3)
2270 IF(IN(3).NE.IN(3*JT+3)) THEN
2271 DO 800 J=1,4
2272 P(IN(3*JT+3),J)=P(IN(3),J)
2273 800 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
2274 ENDIF
2275 DO 810 JQ=1,2
2276 IN(3*JT+JQ)=IN(JQ)
2277 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
2278 810 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
2279 GOTO 680
2280
2281C...Final hadron: side, flavour, hadron, mass.
2282 820 I=I+1
2283 K(I,1)=1
2284 K(I,3)=IE(JR)
2285 K(I,4)=0
2286 K(I,5)=0
2287 CALL LUKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
2288 IF(K(I,2).EQ.0) GOTO 560
2289 P(I,5)=ULMASS(K(I,2))
2290 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
2291
2292C...Final two hadrons: find common setup of four-vectors.
2293 JQ=1
2294 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
2295 &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
2296 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
2297 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
2298 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
2299 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
2300 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
2301 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
2302 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
2303 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
2304 ENDIF
2305
2306C...Solve kinematics for final two hadrons, if possible.
2307 WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
2308 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
2309 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1.) GOTO 190
2310 IF(FD.GE.1.) GOTO 560
2311 FA=WREM2+PR(JT)-PR(JR)
2312 IF(MSTJ(11).NE.2) PREV=0.5*EXP(MAX(-80.,LOG(FD)*PARJ(38)*
2313 &(PR(1)+PR(2))**2))
2314 IF(MSTJ(11).EQ.2) PREV=0.5*FD**PARJ(39)
2315 FB=SIGN(SQRT(MAX(0.,FA**2-4.*WREM2*PR(JT))),JS*(RLU(0)-PREV))
2316 KFL1A=IABS(KFL(1))
2317 KFL2A=IABS(KFL(2))
2318 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
2319 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0.,FA**2-
2320 &4.*WREM2*PR(JT))),FLOAT(JS))
2321 DO 830 J=1,4
2322 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
2323 &P(IN(3*JQ+3)+1,J)+0.5*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
2324 &DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
2325 830 P(I,J)=P(N+NRS,J)-P(I-1,J)
2326 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 560
2327C...Mark jets as fragmented and give daughter pointers.
2328 N=I-NRS+1
2329 DO 840 I=NSAV+1,NSAV+NP
2330 IM=K(I,3)
2331 K(IM,1)=K(IM,1)+10
2332 IF(MSTU(16).NE.2) THEN
2333 K(IM,4)=NSAV+1
2334 K(IM,5)=NSAV+1
2335 ELSE
2336 K(IM,4)=NSAV+2
2337 K(IM,5)=N
2338 ENDIF
2339 840 CONTINUE
2340
2341C...Document string system. Move up particles.
2342 NSAV=NSAV+1
2343 K(NSAV,1)=11
2344 K(NSAV,2)=92
2345 K(NSAV,3)=IP
2346 K(NSAV,4)=NSAV+1
2347 K(NSAV,5)=N
2348 DO 850 J=1,4
2349 P(NSAV,J)=DPS(J)
2350 850 V(NSAV,J)=V(IP,J)
2351 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2352 V(NSAV,5)=0.
2353 DO 860 I=NSAV+1,N
2354 DO 860 J=1,5
2355 K(I,J)=K(I+NRS-1,J)
2356 P(I,J)=P(I+NRS-1,J)
2357 860 V(I,J)=0.
2358 MSTU91=MSTU(90)
2359 DO 870 IZ=MSTU90+1,MSTU91
2360 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
2361 870 PARU9T(IZ)=PARU(90+IZ)
2362 MSTU(90)=MSTU90
2363
2364C...Order particles in rank along the chain. Update mother pointer.
2365 DO 880 I=NSAV+1,N
2366 DO 880 J=1,5
2367 K(I-NSAV+N,J)=K(I,J)
2368 880 P(I-NSAV+N,J)=P(I,J)
2369 I1=NSAV
2370 DO 910 I=N+1,2*N-NSAV
2371 IF(K(I,3).NE.IE(1)) GOTO 910
2372 I1=I1+1
2373 DO 890 J=1,5
2374 K(I1,J)=K(I,J)
2375 890 P(I1,J)=P(I,J)
2376 IF(MSTU(16).NE.2) K(I1,3)=NSAV
2377 DO 900 IZ=MSTU90+1,MSTU91
2378 IF(MSTU9T(IZ).EQ.I) THEN
2379 MSTU(90)=MSTU(90)+1
2380 MSTU(90+MSTU(90))=I1
2381 PARU(90+MSTU(90))=PARU9T(IZ)
2382 ENDIF
2383 900 CONTINUE
2384 910 CONTINUE
2385 DO 940 I=2*N-NSAV,N+1,-1
2386 IF(K(I,3).EQ.IE(1)) GOTO 940
2387 I1=I1+1
2388 DO 920 J=1,5
2389 K(I1,J)=K(I,J)
2390 920 P(I1,J)=P(I,J)
2391 IF(MSTU(16).NE.2) K(I1,3)=NSAV
2392 DO 930 IZ=MSTU90+1,MSTU91
2393 IF(MSTU9T(IZ).EQ.I) THEN
2394 MSTU(90)=MSTU(90)+1
2395 MSTU(90+MSTU(90))=I1
2396 PARU(90+MSTU(90))=PARU9T(IZ)
2397 ENDIF
2398 930 CONTINUE
2399 940 CONTINUE
2400
2401C...Boost back particle system. Set production vertices.
2402 IF(MBST.EQ.0) THEN
2403 MSTU(33)=1
2404 CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),
2405 & DPS(3)/DPS(4))
2406 ELSE
2407 DO 950 I=NSAV+1,N
2408 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
2409 IF(P(I,3).GT.0.) THEN
2410 HHPEZ=(P(I,4)+P(I,3))*HHBZ
2411 P(I,3)=0.5*(HHPEZ-HHPMT/HHPEZ)
2412 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2413 ELSE
2414 HHPEZ=(P(I,4)-P(I,3))/HHBZ
2415 P(I,3)=-0.5*(HHPEZ-HHPMT/HHPEZ)
2416 P(I,4)=0.5*(HHPEZ+HHPMT/HHPEZ)
2417 ENDIF
2418 950 CONTINUE
2419 ENDIF
2420 DO 960 I=NSAV+1,N
2421 DO 960 J=1,4
2422 960 V(I,J)=V(IP,J)
2423
2424 RETURN
2425 END
2426
2427C*********************************************************************
2428
2429 SUBROUTINE LUINDF(IP)
2430
2431C...Purpose: to handle the fragmentation of a jet system (or a single
2432C...jet) according to independent fragmentation models.
2433 IMPLICIT DOUBLE PRECISION(D)
2434 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
2435 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2436 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2437 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
2438 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
2439 &KFLO(2),PXO(2),PYO(2),WO(2)
2440
2441C...Reset counters. Identify parton system and take copy. Check flavour.
2442 NSAV=N
2443 MSTU90=MSTU(90)
2444 NJET=0
2445 KQSUM=0
2446 DO 100 J=1,5
2447 100 DPS(J)=0.
2448 I=IP-1
2449 110 I=I+1
2450 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
2451 CALL LUERRM(12,'(LUINDF:) failed to reconstruct jet system')
2452 IF(MSTU(21).GE.1) RETURN
2453 ENDIF
2454 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
2455 KC=LUCOMP(K(I,2))
2456 IF(KC.EQ.0) GOTO 110
2457 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2458 IF(KQ.EQ.0) GOTO 110
2459 NJET=NJET+1
2460 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2461 DO 120 J=1,5
2462 K(NSAV+NJET,J)=K(I,J)
2463 P(NSAV+NJET,J)=P(I,J)
2464 120 DPS(J)=DPS(J)+P(I,J)
2465 K(NSAV+NJET,3)=I
2466 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
2467 &K(I+1,1).EQ.2)) GOTO 110
2468 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
2469 CALL LUERRM(12,'(LUINDF:) unphysical flavour combination')
2470 IF(MSTU(21).GE.1) RETURN
2471 ENDIF
2472
2473C...Boost copied system to CM frame. Find CM energy and sum flavours.
2474 IF(NJET.NE.1) THEN
2475 MSTU(33)=1
2476 CALL LUDBRB(NSAV+1,NSAV+NJET,0.,0.,-DPS(1)/DPS(4),
2477 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
2478 ENDIF
2479 PECM=0.
2480 DO 130 J=1,3
2481 130 NFI(J)=0
2482 DO 140 I=NSAV+1,NSAV+NJET
2483 PECM=PECM+P(I,4)
2484 KFA=IABS(K(I,2))
2485 IF(KFA.LE.3) THEN
2486 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
2487 ELSEIF(KFA.GT.1000) THEN
2488 KFLA=MOD(KFA/1000,10)
2489 KFLB=MOD(KFA/100,10)
2490 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
2491 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
2492 ENDIF
2493 140 CONTINUE
2494
2495C...Loop over attempts made. Reset counters.
2496 NTRY=0
2497 150 NTRY=NTRY+1
2498 IF(NTRY.GT.200) THEN
2499 CALL LUERRM(14,'(LUINDF:) caught in infinite loop')
2500 IF(MSTU(21).GE.1) RETURN
2501 ENDIF
2502 N=NSAV+NJET
2503 MSTU(90)=MSTU90
2504 DO 160 J=1,3
2505 NFL(J)=NFI(J)
2506 IFET(J)=0
2507 160 KFLF(J)=0
2508
2509C...Loop over jets to be fragmented.
2510 DO 230 IP1=NSAV+1,NSAV+NJET
2511 MSTJ(91)=0
2512 NSAV1=N
2513 MSTU91=MSTU(90)
2514
2515C...Initial flavour and momentum values. Jet along +z axis.
2516 KFLH=IABS(K(IP1,2))
2517 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
2518 KFLO(2)=0
2519 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
2520
2521C...Initial values for quark or diquark jet.
2522 170 IF(IABS(K(IP1,2)).NE.21) THEN
2523 NSTR=1
2524 KFLO(1)=K(IP1,2)
2525 CALL LUPTDI(0,PXO(1),PYO(1))
2526 WO(1)=WF
2527
2528C...Initial values for gluon treated like random quark jet.
2529 ELSEIF(MSTJ(2).LE.2) THEN
2530 NSTR=1
2531 IF(MSTJ(2).EQ.2) MSTJ(91)=1
2532 KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2533 CALL LUPTDI(0,PXO(1),PYO(1))
2534 WO(1)=WF
2535
2536C...Initial values for gluon treated like quark-antiquark jet pair,
2537C...sharing energy according to Altarelli-Parisi splitting function.
2538 ELSE
2539 NSTR=2
2540 IF(MSTJ(2).EQ.4) MSTJ(91)=1
2541 KFLO(1)=INT(1.+(2.+PARJ(2))*RLU(0))*(-1)**INT(RLU(0)+0.5)
2542 KFLO(2)=-KFLO(1)
2543 CALL LUPTDI(0,PXO(1),PYO(1))
2544 PXO(2)=-PXO(1)
2545 PYO(2)=-PYO(1)
2546 WO(1)=WF*RLU(0)**(1./3.)
2547 WO(2)=WF-WO(1)
2548 ENDIF
2549
2550C...Initial values for rank, flavour, pT and W+.
2551 DO 220 ISTR=1,NSTR
2552 180 I=N
2553 MSTU(90)=MSTU91
2554 IRANK=0
2555 KFL1=KFLO(ISTR)
2556 PX1=PXO(ISTR)
2557 PY1=PYO(ISTR)
2558 W=WO(ISTR)
2559
2560C...New hadron. Generate flavour and hadron species.
2561 190 I=I+1
2562 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
2563 CALL LUERRM(11,'(LUINDF:) no more memory left in LUJETS')
2564 IF(MSTU(21).GE.1) RETURN
2565 ENDIF
2566 IRANK=IRANK+1
2567 K(I,1)=1
2568 K(I,3)=IP1
2569 K(I,4)=0
2570 K(I,5)=0
2571 200 CALL LUKFDI(KFL1,0,KFL2,K(I,2))
2572 IF(K(I,2).EQ.0) GOTO 180
2573 IF(MSTJ(12).GE.3.AND.IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.
2574 &IABS(KFL2).GT.10) THEN
2575 IF(RLU(0).GT.PARJ(19)) GOTO 200
2576 ENDIF
2577
2578C...Find hadron mass. Generate four-momentum.
2579 P(I,5)=ULMASS(K(I,2))
2580 CALL LUPTDI(KFL1,PX2,PY2)
2581 P(I,1)=PX1+PX2
2582 P(I,2)=PY1+PY2
2583 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
2584 CALL LUZDIS(KFL1,KFL2,PR,Z)
2585 MZSAV=0
2586 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
2587 MZSAV=1
2588 MSTU(90)=MSTU(90)+1
2589 MSTU(90+MSTU(90))=I
2590 PARU(90+MSTU(90))=Z
2591 ENDIF
2592 P(I,3)=0.5*(Z*W-PR/(Z*W))
2593 P(I,4)=0.5*(Z*W+PR/(Z*W))
2594 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
2595 &P(I,3).LE.0.001) THEN
2596 IF(W.GE.P(I,5)+0.5*PARJ(32)) GOTO 180
2597 P(I,3)=0.0001
2598 P(I,4)=SQRT(PR)
2599 Z=P(I,4)/W
2600 ENDIF
2601
2602C...Remaining flavour and momentum.
2603 KFL1=-KFL2
2604 PX1=-PX2
2605 PY1=-PY2
2606 W=(1.-Z)*W
2607 DO 210 J=1,5
2608 210 V(I,J)=0.
2609
2610C...Check if pL acceptable. Go back for new hadron if enough energy.
2611 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0.) THEN
2612 I=I-1
2613 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
2614 ENDIF
2615 IF(W.GT.PARJ(31)) GOTO 190
2616 220 N=I
2617 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1*PARJ(32)
2618 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
2619
2620C...Rotate jet to new direction.
2621 THE=ULANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
2622 PHI=ULANGL(P(IP1,1),P(IP1,2))
2623 MSTU(33)=1
2624 CALL LUDBRB(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
2625 K(K(IP1,3),4)=NSAV1+1
2626 K(K(IP1,3),5)=N
2627
2628C...End of jet generation loop. Skip conservation in some cases.
2629 230 CONTINUE
2630 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 470
2631 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
2632
2633C...Subtract off produced hadron flavours, finished if zero.
2634 DO 240 I=NSAV+NJET+1,N
2635 KFA=IABS(K(I,2))
2636 KFLA=MOD(KFA/1000,10)
2637 KFLB=MOD(KFA/100,10)
2638 KFLC=MOD(KFA/10,10)
2639 IF(KFLA.EQ.0) THEN
2640 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
2641 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
2642 ELSE
2643 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
2644 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
2645 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
2646 ENDIF
2647 240 CONTINUE
2648 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2649 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2650 IF(NREQ.EQ.0) GOTO 320
2651
2652C...Take away flavour of low-momentum particles until enough freedom.
2653 NREM=0
2654 250 IREM=0
2655 P2MIN=PECM**2
2656 DO 260 I=NSAV+NJET+1,N
2657 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
2658 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
2659 260 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
2660 IF(IREM.EQ.0) GOTO 150
2661 K(IREM,1)=7
2662 KFA=IABS(K(IREM,2))
2663 KFLA=MOD(KFA/1000,10)
2664 KFLB=MOD(KFA/100,10)
2665 KFLC=MOD(KFA/10,10)
2666 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
2667 IF(K(IREM,1).EQ.8) GOTO 250
2668 IF(KFLA.EQ.0) THEN
2669 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
2670 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
2671 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
2672 ELSE
2673 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
2674 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
2675 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
2676 ENDIF
2677 NREM=NREM+1
2678 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2679 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2680 IF(NREQ.GT.NREM) GOTO 250
2681 DO 270 I=NSAV+NJET+1,N
2682 270 IF(K(I,1).EQ.8) K(I,1)=1
2683
2684C...Find combination of existing and new flavours for hadron.
2685 280 NFET=2
2686 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
2687 IF(NREQ.LT.NREM) NFET=1
2688 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
2689 DO 290 J=1,NFET
2690 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*RLU(0)
2691 KFLF(J)=ISIGN(1,NFL(1))
2692 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
2693 290 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
2694 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
2695 &GOTO 280
2696 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
2697 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3).
2698 &LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
2699 IF(NFET.EQ.0) KFLF(1)=1+INT((2.+PARJ(2))*RLU(0))
2700 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
2701 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2.+PARJ(2))*RLU(0)),-KFLF(1))
2702 IF(NFET.LE.2) KFLF(3)=0
2703 IF(KFLF(3).NE.0) THEN
2704 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
2705 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
2706 IF(KFLF(1).EQ.KFLF(3).OR.(1.+3.*PARJ(4))*RLU(0).GT.1.)
2707 & KFLFC=KFLFC+ISIGN(2,KFLFC)
2708 ELSE
2709 KFLFC=KFLF(1)
2710 ENDIF
2711 CALL LUKFDI(KFLFC,KFLF(2),KFLDMP,KF)
2712 IF(KF.EQ.0) GOTO 280
2713 DO 300 J=1,MAX(2,NFET)
2714 300 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
2715
2716C...Store hadron at random among free positions.
2717 NPOS=MIN(1+INT(RLU(0)*NREM),NREM)
2718 DO 310 I=NSAV+NJET+1,N
2719 IF(K(I,1).EQ.7) NPOS=NPOS-1
2720 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
2721 K(I,1)=1
2722 K(I,2)=KF
2723 P(I,5)=ULMASS(K(I,2))
2724 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2725 310 CONTINUE
2726 NREM=NREM-1
2727 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
2728 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
2729 IF(NREM.GT.0) GOTO 280
2730
2731C...Compensate for missing momentum in global scheme (3 options).
2732 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
2733 DO 330 J=1,3
2734 PSI(J)=0.
2735 DO 330 I=NSAV+NJET+1,N
2736 330 PSI(J)=PSI(J)+P(I,J)
2737 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
2738 PWS=0.
2739 DO 340 I=NSAV+NJET+1,N
2740 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
2741 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2742 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2743 340 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1.
2744 DO 360 I=NSAV+NJET+1,N
2745 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
2746 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
2747 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
2748 IF(MOD(MSTJ(3),5).EQ.3) PW=1.
2749 DO 350 J=1,3
2750 350 P(I,J)=P(I,J)-PSI(J)*PW/PWS
2751 360 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2752
2753C...Compensate for missing momentum withing each jet separately.
2754 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
2755 DO 370 I=N+1,N+NJET
2756 K(I,1)=0
2757 DO 370 J=1,5
2758 370 P(I,J)=0.
2759 DO 390 I=NSAV+NJET+1,N
2760 IR1=K(I,3)
2761 IR2=N+IR1-NSAV
2762 K(IR2,1)=K(IR2,1)+1
2763 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2764 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2765 DO 380 J=1,3
2766 380 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
2767 P(IR2,4)=P(IR2,4)+P(I,4)
2768 390 P(IR2,5)=P(IR2,5)+PLS
2769 PSS=0.
2770 DO 400 I=N+1,N+NJET
2771 400 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8*P(I,5)+0.2))
2772 DO 420 I=NSAV+NJET+1,N
2773 IR1=K(I,3)
2774 IR2=N+IR1-NSAV
2775 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
2776 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
2777 DO 410 J=1,3
2778 410 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1./(P(IR2,5)*PSS)-1.)*PLS*
2779 & P(IR1,J)
2780 420 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2781 ENDIF
2782
2783C...Scale momenta for energy conservation.
2784 IF(MOD(MSTJ(3),5).NE.0) THEN
2785 PMS=0.
2786 PES=0.
2787 PQS=0.
2788 DO 430 I=NSAV+NJET+1,N
2789 PMS=PMS+P(I,5)
2790 PES=PES+P(I,4)
2791 430 PQS=PQS+P(I,5)**2/P(I,4)
2792 IF(PMS.GE.PECM) GOTO 150
2793 NECO=0
2794 440 NECO=NECO+1
2795 PFAC=(PECM-PQS)/(PES-PQS)
2796 PES=0.
2797 PQS=0.
2798 DO 460 I=NSAV+NJET+1,N
2799 DO 450 J=1,3
2800 450 P(I,J)=PFAC*P(I,J)
2801 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
2802 PES=PES+P(I,4)
2803 460 PQS=PQS+P(I,5)**2/P(I,4)
2804 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2E-6*PECM) GOTO 440
2805 ENDIF
2806
2807C...Origin of produced particles and parton daughter pointers.
2808 470 DO 480 I=NSAV+NJET+1,N
2809 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
2810 480 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
2811 DO 490 I=NSAV+1,NSAV+NJET
2812 I1=K(I,3)
2813 K(I1,1)=K(I1,1)+10
2814 IF(MSTU(16).NE.2) THEN
2815 K(I1,4)=NSAV+1
2816 K(I1,5)=NSAV+1
2817 ELSE
2818 K(I1,4)=K(I1,4)-NJET+1
2819 K(I1,5)=K(I1,5)-NJET+1
2820 IF(K(I1,5).LT.K(I1,4)) THEN
2821 K(I1,4)=0
2822 K(I1,5)=0
2823 ENDIF
2824 ENDIF
2825 490 CONTINUE
2826
2827C...Document independent fragmentation system. Remove copy of jets.
2828 NSAV=NSAV+1
2829 K(NSAV,1)=11
2830 K(NSAV,2)=93
2831 K(NSAV,3)=IP
2832 K(NSAV,4)=NSAV+1
2833 K(NSAV,5)=N-NJET+1
2834 DO 500 J=1,4
2835 P(NSAV,J)=DPS(J)
2836 500 V(NSAV,J)=V(IP,J)
2837 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
2838 V(NSAV,5)=0.
2839 DO 510 I=NSAV+NJET,N
2840 DO 510 J=1,5
2841 K(I-NJET+1,J)=K(I,J)
2842 P(I-NJET+1,J)=P(I,J)
2843 510 V(I-NJET+1,J)=V(I,J)
2844 N=N-NJET+1
2845 DO 520 IZ=MSTU90+1,MSTU(90)
2846 520 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
2847
2848C...Boost back particle system. Set production vertices.
2849 IF(NJET.NE.1) CALL LUDBRB(NSAV+1,N,0.,0.,DPS(1)/DPS(4),
2850 &DPS(2)/DPS(4),DPS(3)/DPS(4))
2851 DO 530 I=NSAV+1,N
2852 DO 530 J=1,4
2853 530 V(I,J)=V(IP,J)
2854
2855 RETURN
2856 END
2857
2858C*********************************************************************
2859
2860 SUBROUTINE LUDECY(IP)
2861
2862C...Purpose: to handle the decay of unstable particles.
2863 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
2864 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2865 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
2866 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
2867 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
2868 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
2869 &WTCOR(10)
2870 DATA WTCOR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5,150.,16./
2871
2872C...Functions: momentum in two-particle decays, four-product and
2873C...matrix element times phase space in weak decays.
2874 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
2875 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)
2876 HMEPS(HA)=((1.-HRQ-HA)**2+3.*HA*(1.+HRQ-HA))*
2877 &SQRT((1.-HRQ-HA)**2-4.*HRQ*HA)
2878
2879C...Initial values.
2880 NTRY=0
2881 NSAV=N
2882 KFA=IABS(K(IP,2))
2883 KFS=ISIGN(1,K(IP,2))
2884 KC=LUCOMP(KFA)
2885 MSTJ(92)=0
2886
2887C...Choose lifetime and determine decay vertex.
2888 IF(K(IP,1).EQ.5) THEN
2889 V(IP,5)=0.
2890 ELSEIF(K(IP,1).NE.4) THEN
2891 V(IP,5)=-PMAS(KC,4)*LOG(RLU(0))
2892 ENDIF
2893 DO 100 J=1,4
2894 100 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
2895
2896C...Determine whether decay allowed or not.
2897 MOUT=0
2898 IF(MSTJ(22).EQ.2) THEN
2899 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
2900 ELSEIF(MSTJ(22).EQ.3) THEN
2901 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
2902 ELSEIF(MSTJ(22).EQ.4) THEN
2903 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
2904 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
2905 ENDIF
2906 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
2907 K(IP,1)=4
2908 RETURN
2909 ENDIF
2910
2911C...B-B~ mixing: flip sign of meson appropriately.
2912 MMIX=0
2913 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
2914 XBBMIX=PARJ(76)
2915 IF(KFA.EQ.531) XBBMIX=PARJ(77)
2916 IF(SIN(0.5*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.RLU(0)) MMIX=1
2917 IF(MMIX.EQ.1) KFS=-KFS
2918 ENDIF
2919
2920C...Check existence of decay channels. Particle/antiparticle rules.
2921 KCA=KC
2922 IF(MDCY(KC,2).GT.0) THEN
2923 MDMDCY=MDME(MDCY(KC,2),2)
2924 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
2925 ENDIF
2926 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
2927 CALL LUERRM(9,'(LUDECY:) no decay channel defined')
2928 RETURN
2929 ENDIF
2930 IF(MOD(KFA/1000,10).EQ.0.AND.(KCA.EQ.85.OR.KCA.EQ.87)) KFS=-KFS
2931 IF(KCHG(KC,3).EQ.0) THEN
2932 KFSP=1
2933 KFSN=0
2934 IF(RLU(0).GT.0.5) KFS=-KFS
2935 ELSEIF(KFS.GT.0) THEN
2936 KFSP=1
2937 KFSN=0
2938 ELSE
2939 KFSP=0
2940 KFSN=1
2941 ENDIF
2942
2943C...Sum branching ratios of allowed decay channels.
2944 110 NOPE=0
2945 BRSU=0.
2946 DO 120 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
2947 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2948 &KFSN*MDME(IDL,1).NE.3) GOTO 120
2949 IF(MDME(IDL,2).GT.100) GOTO 120
2950 NOPE=NOPE+1
2951 BRSU=BRSU+BRAT(IDL)
2952 120 CONTINUE
2953 IF(NOPE.EQ.0) THEN
2954 CALL LUERRM(2,'(LUDECY:) all decay channels closed by user')
2955 RETURN
2956 ENDIF
2957
2958C...Select decay channel among allowed ones.
2959 130 RBR=BRSU*RLU(0)
2960 IDL=MDCY(KCA,2)-1
2961 140 IDL=IDL+1
2962 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
2963 &KFSN*MDME(IDL,1).NE.3) THEN
2964 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2965 ELSEIF(MDME(IDL,2).GT.100) THEN
2966 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 140
2967 ELSE
2968 IDC=IDL
2969 RBR=RBR-BRAT(IDL)
2970 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0.) GOTO 140
2971 ENDIF
2972
2973C...Start readout of decay channel: matrix element, reset counters.
2974 MMAT=MDME(IDC,2)
2975 150 NTRY=NTRY+1
2976 IF(NTRY.GT.1000) THEN
2977 CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
2978 IF(MSTU(21).GE.1) RETURN
2979 ENDIF
2980 I=N
2981 NP=0
2982 NQ=0
2983 MBST=0
2984 IF(MMAT.GE.11.AND.MMAT.NE.46.AND.P(IP,4).GT.20.*P(IP,5)) MBST=1
2985 DO 160 J=1,4
2986 PV(1,J)=0.
2987 160 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
2988 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
2989 PV(1,5)=P(IP,5)
2990 PS=0.
2991 PSQ=0.
2992 MREM=0
2993
2994C...Read out decay products. Convert to standard flavour code.
2995 JTMAX=5
2996 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
2997 DO 170 JT=1,JTMAX
2998 IF(JT.LE.5) KP=KFDP(IDC,JT)
2999 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
3000 IF(KP.EQ.0) GOTO 170
3001 KPA=IABS(KP)
3002 KCP=LUCOMP(KPA)
3003 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
3004 KFP=KP
3005 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
3006 KFP=KFS*KP
3007 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
3008 KFP=-KFS*MOD(KFA/10,10)
3009 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
3010 KFP=KFS*(100*MOD(KFA/10,100)+3)
3011 ELSEIF(KPA.EQ.81) THEN
3012 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
3013 ELSEIF(KP.EQ.82) THEN
3014 CALL LUKFDI(-KFS*INT(1.+(2.+PARJ(2))*RLU(0)),0,KFP,KDUMP)
3015 IF(KFP.EQ.0) GOTO 150
3016 MSTJ(93)=1
3017 IF(PV(1,5).LT.PARJ(32)+2.*ULMASS(KFP)) GOTO 150
3018 ELSEIF(KP.EQ.-82) THEN
3019 KFP=-KFP
3020 IF(IABS(KFP).GT.10) KFP=KFP+ISIGN(10000,KFP)
3021 ENDIF
3022 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=LUCOMP(KFP)
3023
3024C...Add decay product to event record or to quark flavour list.
3025 KFPA=IABS(KFP)
3026 KQP=KCHG(KCP,2)
3027 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
3028 NQ=NQ+1
3029 KFLO(NQ)=KFP
3030 MSTJ(93)=2
3031 PSQ=PSQ+ULMASS(KFLO(NQ))
3032 ELSEIF(MMAT.GE.42.AND.MMAT.LE.43.AND.NP.EQ.3.AND.MOD(NQ,2).EQ.1)
3033 &THEN
3034 NQ=NQ-1
3035 PS=PS-P(I,5)
3036 K(I,1)=1
3037 KFI=K(I,2)
3038 CALL LUKFDI(KFP,KFI,KFLDMP,K(I,2))
3039 IF(K(I,2).EQ.0) GOTO 150
3040 MSTJ(93)=1
3041 P(I,5)=ULMASS(K(I,2))
3042 PS=PS+P(I,5)
3043 ELSE
3044 I=I+1
3045 NP=NP+1
3046 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
3047 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
3048 K(I,1)=1+MOD(NQ,2)
3049 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
3050 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
3051 K(I,2)=KFP
3052 K(I,3)=IP
3053 K(I,4)=0
3054 K(I,5)=0
3055 P(I,5)=ULMASS(KFP)
3056 IF(MMAT.EQ.45.AND.KFPA.EQ.89) P(I,5)=PARJ(32)
3057 PS=PS+P(I,5)
3058 ENDIF
3059 170 CONTINUE
3060
3061C...Choose decay multiplicity in phase space model.
3062 180 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
3063 PSP=PS
3064 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1))
3065 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
3066 190 NTRY=NTRY+1
3067 IF(NTRY.GT.1000) THEN
3068 CALL LUERRM(14,'(LUDECY:) caught in infinite loop')
3069 IF(MSTU(21).GE.1) RETURN
3070 ENDIF
3071 IF(MMAT.LE.20) THEN
3072 GAUSS=SQRT(-2.*CNDE*LOG(MAX(1E-10,RLU(0))))*
3073 & SIN(PARU(2)*RLU(0))
3074 ND=0.5+0.5*NP+0.25*NQ+CNDE+GAUSS
3075 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 190
3076 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 190
3077 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 190
3078 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 190
3079 ELSE
3080 ND=MMAT-20
3081 ENDIF
3082
3083C...Form hadrons from flavour content.
3084 DO 200 JT=1,4
3085 200 KFL1(JT)=KFLO(JT)
3086 IF(ND.EQ.NP+NQ/2) GOTO 220
3087 DO 210 I=N+NP+1,N+ND-NQ/2
3088 JT=1+INT((NQ-1)*RLU(0))
3089 CALL LUKFDI(KFL1(JT),0,KFL2,K(I,2))
3090 IF(K(I,2).EQ.0) GOTO 190
3091 210 KFL1(JT)=-KFL2
3092 220 JT=2
3093 JT2=3
3094 JT3=4
3095 IF(NQ.EQ.4.AND.RLU(0).LT.PARJ(66)) JT=4
3096 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
3097 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
3098 IF(JT.EQ.3) JT2=2
3099 IF(JT.EQ.4) JT3=2
3100 CALL LUKFDI(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
3101 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 190
3102 IF(NQ.EQ.4) CALL LUKFDI(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
3103 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 190
3104
3105C...Check that sum of decay product masses not too large.
3106 PS=PSP
3107 DO 230 I=N+NP+1,N+ND
3108 K(I,1)=1
3109 K(I,3)=IP
3110 K(I,4)=0
3111 K(I,5)=0
3112 P(I,5)=ULMASS(K(I,2))
3113 230 PS=PS+P(I,5)
3114 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 190
3115
3116C...Rescale energy to subtract off spectator quark mass.
3117 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44.OR.MMAT.EQ.45).
3118 &AND.NP.GE.3) THEN
3119 PS=PS-P(N+NP,5)
3120 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
3121 DO 240 J=1,5
3122 P(N+NP,J)=PQT*PV(1,J)
3123 240 PV(1,J)=(1.-PQT)*PV(1,J)
3124 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 150
3125 ND=NP-1
3126 MREM=1
3127
3128C...Phase space factors imposed in W decay.
3129 ELSEIF(MMAT.EQ.46) THEN
3130 MSTJ(93)=1
3131 PSMC=ULMASS(K(N+1,2))
3132 MSTJ(93)=1
3133 PSMC=PSMC+ULMASS(K(N+2,2))
3134 IF(MAX(PS,PSMC)+PARJ(32).GT.PV(1,5)) GOTO 130
3135 HR1=(P(N+1,5)/PV(1,5))**2
3136 HR2=(P(N+2,5)/PV(1,5))**2
3137 IF((1.-HR1-HR2)*(2.+HR1+HR2)*SQRT((1.-HR1-HR2)**2-4.*HR1*HR2).
3138 & LT.2.*RLU(0)) GOTO 130
3139 ND=NP
3140
3141C...Fully specified final state: check mass broadening effects.
3142 ELSE
3143 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 150
3144 ND=NP
3145 ENDIF
3146
3147C...Select W mass in decay Q -> W + q, without W propagator.
3148 IF(MMAT.EQ.45.AND.MSTJ(25).LE.0) THEN
3149 HLQ=(PARJ(32)/PV(1,5))**2
3150 HUQ=(1.-(P(N+2,5)+PARJ(64))/PV(1,5))**2
3151 HRQ=(P(N+2,5)/PV(1,5))**2
3152 250 HW=HLQ+RLU(0)*(HUQ-HLQ)
3153 IF(HMEPS(HW).LT.RLU(0)) GOTO 250
3154 P(N+1,5)=PV(1,5)*SQRT(HW)
3155
3156C...Ditto, including W propagator. Divide mass range into three regions.
3157 ELSEIF(MMAT.EQ.45) THEN
3158 HQW=(PV(1,5)/PMAS(24,1))**2
3159 HLW=(PARJ(32)/PMAS(24,1))**2
3160 HUW=((PV(1,5)-P(N+2,5)-PARJ(64))/PMAS(24,1))**2
3161 HRQ=(P(N+2,5)/PV(1,5))**2
3162 HG=PMAS(24,2)/PMAS(24,1)
3163 HATL=ATAN((HLW-1.)/HG)
3164 HM=MIN(1.,HUW-0.001)
3165 HMV1=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3166 260 HM=HM-HG
3167 HMV2=HMEPS(HM/HQW)/((HM-1.)**2+HG**2)
3168 IF(HMV2.GT.HMV1.AND.HM-HG.GT.HLW) THEN
3169 HMV1=HMV2
3170 GOTO 260
3171 ENDIF
3172 HMV=MIN(2.*HMV1,HMEPS(HM/HQW)/HG**2)
3173 HM1=1.-SQRT(1./HMV-HG**2)
3174 IF(HM1.GT.HLW.AND.HM1.LT.HM) THEN
3175 HM=HM1
3176 ELSEIF(HMV2.LE.HMV1) THEN
3177 HM=MAX(HLW,HM-MIN(0.1,1.-HM))
3178 ENDIF
3179 HATM=ATAN((HM-1.)/HG)
3180 HWT1=(HATM-HATL)/HG
3181 HWT2=HMV*(MIN(1.,HUW)-HM)
3182 HWT3=0.
3183 IF(HUW.GT.1.) THEN
3184 HATU=ATAN((HUW-1.)/HG)
3185 HMP1=HMEPS(1./HQW)
3186 HWT3=HMP1*HATU/HG
3187 ENDIF
3188
3189C...Select mass region and W mass there. Accept according to weight.
3190 270 HREG=RLU(0)*(HWT1+HWT2+HWT3)
3191 IF(HREG.LE.HWT1) THEN
3192 HW=1.+HG*TAN(HATL+RLU(0)*(HATM-HATL))
3193 HACC=HMEPS(HW/HQW)
3194 ELSEIF(HREG.LE.HWT1+HWT2) THEN
3195 HW=HM+RLU(0)*(MIN(1.,HUW)-HM)
3196 HACC=HMEPS(HW/HQW)/((HW-1.)**2+HG**2)/HMV
3197 ELSE
3198 HW=1.+HG*TAN(RLU(0)*HATU)
3199 HACC=HMEPS(HW/HQW)/HMP1
3200 ENDIF
3201 IF(HACC.LT.RLU(0)) GOTO 270
3202 P(N+1,5)=PMAS(24,1)*SQRT(HW)
3203 ENDIF
3204
3205C...Determine position of grandmother, number of sisters, Q -> W sign.
3206 NM=0
3207 KFAS=0
3208 MSGN=0
3209 IF(MMAT.EQ.3.OR.MMAT.EQ.46) THEN
3210 IM=K(IP,3)
3211 IF(IM.LT.0.OR.IM.GE.IP) IM=0
3212 IF(IM.NE.0) KFAM=IABS(K(IM,2))
3213 IF(IM.NE.0.AND.MMAT.EQ.3) THEN
3214 DO 280 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
3215 IF(K(IL,3).EQ.IM) NM=NM+1
3216 280 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
3217 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
3218 & MOD(KFAM/1000,10).NE.0) NM=0
3219 IF(NM.EQ.2) THEN
3220 KFAS=IABS(K(ISIS,2))
3221 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
3222 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
3223 ENDIF
3224 ELSEIF(IM.NE.0.AND.MMAT.EQ.46) THEN
3225 MSGN=ISIGN(1,K(IM,2)*K(IP,2))
3226 IF(KFAM.GT.100.AND.MOD(KFAM/1000,10).EQ.0) MSGN=
3227 & MSGN*(-1)**MOD(KFAM/100,10)
3228 ENDIF
3229 ENDIF
3230
3231C...Kinematics of one-particle decays.
3232 IF(ND.EQ.1) THEN
3233 DO 290 J=1,4
3234 290 P(N+1,J)=P(IP,J)
3235 GOTO 520
3236 ENDIF
3237
3238C...Calculate maximum weight ND-particle decay.
3239 PV(ND,5)=P(N+ND,5)
3240 IF(ND.GE.3) THEN
3241 WTMAX=1./WTCOR(ND-2)
3242 PMAX=PV(1,5)-PS+P(N+ND,5)
3243 PMIN=0.
3244 DO 300 IL=ND-1,1,-1
3245 PMAX=PMAX+P(N+IL,5)
3246 PMIN=PMIN+P(N+IL+1,5)
3247 300 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
3248 ENDIF
3249
3250C...Find virtual gamma mass in Dalitz decay.
3251 310 IF(ND.EQ.2) THEN
3252 ELSEIF(MMAT.EQ.2) THEN
3253 PMES=4.*PMAS(11,1)**2
3254 PMRHO2=PMAS(131,1)**2
3255 PGRHO2=PMAS(131,2)**2
3256 320 PMST=PMES*(P(IP,5)**2/PMES)**RLU(0)
3257 WT=(1+0.5*PMES/PMST)*SQRT(MAX(0.,1.-PMES/PMST))*
3258 & (1.-PMST/P(IP,5)**2)**3*(1.+PGRHO2/PMRHO2)/
3259 & ((1.-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
3260 IF(WT.LT.RLU(0)) GOTO 320
3261 PV(2,5)=MAX(2.00001*PMAS(11,1),SQRT(PMST))
3262
3263C...M-generator gives weight. If rejected, try again.
3264 ELSE
3265 330 RORD(1)=1.
3266 DO 350 IL1=2,ND-1
3267 RSAV=RLU(0)
3268 DO 340 IL2=IL1-1,1,-1
3269 IF(RSAV.LE.RORD(IL2)) GOTO 350
3270 340 RORD(IL2+1)=RORD(IL2)
3271 350 RORD(IL2+1)=RSAV
3272 RORD(ND)=0.
3273 WT=1.
3274 DO 360 IL=ND-1,1,-1
3275 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*(PV(1,5)-PS)
3276 360 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3277 IF(WT.LT.RLU(0)*WTMAX) GOTO 330
3278 ENDIF
3279
3280C...Perform two-particle decays in respective CM frame.
3281 370 DO 390 IL=1,ND-1
3282 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
3283 UE(3)=2.*RLU(0)-1.
3284 PHI=PARU(2)*RLU(0)
3285 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
3286 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
3287 DO 380 J=1,3
3288 P(N+IL,J)=PA*UE(J)
3289 380 PV(IL+1,J)=-PA*UE(J)
3290 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
3291 390 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
3292
3293C...Lorentz transform decay products to lab frame.
3294 DO 400 J=1,4
3295 400 P(N+ND,J)=PV(ND,J)
3296 DO 430 IL=ND-1,1,-1
3297 DO 410 J=1,3
3298 410 BE(J)=PV(IL,J)/PV(IL,4)
3299 GA=PV(IL,4)/PV(IL,5)
3300 DO 430 I=N+IL,N+ND
3301 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3302 DO 420 J=1,3
3303 420 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3304 430 P(I,4)=GA*(P(I,4)+BEP)
3305
3306C...Check that no infinite loop in matrix element weight.
3307 NTRY=NTRY+1
3308 IF(NTRY.GT.800) GOTO 450
3309
3310C...Matrix elements for omega and phi decays.
3311 IF(MMAT.EQ.1) THEN
3312 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
3313 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
3314 & +2.*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
3315 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001).LT.RLU(0)) GOTO 310
3316
3317C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3318 ELSEIF(MMAT.EQ.2) THEN
3319 FOUR12=FOUR(N+1,N+2)
3320 FOUR13=FOUR(N+1,N+3)
3321 WT=(PMST-0.5*PMES)*(FOUR12**2+FOUR13**2)+
3322 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
3323 IF(WT.LT.RLU(0)*0.25*PMST*(P(IP,5)**2-PMST)**2) GOTO 370
3324
3325C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3326C...V vector), of form cos**2(theta02) in V1 rest frame, and for
3327C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
3328 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
3329 FOUR10=FOUR(IP,IM)
3330 FOUR12=FOUR(IP,N+1)
3331 FOUR02=FOUR(IM,N+1)
3332 PMS1=P(IP,5)**2
3333 PMS0=P(IM,5)**2
3334 PMS2=P(N+1,5)**2
3335 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
3336 IF(KFAS.EQ.22) HNUM=PMS1*(2.*FOUR10*FOUR12*FOUR02-
3337 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
3338 HNUM=MAX(1E-6*PMS1**2*PMS0*PMS2,HNUM)
3339 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
3340 IF(HNUM.LT.RLU(0)*HDEN) GOTO 370
3341
3342C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3343 ELSEIF(MMAT.EQ.4) THEN
3344 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3345 HX2=2.*FOUR(IP,N+2)/P(IP,5)**2
3346 HX3=2.*FOUR(IP,N+3)/P(IP,5)**2
3347 WT=((1.-HX1)/(HX2*HX3))**2+((1.-HX2)/(HX1*HX3))**2+
3348 & ((1.-HX3)/(HX1*HX2))**2
3349 IF(WT.LT.2.*RLU(0)) GOTO 310
3350 IF(K(IP+1,2).EQ.22.AND.(1.-HX1)*P(IP,5)**2.LT.4.*PARJ(32)**2)
3351 & GOTO 310
3352
3353C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3354 ELSEIF(MMAT.EQ.41) THEN
3355 HX1=2.*FOUR(IP,N+1)/P(IP,5)**2
3356 IF(8.*HX1*(3.-2.*HX1)/9..LT.RLU(0)) GOTO 310
3357
3358C...Matrix elements for weak decays (only semileptonic for c and b)
3359 ELSEIF(MMAT.GE.42.AND.MMAT.LE.44.AND.ND.EQ.3) THEN
3360 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
3361 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
3362 IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3363 ELSEIF(MMAT.GE.42.AND.MMAT.LE.44) THEN
3364 DO 440 J=1,4
3365 P(N+NP+1,J)=0.
3366 DO 440 IS=N+3,N+NP
3367 440 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
3368 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
3369 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
3370 IF(WT.LT.RLU(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 310
3371
3372C...Angular distribution in W decay.
3373 ELSEIF(MMAT.EQ.46.AND.MSGN.NE.0) THEN
3374 IF(MSGN.GT.0) WT=FOUR(IM,N+1)*FOUR(N+2,IP+1)
3375 IF(MSGN.LT.0) WT=FOUR(IM,N+2)*FOUR(N+1,IP+1)
3376 IF(WT.LT.RLU(0)*P(IM,5)**4/WTCOR(10)) GOTO 370
3377 ENDIF
3378
3379C...Scale back energy and reattach spectator.
3380 450 IF(MREM.EQ.1) THEN
3381 DO 460 J=1,5
3382 460 PV(1,J)=PV(1,J)/(1.-PQT)
3383 ND=ND+1
3384 MREM=0
3385 ENDIF
3386
3387C...Low invariant mass for system with spectator quark gives particle,
3388C...not two jets. Readjust momenta accordingly.
3389 IF((MMAT.EQ.31.OR.MMAT.EQ.45).AND.ND.EQ.3) THEN
3390 MSTJ(93)=1
3391 PM2=ULMASS(K(N+2,2))
3392 MSTJ(93)=1
3393 PM3=ULMASS(K(N+3,2))
3394 IF(P(N+2,5)**2+P(N+3,5)**2+2.*FOUR(N+2,N+3).GE.
3395 & (PARJ(32)+PM2+PM3)**2) GOTO 520
3396 K(N+2,1)=1
3397 KFTEMP=K(N+2,2)
3398 CALL LUKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
3399 IF(K(N+2,2).EQ.0) GOTO 150
3400 P(N+2,5)=ULMASS(K(N+2,2))
3401 PS=P(N+1,5)+P(N+2,5)
3402 PV(2,5)=P(N+2,5)
3403 MMAT=0
3404 ND=2
3405 GOTO 370
3406 ELSEIF(MMAT.EQ.44) THEN
3407 MSTJ(93)=1
3408 PM3=ULMASS(K(N+3,2))
3409 MSTJ(93)=1
3410 PM4=ULMASS(K(N+4,2))
3411 IF(P(N+3,5)**2+P(N+4,5)**2+2.*FOUR(N+3,N+4).GE.
3412 & (PARJ(32)+PM3+PM4)**2) GOTO 490
3413 K(N+3,1)=1
3414 KFTEMP=K(N+3,2)
3415 CALL LUKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
3416 IF(K(N+3,2).EQ.0) GOTO 150
3417 P(N+3,5)=ULMASS(K(N+3,2))
3418 DO 470 J=1,3
3419 470 P(N+3,J)=P(N+3,J)+P(N+4,J)
3420 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)
3421 HA=P(N+1,4)**2-P(N+2,4)**2
3422 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
3423 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
3424 & (P(N+1,3)-P(N+2,3))**2
3425 HD=(PV(1,4)-P(N+3,4))**2
3426 HE=HA**2-2.*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
3427 HF=HD*HC-HB**2
3428 HG=HD*HC-HA*HB
3429 HH=(SQRT(HG**2+HE*HF)-HG)/(2.*HF)
3430 DO 480 J=1,3
3431 PCOR=HH*(P(N+1,J)-P(N+2,J))
3432 P(N+1,J)=P(N+1,J)+PCOR
3433 480 P(N+2,J)=P(N+2,J)-PCOR
3434 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)
3435 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)
3436 ND=ND-1
3437 ENDIF
3438
3439C...Check invariant mass of W jets. May give one particle or start over.
3440 490 IF(MMAT.GE.42.AND.MMAT.LE.44.AND.IABS(K(N+1,2)).LT.10) THEN
3441 PMR=SQRT(MAX(0.,P(N+1,5)**2+P(N+2,5)**2+2.*FOUR(N+1,N+2)))
3442 MSTJ(93)=1
3443 PM1=ULMASS(K(N+1,2))
3444 MSTJ(93)=1
3445 PM2=ULMASS(K(N+2,2))
3446 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 500
3447 KFLDUM=INT(1.5+RLU(0))
3448 CALL LUKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
3449 CALL LUKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
3450 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 150
3451 PSM=ULMASS(KF1)+ULMASS(KF2)
3452 IF(MMAT.EQ.42.AND.PMR.GT.PARJ(64)+PSM) GOTO 500
3453 IF(MMAT.GE.43.AND.PMR.GT.0.2*PARJ(32)+PSM) GOTO 500
3454 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 150
3455 K(N+1,1)=1
3456 KFTEMP=K(N+1,2)
3457 CALL LUKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
3458 IF(K(N+1,2).EQ.0) GOTO 150
3459 P(N+1,5)=ULMASS(K(N+1,2))
3460 K(N+2,2)=K(N+3,2)
3461 P(N+2,5)=P(N+3,5)
3462 PS=P(N+1,5)+P(N+2,5)
3463 PV(2,5)=P(N+3,5)
3464 MMAT=0
3465 ND=2
3466 GOTO 370
3467 ENDIF
3468
3469C...Phase space decay of partons from W decay.
3470 500 IF(MMAT.EQ.42.AND.IABS(K(N+1,2)).LT.10) THEN
3471 KFLO(1)=K(N+1,2)
3472 KFLO(2)=K(N+2,2)
3473 K(N+1,1)=K(N+3,1)
3474 K(N+1,2)=K(N+3,2)
3475 DO 510 J=1,5
3476 PV(1,J)=P(N+1,J)+P(N+2,J)
3477 510 P(N+1,J)=P(N+3,J)
3478 PV(1,5)=PMR
3479 N=N+1
3480 NP=0
3481 NQ=2
3482 PS=0.
3483 MSTJ(93)=2
3484 PSQ=ULMASS(KFLO(1))
3485 MSTJ(93)=2
3486 PSQ=PSQ+ULMASS(KFLO(2))
3487 MMAT=11
3488 GOTO 180
3489 ENDIF
3490
3491C...Boost back for rapidly moving particle.
3492 520 N=N+ND
3493 IF(MBST.EQ.1) THEN
3494 DO 530 J=1,3
3495 530 BE(J)=P(IP,J)/P(IP,4)
3496 GA=P(IP,4)/P(IP,5)
3497 DO 550 I=NSAV+1,N
3498 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
3499 DO 540 J=1,3
3500 540 P(I,J)=P(I,J)+GA*(GA*BEP/(1.+GA)+P(I,4))*BE(J)
3501 550 P(I,4)=GA*(P(I,4)+BEP)
3502 ENDIF
3503
3504C...Fill in position of decay vertex.
3505 DO 570 I=NSAV+1,N
3506 DO 560 J=1,4
3507 560 V(I,J)=VDCY(J)
3508 570 V(I,5)=0.
3509
3510C...Set up for parton shower evolution from jets.
3511 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
3512 K(NSAV+1,1)=3
3513 K(NSAV+2,1)=3
3514 K(NSAV+3,1)=3
3515 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3516 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3517 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3518 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3519 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3520 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3521 MSTJ(92)=-(NSAV+1)
3522 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
3523 K(NSAV+2,1)=3
3524 K(NSAV+3,1)=3
3525 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
3526 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
3527 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
3528 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
3529 MSTJ(92)=NSAV+2
3530 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
3531 &AND.IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
3532 K(NSAV+1,1)=3
3533 K(NSAV+2,1)=3
3534 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
3535 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
3536 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
3537 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
3538 MSTJ(92)=NSAV+1
3539 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44.OR.MMAT.EQ.46).
3540 &AND.IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
3541 MSTJ(92)=NSAV+1
3542 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
3543 &THEN
3544 K(NSAV+1,1)=3
3545 K(NSAV+2,1)=3
3546 K(NSAV+3,1)=3
3547 KCP=LUCOMP(K(NSAV+1,2))
3548 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
3549 JCON=4
3550 IF(KQP.LT.0) JCON=5
3551 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
3552 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
3553 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
3554 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
3555 MSTJ(92)=NSAV+1
3556 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
3557 K(NSAV+1,1)=3
3558 K(NSAV+3,1)=3
3559 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
3560 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
3561 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
3562 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
3563 MSTJ(92)=NSAV+1
3564 ENDIF
3565
3566C...Mark decayed particle; special option for B-B~ mixing.
3567 IF(K(IP,1).EQ.5) K(IP,1)=15
3568 IF(K(IP,1).LE.10) K(IP,1)=11
3569 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
3570 K(IP,4)=NSAV+1
3571 K(IP,5)=N
3572
3573 RETURN
3574 END
3575
3576C*********************************************************************
3577
3578 SUBROUTINE LUKFDI(KFL1,KFL2,KFL3,KF)
3579
3580C...Purpose: to generate a new flavour pair and combine off a hadron.
3581 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3582 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3583 SAVE /LUDAT1/,/LUDAT2/
3584
3585C...Default flavour values. Input consistency checks.
3586 KF1A=IABS(KFL1)
3587 KF2A=IABS(KFL2)
3588 KFL3=0
3589 KF=0
3590 IF(KF1A.EQ.0) RETURN
3591 IF(KF2A.NE.0) THEN
3592 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
3593 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
3594 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
3595 ENDIF
3596
3597C...Check if tabulated flavour probabilities are to be used.
3598 IF(MSTJ(15).EQ.1) THEN
3599 KTAB1=-1
3600 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
3601 KFL1A=MOD(KF1A/1000,10)
3602 KFL1B=MOD(KF1A/100,10)
3603 KFL1S=MOD(KF1A,10)
3604 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
3605 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
3606 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
3607 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
3608 KTAB2=0
3609 IF(KF2A.NE.0) THEN
3610 KTAB2=-1
3611 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
3612 KFL2A=MOD(KF2A/1000,10)
3613 KFL2B=MOD(KF2A/100,10)
3614 KFL2S=MOD(KF2A,10)
3615 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
3616 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
3617 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
3618 ENDIF
3619 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
3620 ENDIF
3621
3622C...Parameters and breaking diquark parameter combinations.
3623 100 PAR2=PARJ(2)
3624 PAR3=PARJ(3)
3625 PAR4=3.*PARJ(4)
3626 IF(MSTJ(12).GE.2) THEN
3627 PAR3M=SQRT(PARJ(3))
3628 PAR4M=1./(3.*SQRT(PARJ(4)))
3629 PARDM=PARJ(7)/(PARJ(7)+PAR3M*PARJ(6))
3630 PARS0=PARJ(5)*(2.+(1.+PAR2*PAR3M*PARJ(7))*(1.+PAR4M))
3631 PARS1=PARJ(7)*PARS0/(2.*PAR3M)+PARJ(5)*(PARJ(6)*(1.+PAR4M)+
3632 & PAR2*PAR3M*PARJ(6)*PARJ(7))
3633 PARS2=PARJ(5)*2.*PARJ(6)*PARJ(7)*(PAR2*PARJ(7)+(1.+PAR4M)/PAR3M)
3634 PARSM=MAX(PARS0,PARS1,PARS2)
3635 PAR4=PAR4*(1.+PARSM)/(1.+PARSM/(3.*PAR4M))
3636 ENDIF
3637
3638C...Choice of whether to generate meson or baryon.
3639 MBARY=0
3640 KFDA=0
3641 IF(KF1A.LE.10) THEN
3642 IF(KF2A.EQ.0.AND.MSTJ(12).GE.1.AND.(1.+PARJ(1))*RLU(0).GT.1.)
3643 & MBARY=1
3644 IF(KF2A.GT.10) MBARY=2
3645 IF(KF2A.GT.10.AND.KF2A.LE.10000) KFDA=KF2A
3646 ELSE
3647 MBARY=2
3648 IF(KF1A.LE.10000) KFDA=KF1A
3649 ENDIF
3650
3651C...Possibility of process diquark -> meson + new diquark.
3652 IF(KFDA.NE.0.AND.MSTJ(12).GE.2) THEN
3653 KFLDA=MOD(KFDA/1000,10)
3654 KFLDB=MOD(KFDA/100,10)
3655 KFLDS=MOD(KFDA,10)
3656 WTDQ=PARS0
3657 IF(MAX(KFLDA,KFLDB).EQ.3) WTDQ=PARS1
3658 IF(MIN(KFLDA,KFLDB).EQ.3) WTDQ=PARS2
3659 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3660 IF((1.+WTDQ)*RLU(0).GT.1.) MBARY=-1
3661 IF(MBARY.EQ.-1.AND.KF2A.NE.0) RETURN
3662 ENDIF
3663
3664C...Flavour for meson, possibly with new flavour.
3665 IF(MBARY.LE.0) THEN
3666 KFS=ISIGN(1,KFL1)
3667 IF(MBARY.EQ.0) THEN
3668 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),-KFL1)
3669 KFLA=MAX(KF1A,KF2A+IABS(KFL3))
3670 KFLB=MIN(KF1A,KF2A+IABS(KFL3))
3671 IF(KFLA.NE.KF1A) KFS=-KFS
3672
3673C...Splitting of diquark into meson plus new diquark.
3674 ELSE
3675 KFL1A=MOD(KF1A/1000,10)
3676 KFL1B=MOD(KF1A/100,10)
3677 110 KFL1D=KFL1A+INT(RLU(0)+0.5)*(KFL1B-KFL1A)
3678 KFL1E=KFL1A+KFL1B-KFL1D
3679 IF((KFL1D.EQ.3.AND.RLU(0).GT.PARDM).OR.(KFL1E.EQ.3.AND.
3680 & RLU(0).LT.PARDM)) THEN
3681 KFL1D=KFL1A+KFL1B-KFL1D
3682 KFL1E=KFL1A+KFL1B-KFL1E
3683 ENDIF
3684 KFL3A=1+INT((2.+PAR2*PAR3M*PARJ(7))*RLU(0))
3685 IF((KFL1E.NE.KFL3A.AND.RLU(0).GT.(1.+PAR4M)/MAX(2.,1.+PAR4M)).
3686 & OR.(KFL1E.EQ.KFL3A.AND.RLU(0).GT.2./MAX(2.,1.+PAR4M)))
3687 & GOTO 110
3688 KFLDS=3
3689 IF(KFL1E.NE.KFL3A) KFLDS=2*INT(RLU(0)+1./(1.+PAR4M))+1
3690 KFL3=ISIGN(10000+1000*MAX(KFL1E,KFL3A)+100*MIN(KFL1E,KFL3A)+
3691 & KFLDS,-KFL1)
3692 KFLA=MAX(KFL1D,KFL3A)
3693 KFLB=MIN(KFL1D,KFL3A)
3694 IF(KFLA.NE.KFL1D) KFS=-KFS
3695 ENDIF
3696
3697C...Form meson, with spin and flavour mixing for diagonal states.
3698 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+RLU(0))
3699 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+RLU(0))
3700 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+RLU(0))
3701 IF(KMUL.EQ.0.AND.PARJ(14).GT.0.) THEN
3702 IF(RLU(0).LT.PARJ(14)) KMUL=2
3703 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0.) THEN
3704 RMUL=RLU(0)
3705 IF(RMUL.LT.PARJ(15)) KMUL=3
3706 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
3707 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
3708 ENDIF
3709 KFLS=3
3710 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
3711 IF(KMUL.EQ.5) KFLS=5
3712 IF(KFLA.NE.KFLB) THEN
3713 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
3714 ELSE
3715 RMIX=RLU(0)
3716 IMIX=2*KFLA+10*KMUL
3717 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
3718 & INT(RMIX+PARF(IMIX)))+KFLS
3719 IF(KFLA.GE.4) KF=110*KFLA+KFLS
3720 ENDIF
3721 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
3722 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
3723
3724C...Generate diquark flavour.
3725 ELSE
3726 120 IF(KF1A.LE.10.AND.KF2A.EQ.0) THEN
3727 KFLA=KF1A
3728 130 KFLB=1+INT((2.+PAR2*PAR3)*RLU(0))
3729 KFLC=1+INT((2.+PAR2*PAR3)*RLU(0))
3730 KFLDS=1
3731 IF(KFLB.GE.KFLC) KFLDS=3
3732 IF(KFLDS.EQ.1.AND.PAR4*RLU(0).GT.1.) GOTO 130
3733 IF(KFLDS.EQ.3.AND.PAR4.LT.RLU(0)) GOTO 130
3734 KFL3=ISIGN(1000*MAX(KFLB,KFLC)+100*MIN(KFLB,KFLC)+KFLDS,KFL1)
3735
3736C...Take diquark flavour from input.
3737 ELSEIF(KF1A.LE.10) THEN
3738 KFLA=KF1A
3739 KFLB=MOD(KF2A/1000,10)
3740 KFLC=MOD(KF2A/100,10)
3741 KFLDS=MOD(KF2A,10)
3742
3743C...Generate (or take from input) quark to go with diquark.
3744 ELSE
3745 IF(KF2A.EQ.0) KFL3=ISIGN(1+INT((2.+PAR2)*RLU(0)),KFL1)
3746 KFLA=KF2A+IABS(KFL3)
3747 KFLB=MOD(KF1A/1000,10)
3748 KFLC=MOD(KF1A/100,10)
3749 KFLDS=MOD(KF1A,10)
3750 ENDIF
3751
3752C...SU(6) factors for formation of baryon. Try again if fails.
3753 KBARY=KFLDS
3754 IF(KFLDS.EQ.3.AND.KFLB.NE.KFLC) KBARY=5
3755 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC) KBARY=KBARY+1
3756 WT=PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY)
3757 IF(MBARY.EQ.1.AND.MSTJ(12).GE.2) THEN
3758 WTDQ=PARS0
3759 IF(MAX(KFLB,KFLC).EQ.3) WTDQ=PARS1
3760 IF(MIN(KFLB,KFLC).EQ.3) WTDQ=PARS2
3761 IF(KFLDS.EQ.1) WTDQ=WTDQ/(3.*PAR4M)
3762 IF(KFLDS.EQ.1) WT=WT*(1.+WTDQ)/(1.+PARSM/(3.*PAR4M))
3763 IF(KFLDS.EQ.3) WT=WT*(1.+WTDQ)/(1.+PARSM)
3764 ENDIF
3765 IF(KF2A.EQ.0.AND.WT.LT.RLU(0)) GOTO 120
3766
3767C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3768 KFLD=MAX(KFLA,KFLB,KFLC)
3769 KFLF=MIN(KFLA,KFLB,KFLC)
3770 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3771 KFLS=2
3772 IF((PARF(60+KBARY)+PARJ(18)*PARF(70+KBARY))*RLU(0).GT.
3773 & PARF(60+KBARY)) KFLS=4
3774 KFLL=0
3775 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF) THEN
3776 IF(KFLDS.EQ.1.AND.KFLA.EQ.KFLD) KFLL=1
3777 IF(KFLDS.EQ.1.AND.KFLA.NE.KFLD) KFLL=INT(0.25+RLU(0))
3778 IF(KFLDS.EQ.3.AND.KFLA.NE.KFLD) KFLL=INT(0.75+RLU(0))
3779 ENDIF
3780 IF(KFLL.EQ.0) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
3781 IF(KFLL.EQ.1) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
3782 ENDIF
3783 RETURN
3784
3785C...Use tabulated probabilities to select new flavour and hadron.
3786 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
3787 KT3L=1
3788 KT3U=6
3789 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
3790 KT3L=1
3791 KT3U=6
3792 ELSEIF(KTAB2.EQ.0) THEN
3793 KT3L=1
3794 KT3U=22
3795 ELSE
3796 KT3L=KTAB2
3797 KT3U=KTAB2
3798 ENDIF
3799 RFL=0.
3800 DO 150 KTS=0,2
3801 DO 150 KT3=KT3L,KT3U
3802 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
3803 150 CONTINUE
3804 RFL=RLU(0)*RFL
3805 DO 160 KTS=0,2
3806 KTABS=KTS
3807 DO 160 KT3=KT3L,KT3U
3808 KTAB3=KT3
3809 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
3810 160 IF(RFL.LE.0.) GOTO 170
3811 170 CONTINUE
3812
3813C...Reconstruct flavour of produced quark/diquark.
3814 IF(KTAB3.LE.6) THEN
3815 KFL3A=KTAB3
3816 KFL3B=0
3817 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
3818 ELSE
3819 KFL3A=1
3820 IF(KTAB3.GE.8) KFL3A=2
3821 IF(KTAB3.GE.11) KFL3A=3
3822 IF(KTAB3.GE.16) KFL3A=4
3823 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
3824 KFL3=1000*KFL3A+100*KFL3B+1
3825 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
3826 & KFL3+2
3827 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
3828 ENDIF
3829
3830C...Reconstruct meson code.
3831 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
3832 &KFL3B.NE.0)) THEN
3833 RFL=RLU(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3834 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
3835 KF=110+2*KTABS+1
3836 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
3837 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
3838 & 25*KTABS)) KF=330+2*KTABS+1
3839 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
3840 KFLA=MAX(KTAB1,KTAB3)
3841 KFLB=MIN(KTAB1,KTAB3)
3842 KFS=ISIGN(1,KFL1)
3843 IF(KFLA.NE.KF1A) KFS=-KFS
3844 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3845 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
3846 KFS=ISIGN(1,KFL1)
3847 IF(KFL1A.EQ.KFL3A) THEN
3848 KFLA=MAX(KFL1B,KFL3B)
3849 KFLB=MIN(KFL1B,KFL3B)
3850 IF(KFLA.NE.KFL1B) KFS=-KFS
3851 ELSEIF(KFL1A.EQ.KFL3B) THEN
3852 KFLA=KFL3A
3853 KFLB=KFL1B
3854 KFS=-KFS
3855 ELSEIF(KFL1B.EQ.KFL3A) THEN
3856 KFLA=KFL1A
3857 KFLB=KFL3B
3858 ELSEIF(KFL1B.EQ.KFL3B) THEN
3859 KFLA=MAX(KFL1A,KFL3A)
3860 KFLB=MIN(KFL1A,KFL3A)
3861 IF(KFLA.NE.KFL1A) KFS=-KFS
3862 ELSE
3863 CALL LUERRM(2,'(LUKFDI:) no matching flavours for qq -> qq')
3864 GOTO 100
3865 ENDIF
3866 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
3867
3868C...Reconstruct baryon code.
3869 ELSE
3870 IF(KTAB1.GE.7) THEN
3871 KFLA=KFL3A
3872 KFLB=KFL1A
3873 KFLC=KFL1B
3874 ELSE
3875 KFLA=KFL1A
3876 KFLB=KFL3A
3877 KFLC=KFL3B
3878 ENDIF
3879 KFLD=MAX(KFLA,KFLB,KFLC)
3880 KFLF=MIN(KFLA,KFLB,KFLC)
3881 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
3882 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
3883 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
3884 ENDIF
3885
3886C...Check that constructed flavour code is an allowed one.
3887 IF(KFL2.NE.0) KFL3=0
3888 KC=LUCOMP(KF)
3889 IF(KC.EQ.0) THEN
3890 CALL LUERRM(2,'(LUKFDI:) user-defined flavour probabilities '//
3891 & 'failed')
3892 GOTO 100
3893 ENDIF
3894
3895 RETURN
3896 END
3897
3898C*********************************************************************
3899
3900 SUBROUTINE LUPTDI(KFL,PX,PY)
3901
3902C...Purpose: to generate transverse momentum according to a Gaussian.
3903 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3904 SAVE /LUDAT1/
3905
3906C...Generate p_T and azimuthal angle, gives p_x and p_y.
3907 KFLA=IABS(KFL)
3908 PT=PARJ(21)*SQRT(-LOG(MAX(1E-10,RLU(0))))
3909 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
3910 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0.
3911 PHI=PARU(2)*RLU(0)
3912 PX=PT*COS(PHI)
3913 PY=PT*SIN(PHI)
3914
3915 RETURN
3916 END
3917
3918C*********************************************************************
3919
3920 SUBROUTINE LUZDIS(KFL1,KFL2,PR,Z)
3921
3922C...Purpose: to generate the longitudinal splitting variable z.
3923 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3924 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
3925 SAVE /LUDAT1/,/LUDAT2/
3926
3927C...Check if heavy flavour fragmentation.
3928 KFLA=IABS(KFL1)
3929 KFLB=IABS(KFL2)
3930 KFLH=KFLA
3931 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
3932
3933C...Lund symmetric scaling function: determine parameters of shape.
3934 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
3935 &MSTJ(11).GE.4) THEN
3936 FA=PARJ(41)
3937 IF(MSTJ(91).EQ.1) FA=PARJ(43)
3938 IF(KFLB.GE.10) FA=FA+PARJ(45)
3939 FBB=PARJ(42)
3940 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
3941 FB=FBB*PR
3942 FC=1.
3943 IF(KFLA.GE.10) FC=FC-PARJ(45)
3944 IF(KFLB.GE.10) FC=FC+PARJ(45)
3945 IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
3946 FRED=PARJ(46)
3947 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
3948 FC=FC+FRED*FBB*PARF(100+KFLH)**2
3949 ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
3950 FRED=PARJ(46)
3951 IF(MSTJ(11).EQ.5) FRED=PARJ(48)
3952 FC=FC+FRED*FBB*PMAS(KFLH,1)**2
3953 ENDIF
3954 MC=1
3955 IF(ABS(FC-1.).GT.0.01) MC=2
3956
3957C...Determine position of maximum. Special cases for a = 0 or a = c.
3958 IF(FA.LT.0.02) THEN
3959 MA=1
3960 ZMAX=1.
3961 IF(FC.GT.FB) ZMAX=FB/FC
3962 ELSEIF(ABS(FC-FA).LT.0.01) THEN
3963 MA=2
3964 ZMAX=FB/(FB+FC)
3965 ELSE
3966 MA=3
3967 ZMAX=0.5*(FB+FC-SQRT((FB-FC)**2+4.*FA*FB))/(FC-FA)
3968 IF(ZMAX.GT.0.9999.AND.FB.GT.100.) ZMAX=MIN(ZMAX,1.-FA/FB)
3969 ENDIF
3970
3971C...Subdivide z range if distribution very peaked near endpoint.
3972 MMAX=2
3973 IF(ZMAX.LT.0.1) THEN
3974 MMAX=1
3975 ZDIV=2.75*ZMAX
3976 IF(MC.EQ.1) THEN
3977 FINT=1.-LOG(ZDIV)
3978 ELSE
3979 ZDIVC=ZDIV**(1.-FC)
3980 FINT=1.+(1.-1./ZDIVC)/(FC-1.)
3981 ENDIF
3982 ELSEIF(ZMAX.GT.0.85.AND.FB.GT.1.) THEN
3983 MMAX=3
3984 FSCB=SQRT(4.+(FC/FB)**2)
3985 ZDIV=FSCB-1./ZMAX-(FC/FB)*LOG(ZMAX*0.5*(FSCB+FC/FB))
3986 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1.-ZMAX)
3987 ZDIV=MIN(ZMAX,MAX(0.,ZDIV))
3988 FINT=1.+FB*(1.-ZDIV)
3989 ENDIF
3990
3991C...Choice of z, preweighted for peaks at low or high z.
3992 100 Z=RLU(0)
3993 FPRE=1.
3994 IF(MMAX.EQ.1) THEN
3995 IF(FINT*RLU(0).LE.1.) THEN
3996 Z=ZDIV*Z
3997 ELSEIF(MC.EQ.1) THEN
3998 Z=ZDIV**Z
3999 FPRE=ZDIV/Z
4000 ELSE
4001 Z=1./(ZDIVC+Z*(1.-ZDIVC))**(1./(1.-FC))
4002 FPRE=(ZDIV/Z)**FC
4003 ENDIF
4004 ELSEIF(MMAX.EQ.3) THEN
4005 IF(FINT*RLU(0).LE.1.) THEN
4006 Z=ZDIV+LOG(Z)/FB
4007 FPRE=EXP(FB*(Z-ZDIV))
4008 ELSE
4009 Z=ZDIV+Z*(1.-ZDIV)
4010 ENDIF
4011 ENDIF
4012
4013C...Weighting according to correct formula.
4014 IF(Z.LE.0..OR.Z.GE.1.) GOTO 100
4015 FEXP=FC*LOG(ZMAX/Z)+FB*(1./ZMAX-1./Z)
4016 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1.-Z)/(1.-ZMAX))
4017 FVAL=EXP(MAX(-50.,FEXP))
4018 IF(FVAL.LT.RLU(0)*FPRE) GOTO 100
4019
4020C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
4021 ELSE
4022 FC=PARJ(50+MAX(1,KFLH))
4023 IF(MSTJ(91).EQ.1) FC=PARJ(59)
4024 110 Z=RLU(0)
4025 IF(FC.GE.0..AND.FC.LE.1.) THEN
4026 IF(FC.GT.RLU(0)) Z=1.-Z**(1./3.)
4027 ELSEIF(FC.GT.-1.) THEN
4028 IF(-4.*FC*Z*(1.-Z)**2.LT.RLU(0)*((1.-Z)**2-FC*Z)**2) GOTO 110
4029 ELSE
4030 IF(FC.GT.0.) Z=1.-Z**(1./FC)
4031 IF(FC.LT.0.) Z=Z**(-1./FC)
4032 ENDIF
4033 ENDIF
4034
4035 RETURN
4036 END
4037
4038C*********************************************************************
4039
4040 SUBROUTINE LUSHOW(IP1,IP2,QMAX)
4041
4042C...Purpose: to generate timelike parton showers from given partons.
4043 IMPLICIT DOUBLE PRECISION(D)
4044 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
4045 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4046 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
4047 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
4048 DIMENSION PMTH(5,40),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
4049 &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
4050 &KSH(0:40)
4051
4052C...Initialization of cutoff masses etc.
4053 IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
4054 &QMAX.LE.MIN(PARJ(82),PARJ(83)).OR.MSTJ(41).GE.3) RETURN
4055 DO 101 IF=0,40
4056 101 KSH(IF)=0
4057 KSH(21)=1
4058 PMTH(1,21)=ULMASS(21)
4059 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25*PARJ(82)**2)
4060 PMTH(3,21)=2.*PMTH(2,21)
4061 PMTH(4,21)=PMTH(3,21)
4062 PMTH(5,21)=PMTH(3,21)
4063 PMTH(1,22)=ULMASS(22)
4064 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25*PARJ(83)**2)
4065 PMTH(3,22)=2.*PMTH(2,22)
4066 PMTH(4,22)=PMTH(3,22)
4067 PMTH(5,22)=PMTH(3,22)
4068 PMQTH1=PARJ(82)
4069 IF(MSTJ(41).EQ.2) PMQTH1=MIN(PARJ(82),PARJ(83))
4070 PMQTH2=PMTH(2,21)
4071 IF(MSTJ(41).EQ.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
4072 DO 100 IF=1,8
4073 KSH(IF)=1
4074 PMTH(1,IF)=ULMASS(IF)
4075 PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PMQTH1**2)
4076 PMTH(3,IF)=PMTH(2,IF)+PMQTH2
4077 PMTH(4,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(82)**2)+PMTH(2,21)
4078 100 PMTH(5,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)+PMTH(2,22)
4079 DO 105 IF=11,17,2
4080 IF(MSTJ(41).EQ.2) KSH(IF)=1
4081 PMTH(1,IF)=ULMASS(IF)
4082 PMTH(2,IF)=SQRT(PMTH(1,IF)**2+0.25*PARJ(83)**2)
4083 PMTH(3,IF)=PMTH(2,IF)+PMTH(2,22)
4084 PMTH(4,IF)=PMTH(3,IF)
4085 105 PMTH(5,IF)=PMTH(3,IF)
4086 PT2MIN=MAX(0.5*PARJ(82),1.1*PARJ(81))**2
4087 ALAMS=PARJ(81)**2
4088 ALFM=LOG(PT2MIN/ALAMS)
4089
4090C...Store positions of shower initiating partons.
4091 M3JC=0
4092 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
4093 NPA=1
4094 IPA(1)=IP1
4095 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
4096 &MSTU(32))) THEN
4097 NPA=2
4098 IPA(1)=IP1
4099 IPA(2)=IP2
4100 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0.
4101 &AND.IP2.GE.-3) THEN
4102 NPA=IABS(IP2)
4103 DO 110 I=1,NPA
4104 110 IPA(I)=IP1+I-1
4105 ELSE
4106 CALL LUERRM(12,
4107 & '(LUSHOW:) failed to reconstruct showering system')
4108 IF(MSTU(21).GE.1) RETURN
4109 ENDIF
4110
4111C...Check on phase space available for emission.
4112 IREJ=0
4113 DO 120 J=1,5
4114 120 PS(J)=0.
4115 PM=0.
4116 DO 130 I=1,NPA
4117 KFLA(I)=IABS(K(IPA(I),2))
4118 PMA(I)=P(IPA(I),5)
4119 IF(KFLA(I).LE.40) THEN
4120 IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,KFLA(I))
4121 ENDIF
4122 PM=PM+PMA(I)
4123 IF(KFLA(I).GT.40) THEN
4124 IREJ=IREJ+1
4125 ELSE
4126 IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
4127 ENDIF
4128 DO 130 J=1,4
4129 130 PS(J)=PS(J)+P(IPA(I),J)
4130 IF(IREJ.EQ.NPA) RETURN
4131 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
4132 IF(NPA.EQ.1) PS(5)=PS(4)
4133 IF(PS(5).LE.PM+PMQTH1) RETURN
4134 IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
4135 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
4136 & KFLA(2).LE.8) M3JC=1
4137 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4138 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
4139 IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
4140 & KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
4141 IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
4142 & KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
4143 IF(MSTJ(47).GE.2) M3JC=1
4144 ENDIF
4145
4146C...Define imagined single initiator of shower for parton system.
4147 NS=N
4148 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4149 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4150 IF(MSTU(21).GE.1) RETURN
4151 ENDIF
4152 IF(NPA.GE.2) THEN
4153 K(N+1,1)=11
4154 K(N+1,2)=21
4155 K(N+1,3)=0
4156 K(N+1,4)=0
4157 K(N+1,5)=0
4158 P(N+1,1)=0.
4159 P(N+1,2)=0.
4160 P(N+1,3)=0.
4161 P(N+1,4)=PS(5)
4162 P(N+1,5)=PS(5)
4163 V(N+1,5)=PS(5)**2
4164 N=N+1
4165 ENDIF
4166
4167C...Loop over partons that may branch.
4168 NEP=NPA
4169 IM=NS
4170 IF(NPA.EQ.1) IM=NS-1
4171 140 IM=IM+1
4172 IF(N.GT.NS) THEN
4173 IF(IM.GT.N) GOTO 380
4174 KFLM=IABS(K(IM,2))
4175 IF(KFLM.GT.40) GOTO 140
4176 IF(KSH(KFLM).EQ.0) GOTO 140
4177 IF(P(IM,5).LT.PMTH(2,KFLM)) GOTO 140
4178 IGM=K(IM,3)
4179 ELSE
4180 IGM=-1
4181 ENDIF
4182 IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
4183 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4184 IF(MSTU(21).GE.1) RETURN
4185 ENDIF
4186
4187C...Position of aunt (sister to branching parton).
4188C...Origin and flavour of daughters.
4189 IAU=0
4190 IF(IGM.GT.0) THEN
4191 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
4192 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
4193 ENDIF
4194 IF(IGM.GE.0) THEN
4195 K(IM,4)=N+1
4196 DO 150 I=1,NEP
4197 150 K(N+I,3)=IM
4198 ELSE
4199 K(N+1,3)=IPA(1)
4200 ENDIF
4201 IF(IGM.LE.0) THEN
4202 DO 160 I=1,NEP
4203 160 K(N+I,2)=K(IPA(I),2)
4204 ELSEIF(KFLM.NE.21) THEN
4205 K(N+1,2)=K(IM,2)
4206 K(N+2,2)=K(IM,5)
4207 ELSEIF(K(IM,5).EQ.21) THEN
4208 K(N+1,2)=21
4209 K(N+2,2)=21
4210 ELSE
4211 K(N+1,2)=K(IM,5)
4212 K(N+2,2)=-K(IM,5)
4213 ENDIF
4214
4215C...Reset flags on daughers and tries made.
4216 DO 170 IP=1,NEP
4217 K(N+IP,1)=3
4218 K(N+IP,4)=0
4219 K(N+IP,5)=0
4220 KFLD(IP)=IABS(K(N+IP,2))
4221 IF(KCHG(LUCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
4222 ITRY(IP)=0
4223 ISL(IP)=0
4224 ISI(IP)=0
4225 IF(KFLD(IP).LE.40) THEN
4226 IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
4227 ENDIF
4228 170 CONTINUE
4229 ISLM=0
4230
4231C...Maximum virtuality of daughters.
4232 IF(IGM.LE.0) THEN
4233 DO 180 I=1,NPA
4234 IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
4235 & PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
4236 P(N+I,5)=MIN(QMAX,PS(5))
4237 IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
4238 180 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
4239 ELSE
4240 IF(MSTJ(43).LE.2) PEM=V(IM,2)
4241 IF(MSTJ(43).GE.3) PEM=P(IM,4)
4242 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
4243 P(N+2,5)=MIN(P(IM,5),(1.-V(IM,1))*PEM)
4244 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
4245 ENDIF
4246 DO 190 I=1,NEP
4247 PMSD(I)=P(N+I,5)
4248 IF(ISI(I).EQ.1) THEN
4249 IF(P(N+I,5).LE.PMTH(3,KFLD(I))) P(N+I,5)=PMTH(1,KFLD(I))
4250 ENDIF
4251 190 V(N+I,5)=P(N+I,5)**2
4252
4253C...Choose one of the daughters for evolution.
4254 200 INUM=0
4255 IF(NEP.EQ.1) INUM=1
4256 DO 210 I=1,NEP
4257 210 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
4258 DO 220 I=1,NEP
4259 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
4260 IF(P(N+I,5).GE.PMTH(2,KFLD(I))) INUM=I
4261 ENDIF
4262 220 CONTINUE
4263 IF(INUM.EQ.0) THEN
4264 RMAX=0.
4265 DO 230 I=1,NEP
4266 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
4267 RPM=P(N+I,5)/PMSD(I)
4268 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,KFLD(I))) THEN
4269 RMAX=RPM
4270 INUM=I
4271 ENDIF
4272 ENDIF
4273 230 CONTINUE
4274 ENDIF
4275
4276C...Store information on choice of evolving daughter.
4277 INUM=MAX(1,INUM)
4278 IEP(1)=N+INUM
4279 DO 240 I=2,NEP
4280 IEP(I)=IEP(I-1)+1
4281 240 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
4282 DO 250 I=1,NEP
4283 250 KFL(I)=IABS(K(IEP(I),2))
4284 ITRY(INUM)=ITRY(INUM)+1
4285 IF(ITRY(INUM).GT.200) THEN
4286 CALL LUERRM(14,'(LUSHOW:) caught in infinite loop')
4287 IF(MSTU(21).GE.1) RETURN
4288 ENDIF
4289 Z=0.5
4290 IF(KFL(1).GT.40) GOTO 300
4291 IF(KSH(KFL(1)).EQ.0) GOTO 300
4292 IF(P(IEP(1),5).LT.PMTH(2,KFL(1))) GOTO 300
4293
4294C...Calculate allowed z range.
4295 IF(NEP.EQ.1) THEN
4296 PMED=PS(4)
4297 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4298 PMED=P(IM,5)
4299 ELSE
4300 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
4301 IF(INUM.EQ.2) PMED=(1.-V(IM,1))*PEM
4302 ENDIF
4303 IF(MOD(MSTJ(43),2).EQ.1) THEN
4304 ZC=PMTH(2,21)/PMED
4305 ZCE=PMTH(2,22)/PMED
4306 ELSE
4307 ZC=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,21)/PMED)**2)))
4308 IF(ZC.LT.1E-4) ZC=(PMTH(2,21)/PMED)**2
4309 ZCE=0.5*(1.-SQRT(MAX(0.,1.-(2.*PMTH(2,22)/PMED)**2)))
4310 IF(ZCE.LT.1E-4) ZCE=(PMTH(2,22)/PMED)**2
4311 ENDIF
4312 ZC=MIN(ZC,0.491)
4313 ZCE=MIN(ZCE,0.491)
4314 IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49).OR.(MSTJ(41).EQ.2.AND.
4315 &MIN(ZC,ZCE).GT.0.49)) THEN
4316 P(IEP(1),5)=PMTH(1,KFL(1))
4317 V(IEP(1),5)=P(IEP(1),5)**2
4318 GOTO 300
4319 ENDIF
4320
4321C...Integral of Altarelli-Parisi z kernel for QCD.
4322 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
4323 FBR=6.*LOG((1.-ZC)/ZC)+MSTJ(45)*(0.5-ZC)
4324 ELSEIF(MSTJ(49).EQ.0) THEN
4325 FBR=(8./3.)*LOG((1.-ZC)/ZC)
4326
4327C...Integral of Altarelli-Parisi z kernel for scalar gluon.
4328 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
4329 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1.-2.*ZC)
4330 ELSEIF(MSTJ(49).EQ.1) THEN
4331 FBR=(1.-2.*ZC)/3.
4332 IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4.*FBR
4333
4334C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
4335 ELSEIF(KFL(1).EQ.21) THEN
4336 FBR=6.*MSTJ(45)*(0.5-ZC)
4337 ELSE
4338 FBR=2.*LOG((1.-ZC)/ZC)
4339 ENDIF
4340
4341C...Reset QCD probability for lepton.
4342 IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0.
4343
4344C...Integral of Altarelli-Parisi kernel for photon emission.
4345 IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18)
4346 &FBRE=(KCHG(KFL(1),1)/3.)**2*2.*LOG((1.-ZCE)/ZCE)
4347
4348C...Inner veto algorithm starts. Find maximum mass for evolution.
4349 260 PMS=V(IEP(1),5)
4350 IF(IGM.GE.0) THEN
4351 PM2=0.
4352 DO 270 I=2,NEP
4353 PM=P(IEP(I),5)
4354 IF(KFL(I).LE.40) THEN
4355 IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,KFL(I))
4356 ENDIF
4357 270 PM2=PM2+PM
4358 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
4359 ENDIF
4360
4361C...Select mass for daughter in QCD evolution.
4362 B0=27./6.
4363 DO 280 IF=4,MSTJ(45)
4364 280 IF(PMS.GT.4.*PMTH(2,IF)**2) B0=(33.-2.*IF)/6.
4365 IF(FBR.LT.1E-3) THEN
4366 PMSQCD=0.
4367 ELSEIF(MSTJ(44).LE.0) THEN
4368 PMSQCD=PMS*EXP(MAX(-50.,LOG(RLU(0))*PARU(2)/(PARU(111)*FBR)))
4369 ELSEIF(MSTJ(44).EQ.1) THEN
4370 PMSQCD=4.*ALAMS*(0.25*PMS/ALAMS)**(RLU(0)**(B0/FBR))
4371 ELSE
4372 PMSQCD=PMS*EXP(MAX(-50.,ALFM*B0*LOG(RLU(0))/FBR))
4373 ENDIF
4374 IF(ZC.GT.0.49.OR.PMSQCD.LE.PMTH(4,KFL(1))**2) PMSQCD=
4375 &PMTH(2,KFL(1))**2
4376 V(IEP(1),5)=PMSQCD
4377 MCE=1
4378
4379C...Select mass for daughter in QED evolution.
4380 IF(MSTJ(41).EQ.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
4381 PMSQED=PMS*EXP(MAX(-80.,LOG(RLU(0))*PARU(2)/(PARU(101)*FBRE)))
4382 IF(ZCE.GT.0.49.OR.PMSQED.LE.PMTH(5,KFL(1))**2) PMSQED=
4383 & PMTH(2,KFL(1))**2
4384 IF(PMSQED.GT.PMSQCD) THEN
4385 V(IEP(1),5)=PMSQED
4386 MCE=2
4387 ENDIF
4388 ENDIF
4389
4390C...Check whether daughter mass below cutoff.
4391 P(IEP(1),5)=SQRT(V(IEP(1),5))
4392 IF(P(IEP(1),5).LE.PMTH(3,KFL(1))) THEN
4393 P(IEP(1),5)=PMTH(1,KFL(1))
4394 V(IEP(1),5)=P(IEP(1),5)**2
4395 GOTO 300
4396 ENDIF
4397
4398C...Select z value of branching: q -> qgamma.
4399 IF(MCE.EQ.2) THEN
4400 Z=1.-(1.-ZCE)*(ZCE/(1.-ZCE))**RLU(0)
4401 IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4402 K(IEP(1),5)=22
4403
4404C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4405 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
4406 Z=1.-(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4407 IF(1.+Z**2.LT.2.*RLU(0)) GOTO 260
4408 K(IEP(1),5)=21
4409 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5-ZC).LT.RLU(0)*FBR) THEN
4410 Z=(1.-ZC)*(ZC/(1.-ZC))**RLU(0)
4411 IF(RLU(0).GT.0.5) Z=1.-Z
4412 IF((1.-Z*(1.-Z))**2.LT.RLU(0)) GOTO 260
4413 K(IEP(1),5)=21
4414 ELSEIF(MSTJ(49).NE.1) THEN
4415 Z=ZC+(1.-2.*ZC)*RLU(0)
4416 IF(Z**2+(1.-Z)**2.LT.RLU(0)) GOTO 260
4417 KFLB=1+INT(MSTJ(45)*RLU(0))
4418 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4419 IF(PMQ.GE.1.) GOTO 260
4420 PMQ0=4.*PMTH(2,21)**2/V(IEP(1),5)
4421 IF(MOD(MSTJ(43),2).EQ.0.AND.(1.+0.5*PMQ)*SQRT(1.-PMQ).LT.
4422 & RLU(0)*(1.+0.5*PMQ0)*SQRT(1.-PMQ0)) GOTO 260
4423 K(IEP(1),5)=KFLB
4424
4425C...Ditto for scalar gluon model.
4426 ELSEIF(KFL(1).NE.21) THEN
4427 Z=1.-SQRT(ZC**2+RLU(0)*(1.-2.*ZC))
4428 K(IEP(1),5)=21
4429 ELSEIF(RLU(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
4430 Z=ZC+(1.-2.*ZC)*RLU(0)
4431 K(IEP(1),5)=21
4432 ELSE
4433 Z=ZC+(1.-2.*ZC)*RLU(0)
4434 KFLB=1+INT(MSTJ(45)*RLU(0))
4435 PMQ=4.*PMTH(2,KFLB)**2/V(IEP(1),5)
4436 IF(PMQ.GE.1.) GOTO 260
4437 K(IEP(1),5)=KFLB
4438 ENDIF
4439 IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
4440 IF(Z*(1.-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 260
4441 IF(ALFM/LOG(V(IEP(1),5)*Z*(1.-Z)/ALAMS).LT.RLU(0)) GOTO 260
4442 ENDIF
4443
4444C...Check if z consistent with chosen m.
4445 IF(KFL(1).EQ.21) THEN
4446 KFLGD1=IABS(K(IEP(1),5))
4447 KFLGD2=KFLGD1
4448 ELSE
4449 KFLGD1=KFL(1)
4450 KFLGD2=IABS(K(IEP(1),5))
4451 ENDIF
4452 IF(NEP.EQ.1) THEN
4453 PED=PS(4)
4454 ELSEIF(NEP.GE.3) THEN
4455 PED=P(IEP(1),4)
4456 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4457 PED=0.5*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
4458 ELSE
4459 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
4460 IF(IEP(1).EQ.N+2) PED=(1.-V(IM,1))*PEM
4461 ENDIF
4462 IF(MOD(MSTJ(43),2).EQ.1) THEN
4463 PMQTH3=0.5*PARJ(82)
4464 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4465 PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
4466 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
4467 ZD=SQRT(MAX(0.,(1.-V(IEP(1),5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4468 & 4.*PMQ1*PMQ2)))
4469 ZH=1.+PMQ1-PMQ2
4470 ELSE
4471 ZD=SQRT(MAX(0.,1.-V(IEP(1),5)/PED**2))
4472 ZH=1.
4473 ENDIF
4474 ZL=0.5*(ZH-ZD)
4475 ZU=0.5*(ZH+ZD)
4476 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 260
4477 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*
4478 &(1.-ZU)))
4479 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4480
4481C...Three-jet matrix element correction.
4482 IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
4483 X1=Z*(1.+V(IEP(1),5)/V(NS+1,5))
4484 X2=1.-V(IEP(1),5)/V(NS+1,5)
4485 X3=(1.-X1)+(1.-X2)
4486 IF(MCE.EQ.2) THEN
4487 KI1=K(IPA(INUM),2)
4488 KI2=K(IPA(3-INUM),2)
4489 QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3.
4490 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3.
4491 WSHOW=QF1**2*(1.-X1)/X3*(1.+(X1/(2.-X2))**2)+
4492 & QF2**2*(1.-X2)/X3*(1.+(X2/(2.-X1))**2)
4493 WME=(QF1*(1.-X1)/X3-QF2*(1.-X2)/X3)**2*(X1**2+X2**2)
4494 ELSEIF(MSTJ(49).NE.1) THEN
4495 WSHOW=1.+(1.-X1)/X3*(X1/(2.-X2))**2+
4496 & (1.-X2)/X3*(X2/(2.-X1))**2
4497 WME=X1**2+X2**2
4498 ELSE
4499 WSHOW=4.*X3*((1.-X1)/(2.-X2)**2+(1.-X2)/(2.-X1)**2)
4500 WME=X3**2
4501 IF(MSTJ(102).GE.2) WME=X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*
4502 & PARJ(171)
4503 ENDIF
4504 IF(WME.LT.RLU(0)*WSHOW) GOTO 260
4505
4506C...Impose angular ordering by rejection of nonordered emission.
4507 ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
4508 MAOM=1
4509 ZM=V(IM,1)
4510 IF(IEP(1).EQ.N+2) ZM=1.-V(IM,1)
4511 THE2ID=Z*(1.-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
4512 IAOM=IM
4513 290 IF(K(IAOM,5).EQ.22) THEN
4514 IAOM=K(IAOM,3)
4515 IF(K(IAOM,3).LE.NS) MAOM=0
4516 IF(MAOM.EQ.1) GOTO 290
4517 ENDIF
4518 IF(MAOM.EQ.1) THEN
4519 THE2IM=V(IAOM,1)*(1.-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
4520 IF(THE2ID.LT.THE2IM) GOTO 260
4521 ENDIF
4522 ENDIF
4523
4524C...Impose user-defined maximum angle at first branching.
4525 IF(MSTJ(48).EQ.1) THEN
4526 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
4527 THE2ID=Z*(1.-Z)*PS(4)**2/V(IEP(1),5)
4528 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4529 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
4530 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4531 IF(THE2ID.LT.1./PARJ(85)**2) GOTO 260
4532 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
4533 THE2ID=Z*(1.-Z)*(0.5*P(IM,4))**2/V(IEP(1),5)
4534 IF(THE2ID.LT.1./PARJ(86)**2) GOTO 260
4535 ENDIF
4536 ENDIF
4537
4538C...End of inner veto algorithm. Check if only one leg evolved so far.
4539 300 V(IEP(1),1)=Z
4540 ISL(1)=0
4541 ISL(2)=0
4542 IF(NEP.EQ.1) GOTO 330
4543 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 200
4544 DO 310 I=1,NEP
4545 IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
4546 IF(KSH(KFLD(I)).EQ.1) THEN
4547 IF(P(N+I,5).GE.PMTH(2,KFLD(I))) GOTO 200
4548 ENDIF
4549 ENDIF
4550 310 CONTINUE
4551
4552C...Check if chosen multiplet m1,m2,z1,z2 is physical.
4553 IF(NEP.EQ.3) THEN
4554 PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
4555 PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
4556 PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
4557 PTS=0.25*(2.*PA1S*PA2S+2.*PA1S*PA3S+2.*PA2S*PA3S-
4558 & PA1S**2-PA2S**2-PA3S**2)/PA1S
4559 IF(PTS.LE.0.) GOTO 200
4560 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
4561 DO 320 I1=N+1,N+2
4562 KFLDA=IABS(K(I1,2))
4563 IF(KFLDA.GT.40) GOTO 320
4564 IF(KSH(KFLDA).EQ.0) GOTO 320
4565 IF(P(I1,5).LT.PMTH(2,KFLDA)) GOTO 320
4566 IF(KFLDA.EQ.21) THEN
4567 KFLGD1=IABS(K(I1,5))
4568 KFLGD2=KFLGD1
4569 ELSE
4570 KFLGD1=KFLDA
4571 KFLGD2=IABS(K(I1,5))
4572 ENDIF
4573 I2=2*N+3-I1
4574 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
4575 PED=0.5*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
4576 ELSE
4577 IF(I1.EQ.N+1) ZM=V(IM,1)
4578 IF(I1.EQ.N+2) ZM=1.-V(IM,1)
4579 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
4580 & 4.*V(N+1,5)*V(N+2,5))
4581 PED=PEM*(0.5*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
4582 ENDIF
4583 IF(MOD(MSTJ(43),2).EQ.1) THEN
4584 PMQTH3=0.5*PARJ(82)
4585 IF(KFLGD2.EQ.22) PMQTH3=0.5*PARJ(83)
4586 PMQ1=(PMTH(1,KFLGD1)**2+PMQTH3**2)/V(I1,5)
4587 PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
4588 ZD=SQRT(MAX(0.,(1.-V(I1,5)/PED**2)*((1.-PMQ1-PMQ2)**2-
4589 & 4.*PMQ1*PMQ2)))
4590 ZH=1.+PMQ1-PMQ2
4591 ELSE
4592 ZD=SQRT(MAX(0.,1.-V(I1,5)/PED**2))
4593 ZH=1.
4594 ENDIF
4595 ZL=0.5*(ZH-ZD)
4596 ZU=0.5*(ZH+ZD)
4597 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
4598 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
4599 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1.-ZL)/MAX(1E-20,ZL*(1.-ZU)))
4600 IF(KFLDA.NE.21) V(I1,4)=LOG((1.-ZL)/MAX(1E-10,1.-ZU))
4601 320 CONTINUE
4602 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
4603 ISL(3-ISLM)=0
4604 ISLM=3-ISLM
4605 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
4606 ZDR1=MAX(0.,V(N+1,3)/MAX(1E-6,V(N+1,4))-1.)
4607 ZDR2=MAX(0.,V(N+2,3)/MAX(1E-6,V(N+2,4))-1.)
4608 IF(ZDR2.GT.RLU(0)*(ZDR1+ZDR2)) ISL(1)=0
4609 IF(ISL(1).EQ.1) ISL(2)=0
4610 IF(ISL(1).EQ.0) ISLM=1
4611 IF(ISL(2).EQ.0) ISLM=2
4612 ENDIF
4613 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 200
4614 ENDIF
4615 IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
4616 &PMTH(2,KFLD(1)).OR.P(N+2,5).GE.PMTH(2,KFLD(2)))) THEN
4617 PMQ1=V(N+1,5)/V(IM,5)
4618 PMQ2=V(N+2,5)/V(IM,5)
4619 ZD=SQRT(MAX(0.,(1.-V(IM,5)/PEM**2)*((1.-PMQ1-PMQ2)**2-
4620 & 4.*PMQ1*PMQ2)))
4621 ZH=1.+PMQ1-PMQ2
4622 ZL=0.5*(ZH-ZD)
4623 ZU=0.5*(ZH+ZD)
4624 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 200
4625 ENDIF
4626
4627C...Accepted branch. Construct four-momentum for initial partons.
4628 330 MAZIP=0
4629 MAZIC=0
4630 IF(NEP.EQ.1) THEN
4631 P(N+1,1)=0.
4632 P(N+1,2)=0.
4633 P(N+1,3)=SQRT(MAX(0.,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
4634 & P(N+1,5))))
4635 P(N+1,4)=P(IPA(1),4)
4636 V(N+1,2)=P(N+1,4)
4637 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
4638 PED1=0.5*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
4639 P(N+1,1)=0.
4640 P(N+1,2)=0.
4641 P(N+1,3)=SQRT(MAX(0.,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
4642 P(N+1,4)=PED1
4643 P(N+2,1)=0.
4644 P(N+2,2)=0.
4645 P(N+2,3)=-P(N+1,3)
4646 P(N+2,4)=P(IM,5)-PED1
4647 V(N+1,2)=P(N+1,4)
4648 V(N+2,2)=P(N+2,4)
4649 ELSEIF(NEP.EQ.3) THEN
4650 P(N+1,1)=0.
4651 P(N+1,2)=0.
4652 P(N+1,3)=SQRT(MAX(0.,PA1S))
4653 P(N+2,1)=SQRT(PTS)
4654 P(N+2,2)=0.
4655 P(N+2,3)=0.5*(PA3S-PA2S-PA1S)/P(N+1,3)
4656 P(N+3,1)=-P(N+2,1)
4657 P(N+3,2)=0.
4658 P(N+3,3)=-(P(N+1,3)+P(N+2,3))
4659 V(N+1,2)=P(N+1,4)
4660 V(N+2,2)=P(N+2,4)
4661 V(N+3,2)=P(N+3,4)
4662
4663C...Construct transverse momentum for ordinary branching in shower.
4664 ELSE
4665 ZM=V(IM,1)
4666 PZM=SQRT(MAX(0.,(PEM+P(IM,5))*(PEM-P(IM,5))))
4667 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4.*V(N+1,5)*V(N+2,5)
4668 IF(PZM.LE.0.) THEN
4669 PTS=0.
4670 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
4671 PTS=(PEM**2*(ZM*(1.-ZM)*V(IM,5)-(1.-ZM)*V(N+1,5)-
4672 & ZM*V(N+2,5))-0.25*PMLS)/PZM**2
4673 ELSE
4674 PTS=PMLS*(ZM*(1.-ZM)*PEM**2/V(IM,5)-0.25)/PZM**2
4675 ENDIF
4676 PT=SQRT(MAX(0.,PTS))
4677
4678C...Find coefficient of azimuthal asymmetry due to gluon polarization.
4679 HAZIP=0.
4680 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21.
4681 & AND.IAU.NE.0) THEN
4682 IF(K(IGM,3).NE.0) MAZIP=1
4683 ZAU=V(IGM,1)
4684 IF(IAU.EQ.IM+1) ZAU=1.-V(IGM,1)
4685 IF(MAZIP.EQ.0) ZAU=0.
4686 IF(K(IGM,2).NE.21) THEN
4687 HAZIP=2.*ZAU/(1.+ZAU**2)
4688 ELSE
4689 HAZIP=(ZAU/(1.-ZAU*(1.-ZAU)))**2
4690 ENDIF
4691 IF(K(N+1,2).NE.21) THEN
4692 HAZIP=HAZIP*(-2.*ZM*(1.-ZM))/(1.-2.*ZM*(1.-ZM))
4693 ELSE
4694 HAZIP=HAZIP*(ZM*(1.-ZM)/(1.-ZM*(1.-ZM)))**2
4695 ENDIF
4696 ENDIF
4697
4698C...Find coefficient of azimuthal asymmetry due to soft gluon
4699C...interference.
4700 HAZIC=0.
4701 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
4702 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
4703 IF(K(IGM,3).NE.0) MAZIC=N+1
4704 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
4705 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
4706 & ZM.GT.0.5) MAZIC=N+2
4707 IF(K(IAU,2).EQ.22) MAZIC=0
4708 ZS=ZM
4709 IF(MAZIC.EQ.N+2) ZS=1.-ZM
4710 ZGM=V(IGM,1)
4711 IF(IAU.EQ.IM-1) ZGM=1.-V(IGM,1)
4712 IF(MAZIC.EQ.0) ZGM=1.
4713 HAZIC=(P(IM,5)/P(IGM,5))*SQRT((1.-ZS)*(1.-ZGM)/(ZS*ZGM))
4714 HAZIC=MIN(0.95,HAZIC)
4715 ENDIF
4716 ENDIF
4717
4718C...Construct kinematics for ordinary branching in shower.
4719 340 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
4720 IF(MOD(MSTJ(43),2).EQ.1) THEN
4721 P(N+1,4)=PEM*V(IM,1)
4722 ELSE
4723 P(N+1,4)=PEM*(0.5*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
4724 & SQRT(PMLS)*ZM)/V(IM,5)
4725 ENDIF
4726 PHI=PARU(2)*RLU(0)
4727 P(N+1,1)=PT*COS(PHI)
4728 P(N+1,2)=PT*SIN(PHI)
4729 IF(PZM.GT.0.) THEN
4730 P(N+1,3)=0.5*(V(N+2,5)-V(N+1,5)-V(IM,5)+2.*PEM*P(N+1,4))/PZM
4731 ELSE
4732 P(N+1,3)=0.
4733 ENDIF
4734 P(N+2,1)=-P(N+1,1)
4735 P(N+2,2)=-P(N+1,2)
4736 P(N+2,3)=PZM-P(N+1,3)
4737 P(N+2,4)=PEM-P(N+1,4)
4738 IF(MSTJ(43).LE.2) THEN
4739 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
4740 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
4741 ENDIF
4742 ENDIF
4743
4744C...Rotate and boost daughters.
4745 IF(IGM.GT.0) THEN
4746 IF(MSTJ(43).LE.2) THEN
4747 BEX=P(IGM,1)/P(IGM,4)
4748 BEY=P(IGM,2)/P(IGM,4)
4749 BEZ=P(IGM,3)/P(IGM,4)
4750 GA=P(IGM,4)/P(IGM,5)
4751 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1.+GA)-
4752 & P(IM,4))
4753 ELSE
4754 BEX=0.
4755 BEY=0.
4756 BEZ=0.
4757 GA=1.
4758 GABEP=0.
4759 ENDIF
4760 THE=ULANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
4761 & (P(IM,2)+GABEP*BEY)**2))
4762 PHI=ULANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
4763 DO 350 I=N+1,N+2
4764 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
4765 & SIN(THE)*COS(PHI)*P(I,3)
4766 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
4767 & SIN(THE)*SIN(PHI)*P(I,3)
4768 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
4769 DP(4)=P(I,4)
4770 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
4771 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
4772 P(I,1)=DP(1)+DGABP*BEX
4773 P(I,2)=DP(2)+DGABP*BEY
4774 P(I,3)=DP(3)+DGABP*BEZ
4775 350 P(I,4)=GA*(DP(4)+DBP)
4776 ENDIF
4777
4778C...Weight with azimuthal distribution, if required.
4779 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
4780 DO 360 J=1,3
4781 DPT(1,J)=P(IM,J)
4782 DPT(2,J)=P(IAU,J)
4783 360 DPT(3,J)=P(N+1,J)
4784 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
4785 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
4786 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
4787 DO 370 J=1,3
4788 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
4789 370 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
4790 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
4791 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
4792 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1*PARJ(82)) THEN
4793 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
4794 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
4795 IF(MAZIP.NE.0) THEN
4796 IF(1.+HAZIP*(2.*CAD**2-1.).LT.RLU(0)*(1.+ABS(HAZIP)))
4797 & GOTO 340
4798 ENDIF
4799 IF(MAZIC.NE.0) THEN
4800 IF(MAZIC.EQ.N+2) CAD=-CAD
4801 IF((1.-HAZIC)*(1.-HAZIC*CAD)/(1.+HAZIC**2-2.*HAZIC*CAD).
4802 & LT.RLU(0)) GOTO 340
4803 ENDIF
4804 ENDIF
4805 ENDIF
4806
4807C...Continue loop over partons that may branch, until none left.
4808 IF(IGM.GE.0) K(IM,1)=14
4809 N=N+NEP
4810 NEP=2
4811 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
4812 CALL LUERRM(11,'(LUSHOW:) no more memory left in LUJETS')
4813 IF(MSTU(21).GE.1) N=NS
4814 IF(MSTU(21).GE.1) RETURN
4815 ENDIF
4816 GOTO 140
4817
4818C...Set information on imagined shower initiator.
4819 380 IF(NPA.GE.2) THEN
4820 K(NS+1,1)=11
4821 K(NS+1,2)=94
4822 K(NS+1,3)=IP1
4823 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
4824 K(NS+1,4)=NS+2
4825 K(NS+1,5)=NS+1+NPA
4826 IIM=1
4827 ELSE
4828 IIM=0
4829 ENDIF
4830
4831C...Reconstruct string drawing information.
4832 DO 390 I=NS+1+IIM,N
4833 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
4834 K(I,1)=1
4835 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
4836 &IABS(K(I,2)).LE.18) THEN
4837 K(I,1)=1
4838 ELSEIF(K(I,1).LE.10) THEN
4839 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
4840 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
4841 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
4842 ID1=MOD(K(I,4),MSTU(5))
4843 IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
4844 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
4845 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4846 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
4847 K(ID1,4)=K(ID1,4)+MSTU(5)*I
4848 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
4849 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
4850 K(ID2,5)=K(ID2,5)+MSTU(5)*I
4851 ELSE
4852 ID1=MOD(K(I,4),MSTU(5))
4853 ID2=ID1+1
4854 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
4855 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
4856 K(ID1,4)=K(ID1,4)+MSTU(5)*I
4857 K(ID1,5)=K(ID1,5)+MSTU(5)*I
4858 K(ID2,4)=0
4859 K(ID2,5)=0
4860 ENDIF
4861 390 CONTINUE
4862
4863C...Transformation from CM frame.
4864 IF(NPA.GE.2) THEN
4865 BEX=PS(1)/PS(4)
4866 BEY=PS(2)/PS(4)
4867 BEZ=PS(3)/PS(4)
4868 GA=PS(4)/PS(5)
4869 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
4870 & /(1.+GA)-P(IPA(1),4))
4871 ELSE
4872 BEX=0.
4873 BEY=0.
4874 BEZ=0.
4875 GABEP=0.
4876 ENDIF
4877 THE=ULANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
4878 &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
4879 PHI=ULANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
4880 IF(NPA.EQ.3) THEN
4881 CHI=ULANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
4882 & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
4883 & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
4884 & GABEP*BEY))
4885 MSTU(33)=1
4886 CALL LUDBRB(NS+1,N,0.,CHI,0D0,0D0,0D0)
4887 ENDIF
4888 DBEX=DBLE(BEX)
4889 DBEY=DBLE(BEY)
4890 DBEZ=DBLE(BEZ)
4891 MSTU(33)=1
4892 CALL LUDBRB(NS+1,N,THE,PHI,DBEX,DBEY,DBEZ)
4893
4894C...Decay vertex of shower.
4895 DO 400 I=NS+1,N
4896 DO 400 J=1,5
4897 400 V(I,J)=V(IP1,J)
4898
4899C...Delete trivial shower, else connect initiators.
4900 IF(N.EQ.NS+NPA+IIM) THEN
4901 N=NS
4902 ELSE
4903 DO 410 IP=1,NPA
4904 K(IPA(IP),1)=14
4905 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
4906 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
4907 K(NS+IIM+IP,3)=IPA(IP)
4908 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
4909 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
4910 410 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
4911 ENDIF
4912
4913 RETURN
4914 END
4915
4916C*********************************************************************
4917
4918 SUBROUTINE LUBOEI(NSAV)
4919
4920C...Purpose: to modify event so as to approximately take into account
4921C...Bose-Einstein effects according to a simple phenomenological
4922C...parametrization.
4923 IMPLICIT DOUBLE PRECISION(D)
4924 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
4925 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4926 SAVE /LUJETS/,/LUDAT1/
4927 DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
4928 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
4929
4930C...Boost event to overall CM frame. Calculate CM energy.
4931 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
4932 DO 100 J=1,4
4933 100 DPS(J)=0.
4934 DO 120 I=1,N
4935 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
4936 DO 110 J=1,4
4937 110 DPS(J)=DPS(J)+P(I,J)
4938 120 CONTINUE
4939 CALL LUDBRB(0,0,0.,0.,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
4940 &-DPS(3)/DPS(4))
4941 PECM=0.
4942 DO 130 I=1,N
4943 130 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
4944
4945C...Reserve copy of particles by species at end of record.
4946 NBE(0)=N+MSTU(3)
4947 DO 160 IBE=1,MIN(9,MSTJ(52))
4948 NBE(IBE)=NBE(IBE-1)
4949 DO 150 I=NSAV+1,N
4950 IF(K(I,2).NE.KFBE(IBE)) GOTO 150
4951 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
4952 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
4953 CALL LUERRM(11,'(LUBOEI:) no more memory left in LUJETS')
4954 RETURN
4955 ENDIF
4956 NBE(IBE)=NBE(IBE)+1
4957 K(NBE(IBE),1)=I
4958 DO 140 J=1,3
4959 140 P(NBE(IBE),J)=0.
4960 150 CONTINUE
4961 160 CONTINUE
4962
4963C...Tabulate integral for subsequent momentum shift.
4964 DO 210 IBE=1,MIN(9,MSTJ(52))
4965 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
4966 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)).
4967 &LE.1) GOTO 180
4968 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
4969 &NBE(7)-NBE(6)).LE.1) GOTO 180
4970 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
4971 IF(IBE.EQ.1) PMHQ=2.*ULMASS(211)
4972 IF(IBE.EQ.4) PMHQ=2.*ULMASS(321)
4973 IF(IBE.EQ.8) PMHQ=2.*ULMASS(221)
4974 IF(IBE.EQ.9) PMHQ=2.*ULMASS(331)
4975 QDEL=0.1*MIN(PMHQ,PARJ(93))
4976 IF(MSTJ(51).EQ.1) THEN
4977 NBIN=MIN(100,NINT(9.*PARJ(93)/QDEL))
4978 BEEX=EXP(0.5*QDEL/PARJ(93))
4979 BERT=EXP(-QDEL/PARJ(93))
4980 ELSE
4981 NBIN=MIN(100,NINT(3.*PARJ(93)/QDEL))
4982 ENDIF
4983 DO 170 IBIN=1,NBIN
4984 QBIN=QDEL*(IBIN-0.5)
4985 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12.)/SQRT(QBIN**2+PMHQ**2)
4986 IF(MSTJ(51).EQ.1) THEN
4987 BEEX=BEEX*BERT
4988 BEI(IBIN)=BEI(IBIN)*BEEX
4989 ELSE
4990 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
4991 ENDIF
4992 170 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
4993
4994C...Loop through particle pairs and find old relative momentum.
4995 180 DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
4996 I1=K(I1M,1)
4997 DO 200 I2M=I1M+1,NBE(IBE)
4998 I2=K(I2M,1)
4999 Q2OLD=MAX(0.,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
5000 &P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2)
5001 QOLD=SQRT(Q2OLD)
5002
5003C...Calculate new relative momentum.
5004 IF(QOLD.LT.0.5*QDEL) THEN
5005 QMOV=QOLD/3.
5006 ELSEIF(QOLD.LT.(NBIN-0.1)*QDEL) THEN
5007 RBIN=QOLD/QDEL
5008 IBIN=RBIN
5009 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
5010 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
5011 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
5012 ELSE
5013 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
5014 ENDIF
5015 Q2NEW=Q2OLD*(QOLD/(QOLD+3.*PARJ(92)*QMOV))**(2./3.)
5016
5017C...Calculate and save shift to be performed on three-momenta.
5018 HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
5019 HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
5020 HA=0.5*(1.-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
5021 DO 190 J=1,3
5022 PD=HA*(P(I2,J)-P(I1,J))
5023 P(I1M,J)=P(I1M,J)+PD
5024 190 P(I2M,J)=P(I2M,J)-PD
5025 200 CONTINUE
5026 210 CONTINUE
5027
5028C...Shift momenta and recalculate energies.
5029 DO 230 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
5030 I=K(IM,1)
5031 DO 220 J=1,3
5032 220 P(I,J)=P(I,J)+P(IM,J)
5033 230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5034
5035C...Rescale all momenta for energy conservation.
5036 PES=0.
5037 PQS=0.
5038 DO 240 I=1,N
5039 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
5040 PES=PES+P(I,4)
5041 PQS=PQS+P(I,5)**2/P(I,4)
5042 240 CONTINUE
5043 FAC=(PECM-PQS)/(PES-PQS)
5044 DO 260 I=1,N
5045 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 260
5046 DO 250 J=1,3
5047 250 P(I,J)=FAC*P(I,J)
5048 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
5049 260 CONTINUE
5050
5051C...Boost back to correct reference frame.
5052 CALL LUDBRB(0,0,0.,0.,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
5053
5054 RETURN
5055 END
5056
5057C*********************************************************************
5058
5059 FUNCTION ULMASS(KF)
5060
5061C...Purpose: to give the mass of a particle/parton.
5062 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5063 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5064 SAVE /LUDAT1/,/LUDAT2/
5065
5066C...Reset variables. Compressed code.
5067 ULMASS=0.
5068 KFA=IABS(KF)
5069 KC=LUCOMP(KF)
5070 IF(KC.EQ.0) RETURN
5071 PARF(106)=PMAS(6,1)
5072 PARF(107)=PMAS(7,1)
5073 PARF(108)=PMAS(8,1)
5074
5075C...Guarantee use of constituent masses for internal checks.
5076 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.KFA.LE.10) THEN
5077 ULMASS=PARF(100+KFA)
5078 IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(121))
5079
5080C...Masses that can be read directly off table.
5081 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5082 ULMASS=PMAS(KC,1)
5083
5084C...Find constituent partons and their masses.
5085 ELSE
5086 KFLA=MOD(KFA/1000,10)
5087 KFLB=MOD(KFA/100,10)
5088 KFLC=MOD(KFA/10,10)
5089 KFLS=MOD(KFA,10)
5090 KFLR=MOD(KFA/10000,10)
5091 PMA=PARF(100+KFLA)
5092 PMB=PARF(100+KFLB)
5093 PMC=PARF(100+KFLC)
5094
5095C...Construct masses for various meson, diquark and baryon cases.
5096 IF(KFLA.EQ.0.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5097 IF(KFLS.EQ.1) PMSPL=-3./(PMB*PMC)
5098 IF(KFLS.GE.3) PMSPL=1./(PMB*PMC)
5099 ULMASS=PARF(111)+PMB+PMC+PARF(113)*PARF(101)**2*PMSPL
5100 ELSEIF(KFLA.EQ.0) THEN
5101 KMUL=2
5102 IF(KFLS.EQ.1) KMUL=3
5103 IF(KFLR.EQ.2) KMUL=4
5104 IF(KFLS.EQ.5) KMUL=5
5105 ULMASS=PARF(113+KMUL)+PMB+PMC
5106 ELSEIF(KFLC.EQ.0) THEN
5107 IF(KFLS.EQ.1) PMSPL=-3./(PMA*PMB)
5108 IF(KFLS.EQ.3) PMSPL=1./(PMA*PMB)
5109 ULMASS=2.*PARF(112)/3.+PMA+PMB+PARF(114)*PARF(101)**2*PMSPL
5110 IF(MSTJ(93).EQ.1) ULMASS=PMA+PMB
5111 IF(MSTJ(93).EQ.2) ULMASS=MAX(0.,ULMASS-PARF(122)-
5112 & 2.*PARF(112)/3.)
5113 ELSE
5114 IF(KFLS.EQ.2.AND.KFLA.EQ.KFLB) THEN
5115 PMSPL=1./(PMA*PMB)-2./(PMA*PMC)-2./(PMB*PMC)
5116 ELSEIF(KFLS.EQ.2.AND.KFLB.GE.KFLC) THEN
5117 PMSPL=-2./(PMA*PMB)-2./(PMA*PMC)+1./(PMB*PMC)
5118 ELSEIF(KFLS.EQ.2) THEN
5119 PMSPL=-3./(PMB*PMC)
5120 ELSE
5121 PMSPL=1./(PMA*PMB)+1./(PMA*PMC)+1./(PMB*PMC)
5122 ENDIF
5123 ULMASS=PARF(112)+PMA+PMB+PMC+PARF(114)*PARF(101)**2*PMSPL
5124 ENDIF
5125 ENDIF
5126
5127C...Optional mass broadening according to truncated Breit-Wigner
5128C...(either in m or in m^2).
5129 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1E-4) THEN
5130 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
5131 ULMASS=ULMASS+0.5*PMAS(KC,2)*TAN((2.*RLU(0)-1.)*
5132 & ATAN(2.*PMAS(KC,3)/PMAS(KC,2)))
5133 ELSE
5134 PM0=ULMASS
5135 PMLOW=ATAN((MAX(0.,PM0-PMAS(KC,3))**2-PM0**2)/
5136 & (PM0*PMAS(KC,2)))
5137 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
5138 ULMASS=SQRT(MAX(0.,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
5139 & (PMUPP-PMLOW)*RLU(0))))
5140 ENDIF
5141 ENDIF
5142 MSTJ(93)=0
5143
5144 RETURN
5145 END
5146
5147C*********************************************************************
5148
5149 SUBROUTINE LUNAME(KF,CHAU)
5150
5151C...Purpose: to give the particle/parton name as a character string.
5152 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5153 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5154 COMMON/LUDAT4/CHAF(500)
5155 CHARACTER CHAF*8
5156 SAVE /LUDAT1/,/LUDAT2/,/LUDAT4/
5157 CHARACTER CHAU*16
5158
5159C...Initial values. Charge. Subdivide code.
5160 CHAU=' '
5161 KFA=IABS(KF)
5162 KC=LUCOMP(KF)
5163 IF(KC.EQ.0) RETURN
5164 KQ=LUCHGE(KF)
5165 KFLA=MOD(KFA/1000,10)
5166 KFLB=MOD(KFA/100,10)
5167 KFLC=MOD(KFA/10,10)
5168 KFLS=MOD(KFA,10)
5169 KFLR=MOD(KFA/10000,10)
5170
5171C...Read out root name and spin for simple particle.
5172 IF(KFA.LE.100.OR.(KFA.GT.100.AND.KC.GT.100)) THEN
5173 CHAU=CHAF(KC)
5174 LEN=0
5175 DO 100 LEM=1,8
5176 100 IF(CHAU(LEM:LEM).NE.' ') LEN=LEM
5177
5178C...Construct root name for diquark. Add on spin.
5179 ELSEIF(KFLC.EQ.0) THEN
5180 CHAU(1:2)=CHAF(KFLA)(1:1)//CHAF(KFLB)(1:1)
5181 IF(KFLS.EQ.1) CHAU(3:4)='_0'
5182 IF(KFLS.EQ.3) CHAU(3:4)='_1'
5183 LEN=4
5184
5185C...Construct root name for heavy meson. Add on spin and heavy flavour.
5186 ELSEIF(KFLA.EQ.0) THEN
5187 IF(KFLB.EQ.5) CHAU(1:1)='B'
5188 IF(KFLB.EQ.6) CHAU(1:1)='T'
5189 IF(KFLB.EQ.7) CHAU(1:1)='L'
5190 IF(KFLB.EQ.8) CHAU(1:1)='H'
5191 LEN=1
5192 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5193 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5194 CHAU(2:2)='*'
5195 LEN=2
5196 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5197 CHAU(2:3)='_1'
5198 LEN=3
5199 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5200 CHAU(2:4)='*_0'
5201 LEN=4
5202 ELSEIF(KFLR.EQ.2) THEN
5203 CHAU(2:4)='*_1'
5204 LEN=4
5205 ELSEIF(KFLS.EQ.5) THEN
5206 CHAU(2:4)='*_2'
5207 LEN=4
5208 ENDIF
5209 IF(KFLC.GE.3.AND.KFLR.EQ.0.AND.KFLS.LE.3) THEN
5210 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLC)(1:1)
5211 LEN=LEN+2
5212 ELSEIF(KFLC.GE.3) THEN
5213 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5214 LEN=LEN+1
5215 ENDIF
5216
5217C...Construct root name and spin for heavy baryon.
5218 ELSE
5219 IF(KFLB.LE.2.AND.KFLC.LE.2) THEN
5220 CHAU='Sigma '
5221 IF(KFLC.GT.KFLB) CHAU='Lambda'
5222 IF(KFLS.EQ.4) CHAU='Sigma*'
5223 LEN=5
5224 IF(CHAU(6:6).NE.' ') LEN=6
5225 ELSEIF(KFLB.LE.2.OR.KFLC.LE.2) THEN
5226 CHAU='Xi '
5227 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Xi'''
5228 IF(KFLS.EQ.4) CHAU='Xi*'
5229 LEN=2
5230 IF(CHAU(3:3).NE.' ') LEN=3
5231 ELSE
5232 CHAU='Omega '
5233 IF(KFLA.GT.KFLB.AND.KFLB.GT.KFLC) CHAU='Omega'''
5234 IF(KFLS.EQ.4) CHAU='Omega*'
5235 LEN=5
5236 IF(CHAU(6:6).NE.' ') LEN=6
5237 ENDIF
5238
5239C...Add on heavy flavour content for heavy baryon.
5240 CHAU(LEN+1:LEN+2)='_'//CHAF(KFLA)(1:1)
5241 LEN=LEN+2
5242 IF(KFLB.GE.KFLC.AND.KFLC.GE.4) THEN
5243 CHAU(LEN+1:LEN+2)=CHAF(KFLB)(1:1)//CHAF(KFLC)(1:1)
5244 LEN=LEN+2
5245 ELSEIF(KFLB.GE.KFLC.AND.KFLB.GE.4) THEN
5246 CHAU(LEN+1:LEN+1)=CHAF(KFLB)(1:1)
5247 LEN=LEN+1
5248 ELSEIF(KFLC.GT.KFLB.AND.KFLB.GE.4) THEN
5249 CHAU(LEN+1:LEN+2)=CHAF(KFLC)(1:1)//CHAF(KFLB)(1:1)
5250 LEN=LEN+2
5251 ELSEIF(KFLC.GT.KFLB.AND.KFLC.GE.4) THEN
5252 CHAU(LEN+1:LEN+1)=CHAF(KFLC)(1:1)
5253 LEN=LEN+1
5254 ENDIF
5255 ENDIF
5256
5257C...Add on bar sign for antiparticle (where necessary).
5258 IF(KF.GT.0.OR.LEN.EQ.0) THEN
5259 ELSEIF(KFA.GT.10.AND.KFA.LE.40.AND.KQ.NE.0.AND.MOD(KQ,3).EQ.0)
5260 &THEN
5261 ELSEIF(KFA.EQ.89.OR.(KFA.GE.91.AND.KFA.LE.99)) THEN
5262 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KQ.NE.0) THEN
5263 ELSEIF(MSTU(15).LE.1) THEN
5264 CHAU(LEN+1:LEN+1)='~'
5265 LEN=LEN+1
5266 ELSE
5267 CHAU(LEN+1:LEN+3)='bar'
5268 LEN=LEN+3
5269 ENDIF
5270
5271C...Add on charge where applicable (conventional cases skipped).
5272 IF(KQ.EQ.6) CHAU(LEN+1:LEN+2)='++'
5273 IF(KQ.EQ.-6) CHAU(LEN+1:LEN+2)='--'
5274 IF(KQ.EQ.3) CHAU(LEN+1:LEN+1)='+'
5275 IF(KQ.EQ.-3) CHAU(LEN+1:LEN+1)='-'
5276 IF(KQ.EQ.0.AND.(KFA.LE.22.OR.LEN.EQ.0)) THEN
5277 ELSEIF(KQ.EQ.0.AND.(KFA.GE.81.AND.KFA.LE.100)) THEN
5278 ELSEIF(KFA.GT.100.AND.KFLA.EQ.0.AND.KFLB.EQ.KFLC.AND.
5279 &KFLB.NE.1) THEN
5280 ELSEIF(KQ.EQ.0) THEN
5281 CHAU(LEN+1:LEN+1)='0'
5282 ENDIF
5283
5284 RETURN
5285 END
5286
5287C*********************************************************************
5288
5289 FUNCTION LUCHGE(KF)
5290
5291C...Purpose: to give three times the charge for a particle/parton.
5292 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5293 SAVE /LUDAT2/
5294
5295C...Initial values. Simple case of direct readout.
5296 LUCHGE=0
5297 KFA=IABS(KF)
5298 KC=LUCOMP(KFA)
5299 IF(KC.EQ.0) THEN
5300 ELSEIF(KFA.LE.100.OR.KC.LE.80.OR.KC.GT.100) THEN
5301 LUCHGE=KCHG(KC,1)
5302
5303C...Construction from quark content for heavy meson, diquark, baryon.
5304 ELSEIF(MOD(KFA/1000,10).EQ.0) THEN
5305 LUCHGE=(KCHG(MOD(KFA/100,10),1)-KCHG(MOD(KFA/10,10),1))*
5306 & (-1)**MOD(KFA/100,10)
5307 ELSEIF(MOD(KFA/10,10).EQ.0) THEN
5308 LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)
5309 ELSE
5310 LUCHGE=KCHG(MOD(KFA/1000,10),1)+KCHG(MOD(KFA/100,10),1)+
5311 & KCHG(MOD(KFA/10,10),1)
5312 ENDIF
5313
5314C...Add on correct sign.
5315 LUCHGE=LUCHGE*ISIGN(1,KF)
5316
5317 RETURN
5318 END
5319
5320C*********************************************************************
5321
5322 FUNCTION LUCOMP(KF)
5323
5324C...Purpose: to compress the standard KF codes for use in mass and decay
5325C...arrays; also to check whether a given code actually is defined.
5326 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5327 SAVE /LUDAT2/
5328
5329C...Subdivide KF code into constituent pieces.
5330 LUCOMP=0
5331 KFA=IABS(KF)
5332 KFLA=MOD(KFA/1000,10)
5333 KFLB=MOD(KFA/100,10)
5334 KFLC=MOD(KFA/10,10)
5335 KFLS=MOD(KFA,10)
5336 KFLR=MOD(KFA/10000,10)
5337
5338C...Simple cases: direct translation or special codes.
5339 IF(KFA.EQ.0.OR.KFA.GE.100000) THEN
5340 ELSEIF(KFA.LE.100) THEN
5341 LUCOMP=KFA
5342 IF(KF.LT.0.AND.KCHG(KFA,3).EQ.0) LUCOMP=0
5343 ELSEIF(KFLS.EQ.0) THEN
5344 IF(KF.EQ.130) LUCOMP=221
5345 IF(KF.EQ.310) LUCOMP=222
5346 IF(KFA.EQ.210) LUCOMP=281
5347 IF(KFA.EQ.2110) LUCOMP=282
5348 IF(KFA.EQ.2210) LUCOMP=283
5349
5350C...Mesons.
5351 ELSEIF(KFA-10000*KFLR.LT.1000) THEN
5352 IF(KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.0.OR.KFLC.EQ.9) THEN
5353 ELSEIF(KFLB.LT.KFLC) THEN
5354 ELSEIF(KF.LT.0.AND.KFLB.EQ.KFLC) THEN
5355 ELSEIF(KFLB.EQ.KFLC) THEN
5356 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5357 LUCOMP=110+KFLB
5358 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5359 LUCOMP=130+KFLB
5360 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5361 LUCOMP=150+KFLB
5362 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5363 LUCOMP=170+KFLB
5364 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
5365 LUCOMP=190+KFLB
5366 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
5367 LUCOMP=210+KFLB
5368 ENDIF
5369 ELSEIF(KFLB.LE.5.AND.KFLC.LE.3) THEN
5370 IF(KFLR.EQ.0.AND.KFLS.EQ.1) THEN
5371 LUCOMP=100+((KFLB-1)*(KFLB-2))/2+KFLC
5372 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.3) THEN
5373 LUCOMP=120+((KFLB-1)*(KFLB-2))/2+KFLC
5374 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.3) THEN
5375 LUCOMP=140+((KFLB-1)*(KFLB-2))/2+KFLC
5376 ELSEIF(KFLR.EQ.1.AND.KFLS.EQ.1) THEN
5377 LUCOMP=160+((KFLB-1)*(KFLB-2))/2+KFLC
5378 ELSEIF(KFLR.EQ.2.AND.KFLS.EQ.3) THEN
5379 LUCOMP=180+((KFLB-1)*(KFLB-2))/2+KFLC
5380 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.5) THEN
5381 LUCOMP=200+((KFLB-1)*(KFLB-2))/2+KFLC
5382 ENDIF
5383 ELSEIF((KFLS.EQ.1.AND.KFLR.LE.1).OR.(KFLS.EQ.3.AND.KFLR.LE.2).
5384 & OR.(KFLS.EQ.5.AND.KFLR.EQ.0)) THEN
5385 LUCOMP=80+KFLB
5386 ENDIF
5387
5388C...Diquarks.
5389 ELSEIF((KFLR.EQ.0.OR.KFLR.EQ.1).AND.KFLC.EQ.0) THEN
5390 IF(KFLS.NE.1.AND.KFLS.NE.3) THEN
5391 ELSEIF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9) THEN
5392 ELSEIF(KFLA.LT.KFLB) THEN
5393 ELSEIF(KFLS.EQ.1.AND.KFLA.EQ.KFLB) THEN
5394 ELSE
5395 LUCOMP=90
5396 ENDIF
5397
5398C...Spin 1/2 baryons.
5399 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.2) THEN
5400 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
5401 ELSEIF(KFLA.LE.KFLC.OR.KFLA.LT.KFLB) THEN
5402 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4.OR.KFLC.GE.4) THEN
5403 LUCOMP=80+KFLA
5404 ELSEIF(KFLB.LT.KFLC) THEN
5405 LUCOMP=300+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLC*(KFLC-1))/2+KFLB
5406 ELSE
5407 LUCOMP=330+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5408 ENDIF
5409
5410C...Spin 3/2 baryons.
5411 ELSEIF(KFLR.EQ.0.AND.KFLS.EQ.4) THEN
5412 IF(KFLA.EQ.9.OR.KFLB.EQ.0.OR.KFLB.EQ.9.OR.KFLC.EQ.9) THEN
5413 ELSEIF(KFLA.LT.KFLB.OR.KFLB.LT.KFLC) THEN
5414 ELSEIF(KFLA.GE.6.OR.KFLB.GE.4) THEN
5415 LUCOMP=80+KFLA
5416 ELSE
5417 LUCOMP=360+((KFLA+1)*KFLA*(KFLA-1))/6+(KFLB*(KFLB-1))/2+KFLC
5418 ENDIF
5419 ENDIF
5420
5421 RETURN
5422 END
5423
5424C*********************************************************************
5425
5426 SUBROUTINE LUERRM(MERR,CHMESS)
5427
5428C...Purpose: to inform user of errors in program execution.
5429 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
5430 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5431 SAVE /LUJETS/,/LUDAT1/
5432 CHARACTER CHMESS*(*)
5433
5434C...Write first few warnings, then be silent.
5435 IF(MERR.LE.10) THEN
5436 MSTU(27)=MSTU(27)+1
5437 MSTU(28)=MERR
5438 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
5439 & MERR,MSTU(31),CHMESS
5440
5441C...Write first few errors, then be silent or stop program.
5442 ELSEIF(MERR.LE.20) THEN
5443 MSTU(23)=MSTU(23)+1
5444 MSTU(24)=MERR-10
5445 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
5446 & MERR-10,MSTU(31),CHMESS
5447 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
5448 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
5449 WRITE(MSTU(11),5200)
5450 IF(MERR.NE.17) CALL LULIST(2)
5451 STOP
5452 ENDIF
5453
5454C...Stop program in case of irreparable error.
5455 ELSE
5456 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
5457 STOP
5458 ENDIF
5459
5460C...Formats for output.
5461 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I6,
5462 &' LUEXEC calls:'/5X,A)
5463 5100 FORMAT(/5X,'Error type',I2,' has occured after',I6,
5464 &' LUEXEC calls:'/5X,A)
5465 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
5466 &'event!')
5467 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I6,
5468 &' LUEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
5469
5470 RETURN
5471 END
5472
5473C*********************************************************************
5474
5475 FUNCTION ULALEM(Q2)
5476
5477C...Purpose: to calculate the running alpha_electromagnetic.
5478 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5479 SAVE /LUDAT1/
5480
5481C...Calculate real part of photon vacuum polarization.
5482C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
5483C...For hadrons use parametrization of H. Burkhardt et al.
5484C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
5485 AEMPI=PARU(101)/(3.*PARU(1))
5486 IF(MSTU(101).LE.0.OR.Q2.LT.2E-6) THEN
5487 RPIGG=0.
5488 ELSEIF(Q2.LT.0.09) THEN
5489 RPIGG=AEMPI*(13.4916+LOG(Q2))+0.00835*LOG(1.+Q2)
5490 ELSEIF(Q2.LT.9.) THEN
5491 RPIGG=AEMPI*(16.3200+2.*LOG(Q2))+0.00238*LOG(1.+3.927*Q2)
5492 ELSEIF(Q2.LT.1E4) THEN
5493 RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00165+0.00299*LOG(1.+Q2)
5494 ELSE
5495 RPIGG=AEMPI*(13.4955+3.*LOG(Q2))+0.00221+0.00293*LOG(1.+Q2)
5496 ENDIF
5497
5498C...Calculate running alpha_em.
5499 ULALEM=PARU(101)/(1.-RPIGG)
5500 PARU(108)=ULALEM
5501
5502 RETURN
5503 END
5504
5505C*********************************************************************
5506
5507 FUNCTION ULALPS(Q2)
5508
5509C...Purpose: to give the value of alpha_strong.
5510 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5511 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5512 SAVE /LUDAT1/,/LUDAT2/
5513
5514C...Constant alpha_strong trivial.
5515 IF(MSTU(111).LE.0) THEN
5516 ULALPS=PARU(111)
5517 MSTU(118)=MSTU(112)
5518 PARU(117)=0.
5519 PARU(118)=PARU(111)
5520 RETURN
5521 ENDIF
5522
5523C...Find effective Q2, number of flavours and Lambda.
5524 Q2EFF=Q2
5525 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
5526 NF=MSTU(112)
5527 ALAM2=PARU(112)**2
5528 100 IF(NF.GT.MAX(2,MSTU(113))) THEN
5529 Q2THR=PARU(113)*PMAS(NF,1)**2
5530 IF(Q2EFF.LT.Q2THR) THEN
5531 NF=NF-1
5532 ALAM2=ALAM2*(Q2THR/ALAM2)**(2./(33.-2.*NF))
5533 GOTO 100
5534 ENDIF
5535 ENDIF
5536 110 IF(NF.LT.MIN(8,MSTU(114))) THEN
5537 Q2THR=PARU(113)*PMAS(NF+1,1)**2
5538 IF(Q2EFF.GT.Q2THR) THEN
5539 NF=NF+1
5540 ALAM2=ALAM2*(ALAM2/Q2THR)**(2./(33.-2.*NF))
5541 GOTO 110
5542 ENDIF
5543 ENDIF
5544 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
5545 PARU(117)=SQRT(ALAM2)
5546
5547C...Evaluate first or second order alpha_strong.
5548 B0=(33.-2.*NF)/6.
5549 ALGQ=LOG(MAX(1.0001,Q2EFF/ALAM2))
5550 IF(MSTU(111).EQ.1) THEN
5551 ULALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
5552 ELSE
5553 B1=(153.-19.*NF)/6.
5554 ULALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1.-B1*LOG(ALGQ)/
5555 & (B0**2*ALGQ)))
5556 ENDIF
5557 MSTU(118)=NF
5558 PARU(118)=ULALPS
5559
5560 RETURN
5561 END
5562
5563C*********************************************************************
5564
5565 FUNCTION ULANGL(X,Y)
5566
5567C...Purpose: to reconstruct an angle from given x and y coordinates.
5568 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5569 SAVE /LUDAT1/
5570
5571 ULANGL=0.
5572 R=SQRT(X**2+Y**2)
5573 IF(R.LT.1E-20) RETURN
5574 IF(ABS(X)/R.LT.0.8) THEN
5575 ULANGL=SIGN(ACOS(X/R),Y)
5576 ELSE
5577 ULANGL=ASIN(Y/R)
5578 IF(X.LT.0..AND.ULANGL.GE.0.) THEN
5579 ULANGL=PARU(1)-ULANGL
5580 ELSEIF(X.LT.0.) THEN
5581 ULANGL=-PARU(1)-ULANGL
5582 ENDIF
5583 ENDIF
5584
5585 RETURN
5586 END
5587
5588C*********************************************************************
5589
5590 FUNCTION RLU(IDUM)
5591
5592C...Purpose: to generate random numbers uniformly distributed between
5593C...0 and 1, excluding the endpoints.
5594 COMMON/LUDATR/MRLU(6),RRLU(100)
5595 SAVE /LUDATR/
5596 EQUIVALENCE (MRLU1,MRLU(1)),(MRLU2,MRLU(2)),(MRLU3,MRLU(3)),
5597 &(MRLU4,MRLU(4)),(MRLU5,MRLU(5)),(MRLU6,MRLU(6)),
5598 &(RRLU98,RRLU(98)),(RRLU99,RRLU(99)),(RRLU00,RRLU(100))
5599
5600C...Initialize generation from given seed.
5601 IF(MRLU2.EQ.0) THEN
5602 IJ=MOD(MRLU1/30082,31329)
5603 KL=MOD(MRLU1,30082)
5604 I=MOD(IJ/177,177)+2
5605 J=MOD(IJ,177)+2
5606 K=MOD(KL/169,178)+1
5607 L=MOD(KL,169)
5608 DO 110 II=1,97
5609 S=0.
5610 T=0.5
5611 DO 100 JJ=1,24
5612 M=MOD(MOD(I*J,179)*K,179)
5613 I=J
5614 J=K
5615 K=M
5616 L=MOD(53*L+1,169)
5617 IF(MOD(L*M,64).GE.32) S=S+T
5618 100 T=0.5*T
5619 110 RRLU(II)=S
5620 TWOM24=1.
5621 DO 120 I24=1,24
5622 120 TWOM24=0.5*TWOM24
5623 RRLU98=362436.*TWOM24
5624 RRLU99=7654321.*TWOM24
5625 RRLU00=16777213.*TWOM24
5626 MRLU2=1
5627 MRLU3=0
5628 MRLU4=97
5629 MRLU5=33
5630 ENDIF
5631
5632C...Generate next random number.
5633 130 RUNI=RRLU(MRLU4)-RRLU(MRLU5)
5634 IF(RUNI.LT.0.) RUNI=RUNI+1.
5635 RRLU(MRLU4)=RUNI
5636 MRLU4=MRLU4-1
5637 IF(MRLU4.EQ.0) MRLU4=97
5638 MRLU5=MRLU5-1
5639 IF(MRLU5.EQ.0) MRLU5=97
5640 RRLU98=RRLU98-RRLU99
5641 IF(RRLU98.LT.0.) RRLU98=RRLU98+RRLU00
5642 RUNI=RUNI-RRLU98
5643 IF(RUNI.LT.0.) RUNI=RUNI+1.
5644 IF(RUNI.LE.0.OR.RUNI.GE.1.) GOTO 130
5645
5646C...Update counters. Random number to output.
5647 MRLU3=MRLU3+1
5648 IF(MRLU3.EQ.1000000000) THEN
5649 MRLU2=MRLU2+1
5650 MRLU3=0
5651 ENDIF
5652 RLU=RUNI
5653
5654 RETURN
5655 END
5656
5657C*********************************************************************
5658
5659 SUBROUTINE RLUGET(LFN,MOVE)
5660
5661C...Purpose: to dump the state of the random number generator on a file
5662C...for subsequent startup from this state onwards.
5663 COMMON/LUDATR/MRLU(6),RRLU(100)
5664 SAVE /LUDATR/
5665 CHARACTER CHERR*8
5666
5667C...Backspace required number of records (or as many as there are).
5668 IF(MOVE.LT.0) THEN
5669 NBCK=MIN(MRLU(6),-MOVE)
5670 DO 100 IBCK=1,NBCK
5671 100 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
5672 MRLU(6)=MRLU(6)-NBCK
5673 ENDIF
5674
5675C...Unformatted write on unit LFN.
5676 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRLU(I1),I1=1,5),
5677 &(RRLU(I2),I2=1,100)
5678 MRLU(6)=MRLU(6)+1
5679 RETURN
5680
5681C...Write error.
5682 110 WRITE(CHERR,'(I8)') IERR
5683 CALL LUERRM(18,'(RLUGET:) error when accessing file, IOSTAT ='//
5684 &CHERR)
5685
5686 RETURN
5687 END
5688
5689C*********************************************************************
5690
5691 SUBROUTINE RLUSET(LFN,MOVE)
5692
5693C...Purpose: to read a state of the random number generator from a file
5694C...for subsequent generation from this state onwards.
5695 COMMON/LUDATR/MRLU(6),RRLU(100)
5696 SAVE /LUDATR/
5697 CHARACTER CHERR*8
5698
5699C...Backspace required number of records (or as many as there are).
5700 IF(MOVE.LT.0) THEN
5701 NBCK=MIN(MRLU(6),-MOVE)
5702 DO 100 IBCK=1,NBCK
5703 100 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
5704 MRLU(6)=MRLU(6)-NBCK
5705 ENDIF
5706
5707C...Unformatted read from unit LFN.
5708 NFOR=1+MAX(0,MOVE)
5709 DO 110 IFOR=1,NFOR
5710 110 READ(LFN,ERR=120,IOSTAT=IERR) (MRLU(I1),I1=1,5),
5711 &(RRLU(I2),I2=1,100)
5712 MRLU(6)=MRLU(6)+NFOR
5713 RETURN
5714
5715C...Write error.
5716 120 WRITE(CHERR,'(I8)') IERR
5717 CALL LUERRM(18,'(RLUSET:) error when accessing file, IOSTAT ='//
5718 &CHERR)
5719
5720 RETURN
5721 END
5722
5723C*********************************************************************
5724
5725 SUBROUTINE LUROBO(THE,PHI,BEX,BEY,BEZ)
5726
5727C...Purpose: to perform rotations and boosts.
5728 IMPLICIT DOUBLE PRECISION(D)
5729 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
5730 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5731 SAVE /LUJETS/,/LUDAT1/
5732 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
5733
5734C...Find range of rotation/boost. Convert boost to double precision.
5735 IMIN=1
5736 IF(MSTU(1).GT.0) IMIN=MSTU(1)
5737 IMAX=N
5738 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5739 DBX=BEX
5740 DBY=BEY
5741 DBZ=BEZ
5742 GOTO 110
5743
5744C...Entry for specific range and double precision boost.
5745 ENTRY LUDBRB(IMI,IMA,THE,PHI,DBEX,DBEY,DBEZ)
5746 IMIN=IMI
5747 IF(IMIN.LE.0) IMIN=1
5748 IMAX=IMA
5749 IF(IMAX.LE.0) IMAX=N
5750 DBX=DBEX
5751 DBY=DBEY
5752 DBZ=DBEZ
5753
5754C...Optional resetting of V (when not set before.)
5755 IF(MSTU(33).NE.0) THEN
5756 DO 100 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
5757 DO 100 J=1,5
5758 100 V(I,J)=0.
5759 MSTU(33)=0
5760 ENDIF
5761
5762C...Check range of rotation/boost.
5763 110 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
5764 CALL LUERRM(11,'(LUROBO:) range outside LUJETS memory')
5765 RETURN
5766 ENDIF
5767
5768C...Rotate, typically from z axis to direction (theta,phi).
5769 IF(THE**2+PHI**2.GT.1E-20) THEN
5770 ROT(1,1)=COS(THE)*COS(PHI)
5771 ROT(1,2)=-SIN(PHI)
5772 ROT(1,3)=SIN(THE)*COS(PHI)
5773 ROT(2,1)=COS(THE)*SIN(PHI)
5774 ROT(2,2)=COS(PHI)
5775 ROT(2,3)=SIN(THE)*SIN(PHI)
5776 ROT(3,1)=-SIN(THE)
5777 ROT(3,2)=0.
5778 ROT(3,3)=COS(THE)
5779 DO 140 I=IMIN,IMAX
5780 IF(K(I,1).LE.0) GOTO 140
5781 DO 120 J=1,3
5782 PR(J)=P(I,J)
5783 120 VR(J)=V(I,J)
5784 DO 130 J=1,3
5785 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
5786 130 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
5787 140 CONTINUE
5788 ENDIF
5789
5790C...Boost, typically from rest to momentum/energy=beta.
5791 IF(DBX**2+DBY**2+DBZ**2.GT.1E-20) THEN
5792 DB=SQRT(DBX**2+DBY**2+DBZ**2)
5793 IF(DB.GT.0.99999999D0) THEN
5794C...Rescale boost vector if too close to unity.
5795 CALL LUERRM(3,'(LUROBO:) boost vector too large')
5796 DBX=DBX*(0.99999999D0/DB)
5797 DBY=DBY*(0.99999999D0/DB)
5798 DBZ=DBZ*(0.99999999D0/DB)
5799 DB=0.99999999D0
5800 ENDIF
5801 DGA=1D0/SQRT(1D0-DB**2)
5802 DO 160 I=IMIN,IMAX
5803 IF(K(I,1).LE.0) GOTO 160
5804 DO 150 J=1,4
5805 DP(J)=P(I,J)
5806 150 DV(J)=V(I,J)
5807 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
5808 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
5809 P(I,1)=DP(1)+DGABP*DBX
5810 P(I,2)=DP(2)+DGABP*DBY
5811 P(I,3)=DP(3)+DGABP*DBZ
5812 P(I,4)=DGA*(DP(4)+DBP)
5813 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
5814 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
5815 V(I,1)=DV(1)+DGABV*DBX
5816 V(I,2)=DV(2)+DGABV*DBY
5817 V(I,3)=DV(3)+DGABV*DBZ
5818 V(I,4)=DGA*(DV(4)+DBV)
5819 160 CONTINUE
5820 ENDIF
5821
5822 RETURN
5823 END
5824
5825C*********************************************************************
5826
5827 SUBROUTINE LUEDIT(MEDIT)
5828
5829C...Purpose: to perform global manipulations on the event record,
5830C...in particular to exclude unstable or undetectable partons/particles.
5831 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
5832 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5833 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
5834 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
5835 DIMENSION NS(2),PTS(2),PLS(2)
5836
5837C...Remove unwanted partons/particles.
5838 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
5839 IMAX=N
5840 IF(MSTU(2).GT.0) IMAX=MSTU(2)
5841 I1=MAX(1,MSTU(1))-1
5842 DO 110 I=MAX(1,MSTU(1)),IMAX
5843 IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
5844 IF(MEDIT.EQ.1) THEN
5845 IF(K(I,1).GT.10) GOTO 110
5846 ELSEIF(MEDIT.EQ.2) THEN
5847 IF(K(I,1).GT.10) GOTO 110
5848 KC=LUCOMP(K(I,2))
5849 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
5850 & GOTO 110
5851 ELSEIF(MEDIT.EQ.3) THEN
5852 IF(K(I,1).GT.10) GOTO 110
5853 KC=LUCOMP(K(I,2))
5854 IF(KC.EQ.0) GOTO 110
5855 IF(KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0) GOTO 110
5856 ELSEIF(MEDIT.EQ.5) THEN
5857 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
5858 KC=LUCOMP(K(I,2))
5859 IF(KC.EQ.0) GOTO 110
5860 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
5861 ENDIF
5862
5863C...Pack remaining partons/particles. Origin no longer known.
5864 I1=I1+1
5865 DO 100 J=1,5
5866 K(I1,J)=K(I,J)
5867 P(I1,J)=P(I,J)
5868 100 V(I1,J)=V(I,J)
5869 K(I1,3)=0
5870 110 CONTINUE
5871 IF(I1.LT.N) MSTU(3)=0
5872 IF(I1.LT.N) MSTU(70)=0
5873 N=I1
5874
5875C...Selective removal of class of entries. New position of retained.
5876 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
5877 I1=0
5878 DO 120 I=1,N
5879 K(I,3)=MOD(K(I,3),MSTU(5))
5880 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
5881 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
5882 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
5883 & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
5884 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
5885 & K(I,2).EQ.94)) GOTO 120
5886 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
5887 I1=I1+1
5888 K(I,3)=K(I,3)+MSTU(5)*I1
5889 120 CONTINUE
5890
5891C...Find new event history information and replace old.
5892 DO 140 I=1,N
5893 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) GOTO 140
5894 ID=I
5895 130 IM=MOD(K(ID,3),MSTU(5))
5896 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
5897 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
5898 & K(IM,2).NE.94) THEN
5899 ID=IM
5900 GOTO 130
5901 ENDIF
5902 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
5903 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
5904 ID=IM
5905 GOTO 130
5906 ENDIF
5907 ENDIF
5908 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
5909 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
5910 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
5911 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
5912 & K(K(I,4),3)/MSTU(5)
5913 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
5914 & K(K(I,5),3)/MSTU(5)
5915 ELSE
5916 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
5917 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5918 KCD=MOD(K(I,4),MSTU(5))
5919 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5920 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5921 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
5922 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
5923 KCD=MOD(K(I,5),MSTU(5))
5924 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
5925 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
5926 ENDIF
5927 140 CONTINUE
5928
5929C...Pack remaining entries.
5930 I1=0
5931 MSTU90=MSTU(90)
5932 MSTU(90)=0
5933 DO 170 I=1,N
5934 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
5935 I1=I1+1
5936 DO 150 J=1,5
5937 K(I1,J)=K(I,J)
5938 P(I1,J)=P(I,J)
5939 150 V(I1,J)=V(I,J)
5940 K(I1,3)=MOD(K(I1,3),MSTU(5))
5941 DO 160 IZ=1,MSTU90
5942 IF(I.EQ.MSTU(90+IZ)) THEN
5943 MSTU(90)=MSTU(90)+1
5944 MSTU(90+MSTU(90))=I1
5945 PARU(90+MSTU(90))=PARU(90+IZ)
5946 ENDIF
5947 160 CONTINUE
5948 170 CONTINUE
5949 IF(I1.LT.N) MSTU(3)=0
5950 IF(I1.LT.N) MSTU(70)=0
5951 N=I1
5952
5953C...Save top entries at bottom of LUJETS commonblock.
5954 ELSEIF(MEDIT.EQ.21) THEN
5955 IF(2*N.GE.MSTU(4)) THEN
5956 CALL LUERRM(11,'(LUEDIT:) no more memory left in LUJETS')
5957 RETURN
5958 ENDIF
5959 DO 180 I=1,N
5960 DO 180 J=1,5
5961 K(MSTU(4)-I,J)=K(I,J)
5962 P(MSTU(4)-I,J)=P(I,J)
5963 180 V(MSTU(4)-I,J)=V(I,J)
5964 MSTU(32)=N
5965
5966C...Restore bottom entries of commonblock LUJETS to top.
5967 ELSEIF(MEDIT.EQ.22) THEN
5968 DO 190 I=1,MSTU(32)
5969 DO 190 J=1,5
5970 K(I,J)=K(MSTU(4)-I,J)
5971 P(I,J)=P(MSTU(4)-I,J)
5972 190 V(I,J)=V(MSTU(4)-I,J)
5973 N=MSTU(32)
5974
5975C...Mark primary entries at top of commonblock LUJETS as untreated.
5976 ELSEIF(MEDIT.EQ.23) THEN
5977 I1=0
5978 DO 200 I=1,N
5979 KH=K(I,3)
5980 IF(KH.GE.1) THEN
5981 IF(K(KH,1).GT.20) KH=0
5982 ENDIF
5983 IF(KH.NE.0) GOTO 210
5984 I1=I1+1
5985 200 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
5986 210 N=I1
5987
5988C...Place largest axis along z axis and second largest in xy plane.
5989 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
5990 CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61),1),
5991 & P(MSTU(61),2)),0D0,0D0,0D0)
5992 CALL LUDBRB(1,N+MSTU(3),-ULANGL(P(MSTU(61),3),
5993 & P(MSTU(61),1)),0.,0D0,0D0,0D0)
5994 CALL LUDBRB(1,N+MSTU(3),0.,-ULANGL(P(MSTU(61)+1,1),
5995 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
5996 IF(MEDIT.EQ.31) RETURN
5997
5998C...Rotate to put slim jet along +z axis.
5999 DO 220 IS=1,2
6000 NS(IS)=0
6001 PTS(IS)=0.
6002 220 PLS(IS)=0.
6003 DO 230 I=1,N
6004 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 230
6005 IF(MSTU(41).GE.2) THEN
6006 KC=LUCOMP(K(I,2))
6007 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6008 & KC.EQ.18) GOTO 230
6009 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6010 & GOTO 230
6011 ENDIF
6012 IS=2.-SIGN(0.5,P(I,3))
6013 NS(IS)=NS(IS)+1
6014 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
6015 230 CONTINUE
6016 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
6017 & CALL LUDBRB(1,N+MSTU(3),PARU(1),0.,0D0,0D0,0D0)
6018
6019C...Rotate to put second largest jet into -z,+x quadrant.
6020 DO 240 I=1,N
6021 IF(P(I,3).GE.0.) GOTO 240
6022 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 240
6023 IF(MSTU(41).GE.2) THEN
6024 KC=LUCOMP(K(I,2))
6025 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6026 & KC.EQ.18) GOTO 240
6027 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6028 & GOTO 240
6029 ENDIF
6030 IS=2.-SIGN(0.5,P(I,1))
6031 PLS(IS)=PLS(IS)-P(I,3)
6032 240 CONTINUE
6033 IF(PLS(2).GT.PLS(1)) CALL LUDBRB(1,N+MSTU(3),0.,PARU(1),
6034 & 0D0,0D0,0D0)
6035 ENDIF
6036
6037 RETURN
6038 END
6039
6040C*********************************************************************
6041
6042 SUBROUTINE LULIST(MLIST)
6043
6044C...Purpose: to give program heading, or list an event, or particle
6045C...data, or current parameter values.
6046 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6047 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6048 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6049 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6050 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
6051 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHMO(12)*3,CHDL(7)*4
6052 DIMENSION PS(6)
6053 DATA CHMO/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
6054 &'Oct','Nov','Dec'/,CHDL/'(())',' ','()','!!','<>','==','(==)'/
6055
6056C...Initialization printout: version number and date of last change.
6057 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
6058 WRITE(MSTU(11),5000) MSTU(181),MSTU(182),MSTU(185),
6059 & CHMO(MSTU(184)),MSTU(183)
6060 MSTU(12)=0
6061 IF(MLIST.EQ.0) RETURN
6062 ENDIF
6063
6064C...List event data, including additional lines after N.
6065 IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
6066 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
6067 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
6068 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
6069 LMX=12
6070 IF(MLIST.GE.2) LMX=16
6071 ISTR=0
6072 IMAX=N
6073 IF(MSTU(2).GT.0) IMAX=MSTU(2)
6074 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
6075 IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
6076
6077C...Get particle name, pad it and check it is not too long.
6078 CALL LUNAME(K(I,2),CHAP)
6079 LEN=0
6080 DO 100 LEM=1,16
6081 100 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
6082 MDL=(K(I,1)+19)/10
6083 LDL=0
6084 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
6085 CHAC=CHAP
6086 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
6087 ELSE
6088 LDL=1
6089 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
6090 IF(LEN.EQ.0) THEN
6091 CHAC=CHDL(MDL)(1:2*LDL)//' '
6092 ELSE
6093 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
6094 & CHDL(MDL)(LDL+1:2*LDL)//' '
6095 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
6096 ENDIF
6097 ENDIF
6098
6099C...Add information on string connection.
6100 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
6101 & THEN
6102 KC=LUCOMP(K(I,2))
6103 KCC=0
6104 IF(KC.NE.0) KCC=KCHG(KC,2)
6105 IF(IABS(K(I,2)).EQ.39) THEN
6106 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
6107 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
6108 ISTR=1
6109 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
6110 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
6111 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
6112 ELSEIF(KCC.NE.0) THEN
6113 ISTR=0
6114 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
6115 ENDIF
6116 ENDIF
6117
6118C...Write data for particle/jet.
6119 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999.) THEN
6120 WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
6121 & (P(I,J2),J2=1,5)
6122 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999.) THEN
6123 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
6124 & (P(I,J2),J2=1,5)
6125 ELSEIF(MLIST.EQ.1) THEN
6126 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
6127 & (P(I,J2),J2=1,5)
6128 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
6129 & K(I,1).EQ.14)) THEN
6130 WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
6131 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
6132 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
6133 & (P(I,J2),J2=1,5)
6134 ELSE
6135 WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),(P(I,J2),J2=1,5)
6136 ENDIF
6137 IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
6138
6139C...Insert extra separator lines specified by user.
6140 IF(MSTU(70).GE.1) THEN
6141 ISEP=0
6142 DO 110 J=1,MIN(10,MSTU(70))
6143 110 IF(I.EQ.MSTU(70+J)) ISEP=1
6144 IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
6145 IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
6146 ENDIF
6147 120 CONTINUE
6148
6149C...Sum of charges and momenta.
6150 DO 130 J=1,6
6151 130 PS(J)=PLU(0,J)
6152 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999.) THEN
6153 WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
6154 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999.) THEN
6155 WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
6156 ELSEIF(MLIST.EQ.1) THEN
6157 WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
6158 ELSE
6159 WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
6160 ENDIF
6161
6162C...Give simple list of KF codes defined in program.
6163 ELSEIF(MLIST.EQ.11) THEN
6164 WRITE(MSTU(11),6600)
6165 DO 140 KF=1,40
6166 CALL LUNAME(KF,CHAP)
6167 CALL LUNAME(-KF,CHAN)
6168 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
6169 140 IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6170 DO 150 KFLS=1,3,2
6171 DO 150 KFLA=1,8
6172 DO 150 KFLB=1,KFLA-(3-KFLS)/2
6173 KF=1000*KFLA+100*KFLB+KFLS
6174 CALL LUNAME(KF,CHAP)
6175 CALL LUNAME(-KF,CHAN)
6176 150 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6177 KF=130
6178 CALL LUNAME(KF,CHAP)
6179 WRITE(MSTU(11),6700) KF,CHAP
6180 KF=310
6181 CALL LUNAME(KF,CHAP)
6182 WRITE(MSTU(11),6700) KF,CHAP
6183 DO 170 KMUL=0,5
6184 KFLS=3
6185 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
6186 IF(KMUL.EQ.5) KFLS=5
6187 KFLR=0
6188 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
6189 IF(KMUL.EQ.4) KFLR=2
6190 DO 170 KFLB=1,8
6191 DO 160 KFLC=1,KFLB-1
6192 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
6193 CALL LUNAME(KF,CHAP)
6194 CALL LUNAME(-KF,CHAN)
6195 160 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6196 KF=10000*KFLR+110*KFLB+KFLS
6197 CALL LUNAME(KF,CHAP)
6198 170 WRITE(MSTU(11),6700) KF,CHAP
6199 DO 190 KFLSP=1,3
6200 KFLS=2+2*(KFLSP/3)
6201 DO 190 KFLA=1,8
6202 DO 190 KFLB=1,KFLA
6203 DO 180 KFLC=1,KFLB
6204 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) GOTO 180
6205 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 180
6206 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
6207 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
6208 CALL LUNAME(KF,CHAP)
6209 CALL LUNAME(-KF,CHAN)
6210 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
6211 180 CONTINUE
6212 190 CONTINUE
6213
6214C...List parton/particle data table. Check whether to be listed.
6215 ELSEIF(MLIST.EQ.12) THEN
6216 WRITE(MSTU(11),6800)
6217 MSTJ24=MSTJ(24)
6218 MSTJ(24)=0
6219 KFMAX=20883
6220 IF(MSTU(2).NE.0) KFMAX=MSTU(2)
6221 DO 220 KF=MAX(1,MSTU(1)),KFMAX
6222 KC=LUCOMP(KF)
6223 IF(KC.EQ.0) GOTO 220
6224 IF(MSTU(14).EQ.0.AND.KF.GT.100.AND.KC.LE.100) GOTO 220
6225 IF(MSTU(14).GT.0.AND.KF.GT.100.AND.MAX(MOD(KF/1000,10),
6226 & MOD(KF/100,10)).GT.MSTU(14)) GOTO 220
6227
6228C...Find particle name and mass. Print information.
6229 CALL LUNAME(KF,CHAP)
6230 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 220
6231 CALL LUNAME(-KF,CHAN)
6232 PM=ULMASS(KF)
6233 WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,KCHG(KC,1),KCHG(KC,2),
6234 & KCHG(KC,3),PM,PMAS(KC,2),PMAS(KC,3),PMAS(KC,4),MDCY(KC,1)
6235
6236C...Particle decay: channel number, branching ration, matrix element,
6237C...decay products.
6238 IF(KF.GT.100.AND.KC.LE.100) GOTO 220
6239 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6240 DO 200 J=1,5
6241 200 CALL LUNAME(KFDP(IDC,J),CHAD(J))
6242 210 WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6243 & (CHAD(J),J=1,5)
6244 220 CONTINUE
6245 MSTJ(24)=MSTJ24
6246
6247C...List parameter value table.
6248 ELSEIF(MLIST.EQ.13) THEN
6249 WRITE(MSTU(11),7100)
6250 DO 230 I=1,200
6251 230 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
6252 ENDIF
6253
6254C...Format statements for output on unit MSTU(11) (by default 6).
6255 5000 FORMAT(///20X,'The Lund Monte Carlo - JETSET version ',I1,'.',I1/
6256 &20X,'** Last date of change: ',I2,1X,A3,1X,I4,' **'/)
6257 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
6258 &5X,'KF orig p_x p_y p_z E m'/)
6259 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
6260 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
6261 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
6262 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
6263 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
6264 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
6265 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
6266 5400 FORMAT(1X,I5,2X,A12,1X,I2,1X,I6,1X,I4,5F9.3)
6267 5500 FORMAT(1X,I5,2X,A12,1X,I2,1X,I6,1X,I4,5F9.2)
6268 5600 FORMAT(1X,I5,2X,A12,1X,I2,1X,I6,1X,I4,5F9.1)
6269 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I1,2I4),5F13.5)
6270 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I8,2X,I4,2(3X,I9),5F13.5)
6271 5900 FORMAT(66X,5(1X,F12.3))
6272 6000 FORMAT(1X,78('='))
6273 6100 FORMAT(1X,130('='))
6274 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
6275 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
6276 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
6277 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
6278 &5F13.5)
6279 6600 FORMAT(///20X,'List of KF codes in program'/)
6280 6700 FORMAT(4X,I6,4X,A16,6X,I6,4X,A16)
6281 6800 FORMAT(///30X,'Particle/parton data table'//5X,'KF',5X,'KC',4X,
6282 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
6283 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
6284 &1X,'ME',3X,'Br.rat.',4X,'decay products')
6285 6900 FORMAT(/1X,I6,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
6286 &2X,F12.5,3X,I2)
6287 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F8.5,4X,5A16)
6288 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
6289 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
6290 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
6291
6292 RETURN
6293 END
6294
6295C*********************************************************************
6296
6297 SUBROUTINE LUUPDA(MUPDA,LFN)
6298
6299C...Purpose: to facilitate the updating of particle and decay data.
6300 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6301 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6302 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
6303 COMMON/LUDAT4/CHAF(500)
6304 CHARACTER CHAF*8
6305 SAVE /LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/
6306 CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
6307 &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
6308 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
6309 &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
6310 &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
6311 &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
6312
6313C...Write information on file for editing.
6314 IF(MSTU(12).GE.1) CALL LULIST(0)
6315 IF(MUPDA.EQ.1) THEN
6316 DO 110 KC=1,MSTU(6)
6317 WRITE(LFN,5000) KC,CHAF(KC),(KCHG(KC,J1),J1=1,3),
6318 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
6319 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6320 100 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6321 & (KFDP(IDC,J),J=1,5)
6322 110 CONTINUE
6323
6324C...Reset variables and read information from edited file.
6325 ELSEIF(MUPDA.EQ.2) THEN
6326 DO 120 I=1,MSTU(7)
6327 MDME(I,1)=1
6328 MDME(I,2)=0
6329 BRAT(I)=0.
6330 DO 120 J=1,5
6331 120 KFDP(I,J)=0
6332 KC=0
6333 IDC=0
6334 NDC=0
6335 130 READ(LFN,5200,END=140) CHINL
6336 IF(CHINL(2:5).NE.' ') THEN
6337 CHKC=CHINL(2:5)
6338 IF(KC.NE.0) THEN
6339 MDCY(KC,2)=0
6340 IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
6341 MDCY(KC,3)=NDC
6342 ENDIF
6343 READ(CHKC,5300) KC
6344 IF(KC.LE.0.OR.KC.GT.MSTU(6)) CALL LUERRM(27,
6345 & '(LUUPDA:) Read KC code illegal, KC ='//CHKC)
6346 READ(CHINL,5000) KCR,CHAF(KC),(KCHG(KC,J1),J1=1,3),
6347 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
6348 NDC=0
6349 ELSE
6350 IDC=IDC+1
6351 NDC=NDC+1
6352 IF(IDC.GE.MSTU(7)) CALL LUERRM(27,
6353 & '(LUUPDA:) Decay data arrays full by KC ='//CHKC)
6354 READ(CHINL,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
6355 & (KFDP(IDC,J),J=1,5)
6356 ENDIF
6357 GOTO 130
6358 140 MDCY(KC,2)=0
6359 IF(NDC.NE.0) MDCY(KC,2)=IDC+1-NDC
6360 MDCY(KC,3)=NDC
6361
6362C...Perform possible tests that new information is consistent.
6363 MSTJ24=MSTJ(24)
6364 MSTJ(24)=0
6365 DO 170 KC=1,MSTU(6)
6366 WRITE(CHKC,5300) KC
6367 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
6368 & PMAS(KC,4)).LT.0..OR.MDCY(KC,3).LT.0) CALL LUERRM(17,
6369 & '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//CHKC)
6370 BRSUM=0.
6371 DO 160 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
6372 IF(MDME(IDC,2).GT.80) GOTO 160
6373 KQ=KCHG(KC,1)
6374 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
6375 MERR=0
6376 DO 150 J=1,5
6377 KP=KFDP(IDC,J)
6378 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
6379 ELSEIF(LUCOMP(KP).EQ.0) THEN
6380 MERR=3
6381 ELSE
6382 KQ=KQ-LUCHGE(KP)
6383 PMS=PMS-ULMASS(KP)
6384 ENDIF
6385 150 CONTINUE
6386 IF(KQ.NE.0) MERR=MAX(2,MERR)
6387 IF(KFDP(IDC,2).NE.0.AND.(KC.LE.20.OR.KC.GT.40).AND.
6388 & (KC.LE.80.OR.KC.GT.100).AND.MDME(IDC,2).NE.34.AND.
6389 & MDME(IDC,2).NE.61.AND.PMS.LT.0.) MERR=MAX(1,MERR)
6390 IF(MERR.EQ.3) CALL LUERRM(17,
6391 & '(LUUPDA:) Unknown particle code in decay of KC ='//CHKC)
6392 IF(MERR.EQ.2) CALL LUERRM(17,
6393 & '(LUUPDA:) Charge not conserved in decay of KC ='//CHKC)
6394 IF(MERR.EQ.1) CALL LUERRM(7,
6395 & '(LUUPDA:) Kinematically unallowed decay of KC ='//CHKC)
6396 BRSUM=BRSUM+BRAT(IDC)
6397 160 CONTINUE
6398 WRITE(CHTMP,5500) BRSUM
6399 IF(ABS(BRSUM).GT.0.0005.AND.ABS(BRSUM-1.).GT.0.0005) CALL
6400 & LUERRM(7,'(LUUPDA:) Sum of branching ratios is '//CHTMP(5:12)//
6401 & ' for KC ='//CHKC)
6402 170 CONTINUE
6403 MSTJ(24)=MSTJ24
6404
6405C...Initialize writing of DATA statements for inclusion in program.
6406 ELSEIF(MUPDA.EQ.3) THEN
6407 DO 240 IVAR=1,19
6408 NDIM=MSTU(6)
6409 IF(IVAR.GE.11.AND.IVAR.LE.18) NDIM=MSTU(7)
6410 NLIN=1
6411 CHLIN=' '
6412 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
6413 LLIN=35
6414 CHOLD='START'
6415
6416C...Loop through variables for conversion to characters.
6417 DO 220 IDIM=1,NDIM
6418 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
6419 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
6420 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
6421 IF(IVAR.EQ.4) WRITE(CHTMP,5500) PMAS(IDIM,1)
6422 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,2)
6423 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,3)
6424 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,4)
6425 IF(IVAR.EQ.8) WRITE(CHTMP,5400) MDCY(IDIM,1)
6426 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,2)
6427 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,3)
6428 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDME(IDIM,1)
6429 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,2)
6430 IF(IVAR.EQ.13) WRITE(CHTMP,5500) BRAT(IDIM)
6431 IF(IVAR.EQ.14) WRITE(CHTMP,5400) KFDP(IDIM,1)
6432 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,2)
6433 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,3)
6434 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,4)
6435 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,5)
6436 IF(IVAR.EQ.19) CHTMP=CHAF(IDIM)
6437
6438C...Length of variable, trailing decimal zeros, quotation marks.
6439 LLOW=1
6440 LHIG=1
6441 DO 180 LL=1,12
6442 IF(CHTMP(13-LL:13-LL).NE.' ') LLOW=13-LL
6443 180 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
6444 CHNEW=CHTMP(LLOW:LHIG)//' '
6445 LNEW=1+LHIG-LLOW
6446 IF((IVAR.GE.4.AND.IVAR.LE.7).OR.IVAR.EQ.13) THEN
6447 LNEW=LNEW+1
6448 190 LNEW=LNEW-1
6449 IF(CHNEW(LNEW:LNEW).EQ.'0') GOTO 190
6450 IF(LNEW.EQ.1) CHNEW(1:2)='0.'
6451 IF(LNEW.EQ.1) LNEW=2
6452 ELSEIF(IVAR.EQ.19) THEN
6453 DO 200 LL=LNEW,1,-1
6454 IF(CHNEW(LL:LL).EQ.'''') THEN
6455 CHTMP=CHNEW
6456 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
6457 LNEW=LNEW+1
6458 ENDIF
6459 200 CONTINUE
6460 CHTMP=CHNEW
6461 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
6462 LNEW=LNEW+2
6463 ENDIF
6464
6465C...Form composite character string, often including repetition counter.
6466 IF(CHNEW.NE.CHOLD) THEN
6467 NRPT=1
6468 CHOLD=CHNEW
6469 CHCOM=CHNEW
6470 LCOM=LNEW
6471 ELSE
6472 LRPT=LNEW+1
6473 IF(NRPT.GE.2) LRPT=LNEW+3
6474 IF(NRPT.GE.10) LRPT=LNEW+4
6475 IF(NRPT.GE.100) LRPT=LNEW+5
6476 IF(NRPT.GE.1000) LRPT=LNEW+6
6477 LLIN=LLIN-LRPT
6478 NRPT=NRPT+1
6479 WRITE(CHTMP,5400) NRPT
6480 LRPT=1
6481 IF(NRPT.GE.10) LRPT=2
6482 IF(NRPT.GE.100) LRPT=3
6483 IF(NRPT.GE.1000) LRPT=4
6484 CHCOM(1:LRPT+1+LNEW)=CHTMP(13-LRPT:12)//'*'//CHNEW(1:LNEW)
6485 LCOM=LRPT+1+LNEW
6486 ENDIF
6487
6488C...Add characters to end of line, to new line (after storing old line),
6489C...or to new block of lines (after writing old block).
6490 IF(LLIN+LCOM.LE.70) THEN
6491 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
6492 LLIN=LLIN+LCOM+1
6493 ELSEIF(NLIN.LE.19) THEN
6494 CHLIN(LLIN+1:72)=' '
6495 CHBLK(NLIN)=CHLIN
6496 NLIN=NLIN+1
6497 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
6498 LLIN=6+LCOM+1
6499 ELSE
6500 CHLIN(LLIN:72)='/'//' '
6501 CHBLK(NLIN)=CHLIN
6502 WRITE(CHTMP,5400) IDIM-NRPT
6503 CHBLK(1)(30:33)=CHTMP(9:12)
6504 DO 210 ILIN=1,NLIN
6505 210 WRITE(LFN,5600) CHBLK(ILIN)
6506 NLIN=1
6507 CHLIN=' '
6508 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//',I= , )/'//
6509 & CHCOM(1:LCOM)//','
6510 WRITE(CHTMP,5400) IDIM-NRPT+1
6511 CHLIN(25:28)=CHTMP(9:12)
6512 LLIN=35+LCOM+1
6513 ENDIF
6514 220 CONTINUE
6515
6516C...Write final block of lines.
6517 CHLIN(LLIN:72)='/'//' '
6518 CHBLK(NLIN)=CHLIN
6519 WRITE(CHTMP,5400) NDIM
6520 CHBLK(1)(30:33)=CHTMP(9:12)
6521 DO 230 ILIN=1,NLIN
6522 230 WRITE(LFN,5600) CHBLK(ILIN)
6523 240 CONTINUE
6524 ENDIF
6525
6526C...Formats for reading and writing particle data.
6527 5000 FORMAT(1X,I4,2X,A8,3I3,3F12.5,2X,F12.5,I3)
6528 5100 FORMAT(5X,2I5,F12.5,5I8)
6529 5200 FORMAT(A80)
6530 5300 FORMAT(I4)
6531 5400 FORMAT(I12)
6532 5500 FORMAT(F12.5)
6533 5600 FORMAT(A72)
6534
6535 RETURN
6536 END
6537
6538C*********************************************************************
6539
6540 FUNCTION KLU(I,J)
6541
6542C...Purpose: to provide various integer-valued event related data.
6543 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6544 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6545 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6546 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6547
6548C...Default value. For I=0 number of entries, number of stable entries
6549C...or 3 times total charge.
6550 KLU=0
6551 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6552 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
6553 KLU=N
6554 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
6555 DO 100 I1=1,N
6556 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+1
6557 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) KLU=KLU+
6558 & LUCHGE(K(I1,2))
6559 100 CONTINUE
6560 ELSEIF(I.EQ.0) THEN
6561
6562C...For I > 0 direct readout of K matrix or charge.
6563 ELSEIF(J.LE.5) THEN
6564 KLU=K(I,J)
6565 ELSEIF(J.EQ.6) THEN
6566 KLU=LUCHGE(K(I,2))
6567
6568C...Status (existing/fragmented/decayed), parton/hadron separation.
6569 ELSEIF(J.LE.8) THEN
6570 IF(K(I,1).GE.1.AND.K(I,1).LE.10) KLU=1
6571 IF(J.EQ.8) KLU=KLU*K(I,2)
6572 ELSEIF(J.LE.12) THEN
6573 KFA=IABS(K(I,2))
6574 KC=LUCOMP(KFA)
6575 KQ=0
6576 IF(KC.NE.0) KQ=KCHG(KC,2)
6577 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) KLU=K(I,2)
6578 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) KLU=K(I,2)
6579 IF(J.EQ.11) KLU=KC
6580 IF(J.EQ.12) KLU=KQ*ISIGN(1,K(I,2))
6581
6582C...Heaviest flavour in hadron/diquark.
6583 ELSEIF(J.EQ.13) THEN
6584 KFA=IABS(K(I,2))
6585 KLU=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
6586 IF(KFA.LT.10) KLU=KFA
6587 IF(MOD(KFA/1000,10).NE.0) KLU=MOD(KFA/1000,10)
6588 KLU=KLU*ISIGN(1,K(I,2))
6589
6590C...Particle history: generation, ancestor, rank.
6591 ELSEIF(J.LE.16) THEN
6592 I2=I
6593 I1=I
6594 110 KLU=KLU+1
6595 I3=I2
6596 I2=I1
6597 I1=K(I1,3)
6598 IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
6599 IF(J.EQ.15) KLU=I2
6600 IF(J.EQ.16) THEN
6601 KLU=0
6602 DO 120 I1=I2+1,I3
6603 120 IF(K(I1,3).EQ.I2.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) KLU=KLU+1
6604 ENDIF
6605
6606C...Particle coming from collapsing jet system or not.
6607 ELSEIF(J.EQ.17) THEN
6608 I1=I
6609 130 KLU=KLU+1
6610 I3=I1
6611 I1=K(I1,3)
6612 I0=MAX(1,I1)
6613 KC=LUCOMP(K(I0,2))
6614 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
6615 IF(KLU.EQ.1) KLU=-1
6616 IF(KLU.GT.1) KLU=0
6617 RETURN
6618 ENDIF
6619 IF(KCHG(KC,2).EQ.0) GOTO 130
6620 IF(K(I1,1).NE.12) KLU=0
6621 IF(K(I1,1).NE.12) RETURN
6622 I2=I1
6623 140 I2=I2+1
6624 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 140
6625 K3M=K(I3-1,3)
6626 IF(K3M.GE.I1.AND.K3M.LE.I2) KLU=0
6627 K3P=K(I3+1,3)
6628 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) KLU=0
6629
6630C...Number of decay products. Colour flow.
6631 ELSEIF(J.EQ.18) THEN
6632 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) KLU=MAX(0,K(I,5)-K(I,4)+1)
6633 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) KLU=0
6634 ELSEIF(J.LE.22) THEN
6635 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
6636 IF(J.EQ.19) KLU=MOD(K(I,4)/MSTU(5),MSTU(5))
6637 IF(J.EQ.20) KLU=MOD(K(I,5)/MSTU(5),MSTU(5))
6638 IF(J.EQ.21) KLU=MOD(K(I,4),MSTU(5))
6639 IF(J.EQ.22) KLU=MOD(K(I,5),MSTU(5))
6640 ELSE
6641 ENDIF
6642
6643 RETURN
6644 END
6645
6646C*********************************************************************
6647
6648 FUNCTION PLU(I,J)
6649
6650C...Purpose: to provide various real-valued event related data.
6651 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6652 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6653 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6654 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6655 DIMENSION PSUM(4)
6656
6657C...Set default value. For I = 0 sum of momenta or charges,
6658C...or invariant mass of system.
6659 PLU=0.
6660 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
6661 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
6662 DO 100 I1=1,N
6663 100 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+P(I1,J)
6664 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
6665 DO 110 J1=1,4
6666 PSUM(J1)=0.
6667 DO 110 I1=1,N
6668 110 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+P(I1,J1)
6669 PLU=SQRT(MAX(0.,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
6670 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
6671 DO 120 I1=1,N
6672 120 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PLU=PLU+LUCHGE(K(I1,2))/3.
6673 ELSEIF(I.EQ.0) THEN
6674
6675C...Direct readout of P matrix.
6676 ELSEIF(J.LE.5) THEN
6677 PLU=P(I,J)
6678
6679C...Charge, total momentum, transverse momentum, transverse mass.
6680 ELSEIF(J.LE.12) THEN
6681 IF(J.EQ.6) PLU=LUCHGE(K(I,2))/3.
6682 IF(J.EQ.7.OR.J.EQ.8) PLU=P(I,1)**2+P(I,2)**2+P(I,3)**2
6683 IF(J.EQ.9.OR.J.EQ.10) PLU=P(I,1)**2+P(I,2)**2
6684 IF(J.EQ.11.OR.J.EQ.12) PLU=P(I,5)**2+P(I,1)**2+P(I,2)**2
6685 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PLU=SQRT(PLU)
6686
6687C...Theta and phi angle in radians or degrees.
6688 ELSEIF(J.LE.16) THEN
6689 IF(J.LE.14) PLU=ULANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
6690 IF(J.GE.15) PLU=ULANGL(P(I,1),P(I,2))
6691 IF(J.EQ.14.OR.J.EQ.16) PLU=PLU*180./PARU(1)
6692
6693C...True rapidity, rapidity with pion mass, pseudorapidity.
6694 ELSEIF(J.LE.19) THEN
6695 PMR=0.
6696 IF(J.EQ.17) PMR=P(I,5)
6697 IF(J.EQ.18) PMR=ULMASS(211)
6698 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
6699 PLU=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
6700 & 1E20)),P(I,3))
6701
6702C...Energy and momentum fractions (only to be used in CM frame).
6703 ELSEIF(J.LE.25) THEN
6704 IF(J.EQ.20) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
6705 IF(J.EQ.21) PLU=2.*P(I,3)/PARU(21)
6706 IF(J.EQ.22) PLU=2.*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
6707 IF(J.EQ.23) PLU=2.*P(I,4)/PARU(21)
6708 IF(J.EQ.24) PLU=(P(I,4)+P(I,3))/PARU(21)
6709 IF(J.EQ.25) PLU=(P(I,4)-P(I,3))/PARU(21)
6710 ENDIF
6711
6712 RETURN
6713 END
6714
6715C*********************************************************************
6716
6717 SUBROUTINE LUSPHE(SPH,APL)
6718
6719C...Purpose: to perform sphericity tensor analysis to give sphericity,
6720C...aplanarity and the related event axes.
6721 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6722 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6723 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6724 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6725 DIMENSION SM(3,3),SV(3,3)
6726
6727C...Calculate matrix to be diagonalized.
6728 NP=0
6729 DO 100 J1=1,3
6730 DO 100 J2=J1,3
6731 100 SM(J1,J2)=0.
6732 PS=0.
6733 DO 120 I=1,N
6734 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
6735 IF(MSTU(41).GE.2) THEN
6736 KC=LUCOMP(K(I,2))
6737 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6738 & KC.EQ.18) GOTO 120
6739 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6740 & GOTO 120
6741 ENDIF
6742 NP=NP+1
6743 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6744 PWT=1.
6745 IF(ABS(PARU(41)-2.).GT.0.001) PWT=MAX(1E-10,PA)**(PARU(41)-2.)
6746 DO 110 J1=1,3
6747 DO 110 J2=J1,3
6748 110 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
6749 PS=PS+PWT*PA**2
6750 120 CONTINUE
6751
6752C...Very low multiplicities (0 or 1) not considered.
6753 IF(NP.LE.1) THEN
6754 CALL LUERRM(8,'(LUSPHE:) too few particles for analysis')
6755 SPH=-1.
6756 APL=-1.
6757 RETURN
6758 ENDIF
6759 DO 130 J1=1,3
6760 DO 130 J2=J1,3
6761 130 SM(J1,J2)=SM(J1,J2)/PS
6762
6763C...Find eigenvalues to matrix (third degree equation).
6764 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
6765 &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
6766 SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
6767 &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
6768 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
6769 P(N+1,4)=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
6770 P(N+3,4)=1./3.+SQRT(-SQ)*MIN(2.*SP,-SQRT(3.*(1.-SP**2))-SP)
6771 P(N+2,4)=1.-P(N+1,4)-P(N+3,4)
6772 IF(P(N+2,4).LT.1E-5) THEN
6773 CALL LUERRM(8,'(LUSPHE:) all particles back-to-back')
6774 SPH=-1.
6775 APL=-1.
6776 RETURN
6777 ENDIF
6778
6779C...Find first and last eigenvector by solving equation system.
6780 DO 170 I=1,3,2
6781 DO 140 J1=1,3
6782 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
6783 DO 140 J2=J1+1,3
6784 SV(J1,J2)=SM(J1,J2)
6785 140 SV(J2,J1)=SM(J1,J2)
6786 SMAX=0.
6787 DO 150 J1=1,3
6788 DO 150 J2=1,3
6789 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 150
6790 JA=J1
6791 JB=J2
6792 SMAX=ABS(SV(J1,J2))
6793 150 CONTINUE
6794 SMAX=0.
6795 DO 160 J3=JA+1,JA+2
6796 J1=J3-3*((J3-1)/3)
6797 RL=SV(J1,JB)/SV(JA,JB)
6798 DO 160 J2=1,3
6799 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
6800 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 160
6801 JC=J1
6802 SMAX=ABS(SV(J1,J2))
6803 160 CONTINUE
6804 JB1=JB+1-3*(JB/3)
6805 JB2=JB+2-3*((JB+1)/3)
6806 P(N+I,JB1)=-SV(JC,JB2)
6807 P(N+I,JB2)=SV(JC,JB1)
6808 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
6809 &SV(JA,JB)
6810 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
6811 SGN=(-1.)**INT(RLU(0)+0.5)
6812 DO 170 J=1,3
6813 170 P(N+I,J)=SGN*P(N+I,J)/PA
6814
6815C...Middle axis orthogonal to other two. Fill other codes.
6816 SGN=(-1.)**INT(RLU(0)+0.5)
6817 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
6818 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
6819 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
6820 DO 180 I=1,3
6821 K(N+I,1)=31
6822 K(N+I,2)=95
6823 K(N+I,3)=I
6824 K(N+I,4)=0
6825 K(N+I,5)=0
6826 P(N+I,5)=0.
6827 DO 180 J=1,5
6828 180 V(I,J)=0.
6829
6830C...Calculate sphericity and aplanarity. Select storing option.
6831 SPH=1.5*(P(N+2,4)+P(N+3,4))
6832 APL=1.5*P(N+3,4)
6833 MSTU(61)=N+1
6834 MSTU(62)=NP
6835 IF(MSTU(43).LE.1) MSTU(3)=3
6836 IF(MSTU(43).GE.2) N=N+3
6837
6838 RETURN
6839 END
6840
6841C*********************************************************************
6842
6843 SUBROUTINE LUTHRU(THR,OBL)
6844
6845C...Purpose: to perform thrust analysis to give thrust, oblateness
6846C...and the related event axes.
6847 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
6848 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6849 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
6850 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
6851 DIMENSION TDI(3),TPR(3)
6852
6853C...Take copy of particles that are to be considered in thrust analysis.
6854 NP=0
6855 PS=0.
6856 DO 100 I=1,N
6857 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
6858 IF(MSTU(41).GE.2) THEN
6859 KC=LUCOMP(K(I,2))
6860 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
6861 & KC.EQ.18) GOTO 100
6862 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
6863 & GOTO 100
6864 ENDIF
6865 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
6866 CALL LUERRM(11,'(LUTHRU:) no more memory left in LUJETS')
6867 THR=-2.
6868 OBL=-2.
6869 RETURN
6870 ENDIF
6871 NP=NP+1
6872 K(N+NP,1)=23
6873 P(N+NP,1)=P(I,1)
6874 P(N+NP,2)=P(I,2)
6875 P(N+NP,3)=P(I,3)
6876 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
6877 P(N+NP,5)=1.
6878 IF(ABS(PARU(42)-1.).GT.0.001) P(N+NP,5)=P(N+NP,4)**(PARU(42)-1.)
6879 PS=PS+P(N+NP,4)*P(N+NP,5)
6880 100 CONTINUE
6881
6882C...Very low multiplicities (0 or 1) not considered.
6883 IF(NP.LE.1) THEN
6884 CALL LUERRM(8,'(LUTHRU:) too few particles for analysis')
6885 THR=-1.
6886 OBL=-1.
6887 RETURN
6888 ENDIF
6889
6890C...Loop over thrust and major. T axis along z direction in latter case.
6891 DO 280 ILD=1,2
6892 IF(ILD.EQ.2) THEN
6893 K(N+NP+1,1)=31
6894 PHI=ULANGL(P(N+NP+1,1),P(N+NP+1,2))
6895 MSTU(33)=1
6896 CALL LUDBRB(N+1,N+NP+1,0.,-PHI,0D0,0D0,0D0)
6897 THE=ULANGL(P(N+NP+1,3),P(N+NP+1,1))
6898 CALL LUDBRB(N+1,N+NP+1,-THE,0.,0D0,0D0,0D0)
6899 ENDIF
6900
6901C...Find and order particles with highest p (pT for major).
6902 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
6903 110 P(ILF,4)=0.
6904 DO 150 I=N+1,N+NP
6905 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
6906 DO 120 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
6907 IF(P(I,4).LE.P(ILF,4)) GOTO 130
6908 DO 120 J=1,5
6909 120 P(ILF+1,J)=P(ILF,J)
6910 ILF=N+NP+3
6911 130 DO 140 J=1,5
6912 140 P(ILF+1,J)=P(I,J)
6913 150 CONTINUE
6914
6915C...Find and order initial axes with highest thrust (major).
6916 DO 160 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
6917 160 P(ILG,4)=0.
6918 NC=2**(MIN(MSTU(44),NP)-1)
6919 DO 220 ILC=1,NC
6920 DO 170 J=1,3
6921 170 TDI(J)=0.
6922 DO 180 ILF=1,MIN(MSTU(44),NP)
6923 SGN=P(N+NP+ILF+3,5)
6924 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
6925 DO 180 J=1,4-ILD
6926 180 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
6927 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
6928 DO 190 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
6929 IF(TDS.LE.P(ILG,4)) GOTO 200
6930 DO 190 J=1,4
6931 190 P(ILG+1,J)=P(ILG,J)
6932 ILG=N+NP+MSTU(44)+4
6933 200 DO 210 J=1,3
6934 210 P(ILG+1,J)=TDI(J)
6935 P(ILG+1,4)=TDS
6936 220 CONTINUE
6937
6938C...Iterate direction of axis until stable maximum.
6939 P(N+NP+ILD,4)=0.
6940 ILG=0
6941 230 ILG=ILG+1
6942 THP=0.
6943 240 THPS=THP
6944 DO 250 J=1,3
6945 IF(THP.LE.1E-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
6946 IF(THP.GT.1E-10) TDI(J)=TPR(J)
6947 250 TPR(J)=0.
6948 DO 260 I=N+1,N+NP
6949 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
6950 DO 260 J=1,4-ILD
6951 260 TPR(J)=TPR(J)+SGN*P(I,J)
6952 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
6953 IF(THP.GE.THPS+PARU(48)) GOTO 240
6954
6955C...Save good axis. Try new initial axis until a number of tries agree.
6956 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 230
6957 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
6958 IAGR=0
6959 SGN=(-1.)**INT(RLU(0)+0.5)
6960 DO 270 J=1,3
6961 270 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
6962 P(N+NP+ILD,4)=THP
6963 P(N+NP+ILD,5)=0.
6964 ENDIF
6965 IAGR=IAGR+1
6966 280 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 230
6967
6968C...Find minor axis and value by orthogonality.
6969 SGN=(-1.)**INT(RLU(0)+0.5)
6970 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
6971 P(N+NP+3,2)=SGN*P(N+NP+2,1)
6972 P(N+NP+3,3)=0.
6973 THP=0.
6974 DO 290 I=N+1,N+NP
6975 290 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
6976 P(N+NP+3,4)=THP/PS
6977 P(N+NP+3,5)=0.
6978
6979C...Fill axis information. Rotate back to original coordinate system.
6980 DO 300 ILD=1,3
6981 K(N+ILD,1)=31
6982 K(N+ILD,2)=96
6983 K(N+ILD,3)=ILD
6984 K(N+ILD,4)=0
6985 K(N+ILD,5)=0
6986 DO 300 J=1,5
6987 P(N+ILD,J)=P(N+NP+ILD,J)
6988 300 V(N+ILD,J)=0.
6989 CALL LUDBRB(N+1,N+3,THE,PHI,0D0,0D0,0D0)
6990
6991C...Calculate thrust and oblateness. Select storing option.
6992 THR=P(N+1,4)
6993 OBL=P(N+2,4)-P(N+3,4)
6994 MSTU(61)=N+1
6995 MSTU(62)=NP
6996 IF(MSTU(43).LE.1) MSTU(3)=3
6997 IF(MSTU(43).GE.2) N=N+3
6998
6999 RETURN
7000 END
7001
7002C*********************************************************************
7003
7004 SUBROUTINE LUCLUS(NJET)
7005
7006C...Purpose: to subdivide the particle content of an event into
7007C...jets/clusters.
7008 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7009 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7010 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7011 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7012 DIMENSION PS(5)
7013 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
7014
7015C...Functions: distance measure in pT or (pseudo)mass.
7016 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
7017 &P(I1,3)*P(I2,3))*2.*P(I1,5)*P(I2,5)/(0.0001+P(I1,5)+P(I2,5))**2
7018 R2M(I1,I2)=2.*P(I1,4)*P(I2,4)*(1.-(P(I1,1)*P(I2,1)+P(I1,2)*
7019 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
7020
7021C...If first time, reset. If reentering, skip preliminaries.
7022 IF(MSTU(48).LE.0) THEN
7023 NP=0
7024 DO 100 J=1,5
7025 100 PS(J)=0.
7026 PSS=0.
7027 ELSE
7028 NJET=NSAV
7029 IF(MSTU(43).GE.2) N=N-NJET
7030 DO 110 I=N+1,N+NJET
7031 110 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7032 IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
7033 IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
7034 NLOOP=0
7035 GOTO 290
7036 ENDIF
7037
7038C...Find which particles are to be considered in cluster search.
7039 DO 140 I=1,N
7040 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
7041 IF(MSTU(41).GE.2) THEN
7042 KC=LUCOMP(K(I,2))
7043 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7044 & KC.EQ.18) GOTO 140
7045 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7046 & GOTO 140
7047 ENDIF
7048 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
7049 CALL LUERRM(11,'(LUCLUS:) no more memory left in LUJETS')
7050 NJET=-1
7051 RETURN
7052 ENDIF
7053
7054C...Take copy of these particles, with space left for jets later on.
7055 NP=NP+1
7056 K(N+NP,3)=I
7057 DO 120 J=1,5
7058 120 P(N+NP,J)=P(I,J)
7059 IF(MSTU(42).EQ.0) P(N+NP,5)=0.
7060 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
7061 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7062 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7063 DO 130 J=1,4
7064 130 PS(J)=PS(J)+P(N+NP,J)
7065 PSS=PSS+P(N+NP,5)
7066 140 CONTINUE
7067 DO 150 I=N+1,N+NP
7068 K(I+NP,3)=K(I,3)
7069 DO 150 J=1,5
7070 150 P(I+NP,J)=P(I,J)
7071 PS(5)=SQRT(MAX(0.,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
7072
7073C...Very low multiplicities not considered.
7074 IF(NP.LT.MSTU(47)) THEN
7075 CALL LUERRM(8,'(LUCLUS:) too few particles for analysis')
7076 NJET=-1
7077 RETURN
7078 ENDIF
7079
7080C...Find precluster configuration. If too few jets, make harder cuts.
7081 NLOOP=0
7082 IF(MSTU(46).LE.3) R2ACC=PARU(44)**2
7083 IF(MSTU(46).GE.4) R2ACC=PARU(45)*PS(5)**2
7084 RINIT=1.25*PARU(43)
7085 IF(NP.LE.MSTU(47)+2) RINIT=0.
7086 160 RINIT=0.8*RINIT
7087 NPRE=0
7088 NREM=NP
7089 DO 170 I=N+NP+1,N+2*NP
7090 170 K(I,4)=0
7091
7092C...Sum up small momentum region. Jet if enough absolute momentum.
7093 IF(MSTU(46).LE.2) THEN
7094 DO 180 J=1,4
7095 180 P(N+1,J)=0.
7096 DO 200 I=N+NP+1,N+2*NP
7097 IF(P(I,5).GT.2.*RINIT) GOTO 200
7098 NREM=NREM-1
7099 K(I,4)=1
7100 DO 190 J=1,4
7101 190 P(N+1,J)=P(N+1,J)+P(I,J)
7102 200 CONTINUE
7103 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
7104 IF(P(N+1,5).GT.2.*RINIT) NPRE=1
7105 IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
7106 IF(NREM.EQ.0) GOTO 160
7107 ENDIF
7108
7109C...Find fastest remaining particle.
7110 210 NPRE=NPRE+1
7111 PMAX=0.
7112 DO 220 I=N+NP+1,N+2*NP
7113 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 220
7114 IMAX=I
7115 PMAX=P(I,5)
7116 220 CONTINUE
7117 DO 230 J=1,5
7118 230 P(N+NPRE,J)=P(IMAX,J)
7119 NREM=NREM-1
7120 K(IMAX,4)=NPRE
7121
7122C...Sum up precluster around it according to pT separation.
7123 IF(MSTU(46).LE.2) THEN
7124 DO 250 I=N+NP+1,N+2*NP
7125 IF(K(I,4).NE.0) GOTO 250
7126 R2=R2T(I,IMAX)
7127 IF(R2.GT.RINIT**2) GOTO 250
7128 NREM=NREM-1
7129 K(I,4)=NPRE
7130 DO 240 J=1,4
7131 240 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
7132 250 CONTINUE
7133 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
7134
7135C...Sum up precluster around it according to mass separation.
7136 ELSE
7137 260 IMIN=0
7138 R2MIN=RINIT**2
7139 DO 270 I=N+NP+1,N+2*NP
7140 IF(K(I,4).NE.0) GOTO 270
7141 R2=R2M(I,N+NPRE)
7142 IF(R2.GE.R2MIN) GOTO 270
7143 IMIN=I
7144 R2MIN=R2
7145 270 CONTINUE
7146 IF(IMIN.NE.0) THEN
7147 DO 280 J=1,4
7148 280 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
7149 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
7150 NREM=NREM-1
7151 K(IMIN,4)=NPRE
7152 GOTO 260
7153 ENDIF
7154 ENDIF
7155
7156C...Check if more preclusters to be found. Start over if too few.
7157 IF(RINIT.GE.0.2*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 160
7158 IF(NREM.GT.0) GOTO 210
7159 NJET=NPRE
7160
7161C...Reassign all particles to nearest jet. Sum up new jet momenta.
7162 290 TSAV=0.
7163 PSJT=0.
7164 300 IF(MSTU(46).LE.1) THEN
7165 DO 310 I=N+1,N+NJET
7166 DO 310 J=1,4
7167 310 V(I,J)=0.
7168 DO 340 I=N+NP+1,N+2*NP
7169 R2MIN=PSS**2
7170 DO 320 IJET=N+1,N+NJET
7171 IF(P(IJET,5).LT.RINIT) GOTO 320
7172 R2=R2T(I,IJET)
7173 IF(R2.GE.R2MIN) GOTO 320
7174 IMIN=IJET
7175 R2MIN=R2
7176 320 CONTINUE
7177 K(I,4)=IMIN-N
7178 DO 330 J=1,4
7179 330 V(IMIN,J)=V(IMIN,J)+P(I,J)
7180 340 CONTINUE
7181 PSJT=0.
7182 DO 360 I=N+1,N+NJET
7183 DO 350 J=1,4
7184 350 P(I,J)=V(I,J)
7185 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7186 360 PSJT=PSJT+P(I,5)
7187 ENDIF
7188
7189C...Find two closest jets.
7190 R2MIN=2.*R2ACC
7191 DO 370 ITRY1=N+1,N+NJET-1
7192 DO 370 ITRY2=ITRY1+1,N+NJET
7193 IF(MSTU(46).LE.2) R2=R2T(ITRY1,ITRY2)
7194 IF(MSTU(46).GE.3) R2=R2M(ITRY1,ITRY2)
7195 IF(R2.GE.R2MIN) GOTO 370
7196 IMIN1=ITRY1
7197 IMIN2=ITRY2
7198 R2MIN=R2
7199 370 CONTINUE
7200
7201C...If allowed, join two closest jets and start over.
7202 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
7203 IREC=MIN(IMIN1,IMIN2)
7204 IDEL=MAX(IMIN1,IMIN2)
7205 DO 380 J=1,4
7206 380 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
7207 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
7208 DO 390 I=IDEL+1,N+NJET
7209 DO 390 J=1,5
7210 390 P(I-1,J)=P(I,J)
7211 IF(MSTU(46).GE.2) THEN
7212 DO 400 I=N+NP+1,N+2*NP
7213 IORI=N+K(I,4)
7214 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
7215 400 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
7216 ENDIF
7217 NJET=NJET-1
7218 GOTO 290
7219
7220C...Divide up broad jet if empty cluster in list of final ones.
7221 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
7222 DO 410 I=N+1,N+NJET
7223 410 K(I,5)=0
7224 DO 420 I=N+NP+1,N+2*NP
7225 420 K(N+K(I,4),5)=K(N+K(I,4),5)+1
7226 IEMP=0
7227 DO 430 I=N+1,N+NJET
7228 430 IF(K(I,5).EQ.0) IEMP=I
7229 IF(IEMP.NE.0) THEN
7230 NLOOP=NLOOP+1
7231 ISPL=0
7232 R2MAX=0.
7233 DO 440 I=N+NP+1,N+2*NP
7234 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 440
7235 IJET=N+K(I,4)
7236 R2=R2T(I,IJET)
7237 IF(R2.LE.R2MAX) GOTO 440
7238 ISPL=I
7239 R2MAX=R2
7240 440 CONTINUE
7241 IF(ISPL.NE.0) THEN
7242 IJET=N+K(ISPL,4)
7243 DO 450 J=1,4
7244 P(IEMP,J)=P(ISPL,J)
7245 450 P(IJET,J)=P(IJET,J)-P(ISPL,J)
7246 P(IEMP,5)=P(ISPL,5)
7247 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
7248 IF(NLOOP.LE.2) GOTO 290
7249 ENDIF
7250 ENDIF
7251 ENDIF
7252
7253C...If generalized thrust has not yet converged, continue iteration.
7254 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
7255 &THEN
7256 TSAV=PSJT/PSS
7257 GOTO 300
7258 ENDIF
7259
7260C...Reorder jets according to energy.
7261 DO 460 I=N+1,N+NJET
7262 DO 460 J=1,5
7263 460 V(I,J)=P(I,J)
7264 DO 490 INEW=N+1,N+NJET
7265 PEMAX=0.
7266 DO 470 ITRY=N+1,N+NJET
7267 IF(V(ITRY,4).LE.PEMAX) GOTO 470
7268 IMAX=ITRY
7269 PEMAX=V(ITRY,4)
7270 470 CONTINUE
7271 K(INEW,1)=31
7272 K(INEW,2)=97
7273 K(INEW,3)=INEW-N
7274 K(INEW,4)=0
7275 DO 480 J=1,5
7276 480 P(INEW,J)=V(IMAX,J)
7277 V(IMAX,4)=-1.
7278 490 K(IMAX,5)=INEW
7279
7280C...Clean up particle-jet assignments and jet information.
7281 DO 500 I=N+NP+1,N+2*NP
7282 IORI=K(N+K(I,4),5)
7283 K(I,4)=IORI-N
7284 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
7285 K(IORI,4)=K(IORI,4)+1
7286 500 CONTINUE
7287 IEMP=0
7288 PSJT=0.
7289 DO 520 I=N+1,N+NJET
7290 K(I,5)=0
7291 PSJT=PSJT+P(I,5)
7292 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0.))
7293 DO 510 J=1,5
7294 510 V(I,J)=0.
7295 520 IF(K(I,4).EQ.0) IEMP=I
7296
7297C...Select storing option. Output variables. Check for failure.
7298 MSTU(61)=N+1
7299 MSTU(62)=NP
7300 MSTU(63)=NPRE
7301 PARU(61)=PS(5)
7302 PARU(62)=PSJT/PSS
7303 PARU(63)=SQRT(R2MIN)
7304 IF(NJET.LE.1) PARU(63)=0.
7305 IF(IEMP.NE.0) THEN
7306 CALL LUERRM(8,'(LUCLUS:) failed to reconstruct as requested')
7307 NJET=-1
7308 ENDIF
7309 IF(MSTU(43).LE.1) MSTU(3)=NJET
7310 IF(MSTU(43).GE.2) N=N+NJET
7311 NSAV=NJET
7312
7313 RETURN
7314 END
7315
7316C*********************************************************************
7317
7318 SUBROUTINE LUCELL(NJET)
7319
7320C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
7321C...coordinate frame, as used for calorimeters at hadron colliders.
7322 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7323 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7324 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7325 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7326
7327C...Loop over all particles. Find cell that was hit by given particle.
7328 PTLRAT=1./SINH(PARU(51))**2
7329 NP=0
7330 NC=N
7331 DO 110 I=1,N
7332 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
7333 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
7334 IF(MSTU(41).GE.2) THEN
7335 KC=LUCOMP(K(I,2))
7336 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7337 & KC.EQ.18) GOTO 110
7338 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7339 & GOTO 110
7340 ENDIF
7341 NP=NP+1
7342 PT=SQRT(P(I,1)**2+P(I,2)**2)
7343 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
7344 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5*(ETA/PARU(51)+1.))))
7345 PHI=ULANGL(P(I,1),P(I,2))
7346 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5*(PHI/PARU(1)+1.))))
7347 IETPH=MSTU(52)*IETA+IPHI
7348
7349C...Add to cell already hit, or book new cell.
7350 DO 100 IC=N+1,NC
7351 IF(IETPH.EQ.K(IC,3)) THEN
7352 K(IC,4)=K(IC,4)+1
7353 P(IC,5)=P(IC,5)+PT
7354 GOTO 110
7355 ENDIF
7356 100 CONTINUE
7357 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
7358 CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
7359 NJET=-2
7360 RETURN
7361 ENDIF
7362 NC=NC+1
7363 K(NC,3)=IETPH
7364 K(NC,4)=1
7365 K(NC,5)=2
7366 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
7367 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
7368 P(NC,5)=PT
7369 110 CONTINUE
7370
7371C...Smear true bin content by calorimeter resolution.
7372 IF(MSTU(53).GE.1) THEN
7373 DO 130 IC=N+1,NC
7374 PEI=P(IC,5)
7375 IF(MSTU(53).EQ.2) PEI=P(IC,5)/COSH(P(IC,1))
7376 120 PEF=PEI+PARU(55)*SQRT(-2.*LOG(MAX(1E-10,RLU(0)))*PEI)*
7377 & COS(PARU(2)*RLU(0))
7378 IF(PEF.LT.0..OR.PEF.GT.PARU(56)*PEI) GOTO 120
7379 P(IC,5)=PEF
7380 130 IF(MSTU(53).EQ.2) P(IC,5)=PEF*COSH(P(IC,1))
7381 ENDIF
7382
7383C...Find initiator cell: the one with highest pT of not yet used ones.
7384 NJ=NC
7385 140 ETMAX=0.
7386 DO 150 IC=N+1,NC
7387 IF(K(IC,5).NE.2) GOTO 150
7388 IF(P(IC,5).LE.ETMAX) GOTO 150
7389 ICMAX=IC
7390 ETA=P(IC,1)
7391 PHI=P(IC,2)
7392 ETMAX=P(IC,5)
7393 150 CONTINUE
7394 IF(ETMAX.LT.PARU(52)) GOTO 210
7395 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
7396 CALL LUERRM(11,'(LUCELL:) no more memory left in LUJETS')
7397 NJET=-2
7398 RETURN
7399 ENDIF
7400 K(ICMAX,5)=1
7401 NJ=NJ+1
7402 K(NJ,4)=0
7403 K(NJ,5)=1
7404 P(NJ,1)=ETA
7405 P(NJ,2)=PHI
7406 P(NJ,3)=0.
7407 P(NJ,4)=0.
7408 P(NJ,5)=0.
7409
7410C...Sum up unused cells within required distance of initiator.
7411 DO 160 IC=N+1,NC
7412 IF(K(IC,5).EQ.0) GOTO 160
7413 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 160
7414 DPHIA=ABS(P(IC,2)-PHI)
7415 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 160
7416 PHIC=P(IC,2)
7417 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
7418 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 160
7419 K(IC,5)=-K(IC,5)
7420 K(NJ,4)=K(NJ,4)+K(IC,4)
7421 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
7422 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
7423 P(NJ,5)=P(NJ,5)+P(IC,5)
7424 160 CONTINUE
7425
7426C...Reject cluster below minimum ET, else accept.
7427 IF(P(NJ,5).LT.PARU(53)) THEN
7428 NJ=NJ-1
7429 DO 170 IC=N+1,NC
7430 170 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
7431 ELSEIF(MSTU(54).LE.2) THEN
7432 P(NJ,3)=P(NJ,3)/P(NJ,5)
7433 P(NJ,4)=P(NJ,4)/P(NJ,5)
7434 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
7435 & P(NJ,4))
7436 DO 180 IC=N+1,NC
7437 180 IF(K(IC,5).LT.0) K(IC,5)=0
7438 ELSE
7439 DO 190 J=1,4
7440 190 P(NJ,J)=0.
7441 DO 200 IC=N+1,NC
7442 IF(K(IC,5).GE.0) GOTO 200
7443 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
7444 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
7445 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
7446 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
7447 K(IC,5)=0
7448 200 CONTINUE
7449 ENDIF
7450 GOTO 140
7451
7452C...Arrange clusters in falling ET sequence.
7453 210 DO 230 I=1,NJ-NC
7454 ETMAX=0.
7455 DO 220 IJ=NC+1,NJ
7456 IF(K(IJ,5).EQ.0) GOTO 220
7457 IF(P(IJ,5).LT.ETMAX) GOTO 220
7458 IJMAX=IJ
7459 ETMAX=P(IJ,5)
7460 220 CONTINUE
7461 K(IJMAX,5)=0
7462 K(N+I,1)=31
7463 K(N+I,2)=98
7464 K(N+I,3)=I
7465 K(N+I,4)=K(IJMAX,4)
7466 K(N+I,5)=0
7467 DO 230 J=1,5
7468 P(N+I,J)=P(IJMAX,J)
7469 230 V(N+I,J)=0.
7470 NJET=NJ-NC
7471
7472C...Convert to massless or massive four-vectors.
7473 IF(MSTU(54).EQ.2) THEN
7474 DO 240 I=N+1,N+NJET
7475 ETA=P(I,3)
7476 P(I,1)=P(I,5)*COS(P(I,4))
7477 P(I,2)=P(I,5)*SIN(P(I,4))
7478 P(I,3)=P(I,5)*SINH(ETA)
7479 P(I,4)=P(I,5)*COSH(ETA)
7480 240 P(I,5)=0.
7481 ELSEIF(MSTU(54).GE.3) THEN
7482 DO 250 I=N+1,N+NJET
7483 250 P(I,5)=SQRT(MAX(0.,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
7484 ENDIF
7485
7486C...Information about storage.
7487 MSTU(61)=N+1
7488 MSTU(62)=NP
7489 MSTU(63)=NC-N
7490 IF(MSTU(43).LE.1) MSTU(3)=NJET
7491 IF(MSTU(43).GE.2) N=N+NJET
7492
7493 RETURN
7494 END
7495
7496C*********************************************************************
7497
7498 SUBROUTINE LUJMAS(PMH,PML)
7499
7500C...Purpose: to determine, approximately, the two jet masses that
7501C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
7502 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7503 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7504 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7505 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7506 DIMENSION SM(3,3),SAX(3),PS(3,5)
7507
7508C...Reset.
7509 NP=0
7510 DO 110 J1=1,3
7511 DO 100 J2=J1,3
7512 100 SM(J1,J2)=0.
7513 DO 110 J2=1,4
7514 110 PS(J1,J2)=0.
7515 PSS=0.
7516
7517C...Take copy of particles that are to be considered in mass analysis.
7518 DO 150 I=1,N
7519 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
7520 IF(MSTU(41).GE.2) THEN
7521 KC=LUCOMP(K(I,2))
7522 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7523 & KC.EQ.18) GOTO 150
7524 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7525 & GOTO 150
7526 ENDIF
7527 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
7528 CALL LUERRM(11,'(LUJMAS:) no more memory left in LUJETS')
7529 PMH=-2.
7530 PML=-2.
7531 RETURN
7532 ENDIF
7533 NP=NP+1
7534 DO 120 J=1,5
7535 120 P(N+NP,J)=P(I,J)
7536 IF(MSTU(42).EQ.0) P(N+NP,5)=0.
7537 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PMAS(101,1)
7538 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
7539
7540C...Fill information in sphericity tensor and total momentum vector.
7541 DO 130 J1=1,3
7542 DO 130 J2=J1,3
7543 130 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
7544 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7545 DO 140 J=1,4
7546 140 PS(3,J)=PS(3,J)+P(N+NP,J)
7547 150 CONTINUE
7548
7549C...Very low multiplicities (0 or 1) not considered.
7550 IF(NP.LE.1) THEN
7551 CALL LUERRM(8,'(LUJMAS:) too few particles for analysis')
7552 PMH=-1.
7553 PML=-1.
7554 RETURN
7555 ENDIF
7556 PARU(61)=SQRT(MAX(0.,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-PS(3,3)**2))
7557
7558C...Find largest eigenvalue to matrix (third degree equation).
7559 DO 160 J1=1,3
7560 DO 160 J2=J1,3
7561 160 SM(J1,J2)=SM(J1,J2)/PSS
7562 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-SM(1,2)**2-
7563 &SM(1,3)**2-SM(2,3)**2)/3.-1./9.
7564 SR=-0.5*(SQ+1./9.+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+SM(3,3)*
7565 &SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+SM(1,2)*SM(1,3)*SM(2,3)+1./27.
7566 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1.),-1.))/3.)
7567 SMA=1./3.+SQRT(-SQ)*MAX(2.*SP,SQRT(3.*(1.-SP**2))-SP)
7568
7569C...Find largest eigenvector by solving equation system.
7570 DO 170 J1=1,3
7571 SM(J1,J1)=SM(J1,J1)-SMA
7572 DO 170 J2=J1+1,3
7573 170 SM(J2,J1)=SM(J1,J2)
7574 SMAX=0.
7575 DO 180 J1=1,3
7576 DO 180 J2=1,3
7577 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 180
7578 JA=J1
7579 JB=J2
7580 SMAX=ABS(SM(J1,J2))
7581 180 CONTINUE
7582 SMAX=0.
7583 DO 190 J3=JA+1,JA+2
7584 J1=J3-3*((J3-1)/3)
7585 RL=SM(J1,JB)/SM(JA,JB)
7586 DO 190 J2=1,3
7587 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
7588 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 190
7589 JC=J1
7590 SMAX=ABS(SM(J1,J2))
7591 190 CONTINUE
7592 JB1=JB+1-3*(JB/3)
7593 JB2=JB+2-3*((JB+1)/3)
7594 SAX(JB1)=-SM(JC,JB2)
7595 SAX(JB2)=SM(JC,JB1)
7596 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
7597
7598C...Divide particles into two initial clusters by hemisphere.
7599 DO 200 I=N+1,N+NP
7600 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
7601 IS=1
7602 IF(PSAX.LT.0.) IS=2
7603 K(I,3)=IS
7604 DO 200 J=1,4
7605 200 PS(IS,J)=PS(IS,J)+P(I,J)
7606 PMS=MAX(1E-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
7607 &MAX(1E-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
7608
7609C...Reassign one particle at a time; find maximum decrease of m^2 sum.
7610 210 PMD=0.
7611 IM=0
7612 DO 220 J=1,4
7613 220 PS(3,J)=PS(1,J)-PS(2,J)
7614 DO 230 I=N+1,N+NP
7615 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)
7616 IF(K(I,3).EQ.1) PMDI=2.*(P(I,5)**2-PPS)
7617 IF(K(I,3).EQ.2) PMDI=2.*(P(I,5)**2+PPS)
7618 IF(PMDI.LT.PMD) THEN
7619 PMD=PMDI
7620 IM=I
7621 ENDIF
7622 230 CONTINUE
7623
7624C...Loop back if significant reduction in sum of m^2.
7625 IF(PMD.LT.-PARU(48)*PMS) THEN
7626 PMS=PMS+PMD
7627 IS=K(IM,3)
7628 DO 240 J=1,4
7629 PS(IS,J)=PS(IS,J)-P(IM,J)
7630 240 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
7631 K(IM,3)=3-IS
7632 GOTO 210
7633 ENDIF
7634
7635C...Final masses and output.
7636 MSTU(61)=N+1
7637 MSTU(62)=NP
7638 PS(1,5)=SQRT(MAX(0.,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
7639 PS(2,5)=SQRT(MAX(0.,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
7640 PMH=MAX(PS(1,5),PS(2,5))
7641 PML=MIN(PS(1,5),PS(2,5))
7642
7643 RETURN
7644 END
7645
7646C*********************************************************************
7647
7648 SUBROUTINE LUFOWO(H10,H20,H30,H40)
7649
7650C...Purpose: to calculate the first few Fox-Wolfram moments.
7651 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7652 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7653 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7654 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
7655
7656C...Copy momenta for particles and calculate H0.
7657 NP=0
7658 H0=0.
7659 HD=0.
7660 DO 110 I=1,N
7661 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
7662 IF(MSTU(41).GE.2) THEN
7663 KC=LUCOMP(K(I,2))
7664 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
7665 & KC.EQ.18) GOTO 110
7666 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
7667 & GOTO 110
7668 ENDIF
7669 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
7670 CALL LUERRM(11,'(LUFOWO:) no more memory left in LUJETS')
7671 H10=-1.
7672 H20=-1.
7673 H30=-1.
7674 H40=-1.
7675 RETURN
7676 ENDIF
7677 NP=NP+1
7678 DO 100 J=1,3
7679 100 P(N+NP,J)=P(I,J)
7680 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
7681 H0=H0+P(N+NP,4)
7682 HD=HD+P(N+NP,4)**2
7683 110 CONTINUE
7684 H0=H0**2
7685
7686C...Very low multiplicities (0 or 1) not considered.
7687 IF(NP.LE.1) THEN
7688 CALL LUERRM(8,'(LUFOWO:) too few particles for analysis')
7689 H10=-1.
7690 H20=-1.
7691 H30=-1.
7692 H40=-1.
7693 RETURN
7694 ENDIF
7695
7696C...Calculate H1 - H4.
7697 H10=0.
7698 H20=0.
7699 H30=0.
7700 H40=0.
7701 DO 120 I1=N+1,N+NP
7702 DO 120 I2=I1+1,N+NP
7703 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
7704 &(P(I1,4)*P(I2,4))
7705 H10=H10+P(I1,4)*P(I2,4)*CTHE
7706 H20=H20+P(I1,4)*P(I2,4)*(1.5*CTHE**2-0.5)
7707 H30=H30+P(I1,4)*P(I2,4)*(2.5*CTHE**3-1.5*CTHE)
7708 H40=H40+P(I1,4)*P(I2,4)*(4.375*CTHE**4-3.75*CTHE**2+0.375)
7709 120 CONTINUE
7710
7711C...Calculate H1/H0 - H4/H0. Output.
7712 MSTU(61)=N+1
7713 MSTU(62)=NP
7714 H10=(HD+2.*H10)/H0
7715 H20=(HD+2.*H20)/H0
7716 H30=(HD+2.*H30)/H0
7717 H40=(HD+2.*H40)/H0
7718
7719 RETURN
7720 END
7721
7722C*********************************************************************
7723
7724 SUBROUTINE LUTABU(MTABU)
7725
7726C...Purpose: to evaluate various properties of an event, with
7727C...statistics accumulated during the course of the run and
7728C...printed at the end.
7729 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
7730 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7731 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
7732 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
7733 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/,/LUDAT3/
7734 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
7735 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
7736 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
7737 &KFDM(8),KFDC(200,0:8),NPDC(200)
7738 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
7739 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
7740 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
7741 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
7742 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
7743 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0./,FM2FM/120*0./,
7744 &NEVEE/0/,FE1EC/50*0./,FE2EC/50*0./,FE1EA/25*0./,FE2EA/25*0./,
7745 &NEVDC/0/,NKFDC/0/,NREDC/0/
7746
7747C...Reset statistics on initial parton state.
7748 IF(MTABU.EQ.10) THEN
7749 NEVIS=0
7750 NKFIS=0
7751
7752C...Identify and order flavour content of initial state.
7753 ELSEIF(MTABU.EQ.11) THEN
7754 NEVIS=NEVIS+1
7755 KFM1=2*IABS(MSTU(161))
7756 IF(MSTU(161).GT.0) KFM1=KFM1-1
7757 KFM2=2*IABS(MSTU(162))
7758 IF(MSTU(162).GT.0) KFM2=KFM2-1
7759 KFMN=MIN(KFM1,KFM2)
7760 KFMX=MAX(KFM1,KFM2)
7761 DO 100 I=1,NKFIS
7762 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
7763 IKFIS=-I
7764 GOTO 110
7765 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
7766 & KFMX.LT.KFIS(I,2))) THEN
7767 IKFIS=I
7768 GOTO 110
7769 ENDIF
7770 100 CONTINUE
7771 IKFIS=NKFIS+1
7772 110 IF(IKFIS.LT.0) THEN
7773 IKFIS=-IKFIS
7774 ELSE
7775 IF(NKFIS.GE.100) RETURN
7776 DO 120 I=NKFIS,IKFIS,-1
7777 KFIS(I+1,1)=KFIS(I,1)
7778 KFIS(I+1,2)=KFIS(I,2)
7779 DO 120 J=0,10
7780 120 NPIS(I+1,J)=NPIS(I,J)
7781 NKFIS=NKFIS+1
7782 KFIS(IKFIS,1)=KFMN
7783 KFIS(IKFIS,2)=KFMX
7784 DO 130 J=0,10
7785 130 NPIS(IKFIS,J)=0
7786 ENDIF
7787 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
7788
7789C...Count number of partons in initial state.
7790 NP=0
7791 DO 150 I=1,N
7792 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
7793 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
7794 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
7795 & THEN
7796 ELSE
7797 IM=I
7798 140 IM=K(IM,3)
7799 IF(IM.LE.0.OR.IM.GT.N) THEN
7800 NP=NP+1
7801 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7802 NP=NP+1
7803 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
7804 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10).NE.0)
7805 & THEN
7806 ELSE
7807 GOTO 140
7808 ENDIF
7809 ENDIF
7810 150 CONTINUE
7811 NPCO=MAX(NP,1)
7812 IF(NP.GE.6) NPCO=6
7813 IF(NP.GE.8) NPCO=7
7814 IF(NP.GE.11) NPCO=8
7815 IF(NP.GE.16) NPCO=9
7816 IF(NP.GE.26) NPCO=10
7817 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
7818 MSTU(62)=NP
7819
7820C...Write statistics on initial parton state.
7821 ELSEIF(MTABU.EQ.12) THEN
7822 FAC=1./MAX(1,NEVIS)
7823 WRITE(MSTU(11),5000) NEVIS
7824 DO 160 I=1,NKFIS
7825 KFMN=KFIS(I,1)
7826 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7827 KFM1=(KFMN+1)/2
7828 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7829 CALL LUNAME(KFM1,CHAU)
7830 CHIS(1)=CHAU(1:12)
7831 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
7832 KFMX=KFIS(I,2)
7833 IF(KFIS(I,1).EQ.0) KFMX=0
7834 KFM2=(KFMX+1)/2
7835 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7836 CALL LUNAME(KFM2,CHAU)
7837 CHIS(2)=CHAU(1:12)
7838 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
7839 160 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
7840 & (NPIS(I,J)/FLOAT(NPIS(I,0)),J=1,10)
7841
7842C...Copy statistics on initial parton state into /LUJETS/.
7843 ELSEIF(MTABU.EQ.13) THEN
7844 FAC=1./MAX(1,NEVIS)
7845 DO 170 I=1,NKFIS
7846 KFMN=KFIS(I,1)
7847 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
7848 KFM1=(KFMN+1)/2
7849 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
7850 KFMX=KFIS(I,2)
7851 IF(KFIS(I,1).EQ.0) KFMX=0
7852 KFM2=(KFMX+1)/2
7853 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
7854 K(I,1)=32
7855 K(I,2)=99
7856 K(I,3)=KFM1
7857 K(I,4)=KFM2
7858 K(I,5)=NPIS(I,0)
7859 DO 170 J=1,5
7860 P(I,J)=FAC*NPIS(I,J)
7861 170 V(I,J)=FAC*NPIS(I,J+5)
7862 N=NKFIS
7863 DO 180 J=1,5
7864 K(N+1,J)=0
7865 P(N+1,J)=0.
7866 180 V(N+1,J)=0.
7867 K(N+1,1)=32
7868 K(N+1,2)=99
7869 K(N+1,5)=NEVIS
7870 MSTU(3)=1
7871
7872C...Reset statistics on number of particles/partons.
7873 ELSEIF(MTABU.EQ.20) THEN
7874 NEVFS=0
7875 NPRFS=0
7876 NFIFS=0
7877 NCHFS=0
7878 NKFFS=0
7879
7880C...Identify whether particle/parton is primary or not.
7881 ELSEIF(MTABU.EQ.21) THEN
7882 NEVFS=NEVFS+1
7883 MSTU(62)=0
7884 DO 230 I=1,N
7885 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 230
7886 MSTU(62)=MSTU(62)+1
7887 KC=LUCOMP(K(I,2))
7888 MPRI=0
7889 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
7890 MPRI=1
7891 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
7892 MPRI=1
7893 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
7894 MPRI=1
7895 ELSEIF(KC.EQ.0) THEN
7896 ELSEIF(K(K(I,3),1).EQ.13) THEN
7897 IM=K(K(I,3),3)
7898 IF(IM.LE.0.OR.IM.GT.N) THEN
7899 MPRI=1
7900 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
7901 MPRI=1
7902 ENDIF
7903 ELSEIF(KCHG(KC,2).EQ.0) THEN
7904 KCM=LUCOMP(K(K(I,3),2))
7905 IF(KCM.NE.0) THEN
7906 IF(KCHG(KCM,2).NE.0) MPRI=1
7907 ENDIF
7908 ENDIF
7909 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
7910 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
7911 ENDIF
7912 IF(K(I,1).LE.10) THEN
7913 NFIFS=NFIFS+1
7914 IF(LUCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
7915 ENDIF
7916
7917C...Fill statistics on number of particles/partons in event.
7918 KFA=IABS(K(I,2))
7919 KFS=3-ISIGN(1,K(I,2))-MPRI
7920 DO 190 IP=1,NKFFS
7921 IF(KFA.EQ.KFFS(IP)) THEN
7922 IKFFS=-IP
7923 GOTO 200
7924 ELSEIF(KFA.LT.KFFS(IP)) THEN
7925 IKFFS=IP
7926 GOTO 200
7927 ENDIF
7928 190 CONTINUE
7929 IKFFS=NKFFS+1
7930 200 IF(IKFFS.LT.0) THEN
7931 IKFFS=-IKFFS
7932 ELSE
7933 IF(NKFFS.GE.400) RETURN
7934 DO 210 IP=NKFFS,IKFFS,-1
7935 KFFS(IP+1)=KFFS(IP)
7936 DO 210 J=1,4
7937 210 NPFS(IP+1,J)=NPFS(IP,J)
7938 NKFFS=NKFFS+1
7939 KFFS(IKFFS)=KFA
7940 DO 220 J=1,4
7941 220 NPFS(IKFFS,J)=0
7942 ENDIF
7943 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
7944 230 CONTINUE
7945
7946C...Write statistics on particle/parton composition of events.
7947 ELSEIF(MTABU.EQ.22) THEN
7948 FAC=1./MAX(1,NEVFS)
7949 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
7950 DO 240 I=1,NKFFS
7951 CALL LUNAME(KFFS(I),CHAU)
7952 KC=LUCOMP(KFFS(I))
7953 MDCYF=0
7954 IF(KC.NE.0) MDCYF=MDCY(KC,1)
7955 240 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
7956 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
7957
7958C...Copy particle/parton composition information into /LUJETS/.
7959 ELSEIF(MTABU.EQ.23) THEN
7960 FAC=1./MAX(1,NEVFS)
7961 DO 260 I=1,NKFFS
7962 K(I,1)=32
7963 K(I,2)=99
7964 K(I,3)=KFFS(I)
7965 K(I,4)=0
7966 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
7967 DO 250 J=1,4
7968 P(I,J)=FAC*NPFS(I,J)
7969 250 V(I,J)=0.
7970 P(I,5)=FAC*K(I,5)
7971 260 V(I,5)=0.
7972 N=NKFFS
7973 DO 270 J=1,5
7974 K(N+1,J)=0
7975 P(N+1,J)=0.
7976 270 V(N+1,J)=0.
7977 K(N+1,1)=32
7978 K(N+1,2)=99
7979 K(N+1,5)=NEVFS
7980 P(N+1,1)=FAC*NPRFS
7981 P(N+1,2)=FAC*NFIFS
7982 P(N+1,3)=FAC*NCHFS
7983 MSTU(3)=1
7984
7985C...Reset factorial moments statistics.
7986 ELSEIF(MTABU.EQ.30) THEN
7987 NEVFM=0
7988 NMUFM=0
7989 DO 280 IM=1,3
7990 DO 280 IB=1,10
7991 DO 280 IP=1,4
7992 FM1FM(IM,IB,IP)=0.
7993 280 FM2FM(IM,IB,IP)=0.
7994
7995C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
7996 ELSEIF(MTABU.EQ.31) THEN
7997 NEVFM=NEVFM+1
7998 NLOW=N+MSTU(3)
7999 NUPP=NLOW
8000 DO 360 I=1,N
8001 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
8002 IF(MSTU(41).GE.2) THEN
8003 KC=LUCOMP(K(I,2))
8004 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8005 & KC.EQ.18) GOTO 360
8006 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
8007 & GOTO 360
8008 ENDIF
8009 PMR=0.
8010 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
8011 IF(MSTU(42).GE.2) PMR=P(I,5)
8012 PR=MAX(1E-20,PMR**2+P(I,1)**2+P(I,2)**2)
8013 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
8014 & 1E20)),P(I,3))
8015 IF(ABS(YETA).GT.PARU(57)) GOTO 360
8016 PHI=ULANGL(P(I,1),P(I,2))
8017 IYETA=512.*(YETA+PARU(57))/(2.*PARU(57))
8018 IYETA=MAX(0,MIN(511,IYETA))
8019 IPHI=512.*(PHI+PARU(1))/PARU(2)
8020 IPHI=MAX(0,MIN(511,IPHI))
8021 IYEP=0
8022 DO 290 IB=0,9
8023 290 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
8024
8025C...Order particles in (pseudo)rapidity and/or azimuth.
8026 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
8027 CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
8028 RETURN
8029 ENDIF
8030 NUPP=NUPP+1
8031 IF(NUPP.EQ.NLOW+1) THEN
8032 K(NUPP,1)=IYETA
8033 K(NUPP,2)=IPHI
8034 K(NUPP,3)=IYEP
8035 ELSE
8036 DO 300 I1=NUPP-1,NLOW+1,-1
8037 IF(IYETA.GE.K(I1,1)) GOTO 310
8038 300 K(I1+1,1)=K(I1,1)
8039 310 K(I1+1,1)=IYETA
8040 DO 320 I1=NUPP-1,NLOW+1,-1
8041 IF(IPHI.GE.K(I1,2)) GOTO 330
8042 320 K(I1+1,2)=K(I1,2)
8043 330 K(I1+1,2)=IPHI
8044 DO 340 I1=NUPP-1,NLOW+1,-1
8045 IF(IYEP.GE.K(I1,3)) GOTO 350
8046 340 K(I1+1,3)=K(I1,3)
8047 350 K(I1+1,3)=IYEP
8048 ENDIF
8049 360 CONTINUE
8050 K(NUPP+1,1)=2**10
8051 K(NUPP+1,2)=2**10
8052 K(NUPP+1,3)=4**10
8053
8054C...Calculate sum of factorial moments in event.
8055 DO 400 IM=1,3
8056 DO 370 IB=1,10
8057 DO 370 IP=1,4
8058 370 FEVFM(IB,IP)=0.
8059 DO 380 IB=1,10
8060 IF(IM.LE.2) IBIN=2**(10-IB)
8061 IF(IM.EQ.3) IBIN=4**(10-IB)
8062 IAGR=K(NLOW+1,IM)/IBIN
8063 NAGR=1
8064 DO 380 I=NLOW+2,NUPP+1
8065 ICUT=K(I,IM)/IBIN
8066 IF(ICUT.EQ.IAGR) THEN
8067 NAGR=NAGR+1
8068 ELSE
8069 IF(NAGR.EQ.1) THEN
8070 ELSEIF(NAGR.EQ.2) THEN
8071 FEVFM(IB,1)=FEVFM(IB,1)+2.
8072 ELSEIF(NAGR.EQ.3) THEN
8073 FEVFM(IB,1)=FEVFM(IB,1)+6.
8074 FEVFM(IB,2)=FEVFM(IB,2)+6.
8075 ELSEIF(NAGR.EQ.4) THEN
8076 FEVFM(IB,1)=FEVFM(IB,1)+12.
8077 FEVFM(IB,2)=FEVFM(IB,2)+24.
8078 FEVFM(IB,3)=FEVFM(IB,3)+24.
8079 ELSE
8080 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1.)
8081 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1.)*(NAGR-2.)
8082 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)
8083 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1.)*(NAGR-2.)*(NAGR-3.)*
8084 & (NAGR-4.)
8085 ENDIF
8086 IAGR=ICUT
8087 NAGR=1
8088 ENDIF
8089 380 CONTINUE
8090
8091C...Add results to total statistics.
8092 DO 390 IB=10,1,-1
8093 DO 390 IP=1,4
8094 IF(FEVFM(1,IP).LT.0.5) THEN
8095 FEVFM(IB,IP)=0.
8096 ELSEIF(IM.LE.2) THEN
8097 FEVFM(IB,IP)=2**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
8098 ELSE
8099 FEVFM(IB,IP)=4**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
8100 ENDIF
8101 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
8102 390 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
8103 400 CONTINUE
8104 NMUFM=NMUFM+(NUPP-NLOW)
8105 MSTU(62)=NUPP-NLOW
8106
8107C...Write accumulated statistics on factorial moments.
8108 ELSEIF(MTABU.EQ.32) THEN
8109 FAC=1./MAX(1,NEVFM)
8110 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
8111 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
8112 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
8113 DO 420 IM=1,3
8114 WRITE(MSTU(11),5500)
8115 DO 420 IB=1,10
8116 BYETA=2.*PARU(57)
8117 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
8118 BPHI=PARU(2)
8119 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
8120 IF(IM.LE.2) BNAVE=FAC*NMUFM/FLOAT(2**(IB-1))
8121 IF(IM.EQ.3) BNAVE=FAC*NMUFM/FLOAT(4**(IB-1))
8122 DO 410 IP=1,4
8123 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
8124 410 FMOMS(IP)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-FMOMA(IP)**2)))
8125 420 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
8126 & IP=1,4)
8127
8128C...Copy statistics on factorial moments into /LUJETS/.
8129 ELSEIF(MTABU.EQ.33) THEN
8130 FAC=1./MAX(1,NEVFM)
8131 DO 430 IM=1,3
8132 DO 430 IB=1,10
8133 I=10*(IM-1)+IB
8134 K(I,1)=32
8135 K(I,2)=99
8136 K(I,3)=1
8137 IF(IM.NE.2) K(I,3)=2**(IB-1)
8138 K(I,4)=1
8139 IF(IM.NE.1) K(I,4)=2**(IB-1)
8140 K(I,5)=0
8141 P(I,1)=2.*PARU(57)/K(I,3)
8142 V(I,1)=PARU(2)/K(I,4)
8143 DO 430 IP=1,4
8144 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
8145 430 V(I,IP+1)=SQRT(MAX(0.,FAC*(FAC*FM2FM(IM,IB,IP)-P(I,IP+1)**2)))
8146 N=30
8147 DO 440 J=1,5
8148 K(N+1,J)=0
8149 P(N+1,J)=0.
8150 440 V(N+1,J)=0.
8151 K(N+1,1)=32
8152 K(N+1,2)=99
8153 K(N+1,5)=NEVFM
8154 MSTU(3)=1
8155
8156C...Reset statistics on Energy-Energy Correlation.
8157 ELSEIF(MTABU.EQ.40) THEN
8158 NEVEE=0
8159 DO 450 J=1,25
8160 FE1EC(J)=0.
8161 FE2EC(J)=0.
8162 FE1EC(51-J)=0.
8163 FE2EC(51-J)=0.
8164 FE1EA(J)=0.
8165 450 FE2EA(J)=0.
8166
8167C...Find particles to include, with proper assumed mass.
8168 ELSEIF(MTABU.EQ.41) THEN
8169 NEVEE=NEVEE+1
8170 NLOW=N+MSTU(3)
8171 NUPP=NLOW
8172 ECM=0.
8173 DO 460 I=1,N
8174 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 460
8175 IF(MSTU(41).GE.2) THEN
8176 KC=LUCOMP(K(I,2))
8177 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
8178 & KC.EQ.18) GOTO 460
8179 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.LUCHGE(K(I,2)).EQ.0)
8180 & GOTO 460
8181 ENDIF
8182 PMR=0.
8183 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=ULMASS(211)
8184 IF(MSTU(42).GE.2) PMR=P(I,5)
8185 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
8186 CALL LUERRM(11,'(LUTABU:) no more memory left in LUJETS')
8187 RETURN
8188 ENDIF
8189 NUPP=NUPP+1
8190 P(NUPP,1)=P(I,1)
8191 P(NUPP,2)=P(I,2)
8192 P(NUPP,3)=P(I,3)
8193 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
8194 P(NUPP,5)=MAX(1E-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
8195 ECM=ECM+P(NUPP,4)
8196 460 CONTINUE
8197 IF(NUPP.EQ.NLOW) RETURN
8198
8199C...Analyze Energy-Energy Correlation in event.
8200 FAC=(2./ECM**2)*50./PARU(1)
8201 DO 470 J=1,50
8202 470 FEVEE(J)=0.
8203 DO 480 I1=NLOW+2,NUPP
8204 DO 480 I2=NLOW+1,I1-1
8205 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
8206 & (P(I1,5)*P(I2,5))
8207 THE=ACOS(MAX(-1.,MIN(1.,CTHE)))
8208 ITHE=MAX(1,MIN(50,1+INT(50.*THE/PARU(1))))
8209 480 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
8210 DO 490 J=1,25
8211 FE1EC(J)=FE1EC(J)+FEVEE(J)
8212 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
8213 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
8214 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
8215 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
8216 490 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
8217 MSTU(62)=NUPP-NLOW
8218
8219C...Write statistics on Energy-Energy Correlation.
8220 ELSEIF(MTABU.EQ.42) THEN
8221 FAC=1./MAX(1,NEVEE)
8222 WRITE(MSTU(11),5700) NEVEE
8223 DO 500 J=1,25
8224 FEEC1=FAC*FE1EC(J)
8225 FEES1=SQRT(MAX(0.,FAC*(FAC*FE2EC(J)-FEEC1**2)))
8226 FEEC2=FAC*FE1EC(51-J)
8227 FEES2=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
8228 FEECA=FAC*FE1EA(J)
8229 FEESA=SQRT(MAX(0.,FAC*(FAC*FE2EA(J)-FEECA**2)))
8230 500 WRITE(MSTU(11),5800) 3.6*(J-1),3.6*J,FEEC1,FEES1,FEEC2,FEES2,
8231 & FEECA,FEESA
8232
8233C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
8234 ELSEIF(MTABU.EQ.43) THEN
8235 FAC=1./MAX(1,NEVEE)
8236 DO 510 I=1,25
8237 K(I,1)=32
8238 K(I,2)=99
8239 K(I,3)=0
8240 K(I,4)=0
8241 K(I,5)=0
8242 P(I,1)=FAC*FE1EC(I)
8243 V(I,1)=SQRT(MAX(0.,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
8244 P(I,2)=FAC*FE1EC(51-I)
8245 V(I,2)=SQRT(MAX(0.,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
8246 P(I,3)=FAC*FE1EA(I)
8247 V(I,3)=SQRT(MAX(0.,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
8248 P(I,4)=PARU(1)*(I-1)/50.
8249 P(I,5)=PARU(1)*I/50.
8250 V(I,4)=3.6*(I-1)
8251 510 V(I,5)=3.6*I
8252 N=25
8253 DO 520 J=1,5
8254 K(N+1,J)=0
8255 P(N+1,J)=0.
8256 520 V(N+1,J)=0.
8257 K(N+1,1)=32
8258 K(N+1,2)=99
8259 K(N+1,5)=NEVEE
8260 MSTU(3)=1
8261
8262C...Reset statistics on decay channels.
8263 ELSEIF(MTABU.EQ.50) THEN
8264 NEVDC=0
8265 NKFDC=0
8266 NREDC=0
8267
8268C...Identify and order flavour content of final state.
8269 ELSEIF(MTABU.EQ.51) THEN
8270 NEVDC=NEVDC+1
8271 NDS=0
8272 DO 550 I=1,N
8273 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 550
8274 NDS=NDS+1
8275 IF(NDS.GT.8) THEN
8276 NREDC=NREDC+1
8277 RETURN
8278 ENDIF
8279 KFM=2*IABS(K(I,2))
8280 IF(K(I,2).LT.0) KFM=KFM-1
8281 DO 530 IDS=NDS-1,1,-1
8282 IIN=IDS+1
8283 IF(KFM.LT.KFDM(IDS)) GOTO 540
8284 530 KFDM(IDS+1)=KFDM(IDS)
8285 IIN=1
8286 540 KFDM(IIN)=KFM
8287 550 CONTINUE
8288
8289C...Find whether old or new final state.
8290 DO 570 IDC=1,NKFDC
8291 IF(NDS.LT.KFDC(IDC,0)) THEN
8292 IKFDC=IDC
8293 GOTO 580
8294 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
8295 DO 560 I=1,NDS
8296 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
8297 IKFDC=IDC
8298 GOTO 580
8299 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
8300 GOTO 570
8301 ENDIF
8302 560 CONTINUE
8303 IKFDC=-IDC
8304 GOTO 580
8305 ENDIF
8306 570 CONTINUE
8307 IKFDC=NKFDC+1
8308 580 IF(IKFDC.LT.0) THEN
8309 IKFDC=-IKFDC
8310 ELSEIF(NKFDC.GE.200) THEN
8311 NREDC=NREDC+1
8312 RETURN
8313 ELSE
8314 DO 590 IDC=NKFDC,IKFDC,-1
8315 NPDC(IDC+1)=NPDC(IDC)
8316 DO 590 I=0,8
8317 590 KFDC(IDC+1,I)=KFDC(IDC,I)
8318 NKFDC=NKFDC+1
8319 KFDC(IKFDC,0)=NDS
8320 DO 600 I=1,NDS
8321 600 KFDC(IKFDC,I)=KFDM(I)
8322 NPDC(IKFDC)=0
8323 ENDIF
8324 NPDC(IKFDC)=NPDC(IKFDC)+1
8325
8326C...Write statistics on decay channels.
8327 ELSEIF(MTABU.EQ.52) THEN
8328 FAC=1./MAX(1,NEVDC)
8329 WRITE(MSTU(11),5900) NEVDC
8330 DO 620 IDC=1,NKFDC
8331 DO 610 I=1,KFDC(IDC,0)
8332 KFM=KFDC(IDC,I)
8333 KF=(KFM+1)/2
8334 IF(2*KF.NE.KFM) KF=-KF
8335 CALL LUNAME(KF,CHAU)
8336 CHDC(I)=CHAU(1:12)
8337 610 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
8338 620 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
8339 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
8340
8341C...Copy statistics on decay channels into /LUJETS/.
8342 ELSEIF(MTABU.EQ.53) THEN
8343 FAC=1./MAX(1,NEVDC)
8344 DO 650 IDC=1,NKFDC
8345 K(IDC,1)=32
8346 K(IDC,2)=99
8347 K(IDC,3)=0
8348 K(IDC,4)=0
8349 K(IDC,5)=KFDC(IDC,0)
8350 DO 630 J=1,5
8351 P(IDC,J)=0.
8352 630 V(IDC,J)=0.
8353 DO 640 I=1,KFDC(IDC,0)
8354 KFM=KFDC(IDC,I)
8355 KF=(KFM+1)/2
8356 IF(2*KF.NE.KFM) KF=-KF
8357 IF(I.LE.5) P(IDC,I)=KF
8358 640 IF(I.GE.6) V(IDC,I-5)=KF
8359 650 V(IDC,5)=FAC*NPDC(IDC)
8360 N=NKFDC
8361 DO 660 J=1,5
8362 K(N+1,J)=0
8363 P(N+1,J)=0.
8364 660 V(N+1,J)=0.
8365 K(N+1,1)=32
8366 K(N+1,2)=99
8367 K(N+1,5)=NEVDC
8368 V(N+1,5)=FAC*NREDC
8369 MSTU(3)=1
8370 ENDIF
8371
8372C...Format statements for output on unit MSTU(11) (default 6).
8373 5000 FORMAT(///20X,'Event statistics - initial state'/
8374 &20X,'based on an analysis of ',I6,' events'//
8375 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
8376 &'according to fragmenting system multiplicity'/
8377 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
8378 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
8379 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
8380 5200 FORMAT(///20X,'Event statistics - final state'/
8381 &20X,'based on an analysis of ',I6,' events'//
8382 &5X,'Mean primary multiplicity =',F8.3/
8383 &5X,'Mean final multiplicity =',F8.3/
8384 &5X,'Mean charged multiplicity =',F8.3//
8385 &5X,'Number of particles produced per event (directly and via ',
8386 &'decays/branchings)'/
8387 &5X,'KF Particle/jet MDCY',8X,'Particles',9X,'Antiparticles',
8388 &5X,'Total'/34X,'prim seco prim seco'/)
8389 5300 FORMAT(1X,I6,4X,A16,I2,5(1X,F9.4))
8390 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
8391 &20X,'based on an analysis of ',I6,' events'//
8392 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
8393 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
8394 5500 FORMAT(10X)
8395 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
8396 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
8397 &20X,'based on an analysis of ',I6,' events'//
8398 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
8399 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
8400 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
8401 5900 FORMAT(///20X,'Decay channel analysis - final state'/
8402 &20X,'based on an analysis of ',I6,' events'//
8403 &2X,'Probability',10X,'Complete final state'/)
8404 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
8405 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
8406 &'or table overflow)')
8407
8408 RETURN
8409 END
8410
8411C*********************************************************************
8412
8413 SUBROUTINE LUEEVT(KFL,ECM)
8414
8415C...Purpose: to handle the generation of an e+e- annihilation jet event.
8416 IMPLICIT DOUBLE PRECISION(D)
8417 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
8418 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8419 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8420 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
8421
8422C...Check input parameters.
8423 IF(MSTU(12).GE.1) CALL LULIST(0)
8424 IF(KFL.LT.0.OR.KFL.GT.8) THEN
8425 CALL LUERRM(16,'(LUEEVT:) called with unknown flavour code')
8426 IF(MSTU(21).GE.1) RETURN
8427 ENDIF
8428 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02*PARF(100+MAX(1,KFL))
8429 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02*PMAS(KFL,1)
8430 IF(ECM.LT.ECMMIN) THEN
8431 CALL LUERRM(16,'(LUEEVT:) called with too small CM energy')
8432 IF(MSTU(21).GE.1) RETURN
8433 ENDIF
8434
8435C...Check consistency of MSTJ options set.
8436 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
8437 CALL LUERRM(6,
8438 & '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
8439 MSTJ(110)=1
8440 ENDIF
8441 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
8442 CALL LUERRM(6,
8443 & '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
8444 MSTJ(111)=0
8445 ENDIF
8446
8447C...Initialize alpha_strong and total cross-section.
8448 MSTU(111)=MSTJ(108)
8449 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
8450 &MSTU(111)=1
8451 PARU(112)=PARJ(121)
8452 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
8453 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
8454 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL LUXTOT(KFL,ECM,
8455 &XTOT)
8456 IF(MSTJ(116).GE.3) MSTJ(116)=1
8457 PARJ(171)=0.
8458
8459C...Add initial e+e- to event record (documentation only).
8460 NTRY=0
8461 100 NTRY=NTRY+1
8462 IF(NTRY.GT.100) THEN
8463 CALL LUERRM(14,'(LUEEVT:) caught in an infinite loop')
8464 RETURN
8465 ENDIF
8466 MSTU(24)=0
8467 NC=0
8468 IF(MSTJ(115).GE.2) THEN
8469 NC=NC+2
8470 CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
8471 K(NC-1,1)=21
8472 CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
8473 K(NC,1)=21
8474 ENDIF
8475
8476C...Radiative photon (in initial state).
8477 MK=0
8478 ECMC=ECM
8479 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL LURADK(ECM,MK,PAK,
8480 &THEK,PHIK,ALPK)
8481 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2.*PAK))
8482 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
8483 NC=NC+1
8484 CALL LU1ENT(NC,22,PAK,THEK,PHIK)
8485 K(NC,3)=MIN(MSTJ(115)/2,1)
8486 ENDIF
8487
8488C...Virtual exchange boson (gamma or Z0).
8489 IF(MSTJ(115).GE.3) THEN
8490 NC=NC+1
8491 KF=22
8492 IF(MSTJ(102).EQ.2) KF=23
8493 MSTU10=MSTU(10)
8494 MSTU(10)=1
8495 P(NC,5)=ECMC
8496 CALL LU1ENT(NC,KF,ECMC,0.,0.)
8497 K(NC,1)=21
8498 K(NC,3)=1
8499 MSTU(10)=MSTU10
8500 ENDIF
8501
8502C...Choice of flavour and jet configuration.
8503 CALL LUXKFL(KFL,ECM,ECMC,KFLC)
8504 IF(KFLC.EQ.0) GOTO 100
8505 CALL LUXJET(ECMC,NJET,CUT)
8506 KFLN=21
8507 IF(NJET.EQ.4) CALL LUX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
8508 &X12,X14)
8509 IF(NJET.EQ.3) CALL LUX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
8510 IF(NJET.EQ.2) MSTJ(120)=1
8511
8512C...Fill jet configuration and origin.
8513 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL LU2ENT(NC+1,KFLC,-KFLC,ECMC)
8514 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL LU2ENT(-(NC+1),KFLC,-KFLC,
8515 &ECMC)
8516 IF(NJET.EQ.3) CALL LU3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
8517 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL LU4ENT(NC+1,KFLC,KFLN,KFLN,
8518 &-KFLC,ECMC,X1,X2,X4,X12,X14)
8519 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL LU4ENT(NC+1,KFLC,-KFLN,KFLN,
8520 &-KFLC,ECMC,X1,X2,X4,X12,X14)
8521 IF(MSTU(24).NE.0) GOTO 100
8522 DO 110 IP=NC+1,N
8523 110 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
8524
8525C...Angular orientation according to matrix element.
8526 IF(MSTJ(106).EQ.1) THEN
8527 CALL LUXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
8528 CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
8529 CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
8530 ENDIF
8531
8532C...Rotation and boost from radiative photon.
8533 IF(MK.EQ.1) THEN
8534 DBEK=-PAK/(ECM-PAK)
8535 NMIN=NC+1-MSTJ(115)/3
8536 CALL LUDBRB(NMIN,N,0.,-PHIK,0D0,0D0,0D0)
8537 CALL LUDBRB(NMIN,N,ALPK,0.,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
8538 CALL LUDBRB(NMIN,N,0.,PHIK,0D0,0D0,0D0)
8539 ENDIF
8540
8541C...Generate parton shower. Rearrange along strings and check.
8542 IF(MSTJ(101).EQ.5) THEN
8543 CALL LUSHOW(N-1,N,ECMC)
8544 MSTJ14=MSTJ(14)
8545 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
8546 IF(MSTJ(105).GE.0) MSTU(28)=0
8547 CALL LUPREP(0)
8548 MSTJ(14)=MSTJ14
8549 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
8550 ENDIF
8551
8552C...Fragmentation/decay generation. Information for LUTABU.
8553 IF(MSTJ(105).EQ.1) CALL LUEXEC
8554 MSTU(161)=KFLC
8555 MSTU(162)=-KFLC
8556
8557 RETURN
8558 END
8559
8560C*********************************************************************
8561
8562 SUBROUTINE LUXTOT(KFL,ECM,XTOT)
8563
8564C...Purpose: to calculate total cross-section, including initial
8565C...state radiation effects.
8566 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8567 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8568 SAVE /LUDAT1/,/LUDAT2/
8569
8570C...Status, (optimized) Q^2 scale, alpha_strong.
8571 PARJ(151)=ECM
8572 MSTJ(119)=10*MSTJ(102)+KFL
8573 IF(MSTJ(111).EQ.0) THEN
8574 Q2R=ECM**2
8575 ELSEIF(MSTU(111).EQ.0) THEN
8576 PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8577 & ((33.-2.*MSTU(112))*PARU(111)))))
8578 Q2R=PARJ(168)*ECM**2
8579 ELSE
8580 PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8581 & (2.*PARU(112)/ECM)**2))
8582 Q2R=PARJ(168)*ECM**2
8583 ENDIF
8584 ALSPI=ULALPS(Q2R)/PARU(1)
8585
8586C...QCD corrections factor in R.
8587 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
8588 RQCD=1.
8589 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
8590 RQCD=1.+ALSPI
8591 ELSEIF(MSTJ(109).EQ.0) THEN
8592 RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8593 IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8594 & LOG(PARJ(168))*ALSPI**2)
8595 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
8596 RQCD=1.+(3./4.)*ALSPI
8597 ELSE
8598 RQCD=1.+(3./4.)*ALSPI-(3./32.+0.519*MSTU(118))*ALSPI**2
8599 ENDIF
8600
8601C...Calculate Z0 width if default value not acceptable.
8602 IF(MSTJ(102).GE.3) THEN
8603 RVA=3.*(3.+(4.*PARU(102)-1.)**2)+6.*RQCD*(2.+(1.-8.*PARU(102)/
8604 & 3.)**2+(4.*PARU(102)/3.-1.)**2)
8605 DO 100 KFLC=5,6
8606 VQ=1.
8607 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*ULMASS(KFLC)/
8608 & ECM)**2))
8609 IF(KFLC.EQ.5) VF=4.*PARU(102)/3.-1.
8610 IF(KFLC.EQ.6) VF=1.-8.*PARU(102)/3.
8611 100 RVA=RVA+3.*RQCD*(0.5*VQ*(3.-VQ**2)*VF**2+VQ**3)
8612 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48.*PARU(102)*(1.-PARU(102)))
8613 ENDIF
8614
8615C...Calculate propagator and related constants for QFD case.
8616 POLL=1.-PARJ(131)*PARJ(132)
8617 IF(MSTJ(102).GE.2) THEN
8618 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8619 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8620 SFI=SFW*(1.-(PARJ(123)/ECM)**2)
8621 VE=4.*PARU(102)-1.
8622 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
8623 SF1W=SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8624 HF1I=SFI*SF1I
8625 HF1W=SFW*SF1W
8626 ENDIF
8627
8628C...Loop over different flavours: charge, velocity.
8629 RTOT=0.
8630 RQQ=0.
8631 RQV=0.
8632 RVA=0.
8633 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
8634 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
8635 MSTJ(93)=1
8636 PMQ=ULMASS(KFLC)
8637 IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 110
8638 QF=KCHG(KFLC,1)/3.
8639 VQ=1.
8640 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1.-(2.*PMQ/ECM)**2)
8641
8642C...Calculate R and sum of charges for QED or QFD case.
8643 RQQ=RQQ+3.*QF**2*POLL
8644 IF(MSTJ(102).LE.1) THEN
8645 RTOT=RTOT+3.*0.5*VQ*(3.-VQ**2)*QF**2*POLL
8646 ELSE
8647 VF=SIGN(1.,QF)-4.*QF*PARU(102)
8648 RQV=RQV-6.*QF*VF*SF1I
8649 RVA=RVA+3.*(VF**2+1.)*SF1W
8650 RTOT=RTOT+3.*(0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+
8651 & VF**2*HF1W)+VQ**3*HF1W)
8652 ENDIF
8653 110 CONTINUE
8654 RSUM=RQQ
8655 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
8656
8657C...Calculate cross-section, including QCD corrections.
8658 PARJ(141)=RQQ
8659 PARJ(142)=RTOT
8660 PARJ(143)=RTOT*RQCD
8661 PARJ(144)=PARJ(143)
8662 PARJ(145)=PARJ(141)*86.8/ECM**2
8663 PARJ(146)=PARJ(142)*86.8/ECM**2
8664 PARJ(147)=PARJ(143)*86.8/ECM**2
8665 PARJ(148)=PARJ(147)
8666 PARJ(157)=RSUM*RQCD
8667 PARJ(158)=0.
8668 PARJ(159)=0.
8669 XTOT=PARJ(147)
8670 IF(MSTJ(107).LE.0) RETURN
8671
8672C...Virtual cross-section.
8673 XKL=PARJ(135)
8674 XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8675 ALE=2.*LOG(ECM/ULMASS(11))-1.
8676 SIGV=ALE/3.+2.*LOG(ECM**2/(ULMASS(13)*ULMASS(15)))/3.-4./3.+
8677 &1.526*LOG(ECM**2/0.932)
8678
8679C...Soft and hard radiative cross-section in QED case.
8680 IF(MSTJ(102).LE.1) THEN
8681 SIGV=1.5*ALE-0.5+PARU(1)**2/3.+2.*SIGV
8682 SIGS=ALE*(2.*LOG(XKL)-LOG(1.-XKL)-XKL)
8683 SIGH=ALE*(2.*LOG(XKU/XKL)-LOG((1.-XKU)/(1.-XKL))-(XKU-XKL))
8684
8685C...Soft and hard radiative cross-section in QFD case.
8686 ELSE
8687 SZM=1.-(PARJ(123)/ECM)**2
8688 SZW=PARJ(123)*PARJ(124)/ECM**2
8689 PARJ(161)=-RQQ/RSUM
8690 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
8691 PARJ(163)=(RQV*(1.-0.5*SZM-SFI)+RVA*(1.5-SZM-SFW))/RSUM
8692 PARJ(164)=(RQV*SZW**2*(1.-2.*SFW)+RVA*(2.*SFI+SZW**2-4.+3.*SZM-
8693 & SZM**2))/(SZW*RSUM)
8694 SIGV=1.5*ALE-0.5+PARU(1)**2/3.+((2.*RQQ+SFI*RQV)/RSUM)*SIGV+
8695 & (SZW*SFW*RQV/RSUM)*PARU(1)*20./9.
8696 SIGS=ALE*(2.*LOG(XKL)+PARJ(161)*LOG(1.-XKL)+PARJ(162)*XKL+
8697 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
8698 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
8699 SIGH=ALE*(2.*LOG(XKU/XKL)+PARJ(161)*LOG((1.-XKU)/(1.-XKL))+
8700 & PARJ(162)*(XKU-XKL)+PARJ(163)*LOG(((XKU-SZM)**2+SZW**2)/
8701 & ((XKL-SZM)**2+SZW**2))+PARJ(164)*(ATAN((XKU-SZM)/SZW)-
8702 & ATAN((XKL-SZM)/SZW)))
8703 ENDIF
8704
8705C...Total cross-section and fraction of hard photon events.
8706 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
8707 PARJ(157)=RSUM*(1.+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
8708 PARJ(144)=PARJ(157)
8709 PARJ(148)=PARJ(144)*86.8/ECM**2
8710 XTOT=PARJ(148)
8711
8712 RETURN
8713 END
8714
8715C*********************************************************************
8716
8717 SUBROUTINE LURADK(ECM,MK,PAK,THEK,PHIK,ALPK)
8718
8719C...Purpose: to generate initial state photon radiation.
8720 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8721 SAVE /LUDAT1/
8722
8723C...Function: cumulative hard photon spectrum in QFD case.
8724 FXK(XX)=2.*LOG(XX)+PARJ(161)*LOG(1.-XX)+PARJ(162)*XX+
8725 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
8726
8727C...Determine whether radiative photon or not.
8728 MK=0
8729 PAK=0.
8730 IF(PARJ(160).LT.RLU(0)) RETURN
8731 MK=1
8732
8733C...Photon energy range. Find photon momentum in QED case.
8734 XKL=PARJ(135)
8735 XKU=MIN(PARJ(136),1.-(2.*PARJ(127)/ECM)**2)
8736 IF(MSTJ(102).LE.1) THEN
8737 100 XK=1./(1.+(1./XKL-1.)*((1./XKU-1.)/(1./XKL-1.))**RLU(0))
8738 IF(1.+(1.-XK)**2.LT.2.*RLU(0)) GOTO 100
8739
8740C...Ditto in QFD case, by numerical inversion of integrated spectrum.
8741 ELSE
8742 SZM=1.-(PARJ(123)/ECM)**2
8743 SZW=PARJ(123)*PARJ(124)/ECM**2
8744 FXKL=FXK(XKL)
8745 FXKU=FXK(XKU)
8746 FXKD=1E-4*(FXKU-FXKL)
8747 FXKR=FXKL+RLU(0)*(FXKU-FXKL)
8748 NXK=0
8749 110 NXK=NXK+1
8750 XK=0.5*(XKL+XKU)
8751 FXKV=FXK(XK)
8752 IF(FXKV.GT.FXKR) THEN
8753 XKU=XK
8754 FXKU=FXKV
8755 ELSE
8756 XKL=XK
8757 FXKL=FXKV
8758 ENDIF
8759 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
8760 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
8761 ENDIF
8762 PAK=0.5*ECM*XK
8763
8764C...Photon polar and azimuthal angle.
8765 PME=2.*(ULMASS(11)/ECM)**2
8766 120 CTHM=PME*(2./PME)**RLU(0)
8767 IF(1.-(XK**2*CTHM*(1.-0.5*CTHM)+2.*(1.-XK)*PME/MAX(PME,
8768 &CTHM*(1.-0.5*CTHM)))/(1.+(1.-XK)**2).LT.RLU(0)) GOTO 120
8769 CTHE=1.-CTHM
8770 IF(RLU(0).GT.0.5) CTHE=-CTHE
8771 STHE=SQRT(MAX(0.,(CTHM-PME)*(2.-CTHM)))
8772 THEK=ULANGL(CTHE,STHE)
8773 PHIK=PARU(2)*RLU(0)
8774
8775C...Rotation angle for hadronic system.
8776 SGN=1.
8777 IF(0.5*(2.-XK*(1.-CTHE))**2/((2.-XK)**2+(XK*CTHE)**2).GT.
8778 &RLU(0)) SGN=-1.
8779 ALPK=ASIN(SGN*STHE*(XK-SGN*(2.*SQRT(1.-XK)-2.+XK)*CTHE)/
8780 &(2.-XK*(1.-SGN*CTHE)))
8781
8782 RETURN
8783 END
8784
8785C*********************************************************************
8786
8787 SUBROUTINE LUXKFL(KFL,ECM,ECMC,KFLC)
8788
8789C...Purpose: to select flavour for produced qqbar pair.
8790 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8791 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
8792 SAVE /LUDAT1/,/LUDAT2/
8793
8794C...Calculate maximum weight in QED or QFD case.
8795 IF(MSTJ(102).LE.1) THEN
8796 RFMAX=4./9.
8797 ELSE
8798 POLL=1.-PARJ(131)*PARJ(132)
8799 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
8800 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
8801 SFI=SFW*(1.-(PARJ(123)/ECMC)**2)
8802 VE=4.*PARU(102)-1.
8803 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
8804 HF1W=SFW*SFF**2*((VE**2+1.)*POLL+2.*VE*(PARJ(132)-PARJ(131)))
8805 RFMAX=MAX(4./9.*POLL-4./3.*(1.-8.*PARU(102)/3.)*HF1I+
8806 & ((1.-8.*PARU(102)/3.)**2+1.)*HF1W,1./9.*POLL+2./3.*
8807 & (-1.+4.*PARU(102)/3.)*HF1I+((-1.+4.*PARU(102)/3.)**2+1.)*HF1W)
8808 ENDIF
8809
8810C...Choose flavour. Gives charge and velocity.
8811 NTRY=0
8812 100 NTRY=NTRY+1
8813 IF(NTRY.GT.100) THEN
8814 CALL LUERRM(14,'(LUXKFL:) caught in an infinite loop')
8815 KFLC=0
8816 RETURN
8817 ENDIF
8818 KFLC=KFL
8819 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*RLU(0))
8820 MSTJ(93)=1
8821 PMQ=ULMASS(KFLC)
8822 IF(ECM.LT.2.*PMQ+PARJ(127)) GOTO 100
8823 QF=KCHG(KFLC,1)/3.
8824 VQ=1.
8825 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0.,1.-(2.*PMQ/ECMC)**2))
8826
8827C...Calculate weight in QED or QFD case.
8828 IF(MSTJ(102).LE.1) THEN
8829 RF=QF**2
8830 RFV=0.5*VQ*(3.-VQ**2)*QF**2
8831 ELSE
8832 VF=SIGN(1.,QF)-4.*QF*PARU(102)
8833 RF=QF**2*POLL-2.*QF*VF*HF1I+(VF**2+1.)*HF1W
8834 RFV=0.5*VQ*(3.-VQ**2)*(QF**2*POLL-2.*QF*VF*HF1I+VF**2*HF1W)+
8835 & VQ**3*HF1W
8836 IF(RFV.GT.0.) PARJ(171)=MIN(1.,VQ**3*HF1W/RFV)
8837 ENDIF
8838
8839C...Weighting or new event (radiative photon). Cross-section update.
8840 IF(KFL.LE.0.AND.RF.LT.RLU(0)*RFMAX) GOTO 100
8841 PARJ(158)=PARJ(158)+1.
8842 IF(ECMC.LT.2.*PMQ+PARJ(127).OR.RFV.LT.RLU(0)*RF) KFLC=0
8843 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
8844 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1.
8845 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
8846 PARJ(148)=PARJ(144)*86.8/ECM**2
8847
8848 RETURN
8849 END
8850
8851C*********************************************************************
8852
8853 SUBROUTINE LUXJET(ECM,NJET,CUT)
8854
8855C...Purpose: to select number of jets in matrix element approach.
8856 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8857 SAVE /LUDAT1/
8858 DIMENSION ZHUT(5)
8859
8860C...Relative three-jet rate in Zhu second order parametrization.
8861 DATA ZHUT/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
8862
8863C...Trivial result for two-jets only, including parton shower.
8864 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
8865 CUT=0.
8866
8867C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
8868 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
8869 CF=4./3.
8870 IF(MSTJ(109).EQ.2) CF=1.
8871 IF(MSTJ(111).EQ.0) THEN
8872 Q2=ECM**2
8873 Q2R=ECM**2
8874 ELSEIF(MSTU(111).EQ.0) THEN
8875 PARJ(169)=MIN(1.,PARJ(129))
8876 Q2=PARJ(169)*ECM**2
8877 PARJ(168)=MIN(1.,MAX(PARJ(128),EXP(-12.*PARU(1)/
8878 & ((33.-2.*MSTU(112))*PARU(111)))))
8879 Q2R=PARJ(168)*ECM**2
8880 ELSE
8881 PARJ(169)=MIN(1.,MAX(PARJ(129),(2.*PARU(112)/ECM)**2))
8882 Q2=PARJ(169)*ECM**2
8883 PARJ(168)=MIN(1.,MAX(PARJ(128),PARU(112)/ECM,
8884 & (2.*PARU(112)/ECM)**2))
8885 Q2R=PARJ(168)*ECM**2
8886 ENDIF
8887
8888C...alpha_strong for R and R itself.
8889 ALSPI=(3./4.)*CF*ULALPS(Q2R)/PARU(1)
8890 IF(IABS(MSTJ(101)).EQ.1) THEN
8891 RQCD=1.+ALSPI
8892 ELSEIF(MSTJ(109).EQ.0) THEN
8893 RQCD=1.+ALSPI+(1.986-0.115*MSTU(118))*ALSPI**2
8894 IF(MSTJ(111).EQ.1) RQCD=MAX(1.,RQCD+(33.-2.*MSTU(112))/12.*
8895 & LOG(PARJ(168))*ALSPI**2)
8896 ELSE
8897 RQCD=1.+ALSPI-(3./32.+0.519*MSTU(118))*(4.*ALSPI/3.)**2
8898 ENDIF
8899
8900C...alpha_strong for jet rate. Initial value for y cut.
8901 ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8902 CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2)
8903 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
8904 & CUT=MAX(CUT,EXP(-SQRT(0.75/ALSPI))/2.)
8905 IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8906
8907C...Parametrization of first order three-jet cross-section.
8908 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25) THEN
8909 PARJ(152)=0.
8910 ELSE
8911 PARJ(152)=(2.*ALSPI/3.)*((3.-6.*CUT+2.*LOG(CUT))*
8912 & LOG(CUT/(1.-2.*CUT))+(2.5+1.5*CUT-6.571)*(1.-3.*CUT)+
8913 & 5.833*(1.-3.*CUT)**2-3.894*(1.-3.*CUT)**3+
8914 & 1.342*(1.-3.*CUT)**4)/RQCD
8915 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
8916 & PARJ(152)=0.
8917 ENDIF
8918
8919C...Parametrization of second order three-jet cross-section.
8920 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
8921 & CUT.GE.0.25) THEN
8922 PARJ(153)=0.
8923 ELSEIF(MSTJ(110).LE.1) THEN
8924 CT=LOG(1./CUT-2.)
8925 PARJ(153)=ALSPI**2*CT**2*(2.419+0.5989*CT+0.6782*CT**2-
8926 & 0.2661*CT**3+0.01159*CT**4)/RQCD
8927
8928C...Interpolation in second/first order ratio for Zhu parametrization.
8929 ELSEIF(MSTJ(110).EQ.2) THEN
8930 IZA=0
8931 DO 110 IY=1,5
8932 110 IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
8933 IF(IZA.NE.0) THEN
8934 ZHURAT=ZHUT(IZA)
8935 ELSE
8936 IZ=100.*CUT
8937 ZHURAT=ZHUT(IZ)+(100.*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
8938 ENDIF
8939 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
8940 ENDIF
8941
8942C...Shift in second order three-jet cross-section with optimized Q^2.
8943 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3.
8944 & AND.CUT.LT.0.25) PARJ(153)=PARJ(153)+(33.-2.*MSTU(112))/12.*
8945 & LOG(PARJ(169))*ALSPI*PARJ(152)
8946
8947C...Parametrization of second order four-jet cross-section.
8948 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125) THEN
8949 PARJ(154)=0.
8950 ELSE
8951 CT=LOG(1./CUT-5.)
8952 IF(CUT.LE.0.018) THEN
8953 XQQGG=6.349-4.330*CT+0.8304*CT**2
8954 IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(3.035-2.091*CT+
8955 & 0.4059*CT**2)
8956 XQQQQ=1.25*(-0.1080+0.01486*CT+0.009364*CT**2)
8957 IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8958 ELSE
8959 XQQGG=-0.09773+0.2959*CT-0.2764*CT**2+0.08832*CT**3
8960 IF(MSTJ(109).EQ.2) XQQGG=(4./3.)**2*(-0.04079+0.1340*CT-
8961 & 0.1326*CT**2+0.04365*CT**3)
8962 XQQQQ=1.25*(0.003661-0.004888*CT-0.001081*CT**2+0.002093*
8963 & CT**3)
8964 IF(MSTJ(109).EQ.2) XQQQQ=8.*XQQQQ
8965 ENDIF
8966 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
8967 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
8968 ENDIF
8969
8970C...If negative three-jet rate, change y' optimization parameter.
8971 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0..AND.
8972 & PARJ(169).LT.0.99) THEN
8973 PARJ(169)=MIN(1.,1.2*PARJ(169))
8974 Q2=PARJ(169)*ECM**2
8975 ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8976 GOTO 100
8977 ENDIF
8978
8979C...If too high cross-section, use harder cuts, or fail.
8980 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
8981 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499.AND.MSTJ(111).EQ.1.AND.
8982 & PARJ(169).LT.0.99) THEN
8983 PARJ(169)=MIN(1.,1.2*PARJ(169))
8984 Q2=PARJ(169)*ECM**2
8985 ALSPI=(3./4.)*CF*ULALPS(Q2)/PARU(1)
8986 GOTO 100
8987 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499) THEN
8988 CALL LUERRM(26,
8989 & '(LUXJET:) no allowed y cut value for Zhu parametrization')
8990 ENDIF
8991 CUT=0.26*(4.*CUT)**(PARJ(152)+PARJ(153)+PARJ(154))**(-1./3.)
8992 IF(MSTJ(110).EQ.2) CUT=MAX(0.01,MIN(0.05,CUT))
8993 GOTO 100
8994 ENDIF
8995
8996C...Scalar gluon (first order only).
8997 ELSE
8998 ALSPI=ULALPS(ECM**2)/PARU(1)
8999 CUT=MAX(0.001,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3./ALSPI))
9000 PARJ(152)=0.
9001 IF(CUT.LT.0.25) PARJ(152)=(ALSPI/3.)*((1.-2.*CUT)*
9002 & LOG((1.-2.*CUT)/CUT)+0.5*(9.*CUT**2-1.))
9003 PARJ(153)=0.
9004 PARJ(154)=0.
9005 ENDIF
9006
9007C...Select number of jets.
9008 PARJ(150)=CUT
9009 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
9010 NJET=2
9011 ELSEIF(MSTJ(101).LE.0) THEN
9012 NJET=MIN(4,2-MSTJ(101))
9013 ELSE
9014 RNJ=RLU(0)
9015 NJET=2
9016 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
9017 IF(PARJ(154).GT.RNJ) NJET=4
9018 ENDIF
9019
9020 RETURN
9021 END
9022
9023C*********************************************************************
9024
9025 SUBROUTINE LUX3JT(NJET,CUT,KFL,ECM,X1,X2)
9026
9027C...Purpose: to select the kinematical variables of three-jet events.
9028 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9029 SAVE /LUDAT1/
9030 DIMENSION ZHUP(5,12)
9031
9032C...Coefficients of Zhu second order parametrization.
9033 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
9034 & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90,
9035 & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537,
9036 & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855,
9037 & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095,
9038 & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806,
9039 & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062,
9040 & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19,
9041 & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439,
9042 & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99,
9043 & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/
9044
9045C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
9046 DILOG(X)=X+X**2/4.+X**3/9.+X**4/16.+X**5/25.+X**6/36.+X**7/49.
9047
9048C...Event type. Mass effect factors and other common constants.
9049 MSTJ(120)=2
9050 MSTJ(121)=0
9051 PMQ=ULMASS(KFL)
9052 QME=(2.*PMQ/ECM)**2
9053 IF(MSTJ(109).NE.1) THEN
9054 CUTL=LOG(CUT)
9055 CUTD=LOG(1./CUT-2.)
9056 IF(MSTJ(109).EQ.0) THEN
9057 CF=4./3.
9058 CN=3.
9059 TR=2.
9060 WTMX=MIN(20.,37.-6.*CUTD)
9061 IF(MSTJ(110).EQ.2) WTMX=2.*(7.5+80.*CUT)
9062 ELSE
9063 CF=1.
9064 CN=0.
9065 TR=12.
9066 WTMX=0.
9067 ENDIF
9068
9069C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
9070 ALS2PI=PARU(118)/PARU(2)
9071 WTOPT=0.
9072 IF(MSTJ(111).EQ.1) WTOPT=(33.-2.*MSTU(112))/6.*LOG(PARJ(169))*
9073 & ALS2PI
9074 WTMAX=MAX(0.,1.+WTOPT+ALS2PI*WTMX)
9075
9076C...Choose three-jet events in allowed region.
9077 100 NJET=3
9078 110 Y13L=CUTL+CUTD*RLU(0)
9079 Y23L=CUTL+CUTD*RLU(0)
9080 Y13=EXP(Y13L)
9081 Y23=EXP(Y23L)
9082 Y12=1.-Y13-Y23
9083 IF(Y12.LE.CUT) GOTO 110
9084 IF(Y13**2+Y23**2+2.*Y12.LE.2.*RLU(0)) GOTO 110
9085
9086C...Second order corrections.
9087 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
9088 Y12L=LOG(Y12)
9089 Y13M=LOG(1.-Y13)
9090 Y23M=LOG(1.-Y23)
9091 Y12M=LOG(1.-Y12)
9092 IF(Y13.LE.0.5) Y13I=DILOG(Y13)
9093 IF(Y13.GE.0.5) Y13I=1.644934-Y13L*Y13M-DILOG(1.-Y13)
9094 IF(Y23.LE.0.5) Y23I=DILOG(Y23)
9095 IF(Y23.GE.0.5) Y23I=1.644934-Y23L*Y23M-DILOG(1.-Y23)
9096 IF(Y12.LE.0.5) Y12I=DILOG(Y12)
9097 IF(Y12.GE.0.5) Y12I=1.644934-Y12L*Y12M-DILOG(1.-Y12)
9098 WT1=(Y13**2+Y23**2+2.*Y12)/(Y13*Y23)
9099 WT2=CF*(-2.*(CUTL-Y12L)**2-3.*CUTL-1.+3.289868+
9100 & 2.*(2.*CUTL-Y12L)*CUT/Y12)+
9101 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-11.*CUTL/6.+
9102 & 67./18.+1.644934-(2.*CUTL-Y12L)*CUT/Y12+(2.*CUTL-Y13L)*
9103 & CUT/Y13+(2.*CUTL-Y23L)*CUT/Y23)+
9104 & TR*(2.*CUTL/3.-10./9.)+
9105 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
9106 & Y13L*(4.*Y12**2+2.*Y12*Y13+4.*Y12*Y23+Y13*Y23)/(Y12+Y23)**2+
9107 & Y23L*(4.*Y12**2+2.*Y12*Y23+4.*Y12*Y13+Y13*Y23)/(Y12+Y13)**2)/
9108 & WT1+
9109 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+
9110 & (CN-2.*CF)*((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
9111 & Y23M+1.644934-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
9112 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934-Y12I-Y13I)/
9113 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
9114 & 2.*Y12L*Y12**2/(Y13+Y23)**2-4.*Y12L*Y12/(Y13+Y23))/WT1-
9115 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934-Y13I-Y23I)
9116 IF(1.+WTOPT+ALS2PI*WT2.LE.0.) MSTJ(121)=1
9117 IF(1.+WTOPT+ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
9118 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1.+WTOPT+ALS2PI*WT2)
9119
9120 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
9121C...Second order corrections; Zhu parametrization of ERT.
9122 ZX=(Y23-Y13)**2
9123 ZY=1.-Y12
9124 IZA=0
9125 DO 120 IY=1,5
9126 120 IF(ABS(CUT-0.01*IY).LT.0.0001) IZA=IY
9127 IF(IZA.NE.0) THEN
9128 IZ=IZA
9129 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
9130 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
9131 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
9132 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
9133 ELSE
9134 IZ=100.*CUT
9135 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
9136 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
9137 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
9138 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
9139 IZ=IZ+1
9140 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
9141 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
9142 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
9143 & ZHUP(IZ,11)/(1.-ZY)+ZHUP(IZ,12)/ZY
9144 WT2=WTL+(WTU-WTL)*(100.*CUT+1.-IZ)
9145 ENDIF
9146 IF(1.+WTOPT+2.*ALS2PI*WT2.LE.0.) MSTJ(121)=1
9147 IF(1.+WTOPT+2.*ALS2PI*WT2.LE.WTMAX*RLU(0)) GOTO 110
9148 PARJ(156)=(WTOPT+2.*ALS2PI*WT2)/(1.+WTOPT+2.*ALS2PI*WT2)
9149 ENDIF
9150
9151C...Impose mass cuts (gives two jets). For fixed jet number new try.
9152 X1=1.-Y23
9153 X2=1.-Y13
9154 X3=1.-Y12
9155 IF(4.*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
9156 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
9157 & 0.5*QME**2+(0.5*QME+0.25*QME**2)*((1.-X2)/(1.-X1)+
9158 & (1.-X1)/(1.-X2)).GT.(X1**2+X2**2)*RLU(0)) NJET=2
9159 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
9160
9161C...Scalar gluon model (first order only, no mass effects).
9162 ELSE
9163 130 NJET=3
9164 140 X3=SQRT(4.*CUT**2+RLU(0)*((1.-CUT)**2-4.*CUT**2))
9165 IF(LOG((X3-CUT)/CUT).LE.RLU(0)*LOG((1.-2.*CUT)/CUT)) GOTO 140
9166 YD=SIGN(2.*CUT*((X3-CUT)/CUT)**RLU(0)-X3,RLU(0)-0.5)
9167 X1=1.-0.5*(X3+YD)
9168 X2=1.-0.5*(X3-YD)
9169 IF(4.*(1.-X1)*(1.-X2)*(1.-X3)/X3**2.LE.QME) NJET=2
9170 IF(MSTJ(102).GE.2) THEN
9171 IF(X3**2-2.*(1.+X3)*(1.-X1)*(1.-X2)*PARJ(171).LT.
9172 & X3**2*RLU(0)) NJET=2
9173 ENDIF
9174 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
9175 ENDIF
9176
9177 RETURN
9178 END
9179
9180C*********************************************************************
9181
9182 SUBROUTINE LUX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
9183
9184C...Purpose: to select the kinematical variables of four-jet events.
9185 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9186 SAVE /LUDAT1/
9187 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
9188
9189C...Common constants. Colour factors for QCD and Abelian gluon theory.
9190 PMQ=ULMASS(KFL)
9191 QME=(2.*PMQ/ECM)**2
9192 CT=LOG(1./CUT-5.)
9193 IF(MSTJ(109).EQ.0) THEN
9194 CF=4./3.
9195 CN=3.
9196 TR=2.5
9197 ELSE
9198 CF=1.
9199 CN=0.
9200 TR=15.
9201 ENDIF
9202
9203C...Choice of process (qqbargg or qqbarqqbar).
9204 100 NJET=4
9205 IT=1
9206 IF(PARJ(155).GT.RLU(0)) IT=2
9207 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
9208 IF(IT.EQ.1) WTMX=0.7/CUT**2
9209 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6/CUT**2
9210 IF(IT.EQ.2) WTMX=0.1125*CF*TR/CUT**2
9211 ID=1
9212
9213C...Sample the five kinematical variables (for qqgg preweighted in y34).
9214 110 Y134=3.*CUT+(1.-6.*CUT)*RLU(0)
9215 Y234=3.*CUT+(1.-6.*CUT)*RLU(0)
9216 IF(IT.EQ.1) Y34=(1.-5.*CUT)*EXP(-CT*RLU(0))
9217 IF(IT.EQ.2) Y34=CUT+(1.-6.*CUT)*RLU(0)
9218 IF(Y34.LE.Y134+Y234-1..OR.Y34.GE.Y134*Y234) GOTO 110
9219 VT=RLU(0)
9220 CP=COS(PARU(1)*RLU(0))
9221 Y14=(Y134-Y34)*VT
9222 Y13=Y134-Y14-Y34
9223 VB=Y34*(1.-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
9224 Y24=0.5*(Y234-Y34)*(1.-4.*SQRT(MAX(0.,VT*(1.-VT)*VB*(1.-VB)))*
9225 &CP-(1.-2.*VT)*(1.-2.*VB))
9226 Y23=Y234-Y34-Y24
9227 Y12=1.-Y134-Y23-Y24
9228 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
9229 Y123=Y12+Y13+Y23
9230 Y124=Y12+Y14+Y24
9231
9232C...Calculate matrix elements for qqgg or qqqq process.
9233 IC=0
9234 WTTOT=0.
9235 120 IC=IC+1
9236 IF(IT.EQ.1) THEN
9237 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3.*Y12*Y23*Y34+
9238 & 3.*Y12*Y14*Y34+4.*Y12**2*Y34-Y13*Y23*Y24+2.*Y12*Y23*Y24-
9239 & Y13*Y14*Y24-2.*Y12*Y13*Y24+2.*Y12**2*Y24+Y14*Y23**2+2.*Y12*
9240 & Y23**2+Y14**2*Y23+4.*Y12*Y14*Y23+4.*Y12**2*Y23+2.*Y12*Y14**2+
9241 & 2.*Y12*Y13*Y14+4.*Y12**2*Y14+2.*Y12**2*Y13+2.*Y12**3)/(2.*Y13*
9242 & Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-Y14*Y23+Y12*Y13)/(Y13*
9243 & Y134**2)+2.*Y23*(1.-Y13)/(Y13*Y134*Y24)+Y34/(2.*Y13*Y24)
9244 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2.*Y12*
9245 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1.+Y34)*Y124/(Y134*Y234*Y14*
9246 & Y24)-(2.*Y13*Y24+Y14**2+Y13*Y23+2.*Y12*Y13)/(Y13*Y134*Y14)+
9247 & Y12*Y123*Y124/(2.*Y13*Y14*Y23*Y24)
9248 WTC(IC)=-(5.*Y12*Y34**2+2.*Y12*Y24*Y34+2.*Y12*Y23*Y34+2.*Y12*
9249 & Y14*Y34+2.*Y12*Y13*Y34+4.*Y12**2*Y34-Y13*Y24**2+Y14*Y23*Y24+
9250 & Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-3.*Y12*Y13*Y24-
9251 & Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-3.*Y12*Y14*Y23-Y12*Y13*Y23)/
9252 & (4.*Y134*Y234*Y34**2)+(3.*Y12*Y34**2-3.*Y13*Y24*Y34+3.*Y12*Y24*
9253 & Y34+3.*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6.*Y12*Y14*Y34+2.*Y12*
9254 & Y13*Y34-2.*Y12**2*Y34+Y14*Y23*Y24-3.*Y13*Y23*Y24-2.*Y13*Y14*
9255 & Y24+4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+3.*Y14*Y23**2+2.*Y14**2*Y23+
9256 & 2.*Y14**2*Y12+2.*Y12**2*Y14+6.*Y12*Y14*Y23-2.*Y12*Y13**2-
9257 & 2.*Y12**2*Y13)/(4.*Y13*Y134*Y234*Y34)
9258 WTC(IC)=WTC(IC)+(2.*Y12*Y34**2-2.*Y13*Y24*Y34+Y12*Y24*Y34+
9259 & 4.*Y13*Y23*Y34+4.*Y12*Y14*Y34+2.*Y12*Y13*Y34+2.*Y12**2*Y34-
9260 & Y13*Y24**2+3.*Y14*Y23*Y24+4.*Y13*Y23*Y24-2.*Y13*Y14*Y24+
9261 & 4.*Y12*Y14*Y24+2.*Y12*Y13*Y24+2.*Y14*Y23**2+4.*Y13*Y23**2+
9262 & 2.*Y13*Y14*Y23+2.*Y12*Y14*Y23+4.*Y12*Y13*Y23+2.*Y12*Y14**2+4.*
9263 & Y12**2*Y13+4.*Y12*Y13*Y14+2.*Y12**2*Y14)/(4.*Y13*Y134*Y24*Y34)-
9264 & (Y12*Y34**2-2.*Y14*Y24*Y34-2.*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*
9265 & Y34+Y12*Y14*Y34+2.*Y12*Y13*Y34-2.*Y14**2*Y24-4.*Y13*Y14*Y24-
9266 & 4.*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-Y12*Y13**2)/
9267 & (2.*Y13*Y34*Y134**2)+(Y12*Y34**2-4.*Y14*Y24*Y34-2.*Y13*Y24*Y34-
9268 & 2.*Y14*Y23*Y34-4.*Y13*Y23*Y34-4.*Y12*Y14*Y34-4.*Y12*Y13*Y34-
9269 & 2.*Y13*Y14*Y24+2.*Y13**2*Y24+2.*Y14**2*Y23-2.*Y13*Y14*Y23-
9270 & Y12*Y14**2-6.*Y12*Y13*Y14-Y12*Y13**2)/(4.*Y34**2*Y134**2)
9271 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5*CN)*WTB(IC)+CN*WTC(IC))/
9272 & 8.
9273 ELSE
9274 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2.*Y12*
9275 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
9276 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
9277 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
9278 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
9279 & Y13*Y14*Y24+2.*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
9280 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
9281 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
9282 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
9283 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
9284 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
9285 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
9286 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
9287 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
9288 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
9289 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
9290 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
9291 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5*CN)*WTE(IC))/16.
9292 ENDIF
9293
9294C...Permutations of momenta in matrix element. Weighting.
9295 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
9296 YSAV=Y13
9297 Y13=Y14
9298 Y14=YSAV
9299 YSAV=Y23
9300 Y23=Y24
9301 Y24=YSAV
9302 YSAV=Y123
9303 Y123=Y124
9304 Y124=YSAV
9305 ENDIF
9306 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
9307 YSAV=Y13
9308 Y13=Y23
9309 Y23=YSAV
9310 YSAV=Y14
9311 Y14=Y24
9312 Y24=YSAV
9313 YSAV=Y134
9314 Y134=Y234
9315 Y234=YSAV
9316 ENDIF
9317 IF(IC.LE.3) GOTO 120
9318 IF(ID.EQ.1.AND.WTTOT.LT.RLU(0)*WTMX) GOTO 110
9319 IC=5
9320
9321C...qqgg events: string configuration and event type.
9322 IF(IT.EQ.1) THEN
9323 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
9324 PARJ(156)=Y34*(2.*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4.*(WTC(1)+
9325 & WTC(2)+WTC(3)+WTC(4)))/(9.*WTTOT)
9326 IF(WTA(2)+WTA(4)+2.*(WTC(2)+WTC(4)).GT.RLU(0)*(WTA(1)+WTA(2)+
9327 & WTA(3)+WTA(4)+2.*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
9328 IF(ID.EQ.2) GOTO 130
9329 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
9330 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8.*WTTOT)
9331 IF(WTA(2)+WTA(4).GT.RLU(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
9332 IF(ID.EQ.2) GOTO 130
9333 ENDIF
9334 MSTJ(120)=3
9335 IF(MSTJ(109).EQ.0.AND.0.5*Y34*(WTC(1)+WTC(2)+WTC(3)+WTC(4)).GT.
9336 & RLU(0)*WTTOT) MSTJ(120)=4
9337 KFLN=21
9338
9339C...Mass cuts. Kinematical variables out.
9340 IF(Y12.LE.CUT+QME) NJET=2
9341 IF(NJET.EQ.2) GOTO 150
9342 Q12=0.5*(1.-SQRT(1.-QME/Y12))
9343 X1=1.-(1.-Q12)*Y234-Q12*Y134
9344 X4=1.-(1.-Q12)*Y134-Q12*Y234
9345 X2=1.-Y124
9346 X12=(1.-Q12)*Y13+Q12*Y23
9347 X14=Y12-0.5*QME
9348 IF(Y134*Y234/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
9349
9350C...qqbarqqbar events: string configuration, choose new flavour.
9351 ELSE
9352 IF(ID.EQ.1) THEN
9353 WTR=RLU(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
9354 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
9355 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
9356 IF(WTR.LT.WTD(4)) ID=4
9357 IF(ID.GE.2) GOTO 130
9358 ENDIF
9359 MSTJ(120)=5
9360 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16.*WTTOT)
9361 140 KFLN=1+INT(5.*RLU(0))
9362 IF(KFLN.NE.KFL.AND.0.2*PARJ(156).LE.RLU(0)) GOTO 140
9363 IF(KFLN.EQ.KFL.AND.1.-0.8*PARJ(156).LE.RLU(0)) GOTO 140
9364 IF(KFLN.GT.MSTJ(104)) NJET=2
9365 PMQN=ULMASS(KFLN)
9366 QMEN=(2.*PMQN/ECM)**2
9367
9368C...Mass cuts. Kinematical variables out.
9369 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1*QMEN) NJET=2
9370 IF(NJET.EQ.2) GOTO 150
9371 Q24=0.5*(1.-SQRT(1.-QME/Y24))
9372 Q13=0.5*(1.-SQRT(1.-QMEN/Y13))
9373 X1=1.-(1.-Q24)*Y123-Q24*Y134
9374 X4=1.-(1.-Q24)*Y134-Q24*Y123
9375 X2=1.-(1.-Q13)*Y234-Q13*Y124
9376 X12=(1.-Q24)*((1.-Q13)*Y14+Q13*Y34)+Q24*((1.-Q13)*Y12+Q13*Y23)
9377 X14=Y24-0.5*QME
9378 X34=(1.-Q24)*((1.-Q13)*Y23+Q13*Y12)+Q24*((1.-Q13)*Y34+Q13*Y14)
9379 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
9380 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
9381 IF(Y123*Y134/((1.-X1)*(1.-X4)).LE.RLU(0)) NJET=2
9382 ENDIF
9383 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
9384
9385 RETURN
9386 END
9387
9388C*********************************************************************
9389
9390 SUBROUTINE LUXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
9391
9392C...Purpose: to give the angular orientation of events.
9393 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9394 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9395 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9396 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
9397
9398C...Charge. Factors depending on polarization for QED case.
9399 QF=KCHG(KFL,1)/3.
9400 POLL=1.-PARJ(131)*PARJ(132)
9401 POLD=PARJ(132)-PARJ(131)
9402 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
9403 HF1=POLL
9404 HF2=0.
9405 HF3=PARJ(133)**2
9406 HF4=0.
9407
9408C...Factors depending on flavour, energy and polarization for QFD case.
9409 ELSE
9410 SFF=1./(16.*PARU(102)*(1.-PARU(102)))
9411 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
9412 SFI=SFW*(1.-(PARJ(123)/ECM)**2)
9413 AE=-1.
9414 VE=4.*PARU(102)-1.
9415 AF=SIGN(1.,QF)
9416 VF=AF-4.*QF*PARU(102)
9417 HF1=QF**2*POLL-2.*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
9418 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2.*VE*AE*POLD)
9419 HF2=-2.*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2.*VF*AF*SFW*SFF**2*
9420 & (2.*VE*AE*POLL-(VE**2+AE**2)*POLD)
9421 HF3=PARJ(133)**2*(QF**2-2.*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
9422 & SFW*SFF**2*(VE**2-AE**2))
9423 HF4=-PARJ(133)**2*2.*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
9424 & SFF*AE
9425 ENDIF
9426
9427C...Mass factor. Differential cross-sections for two-jet events.
9428 SQ2=SQRT(2.)
9429 QME=0.
9430 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
9431 &MSTJ(109).NE.1) QME=(2.*ULMASS(KFL)/ECM)**2
9432 IF(NJET.EQ.2) THEN
9433 SIGU=4.*SQRT(1.-QME)
9434 SIGL=2.*QME*SQRT(1.-QME)
9435 SIGT=0.
9436 SIGI=0.
9437 SIGA=0.
9438 SIGP=4.
9439
9440C...Kinematical variables. Reduce four-jet event to three-jet one.
9441 ELSE
9442 IF(NJET.EQ.3) THEN
9443 X1=2.*P(NC+1,4)/ECM
9444 X2=2.*P(NC+3,4)/ECM
9445 ELSE
9446 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
9447 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
9448 X1=2.*P(NC+1,4)/ECMR
9449 X2=2.*P(NC+4,4)/ECMR
9450 ENDIF
9451
9452C...Differential cross-sections for three-jet (or reduced four-jet).
9453 XQ=(1.-X1)/(1.-X2)
9454 CT12=(X1*X2-2.*X1-2.*X2+2.+QME)/SQRT((X1**2-QME)*(X2**2-QME))
9455 ST12=SQRT(1.-CT12**2)
9456 IF(MSTJ(109).NE.1) THEN
9457 SIGU=2.*X1**2+X2**2*(1.+CT12**2)-QME*(3.+CT12**2-X1-X2)-
9458 & QME*X1/XQ+0.5*QME*((X2**2-QME)*ST12**2-2.*X2)*XQ
9459 SIGL=(X2*ST12)**2-QME*(3.-CT12**2-2.5*(X1+X2)+X1*X2+QME)+
9460 & 0.5*QME*(X1**2-X1-QME)/XQ+0.5*QME*((X2**2-QME)*CT12**2-X2)*XQ
9461 SIGT=0.5*(X2**2-QME-0.5*QME*(X2**2-QME)/XQ)*ST12**2
9462 SIGI=((1.-0.5*QME*XQ)*(X2**2-QME)*ST12*CT12+QME*(1.-X1-X2+
9463 & 0.5*X1*X2+0.5*QME)*ST12/CT12)/SQ2
9464 SIGA=X2**2*ST12/SQ2
9465 SIGP=2.*(X1**2-X2**2*CT12)
9466
9467C...Differential cross-sect for scalar gluons (no mass or QFD effects).
9468 ELSE
9469 SIGU=2.*(2.-X1-X2)**2-(X2*ST12)**2
9470 SIGL=(X2*ST12)**2
9471 SIGT=0.5*SIGL
9472 SIGI=-(2.-X1-X2)*X2*ST12/SQ2
9473 SIGA=0.
9474 SIGP=0.
9475 ENDIF
9476 ENDIF
9477
9478C...Upper bounds for differential cross-section.
9479 HF1A=ABS(HF1)
9480 HF2A=ABS(HF2)
9481 HF3A=ABS(HF3)
9482 HF4A=ABS(HF4)
9483 SIGMAX=(2.*HF1A+HF3A+HF4A)*ABS(SIGU)+2.*(HF1A+HF3A+HF4A)*
9484 &ABS(SIGL)+2.*(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGT)+2.*SQ2*
9485 &(HF1A+2.*HF3A+2.*HF4A)*ABS(SIGI)+4.*SQ2*HF2A*ABS(SIGA)+
9486 &2.*HF2A*ABS(SIGP)
9487
9488C...Generate angular orientation according to differential cross-sect.
9489 100 CHI=PARU(2)*RLU(0)
9490 CTHE=2.*RLU(0)-1.
9491 PHI=PARU(2)*RLU(0)
9492 CCHI=COS(CHI)
9493 SCHI=SIN(CHI)
9494 C2CHI=COS(2.*CHI)
9495 S2CHI=SIN(2.*CHI)
9496 THE=ACOS(CTHE)
9497 STHE=SIN(THE)
9498 C2PHI=COS(2.*(PHI-PARJ(134)))
9499 S2PHI=SIN(2.*(PHI-PARJ(134)))
9500 SIG=((1.+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
9501 &2.*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
9502 &2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*C2CHI*C2PHI-2.*CTHE*S2CHI*
9503 &S2PHI)*HF3-((1.+CTHE**2)*C2CHI*S2PHI+2.*CTHE*S2CHI*C2PHI)*HF4)*
9504 &SIGT-2.*SQ2*(2.*STHE*CTHE*CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-
9505 &SCHI*S2PHI)*HF3+2.*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
9506 &4.*SQ2*STHE*CCHI*HF2*SIGA+2.*CTHE*HF2*SIGP
9507 IF(SIG.LT.SIGMAX*RLU(0)) GOTO 100
9508
9509 RETURN
9510 END
9511
9512C*********************************************************************
9513
9514 SUBROUTINE LUONIA(KFL,ECM)
9515
9516C...Purpose: to generate Upsilon and toponium decays into three
9517C...gluons or two gluons and a photon.
9518 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9519 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9520 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9521 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
9522
9523C...Printout. Check input parameters.
9524 IF(MSTU(12).GE.1) CALL LULIST(0)
9525 IF(KFL.LT.0.OR.KFL.GT.8) THEN
9526 CALL LUERRM(16,'(LUONIA:) called with unknown flavour code')
9527 IF(MSTU(21).GE.1) RETURN
9528 ENDIF
9529 IF(ECM.LT.PARJ(127)+2.02*PARF(101)) THEN
9530 CALL LUERRM(16,'(LUONIA:) called with too small CM energy')
9531 IF(MSTU(21).GE.1) RETURN
9532 ENDIF
9533
9534C...Initial e+e- and onium state (optional).
9535 NC=0
9536 IF(MSTJ(115).GE.2) THEN
9537 NC=NC+2
9538 CALL LU1ENT(NC-1,11,0.5*ECM,0.,0.)
9539 K(NC-1,1)=21
9540 CALL LU1ENT(NC,-11,0.5*ECM,PARU(1),0.)
9541 K(NC,1)=21
9542 ENDIF
9543 KFLC=IABS(KFL)
9544 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
9545 NC=NC+1
9546 KF=110*KFLC+3
9547 MSTU10=MSTU(10)
9548 MSTU(10)=1
9549 P(NC,5)=ECM
9550 CALL LU1ENT(NC,KF,ECM,0.,0.)
9551 K(NC,1)=21
9552 K(NC,3)=1
9553 MSTU(10)=MSTU10
9554 ENDIF
9555
9556C...Choose x1 and x2 according to matrix element.
9557 NTRY=0
9558 100 X1=RLU(0)
9559 X2=RLU(0)
9560 X3=2.-X1-X2
9561 IF(X3.GE.1..OR.((1.-X1)/(X2*X3))**2+((1.-X2)/(X1*X3))**2+
9562 &((1.-X3)/(X1*X2))**2.LE.2.*RLU(0)) GOTO 100
9563 NTRY=NTRY+1
9564 NJET=3
9565 IF(MSTJ(101).LE.4) CALL LU3ENT(NC+1,21,21,21,ECM,X1,X3)
9566 IF(MSTJ(101).GE.5) CALL LU3ENT(-(NC+1),21,21,21,ECM,X1,X3)
9567
9568C...Photon-gluon-gluon events. Small system modifications. Jet origin.
9569 MSTU(111)=MSTJ(108)
9570 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9571 &MSTU(111)=1
9572 PARU(112)=PARJ(121)
9573 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9574 QF=0.
9575 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3.
9576 RGAM=7.2*QF**2*PARU(101)/ULALPS(ECM**2)
9577 MK=0
9578 ECMC=ECM
9579 IF(RLU(0).GT.RGAM/(1.+RGAM)) THEN
9580 IF(1.-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
9581 & NJET=2
9582 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL LU2ENT(NC+1,21,21,ECM)
9583 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL LU2ENT(-(NC+1),21,21,ECM)
9584 ELSE
9585 MK=1
9586 ECMC=SQRT(1.-X1)*ECM
9587 IF(ECMC.LT.2.*PARJ(127)) GOTO 100
9588 K(NC+1,1)=1
9589 K(NC+1,2)=22
9590 K(NC+1,4)=0
9591 K(NC+1,5)=0
9592 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
9593 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
9594 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
9595 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
9596 NJET=2
9597 IF(ECMC.LT.4.*PARJ(127)) THEN
9598 MSTU10=MSTU(10)
9599 MSTU(10)=1
9600 P(NC+2,5)=ECMC
9601 CALL LU1ENT(NC+2,83,0.5*(X2+X3)*ECM,PARU(1),0.)
9602 MSTU(10)=MSTU10
9603 NJET=0
9604 ENDIF
9605 ENDIF
9606 DO 110 IP=NC+1,N
9607 110 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
9608
9609C...Differential cross-sections. Upper limit for cross-section.
9610 IF(MSTJ(106).EQ.1) THEN
9611 SQ2=SQRT(2.)
9612 HF1=1.-PARJ(131)*PARJ(132)
9613 HF3=PARJ(133)**2
9614 CT13=(X1*X3-2.*X1-2.*X3+2.)/(X1*X3)
9615 ST13=SQRT(1.-CT13**2)
9616 SIGL=0.5*X3**2*((1.-X2)**2+(1.-X3)**2)*ST13**2
9617 SIGU=(X1*(1.-X1))**2+(X2*(1.-X2))**2+(X3*(1.-X3))**2-SIGL
9618 SIGT=0.5*SIGL
9619 SIGI=(SIGL*CT13/ST13+0.5*X1*X3*(1.-X2)**2*ST13)/SQ2
9620 SIGMAX=(2.*HF1+HF3)*ABS(SIGU)+2.*(HF1+HF3)*ABS(SIGL)+2.*(HF1+
9621 & 2.*HF3)*ABS(SIGT)+2.*SQ2*(HF1+2.*HF3)*ABS(SIGI)
9622
9623C...Angular orientation of event.
9624 120 CHI=PARU(2)*RLU(0)
9625 CTHE=2.*RLU(0)-1.
9626 PHI=PARU(2)*RLU(0)
9627 CCHI=COS(CHI)
9628 SCHI=SIN(CHI)
9629 C2CHI=COS(2.*CHI)
9630 S2CHI=SIN(2.*CHI)
9631 THE=ACOS(CTHE)
9632 STHE=SIN(THE)
9633 C2PHI=COS(2.*(PHI-PARJ(134)))
9634 S2PHI=SIN(2.*(PHI-PARJ(134)))
9635 SIG=((1.+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2.*(STHE**2*HF1-
9636 & STHE**2*C2PHI*HF3)*SIGL+2.*(STHE**2*C2CHI*HF1+((1.+CTHE**2)*
9637 & C2CHI*C2PHI-2.*CTHE*S2CHI*S2PHI)*HF3)*SIGT-2.*SQ2*(2.*STHE*CTHE*
9638 & CCHI*HF1-2.*STHE*(CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
9639 IF(SIG.LT.SIGMAX*RLU(0)) GOTO 120
9640 CALL LUDBRB(NC+1,N,0.,CHI,0D0,0D0,0D0)
9641 CALL LUDBRB(NC+1,N,THE,PHI,0D0,0D0,0D0)
9642 ENDIF
9643
9644C...Generate parton shower. Rearrange along strings and check.
9645 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
9646 CALL LUSHOW(NC+MK+1,-NJET,ECMC)
9647 MSTJ14=MSTJ(14)
9648 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
9649 IF(MSTJ(105).GE.0) MSTU(28)=0
9650 CALL LUPREP(0)
9651 MSTJ(14)=MSTJ14
9652 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
9653 ENDIF
9654
9655C...Generate fragmentation. Information for LUTABU:
9656 IF(MSTJ(105).EQ.1) CALL LUEXEC
9657 MSTU(161)=110*KFLC+3
9658 MSTU(162)=0
9659
9660 RETURN
9661 END
9662
9663C*********************************************************************
9664
9665 SUBROUTINE LUHEPC(MCONV)
9666
9667C...Purpose: to convert JETSET event record contents to or from
9668C...the standard event record commonblock.
9669 PARAMETER (NMXHEP=2000)
9670 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
9671 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
9672 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9673 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9674 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
9675 SAVE /HEPEVT/
9676 SAVE /LUJETS/,/LUDAT1/,/LUDAT2/
9677
9678C...Conversion from JETSET to standard, the easy part.
9679 IF(MCONV.EQ.1) THEN
9680 NEVHEP=0
9681 IF(N.GT.NMXHEP) CALL LUERRM(8,
9682 & '(LUHEPC:) no more space in /HEPEVT/')
9683 NHEP=MIN(N,NMXHEP)
9684 DO 140 I=1,NHEP
9685 ISTHEP(I)=0
9686 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
9687 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
9688 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
9689 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
9690 IDHEP(I)=K(I,2)
9691 JMOHEP(1,I)=K(I,3)
9692 JMOHEP(2,I)=0
9693 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
9694 JDAHEP(1,I)=K(I,4)
9695 JDAHEP(2,I)=K(I,5)
9696 ELSE
9697 JDAHEP(1,I)=0
9698 JDAHEP(2,I)=0
9699 ENDIF
9700 DO 100 J=1,5
9701 100 PHEP(J,I)=P(I,J)
9702 DO 110 J=1,4
9703 110 VHEP(J,I)=V(I,J)
9704
9705C...Fill in missing mother information.
9706 IF(I.GE.3.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
9707 IMO1=I-2
9708 IF(I.GE.4.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0) IMO1=IMO1-1
9709 JMOHEP(1,I)=IMO1
9710 JMOHEP(2,I)=IMO1+1
9711 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
9712 I1=K(I,3)-1
9713 120 I1=I1+1
9714 IF(I1.GE.I) CALL LUERRM(8,
9715 & '(LUHEPC:) translation of inconsistent event history')
9716 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
9717 KC=LUCOMP(K(I1,2))
9718 IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
9719 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
9720 JMOHEP(2,I)=I1
9721 ELSEIF(K(I,2).EQ.94) THEN
9722 NJET=2
9723 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
9724 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
9725 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
9726 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
9727 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
9728 ENDIF
9729
9730C...Fill in missing daughter information.
9731 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
9732 DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
9733 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
9734 130 JDAHEP(1,I2)=I
9735 ENDIF
9736 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
9737 I1=JMOHEP(1,I)
9738 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
9739 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
9740 IF(JDAHEP(1,I1).EQ.0) THEN
9741 JDAHEP(1,I1)=I
9742 ELSE
9743 JDAHEP(2,I1)=I
9744 ENDIF
9745 140 CONTINUE
9746 DO 150 I=1,NHEP
9747 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
9748 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
9749 150 CONTINUE
9750
9751C...Conversion from standard to JETSET, the easy part.
9752 ELSE
9753 IF(NHEP.GT.MSTU(4)) CALL LUERRM(8,
9754 & '(LUHEPC:) no more space in /LUJETS/')
9755 N=MIN(NHEP,MSTU(4))
9756 NKQ=0
9757 KQSUM=0
9758 DO 180 I=1,N
9759 K(I,1)=0
9760 IF(ISTHEP(I).EQ.1) K(I,1)=1
9761 IF(ISTHEP(I).EQ.2) K(I,1)=11
9762 IF(ISTHEP(I).EQ.3) K(I,1)=21
9763 K(I,2)=IDHEP(I)
9764 K(I,3)=JMOHEP(1,I)
9765 K(I,4)=JDAHEP(1,I)
9766 K(I,5)=JDAHEP(2,I)
9767 DO 160 J=1,5
9768 160 P(I,J)=PHEP(J,I)
9769 DO 170 J=1,4
9770 170 V(I,J)=VHEP(J,I)
9771 V(I,5)=0.
9772 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
9773 I1=JDAHEP(1,I)
9774 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
9775 & PHEP(5,I)/PHEP(4,I)
9776 ENDIF
9777
9778C...Fill in missing information on colour connection in jet systems.
9779 IF(ISTHEP(I).EQ.1) THEN
9780 KC=LUCOMP(K(I,2))
9781 KQ=0
9782 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
9783 IF(KQ.NE.0) NKQ=NKQ+1
9784 IF(KQ.NE.2) KQSUM=KQSUM+KQ
9785 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
9786 K(I,1)=2
9787 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
9788 IF(K(I+1,2).EQ.21) K(I,1)=2
9789 ENDIF
9790 ENDIF
9791 180 CONTINUE
9792 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL LUERRM(8,
9793 & '(LUHEPC:) input parton configuration not colour singlet')
9794 ENDIF
9795
9796 END
9797
9798C*********************************************************************
9799
9800 SUBROUTINE LUTEST(MTEST)
9801
9802C...Purpose: to provide a simple program (disguised as subroutine) to
9803C...run at installation as a check that the program works as intended.
9804 COMMON/LUJETS/N,K(150000,5),P(150000,5),V(150000,5)
9805 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9806 SAVE /LUJETS/,/LUDAT1/
9807 DIMENSION PSUM(5),PINI(6),PFIN(6)
9808
9809C...Loop over events to be generated.
9810 IF(MTEST.GE.1) CALL LUTABU(20)
9811 NERR=0
9812 DO 170 IEV=1,600
9813
9814C...Reset parameter values. Switch on some nonstandard features.
9815 MSTJ(1)=1
9816 MSTJ(3)=0
9817 MSTJ(11)=1
9818 MSTJ(42)=2
9819 MSTJ(43)=4
9820 MSTJ(44)=2
9821 PARJ(17)=0.1
9822 PARJ(22)=1.5
9823 PARJ(43)=1.
9824 PARJ(54)=-0.05
9825 MSTJ(101)=5
9826 MSTJ(104)=5
9827 MSTJ(105)=0
9828 MSTJ(107)=1
9829 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
9830
9831C...Ten events each for some single jets configurations.
9832 IF(IEV.LE.50) THEN
9833 ITY=(IEV+9)/10
9834 MSTJ(3)=-1
9835 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
9836 IF(ITY.EQ.1) CALL LU1ENT(1,1,15.,0.,0.)
9837 IF(ITY.EQ.2) CALL LU1ENT(1,3101,15.,0.,0.)
9838 IF(ITY.EQ.3) CALL LU1ENT(1,-2203,15.,0.,0.)
9839 IF(ITY.EQ.4) CALL LU1ENT(1,-4,30.,0.,0.)
9840 IF(ITY.EQ.5) CALL LU1ENT(1,21,15.,0.,0.)
9841
9842C...Ten events each for some simple jet systems; string fragmentation.
9843 ELSEIF(IEV.LE.130) THEN
9844 ITY=(IEV-41)/10
9845 IF(ITY.EQ.1) CALL LU2ENT(1,1,-1,40.)
9846 IF(ITY.EQ.2) CALL LU2ENT(1,4,-4,30.)
9847 IF(ITY.EQ.3) CALL LU2ENT(1,2,2103,100.)
9848 IF(ITY.EQ.4) CALL LU2ENT(1,21,21,40.)
9849 IF(ITY.EQ.5) CALL LU3ENT(1,2101,21,-3203,30.,0.6,0.8)
9850 IF(ITY.EQ.6) CALL LU3ENT(1,5,21,-5,40.,0.9,0.8)
9851 IF(ITY.EQ.7) CALL LU3ENT(1,21,21,21,60.,0.7,0.5)
9852 IF(ITY.EQ.8) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9853
9854C...Seventy events with independent fragmentation and momentum cons.
9855 ELSEIF(IEV.LE.200) THEN
9856 ITY=1+(IEV-131)/16
9857 MSTJ(2)=1+MOD(IEV-131,4)
9858 MSTJ(3)=1+MOD((IEV-131)/4,4)
9859 IF(ITY.EQ.1) CALL LU2ENT(1,4,-5,40.)
9860 IF(ITY.EQ.2) CALL LU3ENT(1,3,21,-3,40.,0.9,0.4)
9861 IF(ITY.EQ.3) CALL LU4ENT(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9862 IF(ITY.GE.4) CALL LU4ENT(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
9863
9864C...A hundred events with random jets (check invariant mass).
9865 ELSEIF(IEV.LE.300) THEN
9866 100 DO 110 J=1,5
9867 110 PSUM(J)=0.
9868 NJET=2.+6.*RLU(0)
9869 DO 120 I=1,NJET
9870 KFL=21
9871 IF(I.EQ.1) KFL=INT(1.+4.*RLU(0))
9872 IF(I.EQ.NJET) KFL=-INT(1.+4.*RLU(0))
9873 EJET=5.+20.*RLU(0)
9874 THETA=ACOS(2.*RLU(0)-1.)
9875 PHI=6.2832*RLU(0)
9876 IF(I.LT.NJET) CALL LU1ENT(-I,KFL,EJET,THETA,PHI)
9877 IF(I.EQ.NJET) CALL LU1ENT(I,KFL,EJET,THETA,PHI)
9878 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+ULMASS(KFL)
9879 DO 120 J=1,4
9880 120 PSUM(J)=PSUM(J)+P(I,J)
9881 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
9882 & (PSUM(5)+PARJ(32))**2) GOTO 100
9883
9884C...Fifty e+e- continuum events with matrix elements.
9885 ELSEIF(IEV.LE.350) THEN
9886 MSTJ(101)=2
9887 CALL LUEEVT(0,40.)
9888
9889C...Fifty e+e- continuum event with varying shower options.
9890 ELSEIF(IEV.LE.400) THEN
9891 MSTJ(42)=1+MOD(IEV,2)
9892 MSTJ(43)=1+MOD(IEV/2,4)
9893 MSTJ(44)=MOD(IEV/8,3)
9894 CALL LUEEVT(0,90.)
9895
9896C...Fifty e+e- continuum events with coherent shower, including top.
9897 ELSEIF(IEV.LE.450) THEN
9898 MSTJ(104)=6
9899 CALL LUEEVT(0,500.)
9900
9901C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
9902 ELSEIF(IEV.LE.500) THEN
9903 CALL LUONIA(5,9.46)
9904
9905C...One decay each for some heavy mesons.
9906 ELSEIF(IEV.LE.560) THEN
9907 ITY=IEV-501
9908 KFLS=2*(ITY/20)+1
9909 KFLB=8-MOD(ITY/5,4)
9910 KFLC=KFLB-MOD(ITY,5)
9911 CALL LU1ENT(1,100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9912
9913C...One decay each for some heavy baryons.
9914 ELSEIF(IEV.LE.600) THEN
9915 ITY=IEV-561
9916 KFLS=2*(ITY/20)+2
9917 KFLA=8-MOD(ITY/5,4)
9918 KFLB=KFLA-MOD(ITY,5)
9919 KFLC=MAX(1,KFLB-1)
9920 CALL LU1ENT(1,1000*KFLA+100*KFLB+10*KFLC+KFLS,0.,0.,0.)
9921 ENDIF
9922
9923C...Generate event. Find total momentum, energy and charge.
9924 DO 130 J=1,4
9925 130 PINI(J)=PLU(0,J)
9926 PINI(6)=PLU(0,6)
9927 CALL LUEXEC
9928 DO 140 J=1,4
9929 140 PFIN(J)=PLU(0,J)
9930 PFIN(6)=PLU(0,6)
9931
9932C...Check conservation of energy, momentum and charge;
9933C...usually exact, but only approximate for single jets.
9934 MERR=0
9935 IF(IEV.LE.50) THEN
9936 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4.) MERR=MERR+1
9937 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
9938 IF(EPZREM.LT.0..OR.EPZREM.GT.2.*PARJ(31)) MERR=MERR+1
9939 IF(ABS(PFIN(6)-PINI(6)).GT.2.1) MERR=MERR+1
9940 ELSE
9941 DO 150 J=1,4
9942 150 IF(ABS(PFIN(J)-PINI(J)).GT.0001*PINI(4)) MERR=MERR+1
9943 IF(ABS(PFIN(6)-PINI(6)).GT.0.1) MERR=MERR+1
9944 ENDIF
9945 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
9946 &(PFIN(J),J=1,4),PFIN(6)
9947
9948C...Check that all KF codes are known ones, and that partons/particles
9949C...satisfy energy-momentum-mass relation. Store particle statistics.
9950 DO 160 I=1,N
9951 IF(K(I,1).GT.20) GOTO 160
9952 IF(LUCOMP(K(I,2)).EQ.0) THEN
9953 WRITE(MSTU(11),5100) I
9954 MERR=MERR+1
9955 ENDIF
9956 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
9957 IF(ABS(PD).GT.MAX(0.1,0.001*P(I,4)**2).OR.P(I,4).LT.0.) THEN
9958 WRITE(MSTU(11),5200) I
9959 MERR=MERR+1
9960 ENDIF
9961 160 CONTINUE
9962 IF(MTEST.GE.1) CALL LUTABU(21)
9963
9964C...List all erroneous events and some normal ones.
9965 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
9966 CALL LULIST(2)
9967 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
9968 CALL LULIST(1)
9969 ENDIF
9970
9971C...Stop execution if too many errors. Endresult of run.
9972 IF(MERR.NE.0) NERR=NERR+1
9973 IF(NERR.GE.10) THEN
9974 WRITE(MSTU(11),5300) IEV
9975 STOP
9976 ENDIF
9977 170 CONTINUE
9978 IF(MTEST.GE.1) CALL LUTABU(22)
9979 WRITE(MSTU(11),5400) NERR
9980
9981C...Reset commonblock variables changed during run.
9982 MSTJ(2)=3
9983 PARJ(17)=0.
9984 PARJ(22)=1.
9985 PARJ(43)=0.5
9986 PARJ(54)=0.
9987 MSTJ(105)=1
9988 MSTJ(107)=0
9989
9990C...Format statements for output.
9991 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
9992 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
9993 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
9994 &4(1X,F12.5),1X,F8.2)
9995 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
9996 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
9997 &'kinematics')
9998 5300 FORMAT(/5X,'Ten errors experienced by event ',I3/
9999 &5X,'Something is seriously wrong! Execution stopped now!')
10000 5400 FORMAT(/5X,'Number of erroneous or suspect events in run:',I3/
10001 &5X,'(0 fine, 1 acceptable if a single jet, ',
10002 &'>=2 something is wrong)')
10003
10004 RETURN
10005 END
10006
10007C*********************************************************************
10008
10009 BLOCK DATA LUDATA
10010
10011C...Purpose: to give default values to parameters and particle and
10012C...decay data.
10013 COMMON/LUDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10014 COMMON/LUDAT2/KCHG(500,3),PMAS(500,4),PARF(2000),VCKM(4,4)
10015 COMMON/LUDAT3/MDCY(500,3),MDME(2000,2),BRAT(2000),KFDP(2000,5)
10016 COMMON/LUDAT4/CHAF(500)
10017 CHARACTER CHAF*8
10018 COMMON/LUDATR/MRLU(6),RRLU(100)
10019 SAVE /LUDAT1/,/LUDAT2/,/LUDAT3/,/LUDAT4/,/LUDATR/
10020
10021C...LUDAT1, containing status codes and most parameters.
10022 DATA MSTU/
10023 & 0, 0, 0, 150000,20000, 500, 2000, 0, 0, 2,
10024 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
10025 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
10026 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10027 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
10028 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
10029 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10030 7 30*0,
10031 & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10032 1 1, 5, 3, 23, 0, 0, 0, 0, 0, 0,
10033 2 60*0,
10034 8 7, 3, 1992, 2, 21, 0, 0, 0, 0, 0,
10035 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
10036 DATA PARU/
10037 & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
10038 1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
10039 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10040 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10041 4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
10042 5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
10043 6 40*0.,
10044 & 0.00729735, 0.230, 0., 0., 0., 0., 0., 0., 0., 0.,
10045 1 0.20, 0.25, 1.0, 4.0, 10., 0., 0., 0., 0., 0.,
10046 2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0, 0.,
10047 3 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 0., 0., 0.,
10048 4 5.0, 1.0, 1.0, 0., 1.0, 1.0, 0., 0., 0., 0.,
10049 5 1.0, 0., 0., 0., 1000., 1.0, 1.0, 1.0, 1.0, 0.,
10050 6 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., 0., 0.,
10051 7 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0.,
10052 8 1.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.,
10053 9 0., 0., 0., 0., 1.0, 0., 0., 0., 0., 0./
10054 DATA MSTJ/
10055 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
10056 1 1, 2, 0, 1, 0, 0, 0, 0, 0, 0,
10057 2 2, 1, 1, 2, 1, 0, 0, 0, 0, 0,
10058 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10059 4 1, 2, 4, 2, 5, 0, 1, 0, 0, 0,
10060 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
10061 6 40*0,
10062 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 1,
10063 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
10064 2 80*0/
10065 DATA PARJ/
10066 & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
10067 1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
10068 2 0.35, 1.0, 0., 0., 0., 0., 0., 0., 0., 0.,
10069 3 0.10, 1.0, 0.8, 1.5, 0., 2.0, 0.2, 2.5, 0.6, 0.,
10070 4 0.5, 0.9, 0.5, 0.9, 0.5, 1.0, 1.0, 1.0, 0., 0.,
10071 5 0.77, 0.77, 0.77, 0., 0., 0., 0., 0., 1.0, 0.,
10072 6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
10073 7 10., 1000., 100., 1000., 0., 0.7, 10., 0., 0., 0.,
10074 8 0.4, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
10075 9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
10076 & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10077 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10078 2 1.5, 0.5, 91.2, 2.40, 0.02, 2.0, 1.0, 0.25,0.002, 0.,
10079 3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
10080 4 60*0./
10081
10082C...LUDAT2, with particle data and flavour treatment parameters.
10083 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
10084 &-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,
10085 &3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,
10086 &0,3,12*0,3,0,2*3,0,3,0,3,12*0,3,0,2*3,0,3,0,3,72*0,3,0,3,28*0,3,
10087 &2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,3,5*0,-3,0,3,-3,0,-3,
10088 &4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,-3,0,3,-3,0,-3,114*0/
10089 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,17*0,1,50*0,-1,410*0/
10090 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,
10091 &41*0,1,0,7*1,10*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,11*0,9*1,11*0,
10092 &9*1,71*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,0,6*1,
10093 &4*0,6*1,4*0,16*1,4*0,6*1,114*0/
10094 DATA (PMAS(I,1),I= 1, 500)/0.0099,0.0056,0.199,1.35,5.,2*120.,
10095 &200.,2*0.,0.00051,0.,0.1057,0.,1.7841,0.,100.,5*0.,91.2,80.,50.,
10096 &6*0.,500.,900.,500.,3*300.,0.,200.,5000.,60*0.,0.1396,0.4977,
10097 &0.4936,1.8693,1.8645,1.9693,5.2794,5.2776,5.47972,0.,0.135,
10098 &0.5488,0.9575,2.9796,9.4,2*238.,397.,2*0.,0.7669,0.8962,0.8921,
10099 &2.0101,2.0071,2.1127,2*5.3354,5.5068,0.,0.77,0.782,1.0194,3.0969,
10100 &9.4603,2*238.,397.,2*0.,1.233,2*1.3,2*2.322,2.51,2*5.73,5.97,0.,
10101 &1.233,1.17,1.41,3.46,9.875,2*238.42,397.41992,2*0.,0.983,2*1.429,
10102 &2*2.272,2.46,2*5.68,5.92,0.,0.983,1.,1.4,3.4151,9.8598,
10103 &2*238.39999,397.3999,2*0.,1.26,2*1.401,2*2.372,2.56,2*5.78,6.02,
10104 &0.,1.26,1.283,1.422,3.5106,9.8919,2*238.5,397.5,2*0.,1.318,
10105 &2*1.426,2*2.422,2.61,2*5.83,6.07,0.,1.318,1.274,1.525,3.5563,
10106 &9.9132,2*238.45,397.44995,2*0.,2*0.4977,83*0.,1.1156,5*0.,2.2849,
10107 &0.,2*2.46,6*0.,5.62,0.,2*5.84,6*0.,0.9396,0.9383,0.,1.1974,
10108 &1.1926,1.1894,1.3213,1.3149,0.,2.454,2.4529,2.4522,2*2.55,2.73,
10109 &4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,1.233,1.232,1.231,1.3872,
10110 &1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8,4*0.,3*5.81,
10111 &2*5.97,6.13,114*0./
10112 DATA (PMAS(I,2),I= 1, 500)/22*0.,2.5,2.1,88*0.,0.0002,0.001,
10113 &6*0.,0.149,0.0505,0.0513,7*0.,0.153,0.0085,0.0044,7*0.,0.15,
10114 &2*0.09,2*0.06,0.04,3*0.1,0.,0.15,0.335,0.08,2*0.01,5*0.,0.057,
10115 &2*0.287,2*0.06,0.04,3*0.1,0.,0.057,0.,0.25,0.0135,6*0.,0.4,
10116 &2*0.184,2*0.06,0.04,3*0.1,0.,0.4,0.025,0.055,0.00135,6*0.,0.11,
10117 &0.115,0.099,2*0.06,4*0.1,0.,0.11,0.185,0.076,0.0026,146*0.,
10118 &4*0.115,0.039,2*0.036,0.0099,0.0091,131*0./
10119 DATA (PMAS(I,3),I= 1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0.,
10120 &0.4,2*0.2,7*0.,0.4,0.1,0.015,7*0.,0.25,2*0.01,3*0.08,2*0.2,0.12,
10121 &0.,0.25,0.2,0.001,2*0.02,5*0.,0.05,2*0.4,3*0.08,2*0.2,0.12,0.,
10122 &0.05,0.,0.35,0.05,6*0.,3*0.3,2*0.08,0.06,2*0.2,0.12,0.,0.3,0.05,
10123 &0.025,0.001,6*0.,0.25,4*0.12,4*0.2,0.,0.25,0.17,0.2,0.01,146*0.,
10124 &4*0.14,0.04,2*0.035,2*0.05,131*0./
10125 DATA (PMAS(I,4),I= 1, 500)/12*0.,658650.,0.,0.091,68*0.,0.1,
10126 &0.43,15*0.,7803.,0.,3709.,0.32,0.128,0.131,3*0.393,84*0.,0.,
10127 &26*0.,15540.,26.75,83*0.,78.88,5*0.,0.054,0.,2*0.13,6*0.,0.393,
10128 &0.,2*0.393,9*0.,44.3,0.,24.,49.10001,86.89999,6*0.,0.13,9*0.,
10129 &0.393,13*0.,24.60001,130*0./
10130 DATA PARF/
10131 & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
10132 1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10133 2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10134 3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10135 4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10136 5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10137 6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
10138 7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
10139 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10140 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10141 & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
10142 1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
10143 2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
10144 3 1870*0./
10145 DATA ((VCKM(I,J),J=1,4),I=1,4)/
10146 1 0.95150, 0.04847, 0.00003, 0.00000,
10147 2 0.04847, 0.94936, 0.00217, 0.00000,
10148 3 0.00003, 0.00217, 0.99780, 0.00000,
10149 4 0.00000, 0.00000, 0.00000, 1.00000/
10150
10151C...LUDAT3, with particle decay parameters and data.
10152 DATA (MDCY(I,1),I= 1, 500)/14*0,1,0,1,5*0,3*1,6*0,1,0,1,2*0,1,
10153 &0,2*1,42*0,7*1,12*0,1,0,6*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,
10154 &2*0,9*1,0,8*1,2*0,9*1,0,8*1,2*0,9*1,0,8*1,3*0,1,83*0,1,5*0,1,0,
10155 &2*1,6*0,1,0,2*1,9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
10156 DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,49,57,2*0,65,69,71,
10157 &76,78,118,120,125,2*0,127,136,148,164,184,6*0,201,0,223,246,266,
10158 &284,0,293,294,42*0,303,304,308,317,320,325,327,11*0,347,348,350,
10159 &356,477,645,677,678,679,0,680,682,688,694,695,696,697,698,2*0,
10160 &699,700,703,706,709,711,712,713,714,0,715,716,721,729,732,741,
10161 &756,757,2*0,758,759,764,769,771,773,774,776,778,0,780,781,784,
10162 &788,789,790,792,793,2*0,794,797,799,801,805,809,811,815,819,0,
10163 &823,826,830,834,836,838,840,841,2*0,842,844,846,848,850,852,855,
10164 &857,859,0,862,864,877,881,883,885,887,888,2*0,889,895,906,917,
10165 &925,933,938,946,954,0,959,966,974,976,978,980,982,983,2*0,984,
10166 &992,83*0,994,5*0,998,0,1072,1073,6*0,1074,0,1075,1076,9*0,1077,
10167 &1079,1080,1083,1084,0,1086,1087,1088,1089,1090,1091,4*0,1092,
10168 &1093,1094,1095,1096,1097,4*0,1098,1099,1102,1105,1106,1109,1112,
10169 &1115,1117,1119,1123,1124,1125,1126,1128,1130,4*0,1131,1132,1133,
10170 &1134,1135,1136,114*0/
10171 DATA (MDCY(I,3),I= 1, 500)/8*8,2*0,4,2,5,2,40,2,5,2,2*0,9,12,
10172 &16,20,17,6*0,22,0,23,20,18,9,0,1,9,42*0,1,4,9,3,5,2,20,11*0,1,2,
10173 &6,121,168,32,3*1,0,2,2*6,5*1,2*0,1,3*3,2,4*1,0,1,5,8,3,9,15,2*1,
10174 &2*0,1,2*5,2*2,1,3*2,0,1,3,4,2*1,2,2*1,2*0,3,2*2,2*4,2,3*4,0,3,
10175 &2*4,3*2,2*1,2*0,5*2,3,2*2,3,0,2,13,4,3*2,2*1,2*0,6,2*11,2*8,5,
10176 &2*8,5,0,7,8,4*2,2*1,2*0,8,2,83*0,4,5*0,74,0,2*1,6*0,1,0,2*1,9*0,
10177 &2,1,3,1,2,0,6*1,4*0,6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,
10178 &114*0/
10179 DATA (MDME(I,1),I= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
10180 &7*1,-1,85*1,2*-1,7*1,2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,
10181 &3*1,5*-1,3*1,-1,6*1,2*-1,3*1,-1,11*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,
10182 &3*1,5*-1,3*1,4*-1,6*1,2*-1,3*1,-1,5*1,-1,8*1,2*-1,3*1,-1,9*1,-1,
10183 &3*1,-1,6*1,2*-1,2*1,-1,16*1,-1,2*1,3*-1,470*1,2*0,1204*1/
10184 DATA (MDME(I,2),I= 1,2000)/70*102,42,6*102,2*42,2*0,7*41,2*0,
10185 &23*41,6*102,45,27*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
10186 &14*0,16*32,7*0,8*32,4*0,32,7*0,8*32,4*0,32,5*0,4*32,6*0,6*32,3*0,
10187 &12,2*42,2*11,9*42,2*45,31,2*45,2*33,31,2*45,20*46,7*0,34*42,86*0,
10188 &2*25,26,24*42,142*0,25,26,0,10*42,19*0,2*13,3*85,0,2,4*0,2,8*0,
10189 &2*32,87,88,3*3,0,2*3,0,2*3,0,3,5*0,3,1,0,3,2*0,2*3,3*0,1,4*0,12,
10190 &3*0,4*32,2*4,2*45,6*0,5*32,2*4,87,88,30*0,12,32,0,32,87,88,41*0,
10191 &12,0,32,0,32,87,88,40*0,12,0,32,0,32,87,88,88*0,12,0,32,0,32,87,
10192 &88,2*0,4*42,8*0,14*42,50*0,10*13,2*84,3*85,14*0,84,5*0,85,903*0/
10193 DATA (BRAT(I) ,I= 1, 501)/70*0.,1.,6*0.,2*0.177,0.108,0.225,
10194 &0.003,0.06,0.02,0.025,0.013,2*0.004,0.007,0.014,2*0.002,2*0.001,
10195 &0.054,0.014,0.016,0.005,2*0.012,5*0.006,0.002,2*0.001,5*0.002,
10196 &6*0.,1.,27*0.,0.143,0.111,0.143,0.111,0.143,0.085,2*0.,0.03,
10197 &0.058,0.03,0.058,0.03,0.058,2*0.,0.25,0.01,2*0.,0.01,0.25,4*0.,
10198 &0.24,5*0.,3*0.08,3*0.,0.01,0.08,0.82,5*0.,0.09,6*0.,0.143,0.111,
10199 &0.143,0.111,0.143,0.085,2*0.,0.03,0.058,0.03,0.058,0.03,0.058,
10200 &8*0.,0.25,0.01,2*0.,0.01,0.25,4*0.,0.24,5*0.,3*0.08,6*0.,0.01,
10201 &0.08,0.82,5*0.,0.09,11*0.,0.01,0.08,0.82,5*0.,0.09,9*0.,1.,6*0.,
10202 &1.,4*0.215,2*0.,2*0.07,0.,1.,2*0.08,0.76,0.08,2*0.112,0.05,0.476,
10203 &0.08,0.14,0.01,0.015,0.005,1.,3*0.,1.,3*0.,1.,0.,0.25,0.01,2*0.,
10204 &0.01,0.25,4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,
10205 &0.017,0.048,0.032,0.035,0.03,2*0.015,0.044,2*0.022,9*0.001,0.035,
10206 &0.03,2*0.015,0.044,2*0.022,9*0.001,0.028,0.017,0.066,0.02,0.008,
10207 &2*0.006,0.003,0.001,2*0.002,0.003,0.001,2*0.002,0.005,0.002,
10208 &0.005,0.006,0.004,0.012,2*0.005,0.008,2*0.005,0.037,0.004,0.067,
10209 &2*0.01,2*0.001,3*0.002,0.003,8*0.002,0.005,4*0.004,0.015,0.005,
10210 &0.027,2*0.005,0.007,0.014,0.007,0.01,0.008,0.012,0.015,11*0.002,
10211 &3*0.004,0.002,0.004,6*0.002,2*0.004,0.005,0.011,0.005,0.015,0.02,
10212 &2*0.01,3*0.004,5*0.002,0.015,0.02,2*0.01,3*0.004,5*0.002,0.038/
10213 DATA (BRAT(I) ,I= 502, 841)/0.048,0.082,0.06,0.028,0.021,
10214 &2*0.005,2*0.002,0.005,0.018,0.005,0.01,0.008,0.005,3*0.004,0.001,
10215 &3*0.003,0.001,2*0.002,0.003,2*0.002,2*0.001,0.002,0.001,0.002,
10216 &0.001,0.005,4*0.003,0.001,2*0.002,0.003,2*0.001,0.013,0.03,0.058,
10217 &0.055,3*0.003,2*0.01,0.007,0.019,4*0.005,0.015,3*0.005,8*0.002,
10218 &3*0.001,0.002,2*0.001,0.003,16*0.001,0.019,2*0.003,0.002,0.005,
10219 &0.004,0.008,0.003,0.006,0.003,0.01,5*0.002,2*0.001,2*0.002,
10220 &11*0.001,0.002,14*0.001,0.018,0.005,0.01,2*0.015,0.017,4*0.015,
10221 &0.017,3*0.015,0.025,0.08,2*0.025,0.04,0.001,2*0.005,0.02,0.04,
10222 &2*0.06,0.04,0.01,4*0.005,0.25,0.115,3*1.,0.988,0.012,0.389,0.319,
10223 &0.237,0.049,0.005,0.001,0.441,0.205,0.301,0.03,0.022,0.001,6*1.,
10224 &0.665,0.333,0.002,0.666,0.333,0.001,0.49,0.34,0.17,0.52,0.48,
10225 &5*1.,0.893,0.08,0.017,2*0.005,0.495,0.343,3*0.043,0.019,0.013,
10226 &0.001,2*0.069,0.862,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,
10227 &1.,14*0.,3*1.,0.28,0.14,0.313,0.157,0.11,0.28,0.14,0.313,0.157,
10228 &0.11,0.667,0.333,0.667,0.333,1.,0.667,0.333,0.667,0.333,2*0.5,1.,
10229 &0.333,0.334,0.333,4*0.25,2*1.,0.3,0.7,2*1.,0.8,2*0.1,0.667,0.333,
10230 &0.667,0.333,0.6,0.3,0.067,0.033,0.6,0.3,0.067,0.033,2*0.5,0.6,
10231 &0.3,0.067,0.033,0.6,0.3,0.067,0.033,2*0.4,2*0.1,0.8,2*0.1,0.52,
10232 &0.26,2*0.11,0.62,0.31,2*0.035,0.007,0.993,0.02,0.98,0.3,0.7,2*1./
10233 DATA (BRAT(I) ,I= 842,1136)/2*0.5,0.667,0.333,0.667,0.333,0.667,
10234 &0.333,0.667,0.333,2*0.35,0.3,0.667,0.333,0.667,0.333,2*0.35,0.3,
10235 &2*0.5,3*0.14,0.1,0.05,4*0.08,0.028,0.027,0.028,0.027,4*0.25,
10236 &0.273,0.727,0.35,0.65,0.3,0.7,2*1.,2*0.35,0.144,0.105,0.048,
10237 &0.003,0.332,0.166,0.168,0.084,0.086,0.043,0.059,2*0.029,2*0.002,
10238 &0.332,0.166,0.168,0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,
10239 &0.15,0.16,0.08,0.13,0.06,0.08,0.04,0.3,0.15,0.16,0.08,0.13,0.06,
10240 &0.08,0.04,2*0.4,0.1,2*0.05,0.3,0.15,0.16,0.08,0.13,0.06,0.08,
10241 &0.04,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,2*0.4,0.1,2*0.05,
10242 &2*0.35,0.144,0.105,2*0.024,0.003,0.573,0.287,0.063,0.028,2*0.021,
10243 &0.004,0.003,2*0.5,0.15,0.85,0.22,0.78,0.3,0.7,2*1.,0.217,0.124,
10244 &2*0.193,2*0.135,0.002,0.001,0.686,0.314,0.641,0.357,2*0.001,
10245 &0.018,2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,
10246 &2*0.006,0.005,0.025,0.015,0.006,2*0.005,0.004,0.005,5*0.004,
10247 &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002,
10248 &2*0.001,2*0.002,5*0.001,4*0.003,2*0.005,2*0.002,2*0.001,2*0.002,
10249 &2*0.001,0.255,0.057,2*0.035,0.15,2*0.075,0.03,2*0.015,5*1.,0.999,
10250 &0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331,0.663,
10251 &0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88,2*0.06,
10252 &0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5,7*1./
10253 DATA (BRAT(I) ,I=1137,2000)/864*0./
10254 DATA (KFDP(I,1),I= 1, 530)/21,22,23,4*-24,25,21,22,23,4*24,25,
10255 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
10256 &4*24,25,21,22,23,4*-24,25,21,22,23,4*24,25,22,23,-24,25,23,24,
10257 &-12,22,23,-24,25,23,24,-12,-14,34*16,22,23,-24,25,23,24,-89,22,
10258 &23,-24,25,23,24,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,
10259 &2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,
10260 &-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1,2,3,4,5,
10261 &6,7,8,11,12,13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,
10262 &4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
10263 &24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,-1,-3,
10264 &-5,-7,-11,-13,-15,-17,24,2,1,2,3,4,5,6,11,13,15,82,-11,-13,2*2,
10265 &-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37,2*-89,2*5,-37,2*89,4*-1,4*-3,
10266 &4*-5,4*-7,-11,-13,-15,-17,-13,130,310,-13,3*211,12,14,16*-11,
10267 &16*-13,-311,-313,-311,-313,-311,-313,-311,-313,2*111,2*221,2*331,
10268 &2*113,2*223,2*333,-311,-313,2*-311,-313,3*-311,-321,-323,-321,
10269 &2*211,2*213,-213,113,3*213,3*211,2*213,2*-311,-313,-321,2*-311,
10270 &-313,-311,-313,4*-311,-321,-323,2*-321,3*211,213,2*211,213,5*211,
10271 &213,4*211,3*213,211,213,321,311,3,2*2,12*-11,12*-13,-321,-323,
10272 &-321,-323,-311,-313,-311,-313,-311,-313,-311,-313,-311,-313,-311,
10273 &-321,-323,-321,-323,211,213,211,213,111,221,331,113,223,333,221/
10274 DATA (KFDP(I,1),I= 531, 906)/331,113,223,113,223,113,223,333,223,
10275 &333,321,323,321,323,311,313,-321,-323,3*-321,-323,2*-321,-323,
10276 &-321,-311,-313,3*-311,-313,2*-311,-313,-321,-323,3*-321,-323,
10277 &2*-321,-311,2*333,211,213,2*211,2*213,4*211,10*111,-321,-323,
10278 &5*-321,-323,2*-321,-311,-313,4*-311,-313,4*-311,-321,-323,2*-321,
10279 &-323,-321,-313,-311,-313,-311,211,213,2*211,213,4*211,111,221,
10280 &113,223,113,223,2*3,-15,5*-11,5*-13,221,331,333,221,331,333,211,
10281 &213,211,213,321,323,321,323,2212,221,331,333,221,2*2,3*0,3*22,
10282 &111,211,2*22,2*211,111,3*22,111,3*21,2*0,211,321,3*311,2*321,421,
10283 &2*411,2*421,431,511,521,531,2*211,22,211,2*111,321,130,-213,113,
10284 &213,211,22,111,11,13,82,11,13,15,1,2,3,4,21,22,2*89,11,12,13,14,
10285 &15,16,1,2,3,4,5,21,22,2*0,223,321,311,323,313,2*311,321,313,323,
10286 &321,421,2*411,421,433,521,2*511,521,523,513,223,213,113,-213,313,
10287 &-313,323,-323,82,21,663,21,2*0,221,213,113,321,2*311,321,421,411,
10288 &423,413,411,421,413,423,431,433,521,511,523,513,511,521,513,523,
10289 &521,511,531,533,221,213,-213,211,111,321,130,211,111,321,130,443,
10290 &82,553,21,663,21,2*0,113,213,323,2*313,323,423,2*413,423,421,411,
10291 &433,523,2*513,523,521,511,533,213,-213,10211,10111,-10211,2*221,
10292 &213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82,553,21,663,
10293 &21,2*0,213,113,221,223,321,211,321,311,323,313,323,313,321,5*311/
10294 DATA (KFDP(I,1),I= 907,2000)/321,313,323,313,323,311,4*321,421,
10295 &411,423,413,423,413,421,2*411,421,413,423,413,423,411,2*421,411,
10296 &433,2*431,521,511,523,513,523,513,521,2*511,521,513,523,513,523,
10297 &511,2*521,511,533,2*531,213,-213,221,223,321,130,111,211,111,
10298 &2*211,321,130,221,111,321,130,443,82,553,21,663,21,2*0,111,211,
10299 &-12,12,-14,14,211,111,211,111,2212,2*2112,-12,7*-11,7*-13,2*2224,
10300 &2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,
10301 &2*2224,5*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,
10302 &2*3224,4*2,3,2*2,1,2*2,5*0,2112,-12,3122,2212,2112,2212,3*3122,
10303 &3*4122,4132,4232,0,3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,
10304 &2*2212,3122,3212,3112,3122,3222,3112,3122,3222,3212,3322,3312,
10305 &3322,3312,3122,3322,3312,-12,3*4122,2*4132,2*4232,4332,3*5122,
10306 &5132,5232,5332,864*0/
10307 DATA (KFDP(I,2),I= 1, 467)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
10308 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,3*7,2,4,6,8,7,
10309 &3*8,1,3,5,7,8,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,-211,
10310 &-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,2*-321,
10311 &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
10312 &16,15,16,15,18,2*17,18,17,18,17,-1,-2,-3,-4,-5,-6,-7,-8,21,-1,-2,
10313 &-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,-11,
10314 &-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,
10315 &14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,
10316 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,
10317 &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,25,
10318 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,36,
10319 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4,6,
10320 &8,12,14,16,18,25,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,12,14,-1,
10321 &-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,4,6,8,2,
10322 &4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,16*12,
10323 &16*14,2*211,2*213,2*321,2*323,211,213,211,213,211,213,211,213,
10324 &211,213,211,213,2*211,213,7*211,213,211,111,211,111,2*211,-213,
10325 &213,2*113,223,113,223,221,321,2*311,321,313,4*211,213,113,213,
10326 &-213,2*211,213,113,111,221,331,111,113,223,4*113,223,6*211,213/
10327 DATA (KFDP(I,2),I= 468, 873)/4*211,-321,-311,3*-1,12*12,12*14,
10328 &2*211,2*213,2*111,2*221,2*331,2*113,2*223,333,2*321,2*323,2*-211,
10329 &2*-213,6*111,4*221,2*331,3*113,2*223,2*-211,2*-213,113,111,2*211,
10330 &213,6*211,321,2*211,213,211,2*111,113,2*223,2*321,323,321,2*311,
10331 &313,2*311,111,211,2*-211,-213,-211,-213,-211,-213,3*-211,5*111,
10332 &2*113,223,113,223,2*211,213,5*211,213,3*211,213,2*211,2*111,221,
10333 &113,223,3*321,323,2*321,323,311,313,311,313,3*211,2*-211,-213,
10334 &3*-211,4*111,2*113,2*-1,16,5*12,5*14,3*211,3*213,2*111,2*113,
10335 &2*-311,2*-313,-2112,3*321,323,2*-1,3*0,22,11,22,111,-211,211,11,
10336 &2*-211,111,113,223,22,111,3*21,2*0,111,-211,111,22,211,111,22,
10337 &211,111,22,111,5*22,2*-211,111,-211,2*111,-321,310,211,111,
10338 &2*-211,221,22,-11,-13,-82,-11,-13,-15,-1,-2,-3,-4,2*21,5,3,-11,
10339 &-12,-13,-14,-15,-16,-1,-2,-3,-4,-5,2*21,2*0,211,-213,113,-211,
10340 &111,223,211,111,211,111,223,211,111,-211,2*111,-211,111,211,111,
10341 &-321,-311,111,-211,111,211,-311,311,-321,321,-82,21,22,21,2*0,
10342 &211,111,211,-211,111,211,111,211,111,211,111,-211,111,-211,3*111,
10343 &-211,111,-211,111,211,111,211,111,-321,-311,3*111,-211,211,-211,
10344 &111,-321,310,-211,111,-321,310,22,-82,22,21,22,21,2*0,211,111,
10345 &-211,111,211,111,211,111,-211,111,321,311,111,-211,111,211,111,
10346 &-321,-311,111,-211,211,-211,111,2*211,111,-211,211,111,211,-321/
10347 DATA (KFDP(I,2),I= 874,2000)/2*-311,-321,-311,311,-321,321,22,
10348 &-82,22,21,22,21,2*0,111,3*211,-311,22,-211,111,-211,111,-211,211,
10349 &-213,113,223,221,22,211,111,211,111,2*211,213,113,223,221,22,211,
10350 &111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,311,
10351 &2*111,211,-211,111,-211,111,-211,211,-211,2*211,111,211,111,
10352 &4*211,-321,-311,2*111,211,-211,211,111,211,-321,310,22,-211,111,
10353 &2*-211,-321,310,221,111,-321,310,22,-82,22,21,22,21,2*0,111,-211,
10354 &11,-11,13,-13,-211,111,-211,111,-211,111,22,11,7*12,7*14,-321,
10355 &-323,-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,
10356 &223,111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,
10357 &111,221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,
10358 &313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,5*0,-211,11,
10359 &22,111,211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,
10360 &0,2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211,
10361 &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22,
10362 &-211,111,211,3*22,864*0/
10363 DATA (KFDP(I,3),I= 1, 989)/70*0,14,6*0,2*16,2*0,5*111,310,130,
10364 &2*0,2*111,310,130,113,211,223,221,2*113,2*211,2*223,2*221,2*113,
10365 &221,113,2*213,-213,190*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211,3*111,
10366 &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10367 &-311,-313,-311,2*-321,2*-311,111,221,331,113,223,211,111,211,111,
10368 &20*0,3*111,2*221,331,113,223,3*211,-211,111,-211,111,211,111,211,
10369 &-211,111,113,111,223,2*111,-311,4*211,2*111,2*211,111,7*211,
10370 &7*111,113,221,2*223,2*-211,-213,4*-211,-213,-211,-213,-211,2*211,
10371 &2,2*0,-321,-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,-321,
10372 &-323,-311,-321,-311,2*-321,-211,-213,2*-211,211,46*0,3*111,113,
10373 &2*221,331,2*223,-311,3*-211,-213,8*111,113,3*211,213,2*111,-211,
10374 &3*111,113,111,2*113,221,331,223,111,221,331,113,223,113,2*223,
10375 &2*221,3*111,221,113,223,4*211,3*-211,-213,-211,5*111,-321,3*211,
10376 &3*111,2*211,2*111,2*-211,-213,3*111,221,113,223,6*111,3*0,221,
10377 &331,333,321,311,221,331,333,321,311,19*0,3,5*0,-11,0,2*111,-211,
10378 &-11,11,2*221,3*0,111,22*0,111,2*0,22,111,5*0,111,12*0,2*21,2*-6,
10379 &11*0,2*21,111*0,-211,2*111,-211,3*111,-211,111,211,15*0,111,6*0,
10380 &111,-211,9*0,111,-211,9*0,111,-211,111,-211,4*0,111,-211,111,
10381 &-211,4*0,-211,4*0,111,-211,111,-211,4*0,111,-211,111,-211,4*0,
10382 &-211,3*0,-211,5*0,111,211,3*0,111,10*0,2*111,211,-211,211,-211/
10383 DATA (KFDP(I,3),I= 990,2000)/7*0,2212,3122,3212,3214,2112,2114,
10384 &2212,2112,3122,3212,3214,2112,2114,2212,2112,50*0,3*3,1,12*0,
10385 &2112,43*0,3322,878*0/
10386 DATA (KFDP(I,4),I= 1,2000)/83*0,3*111,9*0,-211,3*0,111,2*-211,
10387 &0,111,0,2*111,113,221,111,-213,-211,211,190*0,13*81,41*0,111,
10388 &3*211,111,5*0,-211,111,-211,111,2*0,111,3*211,111,5*0,-211,111,
10389 &-211,111,50*0,2*111,2*-211,2*111,-211,211,3*111,211,14*111,221,
10390 &113,223,2*111,2*113,223,2*111,-1,4*0,-211,111,-211,211,111,2*0,
10391 &2*111,-211,2*0,-211,111,-211,211,111,2*0,2*111,-211,96*0,6*111,
10392 &3*-211,-213,4*111,113,6*111,3*-211,3*111,2*-211,2*111,3*-211,
10393 &12*111,6*0,-321,-311,3*0,-321,-311,19*0,-3,11*0,-11,280*0,111,
10394 &-211,3*0,111,29*0,-211,111,5*0,-211,111,50*0,2101,2103,2*2101,
10395 &935*0/
10396 DATA (KFDP(I,5),I= 1,2000)/85*0,111,15*0,111,7*0,111,0,2*111,
10397 &246*0,111,-211,111,7*0,2*111,4*0,111,-211,111,7*0,2*111,93*0,111,
10398 &-211,111,3*0,111,-211,4*0,111,-211,111,3*0,111,-211,1500*0/
10399
10400C...LUDAT4, with character strings.
10401 DATA (CHAF(I) ,I= 1, 325)/'d','u','s','c','b','t','l','h',
10402 &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
10403 &2*' ','g','gamma','Z','W','H',6*' ','Z''','Z"','W''','H''','A',
10404 &'H',' ','LQ_ue','R',40*' ','specflav','rndmflav','phasespa',
10405 &'c-hadron','b-hadron','t-hadron','l-hadron','h-hadron','Wvirt',
10406 &'diquark','cluster','string','indep.','CMshower','SPHEaxis',
10407 &'THRUaxis','CLUSjet','CELLjet','table',' ','pi',2*'K',2*'D',
10408 &'D_s',2*'B','B_s',' ','pi','eta','eta''','eta_c','eta_b','eta_t',
10409 &'eta_l','eta_h',2*' ','rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s',
10410 &' ','rho','omega','phi','J/psi','Upsilon','Theta','Theta_l',
10411 &'Theta_h',2*' ','b_1',2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s',' ',
10412 &'b_1','h_1','h''_1','h_1c','h_1b','h_1t','h_1l','h_1h',2*' ',
10413 &'a_0',2*'K*_0',2*'D*_0','D*_0s',2*'B*_0','B*_0s',' ','a_0','f_0',
10414 &'f''_0','chi_0c','chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',
10415 &2*'K*_1',2*'D*_1','D*_1s',2*'B*_1','B*_1s',' ','a_1','f_1',
10416 &'f''_1','chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
10417 &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s',' ','a_2','f_2',
10418 &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
10419 &'K_S',58*' ','pi_diffr','n_diffr','p_diffr',22*' ','Lambda',
10420 &5*' ','Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b'/
10421 DATA (CHAF(I) ,I= 326, 500)/6*' ','n','p',' ',3*'Sigma',2*'Xi',
10422 &' ',3*'Sigma_c',2*'Xi''_c','Omega_c',4*' ',3*'Sigma_b',
10423 &2*'Xi''_b','Omega_b',4*' ',4*'Delta',3*'Sigma*',2*'Xi*','Omega',
10424 &3*'Sigma*_c',2*'Xi*_c','Omega*_c',4*' ',3*'Sigma*_b',2*'Xi*_b',
10425 &'Omega*_b',114*' '/
10426
10427C...LUDATR, with initial values for the random number generator.
10428 DATA MRLU/19780503,0,0,97,33,0/
10429
10430 END
10431
10432C*********** THIS IS THE END OF JETSET PACKAGE ***************************