C++ Interface to Tauola
jetset74.f
1C*********************************************************************
2C*********************************************************************
3C* **
4C* December 1993 **
5C* **
6C* The Lund Monte Carlo for Jet Fragmentation and e+e- Physics **
7C* **
8C* JETSET version 7.4 **
9C* **
10C* Torbjorn Sjostrand **
11C* CERN/TH, CH-1211 Geneva 23 **
12C* BITNET/EARN address TORSJO@CERNVM **
13C* Tel. +41 - 22 - 767 28 20 **
14C* **
15C* LUSHOW is written together with Mats Bengtsson **
16C* **
17C* Copyright Torbjorn Sjostrand and CERN, Geneva 1993 **
18C* **
19C*********************************************************************
20C*********************************************************************
21C *
22C List of subprograms in order of appearance, with main purpose *
23C (S = subroutine, F = function, B = block data) *
24C *
25C S LU1ENT to fill one entry (= parton or particle) *
26C S LU2ENT to fill two entries *
27C S LU3ENT to fill three entries *
28C S LU4ENT to fill four entries *
29C S LUJOIN to connect entries with colour flow information *
30C S LUGIVE to fill (or query) commonblock variables *
31C S LUEXEC to administrate fragmentation and decay chain *
32C S LUPREP to rearrange showered partons along strings *
33C S LUSTRF to do string fragmentation of jet system *
34C S LUINDF to do independent fragmentation of one or many jets *
35C S LUDECY to do the decay of a particle *
36C S LUKFDI to select parton and hadron flavours in fragm *
37C S LUPTDI to select transverse momenta in fragm *
38C S LUZDIS to select longitudinal scaling variable in fragm *
39C S LUSHOW to do timelike parton shower evolution *
40C S LUBOEI to include Bose-Einstein effects (crudely) *
41C F ULMASS to give the mass of a particle or parton *
42C S LUNAME to give the name of a particle or parton *
43C F LUCHGE to give three times the electric charge *
44C F LUCOMP to compress standard KF flavour code to internal KC *
45C S LUERRM to write error messages and abort faulty run *
46C F ULALEM to give the alpha_electromagnetic value *
47C F ULALPS to give the alpha_strong value *
48C F ULANGL to give the angle from known x and y components *
49C F RLU to provide a random number generator *
50C S RLUGET to save the state of the random number generator *
51C S RLUSET to set the state of the random number generator *
52C S LUROBO to rotate and/or boost an event *
53C S LUEDIT to remove unwanted entries from record *
54C S LULIST to list event record or particle data *
55C S LULOGO to write a logo for JETSET and PYTHIA *
56C S LUUPDA to update particle data *
57C F KLU to provide integer-valued event information *
58C F PLU to provide real-valued event information *
59C S LUSPHE to perform sphericity analysis *
60C S LUTHRU to perform thrust analysis *
61C S LUCLUS to perform three-dimensional cluster analysis *
62C S LUCELL to perform cluster analysis in (eta, phi, E_T) *
63C S LUJMAS to give high and low jet mass of event *
64C S LUFOWO to give Fox-Wolfram moments *
65C S LUTABU to analyze events, with tabular output *
66C *
67C S LUEEVT to administrate the generation of an e+e- event *
68C S LUXTOT to give the total cross-section at given CM energy *
69C S LURADK to generate initial state photon radiation *
70C S LUXKFL to select flavour of primary qqbar pair *
71C S LUXJET to select (matrix element) jet multiplicity *
72C S LUX3JT to select kinematics of three-jet event *
73C S LUX4JT to select kinematics of four-jet event *
74C S LUXDIF to select angular orientation of event *
75C S LUONIA to perform generation of onium decay to gluons *
76C *
77C S LUHEPC to convert between /LUJETS/ and /HEPEVT/ records *
78C S LUTEST to test the proper functioning of the package *
79C B LUDATA to contain default values and particle data *
80C *
81C*********************************************************************
82
83 SUBROUTINE lu1ent(IP,KF,PE,THE,PHI)
84
85C...Purpose: to store one parton/particle in commonblock LUJETS.
86 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
87 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
88 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
89 SAVE /lujets/,/ludat1/,/ludat2/
90
91C...Standard checks.
92 mstu(28)=0
93 IF(mstu(12).GE.1) CALL lulist(0)
94 ipa=max(1,iabs(ip))
95 IF(ipa.GT.mstu(4)) CALL luerrm(21,
96 &'(LU1ENT:) writing outside LUJETS memory')
97 kc=lucomp(kf)
98 IF(kc.EQ.0) CALL luerrm(12,'(LU1ENT:) unknown flavour code')
99
100C...Find mass. Reset K, P and V vectors.
101 pm=0.
102 IF(mstu(10).EQ.1) pm=p(ipa,5)
103 IF(mstu(10).GE.2) pm=ulmass(kf)
104 DO 100 j=1,5
105 k(ipa,j)=0
106 p(ipa,j)=0.
107 v(ipa,j)=0.
108 100 CONTINUE
109
110C...Store parton/particle in K and P vectors.
111 k(ipa,1)=1
112 IF(ip.LT.0) k(ipa,1)=2
113 k(ipa,2)=kf
114 p(ipa,5)=pm
115 p(ipa,4)=max(pe,pm)
116 pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)
117 p(ipa,1)=pa*sin(the)*cos(phi)
118 p(ipa,2)=pa*sin(the)*sin(phi)
119 p(ipa,3)=pa*cos(the)
120
121C...Set N. Optionally fragment/decay.
122 n=ipa
123 IF(ip.EQ.0) CALL luexec
124
125 RETURN
126 END
127
128C*********************************************************************
129
130 SUBROUTINE lu2ent(IP,KF1,KF2,PECM)
131
132C...Purpose: to store two partons/particles in their CM frame,
133C...with the first along the +z axis.
134 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
135 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
136 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
137 SAVE /lujets/,/ludat1/,/ludat2/
138
139C...Standard checks.
140 mstu(28)=0
141 IF(mstu(12).GE.1) CALL lulist(0)
142 ipa=max(1,iabs(ip))
143 IF(ipa.GT.mstu(4)-1) CALL luerrm(21,
144 &'(LU2ENT:) writing outside LUJETS memory')
145 kc1=lucomp(kf1)
146 kc2=lucomp(kf2)
147 IF(kc1.EQ.0.OR.kc2.EQ.0) CALL luerrm(12,
148 &'(LU2ENT:) unknown flavour code')
149
150C...Find masses. Reset K, P and V vectors.
151 pm1=0.
152 IF(mstu(10).EQ.1) pm1=p(ipa,5)
153 IF(mstu(10).GE.2) pm1=ulmass(kf1)
154 pm2=0.
155 IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
156 IF(mstu(10).GE.2) pm2=ulmass(kf2)
157 DO 110 i=ipa,ipa+1
158 DO 100 j=1,5
159 k(i,j)=0
160 p(i,j)=0.
161 v(i,j)=0.
162 100 CONTINUE
163 110 CONTINUE
164
165C...Check flavours.
166 kq1=kchg(kc1,2)*isign(1,kf1)
167 kq2=kchg(kc2,2)*isign(1,kf2)
168 IF(mstu(19).EQ.1) THEN
169 mstu(19)=0
170 ELSE
171 IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL luerrm(2,
172 & '(LU2ENT:) unphysical flavour combination')
173 ENDIF
174 k(ipa,2)=kf1
175 k(ipa+1,2)=kf2
176
177C...Store partons/particles in K vectors for normal case.
178 IF(ip.GE.0) THEN
179 k(ipa,1)=1
180 IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2
181 k(ipa+1,1)=1
182
183C...Store partons in K vectors for parton shower evolution.
184 ELSE
185 k(ipa,1)=3
186 k(ipa+1,1)=3
187 k(ipa,4)=mstu(5)*(ipa+1)
188 k(ipa,5)=k(ipa,4)
189 k(ipa+1,4)=mstu(5)*ipa
190 k(ipa+1,5)=k(ipa+1,4)
191 ENDIF
192
193C...Check kinematics and store partons/particles in P vectors.
194 IF(pecm.LE.pm1+pm2) CALL luerrm(13,
195 &'(LU2ENT:) energy smaller than sum of masses')
196 pa=sqrt(max(0.,(pecm**2-pm1**2-pm2**2)**2-(2.*pm1*pm2)**2))/
197 &(2.*pecm)
198 p(ipa,3)=pa
199 p(ipa,4)=sqrt(pm1**2+pa**2)
200 p(ipa,5)=pm1
201 p(ipa+1,3)=-pa
202 p(ipa+1,4)=sqrt(pm2**2+pa**2)
203 p(ipa+1,5)=pm2
204
205C...Set N. Optionally fragment/decay.
206 n=ipa+1
207 IF(ip.EQ.0) CALL luexec
208
209 RETURN
210 END
211
212C*********************************************************************
213
214 SUBROUTINE lu3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
215
216C...Purpose: to store three partons or particles in their CM frame,
217C...with the first along the +z axis and the third in the (x,z)
218C...plane with x > 0.
219 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
220 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
221 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
222 SAVE /lujets/,/ludat1/,/ludat2/
223
224C...Standard checks.
225 mstu(28)=0
226 IF(mstu(12).GE.1) CALL lulist(0)
227 ipa=max(1,iabs(ip))
228 IF(ipa.GT.mstu(4)-2) CALL luerrm(21,
229 &'(LU3ENT:) writing outside LUJETS memory')
230 kc1=lucomp(kf1)
231 kc2=lucomp(kf2)
232 kc3=lucomp(kf3)
233 IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL luerrm(12,
234 &'(LU3ENT:) unknown flavour code')
235
236C...Find masses. Reset K, P and V vectors.
237 pm1=0.
238 IF(mstu(10).EQ.1) pm1=p(ipa,5)
239 IF(mstu(10).GE.2) pm1=ulmass(kf1)
240 pm2=0.
241 IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
242 IF(mstu(10).GE.2) pm2=ulmass(kf2)
243 pm3=0.
244 IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
245 IF(mstu(10).GE.2) pm3=ulmass(kf3)
246 DO 110 i=ipa,ipa+2
247 DO 100 j=1,5
248 k(i,j)=0
249 p(i,j)=0.
250 v(i,j)=0.
251 100 CONTINUE
252 110 CONTINUE
253
254C...Check flavours.
255 kq1=kchg(kc1,2)*isign(1,kf1)
256 kq2=kchg(kc2,2)*isign(1,kf2)
257 kq3=kchg(kc3,2)*isign(1,kf3)
258 IF(mstu(19).EQ.1) THEN
259 mstu(19)=0
260 ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN
261 ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.
262 &kq1+kq3.EQ.4)) THEN
263 ELSE
264 CALL luerrm(2,'(LU3ENT:) unphysical flavour combination')
265 ENDIF
266 k(ipa,2)=kf1
267 k(ipa+1,2)=kf2
268 k(ipa+2,2)=kf3
269
270C...Store partons/particles in K vectors for normal case.
271 IF(ip.GE.0) THEN
272 k(ipa,1)=1
273 IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2
274 k(ipa+1,1)=1
275 IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2
276 k(ipa+2,1)=1
277
278C...Store partons in K vectors for parton shower evolution.
279 ELSE
280 k(ipa,1)=3
281 k(ipa+1,1)=3
282 k(ipa+2,1)=3
283 kcs=4
284 IF(kq1.EQ.-1) kcs=5
285 k(ipa,kcs)=mstu(5)*(ipa+1)
286 k(ipa,9-kcs)=mstu(5)*(ipa+2)
287 k(ipa+1,kcs)=mstu(5)*(ipa+2)
288 k(ipa+1,9-kcs)=mstu(5)*ipa
289 k(ipa+2,kcs)=mstu(5)*ipa
290 k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
291 ENDIF
292
293C...Check kinematics.
294 mkerr=0
295 IF(0.5*x1*pecm.LE.pm1.OR.0.5*(2.-x1-x3)*pecm.LE.pm2.OR.
296 &0.5*x3*pecm.LE.pm3) mkerr=1
297 pa1=sqrt(max(1e-10,(0.5*x1*pecm)**2-pm1**2))
298 pa2=sqrt(max(1e-10,(0.5*(2.-x1-x3)*pecm)**2-pm2**2))
299 pa3=sqrt(max(1e-10,(0.5*x3*pecm)**2-pm3**2))
300 cthe2=(pa3**2-pa1**2-pa2**2)/(2.*pa1*pa2)
301 cthe3=(pa2**2-pa1**2-pa3**2)/(2.*pa1*pa3)
302 IF(abs(cthe2).GE.1.001.OR.abs(cthe3).GE.1.001) mkerr=1
303 cthe3=max(-1.,min(1.,cthe3))
304 IF(mkerr.NE.0) CALL luerrm(13,
305 &'(LU3ENT:) unphysical kinematical variable setup')
306
307C...Store partons/particles in P vectors.
308 p(ipa,3)=pa1
309 p(ipa,4)=sqrt(pa1**2+pm1**2)
310 p(ipa,5)=pm1
311 p(ipa+2,1)=pa3*sqrt(1.-cthe3**2)
312 p(ipa+2,3)=pa3*cthe3
313 p(ipa+2,4)=sqrt(pa3**2+pm3**2)
314 p(ipa+2,5)=pm3
315 p(ipa+1,1)=-p(ipa+2,1)
316 p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)
317 p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)
318 p(ipa+1,5)=pm2
319
320C...Set N. Optionally fragment/decay.
321 n=ipa+2
322 IF(ip.EQ.0) CALL luexec
323
324 RETURN
325 END
326
327C*********************************************************************
328
329 SUBROUTINE lu4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
330
331C...Purpose: to store four partons or particles in their CM frame, with
332C...the first along the +z axis, the last in the xz plane with x > 0
333C...and the second having y < 0 and y > 0 with equal probability.
334 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
335 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
336 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
337 SAVE /lujets/,/ludat1/,/ludat2/
338
339C...Standard checks.
340 mstu(28)=0
341 IF(mstu(12).GE.1) CALL lulist(0)
342 ipa=max(1,iabs(ip))
343 IF(ipa.GT.mstu(4)-3) CALL luerrm(21,
344 &'(LU4ENT:) writing outside LUJETS momory')
345 kc1=lucomp(kf1)
346 kc2=lucomp(kf2)
347 kc3=lucomp(kf3)
348 kc4=lucomp(kf4)
349 IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL luerrm(12,
350 &'(LU4ENT:) unknown flavour code')
351
352C...Find masses. Reset K, P and V vectors.
353 pm1=0.
354 IF(mstu(10).EQ.1) pm1=p(ipa,5)
355 IF(mstu(10).GE.2) pm1=ulmass(kf1)
356 pm2=0.
357 IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
358 IF(mstu(10).GE.2) pm2=ulmass(kf2)
359 pm3=0.
360 IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
361 IF(mstu(10).GE.2) pm3=ulmass(kf3)
362 pm4=0.
363 IF(mstu(10).EQ.1) pm4=p(ipa+3,5)
364 IF(mstu(10).GE.2) pm4=ulmass(kf4)
365 DO 110 i=ipa,ipa+3
366 DO 100 j=1,5
367 k(i,j)=0
368 p(i,j)=0.
369 v(i,j)=0.
370 100 CONTINUE
371 110 CONTINUE
372
373C...Check flavours.
374 kq1=kchg(kc1,2)*isign(1,kf1)
375 kq2=kchg(kc2,2)*isign(1,kf2)
376 kq3=kchg(kc3,2)*isign(1,kf3)
377 kq4=kchg(kc4,2)*isign(1,kf4)
378 IF(mstu(19).EQ.1) THEN
379 mstu(19)=0
380 ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN
381 ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.
382 &kq1+kq4.EQ.4)) THEN
383 ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0.)
384 &THEN
385 ELSE
386 CALL luerrm(2,'(LU4ENT:) unphysical flavour combination')
387 ENDIF
388 k(ipa,2)=kf1
389 k(ipa+1,2)=kf2
390 k(ipa+2,2)=kf3
391 k(ipa+3,2)=kf4
392
393C...Store partons/particles in K vectors for normal case.
394 IF(ip.GE.0) THEN
395 k(ipa,1)=1
396 IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2
397 k(ipa+1,1)=1
398 IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))
399 & k(ipa+1,1)=2
400 k(ipa+2,1)=1
401 IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2
402 k(ipa+3,1)=1
403
404C...Store partons for parton shower evolution from q-g-g-qbar or
405C...g-g-g-g event.
406 ELSEIF(kq1+kq2.NE.0) THEN
407 k(ipa,1)=3
408 k(ipa+1,1)=3
409 k(ipa+2,1)=3
410 k(ipa+3,1)=3
411 kcs=4
412 IF(kq1.EQ.-1) kcs=5
413 k(ipa,kcs)=mstu(5)*(ipa+1)
414 k(ipa,9-kcs)=mstu(5)*(ipa+3)
415 k(ipa+1,kcs)=mstu(5)*(ipa+2)
416 k(ipa+1,9-kcs)=mstu(5)*ipa
417 k(ipa+2,kcs)=mstu(5)*(ipa+3)
418 k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
419 k(ipa+3,kcs)=mstu(5)*ipa
420 k(ipa+3,9-kcs)=mstu(5)*(ipa+2)
421
422C...Store partons for parton shower evolution from q-qbar-q-qbar event.
423 ELSE
424 k(ipa,1)=3
425 k(ipa+1,1)=3
426 k(ipa+2,1)=3
427 k(ipa+3,1)=3
428 k(ipa,4)=mstu(5)*(ipa+1)
429 k(ipa,5)=k(ipa,4)
430 k(ipa+1,4)=mstu(5)*ipa
431 k(ipa+1,5)=k(ipa+1,4)
432 k(ipa+2,4)=mstu(5)*(ipa+3)
433 k(ipa+2,5)=k(ipa+2,4)
434 k(ipa+3,4)=mstu(5)*(ipa+2)
435 k(ipa+3,5)=k(ipa+3,4)
436 ENDIF
437
438C...Check kinematics.
439 mkerr=0
440 IF(0.5*x1*pecm.LE.pm1.OR.0.5*x2*pecm.LE.pm2.OR.0.5*(2.-x1-x2-x4)*
441 &pecm.LE.pm3.OR.0.5*x4*pecm.LE.pm4) mkerr=1
442 pa1=sqrt(max(1e-10,(0.5*x1*pecm)**2-pm1**2))
443 pa2=sqrt(max(1e-10,(0.5*x2*pecm)**2-pm2**2))
444 pa4=sqrt(max(1e-10,(0.5*x4*pecm)**2-pm4**2))
445 x24=x1+x2+x4-1.-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2
446 cthe4=(x1*x4-2.*x14)*pecm**2/(4.*pa1*pa4)
447 IF(abs(cthe4).GE.1.002) mkerr=1
448 cthe4=max(-1.,min(1.,cthe4))
449 sthe4=sqrt(1.-cthe4**2)
450 cthe2=(x1*x2-2.*x12)*pecm**2/(4.*pa1*pa2)
451 IF(abs(cthe2).GE.1.002) mkerr=1
452 cthe2=max(-1.,min(1.,cthe2))
453 sthe2=sqrt(1.-cthe2**2)
454 cphi2=((x2*x4-2.*x24)*pecm**2-4.*pa2*cthe2*pa4*cthe4)/
455 &max(1e-8*pecm**2,4.*pa2*sthe2*pa4*sthe4)
456 IF(abs(cphi2).GE.1.05) mkerr=1
457 cphi2=max(-1.,min(1.,cphi2))
458 IF(mkerr.EQ.1) CALL luerrm(13,
459 &'(LU4ENT:) unphysical kinematical variable setup')
460
461C...Store partons/particles in P vectors.
462 p(ipa,3)=pa1
463 p(ipa,4)=sqrt(pa1**2+pm1**2)
464 p(ipa,5)=pm1
465 p(ipa+3,1)=pa4*sthe4
466 p(ipa+3,3)=pa4*cthe4
467 p(ipa+3,4)=sqrt(pa4**2+pm4**2)
468 p(ipa+3,5)=pm4
469 p(ipa+1,1)=pa2*sthe2*cphi2
470 p(ipa+1,2)=pa2*sthe2*sqrt(1.-cphi2**2)*(-1.)**int(rlu(0)+0.5)
471 p(ipa+1,3)=pa2*cthe2
472 p(ipa+1,4)=sqrt(pa2**2+pm2**2)
473 p(ipa+1,5)=pm2
474 p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)
475 p(ipa+2,2)=-p(ipa+1,2)
476 p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)
477 p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)
478 p(ipa+2,5)=pm3
479
480C...Set N. Optionally fragment/decay.
481 n=ipa+3
482 IF(ip.EQ.0) CALL luexec
483
484 RETURN
485 END
486
487C*********************************************************************
488
489 SUBROUTINE lujoin(NJOIN,IJOIN)
490
491C...Purpose: to connect a sequence of partons with colour flow indices,
492C...as required for subsequent shower evolution (or other operations).
493 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
494 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
495 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
496 SAVE /lujets/,/ludat1/,/ludat2/
497 dimension ijoin(*)
498
499C...Check that partons are of right types to be connected.
500 IF(njoin.LT.2) GOTO 120
501 kqsum=0
502 DO 100 ijn=1,njoin
503 i=ijoin(ijn)
504 IF(i.LE.0.OR.i.GT.n) GOTO 120
505 IF(k(i,1).LT.1.OR.k(i,1).GT.3) GOTO 120
506 kc=lucomp(k(i,2))
507 IF(kc.EQ.0) GOTO 120
508 kq=kchg(kc,2)*isign(1,k(i,2))
509 IF(kq.EQ.0) GOTO 120
510 IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) GOTO 120
511 IF(kq.NE.2) kqsum=kqsum+kq
512 IF(ijn.EQ.1) kqs=kq
513 100 CONTINUE
514 IF(kqsum.NE.0) GOTO 120
515
516C...Connect the partons sequentially (closing for gluon loop).
517 kcs=(9-kqs)/2
518 IF(kqs.EQ.2) kcs=int(4.5+rlu(0))
519 DO 110 ijn=1,njoin
520 i=ijoin(ijn)
521 k(i,1)=3
522 IF(ijn.NE.1) ip=ijoin(ijn-1)
523 IF(ijn.EQ.1) ip=ijoin(njoin)
524 IF(ijn.NE.njoin) in=ijoin(ijn+1)
525 IF(ijn.EQ.njoin) in=ijoin(1)
526 k(i,kcs)=mstu(5)*in
527 k(i,9-kcs)=mstu(5)*ip
528 IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0
529 IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0
530 110 CONTINUE
531
532C...Error exit: no action taken.
533 RETURN
534 120 CALL luerrm(12,
535 &'(LUJOIN:) given entries can not be joined by one string')
536
537 RETURN
538 END
539
540C*********************************************************************
541
542 SUBROUTINE lugive(CHIN)
543
544C...Purpose: to set values of commonblock variables (also in PYTHIA!).
545 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
546 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
547 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
548 common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
549 common/ludat4/chaf(500)
550 CHARACTER CHAF*8
551 common/ludatr/mrlu(6),rrlu(100)
552 common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
553 common/pypars/mstp(200),parp(200),msti(200),pari(200)
554 common/pyint1/mint(400),vint(400)
555 common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
556 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
557 common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
558 common/pyint5/ngen(0:200,3),xsec(0:200,3)
559 common/pyint6/proc(0:200)
560 common/pyint7/sigt(0:6,0:6,0:5)
561 CHARACTER PROC*28
562 SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/,/ludat4/,/ludatr/
563 SAVE /pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,
564 &/pyint5/,/pyint6/,/pyint7/
565 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
566 &CHNEW2*28,CHNAM*4,CHVAR(43)*4,CHALP(2)*26,CHIND*8,CHINI*10,
567 &CHINR*16
568 dimension msvar(43,8)
569
570C...For each variable to be translated give: name,
571C...integer/real/character, no. of indices, lower&upper index bounds.
572 DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
573 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU',
574 &'RRLU','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
575 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
576 &'WIDP','WIDE','WIDS','NGEN','XSEC','PROC','SIGT'/
577 DATA ((msvar(i,j),j=1,8),i=1,43)/ 1,7*0, 1,2,1,4000,1,5,2*0,
578 & 2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
579 & 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
580 & 1,2,1,500,1,3,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
581 & 2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,2000,1,2,2*0,
582 & 2,1,1,2000,4*0, 1,2,1,2000,1,5,2*0, 3,1,1,500,4*0,
583 & 1,1,1,6,4*0, 2,1,1,100,4*0,
584 & 1,7*0, 1,1,1,200,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
585 & 1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
586 & 1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,200,4*0,
587 & 1,2,1,200,1,2,2*0, 2,2,1,200,1,20,2*0, 1,3,1,40,1,4,1,2,
588 & 2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
589 & 2,2,21,40,0,40,2*0, 2,2,21,40,0,40,2*0, 2,2,21,40,1,3,2*0,
590 & 1,2,0,200,1,3,2*0, 2,2,0,200,1,3,2*0, 4,1,0,200,4*0,
591 & 2,3,0,6,0,6,0,5/
592 DATA chalp/'abcdefghijklmnopqrstuvwxyz',
593 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
594
595C...Length of character variable. Subdivide it into instructions.
596 IF(mstu(12).GE.1) CALL lulist(0)
597 chbit=chin//' '
598 lbit=101
599 100 lbit=lbit-1
600 IF(chbit(lbit:lbit).EQ.' ') GOTO 100
601 ltot=0
602 DO 110 lcom=1,lbit
603 IF(chbit(lcom:lcom).EQ.' ') GOTO 110
604 ltot=ltot+1
605 chfix(ltot:ltot)=chbit(lcom:lcom)
606 110 CONTINUE
607 llow=0
608 120 lhig=llow+1
609 130 lhig=lhig+1
610 IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') GOTO 130
611 lbit=lhig-llow-1
612 chbit(1:lbit)=chfix(llow+1:lhig-1)
613
614C...Identify commonblock variable.
615 lnam=1
616 140 lnam=lnam+1
617 IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.
618 &lnam.LE.4) GOTO 140
619 chnam=chbit(1:lnam-1)//' '
620 DO 160 lcom=1,lnam-1
621 DO 150 lalp=1,26
622 IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=
623 &chalp(2)(lalp:lalp)
624 150 CONTINUE
625 160 CONTINUE
626 ivar=0
627 DO 170 iv=1,43
628 IF(chnam.EQ.chvar(iv)) ivar=iv
629 170 CONTINUE
630 IF(ivar.EQ.0) THEN
631 CALL luerrm(18,'(LUGIVE:) do not recognize variable '//chnam)
632 llow=lhig
633 IF(llow.LT.ltot) GOTO 120
634 RETURN
635 ENDIF
636
637C...Identify any indices.
638 i1=0
639 i2=0
640 i3=0
641 nindx=0
642 IF(chbit(lnam:lnam).EQ.'(') THEN
643 lind=lnam
644 180 lind=lind+1
645 IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 180
646 chind=' '
647 IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c').
648 & and.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17)) THEN
649 chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)
650 READ(chind,'(I8)') kf
651 i1=lucomp(kf)
652 ELSEIF(chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.
653 & 'c') THEN
654 CALL luerrm(18,'(LUGIVE:) not allowed to use C index for '//
655 & chnam)
656 llow=lhig
657 IF(llow.LT.ltot) GOTO 120
658 RETURN
659 ELSE
660 chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
661 READ(chind,'(I8)') i1
662 ENDIF
663 lnam=lind
664 IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
665 nindx=1
666 ENDIF
667 IF(chbit(lnam:lnam).EQ.',') THEN
668 lind=lnam
669 190 lind=lind+1
670 IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 190
671 chind=' '
672 chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
673 READ(chind,'(I8)') i2
674 lnam=lind
675 IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
676 nindx=2
677 ENDIF
678 IF(chbit(lnam:lnam).EQ.',') THEN
679 lind=lnam
680 200 lind=lind+1
681 IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 200
682 chind=' '
683 chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
684 READ(chind,'(I8)') i3
685 lnam=lind+1
686 nindx=3
687 ENDIF
688
689C...Check that indices allowed.
690 ierr=0
691 IF(nindx.NE.msvar(ivar,2)) ierr=1
692 IF(nindx.GE.1.AND.(i1.LT.msvar(ivar,3).OR.i1.GT.msvar(ivar,4)))
693 &ierr=2
694 IF(nindx.GE.2.AND.(i2.LT.msvar(ivar,5).OR.i2.GT.msvar(ivar,6)))
695 &ierr=3
696 IF(nindx.EQ.3.AND.(i3.LT.msvar(ivar,7).OR.i3.GT.msvar(ivar,8)))
697 &ierr=4
698 IF(chbit(lnam:lnam).NE.'=') ierr=5
699 IF(ierr.GE.1) THEN
700 CALL luerrm(18,'(LUGIVE:) unallowed indices for '//
701 & chbit(1:lnam-1))
702 llow=lhig
703 IF(llow.LT.ltot) GOTO 120
704 RETURN
705 ENDIF
706
707C...Save old value of variable.
708 IF(ivar.EQ.1) THEN
709 iold=n
710 ELSEIF(ivar.EQ.2) THEN
711 iold=k(i1,i2)
712 ELSEIF(ivar.EQ.3) THEN
713 rold=p(i1,i2)
714 ELSEIF(ivar.EQ.4) THEN
715 rold=v(i1,i2)
716 ELSEIF(ivar.EQ.5) THEN
717 iold=mstu(i1)
718 ELSEIF(ivar.EQ.6) THEN
719 rold=paru(i1)
720 ELSEIF(ivar.EQ.7) THEN
721 iold=mstj(i1)
722 ELSEIF(ivar.EQ.8) THEN
723 rold=parj(i1)
724 ELSEIF(ivar.EQ.9) THEN
725 iold=kchg(i1,i2)
726 ELSEIF(ivar.EQ.10) THEN
727 rold=pmas(i1,i2)
728 ELSEIF(ivar.EQ.11) THEN
729 rold=parf(i1)
730 ELSEIF(ivar.EQ.12) THEN
731 rold=vckm(i1,i2)
732 ELSEIF(ivar.EQ.13) THEN
733 iold=mdcy(i1,i2)
734 ELSEIF(ivar.EQ.14) THEN
735 iold=mdme(i1,i2)
736 ELSEIF(ivar.EQ.15) THEN
737 rold=brat(i1)
738 ELSEIF(ivar.EQ.16) THEN
739 iold=kfdp(i1,i2)
740 ELSEIF(ivar.EQ.17) THEN
741 chold=chaf(i1)
742 ELSEIF(ivar.EQ.18) THEN
743 iold=mrlu(i1)
744 ELSEIF(ivar.EQ.19) THEN
745 rold=rrlu(i1)
746 ELSEIF(ivar.EQ.20) THEN
747 iold=msel
748 ELSEIF(ivar.EQ.21) THEN
749 iold=msub(i1)
750 ELSEIF(ivar.EQ.22) THEN
751 iold=kfin(i1,i2)
752 ELSEIF(ivar.EQ.23) THEN
753 rold=ckin(i1)
754 ELSEIF(ivar.EQ.24) THEN
755 iold=mstp(i1)
756 ELSEIF(ivar.EQ.25) THEN
757 rold=parp(i1)
758 ELSEIF(ivar.EQ.26) THEN
759 iold=msti(i1)
760 ELSEIF(ivar.EQ.27) THEN
761 rold=pari(i1)
762 ELSEIF(ivar.EQ.28) THEN
763 iold=mint(i1)
764 ELSEIF(ivar.EQ.29) THEN
765 rold=vint(i1)
766 ELSEIF(ivar.EQ.30) THEN
767 iold=iset(i1)
768 ELSEIF(ivar.EQ.31) THEN
769 iold=kfpr(i1,i2)
770 ELSEIF(ivar.EQ.32) THEN
771 rold=coef(i1,i2)
772 ELSEIF(ivar.EQ.33) THEN
773 iold=icol(i1,i2,i3)
774 ELSEIF(ivar.EQ.34) THEN
775 rold=xsfx(i1,i2)
776 ELSEIF(ivar.EQ.35) THEN
777 iold=isig(i1,i2)
778 ELSEIF(ivar.EQ.36) THEN
779 rold=sigh(i1)
780 ELSEIF(ivar.EQ.37) THEN
781 rold=widp(i1,i2)
782 ELSEIF(ivar.EQ.38) THEN
783 rold=wide(i1,i2)
784 ELSEIF(ivar.EQ.39) THEN
785 rold=wids(i1,i2)
786 ELSEIF(ivar.EQ.40) THEN
787 iold=ngen(i1,i2)
788 ELSEIF(ivar.EQ.41) THEN
789 rold=xsec(i1,i2)
790 ELSEIF(ivar.EQ.42) THEN
791 chold2=proc(i1)
792 ELSEIF(ivar.EQ.43) THEN
793 rold=sigt(i1,i2,i3)
794 ENDIF
795
796C...Print current value of variable. Loop back.
797 IF(lnam.GE.lbit) THEN
798 chbit(lnam:14)=' '
799 chbit(15:60)=' has the value '
800 IF(msvar(ivar,1).EQ.1) THEN
801 WRITE(chbit(51:60),'(I10)') iold
802 ELSEIF(msvar(ivar,1).EQ.2) THEN
803 WRITE(chbit(47:60),'(F14.5)') rold
804 ELSEIF(msvar(ivar,1).EQ.3) THEN
805 chbit(53:60)=chold
806 ELSE
807 chbit(33:60)=chold
808 ENDIF
809 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
810 llow=lhig
811 IF(llow.LT.ltot) GOTO 120
812 RETURN
813 ENDIF
814
815C...Read in new variable value.
816 IF(msvar(ivar,1).EQ.1) THEN
817 chini=' '
818 chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)
819 READ(chini,'(I10)') inew
820 ELSEIF(msvar(ivar,1).EQ.2) THEN
821 chinr=' '
822 chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)
823 READ(chinr,'(F16.2)') rnew
824 ELSEIF(msvar(ivar,1).EQ.3) THEN
825 chnew=chbit(lnam+1:lbit)//' '
826 ELSE
827 chnew2=chbit(lnam+1:lbit)//' '
828 ENDIF
829
830C...Store new variable value.
831 IF(ivar.EQ.1) THEN
832 n=inew
833 ELSEIF(ivar.EQ.2) THEN
834 k(i1,i2)=inew
835 ELSEIF(ivar.EQ.3) THEN
836 p(i1,i2)=rnew
837 ELSEIF(ivar.EQ.4) THEN
838 v(i1,i2)=rnew
839 ELSEIF(ivar.EQ.5) THEN
840 mstu(i1)=inew
841 ELSEIF(ivar.EQ.6) THEN
842 paru(i1)=rnew
843 ELSEIF(ivar.EQ.7) THEN
844 mstj(i1)=inew
845 ELSEIF(ivar.EQ.8) THEN
846 parj(i1)=rnew
847 ELSEIF(ivar.EQ.9) THEN
848 kchg(i1,i2)=inew
849 ELSEIF(ivar.EQ.10) THEN
850 pmas(i1,i2)=rnew
851 ELSEIF(ivar.EQ.11) THEN
852 parf(i1)=rnew
853 ELSEIF(ivar.EQ.12) THEN
854 vckm(i1,i2)=rnew
855 ELSEIF(ivar.EQ.13) THEN
856 mdcy(i1,i2)=inew
857 ELSEIF(ivar.EQ.14) THEN
858 mdme(i1,i2)=inew
859 ELSEIF(ivar.EQ.15) THEN
860 brat(i1)=rnew
861 ELSEIF(ivar.EQ.16) THEN
862 kfdp(i1,i2)=inew
863 ELSEIF(ivar.EQ.17) THEN
864 chaf(i1)=chnew
865 ELSEIF(ivar.EQ.18) THEN
866 mrlu(i1)=inew
867 ELSEIF(ivar.EQ.19) THEN
868 rrlu(i1)=rnew
869 ELSEIF(ivar.EQ.20) THEN
870 msel=inew
871 ELSEIF(ivar.EQ.21) THEN
872 msub(i1)=inew
873 ELSEIF(ivar.EQ.22) THEN
874 kfin(i1,i2)=inew
875 ELSEIF(ivar.EQ.23) THEN
876 ckin(i1)=rnew
877 ELSEIF(ivar.EQ.24) THEN
878 mstp(i1)=inew
879 ELSEIF(ivar.EQ.25) THEN
880 parp(i1)=rnew
881 ELSEIF(ivar.EQ.26) THEN
882 msti(i1)=inew
883 ELSEIF(ivar.EQ.27) THEN
884 pari(i1)=rnew
885 ELSEIF(ivar.EQ.28) THEN
886 mint(i1)=inew
887 ELSEIF(ivar.EQ.29) THEN
888 vint(i1)=rnew
889 ELSEIF(ivar.EQ.30) THEN
890 iset(i1)=inew
891 ELSEIF(ivar.EQ.31) THEN
892 kfpr(i1,i2)=inew
893 ELSEIF(ivar.EQ.32) THEN
894 coef(i1,i2)=rnew
895 ELSEIF(ivar.EQ.33) THEN
896 icol(i1,i2,i3)=inew
897 ELSEIF(ivar.EQ.34) THEN
898 xsfx(i1,i2)=rnew
899 ELSEIF(ivar.EQ.35) THEN
900 isig(i1,i2)=inew
901 ELSEIF(ivar.EQ.36) THEN
902 sigh(i1)=rnew
903 ELSEIF(ivar.EQ.37) THEN
904 widp(i1,i2)=rnew
905 ELSEIF(ivar.EQ.38) THEN
906 wide(i1,i2)=rnew
907 ELSEIF(ivar.EQ.39) THEN
908 wids(i1,i2)=rnew
909 ELSEIF(ivar.EQ.40) THEN
910 ngen(i1,i2)=inew
911 ELSEIF(ivar.EQ.41) THEN
912 xsec(i1,i2)=rnew
913 ELSEIF(ivar.EQ.42) THEN
914 proc(i1)=chnew2
915 ELSEIF(ivar.EQ.43) THEN
916 sigt(i1,i2,i3)=rnew
917 ENDIF
918
919C...Write old and new value. Loop back.
920 chbit(lnam:14)=' '
921 chbit(15:60)=' changed from to '
922 IF(msvar(ivar,1).EQ.1) THEN
923 WRITE(chbit(33:42),'(I10)') iold
924 WRITE(chbit(51:60),'(I10)') inew
925 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
926 ELSEIF(msvar(ivar,1).EQ.2) THEN
927 WRITE(chbit(29:42),'(F14.5)') rold
928 WRITE(chbit(47:60),'(F14.5)') rnew
929 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
930 ELSEIF(msvar(ivar,1).EQ.3) THEN
931 chbit(35:42)=chold
932 chbit(53:60)=chnew
933 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
934 ELSE
935 chbit(15:88)=' changed from '//chold2//' to '//chnew2
936 IF(mstu(13).GE.1) WRITE(mstu(11),5100) chbit(1:88)
937 ENDIF
938 llow=lhig
939 IF(llow.LT.ltot) GOTO 120
940
941C...Format statement for output on unit MSTU(11) (by default 6).
942 5000 FORMAT(5x,a60)
943 5100 FORMAT(5x,a88)
944
945 RETURN
946 END
947
948C*********************************************************************
949
950 SUBROUTINE luexec
951
952C...Purpose: to administrate the fragmentation and decay chain.
953 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
954 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
955 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
956 common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
957 SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
958 dimension ps(2,6)
959
960C...Initialize and reset.
961 mstu(24)=0
962 IF(mstu(12).GE.1) CALL lulist(0)
963 mstu(31)=mstu(31)+1
964 mstu(1)=0
965 mstu(2)=0
966 mstu(3)=0
967 IF(mstu(17).LE.0) mstu(90)=0
968 mcons=1
969
970C...Sum up momentum, energy and charge for starting entries.
971 nsav=n
972 DO 110 i=1,2
973 DO 100 j=1,6
974 ps(i,j)=0.
975 100 CONTINUE
976 110 CONTINUE
977 DO 130 i=1,n
978 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 130
979 DO 120 j=1,4
980 ps(1,j)=ps(1,j)+p(i,j)
981 120 CONTINUE
982 ps(1,6)=ps(1,6)+luchge(k(i,2))
983 130 CONTINUE
984 paru(21)=ps(1,4)
985
986C...Prepare system for subsequent fragmentation/decay.
987 CALL luprep(0)
988
989C...Loop through jet fragmentation and particle decays.
990 mbe=0
991 140 mbe=mbe+1
992 ip=0
993 150 ip=ip+1
994 kc=0
995 IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=lucomp(k(ip,2))
996 IF(kc.EQ.0) THEN
997
998C...Particle decay if unstable and allowed. Save long-lived particle
999C...decays until second pass after Bose-Einstein effects.
1000 ELSEIF(kchg(kc,2).EQ.0) THEN
1001 IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe.
1002 & eq.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))
1003 & CALL ludecy(ip)
1004
1005C...Decay products may develop a shower.
1006 IF(mstj(92).GT.0) THEN
1007 ip1=mstj(92)
1008 qmax=sqrt(max(0.,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,
1009 & 1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))
1010 CALL lushow(ip1,ip1+1,qmax)
1011 CALL luprep(ip1)
1012 mstj(92)=0
1013 ELSEIF(mstj(92).LT.0) THEN
1014 ip1=-mstj(92)
1015 CALL lushow(ip1,-3,p(ip,5))
1016 CALL luprep(ip1)
1017 mstj(92)=0
1018 ENDIF
1019
1020C...Jet fragmentation: string or independent fragmentation.
1021 ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN
1022 mfrag=mstj(1)
1023 IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2
1024 IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN
1025 IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.
1026 & k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN
1027 IF(kchg(lucomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)
1028 ENDIF
1029 ENDIF
1030 IF(mfrag.EQ.1) CALL lustrf(ip)
1031 IF(mfrag.EQ.2) CALL luindf(ip)
1032 IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0
1033 IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0
1034 ENDIF
1035
1036C...Loop back if enough space left in LUJETS and no error abort.
1037 IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN
1038 ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN
1039 GOTO 150
1040 ELSEIF(ip.LT.n) THEN
1041 CALL luerrm(11,'(LUEXEC:) no more memory left in LUJETS')
1042 ENDIF
1043
1044C...Include simple Bose-Einstein effect parametrization if desired.
1045 IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN
1046 CALL luboei(nsav)
1047 GOTO 140
1048 ENDIF
1049
1050C...Check that momentum, energy and charge were conserved.
1051 DO 170 i=1,n
1052 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 170
1053 DO 160 j=1,4
1054 ps(2,j)=ps(2,j)+p(i,j)
1055 160 CONTINUE
1056 ps(2,6)=ps(2,6)+luchge(k(i,2))
1057 170 CONTINUE
1058 pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-
1059 &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1.+abs(ps(2,4))+abs(ps(1,4)))
1060 IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL luerrm(15,
1061 &'(LUEXEC:) four-momentum was not conserved')
1062 IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1) CALL luerrm(15,
1063 &'(LUEXEC:) charge was not conserved')
1064
1065 RETURN
1066 END
1067
1068C*********************************************************************
1069
1070 SUBROUTINE luprep(IP)
1071
1072C...Purpose: to rearrange partons along strings, to allow small systems
1073C...to collapse into one or two particles and to check flavours.
1074 IMPLICIT DOUBLE PRECISION(d)
1075 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1076 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1077 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1078 common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
1079 SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
1080 dimension dps(5),dpc(5),ue(3)
1081
1082C...Rearrange parton shower product listing along strings: begin loop.
1083 i1=n
1084 DO 130 mqgst=1,2
1085 DO 120 i=max(1,ip),n
1086 IF(k(i,1).NE.3) GOTO 120
1087 kc=lucomp(k(i,2))
1088 IF(kc.EQ.0) GOTO 120
1089 kq=kchg(kc,2)
1090 IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) GOTO 120
1091
1092C...Pick up loose string end.
1093 kcs=4
1094 IF(kq*isign(1,k(i,2)).LT.0) kcs=5
1095 ia=i
1096 nstp=0
1097 100 nstp=nstp+1
1098 IF(nstp.GT.4*n) THEN
1099 CALL luerrm(14,'(LUPREP:) caught in infinite loop')
1100 RETURN
1101 ENDIF
1102
1103C...Copy undecayed parton.
1104 IF(k(ia,1).EQ.3) THEN
1105 IF(i1.GE.mstu(4)-mstu(32)-5) THEN
1106 CALL luerrm(11,'(LUPREP:) no more memory left in LUJETS')
1107 RETURN
1108 ENDIF
1109 i1=i1+1
1110 k(i1,1)=2
1111 IF(nstp.GE.2.AND.iabs(k(ia,2)).NE.21) k(i1,1)=1
1112 k(i1,2)=k(ia,2)
1113 k(i1,3)=ia
1114 k(i1,4)=0
1115 k(i1,5)=0
1116 DO 110 j=1,5
1117 p(i1,j)=p(ia,j)
1118 v(i1,j)=v(ia,j)
1119 110 CONTINUE
1120 k(ia,1)=k(ia,1)+10
1121 IF(k(i1,1).EQ.1) GOTO 120
1122 ENDIF
1123
1124C...Go to next parton in colour space.
1125 ib=ia
1126 IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5)).
1127 &ne.0) THEN
1128 ia=mod(k(ib,kcs),mstu(5))
1129 k(ib,kcs)=k(ib,kcs)+mstu(5)**2
1130 mrev=0
1131 ELSE
1132 IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),mstu(5)).
1133 & eq.0) kcs=9-kcs
1134 ia=mod(k(ib,kcs)/mstu(5),mstu(5))
1135 k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
1136 mrev=1
1137 ENDIF
1138 IF(ia.LE.0.OR.ia.GT.n) THEN
1139 CALL luerrm(12,'(LUPREP:) colour rearrangement failed')
1140 RETURN
1141 ENDIF
1142 IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
1143 &mstu(5)).EQ.ib) THEN
1144 IF(mrev.EQ.1) kcs=9-kcs
1145 IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
1146 k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
1147 ELSE
1148 IF(mrev.EQ.0) kcs=9-kcs
1149 IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
1150 k(ia,kcs)=k(ia,kcs)+mstu(5)**2
1151 ENDIF
1152 IF(ia.NE.i) GOTO 100
1153 k(i1,1)=1
1154 120 CONTINUE
1155 130 CONTINUE
1156 n=i1
1157 IF(mstj(14).LT.0) RETURN
1158
1159C...Find lowest-mass colour singlet jet system, OK if above threshold.
1160 IF(mstj(14).EQ.0) GOTO 320
1161 ns=n
1162 140 nsin=n-ns
1163 pdm=1.+parj(32)
1164 ic=0
1165 DO 190 i=max(1,ip),ns
1166 IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
1167 ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
1168 nsin=nsin+1
1169 ic=i
1170 DO 150 j=1,4
1171 dps(j)=p(i,j)
1172 150 CONTINUE
1173 mstj(93)=1
1174 dps(5)=ulmass(k(i,2))
1175 ELSEIF(k(i,1).EQ.2) THEN
1176 DO 160 j=1,4
1177 dps(j)=dps(j)+p(i,j)
1178 160 CONTINUE
1179 ELSEIF(ic.NE.0.AND.kchg(lucomp(k(i,2)),2).NE.0) THEN
1180 DO 170 j=1,4
1181 dps(j)=dps(j)+p(i,j)
1182 170 CONTINUE
1183 mstj(93)=1
1184 dps(5)=dps(5)+ulmass(k(i,2))
1185 pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-dps(5)
1186 IF(pd.LT.pdm) THEN
1187 pdm=pd
1188 DO 180 j=1,5
1189 dpc(j)=dps(j)
1190 180 CONTINUE
1191 ic1=ic
1192 ic2=i
1193 ENDIF
1194 ic=0
1195 ELSE
1196 nsin=nsin+1
1197 ENDIF
1198 190 CONTINUE
1199 IF(pdm.GE.parj(32)) GOTO 320
1200
1201C...Fill small-mass system as cluster.
1202 nsav=n
1203 pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
1204 k(n+1,1)=11
1205 k(n+1,2)=91
1206 k(n+1,3)=ic1
1207 k(n+1,4)=n+2
1208 k(n+1,5)=n+3
1209 p(n+1,1)=dpc(1)
1210 p(n+1,2)=dpc(2)
1211 p(n+1,3)=dpc(3)
1212 p(n+1,4)=dpc(4)
1213 p(n+1,5)=pecm
1214
1215C...Form two particles from flavours of lowest-mass system, if feasible.
1216 k(n+2,1)=1
1217 k(n+3,1)=1
1218 IF(mstu(16).NE.2) THEN
1219 k(n+2,3)=n+1
1220 k(n+3,3)=n+1
1221 ELSE
1222 k(n+2,3)=ic1
1223 k(n+3,3)=ic2
1224 ENDIF
1225 k(n+2,4)=0
1226 k(n+3,4)=0
1227 k(n+2,5)=0
1228 k(n+3,5)=0
1229 IF(iabs(k(ic1,2)).NE.21) THEN
1230 kc1=lucomp(k(ic1,2))
1231 kc2=lucomp(k(ic2,2))
1232 IF(kc1.EQ.0.OR.kc2.EQ.0) GOTO 320
1233 kq1=kchg(kc1,2)*isign(1,k(ic1,2))
1234 kq2=kchg(kc2,2)*isign(1,k(ic2,2))
1235 IF(kq1+kq2.NE.0) GOTO 320
1236 200 CALL lukfdi(k(ic1,2),0,kfln,k(n+2,2))
1237 CALL lukfdi(k(ic2,2),-kfln,kfldmp,k(n+3,2))
1238 IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 200
1239 ELSE
1240 IF(iabs(k(ic2,2)).NE.21) GOTO 320
1241 210 CALL lukfdi(1+int((2.+parj(2))*rlu(0)),0,kfln,kfdmp)
1242 CALL lukfdi(kfln,0,kflm,k(n+2,2))
1243 CALL lukfdi(-kfln,-kflm,kfldmp,k(n+3,2))
1244 IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 210
1245 ENDIF
1246 p(n+2,5)=ulmass(k(n+2,2))
1247 p(n+3,5)=ulmass(k(n+3,2))
1248 IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm.AND.nsin.EQ.1) GOTO 320
1249 IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) GOTO 260
1250
1251C...Perform two-particle decay of jet system, if possible.
1252 IF(pecm.GE.0.02*dpc(4)) THEN
1253 pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
1254 & (p(n+2,5)-p(n+3,5))**2))/(2.*pecm)
1255 ue(3)=2.*rlu(0)-1.
1256 phi=paru(2)*rlu(0)
1257 ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
1258 ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
1259 DO 220 j=1,3
1260 p(n+2,j)=pa*ue(j)
1261 p(n+3,j)=-pa*ue(j)
1262 220 CONTINUE
1263 p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
1264 p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
1265 mstu(33)=1
1266 CALL ludbrb(n+2,n+3,0.,0.,dpc(1)/dpc(4),dpc(2)/dpc(4),
1267 & dpc(3)/dpc(4))
1268 ELSE
1269 np=0
1270 DO 230 i=ic1,ic2
1271 IF(k(i,1).EQ.1.OR.k(i,1).EQ.2) np=np+1
1272 230 CONTINUE
1273 ha=p(ic1,4)*p(ic2,4)-p(ic1,1)*p(ic2,1)-p(ic1,2)*p(ic2,2)-
1274 & p(ic1,3)*p(ic2,3)
1275 IF(np.GE.3.OR.ha.LE.1.25*p(ic1,5)*p(ic2,5)) GOTO 260
1276 hd1=0.5*(p(n+2,5)**2-p(ic1,5)**2)
1277 hd2=0.5*(p(n+3,5)**2-p(ic2,5)**2)
1278 hr=sqrt(max(0.,((ha-hd1-hd2)**2-(p(n+2,5)*p(n+3,5))**2)/
1279 & (ha**2-(p(ic1,5)*p(ic2,5))**2)))-1.
1280 hc=p(ic1,5)**2+2.*ha+p(ic2,5)**2
1281 hk1=((p(ic2,5)**2+ha)*hr+hd1-hd2)/hc
1282 hk2=((p(ic1,5)**2+ha)*hr+hd2-hd1)/hc
1283 DO 240 j=1,4
1284 p(n+2,j)=(1.+hk1)*p(ic1,j)-hk2*p(ic2,j)
1285 p(n+3,j)=(1.+hk2)*p(ic2,j)-hk1*p(ic1,j)
1286 240 CONTINUE
1287 ENDIF
1288 DO 250 j=1,4
1289 v(n+1,j)=v(ic1,j)
1290 v(n+2,j)=v(ic1,j)
1291 v(n+3,j)=v(ic2,j)
1292 250 CONTINUE
1293 v(n+1,5)=0.
1294 v(n+2,5)=0.
1295 v(n+3,5)=0.
1296 n=n+3
1297 GOTO 300
1298
1299C...Else form one particle from the flavours available, if possible.
1300 260 k(n+1,5)=n+2
1301 IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN
1302 GOTO 320
1303 ELSEIF(iabs(k(ic1,2)).NE.21) THEN
1304 CALL lukfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))
1305 ELSE
1306 kfln=1+int((2.+parj(2))*rlu(0))
1307 CALL lukfdi(kfln,-kfln,kfldmp,k(n+2,2))
1308 ENDIF
1309 IF(k(n+2,2).EQ.0) GOTO 260
1310 p(n+2,5)=ulmass(k(n+2,2))
1311
1312C...Find parton/particle which combines to largest extra mass.
1313 ir=0
1314 ha=0.
1315 hsm=0.
1316 DO 280 mcomb=1,3
1317 IF(ir.NE.0) GOTO 280
1318 DO 270 i=max(1,ip),n
1319 IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2.
1320 &and.k(i,1).GE.1.AND.k(i,1).LE.2)) GOTO 270
1321 IF(mcomb.EQ.1) kci=lucomp(k(i,2))
1322 IF(mcomb.EQ.1.AND.kci.EQ.0) GOTO 270
1323 IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) GOTO 270
1324 IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
1325 &GOTO 270
1326 hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
1327 hsr=2.*hcr+pecm**2-p(n+2,5)**2-2.*p(n+2,5)*p(i,5)
1328 IF(hsr.GT.hsm) THEN
1329 ir=i
1330 ha=hcr
1331 hsm=hsr
1332 ENDIF
1333 270 CONTINUE
1334 280 CONTINUE
1335
1336C...Shuffle energy and momentum to put new particle on mass shell.
1337 IF(ir.NE.0) THEN
1338 hb=pecm**2+ha
1339 hc=p(n+2,5)**2+ha
1340 hd=p(ir,5)**2+ha
1341 hk2=0.5*(hb*sqrt(max(0.,((hb+hc)**2-4.*(hb+hd)*p(n+2,5)**2)/
1342 & (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)
1343 hk1=(0.5*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
1344 DO 290 j=1,4
1345 p(n+2,j)=(1.+hk1)*dpc(j)-hk2*p(ir,j)
1346 p(ir,j)=(1.+hk2)*p(ir,j)-hk1*dpc(j)
1347 v(n+1,j)=v(ic1,j)
1348 v(n+2,j)=v(ic1,j)
1349 290 CONTINUE
1350 v(n+1,5)=0.
1351 v(n+2,5)=0.
1352 n=n+2
1353 ELSE
1354 CALL luerrm(3,'(LUPREP:) no match for collapsing cluster')
1355 RETURN
1356 ENDIF
1357
1358C...Mark collapsed system and store daughter pointers. Iterate.
1359 300 DO 310 i=ic1,ic2
1360 IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.kchg(lucomp(k(i,2)),2).NE.0)
1361 &THEN
1362 k(i,1)=k(i,1)+10
1363 IF(mstu(16).NE.2) THEN
1364 k(i,4)=nsav+1
1365 k(i,5)=nsav+1
1366 ELSE
1367 k(i,4)=nsav+2
1368 k(i,5)=n
1369 ENDIF
1370 ENDIF
1371 310 CONTINUE
1372 IF(n.LT.mstu(4)-mstu(32)-5) GOTO 140
1373
1374C...Check flavours and invariant masses in parton systems.
1375 320 np=0
1376 kfn=0
1377 kqs=0
1378 DO 330 j=1,5
1379 dps(j)=0.
1380 330 CONTINUE
1381 DO 360 i=max(1,ip),n
1382 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 360
1383 kc=lucomp(k(i,2))
1384 IF(kc.EQ.0) GOTO 360
1385 kq=kchg(kc,2)*isign(1,k(i,2))
1386 IF(kq.EQ.0) GOTO 360
1387 np=np+1
1388 IF(kq.NE.2) THEN
1389 kfn=kfn+1
1390 kqs=kqs+kq
1391 mstj(93)=1
1392 dps(5)=dps(5)+ulmass(k(i,2))
1393 ENDIF
1394 DO 340 j=1,4
1395 dps(j)=dps(j)+p(i,j)
1396 340 CONTINUE
1397 IF(k(i,1).EQ.1) THEN
1398 IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) CALL
1399 & luerrm(2,'(LUPREP:) unphysical flavour combination')
1400 IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
1401 & (0.9*parj(32)+dps(5))**2) CALL luerrm(3,
1402 & '(LUPREP:) too small mass in jet system')
1403 np=0
1404 kfn=0
1405 kqs=0
1406 DO 350 j=1,5
1407 dps(j)=0.
1408 350 CONTINUE
1409 ENDIF
1410 360 CONTINUE
1411
1412 RETURN
1413 END
1414
1415C*********************************************************************
1416
1417 SUBROUTINE lustrf(IP)
1418C...Purpose: to handle the fragmentation of an arbitrary colour singlet
1419C...jet system according to the Lund string fragmentation model.
1420 IMPLICIT DOUBLE PRECISION(d)
1421 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1422 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1423 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1424 SAVE /lujets/,/ludat1/,/ludat2/
1425 dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
1426 &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),
1427 &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8)
1428
1429C...Function: four-product of two vectors.
1430 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)
1431 dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
1432 &dp(i,3)*dp(j,3)
1433
1434C...Reset counters. Identify parton system.
1435 mstj(91)=0
1436 nsav=n
1437 mstu90=mstu(90)
1438 np=0
1439 kqsum=0
1440 DO 100 j=1,5
1441 dps(j)=0d0
1442 100 CONTINUE
1443 mju(1)=0
1444 mju(2)=0
1445 i=ip-1
1446 110 i=i+1
1447 IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
1448 CALL luerrm(12,'(LUSTRF:) failed to reconstruct jet system')
1449 IF(mstu(21).GE.1) RETURN
1450 ENDIF
1451 IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 110
1452 kc=lucomp(k(i,2))
1453 IF(kc.EQ.0) GOTO 110
1454 kq=kchg(kc,2)*isign(1,k(i,2))
1455 IF(kq.EQ.0) GOTO 110
1456 IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
1457 CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
1458 IF(mstu(21).GE.1) RETURN
1459 ENDIF
1460
1461C...Take copy of partons to be considered. Check flavour sum.
1462 np=np+1
1463 DO 120 j=1,5
1464 k(n+np,j)=k(i,j)
1465 p(n+np,j)=p(i,j)
1466 IF(j.NE.4) dps(j)=dps(j)+p(i,j)
1467 120 CONTINUE
1468 dps(4)=dps(4)+sqrt(dble(p(i,1))**2+dble(p(i,2))**2+
1469 &dble(p(i,3))**2+dble(p(i,5))**2)
1470 k(n+np,3)=i
1471 IF(kq.NE.2) kqsum=kqsum+kq
1472 IF(k(i,1).EQ.41) THEN
1473 kqsum=kqsum+2*kq
1474 IF(kqsum.EQ.kq) mju(1)=n+np
1475 IF(kqsum.NE.kq) mju(2)=n+np
1476 ENDIF
1477 IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) GOTO 110
1478 IF(kqsum.NE.0) THEN
1479 CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
1480 IF(mstu(21).GE.1) RETURN
1481 ENDIF
1482
1483C...Boost copied system to CM frame (for better numerical precision).
1484 IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN
1485 mbst=0
1486 mstu(33)=1
1487 CALL ludbrb(n+1,n+np,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
1488 & -dps(3)/dps(4))
1489 ELSE
1490 mbst=1
1491 hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))
1492 DO 130 i=n+1,n+np
1493 hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
1494 IF(p(i,3).GT.0.) THEN
1495 hhpez=(p(i,4)+p(i,3))/hhbz
1496 p(i,3)=0.5*(hhpez-hhpmt/hhpez)
1497 p(i,4)=0.5*(hhpez+hhpmt/hhpez)
1498 ELSE
1499 hhpez=(p(i,4)-p(i,3))*hhbz
1500 p(i,3)=-0.5*(hhpez-hhpmt/hhpez)
1501 p(i,4)=0.5*(hhpez+hhpmt/hhpez)
1502 ENDIF
1503 130 CONTINUE
1504 ENDIF
1505
1506C...Search for very nearby partons that may be recombined.
1507 ntryr=0
1508 paru12=paru(12)
1509 paru13=paru(13)
1510 mju(3)=mju(1)
1511 mju(4)=mju(2)
1512 nr=np
1513 140 IF(nr.GE.3) THEN
1514 pdrmin=2.*paru12
1515 DO 150 i=n+1,n+nr
1516 IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) GOTO 150
1517 i1=i+1
1518 IF(i.EQ.n+nr) i1=n+1
1519 IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) GOTO 150
1520 IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
1521 & GOTO 150
1522 IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21) GOTO 150
1523 pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+
1524 & p(i1,2)**2+p(i1,3)**2))
1525 pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
1526 pdr=4.*(pap-pvp)**2/max(1e-6,paru13**2*pap+2.*(pap-pvp))
1527 IF(pdr.LT.pdrmin) THEN
1528 ir=i
1529 pdrmin=pdr
1530 ENDIF
1531 150 CONTINUE
1532
1533C...Recombine very nearby partons to avoid machine precision problems.
1534 IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
1535 DO 160 j=1,4
1536 p(n+1,j)=p(n+1,j)+p(n+nr,j)
1537 160 CONTINUE
1538 p(n+1,5)=sqrt(max(0.,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
1539 & p(n+1,3)**2))
1540 nr=nr-1
1541 GOTO 140
1542 ELSEIF(pdrmin.LT.paru12) THEN
1543 DO 170 j=1,4
1544 p(ir,j)=p(ir,j)+p(ir+1,j)
1545 170 CONTINUE
1546 p(ir,5)=sqrt(max(0.,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
1547 & p(ir,3)**2))
1548 DO 190 i=ir+1,n+nr-1
1549 k(i,2)=k(i+1,2)
1550 DO 180 j=1,5
1551 p(i,j)=p(i+1,j)
1552 180 CONTINUE
1553 190 CONTINUE
1554 IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
1555 nr=nr-1
1556 IF(mju(1).GT.ir) mju(1)=mju(1)-1
1557 IF(mju(2).GT.ir) mju(2)=mju(2)-1
1558 GOTO 140
1559 ENDIF
1560 ENDIF
1561 ntryr=ntryr+1
1562
1563C...Reset particle counter. Skip ahead if no junctions are present;
1564C...this is usually the case!
1565 nrs=max(5*nr+11,np)
1566 ntry=0
1567 200 ntry=ntry+1
1568 IF(ntry.GT.100.AND.ntryr.LE.4) THEN
1569 paru12=4.*paru12
1570 paru13=2.*paru13
1571 GOTO 140
1572 ELSEIF(ntry.GT.100) THEN
1573 CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
1574 IF(mstu(21).GE.1) RETURN
1575 ENDIF
1576 i=n+nrs
1577 mstu(90)=mstu90
1578 IF(mju(1).EQ.0.AND.mju(2).EQ.0) GOTO 580
1579 DO 570 jt=1,2
1580 njs(jt)=0
1581 IF(mju(jt).EQ.0) GOTO 570
1582 js=3-2*jt
1583
1584C...Find and sum up momentum on three sides of junction. Check flavours.
1585 DO 220 iu=1,3
1586 iju(iu)=0
1587 DO 210 j=1,5
1588 pju(iu,j)=0.
1589 210 CONTINUE
1590 220 CONTINUE
1591 iu=0
1592 DO 240 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js
1593 IF(k(i1,2).NE.21.AND.iu.LE.2) THEN
1594 iu=iu+1
1595 iju(iu)=i1
1596 ENDIF
1597 DO 230 j=1,4
1598 pju(iu,j)=pju(iu,j)+p(i1,j)
1599 230 CONTINUE
1600 240 CONTINUE
1601 DO 250 iu=1,3
1602 pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
1603 250 CONTINUE
1604 IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND.
1605 &k(iju(3),2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN
1606 CALL luerrm(12,'(LUSTRF:) unphysical flavour combination')
1607 IF(mstu(21).GE.1) RETURN
1608 ENDIF
1609
1610C...Calculate (approximate) boost to rest frame of junction.
1611 t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/
1612 &(pju(1,5)*pju(2,5))
1613 t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/
1614 &(pju(1,5)*pju(3,5))
1615 t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/
1616 &(pju(2,5)*pju(3,5))
1617 t11=sqrt((2./3.)*(1.-t12)*(1.-t13)/(1.-t23))
1618 t22=sqrt((2./3.)*(1.-t12)*(1.-t23)/(1.-t13))
1619 tsq=sqrt((2.*t11*t22+t12-1.)*(1.+t12))
1620 t1f=(tsq-t22*(1.+t12))/(1.-t12**2)
1621 t2f=(tsq-t11*(1.+t12))/(1.-t12**2)
1622 DO 260 j=1,3
1623 tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5))
1624 260 CONTINUE
1625 tju(4)=sqrt(1.+tju(1)**2+tju(2)**2+tju(3)**2)
1626 DO 270 iu=1,3
1627 pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
1628 &tju(3)*pju(iu,3)
1629 270 CONTINUE
1630
1631C...Put junction at rest if motion could give inconsistencies.
1632 IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN
1633 DO 280 j=1,3
1634 tju(j)=0.
1635 280 CONTINUE
1636 tju(4)=1.
1637 pju(1,5)=pju(1,4)
1638 pju(2,5)=pju(2,4)
1639 pju(3,5)=pju(3,4)
1640 ENDIF
1641
1642C...Start preparing for fragmentation of two strings from junction.
1643 ista=i
1644 DO 550 iu=1,2
1645 ns=iju(iu+1)-iju(iu)
1646
1647C...Junction strings: find longitudinal string directions.
1648 DO 310 is=1,ns
1649 is1=iju(iu)+is-1
1650 is2=iju(iu)+is
1651 DO 290 j=1,5
1652 dp(1,j)=0.5*p(is1,j)
1653 IF(is.EQ.1) dp(1,j)=p(is1,j)
1654 dp(2,j)=0.5*p(is2,j)
1655 IF(is.EQ.ns) dp(2,j)=-pju(iu,j)
1656 290 CONTINUE
1657 IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
1658 IF(is.EQ.ns) dp(2,5)=0.
1659 dp(3,5)=dfour(1,1)
1660 dp(4,5)=dfour(2,2)
1661 dhkc=dfour(1,2)
1662 IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
1663 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1664 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1665 dp(3,5)=0d0
1666 dp(4,5)=0d0
1667 dhkc=dfour(1,2)
1668 ENDIF
1669 dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
1670 dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
1671 dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
1672 in1=n+nr+4*is-3
1673 p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
1674 DO 300 j=1,4
1675 p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
1676 p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
1677 300 CONTINUE
1678 310 CONTINUE
1679
1680C...Junction strings: initialize flavour, momentum and starting pos.
1681 isav=i
1682 mstu91=mstu(90)
1683 320 ntry=ntry+1
1684 IF(ntry.GT.100.AND.ntryr.LE.4) THEN
1685 paru12=4.*paru12
1686 paru13=2.*paru13
1687 GOTO 140
1688 ELSEIF(ntry.GT.100) THEN
1689 CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
1690 IF(mstu(21).GE.1) RETURN
1691 ENDIF
1692 i=isav
1693 mstu(90)=mstu91
1694 irankj=0
1695 ie(1)=k(n+1+(jt/2)*(np-1),3)
1696 in(4)=n+nr+1
1697 in(5)=in(4)+1
1698 in(6)=n+nr+4*ns+1
1699 DO 340 jq=1,2
1700 DO 330 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
1701 p(in1,1)=2-jq
1702 p(in1,2)=jq-1
1703 p(in1,3)=1.
1704 330 CONTINUE
1705 340 CONTINUE
1706 kfl(1)=k(iju(iu),2)
1707 px(1)=0.
1708 py(1)=0.
1709 gam(1)=0.
1710 DO 350 j=1,5
1711 pju(iu+3,j)=0.
1712 350 CONTINUE
1713
1714C...Junction strings: find initial transverse directions.
1715 DO 360 j=1,4
1716 dp(1,j)=p(in(4),j)
1717 dp(2,j)=p(in(4)+1,j)
1718 dp(3,j)=0.
1719 dp(4,j)=0.
1720 360 CONTINUE
1721 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1722 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1723 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
1724 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
1725 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
1726 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
1727 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
1728 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
1729 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
1730 dhc12=dfour(1,2)
1731 dhcx1=dfour(3,1)/dhc12
1732 dhcx2=dfour(3,2)/dhc12
1733 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
1734 dhcy1=dfour(4,1)/dhc12
1735 dhcy2=dfour(4,2)/dhc12
1736 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
1737 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
1738 DO 370 j=1,4
1739 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
1740 p(in(6),j)=dp(3,j)
1741 p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
1742 &dhcyx*dp(3,j))
1743 370 CONTINUE
1744
1745C...Junction strings: produce new particle, origin.
1746 380 i=i+1
1747 IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
1748 CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
1749 IF(mstu(21).GE.1) RETURN
1750 ENDIF
1751 irankj=irankj+1
1752 k(i,1)=1
1753 k(i,3)=ie(1)
1754 k(i,4)=0
1755 k(i,5)=0
1756
1757C...Junction strings: generate flavour, hadron, pT, z and Gamma.
1758 390 CALL lukfdi(kfl(1),0,kfl(3),k(i,2))
1759 IF(k(i,2).EQ.0) GOTO 320
1760 IF(mstj(12).GE.3.AND.irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
1761 &iabs(kfl(3)).GT.10) THEN
1762 IF(rlu(0).GT.parj(19)) GOTO 390
1763 ENDIF
1764 p(i,5)=ulmass(k(i,2))
1765 CALL luptdi(kfl(1),px(3),py(3))
1766 pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
1767 CALL luzdis(kfl(1),kfl(3),pr(1),z)
1768 IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND.
1769 &mstu(90).LT.8) THEN
1770 mstu(90)=mstu(90)+1
1771 mstu(90+mstu(90))=i
1772 paru(90+mstu(90))=z
1773 ENDIF
1774 gam(3)=(1.-z)*(gam(1)+pr(1)/z)
1775 DO 400 j=1,3
1776 in(j)=in(3+j)
1777 400 CONTINUE
1778
1779C...Junction strings: stepping within or from 'low' string region easy.
1780 IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
1781 &p(in(1),5)**2.GE.pr(1)) THEN
1782 p(in(1)+2,4)=z*p(in(1)+2,3)
1783 p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
1784 DO 410 j=1,4
1785 p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)
1786 410 CONTINUE
1787 GOTO 500
1788 ELSEIF(in(1)+1.EQ.in(2)) THEN
1789 p(in(2)+2,4)=p(in(2)+2,3)
1790 p(in(2)+2,1)=1.
1791 in(2)=in(2)+4
1792 IF(in(2).GT.n+nr+4*ns) GOTO 320
1793 IF(four(in(1),in(2)).LE.1e-2) THEN
1794 p(in(1)+2,4)=p(in(1)+2,3)
1795 p(in(1)+2,1)=0.
1796 in(1)=in(1)+4
1797 ENDIF
1798 ENDIF
1799
1800C...Junction strings: find new transverse directions.
1801 420 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.
1802 &in(1).GT.in(2)) GOTO 320
1803 IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
1804 DO 430 j=1,4
1805 dp(1,j)=p(in(1),j)
1806 dp(2,j)=p(in(2),j)
1807 dp(3,j)=0.
1808 dp(4,j)=0.
1809 430 CONTINUE
1810 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
1811 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
1812 dhc12=dfour(1,2)
1813 IF(dhc12.LE.1e-2) THEN
1814 p(in(1)+2,4)=p(in(1)+2,3)
1815 p(in(1)+2,1)=0.
1816 in(1)=in(1)+4
1817 GOTO 420
1818 ENDIF
1819 in(3)=n+nr+4*ns+5
1820 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
1821 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
1822 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
1823 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
1824 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
1825 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
1826 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
1827 dhcx1=dfour(3,1)/dhc12
1828 dhcx2=dfour(3,2)/dhc12
1829 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
1830 dhcy1=dfour(4,1)/dhc12
1831 dhcy2=dfour(4,2)/dhc12
1832 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
1833 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
1834 DO 440 j=1,4
1835 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
1836 p(in(3),j)=dp(3,j)
1837 p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
1838 & dhcyx*dp(3,j))
1839 440 CONTINUE
1840C...Express pT with respect to new axes, if sensible.
1841 pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
1842 pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
1843 IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
1844 px(3)=pxp
1845 py(3)=pyp
1846 ENDIF
1847 ENDIF
1848
1849C...Junction strings: sum up known four-momentum, coefficients for m2.
1850 DO 470 j=1,4
1851 dhg(j)=0.
1852 p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+
1853 &py(3)*p(in(3)+1,j)
1854 DO 450 in1=in(4),in(1)-4,4
1855 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
1856 450 CONTINUE
1857 DO 460 in2=in(5),in(2)-4,4
1858 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
1859 460 CONTINUE
1860 470 CONTINUE
1861 dhm(1)=four(i,i)
1862 dhm(2)=2.*four(i,in(1))
1863 dhm(3)=2.*four(i,in(2))
1864 dhm(4)=2.*four(in(1),in(2))
1865
1866C...Junction strings: find coefficients for Gamma expression.
1867 DO 490 in2=in(1)+1,in(2),4
1868 DO 480 in1=in(1),in2-1,4
1869 dhc=2.*four(in1,in2)
1870 dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
1871 IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
1872 IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
1873 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
1874 480 CONTINUE
1875 490 CONTINUE
1876
1877C...Junction strings: solve (m2, Gamma) equation system for energies.
1878 dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
1879 IF(abs(dhs1).LT.1e-4) GOTO 320
1880 dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*
1881 &(p(i,5)**2-dhm(1))+dhg(2)*dhm(3)
1882 dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
1883 p(in(2)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-
1884 &dhs2/dhs1)
1885 IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0.) GOTO 320
1886 p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/
1887 &(dhm(2)+dhm(4)*p(in(2)+2,4))
1888
1889C...Junction strings: step to new region if necessary.
1890 IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
1891 p(in(2)+2,4)=p(in(2)+2,3)
1892 p(in(2)+2,1)=1.
1893 in(2)=in(2)+4
1894 IF(in(2).GT.n+nr+4*ns) GOTO 320
1895 IF(four(in(1),in(2)).LE.1e-2) THEN
1896 p(in(1)+2,4)=p(in(1)+2,3)
1897 p(in(1)+2,1)=0.
1898 in(1)=in(1)+4
1899 ENDIF
1900 GOTO 420
1901 ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
1902 p(in(1)+2,4)=p(in(1)+2,3)
1903 p(in(1)+2,1)=0.
1904 in(1)=in(1)+js
1905 GOTO 820
1906 ENDIF
1907
1908C...Junction strings: particle four-momentum, remainder, loop back.
1909 500 DO 510 j=1,4
1910 p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
1911 pju(iu+3,j)=pju(iu+3,j)+p(i,j)
1912 510 CONTINUE
1913 IF(p(i,4).LT.p(i,5)) GOTO 320
1914 pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
1915 &tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
1916 IF(pju(iu+3,5).LT.pju(iu,5)) THEN
1917 kfl(1)=-kfl(3)
1918 px(1)=-px(3)
1919 py(1)=-py(3)
1920 gam(1)=gam(3)
1921 IF(in(3).NE.in(6)) THEN
1922 DO 520 j=1,4
1923 p(in(6),j)=p(in(3),j)
1924 p(in(6)+1,j)=p(in(3)+1,j)
1925 520 CONTINUE
1926 ENDIF
1927 DO 530 jq=1,2
1928 in(3+jq)=in(jq)
1929 p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
1930 p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
1931 530 CONTINUE
1932 GOTO 380
1933 ENDIF
1934
1935C...Junction strings: save quantities left after each string.
1936 IF(iabs(kfl(1)).GT.10) GOTO 320
1937 i=i-1
1938 kfjh(iu)=kfl(1)
1939 DO 540 j=1,4
1940 pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
1941 540 CONTINUE
1942 550 CONTINUE
1943
1944C...Junction strings: put together to new effective string endpoint.
1945 njs(jt)=i-ista
1946 kfjs(jt)=k(k(mju(jt+2),3),2)
1947 kfls=2*int(rlu(0)+3.*parj(4)/(1.+3.*parj(4)))+1
1948 IF(kfjh(1).EQ.kfjh(2)) kfls=3
1949 IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)),
1950 &iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+
1951 &kfls,kfjh(1))
1952 DO 560 j=1,4
1953 pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
1954 pjs(jt+2,j)=pju(4,j)+pju(5,j)
1955 560 CONTINUE
1956 pjs(jt,5)=sqrt(max(0.,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
1957 &pjs(jt,3)**2))
1958 570 CONTINUE
1959
1960C...Open versus closed strings. Choose breakup region for latter.
1961 580 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
1962 ns=mju(2)-mju(1)
1963 nb=mju(1)-n
1964 ELSEIF(mju(1).NE.0) THEN
1965 ns=n+nr-mju(1)
1966 nb=mju(1)-n
1967 ELSEIF(mju(2).NE.0) THEN
1968 ns=mju(2)-n
1969 nb=1
1970 ELSEIF(iabs(k(n+1,2)).NE.21) THEN
1971 ns=nr-1
1972 nb=1
1973 ELSE
1974 ns=nr+1
1975 w2sum=0.
1976 DO 590 is=1,nr
1977 p(n+nr+is,1)=0.5*four(n+is,n+is+1-nr*(is/nr))
1978 w2sum=w2sum+p(n+nr+is,1)
1979 590 CONTINUE
1980 w2ran=rlu(0)*w2sum
1981 nb=0
1982 600 nb=nb+1
1983 w2sum=w2sum-p(n+nr+nb,1)
1984 IF(w2sum.GT.w2ran.AND.nb.LT.nr) GOTO 600
1985 ENDIF
1986
1987C...Find longitudinal string directions (i.e. lightlike four-vectors).
1988 DO 630 is=1,ns
1989 is1=n+is+nb-1-nr*((is+nb-2)/nr)
1990 is2=n+is+nb-nr*((is+nb-1)/nr)
1991 DO 610 j=1,5
1992 dp(1,j)=p(is1,j)
1993 IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5*dp(1,j)
1994 IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
1995 dp(2,j)=p(is2,j)
1996 IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5*dp(2,j)
1997 IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
1998 610 CONTINUE
1999 dp(3,5)=dfour(1,1)
2000 dp(4,5)=dfour(2,2)
2001 dhkc=dfour(1,2)
2002 IF(dp(3,5)+2.*dhkc+dp(4,5).LE.0.) THEN
2003 dp(3,5)=dp(1,5)**2
2004 dp(4,5)=dp(2,5)**2
2005 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)
2006 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)
2007 dhkc=dfour(1,2)
2008 ENDIF
2009 dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
2010 dhk1=0.5*((dp(4,5)+dhkc)/dhks-1.)
2011 dhk2=0.5*((dp(3,5)+dhkc)/dhks-1.)
2012 in1=n+nr+4*is-3
2013 p(in1,5)=sqrt(dp(3,5)+2.*dhkc+dp(4,5))
2014 DO 620 j=1,4
2015 p(in1,j)=(1.+dhk1)*dp(1,j)-dhk2*dp(2,j)
2016 p(in1+1,j)=(1.+dhk2)*dp(2,j)-dhk1*dp(1,j)
2017 620 CONTINUE
2018 630 CONTINUE
2019
2020C...Begin initialization: sum up energy, set starting position.
2021 isav=i
2022 mstu91=mstu(90)
2023 640 ntry=ntry+1
2024 IF(ntry.GT.100.AND.ntryr.LE.4) THEN
2025 paru12=4.*paru12
2026 paru13=2.*paru13
2027 GOTO 140
2028 ELSEIF(ntry.GT.100) THEN
2029 CALL luerrm(14,'(LUSTRF:) caught in infinite loop')
2030 IF(mstu(21).GE.1) RETURN
2031 ENDIF
2032 i=isav
2033 mstu(90)=mstu91
2034 DO 660 j=1,4
2035 p(n+nrs,j)=0.
2036 DO 650 is=1,nr
2037 p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
2038 650 CONTINUE
2039 660 CONTINUE
2040 DO 680 jt=1,2
2041 irank(jt)=0
2042 IF(mju(jt).NE.0) irank(jt)=njs(jt)
2043 IF(ns.GT.nr) irank(jt)=1
2044 ie(jt)=k(n+1+(jt/2)*(np-1),3)
2045 in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
2046 in(3*jt+2)=in(3*jt+1)+1
2047 in(3*jt+3)=n+nr+4*ns+2*jt-1
2048 DO 670 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
2049 p(in1,1)=2-jt
2050 p(in1,2)=jt-1
2051 p(in1,3)=1.
2052 670 CONTINUE
2053 680 CONTINUE
2054
2055C...Initialize flavour and pT variables for open string.
2056 IF(ns.LT.nr) THEN
2057 px(1)=0.
2058 py(1)=0.
2059 IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL luptdi(0,px(1),py(1))
2060 px(2)=-px(1)
2061 py(2)=-py(1)
2062 DO 690 jt=1,2
2063 kfl(jt)=k(ie(jt),2)
2064 IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
2065 mstj(93)=1
2066 pmq(jt)=ulmass(kfl(jt))
2067 gam(jt)=0.
2068 690 CONTINUE
2069
2070C...Closed string: random initial breakup flavour, pT and vertex.
2071 ELSE
2072 kfl(3)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2073 CALL lukfdi(kfl(3),0,kfl(1),kdump)
2074 kfl(2)=-kfl(1)
2075 IF(iabs(kfl(1)).GT.10.AND.rlu(0).GT.0.5) THEN
2076 kfl(2)=-(kfl(1)+isign(10000,kfl(1)))
2077 ELSEIF(iabs(kfl(1)).GT.10) THEN
2078 kfl(1)=-(kfl(2)+isign(10000,kfl(2)))
2079 ENDIF
2080 CALL luptdi(kfl(1),px(1),py(1))
2081 px(2)=-px(1)
2082 py(2)=-py(1)
2083 pr3=min(25.,0.1*p(n+nr+1,5)**2)
2084 700 CALL luzdis(kfl(1),kfl(2),pr3,z)
2085 zr=pr3/(z*p(n+nr+1,5)**2)
2086 IF(zr.GE.1.) GOTO 700
2087 DO 710 jt=1,2
2088 mstj(93)=1
2089 pmq(jt)=ulmass(kfl(jt))
2090 gam(jt)=pr3*(1.-z)/z
2091 in1=n+nr+3+4*(jt/2)*(ns-1)
2092 p(in1,jt)=1.-z
2093 p(in1,3-jt)=jt-1
2094 p(in1,3)=(2-jt)*(1.-z)+(jt-1)*z
2095 p(in1+1,jt)=zr
2096 p(in1+1,3-jt)=2-jt
2097 p(in1+1,3)=(2-jt)*(1.-zr)+(jt-1)*zr
2098 710 CONTINUE
2099 ENDIF
2100
2101C...Find initial transverse directions (i.e. spacelike four-vectors).
2102 DO 750 jt=1,2
2103 IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN
2104 in1=in(3*jt+1)
2105 in3=in(3*jt+3)
2106 DO 720 j=1,4
2107 dp(1,j)=p(in1,j)
2108 dp(2,j)=p(in1+1,j)
2109 dp(3,j)=0.
2110 dp(4,j)=0.
2111 720 CONTINUE
2112 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
2113 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
2114 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
2115 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
2116 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
2117 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
2118 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
2119 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
2120 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
2121 dhc12=dfour(1,2)
2122 dhcx1=dfour(3,1)/dhc12
2123 dhcx2=dfour(3,2)/dhc12
2124 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
2125 dhcy1=dfour(4,1)/dhc12
2126 dhcy2=dfour(4,2)/dhc12
2127 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
2128 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
2129 DO 730 j=1,4
2130 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
2131 p(in3,j)=dp(3,j)
2132 p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
2133 & dhcyx*dp(3,j))
2134 730 CONTINUE
2135 ELSE
2136 DO 740 j=1,4
2137 p(in3+2,j)=p(in3,j)
2138 p(in3+3,j)=p(in3+1,j)
2139 740 CONTINUE
2140 ENDIF
2141 750 CONTINUE
2142
2143C...Remove energy used up in junction string fragmentation.
2144 IF(mju(1)+mju(2).GT.0) THEN
2145 DO 770 jt=1,2
2146 IF(njs(jt).EQ.0) GOTO 770
2147 DO 760 j=1,4
2148 p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
2149 760 CONTINUE
2150 770 CONTINUE
2151 ENDIF
2152
2153C...Produce new particle: side, origin.
2154 780 i=i+1
2155 IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
2156 CALL luerrm(11,'(LUSTRF:) no more memory left in LUJETS')
2157 IF(mstu(21).GE.1) RETURN
2158 ENDIF
2159 jt=1.5+rlu(0)
2160 IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
2161 IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt
2162 jr=3-jt
2163 js=3-2*jt
2164 irank(jt)=irank(jt)+1
2165 k(i,1)=1
2166 k(i,3)=ie(jt)
2167 k(i,4)=0
2168 k(i,5)=0
2169
2170C...Generate flavour, hadron and pT.
2171 790 CALL lukfdi(kfl(jt),0,kfl(3),k(i,2))
2172 IF(k(i,2).EQ.0) GOTO 640
2173 IF(mstj(12).GE.3.AND.irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
2174 &iabs(kfl(3)).GT.10) THEN
2175 IF(rlu(0).GT.parj(19)) GOTO 790
2176 ENDIF
2177 p(i,5)=ulmass(k(i,2))
2178 CALL luptdi(kfl(jt),px(3),py(3))
2179 pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
2180
2181C...Final hadrons for small invariant mass.
2182 mstj(93)=1
2183 pmq(3)=ulmass(kfl(3))
2184 parjst=parj(33)
2185 IF(mstj(11).EQ.2) parjst=parj(34)
2186 wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)
2187 IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
2188 &wmin-0.5*parj(36)*pmq(3)
2189 wrem2=four(n+nrs,n+nrs)
2190 IF(wrem2.LT.0.10) GOTO 640
2191 IF(wrem2.LT.max(wmin*(1.+(2.*rlu(0)-1.)*parj(37)),
2192 &parj(32)+pmq(1)+pmq(2))**2) GOTO 940
2193
2194C...Choose z, which gives Gamma. Shift z for heavy flavours.
2195 CALL luzdis(kfl(jt),kfl(3),pr(jt),z)
2196 IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.
2197 &mstu(90).LT.8) THEN
2198 mstu(90)=mstu(90)+1
2199 mstu(90+mstu(90))=i
2200 paru(90+mstu(90))=z
2201 ENDIF
2202 kfl1a=iabs(kfl(1))
2203 kfl2a=iabs(kfl(2))
2204 IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
2205 &mod(kfl2a/1000,10)).GE.4) THEN
2206 pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2207 pw12=sqrt(max(0.,(wrem2-pr(1)-pr(2))**2-4.*pr(1)*pr(2)))
2208 z=(wrem2+pr(jt)-pr(jr)+pw12*(2.*z-1.))/(2.*wrem2)
2209 pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2210 IF((1.-z)*(wrem2-pr(jt)/z).LT.pr(jr)) GOTO 940
2211 ENDIF
2212 gam(3)=(1.-z)*(gam(jt)+pr(jt)/z)
2213 DO 800 j=1,3
2214 in(j)=in(3*jt+j)
2215 800 CONTINUE
2216
2217C...Stepping within or from 'low' string region easy.
2218 IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
2219 &p(in(1),5)**2.GE.pr(jt)) THEN
2220 p(in(jt)+2,4)=z*p(in(jt)+2,3)
2221 p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
2222 DO 810 j=1,4
2223 p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
2224 810 CONTINUE
2225 GOTO 900
2226 ELSEIF(in(1)+1.EQ.in(2)) THEN
2227 p(in(jr)+2,4)=p(in(jr)+2,3)
2228 p(in(jr)+2,jt)=1.
2229 in(jr)=in(jr)+4*js
2230 IF(js*in(jr).GT.js*in(4*jr)) GOTO 640
2231 IF(four(in(1),in(2)).LE.1e-2) THEN
2232 p(in(jt)+2,4)=p(in(jt)+2,3)
2233 p(in(jt)+2,jt)=0.
2234 in(jt)=in(jt)+4*js
2235 ENDIF
2236 ENDIF
2237
2238C...Find new transverse directions (i.e. spacelike string vectors).
2239 820 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
2240 &in(1).GT.in(2)) GOTO 640
2241 IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
2242 DO 830 j=1,4
2243 dp(1,j)=p(in(1),j)
2244 dp(2,j)=p(in(2),j)
2245 dp(3,j)=0.
2246 dp(4,j)=0.
2247 830 CONTINUE
2248 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
2249 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
2250 dhc12=dfour(1,2)
2251 IF(dhc12.LE.1e-2) THEN
2252 p(in(jt)+2,4)=p(in(jt)+2,3)
2253 p(in(jt)+2,jt)=0.
2254 in(jt)=in(jt)+4*js
2255 GOTO 820
2256 ENDIF
2257 in(3)=n+nr+4*ns+5
2258 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
2259 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
2260 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
2261 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1.
2262 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1.
2263 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1.
2264 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1.
2265 dhcx1=dfour(3,1)/dhc12
2266 dhcx2=dfour(3,2)/dhc12
2267 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
2268 dhcy1=dfour(4,1)/dhc12
2269 dhcy2=dfour(4,2)/dhc12
2270 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
2271 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
2272 DO 840 j=1,4
2273 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
2274 p(in(3),j)=dp(3,j)
2275 p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
2276 & dhcyx*dp(3,j))
2277 840 CONTINUE
2278C...Express pT with respect to new axes, if sensible.
2279 pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
2280 & four(in(3*jt+3)+1,in(3)))
2281 pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
2282 & four(in(3*jt+3)+1,in(3)+1))
2283 IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01) THEN
2284 px(3)=pxp
2285 py(3)=pyp
2286 ENDIF
2287 ENDIF
2288
2289C...Sum up known four-momentum. Gives coefficients for m2 expression.
2290 DO 870 j=1,4
2291 dhg(j)=0.
2292 p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+
2293 &px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)
2294 DO 850 in1=in(3*jt+1),in(1)-4*js,4*js
2295 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
2296 850 CONTINUE
2297 DO 860 in2=in(3*jt+2),in(2)-4*js,4*js
2298 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
2299 860 CONTINUE
2300 870 CONTINUE
2301 dhm(1)=four(i,i)
2302 dhm(2)=2.*four(i,in(1))
2303 dhm(3)=2.*four(i,in(2))
2304 dhm(4)=2.*four(in(1),in(2))
2305
2306C...Find coefficients for Gamma expression.
2307 DO 890 in2=in(1)+1,in(2),4
2308 DO 880 in1=in(1),in2-1,4
2309 dhc=2.*four(in1,in2)
2310 dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
2311 IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
2312 IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
2313 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
2314 880 CONTINUE
2315 890 CONTINUE
2316
2317C...Solve (m2, Gamma) equation system for energies taken.
2318 dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
2319 IF(abs(dhs1).LT.1e-4) GOTO 640
2320 dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
2321 &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
2322 dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
2323 p(in(jr)+2,4)=0.5*(sqrt(max(0d0,dhs2**2-4.*dhs1*dhs3))/abs(dhs1)-
2324 &dhs2/dhs1)
2325 IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0.) GOTO 640
2326 p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
2327 &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
2328
2329C...Step to new region if necessary.
2330 IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
2331 p(in(jr)+2,4)=p(in(jr)+2,3)
2332 p(in(jr)+2,jt)=1.
2333 in(jr)=in(jr)+4*js
2334 IF(js*in(jr).GT.js*in(4*jr)) GOTO 640
2335 IF(four(in(1),in(2)).LE.1e-2) THEN
2336 p(in(jt)+2,4)=p(in(jt)+2,3)
2337 p(in(jt)+2,jt)=0.
2338 in(jt)=in(jt)+4*js
2339 ENDIF
2340 GOTO 820
2341 ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
2342 p(in(jt)+2,4)=p(in(jt)+2,3)
2343 p(in(jt)+2,jt)=0.
2344 in(jt)=in(jt)+4*js
2345 GOTO 820
2346 ENDIF
2347
2348C...Four-momentum of particle. Remaining quantities. Loop back.
2349 900 DO 910 j=1,4
2350 p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
2351 p(n+nrs,j)=p(n+nrs,j)-p(i,j)
2352 910 CONTINUE
2353 IF(p(i,4).LT.p(i,5)) GOTO 640
2354 kfl(jt)=-kfl(3)
2355 pmq(jt)=pmq(3)
2356 px(jt)=-px(3)
2357 py(jt)=-py(3)
2358 gam(jt)=gam(3)
2359 IF(in(3).NE.in(3*jt+3)) THEN
2360 DO 920 j=1,4
2361 p(in(3*jt+3),j)=p(in(3),j)
2362 p(in(3*jt+3)+1,j)=p(in(3)+1,j)
2363 920 CONTINUE
2364 ENDIF
2365 DO 930 jq=1,2
2366 in(3*jt+jq)=in(jq)
2367 p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
2368 p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
2369 930 CONTINUE
2370 GOTO 780
2371
2372C...Final hadron: side, flavour, hadron, mass.
2373 940 i=i+1
2374 k(i,1)=1
2375 k(i,3)=ie(jr)
2376 k(i,4)=0
2377 k(i,5)=0
2378 CALL lukfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
2379 IF(k(i,2).EQ.0) GOTO 640
2380 p(i,5)=ulmass(k(i,2))
2381 pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
2382
2383C...Final two hadrons: find common setup of four-vectors.
2384 jq=1
2385 IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.p(in(7),3)*
2386 &p(in(8),3)*four(in(7),in(8))) jq=2
2387 dhc12=four(in(3*jq+1),in(3*jq+2))
2388 dhr1=four(n+nrs,in(3*jq+2))/dhc12
2389 dhr2=four(n+nrs,in(3*jq+1))/dhc12
2390 IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
2391 px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
2392 py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
2393 pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
2394 & px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
2395 ENDIF
2396
2397C...Solve kinematics for final two hadrons, if possible.
2398 wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2
2399 fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
2400 IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1.) GOTO 200
2401 IF(fd.GE.1.) GOTO 640
2402 fa=wrem2+pr(jt)-pr(jr)
2403 IF(mstj(11).NE.2) prev=0.5*exp(max(-50.,log(fd)*parj(38)*
2404 &(pr(1)+pr(2))**2))
2405 IF(mstj(11).EQ.2) prev=0.5*fd**parj(39)
2406 fb=sign(sqrt(max(0.,fa**2-4.*wrem2*pr(jt))),js*(rlu(0)-prev))
2407 kfl1a=iabs(kfl(1))
2408 kfl2a=iabs(kfl(2))
2409 IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
2410 &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0.,fa**2-
2411 &4.*wrem2*pr(jt))),float(js))
2412 DO 950 j=1,4
2413 p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*
2414 &p(in(3*jq+3)+1,j)+0.5*(dhr1*(fa+fb)*p(in(3*jq+1),j)+
2415 &dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2
2416 p(i,j)=p(n+nrs,j)-p(i-1,j)
2417 950 CONTINUE
2418 IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) GOTO 640
2419
2420C...Mark jets as fragmented and give daughter pointers.
2421 n=i-nrs+1
2422 DO 960 i=nsav+1,nsav+np
2423 im=k(i,3)
2424 k(im,1)=k(im,1)+10
2425 IF(mstu(16).NE.2) THEN
2426 k(im,4)=nsav+1
2427 k(im,5)=nsav+1
2428 ELSE
2429 k(im,4)=nsav+2
2430 k(im,5)=n
2431 ENDIF
2432 960 CONTINUE
2433
2434C...Document string system. Move up particles.
2435 nsav=nsav+1
2436 k(nsav,1)=11
2437 k(nsav,2)=92
2438 k(nsav,3)=ip
2439 k(nsav,4)=nsav+1
2440 k(nsav,5)=n
2441 DO 970 j=1,4
2442 p(nsav,j)=dps(j)
2443 v(nsav,j)=v(ip,j)
2444 970 CONTINUE
2445 p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
2446 v(nsav,5)=0.
2447 DO 990 i=nsav+1,n
2448 DO 980 j=1,5
2449 k(i,j)=k(i+nrs-1,j)
2450 p(i,j)=p(i+nrs-1,j)
2451 v(i,j)=0.
2452 980 CONTINUE
2453 990 CONTINUE
2454 mstu91=mstu(90)
2455 DO 1000 iz=mstu90+1,mstu91
2456 mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n
2457 paru9t(iz)=paru(90+iz)
2458 1000 CONTINUE
2459 mstu(90)=mstu90
2460
2461C...Order particles in rank along the chain. Update mother pointer.
2462 DO 1020 i=nsav+1,n
2463 DO 1010 j=1,5
2464 k(i-nsav+n,j)=k(i,j)
2465 p(i-nsav+n,j)=p(i,j)
2466 1010 CONTINUE
2467 1020 CONTINUE
2468 i1=nsav
2469 DO 1050 i=n+1,2*n-nsav
2470 IF(k(i,3).NE.ie(1)) GOTO 1050
2471 i1=i1+1
2472 DO 1030 j=1,5
2473 k(i1,j)=k(i,j)
2474 p(i1,j)=p(i,j)
2475 1030 CONTINUE
2476 IF(mstu(16).NE.2) k(i1,3)=nsav
2477 DO 1040 iz=mstu90+1,mstu91
2478 IF(mstu9t(iz).EQ.i) THEN
2479 mstu(90)=mstu(90)+1
2480 mstu(90+mstu(90))=i1
2481 paru(90+mstu(90))=paru9t(iz)
2482 ENDIF
2483 1040 CONTINUE
2484 1050 CONTINUE
2485 DO 1080 i=2*n-nsav,n+1,-1
2486 IF(k(i,3).EQ.ie(1)) GOTO 1080
2487 i1=i1+1
2488 DO 1060 j=1,5
2489 k(i1,j)=k(i,j)
2490 p(i1,j)=p(i,j)
2491 1060 CONTINUE
2492 IF(mstu(16).NE.2) k(i1,3)=nsav
2493 DO 1070 iz=mstu90+1,mstu91
2494 IF(mstu9t(iz).EQ.i) THEN
2495 mstu(90)=mstu(90)+1
2496 mstu(90+mstu(90))=i1
2497 paru(90+mstu(90))=paru9t(iz)
2498 ENDIF
2499 1070 CONTINUE
2500 1080 CONTINUE
2501
2502C...Boost back particle system. Set production vertices.
2503 IF(mbst.EQ.0) THEN
2504 mstu(33)=1
2505 CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),dps(2)/dps(4),
2506 & dps(3)/dps(4))
2507 ELSE
2508 DO 1090 i=nsav+1,n
2509 hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
2510 IF(p(i,3).GT.0.) THEN
2511 hhpez=(p(i,4)+p(i,3))*hhbz
2512 p(i,3)=0.5*(hhpez-hhpmt/hhpez)
2513 p(i,4)=0.5*(hhpez+hhpmt/hhpez)
2514 ELSE
2515 hhpez=(p(i,4)-p(i,3))/hhbz
2516 p(i,3)=-0.5*(hhpez-hhpmt/hhpez)
2517 p(i,4)=0.5*(hhpez+hhpmt/hhpez)
2518 ENDIF
2519 1090 CONTINUE
2520 ENDIF
2521 DO 1110 i=nsav+1,n
2522 DO 1100 j=1,4
2523 v(i,j)=v(ip,j)
2524 1100 CONTINUE
2525 1110 CONTINUE
2526
2527 RETURN
2528 END
2529
2530C*********************************************************************
2531
2532 SUBROUTINE luindf(IP)
2533
2534C...Purpose: to handle the fragmentation of a jet system (or a single
2535C...jet) according to independent fragmentation models.
2536 IMPLICIT DOUBLE PRECISION(d)
2537 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
2538 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
2539 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
2540 SAVE /lujets/,/ludat1/,/ludat2/
2541 dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
2542 &kflo(2),pxo(2),pyo(2),wo(2)
2543
2544C...Reset counters. Identify parton system and take copy. Check flavour.
2545 nsav=n
2546 mstu90=mstu(90)
2547 njet=0
2548 kqsum=0
2549 DO 100 j=1,5
2550 dps(j)=0.
2551 100 CONTINUE
2552 i=ip-1
2553 110 i=i+1
2554 IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
2555 CALL luerrm(12,'(LUINDF:) failed to reconstruct jet system')
2556 IF(mstu(21).GE.1) RETURN
2557 ENDIF
2558 IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 110
2559 kc=lucomp(k(i,2))
2560 IF(kc.EQ.0) GOTO 110
2561 kq=kchg(kc,2)*isign(1,k(i,2))
2562 IF(kq.EQ.0) GOTO 110
2563 njet=njet+1
2564 IF(kq.NE.2) kqsum=kqsum+kq
2565 DO 120 j=1,5
2566 k(nsav+njet,j)=k(i,j)
2567 p(nsav+njet,j)=p(i,j)
2568 dps(j)=dps(j)+p(i,j)
2569 120 CONTINUE
2570 k(nsav+njet,3)=i
2571 IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
2572 &k(i+1,1).EQ.2)) GOTO 110
2573 IF(njet.NE.1.AND.kqsum.NE.0) THEN
2574 CALL luerrm(12,'(LUINDF:) unphysical flavour combination')
2575 IF(mstu(21).GE.1) RETURN
2576 ENDIF
2577
2578C...Boost copied system to CM frame. Find CM energy and sum flavours.
2579 IF(njet.NE.1) THEN
2580 mstu(33)=1
2581 CALL ludbrb(nsav+1,nsav+njet,0.,0.,-dps(1)/dps(4),
2582 & -dps(2)/dps(4),-dps(3)/dps(4))
2583 ENDIF
2584 pecm=0.
2585 DO 130 j=1,3
2586 nfi(j)=0
2587 130 CONTINUE
2588 DO 140 i=nsav+1,nsav+njet
2589 pecm=pecm+p(i,4)
2590 kfa=iabs(k(i,2))
2591 IF(kfa.LE.3) THEN
2592 nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
2593 ELSEIF(kfa.GT.1000) THEN
2594 kfla=mod(kfa/1000,10)
2595 kflb=mod(kfa/100,10)
2596 IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
2597 IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
2598 ENDIF
2599 140 CONTINUE
2600
2601C...Loop over attempts made. Reset counters.
2602 ntry=0
2603 150 ntry=ntry+1
2604 IF(ntry.GT.200) THEN
2605 CALL luerrm(14,'(LUINDF:) caught in infinite loop')
2606 IF(mstu(21).GE.1) RETURN
2607 ENDIF
2608 n=nsav+njet
2609 mstu(90)=mstu90
2610 DO 160 j=1,3
2611 nfl(j)=nfi(j)
2612 ifet(j)=0
2613 kflf(j)=0
2614 160 CONTINUE
2615
2616C...Loop over jets to be fragmented.
2617 DO 230 ip1=nsav+1,nsav+njet
2618 mstj(91)=0
2619 nsav1=n
2620 mstu91=mstu(90)
2621
2622C...Initial flavour and momentum values. Jet along +z axis.
2623 kflh=iabs(k(ip1,2))
2624 IF(kflh.GT.10) kflh=mod(kflh/1000,10)
2625 kflo(2)=0
2626 wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
2627
2628C...Initial values for quark or diquark jet.
2629 170 IF(iabs(k(ip1,2)).NE.21) THEN
2630 nstr=1
2631 kflo(1)=k(ip1,2)
2632 CALL luptdi(0,pxo(1),pyo(1))
2633 wo(1)=wf
2634
2635C...Initial values for gluon treated like random quark jet.
2636 ELSEIF(mstj(2).LE.2) THEN
2637 nstr=1
2638 IF(mstj(2).EQ.2) mstj(91)=1
2639 kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2640 CALL luptdi(0,pxo(1),pyo(1))
2641 wo(1)=wf
2642
2643C...Initial values for gluon treated like quark-antiquark jet pair,
2644C...sharing energy according to Altarelli-Parisi splitting function.
2645 ELSE
2646 nstr=2
2647 IF(mstj(2).EQ.4) mstj(91)=1
2648 kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
2649 kflo(2)=-kflo(1)
2650 CALL luptdi(0,pxo(1),pyo(1))
2651 pxo(2)=-pxo(1)
2652 pyo(2)=-pyo(1)
2653 wo(1)=wf*rlu(0)**(1./3.)
2654 wo(2)=wf-wo(1)
2655 ENDIF
2656
2657C...Initial values for rank, flavour, pT and W+.
2658 DO 220 istr=1,nstr
2659 180 i=n
2660 mstu(90)=mstu91
2661 irank=0
2662 kfl1=kflo(istr)
2663 px1=pxo(istr)
2664 py1=pyo(istr)
2665 w=wo(istr)
2666
2667C...New hadron. Generate flavour and hadron species.
2668 190 i=i+1
2669 IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
2670 CALL luerrm(11,'(LUINDF:) no more memory left in LUJETS')
2671 IF(mstu(21).GE.1) RETURN
2672 ENDIF
2673 irank=irank+1
2674 k(i,1)=1
2675 k(i,3)=ip1
2676 k(i,4)=0
2677 k(i,5)=0
2678 200 CALL lukfdi(kfl1,0,kfl2,k(i,2))
2679 IF(k(i,2).EQ.0) GOTO 180
2680 IF(mstj(12).GE.3.AND.irank.EQ.1.AND.iabs(kfl1).LE.10.AND.
2681 &iabs(kfl2).GT.10) THEN
2682 IF(rlu(0).GT.parj(19)) GOTO 200
2683 ENDIF
2684
2685C...Find hadron mass. Generate four-momentum.
2686 p(i,5)=ulmass(k(i,2))
2687 CALL luptdi(kfl1,px2,py2)
2688 p(i,1)=px1+px2
2689 p(i,2)=py1+py2
2690 pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
2691 CALL luzdis(kfl1,kfl2,pr,z)
2692 mzsav=0
2693 IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN
2694 mzsav=1
2695 mstu(90)=mstu(90)+1
2696 mstu(90+mstu(90))=i
2697 paru(90+mstu(90))=z
2698 ENDIF
2699 p(i,3)=0.5*(z*w-pr/(z*w))
2700 p(i,4)=0.5*(z*w+pr/(z*w))
2701 IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
2702 &p(i,3).LE.0.001) THEN
2703 IF(w.GE.p(i,5)+0.5*parj(32)) GOTO 180
2704 p(i,3)=0.0001
2705 p(i,4)=sqrt(pr)
2706 z=p(i,4)/w
2707 ENDIF
2708
2709C...Remaining flavour and momentum.
2710 kfl1=-kfl2
2711 px1=-px2
2712 py1=-py2
2713 w=(1.-z)*w
2714 DO 210 j=1,5
2715 v(i,j)=0.
2716 210 CONTINUE
2717
2718C...Check if pL acceptable. Go back for new hadron if enough energy.
2719 IF(mstj(3).GE.0.AND.p(i,3).LT.0.) THEN
2720 i=i-1
2721 IF(mzsav.EQ.1) mstu(90)=mstu(90)-1
2722 ENDIF
2723 IF(w.GT.parj(31)) GOTO 190
2724 n=i
2725 220 CONTINUE
2726 IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1*parj(32)
2727 IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) GOTO 170
2728
2729C...Rotate jet to new direction.
2730 the=ulangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
2731 phi=ulangl(p(ip1,1),p(ip1,2))
2732 mstu(33)=1
2733 CALL ludbrb(nsav1+1,n,the,phi,0d0,0d0,0d0)
2734 k(k(ip1,3),4)=nsav1+1
2735 k(k(ip1,3),5)=n
2736
2737C...End of jet generation loop. Skip conservation in some cases.
2738 230 CONTINUE
2739 IF(njet.EQ.1.OR.mstj(3).LE.0) GOTO 490
2740 IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) GOTO 150
2741
2742C...Subtract off produced hadron flavours, finished if zero.
2743 DO 240 i=nsav+njet+1,n
2744 kfa=iabs(k(i,2))
2745 kfla=mod(kfa/1000,10)
2746 kflb=mod(kfa/100,10)
2747 kflc=mod(kfa/10,10)
2748 IF(kfla.EQ.0) THEN
2749 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
2750 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
2751 ELSE
2752 IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
2753 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
2754 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
2755 ENDIF
2756 240 CONTINUE
2757 nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
2758 &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
2759 IF(nreq.EQ.0) GOTO 320
2760
2761C...Take away flavour of low-momentum particles until enough freedom.
2762 nrem=0
2763 250 irem=0
2764 p2min=pecm**2
2765 DO 260 i=nsav+njet+1,n
2766 p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
2767 IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
2768 IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
2769 260 CONTINUE
2770 IF(irem.EQ.0) GOTO 150
2771 k(irem,1)=7
2772 kfa=iabs(k(irem,2))
2773 kfla=mod(kfa/1000,10)
2774 kflb=mod(kfa/100,10)
2775 kflc=mod(kfa/10,10)
2776 IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
2777 IF(k(irem,1).EQ.8) GOTO 250
2778 IF(kfla.EQ.0) THEN
2779 isgn=isign(1,k(irem,2))*(-1)**kflb
2780 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
2781 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
2782 ELSE
2783 IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
2784 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
2785 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
2786 ENDIF
2787 nrem=nrem+1
2788 nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
2789 &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
2790 IF(nreq.GT.nrem) GOTO 250
2791 DO 270 i=nsav+njet+1,n
2792 IF(k(i,1).EQ.8) k(i,1)=1
2793 270 CONTINUE
2794
2795C...Find combination of existing and new flavours for hadron.
2796 280 nfet=2
2797 IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
2798 IF(nreq.LT.nrem) nfet=1
2799 IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
2800 DO 290 j=1,nfet
2801 ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*rlu(0)
2802 kflf(j)=isign(1,nfl(1))
2803 IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
2804 IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
2805 290 CONTINUE
2806 IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
2807 &GOTO 280
2808 IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
2809 &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3).
2810 &lt.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) GOTO 280
2811 IF(nfet.EQ.0) kflf(1)=1+int((2.+parj(2))*rlu(0))
2812 IF(nfet.EQ.0) kflf(2)=-kflf(1)
2813 IF(nfet.EQ.1) kflf(2)=isign(1+int((2.+parj(2))*rlu(0)),-kflf(1))
2814 IF(nfet.LE.2) kflf(3)=0
2815 IF(kflf(3).NE.0) THEN
2816 kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
2817 & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
2818 IF(kflf(1).EQ.kflf(3).OR.(1.+3.*parj(4))*rlu(0).GT.1.)
2819 & kflfc=kflfc+isign(2,kflfc)
2820 ELSE
2821 kflfc=kflf(1)
2822 ENDIF
2823 CALL lukfdi(kflfc,kflf(2),kfldmp,kf)
2824 IF(kf.EQ.0) GOTO 280
2825 DO 300 j=1,max(2,nfet)
2826 nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
2827 300 CONTINUE
2828
2829C...Store hadron at random among free positions.
2830 npos=min(1+int(rlu(0)*nrem),nrem)
2831 DO 310 i=nsav+njet+1,n
2832 IF(k(i,1).EQ.7) npos=npos-1
2833 IF(k(i,1).EQ.1.OR.npos.NE.0) GOTO 310
2834 k(i,1)=1
2835 k(i,2)=kf
2836 p(i,5)=ulmass(k(i,2))
2837 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2838 310 CONTINUE
2839 nrem=nrem-1
2840 nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
2841 &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
2842 IF(nrem.GT.0) GOTO 280
2843
2844C...Compensate for missing momentum in global scheme (3 options).
2845 320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
2846 DO 340 j=1,3
2847 psi(j)=0.
2848 DO 330 i=nsav+njet+1,n
2849 psi(j)=psi(j)+p(i,j)
2850 330 CONTINUE
2851 340 CONTINUE
2852 psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
2853 pws=0.
2854 DO 350 i=nsav+njet+1,n
2855 IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
2856 IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
2857 & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
2858 IF(mod(mstj(3),5).EQ.3) pws=pws+1.
2859 350 CONTINUE
2860 DO 370 i=nsav+njet+1,n
2861 IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
2862 IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
2863 & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
2864 IF(mod(mstj(3),5).EQ.3) pw=1.
2865 DO 360 j=1,3
2866 p(i,j)=p(i,j)-psi(j)*pw/pws
2867 360 CONTINUE
2868 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2869 370 CONTINUE
2870
2871C...Compensate for missing momentum withing each jet separately.
2872 ELSEIF(mod(mstj(3),5).EQ.4) THEN
2873 DO 390 i=n+1,n+njet
2874 k(i,1)=0
2875 DO 380 j=1,5
2876 p(i,j)=0.
2877 380 CONTINUE
2878 390 CONTINUE
2879 DO 410 i=nsav+njet+1,n
2880 ir1=k(i,3)
2881 ir2=n+ir1-nsav
2882 k(ir2,1)=k(ir2,1)+1
2883 pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
2884 & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
2885 DO 400 j=1,3
2886 p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
2887 400 CONTINUE
2888 p(ir2,4)=p(ir2,4)+p(i,4)
2889 p(ir2,5)=p(ir2,5)+pls
2890 410 CONTINUE
2891 pss=0.
2892 DO 420 i=n+1,n+njet
2893 IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8*p(i,5)+0.2))
2894 420 CONTINUE
2895 DO 440 i=nsav+njet+1,n
2896 ir1=k(i,3)
2897 ir2=n+ir1-nsav
2898 pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
2899 & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
2900 DO 430 j=1,3
2901 p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1./(p(ir2,5)*pss)-1.)*pls*
2902 & p(ir1,j)
2903 430 CONTINUE
2904 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2905 440 CONTINUE
2906 ENDIF
2907
2908C...Scale momenta for energy conservation.
2909 IF(mod(mstj(3),5).NE.0) THEN
2910 pms=0.
2911 pes=0.
2912 pqs=0.
2913 DO 450 i=nsav+njet+1,n
2914 pms=pms+p(i,5)
2915 pes=pes+p(i,4)
2916 pqs=pqs+p(i,5)**2/p(i,4)
2917 450 CONTINUE
2918 IF(pms.GE.pecm) GOTO 150
2919 neco=0
2920 460 neco=neco+1
2921 pfac=(pecm-pqs)/(pes-pqs)
2922 pes=0.
2923 pqs=0.
2924 DO 480 i=nsav+njet+1,n
2925 DO 470 j=1,3
2926 p(i,j)=pfac*p(i,j)
2927 470 CONTINUE
2928 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
2929 pes=pes+p(i,4)
2930 pqs=pqs+p(i,5)**2/p(i,4)
2931 480 CONTINUE
2932 IF(neco.LT.10.AND.abs(pecm-pes).GT.2e-6*pecm) GOTO 460
2933 ENDIF
2934
2935C...Origin of produced particles and parton daughter pointers.
2936 490 DO 500 i=nsav+njet+1,n
2937 IF(mstu(16).NE.2) k(i,3)=nsav+1
2938 IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
2939 500 CONTINUE
2940 DO 510 i=nsav+1,nsav+njet
2941 i1=k(i,3)
2942 k(i1,1)=k(i1,1)+10
2943 IF(mstu(16).NE.2) THEN
2944 k(i1,4)=nsav+1
2945 k(i1,5)=nsav+1
2946 ELSE
2947 k(i1,4)=k(i1,4)-njet+1
2948 k(i1,5)=k(i1,5)-njet+1
2949 IF(k(i1,5).LT.k(i1,4)) THEN
2950 k(i1,4)=0
2951 k(i1,5)=0
2952 ENDIF
2953 ENDIF
2954 510 CONTINUE
2955
2956C...Document independent fragmentation system. Remove copy of jets.
2957 nsav=nsav+1
2958 k(nsav,1)=11
2959 k(nsav,2)=93
2960 k(nsav,3)=ip
2961 k(nsav,4)=nsav+1
2962 k(nsav,5)=n-njet+1
2963 DO 520 j=1,4
2964 p(nsav,j)=dps(j)
2965 v(nsav,j)=v(ip,j)
2966 520 CONTINUE
2967 p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
2968 v(nsav,5)=0.
2969 DO 540 i=nsav+njet,n
2970 DO 530 j=1,5
2971 k(i-njet+1,j)=k(i,j)
2972 p(i-njet+1,j)=p(i,j)
2973 v(i-njet+1,j)=v(i,j)
2974 530 CONTINUE
2975 540 CONTINUE
2976 n=n-njet+1
2977 DO 550 iz=mstu90+1,mstu(90)
2978 mstu(90+iz)=mstu(90+iz)-njet+1
2979 550 CONTINUE
2980
2981C...Boost back particle system. Set production vertices.
2982 IF(njet.NE.1) CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),
2983 &dps(2)/dps(4),dps(3)/dps(4))
2984 DO 570 i=nsav+1,n
2985 DO 560 j=1,4
2986 v(i,j)=v(ip,j)
2987 560 CONTINUE
2988 570 CONTINUE
2989
2990 RETURN
2991 END
2992
2993C*********************************************************************
2994
2995 SUBROUTINE ludecy(IP)
2996
2997C...Purpose: to handle the decay of unstable particles.
2998 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
2999 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3000 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3001 common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
3002 SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
3003 dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
3004 &wtcor(10)
3005 DATA wtcor/2.,5.,15.,60.,250.,1500.,1.2e4,1.2e5,150.,16./
3006
3007C...Functions: momentum in two-particle decays, four-product and
3008C...matrix element times phase space in weak decays.
3009 pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2.*a)
3010 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)
3011 hmeps(ha)=((1.-hrq-ha)**2+3.*ha*(1.+hrq-ha))*
3012 &sqrt((1.-hrq-ha)**2-4.*hrq*ha)
3013
3014C...Initial values.
3015 ntry=0
3016 nsav=n
3017 kfa=iabs(k(ip,2))
3018 kfs=isign(1,k(ip,2))
3019 kc=lucomp(kfa)
3020 mstj(92)=0
3021
3022C...Choose lifetime and determine decay vertex.
3023 IF(k(ip,1).EQ.5) THEN
3024 v(ip,5)=0.
3025 ELSEIF(k(ip,1).NE.4) THEN
3026 v(ip,5)=-pmas(kc,4)*log(rlu(0))
3027 ENDIF
3028 DO 100 j=1,4
3029 vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
3030 100 CONTINUE
3031
3032C...Determine whether decay allowed or not.
3033 mout=0
3034 IF(mstj(22).EQ.2) THEN
3035 IF(pmas(kc,4).GT.parj(71)) mout=1
3036 ELSEIF(mstj(22).EQ.3) THEN
3037 IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
3038 ELSEIF(mstj(22).EQ.4) THEN
3039 IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
3040 IF(abs(vdcy(3)).GT.parj(74)) mout=1
3041 ENDIF
3042 IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
3043 k(ip,1)=4
3044 RETURN
3045 ENDIF
3046
3047C...B-B~ mixing: flip sign of meson appropriately.
3048 mmix=0
3049 IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN
3050 xbbmix=parj(76)
3051 IF(kfa.EQ.531) xbbmix=parj(77)
3052 IF(sin(0.5*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.rlu(0)) mmix=1
3053 IF(mmix.EQ.1) kfs=-kfs
3054 ENDIF
3055
3056C...Check existence of decay channels. Particle/antiparticle rules.
3057 kca=kc
3058 IF(mdcy(kc,2).GT.0) THEN
3059 mdmdcy=mdme(mdcy(kc,2),2)
3060 IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
3061 ENDIF
3062 IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
3063 CALL luerrm(9,'(LUDECY:) no decay channel defined')
3064 RETURN
3065 ENDIF
3066 IF(mod(kfa/1000,10).EQ.0.AND.(kca.EQ.85.OR.kca.EQ.87)) kfs=-kfs
3067 IF(kchg(kc,3).EQ.0) THEN
3068 kfsp=1
3069 kfsn=0
3070 IF(rlu(0).GT.0.5) kfs=-kfs
3071 ELSEIF(kfs.GT.0) THEN
3072 kfsp=1
3073 kfsn=0
3074 ELSE
3075 kfsp=0
3076 kfsn=1
3077 ENDIF
3078
3079C...Sum branching ratios of allowed decay channels.
3080 110 nope=0
3081 brsu=0.
3082 DO 120 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
3083 IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
3084 &kfsn*mdme(idl,1).NE.3) GOTO 120
3085 IF(mdme(idl,2).GT.100) GOTO 120
3086 nope=nope+1
3087 brsu=brsu+brat(idl)
3088 120 CONTINUE
3089 IF(nope.EQ.0) THEN
3090 CALL luerrm(2,'(LUDECY:) all decay channels closed by user')
3091 RETURN
3092 ENDIF
3093
3094C...Select decay channel among allowed ones.
3095 130 rbr=brsu*rlu(0)
3096 idl=mdcy(kca,2)-1
3097 140 idl=idl+1
3098 IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
3099 &kfsn*mdme(idl,1).NE.3) THEN
3100 IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 140
3101 ELSEIF(mdme(idl,2).GT.100) THEN
3102 IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 140
3103 ELSE
3104 idc=idl
3105 rbr=rbr-brat(idl)
3106 IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0.) GOTO 140
3107 ENDIF
3108
3109C...Start readout of decay channel: matrix element, reset counters.
3110 mmat=mdme(idc,2)
3111 150 ntry=ntry+1
3112 IF(ntry.GT.1000) THEN
3113 CALL luerrm(14,'(LUDECY:) caught in infinite loop')
3114 IF(mstu(21).GE.1) RETURN
3115 ENDIF
3116 i=n
3117 np=0
3118 nq=0
3119 mbst=0
3120 IF(mmat.GE.11.AND.mmat.NE.46.AND.p(ip,4).GT.20.*p(ip,5)) mbst=1
3121 DO 160 j=1,4
3122 pv(1,j)=0.
3123 IF(mbst.EQ.0) pv(1,j)=p(ip,j)
3124 160 CONTINUE
3125 IF(mbst.EQ.1) pv(1,4)=p(ip,5)
3126 pv(1,5)=p(ip,5)
3127 ps=0.
3128 psq=0.
3129 mrem=0
3130 mhaddy=0
3131 IF(kfa.GT.80) mhaddy=1
3132
3133C...Read out decay products. Convert to standard flavour code.
3134 jtmax=5
3135 IF(mdme(idc+1,2).EQ.101) jtmax=10
3136 DO 170 jt=1,jtmax
3137 IF(jt.LE.5) kp=kfdp(idc,jt)
3138 IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
3139 IF(kp.EQ.0) GOTO 170
3140 kpa=iabs(kp)
3141 kcp=lucomp(kpa)
3142 IF(kpa.GT.80) mhaddy=1
3143 IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
3144 kfp=kp
3145 ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
3146 kfp=kfs*kp
3147 ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
3148 kfp=-kfs*mod(kfa/10,10)
3149 ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
3150 kfp=kfs*(100*mod(kfa/10,100)+3)
3151 ELSEIF(kpa.EQ.81) THEN
3152 kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
3153 ELSEIF(kp.EQ.82) THEN
3154 CALL lukfdi(-kfs*int(1.+(2.+parj(2))*rlu(0)),0,kfp,kdump)
3155 IF(kfp.EQ.0) GOTO 150
3156 mstj(93)=1
3157 IF(pv(1,5).LT.parj(32)+2.*ulmass(kfp)) GOTO 150
3158 ELSEIF(kp.EQ.-82) THEN
3159 kfp=-kfp
3160 IF(iabs(kfp).GT.10) kfp=kfp+isign(10000,kfp)
3161 ENDIF
3162 IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=lucomp(kfp)
3163
3164C...Add decay product to event record or to quark flavour list.
3165 kfpa=iabs(kfp)
3166 kqp=kchg(kcp,2)
3167 IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
3168 nq=nq+1
3169 kflo(nq)=kfp
3170 mstj(93)=2
3171 psq=psq+ulmass(kflo(nq))
3172 ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.
3173 &mod(nq,2).EQ.1) THEN
3174 nq=nq-1
3175 ps=ps-p(i,5)
3176 k(i,1)=1
3177 kfi=k(i,2)
3178 CALL lukfdi(kfp,kfi,kfldmp,k(i,2))
3179 IF(k(i,2).EQ.0) GOTO 150
3180 mstj(93)=1
3181 p(i,5)=ulmass(k(i,2))
3182 ps=ps+p(i,5)
3183 ELSE
3184 i=i+1
3185 np=np+1
3186 IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
3187 IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
3188 k(i,1)=1+mod(nq,2)
3189 IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
3190 IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
3191 k(i,2)=kfp
3192 k(i,3)=ip
3193 k(i,4)=0
3194 k(i,5)=0
3195 p(i,5)=ulmass(kfp)
3196 IF(mmat.EQ.45.AND.kfpa.EQ.89) p(i,5)=parj(32)
3197 ps=ps+p(i,5)
3198 ENDIF
3199 170 CONTINUE
3200
3201C...Check masses for resonance decays.
3202 IF(mhaddy.EQ.0) THEN
3203 IF(ps+parj(64).GT.pv(1,5)) GOTO 130
3204 ENDIF
3205
3206C...Choose decay multiplicity in phase space model.
3207 180 IF(mmat.GE.11.AND.mmat.LE.30) THEN
3208 psp=ps
3209 cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1))
3210 IF(mmat.EQ.12) cnde=cnde+parj(63)
3211 190 ntry=ntry+1
3212 IF(ntry.GT.1000) THEN
3213 CALL luerrm(14,'(LUDECY:) caught in infinite loop')
3214 IF(mstu(21).GE.1) RETURN
3215 ENDIF
3216 IF(mmat.LE.20) THEN
3217 gauss=sqrt(-2.*cnde*log(max(1e-10,rlu(0))))*
3218 & sin(paru(2)*rlu(0))
3219 nd=0.5+0.5*np+0.25*nq+cnde+gauss
3220 IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) GOTO 190
3221 IF(mmat.EQ.13.AND.nd.EQ.2) GOTO 190
3222 IF(mmat.EQ.14.AND.nd.LE.3) GOTO 190
3223 IF(mmat.EQ.15.AND.nd.LE.4) GOTO 190
3224 ELSE
3225 nd=mmat-20
3226 ENDIF
3227
3228C...Form hadrons from flavour content.
3229 DO 200 jt=1,4
3230 kfl1(jt)=kflo(jt)
3231 200 CONTINUE
3232 IF(nd.EQ.np+nq/2) GOTO 220
3233 DO 210 i=n+np+1,n+nd-nq/2
3234 jt=1+int((nq-1)*rlu(0))
3235 CALL lukfdi(kfl1(jt),0,kfl2,k(i,2))
3236 IF(k(i,2).EQ.0) GOTO 190
3237 kfl1(jt)=-kfl2
3238 210 CONTINUE
3239 220 jt=2
3240 jt2=3
3241 jt3=4
3242 IF(nq.EQ.4.AND.rlu(0).LT.parj(66)) jt=4
3243 IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
3244 & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
3245 IF(jt.EQ.3) jt2=2
3246 IF(jt.EQ.4) jt3=2
3247 CALL lukfdi(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
3248 IF(k(n+nd-nq/2+1,2).EQ.0) GOTO 190
3249 IF(nq.EQ.4) CALL lukfdi(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
3250 IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) GOTO 190
3251
3252C...Check that sum of decay product masses not too large.
3253 ps=psp
3254 DO 230 i=n+np+1,n+nd
3255 k(i,1)=1
3256 k(i,3)=ip
3257 k(i,4)=0
3258 k(i,5)=0
3259 p(i,5)=ulmass(k(i,2))
3260 ps=ps+p(i,5)
3261 230 CONTINUE
3262 IF(ps+parj(64).GT.pv(1,5)) GOTO 190
3263
3264C...Rescale energy to subtract off spectator quark mass.
3265 ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44.OR.mmat.EQ.45).
3266 &and.np.GE.3) THEN
3267 ps=ps-p(n+np,5)
3268 pqt=(p(n+np,5)+parj(65))/pv(1,5)
3269 DO 240 j=1,5
3270 p(n+np,j)=pqt*pv(1,j)
3271 pv(1,j)=(1.-pqt)*pv(1,j)
3272 240 CONTINUE
3273 IF(ps+parj(64).GT.pv(1,5)) GOTO 150
3274 nd=np-1
3275 mrem=1
3276
3277C...Phase space factors imposed in W decay.
3278 ELSEIF(mmat.EQ.46) THEN
3279 mstj(93)=1
3280 psmc=ulmass(k(n+1,2))
3281 mstj(93)=1
3282 psmc=psmc+ulmass(k(n+2,2))
3283 IF(max(ps,psmc)+parj(32).GT.pv(1,5)) GOTO 130
3284 hr1=(p(n+1,5)/pv(1,5))**2
3285 hr2=(p(n+2,5)/pv(1,5))**2
3286 IF((1.-hr1-hr2)*(2.+hr1+hr2)*sqrt((1.-hr1-hr2)**2-4.*hr1*hr2).
3287 & lt.2.*rlu(0)) GOTO 130
3288 nd=np
3289
3290C...Fully specified final state: check mass broadening effects.
3291 ELSE
3292 IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) GOTO 150
3293 nd=np
3294 ENDIF
3295
3296C...Select W mass in decay Q -> W + q, without W propagator.
3297 IF(mmat.EQ.45.AND.mstj(25).LE.0) THEN
3298 hlq=(parj(32)/pv(1,5))**2
3299 huq=(1.-(p(n+2,5)+parj(64))/pv(1,5))**2
3300 hrq=(p(n+2,5)/pv(1,5))**2
3301 250 hw=hlq+rlu(0)*(huq-hlq)
3302 IF(hmeps(hw).LT.rlu(0)) GOTO 250
3303 p(n+1,5)=pv(1,5)*sqrt(hw)
3304
3305C...Ditto, including W propagator. Divide mass range into three regions.
3306 ELSEIF(mmat.EQ.45) THEN
3307 hqw=(pv(1,5)/pmas(24,1))**2
3308 hlw=(parj(32)/pmas(24,1))**2
3309 huw=((pv(1,5)-p(n+2,5)-parj(64))/pmas(24,1))**2
3310 hrq=(p(n+2,5)/pv(1,5))**2
3311 hg=pmas(24,2)/pmas(24,1)
3312 hatl=atan((hlw-1.)/hg)
3313 hm=min(1.,huw-0.001)
3314 hmv1=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
3315 260 hm=hm-hg
3316 hmv2=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
3317 IF(hmv2.GT.hmv1.AND.hm-hg.GT.hlw) THEN
3318 hmv1=hmv2
3319 GOTO 260
3320 ENDIF
3321 hmv=min(2.*hmv1,hmeps(hm/hqw)/hg**2)
3322 hm1=1.-sqrt(1./hmv-hg**2)
3323 IF(hm1.GT.hlw.AND.hm1.LT.hm) THEN
3324 hm=hm1
3325 ELSEIF(hmv2.LE.hmv1) THEN
3326 hm=max(hlw,hm-min(0.1,1.-hm))
3327 ENDIF
3328 hatm=atan((hm-1.)/hg)
3329 hwt1=(hatm-hatl)/hg
3330 hwt2=hmv*(min(1.,huw)-hm)
3331 hwt3=0.
3332 IF(huw.GT.1.) THEN
3333 hatu=atan((huw-1.)/hg)
3334 hmp1=hmeps(1./hqw)
3335 hwt3=hmp1*hatu/hg
3336 ENDIF
3337
3338C...Select mass region and W mass there. Accept according to weight.
3339 270 hreg=rlu(0)*(hwt1+hwt2+hwt3)
3340 IF(hreg.LE.hwt1) THEN
3341 hw=1.+hg*tan(hatl+rlu(0)*(hatm-hatl))
3342 hacc=hmeps(hw/hqw)
3343 ELSEIF(hreg.LE.hwt1+hwt2) THEN
3344 hw=hm+rlu(0)*(min(1.,huw)-hm)
3345 hacc=hmeps(hw/hqw)/((hw-1.)**2+hg**2)/hmv
3346 ELSE
3347 hw=1.+hg*tan(rlu(0)*hatu)
3348 hacc=hmeps(hw/hqw)/hmp1
3349 ENDIF
3350 IF(hacc.LT.rlu(0)) GOTO 270
3351 p(n+1,5)=pmas(24,1)*sqrt(hw)
3352 ENDIF
3353
3354C...Determine position of grandmother, number of sisters, Q -> W sign.
3355 nm=0
3356 kfas=0
3357 msgn=0
3358 IF(mmat.EQ.3.OR.mmat.EQ.46) THEN
3359 im=k(ip,3)
3360 IF(im.LT.0.OR.im.GE.ip) im=0
3361 IF(mmat.EQ.46.AND.mstj(27).EQ.1) THEN
3362 im=0
3363 ELSEIF(mmat.EQ.46.AND.mstj(27).GE.2.AND.im.NE.0) THEN
3364 IF(k(im,2).EQ.94) THEN
3365 im=k(k(im,3),3)
3366 IF(im.LT.0.OR.im.GE.ip) im=0
3367 ENDIF
3368 ENDIF
3369 IF(im.NE.0) kfam=iabs(k(im,2))
3370 IF(im.NE.0.AND.mmat.EQ.3) THEN
3371 DO 280 il=max(ip-2,im+1),min(ip+2,n)
3372 IF(k(il,3).EQ.im) nm=nm+1
3373 IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il
3374 280 CONTINUE
3375 IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
3376 & mod(kfam/1000,10).NE.0) nm=0
3377 IF(nm.EQ.2) THEN
3378 kfas=iabs(k(isis,2))
3379 IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.
3380 & mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0
3381 ENDIF
3382 ELSEIF(im.NE.0.AND.mmat.EQ.46) THEN
3383 msgn=isign(1,k(im,2)*k(ip,2))
3384 IF(kfam.GT.100.AND.mod(kfam/1000,10).EQ.0) msgn=
3385 & msgn*(-1)**mod(kfam/100,10)
3386 ENDIF
3387 ENDIF
3388
3389C...Kinematics of one-particle decays.
3390 IF(nd.EQ.1) THEN
3391 DO 290 j=1,4
3392 p(n+1,j)=p(ip,j)
3393 290 CONTINUE
3394 GOTO 550
3395 ENDIF
3396
3397C...Calculate maximum weight ND-particle decay.
3398 pv(nd,5)=p(n+nd,5)
3399 IF(nd.GE.3) THEN
3400 wtmax=1./wtcor(nd-2)
3401 pmax=pv(1,5)-ps+p(n+nd,5)
3402 pmin=0.
3403 DO 300 il=nd-1,1,-1
3404 pmax=pmax+p(n+il,5)
3405 pmin=pmin+p(n+il+1,5)
3406 wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
3407 300 CONTINUE
3408 ENDIF
3409
3410C...Find virtual gamma mass in Dalitz decay.
3411 310 IF(nd.EQ.2) THEN
3412 ELSEIF(mmat.EQ.2) THEN
3413 pmes=4.*pmas(11,1)**2
3414 pmrho2=pmas(131,1)**2
3415 pgrho2=pmas(131,2)**2
3416 320 pmst=pmes*(p(ip,5)**2/pmes)**rlu(0)
3417 wt=(1+0.5*pmes/pmst)*sqrt(max(0.,1.-pmes/pmst))*
3418 & (1.-pmst/p(ip,5)**2)**3*(1.+pgrho2/pmrho2)/
3419 & ((1.-pmst/pmrho2)**2+pgrho2/pmrho2)
3420 IF(wt.LT.rlu(0)) GOTO 320
3421 pv(2,5)=max(2.00001*pmas(11,1),sqrt(pmst))
3422
3423C...M-generator gives weight. If rejected, try again.
3424 ELSE
3425 330 rord(1)=1.
3426 DO 360 il1=2,nd-1
3427 rsav=rlu(0)
3428 DO 340 il2=il1-1,1,-1
3429 IF(rsav.LE.rord(il2)) GOTO 350
3430 rord(il2+1)=rord(il2)
3431 340 CONTINUE
3432 350 rord(il2+1)=rsav
3433 360 CONTINUE
3434 rord(nd)=0.
3435 wt=1.
3436 DO 370 il=nd-1,1,-1
3437 pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*(pv(1,5)-ps)
3438 wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
3439 370 CONTINUE
3440 IF(wt.LT.rlu(0)*wtmax) GOTO 330
3441 ENDIF
3442
3443C...Perform two-particle decays in respective CM frame.
3444 380 DO 400 il=1,nd-1
3445 pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
3446 ue(3)=2.*rlu(0)-1.
3447 phi=paru(2)*rlu(0)
3448 ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
3449 ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
3450 DO 390 j=1,3
3451 p(n+il,j)=pa*ue(j)
3452 pv(il+1,j)=-pa*ue(j)
3453 390 CONTINUE
3454 p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
3455 pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
3456 400 CONTINUE
3457
3458C...Lorentz transform decay products to lab frame.
3459 DO 410 j=1,4
3460 p(n+nd,j)=pv(nd,j)
3461 410 CONTINUE
3462 DO 450 il=nd-1,1,-1
3463 DO 420 j=1,3
3464 be(j)=pv(il,j)/pv(il,4)
3465 420 CONTINUE
3466 ga=pv(il,4)/pv(il,5)
3467 DO 440 i=n+il,n+nd
3468 bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
3469 DO 430 j=1,3
3470 p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
3471 430 CONTINUE
3472 p(i,4)=ga*(p(i,4)+bep)
3473 440 CONTINUE
3474 450 CONTINUE
3475
3476C...Check that no infinite loop in matrix element weight.
3477 ntry=ntry+1
3478 IF(ntry.GT.800) GOTO 480
3479
3480C...Matrix elements for omega and phi decays.
3481 IF(mmat.EQ.1) THEN
3482 wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
3483 & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
3484 & +2.*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
3485 IF(max(wt*wtcor(9)/p(ip,5)**6,0.001).LT.rlu(0)) GOTO 310
3486
3487C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
3488 ELSEIF(mmat.EQ.2) THEN
3489 four12=four(n+1,n+2)
3490 four13=four(n+1,n+3)
3491 wt=(pmst-0.5*pmes)*(four12**2+four13**2)+
3492 & pmes*(four12*four13+four12**2+four13**2)
3493 IF(wt.LT.rlu(0)*0.25*pmst*(p(ip,5)**2-pmst)**2) GOTO 380
3494
3495C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
3496C...V vector), of form cos**2(theta02) in V1 rest frame, and for
3497C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
3498 ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
3499 four10=four(ip,im)
3500 four12=four(ip,n+1)
3501 four02=four(im,n+1)
3502 pms1=p(ip,5)**2
3503 pms0=p(im,5)**2
3504 pms2=p(n+1,5)**2
3505 IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2
3506 IF(kfas.EQ.22) hnum=pms1*(2.*four10*four12*four02-
3507 & pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)
3508 hnum=max(1e-6*pms1**2*pms0*pms2,hnum)
3509 hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)
3510 IF(hnum.LT.rlu(0)*hden) GOTO 380
3511
3512C...Matrix element for "onium" -> g + g + g or gamma + g + g.
3513 ELSEIF(mmat.EQ.4) THEN
3514 hx1=2.*four(ip,n+1)/p(ip,5)**2
3515 hx2=2.*four(ip,n+2)/p(ip,5)**2
3516 hx3=2.*four(ip,n+3)/p(ip,5)**2
3517 wt=((1.-hx1)/(hx2*hx3))**2+((1.-hx2)/(hx1*hx3))**2+
3518 & ((1.-hx3)/(hx1*hx2))**2
3519 IF(wt.LT.2.*rlu(0)) GOTO 310
3520 IF(k(ip+1,2).EQ.22.AND.(1.-hx1)*p(ip,5)**2.LT.4.*parj(32)**2)
3521 & GOTO 310
3522
3523C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
3524 ELSEIF(mmat.EQ.41) THEN
3525 hx1=2.*four(ip,n+1)/p(ip,5)**2
3526 hxm=min(0.75,2.*(1.-ps/p(ip,5)))
3527 IF(hx1*(3.-2.*hx1).LT.rlu(0)*hxm*(3.-2.*hxm)) GOTO 310
3528
3529C...Matrix elements for weak decays (only semileptonic for c and b)
3530 ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
3531 &.AND.nd.EQ.3) THEN
3532 IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
3533 IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
3534 IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 310
3535 ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN
3536 DO 470 j=1,4
3537 p(n+np+1,j)=0.
3538 DO 460 is=n+3,n+np
3539 p(n+np+1,j)=p(n+np+1,j)+p(is,j)
3540 460 CONTINUE
3541 470 CONTINUE
3542 IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
3543 IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
3544 IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 310
3545
3546C...Angular distribution in W decay.
3547 ELSEIF(mmat.EQ.46.AND.msgn.NE.0) THEN
3548 IF(msgn.GT.0) wt=four(im,n+1)*four(n+2,ip+1)
3549 IF(msgn.LT.0) wt=four(im,n+2)*four(n+1,ip+1)
3550 IF(wt.LT.rlu(0)*p(im,5)**4/wtcor(10)) GOTO 380
3551 ENDIF
3552
3553C...Scale back energy and reattach spectator.
3554 480 IF(mrem.EQ.1) THEN
3555 DO 490 j=1,5
3556 pv(1,j)=pv(1,j)/(1.-pqt)
3557 490 CONTINUE
3558 nd=nd+1
3559 mrem=0
3560 ENDIF
3561
3562C...Low invariant mass for system with spectator quark gives particle,
3563C...not two jets. Readjust momenta accordingly.
3564 IF((mmat.EQ.31.OR.mmat.EQ.45).AND.nd.EQ.3) THEN
3565 mstj(93)=1
3566 pm2=ulmass(k(n+2,2))
3567 mstj(93)=1
3568 pm3=ulmass(k(n+3,2))
3569 IF(p(n+2,5)**2+p(n+3,5)**2+2.*four(n+2,n+3).GE.
3570 & (parj(32)+pm2+pm3)**2) GOTO 550
3571 k(n+2,1)=1
3572 kftemp=k(n+2,2)
3573 CALL lukfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
3574 IF(k(n+2,2).EQ.0) GOTO 150
3575 p(n+2,5)=ulmass(k(n+2,2))
3576 ps=p(n+1,5)+p(n+2,5)
3577 pv(2,5)=p(n+2,5)
3578 mmat=0
3579 nd=2
3580 GOTO 380
3581 ELSEIF(mmat.EQ.44) THEN
3582 mstj(93)=1
3583 pm3=ulmass(k(n+3,2))
3584 mstj(93)=1
3585 pm4=ulmass(k(n+4,2))
3586 IF(p(n+3,5)**2+p(n+4,5)**2+2.*four(n+3,n+4).GE.
3587 & (parj(32)+pm3+pm4)**2) GOTO 520
3588 k(n+3,1)=1
3589 kftemp=k(n+3,2)
3590 CALL lukfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
3591 IF(k(n+3,2).EQ.0) GOTO 150
3592 p(n+3,5)=ulmass(k(n+3,2))
3593 DO 500 j=1,3
3594 p(n+3,j)=p(n+3,j)+p(n+4,j)
3595 500 CONTINUE
3596 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)
3597 ha=p(n+1,4)**2-p(n+2,4)**2
3598 hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
3599 hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
3600 & (p(n+1,3)-p(n+2,3))**2
3601 hd=(pv(1,4)-p(n+3,4))**2
3602 he=ha**2-2.*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
3603 hf=hd*hc-hb**2
3604 hg=hd*hc-ha*hb
3605 hh=(sqrt(hg**2+he*hf)-hg)/(2.*hf)
3606 DO 510 j=1,3
3607 pcor=hh*(p(n+1,j)-p(n+2,j))
3608 p(n+1,j)=p(n+1,j)+pcor
3609 p(n+2,j)=p(n+2,j)-pcor
3610 510 CONTINUE
3611 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)
3612 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)
3613 nd=nd-1
3614 ENDIF
3615
3616C...Check invariant mass of W jets. May give one particle or start over.
3617 520 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
3618 &.AND.iabs(k(n+1,2)).LT.10) THEN
3619 pmr=sqrt(max(0.,p(n+1,5)**2+p(n+2,5)**2+2.*four(n+1,n+2)))
3620 mstj(93)=1
3621 pm1=ulmass(k(n+1,2))
3622 mstj(93)=1
3623 pm2=ulmass(k(n+2,2))
3624 IF(pmr.GT.parj(32)+pm1+pm2) GOTO 530
3625 kfldum=int(1.5+rlu(0))
3626 CALL lukfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
3627 CALL lukfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
3628 IF(kf1.EQ.0.OR.kf2.EQ.0) GOTO 150
3629 psm=ulmass(kf1)+ulmass(kf2)
3630 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) GOTO 530
3631 IF(mmat.GE.43.AND.pmr.GT.0.2*parj(32)+psm) GOTO 530
3632 IF(mmat.EQ.48) GOTO 310
3633 IF(nd.EQ.4.OR.kfa.EQ.15) GOTO 150
3634 k(n+1,1)=1
3635 kftemp=k(n+1,2)
3636 CALL lukfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
3637 IF(k(n+1,2).EQ.0) GOTO 150
3638 p(n+1,5)=ulmass(k(n+1,2))
3639 k(n+2,2)=k(n+3,2)
3640 p(n+2,5)=p(n+3,5)
3641 ps=p(n+1,5)+p(n+2,5)
3642 IF(ps+parj(64).GT.pv(1,5)) GOTO 150
3643 pv(2,5)=p(n+3,5)
3644 mmat=0
3645 nd=2
3646 GOTO 380
3647 ENDIF
3648
3649C...Phase space decay of partons from W decay.
3650 530 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN
3651 kflo(1)=k(n+1,2)
3652 kflo(2)=k(n+2,2)
3653 k(n+1,1)=k(n+3,1)
3654 k(n+1,2)=k(n+3,2)
3655 DO 540 j=1,5
3656 pv(1,j)=p(n+1,j)+p(n+2,j)
3657 p(n+1,j)=p(n+3,j)
3658 540 CONTINUE
3659 pv(1,5)=pmr
3660 n=n+1
3661 np=0
3662 nq=2
3663 ps=0.
3664 mstj(93)=2
3665 psq=ulmass(kflo(1))
3666 mstj(93)=2
3667 psq=psq+ulmass(kflo(2))
3668 mmat=11
3669 GOTO 180
3670 ENDIF
3671
3672C...Boost back for rapidly moving particle.
3673 550 n=n+nd
3674 IF(mbst.EQ.1) THEN
3675 DO 560 j=1,3
3676 be(j)=p(ip,j)/p(ip,4)
3677 560 CONTINUE
3678 ga=p(ip,4)/p(ip,5)
3679 DO 580 i=nsav+1,n
3680 bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
3681 DO 570 j=1,3
3682 p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
3683 570 CONTINUE
3684 p(i,4)=ga*(p(i,4)+bep)
3685 580 CONTINUE
3686 ENDIF
3687
3688C...Fill in position of decay vertex.
3689 DO 600 i=nsav+1,n
3690 DO 590 j=1,4
3691 v(i,j)=vdcy(j)
3692 590 CONTINUE
3693 v(i,5)=0.
3694 600 CONTINUE
3695
3696C...Set up for parton shower evolution from jets.
3697 IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
3698 k(nsav+1,1)=3
3699 k(nsav+2,1)=3
3700 k(nsav+3,1)=3
3701 k(nsav+1,4)=mstu(5)*(nsav+2)
3702 k(nsav+1,5)=mstu(5)*(nsav+3)
3703 k(nsav+2,4)=mstu(5)*(nsav+3)
3704 k(nsav+2,5)=mstu(5)*(nsav+1)
3705 k(nsav+3,4)=mstu(5)*(nsav+1)
3706 k(nsav+3,5)=mstu(5)*(nsav+2)
3707 mstj(92)=-(nsav+1)
3708 ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
3709 k(nsav+2,1)=3
3710 k(nsav+3,1)=3
3711 k(nsav+2,4)=mstu(5)*(nsav+3)
3712 k(nsav+2,5)=mstu(5)*(nsav+3)
3713 k(nsav+3,4)=mstu(5)*(nsav+2)
3714 k(nsav+3,5)=mstu(5)*(nsav+2)
3715 mstj(92)=nsav+2
3716 ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46).
3717 &and.iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
3718 k(nsav+1,1)=3
3719 k(nsav+2,1)=3
3720 k(nsav+1,4)=mstu(5)*(nsav+2)
3721 k(nsav+1,5)=mstu(5)*(nsav+2)
3722 k(nsav+2,4)=mstu(5)*(nsav+1)
3723 k(nsav+2,5)=mstu(5)*(nsav+1)
3724 mstj(92)=nsav+1
3725 ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46).
3726 &and.iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN
3727 mstj(92)=nsav+1
3728 ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
3729 &THEN
3730 k(nsav+1,1)=3
3731 k(nsav+2,1)=3
3732 k(nsav+3,1)=3
3733 kcp=lucomp(k(nsav+1,2))
3734 kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
3735 jcon=4
3736 IF(kqp.LT.0) jcon=5
3737 k(nsav+1,jcon)=mstu(5)*(nsav+2)
3738 k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
3739 k(nsav+2,jcon)=mstu(5)*(nsav+3)
3740 k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
3741 mstj(92)=nsav+1
3742 ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
3743 k(nsav+1,1)=3
3744 k(nsav+3,1)=3
3745 k(nsav+1,4)=mstu(5)*(nsav+3)
3746 k(nsav+1,5)=mstu(5)*(nsav+3)
3747 k(nsav+3,4)=mstu(5)*(nsav+1)
3748 k(nsav+3,5)=mstu(5)*(nsav+1)
3749 mstj(92)=nsav+1
3750
3751C...Set up for parton shower evolution in t -> W + b.
3752 ELSEIF(mstj(27).GE.1.AND.mmat.EQ.45.AND.nd.EQ.3) THEN
3753 k(nsav+2,1)=3
3754 k(nsav+3,1)=3
3755 k(nsav+2,4)=mstu(5)*(nsav+3)
3756 k(nsav+2,5)=mstu(5)*(nsav+3)
3757 k(nsav+3,4)=mstu(5)*(nsav+2)
3758 k(nsav+3,5)=mstu(5)*(nsav+2)
3759 mstj(92)=nsav+1
3760 ENDIF
3761
3762C...Mark decayed particle; special option for B-B~ mixing.
3763 IF(k(ip,1).EQ.5) k(ip,1)=15
3764 IF(k(ip,1).LE.10) k(ip,1)=11
3765 IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12
3766 k(ip,4)=nsav+1
3767 k(ip,5)=n
3768
3769 RETURN
3770 END
3771
3772C*********************************************************************
3773
3774 SUBROUTINE lukfdi(KFL1,KFL2,KFL3,KF)
3775
3776C...Purpose: to generate a new flavour pair and combine off a hadron.
3777 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3778 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3779 SAVE /ludat1/,/ludat2/
3780
3781C...Default flavour values. Input consistency checks.
3782 kf1a=iabs(kfl1)
3783 kf2a=iabs(kfl2)
3784 kfl3=0
3785 kf=0
3786 IF(kf1a.EQ.0) RETURN
3787 IF(kf2a.NE.0) THEN
3788 IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
3789 IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
3790 IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
3791 ENDIF
3792
3793C...Check if tabulated flavour probabilities are to be used.
3794 IF(mstj(15).EQ.1) THEN
3795 ktab1=-1
3796 IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
3797 kfl1a=mod(kf1a/1000,10)
3798 kfl1b=mod(kf1a/100,10)
3799 kfl1s=mod(kf1a,10)
3800 IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
3801 & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
3802 IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
3803 IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
3804 ktab2=0
3805 IF(kf2a.NE.0) THEN
3806 ktab2=-1
3807 IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
3808 kfl2a=mod(kf2a/1000,10)
3809 kfl2b=mod(kf2a/100,10)
3810 kfl2s=mod(kf2a,10)
3811 IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
3812 & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
3813 IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
3814 ENDIF
3815 IF(ktab1.GE.0.AND.ktab2.GE.0) GOTO 150
3816 ENDIF
3817
3818C...Parameters and breaking diquark parameter combinations.
3819 100 par2=parj(2)
3820 par3=parj(3)
3821 par4=3.*parj(4)
3822 IF(mstj(12).GE.2) THEN
3823 par3m=sqrt(parj(3))
3824 par4m=1./(3.*sqrt(parj(4)))
3825 pardm=parj(7)/(parj(7)+par3m*parj(6))
3826 pars0=parj(5)*(2.+(1.+par2*par3m*parj(7))*(1.+par4m))
3827 pars1=parj(7)*pars0/(2.*par3m)+parj(5)*(parj(6)*(1.+par4m)+
3828 & par2*par3m*parj(6)*parj(7))
3829 pars2=parj(5)*2.*parj(6)*parj(7)*(par2*parj(7)+(1.+par4m)/par3m)
3830 parsm=max(pars0,pars1,pars2)
3831 par4=par4*(1.+parsm)/(1.+parsm/(3.*par4m))
3832 ENDIF
3833
3834C...Choice of whether to generate meson or baryon.
3835 110 mbary=0
3836 kfda=0
3837 IF(kf1a.LE.10) THEN
3838 IF(kf2a.EQ.0.AND.mstj(12).GE.1.AND.(1.+parj(1))*rlu(0).GT.1.)
3839 & mbary=1
3840 IF(kf2a.GT.10) mbary=2
3841 IF(kf2a.GT.10.AND.kf2a.LE.10000) kfda=kf2a
3842 ELSE
3843 mbary=2
3844 IF(kf1a.LE.10000) kfda=kf1a
3845 ENDIF
3846
3847C...Possibility of process diquark -> meson + new diquark.
3848 IF(kfda.NE.0.AND.mstj(12).GE.2) THEN
3849 kflda=mod(kfda/1000,10)
3850 kfldb=mod(kfda/100,10)
3851 kflds=mod(kfda,10)
3852 wtdq=pars0
3853 IF(max(kflda,kfldb).EQ.3) wtdq=pars1
3854 IF(min(kflda,kfldb).EQ.3) wtdq=pars2
3855 IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
3856 IF((1.+wtdq)*rlu(0).GT.1.) mbary=-1
3857 IF(mbary.EQ.-1.AND.kf2a.NE.0) RETURN
3858 ENDIF
3859
3860C...Flavour for meson, possibly with new flavour.
3861 IF(mbary.LE.0) THEN
3862 kfs=isign(1,kfl1)
3863 IF(mbary.EQ.0) THEN
3864 IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),-kfl1)
3865 kfla=max(kf1a,kf2a+iabs(kfl3))
3866 kflb=min(kf1a,kf2a+iabs(kfl3))
3867 IF(kfla.NE.kf1a) kfs=-kfs
3868
3869C...Splitting of diquark into meson plus new diquark.
3870 ELSE
3871 kfl1a=mod(kf1a/1000,10)
3872 kfl1b=mod(kf1a/100,10)
3873 120 kfl1d=kfl1a+int(rlu(0)+0.5)*(kfl1b-kfl1a)
3874 kfl1e=kfl1a+kfl1b-kfl1d
3875 IF((kfl1d.EQ.3.AND.rlu(0).GT.pardm).OR.(kfl1e.EQ.3.AND.
3876 & rlu(0).LT.pardm)) THEN
3877 kfl1d=kfl1a+kfl1b-kfl1d
3878 kfl1e=kfl1a+kfl1b-kfl1e
3879 ENDIF
3880 kfl3a=1+int((2.+par2*par3m*parj(7))*rlu(0))
3881 IF((kfl1e.NE.kfl3a.AND.rlu(0).GT.(1.+par4m)/max(2.,1.+par4m)).
3882 & or.(kfl1e.EQ.kfl3a.AND.rlu(0).GT.2./max(2.,1.+par4m)))
3883 & GOTO 120
3884 kflds=3
3885 IF(kfl1e.NE.kfl3a) kflds=2*int(rlu(0)+1./(1.+par4m))+1
3886 kfl3=isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+
3887 & kflds,-kfl1)
3888 kfla=max(kfl1d,kfl3a)
3889 kflb=min(kfl1d,kfl3a)
3890 IF(kfla.NE.kfl1d) kfs=-kfs
3891 ENDIF
3892
3893C...Form meson, with spin and flavour mixing for diagonal states.
3894 IF(kfla.LE.2) kmul=int(parj(11)+rlu(0))
3895 IF(kfla.EQ.3) kmul=int(parj(12)+rlu(0))
3896 IF(kfla.GE.4) kmul=int(parj(13)+rlu(0))
3897 IF(kmul.EQ.0.AND.parj(14).GT.0.) THEN
3898 IF(rlu(0).LT.parj(14)) kmul=2
3899 ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0.) THEN
3900 rmul=rlu(0)
3901 IF(rmul.LT.parj(15)) kmul=3
3902 IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
3903 IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
3904 ENDIF
3905 kfls=3
3906 IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
3907 IF(kmul.EQ.5) kfls=5
3908 IF(kfla.NE.kflb) THEN
3909 kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
3910 ELSE
3911 rmix=rlu(0)
3912 imix=2*kfla+10*kmul
3913 IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
3914 & int(rmix+parf(imix)))+kfls
3915 IF(kfla.GE.4) kf=110*kfla+kfls
3916 ENDIF
3917 IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
3918 IF(kmul.EQ.4) kf=kf+isign(20000,kf)
3919
3920C...Optional extra suppression of eta and eta'.
3921 IF(kf.EQ.221) THEN
3922 IF(rlu(0).GT.parj(25)) GOTO 110
3923 ELSEIF(kf.EQ.331) THEN
3924 IF(rlu(0).GT.parj(26)) GOTO 110
3925 ENDIF
3926
3927C...Generate diquark flavour.
3928 ELSE
3929 130 IF(kf1a.LE.10.AND.kf2a.EQ.0) THEN
3930 kfla=kf1a
3931 140 kflb=1+int((2.+par2*par3)*rlu(0))
3932 kflc=1+int((2.+par2*par3)*rlu(0))
3933 kflds=1
3934 IF(kflb.GE.kflc) kflds=3
3935 IF(kflds.EQ.1.AND.par4*rlu(0).GT.1.) GOTO 140
3936 IF(kflds.EQ.3.AND.par4.LT.rlu(0)) GOTO 140
3937 kfl3=isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds,kfl1)
3938
3939C...Take diquark flavour from input.
3940 ELSEIF(kf1a.LE.10) THEN
3941 kfla=kf1a
3942 kflb=mod(kf2a/1000,10)
3943 kflc=mod(kf2a/100,10)
3944 kflds=mod(kf2a,10)
3945
3946C...Generate (or take from input) quark to go with diquark.
3947 ELSE
3948 IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),kfl1)
3949 kfla=kf2a+iabs(kfl3)
3950 kflb=mod(kf1a/1000,10)
3951 kflc=mod(kf1a/100,10)
3952 kflds=mod(kf1a,10)
3953 ENDIF
3954
3955C...SU(6) factors for formation of baryon. Try again if fails.
3956 kbary=kflds
3957 IF(kflds.EQ.3.AND.kflb.NE.kflc) kbary=5
3958 IF(kfla.NE.kflb.AND.kfla.NE.kflc) kbary=kbary+1
3959 wt=parf(60+kbary)+parj(18)*parf(70+kbary)
3960 IF(mbary.EQ.1.AND.mstj(12).GE.2) THEN
3961 wtdq=pars0
3962 IF(max(kflb,kflc).EQ.3) wtdq=pars1
3963 IF(min(kflb,kflc).EQ.3) wtdq=pars2
3964 IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
3965 IF(kflds.EQ.1) wt=wt*(1.+wtdq)/(1.+parsm/(3.*par4m))
3966 IF(kflds.EQ.3) wt=wt*(1.+wtdq)/(1.+parsm)
3967 ENDIF
3968 IF(kf2a.EQ.0.AND.wt.LT.rlu(0)) GOTO 130
3969
3970C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
3971 kfld=max(kfla,kflb,kflc)
3972 kflf=min(kfla,kflb,kflc)
3973 kfle=kfla+kflb+kflc-kfld-kflf
3974 kfls=2
3975 IF((parf(60+kbary)+parj(18)*parf(70+kbary))*rlu(0).GT.
3976 & parf(60+kbary)) kfls=4
3977 kfll=0
3978 IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf) THEN
3979 IF(kflds.EQ.1.AND.kfla.EQ.kfld) kfll=1
3980 IF(kflds.EQ.1.AND.kfla.NE.kfld) kfll=int(0.25+rlu(0))
3981 IF(kflds.EQ.3.AND.kfla.NE.kfld) kfll=int(0.75+rlu(0))
3982 ENDIF
3983 IF(kfll.EQ.0) kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
3984 IF(kfll.EQ.1) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
3985 ENDIF
3986 RETURN
3987
3988C...Use tabulated probabilities to select new flavour and hadron.
3989 150 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
3990 kt3l=1
3991 kt3u=6
3992 ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
3993 kt3l=1
3994 kt3u=6
3995 ELSEIF(ktab2.EQ.0) THEN
3996 kt3l=1
3997 kt3u=22
3998 ELSE
3999 kt3l=ktab2
4000 kt3u=ktab2
4001 ENDIF
4002 rfl=0.
4003 DO 170 kts=0,2
4004 DO 160 kt3=kt3l,kt3u
4005 rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
4006 160 CONTINUE
4007 170 CONTINUE
4008 rfl=rlu(0)*rfl
4009 DO 190 kts=0,2
4010 ktabs=kts
4011 DO 180 kt3=kt3l,kt3u
4012 ktab3=kt3
4013 rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
4014 IF(rfl.LE.0.) GOTO 200
4015 180 CONTINUE
4016 190 CONTINUE
4017 200 CONTINUE
4018
4019C...Reconstruct flavour of produced quark/diquark.
4020 IF(ktab3.LE.6) THEN
4021 kfl3a=ktab3
4022 kfl3b=0
4023 kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
4024 ELSE
4025 kfl3a=1
4026 IF(ktab3.GE.8) kfl3a=2
4027 IF(ktab3.GE.11) kfl3a=3
4028 IF(ktab3.GE.16) kfl3a=4
4029 kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
4030 kfl3=1000*kfl3a+100*kfl3b+1
4031 IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
4032 & kfl3+2
4033 kfl3=isign(kfl3,kfl1*(13-2*ktab1))
4034 ENDIF
4035
4036C...Reconstruct meson code.
4037 IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
4038 &kfl3b.NE.0)) THEN
4039 rfl=rlu(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
4040 & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
4041 kf=110+2*ktabs+1
4042 IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
4043 IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
4044 & 25*ktabs)) kf=330+2*ktabs+1
4045 ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
4046 kfla=max(ktab1,ktab3)
4047 kflb=min(ktab1,ktab3)
4048 kfs=isign(1,kfl1)
4049 IF(kfla.NE.kf1a) kfs=-kfs
4050 kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
4051 ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
4052 kfs=isign(1,kfl1)
4053 IF(kfl1a.EQ.kfl3a) THEN
4054 kfla=max(kfl1b,kfl3b)
4055 kflb=min(kfl1b,kfl3b)
4056 IF(kfla.NE.kfl1b) kfs=-kfs
4057 ELSEIF(kfl1a.EQ.kfl3b) THEN
4058 kfla=kfl3a
4059 kflb=kfl1b
4060 kfs=-kfs
4061 ELSEIF(kfl1b.EQ.kfl3a) THEN
4062 kfla=kfl1a
4063 kflb=kfl3b
4064 ELSEIF(kfl1b.EQ.kfl3b) THEN
4065 kfla=max(kfl1a,kfl3a)
4066 kflb=min(kfl1a,kfl3a)
4067 IF(kfla.NE.kfl1a) kfs=-kfs
4068 ELSE
4069 CALL luerrm(2,'(LUKFDI:) no matching flavours for qq -> qq')
4070 GOTO 100
4071 ENDIF
4072 kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
4073
4074C...Reconstruct baryon code.
4075 ELSE
4076 IF(ktab1.GE.7) THEN
4077 kfla=kfl3a
4078 kflb=kfl1a
4079 kflc=kfl1b
4080 ELSE
4081 kfla=kfl1a
4082 kflb=kfl3a
4083 kflc=kfl3b
4084 ENDIF
4085 kfld=max(kfla,kflb,kflc)
4086 kflf=min(kfla,kflb,kflc)
4087 kfle=kfla+kflb+kflc-kfld-kflf
4088 IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
4089 IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
4090 ENDIF
4091
4092C...Check that constructed flavour code is an allowed one.
4093 IF(kfl2.NE.0) kfl3=0
4094 kc=lucomp(kf)
4095 IF(kc.EQ.0) THEN
4096 CALL luerrm(2,'(LUKFDI:) user-defined flavour probabilities '//
4097 & 'failed')
4098 GOTO 100
4099 ENDIF
4100
4101 RETURN
4102 END
4103
4104C*********************************************************************
4105
4106 SUBROUTINE luptdi(KFL,PX,PY)
4107
4108C...Purpose: to generate transverse momentum according to a Gaussian.
4109 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4110 SAVE /ludat1/
4111
4112C...Generate p_T and azimuthal angle, gives p_x and p_y.
4113 kfla=iabs(kfl)
4114 pt=parj(21)*sqrt(-log(max(1e-10,rlu(0))))
4115 IF(parj(23).GT.rlu(0)) pt=parj(24)*pt
4116 IF(mstj(91).EQ.1) pt=parj(22)*pt
4117 IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0.
4118 phi=paru(2)*rlu(0)
4119 px=pt*cos(phi)
4120 py=pt*sin(phi)
4121
4122 RETURN
4123 END
4124
4125C*********************************************************************
4126
4127 SUBROUTINE luzdis(KFL1,KFL2,PR,Z)
4128
4129C...Purpose: to generate the longitudinal splitting variable z.
4130 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4131 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4132 SAVE /ludat1/,/ludat2/
4133
4134C...Check if heavy flavour fragmentation.
4135 kfla=iabs(kfl1)
4136 kflb=iabs(kfl2)
4137 kflh=kfla
4138 IF(kfla.GE.10) kflh=mod(kfla/1000,10)
4139
4140C...Lund symmetric scaling function: determine parameters of shape.
4141 IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.
4142 &mstj(11).GE.4) THEN
4143 fa=parj(41)
4144 IF(mstj(91).EQ.1) fa=parj(43)
4145 IF(kflb.GE.10) fa=fa+parj(45)
4146 fbb=parj(42)
4147 IF(mstj(91).EQ.1) fbb=parj(44)
4148 fb=fbb*pr
4149 fc=1.
4150 IF(kfla.GE.10) fc=fc-parj(45)
4151 IF(kflb.GE.10) fc=fc+parj(45)
4152 IF(mstj(11).GE.4.AND.kflh.GE.4.AND.kflh.LE.5) THEN
4153 fred=parj(46)
4154 IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)
4155 fc=fc+fred*fbb*parf(100+kflh)**2
4156 ELSEIF(mstj(11).GE.4.AND.kflh.GE.6.AND.kflh.LE.8) THEN
4157 fred=parj(46)
4158 IF(mstj(11).EQ.5) fred=parj(48)
4159 fc=fc+fred*fbb*pmas(kflh,1)**2
4160 ENDIF
4161 mc=1
4162 IF(abs(fc-1.).GT.0.01) mc=2
4163
4164C...Determine position of maximum. Special cases for a = 0 or a = c.
4165 IF(fa.LT.0.02) THEN
4166 ma=1
4167 zmax=1.
4168 IF(fc.GT.fb) zmax=fb/fc
4169 ELSEIF(abs(fc-fa).LT.0.01) THEN
4170 ma=2
4171 zmax=fb/(fb+fc)
4172 ELSE
4173 ma=3
4174 zmax=0.5*(fb+fc-sqrt((fb-fc)**2+4.*fa*fb))/(fc-fa)
4175 IF(zmax.GT.0.9999.AND.fb.GT.100.) zmax=min(zmax,1.-fa/fb)
4176 ENDIF
4177
4178C...Subdivide z range if distribution very peaked near endpoint.
4179 mmax=2
4180 IF(zmax.LT.0.1) THEN
4181 mmax=1
4182 zdiv=2.75*zmax
4183 IF(mc.EQ.1) THEN
4184 fint=1.-log(zdiv)
4185 ELSE
4186 zdivc=zdiv**(1.-fc)
4187 fint=1.+(1.-1./zdivc)/(fc-1.)
4188 ENDIF
4189 ELSEIF(zmax.GT.0.85.AND.fb.GT.1.) THEN
4190 mmax=3
4191 fscb=sqrt(4.+(fc/fb)**2)
4192 zdiv=fscb-1./zmax-(fc/fb)*log(zmax*0.5*(fscb+fc/fb))
4193 IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1.-zmax)
4194 zdiv=min(zmax,max(0.,zdiv))
4195 fint=1.+fb*(1.-zdiv)
4196 ENDIF
4197
4198C...Choice of z, preweighted for peaks at low or high z.
4199 100 z=rlu(0)
4200 fpre=1.
4201 IF(mmax.EQ.1) THEN
4202 IF(fint*rlu(0).LE.1.) THEN
4203 z=zdiv*z
4204 ELSEIF(mc.EQ.1) THEN
4205 z=zdiv**z
4206 fpre=zdiv/z
4207 ELSE
4208 z=1./(zdivc+z*(1.-zdivc))**(1./(1.-fc))
4209 fpre=(zdiv/z)**fc
4210 ENDIF
4211 ELSEIF(mmax.EQ.3) THEN
4212 IF(fint*rlu(0).LE.1.) THEN
4213 z=zdiv+log(z)/fb
4214 fpre=exp(fb*(z-zdiv))
4215 ELSE
4216 z=zdiv+z*(1.-zdiv)
4217 ENDIF
4218 ENDIF
4219
4220C...Weighting according to correct formula.
4221 IF(z.LE.0..OR.z.GE.1.) GOTO 100
4222 fexp=fc*log(zmax/z)+fb*(1./zmax-1./z)
4223 IF(ma.GE.2) fexp=fexp+fa*log((1.-z)/(1.-zmax))
4224 fval=exp(max(-50.,min(50.,fexp)))
4225 IF(fval.LT.rlu(0)*fpre) GOTO 100
4226
4227C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
4228 ELSE
4229 fc=parj(50+max(1,kflh))
4230 IF(mstj(91).EQ.1) fc=parj(59)
4231 110 z=rlu(0)
4232 IF(fc.GE.0..AND.fc.LE.1.) THEN
4233 IF(fc.GT.rlu(0)) z=1.-z**(1./3.)
4234 ELSEIF(fc.GT.-1.AND.fc.LT.0.) THEN
4235 IF(-4.*fc*z*(1.-z)**2.LT.rlu(0)*((1.-z)**2-fc*z)**2) GOTO 110
4236 ELSE
4237 IF(fc.GT.0.) z=1.-z**(1./fc)
4238 IF(fc.LT.0.) z=z**(-1./fc)
4239 ENDIF
4240 ENDIF
4241
4242 RETURN
4243 END
4244
4245C*********************************************************************
4246
4247 SUBROUTINE lushow(IP1,IP2,QMAX)
4248
4249C...Purpose: to generate timelike parton showers from given partons.
4250 IMPLICIT DOUBLE PRECISION(d)
4251 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
4252 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4253 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4254 SAVE /lujets/,/ludat1/,/ludat2/
4255 dimension pmth(5,40),ps(5),pma(4),pmsd(4),iep(4),ipa(4),
4256 &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4),
4257 &ksh(0:40),kcii(2),niis(2),iiis(2,2),theiis(2,2),phiiis(2,2),
4258 &isii(2)
4259
4260C...Initialization of cutoff masses etc.
4261 IF(mstj(41).LE.0.OR.(mstj(41).EQ.1.AND.qmax.LE.parj(82)).OR.
4262 &qmax.LE.min(parj(82),parj(83))) RETURN
4263 DO 100 if=0,40
4264 ksh(if)=0
4265 100 CONTINUE
4266 ksh(21)=1
4267 pmth(1,21)=ulmass(21)
4268 pmth(2,21)=sqrt(pmth(1,21)**2+0.25*parj(82)**2)
4269 pmth(3,21)=2.*pmth(2,21)
4270 pmth(4,21)=pmth(3,21)
4271 pmth(5,21)=pmth(3,21)
4272 pmth(1,22)=ulmass(22)
4273 pmth(2,22)=sqrt(pmth(1,22)**2+0.25*parj(83)**2)
4274 pmth(3,22)=2.*pmth(2,22)
4275 pmth(4,22)=pmth(3,22)
4276 pmth(5,22)=pmth(3,22)
4277 pmqth1=parj(82)
4278 IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))
4279 pmqth2=pmth(2,21)
4280 IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))
4281 DO 110 if=1,8
4282 ksh(if)=1
4283 pmth(1,if)=ulmass(if)
4284 pmth(2,if)=sqrt(pmth(1,if)**2+0.25*pmqth1**2)
4285 pmth(3,if)=pmth(2,if)+pmqth2
4286 pmth(4,if)=sqrt(pmth(1,if)**2+0.25*parj(82)**2)+pmth(2,21)
4287 pmth(5,if)=sqrt(pmth(1,if)**2+0.25*parj(83)**2)+pmth(2,22)
4288 110 CONTINUE
4289 DO 120 if=11,17,2
4290 IF(mstj(41).GE.2) ksh(if)=1
4291 pmth(1,if)=ulmass(if)
4292 pmth(2,if)=sqrt(pmth(1,if)**2+0.25*parj(83)**2)
4293 pmth(3,if)=pmth(2,if)+pmth(2,22)
4294 pmth(4,if)=pmth(3,if)
4295 pmth(5,if)=pmth(3,if)
4296 120 CONTINUE
4297 pt2min=max(0.5*parj(82),1.1*parj(81))**2
4298 alams=parj(81)**2
4299 alfm=log(pt2min/alams)
4300
4301C...Store positions of shower initiating partons.
4302 IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
4303 npa=1
4304 ipa(1)=ip1
4305 ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
4306 &mstu(32))) THEN
4307 npa=2
4308 ipa(1)=ip1
4309 ipa(2)=ip2
4310 ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0.
4311 &and.ip2.GE.-3) THEN
4312 npa=iabs(ip2)
4313 DO 130 i=1,npa
4314 ipa(i)=ip1+i-1
4315 130 CONTINUE
4316 ELSE
4317 CALL luerrm(12,
4318 & '(LUSHOW:) failed to reconstruct showering system')
4319 IF(mstu(21).GE.1) RETURN
4320 ENDIF
4321
4322C...Check on phase space available for emission.
4323 irej=0
4324 DO 140 j=1,5
4325 ps(j)=0.
4326 140 CONTINUE
4327 pm=0.
4328 DO 160 i=1,npa
4329 kfla(i)=iabs(k(ipa(i),2))
4330 pma(i)=p(ipa(i),5)
4331 IF(kfla(i).LE.40) THEN
4332 IF(ksh(kfla(i)).EQ.1) pma(i)=pmth(3,kfla(i))
4333 ENDIF
4334 pm=pm+pma(i)
4335 IF(kfla(i).GT.40) THEN
4336 irej=irej+1
4337 ELSE
4338 IF(ksh(kfla(i)).EQ.0.OR.pma(i).GT.qmax) irej=irej+1
4339 ENDIF
4340 DO 150 j=1,4
4341 ps(j)=ps(j)+p(ipa(i),j)
4342 150 CONTINUE
4343 160 CONTINUE
4344 IF(irej.EQ.npa) RETURN
4345 ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
4346 IF(npa.EQ.1) ps(5)=ps(4)
4347 IF(ps(5).LE.pm+pmqth1) RETURN
4348
4349C...Check if 3-jet matrix elements to be used.
4350 m3jc=0
4351 IF(npa.EQ.2.AND.mstj(47).GE.1) THEN
4352 IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.
4353 & kfla(2).LE.8) m3jc=1
4354 IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
4355 & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)) m3jc=1
4356 IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
4357 & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)+1) m3jc=1
4358 IF((kfla(1).EQ.12.OR.kfla(1).EQ.14.OR.kfla(1).EQ.16.OR.
4359 & kfla(1).EQ.18).AND.kfla(2).EQ.kfla(1)-1) m3jc=1
4360 IF(mstj(47).EQ.2.OR.mstj(47).EQ.4) m3jc=1
4361 m3jcm=0
4362 IF(m3jc.EQ.1.AND.mstj(47).GE.3.AND.kfla(1).EQ.kfla(2)) THEN
4363 m3jcm=1
4364 qme=(2.*pmth(kfla(1),1)/ps(5))**2
4365 ENDIF
4366 ENDIF
4367
4368C...Find if interference with initial state partons.
4369 miis=0
4370 IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2) miis=mstj(50)
4371 IF(miis.NE.0) THEN
4372 DO 180 i=1,2
4373 kcii(i)=0
4374 kca=lucomp(kfla(i))
4375 IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))
4376 niis(i)=0
4377 IF(kcii(i).NE.0) THEN
4378 DO 170 j=1,2
4379 icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))
4380 IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.
4381 & (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN
4382 niis(i)=niis(i)+1
4383 iiis(i,niis(i))=icsi
4384 ENDIF
4385 170 CONTINUE
4386 ENDIF
4387 180 CONTINUE
4388 IF(niis(1)+niis(2).EQ.0) miis=0
4389 ENDIF
4390
4391C...Boost interfering initial partons to rest frame
4392C...and reconstruct their polar and azimuthal angles.
4393 IF(miis.NE.0) THEN
4394 DO 200 i=1,2
4395 DO 190 j=1,5
4396 k(n+i,j)=k(ipa(i),j)
4397 p(n+i,j)=p(ipa(i),j)
4398 v(n+i,j)=0.
4399 190 CONTINUE
4400 200 CONTINUE
4401 DO 220 i=3,2+niis(1)
4402 DO 210 j=1,5
4403 k(n+i,j)=k(iiis(1,i-2),j)
4404 p(n+i,j)=p(iiis(1,i-2),j)
4405 v(n+i,j)=0.
4406 210 CONTINUE
4407 220 CONTINUE
4408 DO 240 i=3+niis(1),2+niis(1)+niis(2)
4409 DO 230 j=1,5
4410 k(n+i,j)=k(iiis(2,i-2-niis(1)),j)
4411 p(n+i,j)=p(iiis(2,i-2-niis(1)),j)
4412 v(n+i,j)=0.
4413 230 CONTINUE
4414 240 CONTINUE
4415 CALL ludbrb(n+1,n+2+niis(1)+niis(2),0.,0.,-dble(ps(1)/ps(4)),
4416 & -dble(ps(2)/ps(4)),-dble(ps(3)/ps(4)))
4417 phi=ulangl(p(n+1,1),p(n+1,2))
4418 CALL ludbrb(n+1,n+2+niis(1)+niis(2),0.,-phi,0d0,0d0,0d0)
4419 the=ulangl(p(n+1,3),p(n+1,1))
4420 CALL ludbrb(n+1,n+2+niis(1)+niis(2),-the,0.,0d0,0d0,0d0)
4421 DO 250 i=3,2+niis(1)
4422 theiis(1,i-2)=ulangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))
4423 phiiis(1,i-2)=ulangl(p(n+i,1),p(n+i,2))
4424 250 CONTINUE
4425 DO 260 i=3+niis(1),2+niis(1)+niis(2)
4426 theiis(2,i-2-niis(1))=paru(1)-ulangl(p(n+i,3),
4427 & sqrt(p(n+i,1)**2+p(n+i,2)**2))
4428 phiiis(2,i-2-niis(1))=ulangl(p(n+i,1),p(n+i,2))
4429 260 CONTINUE
4430 ENDIF
4431
4432C...Define imagined single initiator of shower for parton system.
4433 ns=n
4434 IF(n.GT.mstu(4)-mstu(32)-5) THEN
4435 CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
4436 IF(mstu(21).GE.1) RETURN
4437 ENDIF
4438 IF(npa.GE.2) THEN
4439 k(n+1,1)=11
4440 k(n+1,2)=21
4441 k(n+1,3)=0
4442 k(n+1,4)=0
4443 k(n+1,5)=0
4444 p(n+1,1)=0.
4445 p(n+1,2)=0.
4446 p(n+1,3)=0.
4447 p(n+1,4)=ps(5)
4448 p(n+1,5)=ps(5)
4449 v(n+1,5)=ps(5)**2
4450 n=n+1
4451 ENDIF
4452
4453C...Loop over partons that may branch.
4454 nep=npa
4455 im=ns
4456 IF(npa.EQ.1) im=ns-1
4457 270 im=im+1
4458 IF(n.GT.ns) THEN
4459 IF(im.GT.n) GOTO 510
4460 kflm=iabs(k(im,2))
4461 IF(kflm.GT.40) GOTO 270
4462 IF(ksh(kflm).EQ.0) GOTO 270
4463 IF(p(im,5).LT.pmth(2,kflm)) GOTO 270
4464 igm=k(im,3)
4465 ELSE
4466 igm=-1
4467 ENDIF
4468 IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN
4469 CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
4470 IF(mstu(21).GE.1) RETURN
4471 ENDIF
4472
4473C...Position of aunt (sister to branching parton).
4474C...Origin and flavour of daughters.
4475 iau=0
4476 IF(igm.GT.0) THEN
4477 IF(k(im-1,3).EQ.igm) iau=im-1
4478 IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
4479 ENDIF
4480 IF(igm.GE.0) THEN
4481 k(im,4)=n+1
4482 DO 280 i=1,nep
4483 k(n+i,3)=im
4484 280 CONTINUE
4485 ELSE
4486 k(n+1,3)=ipa(1)
4487 ENDIF
4488 IF(igm.LE.0) THEN
4489 DO 290 i=1,nep
4490 k(n+i,2)=k(ipa(i),2)
4491 290 CONTINUE
4492 ELSEIF(kflm.NE.21) THEN
4493 k(n+1,2)=k(im,2)
4494 k(n+2,2)=k(im,5)
4495 ELSEIF(k(im,5).EQ.21) THEN
4496 k(n+1,2)=21
4497 k(n+2,2)=21
4498 ELSE
4499 k(n+1,2)=k(im,5)
4500 k(n+2,2)=-k(im,5)
4501 ENDIF
4502
4503C...Reset flags on daughers and tries made.
4504 DO 300 ip=1,nep
4505 k(n+ip,1)=3
4506 k(n+ip,4)=0
4507 k(n+ip,5)=0
4508 kfld(ip)=iabs(k(n+ip,2))
4509 IF(kchg(lucomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1
4510 itry(ip)=0
4511 isl(ip)=0
4512 isi(ip)=0
4513 IF(kfld(ip).LE.40) THEN
4514 IF(ksh(kfld(ip)).EQ.1) isi(ip)=1
4515 ENDIF
4516 300 CONTINUE
4517 islm=0
4518
4519C...Maximum virtuality of daughters.
4520 IF(igm.LE.0) THEN
4521 DO 310 i=1,npa
4522 IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)-
4523 & ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)
4524 p(n+i,5)=min(qmax,ps(5))
4525 IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))
4526 IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
4527 310 CONTINUE
4528 ELSE
4529 IF(mstj(43).LE.2) pem=v(im,2)
4530 IF(mstj(43).GE.3) pem=p(im,4)
4531 p(n+1,5)=min(p(im,5),v(im,1)*pem)
4532 p(n+2,5)=min(p(im,5),(1.-v(im,1))*pem)
4533 IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
4534 ENDIF
4535 DO 320 i=1,nep
4536 pmsd(i)=p(n+i,5)
4537 IF(isi(i).EQ.1) THEN
4538 IF(p(n+i,5).LE.pmth(3,kfld(i))) p(n+i,5)=pmth(1,kfld(i))
4539 ENDIF
4540 v(n+i,5)=p(n+i,5)**2
4541 320 CONTINUE
4542
4543C...Choose one of the daughters for evolution.
4544 330 inum=0
4545 IF(nep.EQ.1) inum=1
4546 DO 340 i=1,nep
4547 IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
4548 340 CONTINUE
4549 DO 350 i=1,nep
4550 IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
4551 IF(p(n+i,5).GE.pmth(2,kfld(i))) inum=i
4552 ENDIF
4553 350 CONTINUE
4554 IF(inum.EQ.0) THEN
4555 rmax=0.
4556 DO 360 i=1,nep
4557 IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqth2) THEN
4558 rpm=p(n+i,5)/pmsd(i)
4559 IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,kfld(i))) THEN
4560 rmax=rpm
4561 inum=i
4562 ENDIF
4563 ENDIF
4564 360 CONTINUE
4565 ENDIF
4566
4567C...Store information on choice of evolving daughter.
4568 inum=max(1,inum)
4569 iep(1)=n+inum
4570 DO 370 i=2,nep
4571 iep(i)=iep(i-1)+1
4572 IF(iep(i).GT.n+nep) iep(i)=n+1
4573 370 CONTINUE
4574 DO 380 i=1,nep
4575 kfl(i)=iabs(k(iep(i),2))
4576 380 CONTINUE
4577 itry(inum)=itry(inum)+1
4578 IF(itry(inum).GT.200) THEN
4579 CALL luerrm(14,'(LUSHOW:) caught in infinite loop')
4580 IF(mstu(21).GE.1) RETURN
4581 ENDIF
4582 z=0.5
4583 IF(kfl(1).GT.40) GOTO 430
4584 IF(ksh(kfl(1)).EQ.0) GOTO 430
4585 IF(p(iep(1),5).LT.pmth(2,kfl(1))) GOTO 430
4586
4587C...Select side for interference with initial state partons.
4588 IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN
4589 iii=iep(1)-ns-1
4590 isii(iii)=0
4591 IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN
4592 isii(iii)=1
4593 ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN
4594 IF(rlu(0).GT.0.5) isii(iii)=1
4595 ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN
4596 isii(iii)=1
4597 IF(rlu(0).GT.0.5) isii(iii)=2
4598 ENDIF
4599 ENDIF
4600
4601C...Calculate allowed z range.
4602 IF(nep.EQ.1) THEN
4603 pmed=ps(4)
4604 ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
4605 pmed=p(im,5)
4606 ELSE
4607 IF(inum.EQ.1) pmed=v(im,1)*pem
4608 IF(inum.EQ.2) pmed=(1.-v(im,1))*pem
4609 ENDIF
4610 IF(mod(mstj(43),2).EQ.1) THEN
4611 zc=pmth(2,21)/pmed
4612 zce=pmth(2,22)/pmed
4613 ELSE
4614 zc=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,21)/pmed)**2)))
4615 IF(zc.LT.1e-4) zc=(pmth(2,21)/pmed)**2
4616 zce=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,22)/pmed)**2)))
4617 IF(zce.LT.1e-4) zce=(pmth(2,22)/pmed)**2
4618 ENDIF
4619 zc=min(zc,0.491)
4620 zce=min(zce,0.491)
4621 IF((mstj(41).EQ.1.AND.zc.GT.0.49).OR.(mstj(41).GE.2.AND.
4622 &min(zc,zce).GT.0.49)) THEN
4623 p(iep(1),5)=pmth(1,kfl(1))
4624 v(iep(1),5)=p(iep(1),5)**2
4625 GOTO 430
4626 ENDIF
4627
4628C...Integral of Altarelli-Parisi z kernel for QCD.
4629 IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
4630 fbr=6.*log((1.-zc)/zc)+mstj(45)*(0.5-zc)
4631 ELSEIF(mstj(49).EQ.0) THEN
4632 fbr=(8./3.)*log((1.-zc)/zc)
4633
4634C...Integral of Altarelli-Parisi z kernel for scalar gluon.
4635 ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
4636 fbr=(parj(87)+mstj(45)*parj(88))*(1.-2.*zc)
4637 ELSEIF(mstj(49).EQ.1) THEN
4638 fbr=(1.-2.*zc)/3.
4639 IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4.*fbr
4640
4641C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
4642 ELSEIF(kfl(1).EQ.21) THEN
4643 fbr=6.*mstj(45)*(0.5-zc)
4644 ELSE
4645 fbr=2.*log((1.-zc)/zc)
4646 ENDIF
4647
4648C...Reset QCD probability for lepton.
4649 IF(kfl(1).GE.11.AND.kfl(1).LE.18) fbr=0.
4650
4651C...Integral of Altarelli-Parisi kernel for photon emission.
4652 IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
4653 fbre=(kchg(kfl(1),1)/3.)**2*2.*log((1.-zce)/zce)
4654 IF(mstj(41).EQ.10) fbre=parj(84)*fbre
4655 ENDIF
4656
4657C...Inner veto algorithm starts. Find maximum mass for evolution.
4658 390 pms=v(iep(1),5)
4659 IF(igm.GE.0) THEN
4660 pm2=0.
4661 DO 400 i=2,nep
4662 pm=p(iep(i),5)
4663 IF(kfl(i).LE.40) THEN
4664 IF(ksh(kfl(i)).EQ.1) pm=pmth(2,kfl(i))
4665 ENDIF
4666 pm2=pm2+pm
4667 400 CONTINUE
4668 pms=min(pms,(p(im,5)-pm2)**2)
4669 ENDIF
4670
4671C...Select mass for daughter in QCD evolution.
4672 b0=27./6.
4673 DO 410 if=4,mstj(45)
4674 IF(pms.GT.4.*pmth(2,if)**2) b0=(33.-2.*if)/6.
4675 410 CONTINUE
4676 IF(fbr.LT.1e-3) THEN
4677 pmsqcd=0.
4678 ELSEIF(mstj(44).LE.0) THEN
4679 pmsqcd=pms*exp(max(-50.,log(rlu(0))*paru(2)/(paru(111)*fbr)))
4680 ELSEIF(mstj(44).EQ.1) THEN
4681 pmsqcd=4.*alams*(0.25*pms/alams)**(rlu(0)**(b0/fbr))
4682 ELSE
4683 pmsqcd=pms*exp(max(-50.,alfm*b0*log(rlu(0))/fbr))
4684 ENDIF
4685 IF(zc.GT.0.49.OR.pmsqcd.LE.pmth(4,kfl(1))**2) pmsqcd=
4686 &pmth(2,kfl(1))**2
4687 v(iep(1),5)=pmsqcd
4688 mce=1
4689
4690C...Select mass for daughter in QED evolution.
4691 IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
4692 pmsqed=pms*exp(max(-50.,log(rlu(0))*paru(2)/(paru(101)*fbre)))
4693 IF(zce.GT.0.49.OR.pmsqed.LE.pmth(5,kfl(1))**2) pmsqed=
4694 & pmth(2,kfl(1))**2
4695 IF(pmsqed.GT.pmsqcd) THEN
4696 v(iep(1),5)=pmsqed
4697 mce=2
4698 ENDIF
4699 ENDIF
4700
4701C...Check whether daughter mass below cutoff.
4702 p(iep(1),5)=sqrt(v(iep(1),5))
4703 IF(p(iep(1),5).LE.pmth(3,kfl(1))) THEN
4704 p(iep(1),5)=pmth(1,kfl(1))
4705 v(iep(1),5)=p(iep(1),5)**2
4706 GOTO 430
4707 ENDIF
4708
4709C...Select z value of branching: q -> qgamma.
4710 IF(mce.EQ.2) THEN
4711 z=1.-(1.-zce)*(zce/(1.-zce))**rlu(0)
4712 IF(1.+z**2.LT.2.*rlu(0)) GOTO 390
4713 k(iep(1),5)=22
4714
4715C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
4716 ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
4717 z=1.-(1.-zc)*(zc/(1.-zc))**rlu(0)
4718 IF(1.+z**2.LT.2.*rlu(0)) GOTO 390
4719 k(iep(1),5)=21
4720 ELSEIF(mstj(49).EQ.0.AND.mstj(45)*(0.5-zc).LT.rlu(0)*fbr) THEN
4721 z=(1.-zc)*(zc/(1.-zc))**rlu(0)
4722 IF(rlu(0).GT.0.5) z=1.-z
4723 IF((1.-z*(1.-z))**2.LT.rlu(0)) GOTO 390
4724 k(iep(1),5)=21
4725 ELSEIF(mstj(49).NE.1) THEN
4726 z=zc+(1.-2.*zc)*rlu(0)
4727 IF(z**2+(1.-z)**2.LT.rlu(0)) GOTO 390
4728 kflb=1+int(mstj(45)*rlu(0))
4729 pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
4730 IF(pmq.GE.1.) GOTO 390
4731 pmq0=4.*pmth(2,21)**2/v(iep(1),5)
4732 IF(mod(mstj(43),2).EQ.0.AND.(1.+0.5*pmq)*sqrt(1.-pmq).LT.
4733 & rlu(0)*(1.+0.5*pmq0)*sqrt(1.-pmq0)) GOTO 390
4734 k(iep(1),5)=kflb
4735
4736C...Ditto for scalar gluon model.
4737 ELSEIF(kfl(1).NE.21) THEN
4738 z=1.-sqrt(zc**2+rlu(0)*(1.-2.*zc))
4739 k(iep(1),5)=21
4740 ELSEIF(rlu(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
4741 z=zc+(1.-2.*zc)*rlu(0)
4742 k(iep(1),5)=21
4743 ELSE
4744 z=zc+(1.-2.*zc)*rlu(0)
4745 kflb=1+int(mstj(45)*rlu(0))
4746 pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
4747 IF(pmq.GE.1.) GOTO 390
4748 k(iep(1),5)=kflb
4749 ENDIF
4750 IF(mce.EQ.1.AND.mstj(44).GE.2) THEN
4751 IF(z*(1.-z)*v(iep(1),5).LT.pt2min) GOTO 390
4752 IF(alfm/log(v(iep(1),5)*z*(1.-z)/alams).LT.rlu(0)) GOTO 390
4753 ENDIF
4754
4755C...Check if z consistent with chosen m.
4756 IF(kfl(1).EQ.21) THEN
4757 kflgd1=iabs(k(iep(1),5))
4758 kflgd2=kflgd1
4759 ELSE
4760 kflgd1=kfl(1)
4761 kflgd2=iabs(k(iep(1),5))
4762 ENDIF
4763 IF(nep.EQ.1) THEN
4764 ped=ps(4)
4765 ELSEIF(nep.GE.3) THEN
4766 ped=p(iep(1),4)
4767 ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
4768 ped=0.5*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
4769 ELSE
4770 IF(iep(1).EQ.n+1) ped=v(im,1)*pem
4771 IF(iep(1).EQ.n+2) ped=(1.-v(im,1))*pem
4772 ENDIF
4773 IF(mod(mstj(43),2).EQ.1) THEN
4774 pmqth3=0.5*parj(82)
4775 IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
4776 pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(iep(1),5)
4777 pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)
4778 zd=sqrt(max(0.,(1.-v(iep(1),5)/ped**2)*((1.-pmq1-pmq2)**2-
4779 & 4.*pmq1*pmq2)))
4780 zh=1.+pmq1-pmq2
4781 ELSE
4782 zd=sqrt(max(0.,1.-v(iep(1),5)/ped**2))
4783 zh=1.
4784 ENDIF
4785 zl=0.5*(zh-zd)
4786 zu=0.5*(zh+zd)
4787 IF(z.LT.zl.OR.z.GT.zu) GOTO 390
4788 IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1.-zl)/max(1e-20,zl*
4789 &(1.-zu)))
4790 IF(kfl(1).NE.21) v(iep(1),3)=log((1.-zl)/max(1e-10,1.-zu))
4791
4792C...Three-jet matrix element correction.
4793 IF(igm.EQ.0.AND.m3jc.EQ.1) THEN
4794 x1=z*(1.+v(iep(1),5)/v(ns+1,5))
4795 x2=1.-v(iep(1),5)/v(ns+1,5)
4796 x3=(1.-x1)+(1.-x2)
4797 IF(mce.EQ.2) THEN
4798 ki1=k(ipa(inum),2)
4799 ki2=k(ipa(3-inum),2)
4800 qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3.
4801 qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3.
4802 wshow=qf1**2*(1.-x1)/x3*(1.+(x1/(2.-x2))**2)+
4803 & qf2**2*(1.-x2)/x3*(1.+(x2/(2.-x1))**2)
4804 wme=(qf1*(1.-x1)/x3-qf2*(1.-x2)/x3)**2*(x1**2+x2**2)
4805 ELSEIF(mstj(49).NE.1) THEN
4806 wshow=1.+(1.-x1)/x3*(x1/(2.-x2))**2+
4807 & (1.-x2)/x3*(x2/(2.-x1))**2
4808 wme=x1**2+x2**2
4809 IF(m3jcm.EQ.1) wme=wme-qme*x3-0.5*qme**2-
4810 & (0.5*qme+0.25*qme**2)*((1.-x2)/(1.-x1)+(1.-x1)/(1.-x2))
4811 ELSE
4812 wshow=4.*x3*((1.-x1)/(2.-x2)**2+(1.-x2)/(2.-x1)**2)
4813 wme=x3**2
4814 IF(mstj(102).GE.2) wme=x3**2-2.*(1.+x3)*(1.-x1)*(1.-x2)*
4815 & parj(171)
4816 ENDIF
4817 IF(wme.LT.rlu(0)*wshow) GOTO 390
4818
4819C...Impose angular ordering by rejection of nonordered emission.
4820 ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2) THEN
4821 maom=1
4822 zm=v(im,1)
4823 IF(iep(1).EQ.n+2) zm=1.-v(im,1)
4824 the2id=z*(1.-z)*(zm*p(im,4))**2/v(iep(1),5)
4825 iaom=im
4826 420 IF(k(iaom,5).EQ.22) THEN
4827 iaom=k(iaom,3)
4828 IF(k(iaom,3).LE.ns) maom=0
4829 IF(maom.EQ.1) GOTO 420
4830 ENDIF
4831 IF(maom.EQ.1) THEN
4832 the2im=v(iaom,1)*(1.-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
4833 IF(the2id.LT.the2im) GOTO 390
4834 ENDIF
4835 ENDIF
4836
4837C...Impose user-defined maximum angle at first branching.
4838 IF(mstj(48).EQ.1) THEN
4839 IF(nep.EQ.1.AND.im.EQ.ns) THEN
4840 the2id=z*(1.-z)*ps(4)**2/v(iep(1),5)
4841 IF(the2id.LT.1./parj(85)**2) GOTO 390
4842 ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
4843 the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
4844 IF(the2id.LT.1./parj(85)**2) GOTO 390
4845 ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
4846 the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
4847 IF(the2id.LT.1./parj(86)**2) GOTO 390
4848 ENDIF
4849 ENDIF
4850
4851C...Impose angular constraint in first branching from interference
4852C...with initial state partons.
4853 IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN
4854 the2d=max((1.-z)/z,z/(1.-z))*v(iep(1),5)/(0.5*p(im,4))**2
4855 IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN
4856 IF(the2d.GT.theiis(1,isii(1))**2) GOTO 390
4857 ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN
4858 IF(the2d.GT.theiis(2,isii(2))**2) GOTO 390
4859 ENDIF
4860 ENDIF
4861
4862C...End of inner veto algorithm. Check if only one leg evolved so far.
4863 430 v(iep(1),1)=z
4864 isl(1)=0
4865 isl(2)=0
4866 IF(nep.EQ.1) GOTO 460
4867 IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) GOTO 330
4868 DO 440 i=1,nep
4869 IF(itry(i).EQ.0.AND.kfld(i).LE.40) THEN
4870 IF(ksh(kfld(i)).EQ.1) THEN
4871 IF(p(n+i,5).GE.pmth(2,kfld(i))) GOTO 330
4872 ENDIF
4873 ENDIF
4874 440 CONTINUE
4875
4876C...Check if chosen multiplet m1,m2,z1,z2 is physical.
4877 IF(nep.EQ.3) THEN
4878 pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))
4879 pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))
4880 pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))
4881 pts=0.25*(2.*pa1s*pa2s+2.*pa1s*pa3s+2.*pa2s*pa3s-
4882 & pa1s**2-pa2s**2-pa3s**2)/pa1s
4883 IF(pts.LE.0.) GOTO 330
4884 ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
4885 DO 450 i1=n+1,n+2
4886 kflda=iabs(k(i1,2))
4887 IF(kflda.GT.40) GOTO 450
4888 IF(ksh(kflda).EQ.0) GOTO 450
4889 IF(p(i1,5).LT.pmth(2,kflda)) GOTO 450
4890 IF(kflda.EQ.21) THEN
4891 kflgd1=iabs(k(i1,5))
4892 kflgd2=kflgd1
4893 ELSE
4894 kflgd1=kflda
4895 kflgd2=iabs(k(i1,5))
4896 ENDIF
4897 i2=2*n+3-i1
4898 IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
4899 ped=0.5*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
4900 ELSE
4901 IF(i1.EQ.n+1) zm=v(im,1)
4902 IF(i1.EQ.n+2) zm=1.-v(im,1)
4903 pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
4904 & 4.*v(n+1,5)*v(n+2,5))
4905 ped=pem*(0.5*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/v(im,5)
4906 ENDIF
4907 IF(mod(mstj(43),2).EQ.1) THEN
4908 pmqth3=0.5*parj(82)
4909 IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
4910 pmq1=(pmth(1,kflgd1)**2+pmqth3**2)/v(i1,5)
4911 pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)
4912 zd=sqrt(max(0.,(1.-v(i1,5)/ped**2)*((1.-pmq1-pmq2)**2-
4913 & 4.*pmq1*pmq2)))
4914 zh=1.+pmq1-pmq2
4915 ELSE
4916 zd=sqrt(max(0.,1.-v(i1,5)/ped**2))
4917 zh=1.
4918 ENDIF
4919 zl=0.5*(zh-zd)
4920 zu=0.5*(zh+zd)
4921 IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(1)=1
4922 IF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(2)=1
4923 IF(kflda.EQ.21) v(i1,4)=log(zu*(1.-zl)/max(1e-20,zl*(1.-zu)))
4924 IF(kflda.NE.21) v(i1,4)=log((1.-zl)/max(1e-10,1.-zu))
4925 450 CONTINUE
4926 IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
4927 isl(3-islm)=0
4928 islm=3-islm
4929 ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
4930 zdr1=max(0.,v(n+1,3)/max(1e-6,v(n+1,4))-1.)
4931 zdr2=max(0.,v(n+2,3)/max(1e-6,v(n+2,4))-1.)
4932 IF(zdr2.GT.rlu(0)*(zdr1+zdr2)) isl(1)=0
4933 IF(isl(1).EQ.1) isl(2)=0
4934 IF(isl(1).EQ.0) islm=1
4935 IF(isl(2).EQ.0) islm=2
4936 ENDIF
4937 IF(isl(1).EQ.1.OR.isl(2).EQ.1) GOTO 330
4938 ENDIF
4939 IF(igm.GT.0.AND.mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
4940 &pmth(2,kfld(1)).OR.p(n+2,5).GE.pmth(2,kfld(2)))) THEN
4941 pmq1=v(n+1,5)/v(im,5)
4942 pmq2=v(n+2,5)/v(im,5)
4943 zd=sqrt(max(0.,(1.-v(im,5)/pem**2)*((1.-pmq1-pmq2)**2-
4944 & 4.*pmq1*pmq2)))
4945 zh=1.+pmq1-pmq2
4946 zl=0.5*(zh-zd)
4947 zu=0.5*(zh+zd)
4948 IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) GOTO 330
4949 ENDIF
4950
4951C...Accepted branch. Construct four-momentum for initial partons.
4952 460 mazip=0
4953 mazic=0
4954 IF(nep.EQ.1) THEN
4955 p(n+1,1)=0.
4956 p(n+1,2)=0.
4957 p(n+1,3)=sqrt(max(0.,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
4958 & p(n+1,5))))
4959 p(n+1,4)=p(ipa(1),4)
4960 v(n+1,2)=p(n+1,4)
4961 ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
4962 ped1=0.5*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
4963 p(n+1,1)=0.
4964 p(n+1,2)=0.
4965 p(n+1,3)=sqrt(max(0.,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
4966 p(n+1,4)=ped1
4967 p(n+2,1)=0.
4968 p(n+2,2)=0.
4969 p(n+2,3)=-p(n+1,3)
4970 p(n+2,4)=p(im,5)-ped1
4971 v(n+1,2)=p(n+1,4)
4972 v(n+2,2)=p(n+2,4)
4973 ELSEIF(nep.EQ.3) THEN
4974 p(n+1,1)=0.
4975 p(n+1,2)=0.
4976 p(n+1,3)=sqrt(max(0.,pa1s))
4977 p(n+2,1)=sqrt(pts)
4978 p(n+2,2)=0.
4979 p(n+2,3)=0.5*(pa3s-pa2s-pa1s)/p(n+1,3)
4980 p(n+3,1)=-p(n+2,1)
4981 p(n+3,2)=0.
4982 p(n+3,3)=-(p(n+1,3)+p(n+2,3))
4983 v(n+1,2)=p(n+1,4)
4984 v(n+2,2)=p(n+2,4)
4985 v(n+3,2)=p(n+3,4)
4986
4987C...Construct transverse momentum for ordinary branching in shower.
4988 ELSE
4989 zm=v(im,1)
4990 pzm=sqrt(max(0.,(pem+p(im,5))*(pem-p(im,5))))
4991 pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4.*v(n+1,5)*v(n+2,5)
4992 IF(pzm.LE.0.) THEN
4993 pts=0.
4994 ELSEIF(mod(mstj(43),2).EQ.1) THEN
4995 pts=(pem**2*(zm*(1.-zm)*v(im,5)-(1.-zm)*v(n+1,5)-
4996 & zm*v(n+2,5))-0.25*pmls)/pzm**2
4997 ELSE
4998 pts=pmls*(zm*(1.-zm)*pem**2/v(im,5)-0.25)/pzm**2
4999 ENDIF
5000 pt=sqrt(max(0.,pts))
5001
5002C...Find coefficient of azimuthal asymmetry due to gluon polarization.
5003 hazip=0.
5004 IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21.
5005 & and.iau.NE.0) THEN
5006 IF(k(igm,3).NE.0) mazip=1
5007 zau=v(igm,1)
5008 IF(iau.EQ.im+1) zau=1.-v(igm,1)
5009 IF(mazip.EQ.0) zau=0.
5010 IF(k(igm,2).NE.21) THEN
5011 hazip=2.*zau/(1.+zau**2)
5012 ELSE
5013 hazip=(zau/(1.-zau*(1.-zau)))**2
5014 ENDIF
5015 IF(k(n+1,2).NE.21) THEN
5016 hazip=hazip*(-2.*zm*(1.-zm))/(1.-2.*zm*(1.-zm))
5017 ELSE
5018 hazip=hazip*(zm*(1.-zm)/(1.-zm*(1.-zm)))**2
5019 ENDIF
5020 ENDIF
5021
5022C...Find coefficient of azimuthal asymmetry due to soft gluon
5023C...interference.
5024 hazic=0.
5025 IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.
5026 & k(n+2,2).EQ.21).AND.iau.NE.0) THEN
5027 IF(k(igm,3).NE.0) mazic=n+1
5028 IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
5029 IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
5030 & zm.GT.0.5) mazic=n+2
5031 IF(k(iau,2).EQ.22) mazic=0
5032 zs=zm
5033 IF(mazic.EQ.n+2) zs=1.-zm
5034 zgm=v(igm,1)
5035 IF(iau.EQ.im-1) zgm=1.-v(igm,1)
5036 IF(mazic.EQ.0) zgm=1.
5037 hazic=(p(im,5)/p(igm,5))*sqrt((1.-zs)*(1.-zgm)/(zs*zgm))
5038 hazic=min(0.95,hazic)
5039 ENDIF
5040 ENDIF
5041
5042C...Construct kinematics for ordinary branching in shower.
5043 470 IF(nep.EQ.2.AND.igm.GT.0) THEN
5044 IF(mod(mstj(43),2).EQ.1) THEN
5045 p(n+1,4)=pem*v(im,1)
5046 ELSE
5047 p(n+1,4)=pem*(0.5*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
5048 & sqrt(pmls)*zm)/v(im,5)
5049 ENDIF
5050 phi=paru(2)*rlu(0)
5051 p(n+1,1)=pt*cos(phi)
5052 p(n+1,2)=pt*sin(phi)
5053 IF(pzm.GT.0.) THEN
5054 p(n+1,3)=0.5*(v(n+2,5)-v(n+1,5)-v(im,5)+2.*pem*p(n+1,4))/pzm
5055 ELSE
5056 p(n+1,3)=0.
5057 ENDIF
5058 p(n+2,1)=-p(n+1,1)
5059 p(n+2,2)=-p(n+1,2)
5060 p(n+2,3)=pzm-p(n+1,3)
5061 p(n+2,4)=pem-p(n+1,4)
5062 IF(mstj(43).LE.2) THEN
5063 v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
5064 v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
5065 ENDIF
5066 ENDIF
5067
5068C...Rotate and boost daughters.
5069 IF(igm.GT.0) THEN
5070 IF(mstj(43).LE.2) THEN
5071 bex=p(igm,1)/p(igm,4)
5072 bey=p(igm,2)/p(igm,4)
5073 bez=p(igm,3)/p(igm,4)
5074 ga=p(igm,4)/p(igm,5)
5075 gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1.+ga)-
5076 & p(im,4))
5077 ELSE
5078 bex=0.
5079 bey=0.
5080 bez=0.
5081 ga=1.
5082 gabep=0.
5083 ENDIF
5084 the=ulangl(p(im,3)+gabep*bez,sqrt((p(im,1)+gabep*bex)**2+
5085 & (p(im,2)+gabep*bey)**2))
5086 phi=ulangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
5087 DO 480 i=n+1,n+2
5088 dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
5089 & sin(the)*cos(phi)*p(i,3)
5090 dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
5091 & sin(the)*sin(phi)*p(i,3)
5092 dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
5093 dp(4)=p(i,4)
5094 dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
5095 dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
5096 p(i,1)=dp(1)+dgabp*bex
5097 p(i,2)=dp(2)+dgabp*bey
5098 p(i,3)=dp(3)+dgabp*bez
5099 p(i,4)=ga*(dp(4)+dbp)
5100 480 CONTINUE
5101 ENDIF
5102
5103C...Weight with azimuthal distribution, if required.
5104 IF(mazip.NE.0.OR.mazic.NE.0) THEN
5105 DO 490 j=1,3
5106 dpt(1,j)=p(im,j)
5107 dpt(2,j)=p(iau,j)
5108 dpt(3,j)=p(n+1,j)
5109 490 CONTINUE
5110 dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
5111 dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
5112 dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
5113 DO 500 j=1,3
5114 dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/dpmm
5115 dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/dpmm
5116 500 CONTINUE
5117 dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
5118 dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
5119 IF(min(dpt(4,4),dpt(5,4)).GT.0.1*parj(82)) THEN
5120 cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
5121 & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
5122 IF(mazip.NE.0) THEN
5123 IF(1.+hazip*(2.*cad**2-1.).LT.rlu(0)*(1.+abs(hazip)))
5124 & GOTO 470
5125 ENDIF
5126 IF(mazic.NE.0) THEN
5127 IF(mazic.EQ.n+2) cad=-cad
5128 IF((1.-hazic)*(1.-hazic*cad)/(1.+hazic**2-2.*hazic*cad).
5129 & lt.rlu(0)) GOTO 470
5130 ENDIF
5131 ENDIF
5132 ENDIF
5133
5134C...Azimuthal anisotropy due to interference with initial state partons.
5135 IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.
5136 &k(n+2,2).EQ.21)) THEN
5137 iii=im-ns-1
5138 IF(isii(iii).GE.1) THEN
5139 iaziid=n+1
5140 IF(k(n+1,2).NE.21) iaziid=n+2
5141 IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
5142 & p(n+1,4).GT.p(n+2,4)) iaziid=n+2
5143 theiid=ulangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))
5144 IF(iii.EQ.2) theiid=paru(1)-theiid
5145 phiiid=ulangl(p(iaziid,1),p(iaziid,2))
5146 hazii=min(0.95,theiid/theiis(iii,isii(iii)))
5147 cad=cos(phiiid-phiiis(iii,isii(iii)))
5148 phirel=abs(phiiid-phiiis(iii,isii(iii)))
5149 IF(phirel.GT.paru(1)) phirel=paru(2)-phirel
5150 IF((1.-hazii)*(1.-hazii*cad)/(1.+hazii**2-2.*hazii*cad).
5151 & lt.rlu(0)) GOTO 470
5152 ENDIF
5153 ENDIF
5154
5155C...Continue loop over partons that may branch, until none left.
5156 IF(igm.GE.0) k(im,1)=14
5157 n=n+nep
5158 nep=2
5159 IF(n.GT.mstu(4)-mstu(32)-5) THEN
5160 CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
5161 IF(mstu(21).GE.1) n=ns
5162 IF(mstu(21).GE.1) RETURN
5163 ENDIF
5164 GOTO 270
5165
5166C...Set information on imagined shower initiator.
5167 510 IF(npa.GE.2) THEN
5168 k(ns+1,1)=11
5169 k(ns+1,2)=94
5170 k(ns+1,3)=ip1
5171 IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
5172 k(ns+1,4)=ns+2
5173 k(ns+1,5)=ns+1+npa
5174 iim=1
5175 ELSE
5176 iim=0
5177 ENDIF
5178
5179C...Reconstruct string drawing information.
5180 DO 520 i=ns+1+iim,n
5181 IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
5182 k(i,1)=1
5183 ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.
5184 &iabs(k(i,2)).LE.18) THEN
5185 k(i,1)=1
5186 ELSEIF(k(i,1).LE.10) THEN
5187 k(i,4)=mstu(5)*(k(i,4)/mstu(5))
5188 k(i,5)=mstu(5)*(k(i,5)/mstu(5))
5189 ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
5190 id1=mod(k(i,4),mstu(5))
5191 IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1
5192 id2=2*mod(k(i,4),mstu(5))+1-id1
5193 k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
5194 k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
5195 k(id1,4)=k(id1,4)+mstu(5)*i
5196 k(id1,5)=k(id1,5)+mstu(5)*id2
5197 k(id2,4)=k(id2,4)+mstu(5)*id1
5198 k(id2,5)=k(id2,5)+mstu(5)*i
5199 ELSE
5200 id1=mod(k(i,4),mstu(5))
5201 id2=id1+1
5202 k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
5203 k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
5204 IF(iabs(k(i,2)).LE.10.OR.k(id1,1).GE.11) THEN
5205 k(id1,4)=k(id1,4)+mstu(5)*i
5206 k(id1,5)=k(id1,5)+mstu(5)*i
5207 ELSE
5208 k(id1,4)=0
5209 k(id1,5)=0
5210 ENDIF
5211 k(id2,4)=0
5212 k(id2,5)=0
5213 ENDIF
5214 520 CONTINUE
5215
5216C...Transformation from CM frame.
5217 IF(npa.GE.2) THEN
5218 bex=ps(1)/ps(4)
5219 bey=ps(2)/ps(4)
5220 bez=ps(3)/ps(4)
5221 ga=ps(4)/ps(5)
5222 gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
5223 & /(1.+ga)-p(ipa(1),4))
5224 ELSE
5225 bex=0.
5226 bey=0.
5227 bez=0.
5228 gabep=0.
5229 ENDIF
5230 the=ulangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
5231 &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
5232 phi=ulangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
5233 IF(npa.EQ.3) THEN
5234 chi=ulangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*
5235 & sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*
5236 & bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+
5237 & gabep*bey))
5238 mstu(33)=1
5239 CALL ludbrb(ns+1,n,0.,chi,0d0,0d0,0d0)
5240 ENDIF
5241 dbex=dble(bex)
5242 dbey=dble(bey)
5243 dbez=dble(bez)
5244 mstu(33)=1
5245 CALL ludbrb(ns+1,n,the,phi,dbex,dbey,dbez)
5246
5247C...Decay vertex of shower.
5248 DO 540 i=ns+1,n
5249 DO 530 j=1,5
5250 v(i,j)=v(ip1,j)
5251 530 CONTINUE
5252 540 CONTINUE
5253
5254C...Delete trivial shower, else connect initiators.
5255 IF(n.EQ.ns+npa+iim) THEN
5256 n=ns
5257 ELSE
5258 DO 550 ip=1,npa
5259 k(ipa(ip),1)=14
5260 k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
5261 k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
5262 k(ns+iim+ip,3)=ipa(ip)
5263 IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
5264 IF(k(ns+iim+ip,1).NE.1) THEN
5265 k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
5266 k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
5267 ENDIF
5268 550 CONTINUE
5269 ENDIF
5270
5271 RETURN
5272 END
5273
5274C*********************************************************************
5275
5276 SUBROUTINE luboei(NSAV)
5277
5278C...Purpose: to modify event so as to approximately take into account
5279C...Bose-Einstein effects according to a simple phenomenological
5280C...parametrization.
5281 IMPLICIT DOUBLE PRECISION(d)
5282 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
5283 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5284 SAVE /lujets/,/ludat1/
5285 dimension dps(4),kfbe(9),nbe(0:9),bei(100)
5286 DATA kfbe/211,-211,111,321,-321,130,310,221,331/
5287
5288C...Boost event to overall CM frame. Calculate CM energy.
5289 IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
5290 DO 100 j=1,4
5291 dps(j)=0.
5292 100 CONTINUE
5293 DO 120 i=1,n
5294 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120
5295 DO 110 j=1,4
5296 dps(j)=dps(j)+p(i,j)
5297 110 CONTINUE
5298 120 CONTINUE
5299 CALL ludbrb(0,0,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
5300 &-dps(3)/dps(4))
5301 pecm=0.
5302 DO 130 i=1,n
5303 IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
5304 130 CONTINUE
5305
5306C...Reserve copy of particles by species at end of record.
5307 nbe(0)=n+mstu(3)
5308 DO 160 ibe=1,min(9,mstj(52))
5309 nbe(ibe)=nbe(ibe-1)
5310 DO 150 i=nsav+1,n
5311 IF(k(i,2).NE.kfbe(ibe)) GOTO 150
5312 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 150
5313 IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
5314 CALL luerrm(11,'(LUBOEI:) no more memory left in LUJETS')
5315 RETURN
5316 ENDIF
5317 nbe(ibe)=nbe(ibe)+1
5318 k(nbe(ibe),1)=i
5319 DO 140 j=1,3
5320 p(nbe(ibe),j)=0.
5321 140 CONTINUE
5322 150 CONTINUE
5323 160 CONTINUE
5324
5325C...Tabulate integral for subsequent momentum shift.
5326 DO 220 ibe=1,min(9,mstj(52))
5327 IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) GOTO 180
5328 IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2)).
5329 &le.1) GOTO 180
5330 IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
5331 &nbe(7)-nbe(6)).LE.1) GOTO 180
5332 IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) GOTO 180
5333 IF(ibe.EQ.1) pmhq=2.*ulmass(211)
5334 IF(ibe.EQ.4) pmhq=2.*ulmass(321)
5335 IF(ibe.EQ.8) pmhq=2.*ulmass(221)
5336 IF(ibe.EQ.9) pmhq=2.*ulmass(331)
5337 qdel=0.1*min(pmhq,parj(93))
5338 IF(mstj(51).EQ.1) THEN
5339 nbin=min(100,nint(9.*parj(93)/qdel))
5340 beex=exp(0.5*qdel/parj(93))
5341 bert=exp(-qdel/parj(93))
5342 ELSE
5343 nbin=min(100,nint(3.*parj(93)/qdel))
5344 ENDIF
5345 DO 170 ibin=1,nbin
5346 qbin=qdel*(ibin-0.5)
5347 bei(ibin)=qdel*(qbin**2+qdel**2/12.)/sqrt(qbin**2+pmhq**2)
5348 IF(mstj(51).EQ.1) THEN
5349 beex=beex*bert
5350 bei(ibin)=bei(ibin)*beex
5351 ELSE
5352 bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
5353 ENDIF
5354 IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
5355 170 CONTINUE
5356
5357C...Loop through particle pairs and find old relative momentum.
5358 180 DO 210 i1m=nbe(ibe-1)+1,nbe(ibe)-1
5359 i1=k(i1m,1)
5360 DO 200 i2m=i1m+1,nbe(ibe)
5361 i2=k(i2m,1)
5362 q2old=max(0.,(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+
5363 &p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2)
5364 qold=sqrt(q2old)
5365
5366C...Calculate new relative momentum.
5367 IF(qold.LT.1e-3*qdel) THEN
5368 GOTO 200
5369 ELSEIF(qold.LT.0.5*qdel) THEN
5370 qmov=qold/3.
5371 ELSEIF(qold.LT.(nbin-0.1)*qdel) THEN
5372 rbin=qold/qdel
5373 ibin=rbin
5374 rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
5375 qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
5376 & sqrt(q2old+pmhq**2)/q2old
5377 ELSE
5378 qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
5379 ENDIF
5380 q2new=q2old*(qold/(qold+3.*parj(92)*qmov))**(2./3.)
5381
5382C...Calculate and save shift to be performed on three-momenta.
5383 hc1=(p(i1,4)+p(i2,4))**2-(q2old-q2new)
5384 hc2=(q2old-q2new)*(p(i1,4)-p(i2,4))**2
5385 ha=0.5*(1.-sqrt(hc1*q2new/(hc1*q2old-hc2)))
5386 DO 190 j=1,3
5387 pd=ha*(p(i2,j)-p(i1,j))
5388 p(i1m,j)=p(i1m,j)+pd
5389 p(i2m,j)=p(i2m,j)-pd
5390 190 CONTINUE
5391 200 CONTINUE
5392 210 CONTINUE
5393 220 CONTINUE
5394
5395C...Shift momenta and recalculate energies.
5396 DO 240 im=nbe(0)+1,nbe(min(9,mstj(52)))
5397 i=k(im,1)
5398 DO 230 j=1,3
5399 p(i,j)=p(i,j)+p(im,j)
5400 230 CONTINUE
5401 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
5402 240 CONTINUE
5403
5404C...Rescale all momenta for energy conservation.
5405 pes=0.
5406 pqs=0.
5407 DO 250 i=1,n
5408 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 250
5409 pes=pes+p(i,4)
5410 pqs=pqs+p(i,5)**2/p(i,4)
5411 250 CONTINUE
5412 fac=(pecm-pqs)/(pes-pqs)
5413 DO 270 i=1,n
5414 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 270
5415 DO 260 j=1,3
5416 p(i,j)=fac*p(i,j)
5417 260 CONTINUE
5418 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
5419 270 CONTINUE
5420
5421C...Boost back to correct reference frame.
5422 CALL ludbrb(0,0,0.,0.,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
5423
5424 RETURN
5425 END
5426
5427C*********************************************************************
5428
5429 FUNCTION ulmass(KF)
5430
5431C...Purpose: to give the mass of a particle/parton.
5432 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5433 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5434 SAVE /ludat1/,/ludat2/
5435
5436C...Reset variables. Compressed code.
5437 ulmass=0.
5438 kfa=iabs(kf)
5439 kc=lucomp(kf)
5440 IF(kc.EQ.0) RETURN
5441 parf(106)=pmas(6,1)
5442 parf(107)=pmas(7,1)
5443 parf(108)=pmas(8,1)
5444
5445C...Guarantee use of constituent masses for internal checks.
5446 IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.kfa.LE.10) THEN
5447 ulmass=parf(100+kfa)
5448 IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(121))
5449
5450C...Masses that can be read directly off table.
5451 ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
5452 ulmass=pmas(kc,1)
5453
5454C...Find constituent partons and their masses.
5455 ELSE
5456 kfla=mod(kfa/1000,10)
5457 kflb=mod(kfa/100,10)
5458 kflc=mod(kfa/10,10)
5459 kfls=mod(kfa,10)
5460 kflr=mod(kfa/10000,10)
5461 pma=parf(100+kfla)
5462 pmb=parf(100+kflb)
5463 pmc=parf(100+kflc)
5464
5465C...Construct masses for various meson, diquark and baryon cases.
5466 IF(kfla.EQ.0.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
5467 IF(kfls.EQ.1) pmspl=-3./(pmb*pmc)
5468 IF(kfls.GE.3) pmspl=1./(pmb*pmc)
5469 ulmass=parf(111)+pmb+pmc+parf(113)*parf(101)**2*pmspl
5470 ELSEIF(kfla.EQ.0) THEN
5471 kmul=2
5472 IF(kfls.EQ.1) kmul=3
5473 IF(kflr.EQ.2) kmul=4
5474 IF(kfls.EQ.5) kmul=5
5475 ulmass=parf(113+kmul)+pmb+pmc
5476 ELSEIF(kflc.EQ.0) THEN
5477 IF(kfls.EQ.1) pmspl=-3./(pma*pmb)
5478 IF(kfls.EQ.3) pmspl=1./(pma*pmb)
5479 ulmass=2.*parf(112)/3.+pma+pmb+parf(114)*parf(101)**2*pmspl
5480 IF(mstj(93).EQ.1) ulmass=pma+pmb
5481 IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(122)-
5482 & 2.*parf(112)/3.)
5483 ELSE
5484 IF(kfls.EQ.2.AND.kfla.EQ.kflb) THEN
5485 pmspl=1./(pma*pmb)-2./(pma*pmc)-2./(pmb*pmc)
5486 ELSEIF(kfls.EQ.2.AND.kflb.GE.kflc) THEN
5487 pmspl=-2./(pma*pmb)-2./(pma*pmc)+1./(pmb*pmc)
5488 ELSEIF(kfls.EQ.2) THEN
5489 pmspl=-3./(pmb*pmc)
5490 ELSE
5491 pmspl=1./(pma*pmb)+1./(pma*pmc)+1./(pmb*pmc)
5492 ENDIF
5493 ulmass=parf(112)+pma+pmb+pmc+parf(114)*parf(101)**2*pmspl
5494 ENDIF
5495 ENDIF
5496
5497C...Optional mass broadening according to truncated Breit-Wigner
5498C...(either in m or in m^2).
5499 IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1e-4) THEN
5500 IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
5501 ulmass=ulmass+0.5*pmas(kc,2)*tan((2.*rlu(0)-1.)*
5502 & atan(2.*pmas(kc,3)/pmas(kc,2)))
5503 ELSE
5504 pm0=ulmass
5505 pmlow=atan((max(0.,pm0-pmas(kc,3))**2-pm0**2)/
5506 & (pm0*pmas(kc,2)))
5507 pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))
5508 ulmass=sqrt(max(0.,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
5509 & (pmupp-pmlow)*rlu(0))))
5510 ENDIF
5511 ENDIF
5512 mstj(93)=0
5513
5514 RETURN
5515 END
5516
5517C*********************************************************************
5518
5519 SUBROUTINE luname(KF,CHAU)
5520
5521C...Purpose: to give the particle/parton name as a character string.
5522 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5523 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5524 common/ludat4/chaf(500)
5525 CHARACTER CHAF*8
5526 SAVE /ludat1/,/ludat2/,/ludat4/
5527 CHARACTER CHAU*16
5528
5529C...Initial values. Charge. Subdivide code.
5530 chau=' '
5531 kfa=iabs(kf)
5532 kc=lucomp(kf)
5533 IF(kc.EQ.0) RETURN
5534 kq=luchge(kf)
5535 kfla=mod(kfa/1000,10)
5536 kflb=mod(kfa/100,10)
5537 kflc=mod(kfa/10,10)
5538 kfls=mod(kfa,10)
5539 kflr=mod(kfa/10000,10)
5540
5541C...Read out root name and spin for simple particle.
5542 IF(kfa.LE.100.OR.(kfa.GT.100.AND.kc.GT.100)) THEN
5543 chau=chaf(kc)
5544 len=0
5545 DO 100 lem=1,8
5546 IF(chau(lem:lem).NE.' ') len=lem
5547 100 CONTINUE
5548
5549C...Construct root name for diquark. Add on spin.
5550 ELSEIF(kflc.EQ.0) THEN
5551 chau(1:2)=chaf(kfla)(1:1)//chaf(kflb)(1:1)
5552 IF(kfls.EQ.1) chau(3:4)='_0'
5553 IF(kfls.EQ.3) chau(3:4)='_1'
5554 len=4
5555
5556C...Construct root name for heavy meson. Add on spin and heavy flavour.
5557 ELSEIF(kfla.EQ.0) THEN
5558 IF(kflb.EQ.5) chau(1:1)='B'
5559 IF(kflb.EQ.6) chau(1:1)='T'
5560 IF(kflb.EQ.7) chau(1:1)='L'
5561 IF(kflb.EQ.8) chau(1:1)='H'
5562 len=1
5563 IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
5564 ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
5565 chau(2:2)='*'
5566 len=2
5567 ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
5568 chau(2:3)='_1'
5569 len=3
5570 ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
5571 chau(2:4)='*_0'
5572 len=4
5573 ELSEIF(kflr.EQ.2) THEN
5574 chau(2:4)='*_1'
5575 len=4
5576 ELSEIF(kfls.EQ.5) THEN
5577 chau(2:4)='*_2'
5578 len=4
5579 ENDIF
5580 IF(kflc.GE.3.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
5581 chau(len+1:len+2)='_'//chaf(kflc)(1:1)
5582 len=len+2
5583 ELSEIF(kflc.GE.3) THEN
5584 chau(len+1:len+1)=chaf(kflc)(1:1)
5585 len=len+1
5586 ENDIF
5587
5588C...Construct root name and spin for heavy baryon.
5589 ELSE
5590 IF(kflb.LE.2.AND.kflc.LE.2) THEN
5591 chau='Sigma '
5592 IF(kflc.GT.kflb) chau='Lambda'
5593 IF(kfls.EQ.4) chau='Sigma*'
5594 len=5
5595 IF(chau(6:6).NE.' ') len=6
5596 ELSEIF(kflb.LE.2.OR.kflc.LE.2) THEN
5597 chau='Xi '
5598 IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Xi'''
5599 IF(kfls.EQ.4) chau='Xi*'
5600 len=2
5601 IF(chau(3:3).NE.' ') len=3
5602 ELSE
5603 chau='Omega '
5604 IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Omega'''
5605 IF(kfls.EQ.4) chau='Omega*'
5606 len=5
5607 IF(chau(6:6).NE.' ') len=6
5608 ENDIF
5609
5610C...Add on heavy flavour content for heavy baryon.
5611 chau(len+1:len+2)='_'//chaf(kfla)(1:1)
5612 len=len+2
5613 IF(kflb.GE.kflc.AND.kflc.GE.4) THEN
5614 chau(len+1:len+2)=chaf(kflb)(1:1)//chaf(kflc)(1:1)
5615 len=len+2
5616 ELSEIF(kflb.GE.kflc.AND.kflb.GE.4) THEN
5617 chau(len+1:len+1)=chaf(kflb)(1:1)
5618 len=len+1
5619 ELSEIF(kflc.GT.kflb.AND.kflb.GE.4) THEN
5620 chau(len+1:len+2)=chaf(kflc)(1:1)//chaf(kflb)(1:1)
5621 len=len+2
5622 ELSEIF(kflc.GT.kflb.AND.kflc.GE.4) THEN
5623 chau(len+1:len+1)=chaf(kflc)(1:1)
5624 len=len+1
5625 ENDIF
5626 ENDIF
5627
5628C...Add on bar sign for antiparticle (where necessary).
5629 IF(kf.GT.0.OR.len.EQ.0) THEN
5630 ELSEIF(kfa.GT.10.AND.kfa.LE.40.AND.kq.NE.0.AND.mod(kq,3).EQ.0)
5631 &THEN
5632 ELSEIF(kfa.EQ.89.OR.(kfa.GE.91.AND.kfa.LE.99)) THEN
5633 ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kq.NE.0) THEN
5634 ELSEIF(mstu(15).LE.1) THEN
5635 chau(len+1:len+1)='~'
5636 len=len+1
5637 ELSE
5638 chau(len+1:len+3)='bar'
5639 len=len+3
5640 ENDIF
5641
5642C...Add on charge where applicable (conventional cases skipped).
5643 IF(kq.EQ.6) chau(len+1:len+2)='++'
5644 IF(kq.EQ.-6) chau(len+1:len+2)='--'
5645 IF(kq.EQ.3) chau(len+1:len+1)='+'
5646 IF(kq.EQ.-3) chau(len+1:len+1)='-'
5647 IF(kq.EQ.0.AND.(kfa.LE.22.OR.len.EQ.0)) THEN
5648 ELSEIF(kq.EQ.0.AND.(kfa.GE.81.AND.kfa.LE.100)) THEN
5649 ELSEIF(kfa.EQ.28.OR.kfa.EQ.29) THEN
5650 ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kflb.EQ.kflc.AND.
5651 &kflb.NE.1) THEN
5652 ELSEIF(kq.EQ.0) THEN
5653 chau(len+1:len+1)='0'
5654 ENDIF
5655
5656 RETURN
5657 END
5658
5659C*********************************************************************
5660
5661 FUNCTION luchge(KF)
5662
5663C...Purpose: to give three times the charge for a particle/parton.
5664 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5665 SAVE /ludat2/
5666
5667C...Initial values. Simple case of direct readout.
5668 luchge=0
5669 kfa=iabs(kf)
5670 kc=lucomp(kfa)
5671 IF(kc.EQ.0) THEN
5672 ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
5673 luchge=kchg(kc,1)
5674
5675C...Construction from quark content for heavy meson, diquark, baryon.
5676 ELSEIF(mod(kfa/1000,10).EQ.0) THEN
5677 luchge=(kchg(mod(kfa/100,10),1)-kchg(mod(kfa/10,10),1))*
5678 & (-1)**mod(kfa/100,10)
5679 ELSEIF(mod(kfa/10,10).EQ.0) THEN
5680 luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)
5681 ELSE
5682 luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)+
5683 & kchg(mod(kfa/10,10),1)
5684 ENDIF
5685
5686C...Add on correct sign.
5687 luchge=luchge*isign(1,kf)
5688
5689 RETURN
5690 END
5691
5692C*********************************************************************
5693
5694 FUNCTION lucomp(KF)
5695
5696C...Purpose: to compress the standard KF codes for use in mass and decay
5697C...arrays; also to check whether a given code actually is defined.
5698 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5699 SAVE /ludat2/
5700 dimension kftab(25),kctab(25)
5701 DATA kftab/211,111,221,311,321,130,310,213,113,223,
5702 &313,323,2112,2212,210,2110,2210,110,220,330,440,30443,30553,0,0/
5703 DATA kctab/101,111,112,102,103,221,222,121,131,132,
5704 &122,123,332,333,281,282,283,284,285,286,287,231,235,0,0/
5705
5706C...Starting values.
5707 lucomp=0
5708 kfa=iabs(kf)
5709
5710C...Simple cases: direct translation or table.
5711 IF(kfa.EQ.0.OR.kfa.GE.100000) THEN
5712 RETURN
5713 ELSEIF(kfa.LE.100) THEN
5714 lucomp=kfa
5715 IF(kf.LT.0.AND.kchg(kfa,3).EQ.0) lucomp=0
5716 RETURN
5717 ELSE
5718 DO 100 ikf=1,23
5719 IF(kfa.EQ.kftab(ikf)) THEN
5720 lucomp=kctab(ikf)
5721 IF(kf.LT.0.AND.kchg(lucomp,3).EQ.0) lucomp=0
5722 RETURN
5723 ENDIF
5724 100 CONTINUE
5725 ENDIF
5726
5727C...Subdivide KF code into constituent pieces.
5728 kfla=mod(kfa/1000,10)
5729 kflb=mod(kfa/100,10)
5730 kflc=mod(kfa/10,10)
5731 kfls=mod(kfa,10)
5732 kflr=mod(kfa/10000,10)
5733
5734C...Mesons.
5735 IF(kfa-10000*kflr.LT.1000) THEN
5736 IF(kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.0.OR.kflc.EQ.9) THEN
5737 ELSEIF(kflb.LT.kflc) THEN
5738 ELSEIF(kf.LT.0.AND.kflb.EQ.kflc) THEN
5739 ELSEIF(kflb.EQ.kflc) THEN
5740 IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
5741 lucomp=110+kflb
5742 ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
5743 lucomp=130+kflb
5744 ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
5745 lucomp=150+kflb
5746 ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
5747 lucomp=170+kflb
5748 ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
5749 lucomp=190+kflb
5750 ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
5751 lucomp=210+kflb
5752 ENDIF
5753 ELSEIF(kflb.LE.5) THEN
5754 IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
5755 lucomp=100+((kflb-1)*(kflb-2))/2+kflc
5756 ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
5757 lucomp=120+((kflb-1)*(kflb-2))/2+kflc
5758 ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
5759 lucomp=140+((kflb-1)*(kflb-2))/2+kflc
5760 ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
5761 lucomp=160+((kflb-1)*(kflb-2))/2+kflc
5762 ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
5763 lucomp=180+((kflb-1)*(kflb-2))/2+kflc
5764 ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
5765 lucomp=200+((kflb-1)*(kflb-2))/2+kflc
5766 ENDIF
5767 ELSEIF((kfls.EQ.1.AND.kflr.LE.1).OR.(kfls.EQ.3.AND.kflr.LE.2).
5768 & or.(kfls.EQ.5.AND.kflr.EQ.0)) THEN
5769 lucomp=80+kflb
5770 ENDIF
5771
5772C...Diquarks.
5773 ELSEIF((kflr.EQ.0.OR.kflr.EQ.1).AND.kflc.EQ.0) THEN
5774 IF(kfls.NE.1.AND.kfls.NE.3) THEN
5775 ELSEIF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9) THEN
5776 ELSEIF(kfla.LT.kflb) THEN
5777 ELSEIF(kfls.EQ.1.AND.kfla.EQ.kflb) THEN
5778 ELSE
5779 lucomp=90
5780 ENDIF
5781
5782C...Spin 1/2 baryons.
5783 ELSEIF(kflr.EQ.0.AND.kfls.EQ.2) THEN
5784 IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
5785 ELSEIF(kfla.LE.kflc.OR.kfla.LT.kflb) THEN
5786 ELSEIF(kfla.GE.6.OR.kflb.GE.4.OR.kflc.GE.4) THEN
5787 lucomp=80+kfla
5788 ELSEIF(kflb.LT.kflc) THEN
5789 lucomp=300+((kfla+1)*kfla*(kfla-1))/6+(kflc*(kflc-1))/2+kflb
5790 ELSE
5791 lucomp=330+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
5792 ENDIF
5793
5794C...Spin 3/2 baryons.
5795 ELSEIF(kflr.EQ.0.AND.kfls.EQ.4) THEN
5796 IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
5797 ELSEIF(kfla.LT.kflb.OR.kflb.LT.kflc) THEN
5798 ELSEIF(kfla.GE.6.OR.kflb.GE.4) THEN
5799 lucomp=80+kfla
5800 ELSE
5801 lucomp=360+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
5802 ENDIF
5803 ENDIF
5804
5805 RETURN
5806 END
5807
5808C*********************************************************************
5809
5810 SUBROUTINE luerrm(MERR,CHMESS)
5811
5812C...Purpose: to inform user of errors in program execution.
5813 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
5814 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5815 SAVE /lujets/,/ludat1/
5816 CHARACTER CHMESS*(*)
5817
5818C...Write first few warnings, then be silent.
5819 IF(merr.LE.10) THEN
5820 mstu(27)=mstu(27)+1
5821 mstu(28)=merr
5822 IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)
5823 & merr,mstu(31),chmess
5824
5825C...Write first few errors, then be silent or stop program.
5826 ELSEIF(merr.LE.20) THEN
5827 mstu(23)=mstu(23)+1
5828 mstu(24)=merr-10
5829 IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)
5830 & merr-10,mstu(31),chmess
5831 IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
5832 WRITE(mstu(11),5100) merr-10,mstu(31),chmess
5833 WRITE(mstu(11),5200)
5834 IF(merr.NE.17) CALL lulist(2)
5835 stop
5836 ENDIF
5837
5838C...Stop program in case of irreparable error.
5839 ELSE
5840 WRITE(mstu(11),5300) merr-20,mstu(31),chmess
5841 stop
5842 ENDIF
5843
5844C...Formats for output.
5845 5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i6,
5846 &' LUEXEC calls:'/5x,a)
5847 5100 FORMAT(/5x,'Error type',i2,' has occured after',i6,
5848 &' LUEXEC calls:'/5x,a)
5849 5200 FORMAT(5x,'Execution will be stopped after listing of last ',
5850 &'event!')
5851 5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i6,
5852 &' LUEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
5853
5854 RETURN
5855 END
5856
5857C*********************************************************************
5858
5859 FUNCTION ulalem(Q2)
5860
5861C...Purpose: to calculate the running alpha_electromagnetic.
5862 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5863 SAVE /ludat1/
5864
5865C...Calculate real part of photon vacuum polarization.
5866C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
5867C...For hadrons use parametrization of H. Burkhardt et al.
5868C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
5869 aempi=paru(101)/(3.*paru(1))
5870 IF(mstu(101).LE.0.OR.q2.LT.2e-6) THEN
5871 rpigg=0.
5872 ELSEIF(q2.LT.0.09) THEN
5873 rpigg=aempi*(13.4916+log(q2))+0.00835*log(1.+q2)
5874 ELSEIF(q2.LT.9.) THEN
5875 rpigg=aempi*(16.3200+2.*log(q2))+0.00238*log(1.+3.927*q2)
5876 ELSEIF(q2.LT.1e4) THEN
5877 rpigg=aempi*(13.4955+3.*log(q2))+0.00165+0.00299*log(1.+q2)
5878 ELSE
5879 rpigg=aempi*(13.4955+3.*log(q2))+0.00221+0.00293*log(1.+q2)
5880 ENDIF
5881
5882C...Calculate running alpha_em.
5883 ulalem=paru(101)/(1.-rpigg)
5884 paru(108)=ulalem
5885
5886 RETURN
5887 END
5888
5889C*********************************************************************
5890
5891 FUNCTION ulalps(Q2)
5892
5893C...Purpose: to give the value of alpha_strong.
5894 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5895 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5896 SAVE /ludat1/,/ludat2/
5897
5898C...Constant alpha_strong trivial.
5899 IF(mstu(111).LE.0) THEN
5900 ulalps=paru(111)
5901 mstu(118)=mstu(112)
5902 paru(117)=0.
5903 paru(118)=paru(111)
5904 RETURN
5905 ENDIF
5906
5907C...Find effective Q2, number of flavours and Lambda.
5908 q2eff=q2
5909 IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
5910 nf=mstu(112)
5911 alam2=paru(112)**2
5912 100 IF(nf.GT.max(2,mstu(113))) THEN
5913 q2thr=paru(113)*pmas(nf,1)**2
5914 IF(q2eff.LT.q2thr) THEN
5915 nf=nf-1
5916 alam2=alam2*(q2thr/alam2)**(2./(33.-2.*nf))
5917 GOTO 100
5918 ENDIF
5919 ENDIF
5920 110 IF(nf.LT.min(8,mstu(114))) THEN
5921 q2thr=paru(113)*pmas(nf+1,1)**2
5922 IF(q2eff.GT.q2thr) THEN
5923 nf=nf+1
5924 alam2=alam2*(alam2/q2thr)**(2./(33.-2.*nf))
5925 GOTO 110
5926 ENDIF
5927 ENDIF
5928 IF(mstu(115).EQ.1) q2eff=q2eff+alam2
5929 paru(117)=sqrt(alam2)
5930
5931C...Evaluate first or second order alpha_strong.
5932 b0=(33.-2.*nf)/6.
5933 algq=log(max(1.0001,q2eff/alam2))
5934 IF(mstu(111).EQ.1) THEN
5935 ulalps=min(paru(115),paru(2)/(b0*algq))
5936 ELSE
5937 b1=(153.-19.*nf)/6.
5938 ulalps=min(paru(115),paru(2)/(b0*algq)*(1.-b1*log(algq)/
5939 & (b0**2*algq)))
5940 ENDIF
5941 mstu(118)=nf
5942 paru(118)=ulalps
5943
5944 RETURN
5945 END
5946
5947C*********************************************************************
5948
5949 FUNCTION ulangl(X,Y)
5950
5951C...Purpose: to reconstruct an angle from given x and y coordinates.
5952 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5953 SAVE /ludat1/
5954
5955 ulangl=0.
5956 r=sqrt(x**2+y**2)
5957 IF(r.LT.1e-20) RETURN
5958 IF(abs(x)/r.LT.0.8) THEN
5959 ulangl=sign(acos(x/r),y)
5960 ELSE
5961 ulangl=asin(y/r)
5962 IF(x.LT.0..AND.ulangl.GE.0.) THEN
5963 ulangl=paru(1)-ulangl
5964 ELSEIF(x.LT.0.) THEN
5965 ulangl=-paru(1)-ulangl
5966 ENDIF
5967 ENDIF
5968
5969 RETURN
5970 END
5971
5972C*********************************************************************
5973
5974 FUNCTION rlu(IDUMMY)
5975
5976C...Purpose: to generate random numbers uniformly distributed between
5977C...0 and 1, excluding the endpoints.
5978 common/ludatr/mrlu(6),rrlu(100)
5979 SAVE /ludatr/
5980 equivalence(mrlu1,mrlu(1)),(mrlu2,mrlu(2)),(mrlu3,mrlu(3)),
5981 &(mrlu4,mrlu(4)),(mrlu5,mrlu(5)),(mrlu6,mrlu(6)),
5982 &(rrlu98,rrlu(98)),(rrlu99,rrlu(99)),(rrlu00,rrlu(100))
5983
5984C...Initialize generation from given seed.
5985 IF(mrlu2.EQ.0) THEN
5986 ij=mod(mrlu1/30082,31329)
5987 kl=mod(mrlu1,30082)
5988 i=mod(ij/177,177)+2
5989 j=mod(ij,177)+2
5990 k=mod(kl/169,178)+1
5991 l=mod(kl,169)
5992 DO 110 ii=1,97
5993 s=0.
5994 t=0.5
5995 DO 100 jj=1,24
5996 m=mod(mod(i*j,179)*k,179)
5997 i=j
5998 j=k
5999 k=m
6000 l=mod(53*l+1,169)
6001 IF(mod(l*m,64).GE.32) s=s+t
6002 t=0.5*t
6003 100 CONTINUE
6004 rrlu(ii)=s
6005 110 CONTINUE
6006 twom24=1.
6007 DO 120 i24=1,24
6008 twom24=0.5*twom24
6009 120 CONTINUE
6010 rrlu98=362436.*twom24
6011 rrlu99=7654321.*twom24
6012 rrlu00=16777213.*twom24
6013 mrlu2=1
6014 mrlu3=0
6015 mrlu4=97
6016 mrlu5=33
6017 ENDIF
6018
6019C...Generate next random number.
6020 130 runi=rrlu(mrlu4)-rrlu(mrlu5)
6021 IF(runi.LT.0.) runi=runi+1.
6022 rrlu(mrlu4)=runi
6023 mrlu4=mrlu4-1
6024 IF(mrlu4.EQ.0) mrlu4=97
6025 mrlu5=mrlu5-1
6026 IF(mrlu5.EQ.0) mrlu5=97
6027 rrlu98=rrlu98-rrlu99
6028 IF(rrlu98.LT.0.) rrlu98=rrlu98+rrlu00
6029 runi=runi-rrlu98
6030 IF(runi.LT.0.) runi=runi+1.
6031 IF(runi.LE.0.OR.runi.GE.1.) GOTO 130
6032
6033C...Update counters. Random number to output.
6034 mrlu3=mrlu3+1
6035 IF(mrlu3.EQ.1000000000) THEN
6036 mrlu2=mrlu2+1
6037 mrlu3=0
6038 ENDIF
6039 rlu=runi
6040
6041 RETURN
6042 END
6043
6044C*********************************************************************
6045
6046 SUBROUTINE rluget(LFN,MOVE)
6047
6048C...Purpose: to dump the state of the random number generator on a file
6049C...for subsequent startup from this state onwards.
6050 common/ludatr/mrlu(6),rrlu(100)
6051 SAVE /ludatr/
6052 CHARACTER CHERR*8
6053
6054C...Backspace required number of records (or as many as there are).
6055 IF(move.LT.0) THEN
6056 nbck=min(mrlu(6),-move)
6057 DO 100 ibck=1,nbck
6058 backspace(lfn,err=110,iostat=ierr)
6059 100 CONTINUE
6060 mrlu(6)=mrlu(6)-nbck
6061 ENDIF
6062
6063C...Unformatted write on unit LFN.
6064 WRITE(lfn,err=110,iostat=ierr) (mrlu(i1),i1=1,5),
6065 &(rrlu(i2),i2=1,100)
6066 mrlu(6)=mrlu(6)+1
6067 RETURN
6068
6069C...Write error.
6070 110 WRITE(cherr,'(I8)') ierr
6071 CALL luerrm(18,'(RLUGET:) error when accessing file, IOSTAT ='//
6072 &cherr)
6073
6074 RETURN
6075 END
6076
6077C*********************************************************************
6078
6079 SUBROUTINE rluset(LFN,MOVE)
6080
6081C...Purpose: to read a state of the random number generator from a file
6082C...for subsequent generation from this state onwards.
6083 common/ludatr/mrlu(6),rrlu(100)
6084 SAVE /ludatr/
6085 CHARACTER CHERR*8
6086
6087C...Backspace required number of records (or as many as there are).
6088 IF(move.LT.0) THEN
6089 nbck=min(mrlu(6),-move)
6090 DO 100 ibck=1,nbck
6091 backspace(lfn,err=120,iostat=ierr)
6092 100 CONTINUE
6093 mrlu(6)=mrlu(6)-nbck
6094 ENDIF
6095
6096C...Unformatted read from unit LFN.
6097 nfor=1+max(0,move)
6098 DO 110 ifor=1,nfor
6099 READ(lfn,err=120,iostat=ierr) (mrlu(i1),i1=1,5),
6100 &(rrlu(i2),i2=1,100)
6101 110 CONTINUE
6102 mrlu(6)=mrlu(6)+nfor
6103 RETURN
6104
6105C...Write error.
6106 120 WRITE(cherr,'(I8)') ierr
6107 CALL luerrm(18,'(RLUSET:) error when accessing file, IOSTAT ='//
6108 &cherr)
6109
6110 RETURN
6111 END
6112
6113C*********************************************************************
6114
6115 SUBROUTINE lurobo(THE,PHI,BEX,BEY,BEZ)
6116
6117C...Purpose: to perform rotations and boosts.
6118 IMPLICIT DOUBLE PRECISION(d)
6119 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6120 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6121 SAVE /lujets/,/ludat1/
6122 dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
6123
6124C...Find range of rotation/boost. Convert boost to double precision.
6125 imin=1
6126 IF(mstu(1).GT.0) imin=mstu(1)
6127 imax=n
6128 IF(mstu(2).GT.0) imax=mstu(2)
6129 dbx=bex
6130 dby=bey
6131 dbz=bez
6132 GOTO 120
6133
6134C...Entry for specific range and double precision boost.
6135 entry ludbrb(imi,ima,the,phi,dbex,dbey,dbez)
6136 imin=imi
6137 IF(imin.LE.0) imin=1
6138 imax=ima
6139 IF(imax.LE.0) imax=n
6140 dbx=dbex
6141 dby=dbey
6142 dbz=dbez
6143
6144C...Optional resetting of V (when not set before.)
6145 IF(mstu(33).NE.0) THEN
6146 DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))
6147 DO 100 j=1,5
6148 v(i,j)=0.
6149 100 CONTINUE
6150 110 CONTINUE
6151 mstu(33)=0
6152 ENDIF
6153
6154C...Check range of rotation/boost.
6155 120 IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
6156 CALL luerrm(11,'(LUROBO:) range outside LUJETS memory')
6157 RETURN
6158 ENDIF
6159
6160C...Rotate, typically from z axis to direction (theta,phi).
6161 IF(the**2+phi**2.GT.1e-20) THEN
6162 rot(1,1)=cos(the)*cos(phi)
6163 rot(1,2)=-sin(phi)
6164 rot(1,3)=sin(the)*cos(phi)
6165 rot(2,1)=cos(the)*sin(phi)
6166 rot(2,2)=cos(phi)
6167 rot(2,3)=sin(the)*sin(phi)
6168 rot(3,1)=-sin(the)
6169 rot(3,2)=0.
6170 rot(3,3)=cos(the)
6171 DO 150 i=imin,imax
6172 IF(k(i,1).LE.0) GOTO 150
6173 DO 130 j=1,3
6174 pr(j)=p(i,j)
6175 vr(j)=v(i,j)
6176 130 CONTINUE
6177 DO 140 j=1,3
6178 p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
6179 v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
6180 140 CONTINUE
6181 150 CONTINUE
6182 ENDIF
6183
6184C...Boost, typically from rest to momentum/energy=beta.
6185 IF(dbx**2+dby**2+dbz**2.GT.1e-20) THEN
6186 db=sqrt(dbx**2+dby**2+dbz**2)
6187 IF(db.GT.0.99999999d0) THEN
6188C...Rescale boost vector if too close to unity.
6189 CALL luerrm(3,'(LUROBO:) boost vector too large')
6190 dbx=dbx*(0.99999999d0/db)
6191 dby=dby*(0.99999999d0/db)
6192 dbz=dbz*(0.99999999d0/db)
6193 db=0.99999999d0
6194 ENDIF
6195 dga=1d0/sqrt(1d0-db**2)
6196 DO 170 i=imin,imax
6197 IF(k(i,1).LE.0) GOTO 170
6198 DO 160 j=1,4
6199 dp(j)=p(i,j)
6200 dv(j)=v(i,j)
6201 160 CONTINUE
6202 dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
6203 dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
6204 p(i,1)=dp(1)+dgabp*dbx
6205 p(i,2)=dp(2)+dgabp*dby
6206 p(i,3)=dp(3)+dgabp*dbz
6207 p(i,4)=dga*(dp(4)+dbp)
6208 dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
6209 dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
6210 v(i,1)=dv(1)+dgabv*dbx
6211 v(i,2)=dv(2)+dgabv*dby
6212 v(i,3)=dv(3)+dgabv*dbz
6213 v(i,4)=dga*(dv(4)+dbv)
6214 170 CONTINUE
6215 ENDIF
6216
6217 RETURN
6218 END
6219
6220C*********************************************************************
6221
6222 SUBROUTINE luedit(MEDIT)
6223
6224C...Purpose: to perform global manipulations on the event record,
6225C...in particular to exclude unstable or undetectable partons/particles.
6226 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6227 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6228 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6229 SAVE /lujets/,/ludat1/,/ludat2/
6230 dimension ns(2),pts(2),pls(2)
6231
6232C...Remove unwanted partons/particles.
6233 IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
6234 imax=n
6235 IF(mstu(2).GT.0) imax=mstu(2)
6236 i1=max(1,mstu(1))-1
6237 DO 110 i=max(1,mstu(1)),imax
6238 IF(k(i,1).EQ.0.OR.k(i,1).GT.20) GOTO 110
6239 IF(medit.EQ.1) THEN
6240 IF(k(i,1).GT.10) GOTO 110
6241 ELSEIF(medit.EQ.2) THEN
6242 IF(k(i,1).GT.10) GOTO 110
6243 kc=lucomp(k(i,2))
6244 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)
6245 & GOTO 110
6246 ELSEIF(medit.EQ.3) THEN
6247 IF(k(i,1).GT.10) GOTO 110
6248 kc=lucomp(k(i,2))
6249 IF(kc.EQ.0) GOTO 110
6250 IF(kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) GOTO 110
6251 ELSEIF(medit.EQ.5) THEN
6252 IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) GOTO 110
6253 kc=lucomp(k(i,2))
6254 IF(kc.EQ.0) GOTO 110
6255 IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) GOTO 110
6256 ENDIF
6257
6258C...Pack remaining partons/particles. Origin no longer known.
6259 i1=i1+1
6260 DO 100 j=1,5
6261 k(i1,j)=k(i,j)
6262 p(i1,j)=p(i,j)
6263 v(i1,j)=v(i,j)
6264 100 CONTINUE
6265 k(i1,3)=0
6266 110 CONTINUE
6267 IF(i1.LT.n) mstu(3)=0
6268 IF(i1.LT.n) mstu(70)=0
6269 n=i1
6270
6271C...Selective removal of class of entries. New position of retained.
6272 ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
6273 i1=0
6274 DO 120 i=1,n
6275 k(i,3)=mod(k(i,3),mstu(5))
6276 IF(medit.EQ.11.AND.k(i,1).LT.0) GOTO 120
6277 IF(medit.EQ.12.AND.k(i,1).EQ.0) GOTO 120
6278 IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
6279 & k(i,1).EQ.15).AND.k(i,2).NE.94) GOTO 120
6280 IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
6281 & k(i,2).EQ.94)) GOTO 120
6282 IF(medit.EQ.15.AND.k(i,1).GE.21) GOTO 120
6283 i1=i1+1
6284 k(i,3)=k(i,3)+mstu(5)*i1
6285 120 CONTINUE
6286
6287C...Find new event history information and replace old.
6288 DO 140 i=1,n
6289 IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0) GOTO 140
6290 id=i
6291 130 im=mod(k(id,3),mstu(5))
6292 IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
6293 IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND.
6294 & k(im,2).NE.94) THEN
6295 id=im
6296 GOTO 130
6297 ENDIF
6298 ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
6299 IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN
6300 id=im
6301 GOTO 130
6302 ENDIF
6303 ENDIF
6304 k(i,3)=mstu(5)*(k(i,3)/mstu(5))
6305 IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
6306 IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
6307 IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
6308 & k(k(i,4),3)/mstu(5)
6309 IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
6310 & k(k(i,5),3)/mstu(5)
6311 ELSE
6312 kcm=mod(k(i,4)/mstu(5),mstu(5))
6313 IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
6314 kcd=mod(k(i,4),mstu(5))
6315 IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
6316 k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
6317 kcm=mod(k(i,5)/mstu(5),mstu(5))
6318 IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
6319 kcd=mod(k(i,5),mstu(5))
6320 IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
6321 k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
6322 ENDIF
6323 140 CONTINUE
6324
6325C...Pack remaining entries.
6326 i1=0
6327 mstu90=mstu(90)
6328 mstu(90)=0
6329 DO 170 i=1,n
6330 IF(k(i,3)/mstu(5).EQ.0) GOTO 170
6331 i1=i1+1
6332 DO 150 j=1,5
6333 k(i1,j)=k(i,j)
6334 p(i1,j)=p(i,j)
6335 v(i1,j)=v(i,j)
6336 150 CONTINUE
6337 k(i1,3)=mod(k(i1,3),mstu(5))
6338 DO 160 iz=1,mstu90
6339 IF(i.EQ.mstu(90+iz)) THEN
6340 mstu(90)=mstu(90)+1
6341 mstu(90+mstu(90))=i1
6342 paru(90+mstu(90))=paru(90+iz)
6343 ENDIF
6344 160 CONTINUE
6345 170 CONTINUE
6346 IF(i1.LT.n) mstu(3)=0
6347 IF(i1.LT.n) mstu(70)=0
6348 n=i1
6349
6350C...Fill in some missing daughter pointers (lost in colour flow).
6351 ELSEIF(medit.EQ.16) THEN
6352 DO 190 i=1,n
6353 IF(k(i,1).LE.10.OR.k(i,1).GT.20) GOTO 190
6354 IF(k(i,4).NE.0.OR.k(i,5).NE.0) GOTO 190
6355 DO 180 i1=i+1,n
6356 IF(k(i1,3).NE.i) THEN
6357 ELSEIF(k(i,4).EQ.0) THEN
6358 k(i,4)=i1
6359 ELSE
6360 k(i,5)=i1
6361 ENDIF
6362 180 CONTINUE
6363 IF(k(i,5).EQ.0) k(i,5)=k(i,4)
6364 190 CONTINUE
6365
6366C...Save top entries at bottom of LUJETS commonblock.
6367 ELSEIF(medit.EQ.21) THEN
6368 IF(2*n.GE.mstu(4)) THEN
6369 CALL luerrm(11,'(LUEDIT:) no more memory left in LUJETS')
6370 RETURN
6371 ENDIF
6372 DO 210 i=1,n
6373 DO 200 j=1,5
6374 k(mstu(4)-i,j)=k(i,j)
6375 p(mstu(4)-i,j)=p(i,j)
6376 v(mstu(4)-i,j)=v(i,j)
6377 200 CONTINUE
6378 210 CONTINUE
6379 mstu(32)=n
6380
6381C...Restore bottom entries of commonblock LUJETS to top.
6382 ELSEIF(medit.EQ.22) THEN
6383 DO 230 i=1,mstu(32)
6384 DO 220 j=1,5
6385 k(i,j)=k(mstu(4)-i,j)
6386 p(i,j)=p(mstu(4)-i,j)
6387 v(i,j)=v(mstu(4)-i,j)
6388 220 CONTINUE
6389 230 CONTINUE
6390 n=mstu(32)
6391
6392C...Mark primary entries at top of commonblock LUJETS as untreated.
6393 ELSEIF(medit.EQ.23) THEN
6394 i1=0
6395 DO 240 i=1,n
6396 kh=k(i,3)
6397 IF(kh.GE.1) THEN
6398 IF(k(kh,1).GT.20) kh=0
6399 ENDIF
6400 IF(kh.NE.0) GOTO 250
6401 i1=i1+1
6402 IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
6403 240 CONTINUE
6404 250 n=i1
6405
6406C...Place largest axis along z axis and second largest in xy plane.
6407 ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
6408 CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61),1),
6409 & p(mstu(61),2)),0d0,0d0,0d0)
6410 CALL ludbrb(1,n+mstu(3),-ulangl(p(mstu(61),3),
6411 & p(mstu(61),1)),0.,0d0,0d0,0d0)
6412 CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61)+1,1),
6413 & p(mstu(61)+1,2)),0d0,0d0,0d0)
6414 IF(medit.EQ.31) RETURN
6415
6416C...Rotate to put slim jet along +z axis.
6417 DO 260 is=1,2
6418 ns(is)=0
6419 pts(is)=0.
6420 pls(is)=0.
6421 260 CONTINUE
6422 DO 270 i=1,n
6423 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 270
6424 IF(mstu(41).GE.2) THEN
6425 kc=lucomp(k(i,2))
6426 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6427 & kc.EQ.18) GOTO 270
6428 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6429 & GOTO 270
6430 ENDIF
6431 is=2.-sign(0.5,p(i,3))
6432 ns(is)=ns(is)+1
6433 pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
6434 270 CONTINUE
6435 IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
6436 & CALL ludbrb(1,n+mstu(3),paru(1),0.,0d0,0d0,0d0)
6437
6438C...Rotate to put second largest jet into -z,+x quadrant.
6439 DO 280 i=1,n
6440 IF(p(i,3).GE.0.) GOTO 280
6441 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 280
6442 IF(mstu(41).GE.2) THEN
6443 kc=lucomp(k(i,2))
6444 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6445 & kc.EQ.18) GOTO 280
6446 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6447 & GOTO 280
6448 ENDIF
6449 is=2.-sign(0.5,p(i,1))
6450 pls(is)=pls(is)-p(i,3)
6451 280 CONTINUE
6452 IF(pls(2).GT.pls(1)) CALL ludbrb(1,n+mstu(3),0.,paru(1),
6453 & 0d0,0d0,0d0)
6454 ENDIF
6455
6456 RETURN
6457 END
6458
6459C*********************************************************************
6460
6461 SUBROUTINE lulist(MLIST)
6462
6463C...Purpose: to give program heading, or list an event, or particle
6464C...data, or current parameter values.
6465 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6466 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6467 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6468 common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
6469 SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
6470 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
6471 dimension ps(6)
6472 DATA chdl/'(())',' ','()','!!','<>','==','(==)'/
6473
6474C...Initialization printout: version number and date of last change.
6475 IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN
6476 CALL lulogo
6477 mstu(12)=0
6478 IF(mlist.EQ.0) RETURN
6479 ENDIF
6480
6481C...List event data, including additional lines after N.
6482 IF(mlist.GE.1.AND.mlist.LE.3) THEN
6483 IF(mlist.EQ.1) WRITE(mstu(11),5100)
6484 IF(mlist.EQ.2) WRITE(mstu(11),5200)
6485 IF(mlist.EQ.3) WRITE(mstu(11),5300)
6486 lmx=12
6487 IF(mlist.GE.2) lmx=16
6488 istr=0
6489 imax=n
6490 IF(mstu(2).GT.0) imax=mstu(2)
6491 DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
6492 IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) GOTO 120
6493
6494C...Get particle name, pad it and check it is not too long.
6495 CALL luname(k(i,2),chap)
6496 len=0
6497 DO 100 lem=1,16
6498 IF(chap(lem:lem).NE.' ') len=lem
6499 100 CONTINUE
6500 mdl=(k(i,1)+19)/10
6501 ldl=0
6502 IF(mdl.EQ.2.OR.mdl.GE.8) THEN
6503 chac=chap
6504 IF(len.GT.lmx) chac(lmx:lmx)='?'
6505 ELSE
6506 ldl=1
6507 IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
6508 IF(len.EQ.0) THEN
6509 chac=chdl(mdl)(1:2*ldl)//' '
6510 ELSE
6511 chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
6512 & chdl(mdl)(ldl+1:2*ldl)//' '
6513 IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
6514 ENDIF
6515 ENDIF
6516
6517C...Add information on string connection.
6518 IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
6519 & THEN
6520 kc=lucomp(k(i,2))
6521 kcc=0
6522 IF(kc.NE.0) kcc=kchg(kc,2)
6523 IF(iabs(k(i,2)).EQ.39) THEN
6524 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'
6525 ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN
6526 istr=1
6527 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
6528 ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
6529 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
6530 ELSEIF(kcc.NE.0) THEN
6531 istr=0
6532 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
6533 ENDIF
6534 ENDIF
6535
6536C...Write data for particle/jet.
6537 IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999.) THEN
6538 WRITE(mstu(11),5400) i,chac(1:12),(k(i,j1),j1=1,3),
6539 & (p(i,j2),j2=1,5)
6540 ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999.) THEN
6541 WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),
6542 & (p(i,j2),j2=1,5)
6543 ELSEIF(mlist.EQ.1) THEN
6544 WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),
6545 & (p(i,j2),j2=1,5)
6546 ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
6547 & k(i,1).EQ.14)) THEN
6548 WRITE(mstu(11),5700) i,chac,(k(i,j1),j1=1,3),
6549 & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
6550 & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
6551 & (p(i,j2),j2=1,5)
6552 ELSE
6553 WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,5),(p(i,j2),j2=1,5)
6554 ENDIF
6555 IF(mlist.EQ.3) WRITE(mstu(11),5900) (v(i,j),j=1,5)
6556
6557C...Insert extra separator lines specified by user.
6558 IF(mstu(70).GE.1) THEN
6559 isep=0
6560 DO 110 j=1,min(10,mstu(70))
6561 IF(i.EQ.mstu(70+j)) isep=1
6562 110 CONTINUE
6563 IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),6000)
6564 IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),6100)
6565 ENDIF
6566 120 CONTINUE
6567
6568C...Sum of charges and momenta.
6569 DO 130 j=1,6
6570 ps(j)=plu(0,j)
6571 130 CONTINUE
6572 IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999.) THEN
6573 WRITE(mstu(11),6200) ps(6),(ps(j),j=1,5)
6574 ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999.) THEN
6575 WRITE(mstu(11),6300) ps(6),(ps(j),j=1,5)
6576 ELSEIF(mlist.EQ.1) THEN
6577 WRITE(mstu(11),6400) ps(6),(ps(j),j=1,5)
6578 ELSE
6579 WRITE(mstu(11),6500) ps(6),(ps(j),j=1,5)
6580 ENDIF
6581
6582C...Give simple list of KF codes defined in program.
6583 ELSEIF(mlist.EQ.11) THEN
6584 WRITE(mstu(11),6600)
6585 DO 140 kf=1,40
6586 CALL luname(kf,chap)
6587 CALL luname(-kf,chan)
6588 IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
6589 IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
6590 140 CONTINUE
6591 DO 170 kfls=1,3,2
6592 DO 160 kfla=1,8
6593 DO 150 kflb=1,kfla-(3-kfls)/2
6594 kf=1000*kfla+100*kflb+kfls
6595 CALL luname(kf,chap)
6596 CALL luname(-kf,chan)
6597 WRITE(mstu(11),6700) kf,chap,-kf,chan
6598 150 CONTINUE
6599 160 CONTINUE
6600 170 CONTINUE
6601 kf=130
6602 CALL luname(kf,chap)
6603 WRITE(mstu(11),6700) kf,chap
6604 kf=310
6605 CALL luname(kf,chap)
6606 WRITE(mstu(11),6700) kf,chap
6607 DO 200 kmul=0,5
6608 kfls=3
6609 IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
6610 IF(kmul.EQ.5) kfls=5
6611 kflr=0
6612 IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
6613 IF(kmul.EQ.4) kflr=2
6614 DO 190 kflb=1,8
6615 DO 180 kflc=1,kflb-1
6616 kf=10000*kflr+100*kflb+10*kflc+kfls
6617 CALL luname(kf,chap)
6618 CALL luname(-kf,chan)
6619 WRITE(mstu(11),6700) kf,chap,-kf,chan
6620 180 CONTINUE
6621 kf=10000*kflr+110*kflb+kfls
6622 CALL luname(kf,chap)
6623 WRITE(mstu(11),6700) kf,chap
6624 190 CONTINUE
6625 200 CONTINUE
6626 kf=30443
6627 CALL luname(kf,chap)
6628 WRITE(mstu(11),6700) kf,chap
6629 kf=30553
6630 CALL luname(kf,chap)
6631 WRITE(mstu(11),6700) kf,chap
6632 DO 240 kflsp=1,3
6633 kfls=2+2*(kflsp/3)
6634 DO 230 kfla=1,8
6635 DO 220 kflb=1,kfla
6636 DO 210 kflc=1,kflb
6637 IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc)) GOTO 210
6638 IF(kflsp.EQ.2.AND.kfla.EQ.kflc) GOTO 210
6639 IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
6640 IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
6641 CALL luname(kf,chap)
6642 CALL luname(-kf,chan)
6643 WRITE(mstu(11),6700) kf,chap,-kf,chan
6644 210 CONTINUE
6645 220 CONTINUE
6646 230 CONTINUE
6647 240 CONTINUE
6648
6649C...List parton/particle data table. Check whether to be listed.
6650 ELSEIF(mlist.EQ.12) THEN
6651 WRITE(mstu(11),6800)
6652 mstj24=mstj(24)
6653 mstj(24)=0
6654 kfmax=30553
6655 IF(mstu(2).NE.0) kfmax=mstu(2)
6656 DO 270 kf=max(1,mstu(1)),kfmax
6657 kc=lucomp(kf)
6658 IF(kc.EQ.0) GOTO 270
6659 IF(mstu(14).EQ.0.AND.kf.GT.100.AND.kc.LE.100) GOTO 270
6660 IF(mstu(14).GT.0.AND.kf.GT.100.AND.max(mod(kf/1000,10),
6661 & mod(kf/100,10)).GT.mstu(14)) GOTO 270
6662 IF(mstu(14).GT.0.AND.kf.GT.100.AND.kc.EQ.90) GOTO 270
6663
6664C...Find particle name and mass. Print information.
6665 CALL luname(kf,chap)
6666 IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) GOTO 270
6667 CALL luname(-kf,chan)
6668 pm=ulmass(kf)
6669 WRITE(mstu(11),6900) kf,kc,chap,chan,kchg(kc,1),kchg(kc,2),
6670 & kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)
6671
6672C...Particle decay: channel number, branching ration, matrix element,
6673C...decay products.
6674 IF(kf.GT.100.AND.kc.LE.100) GOTO 270
6675 DO 260 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
6676 DO 250 j=1,5
6677 CALL luname(kfdp(idc,j),chad(j))
6678 250 CONTINUE
6679 WRITE(mstu(11),7000) idc,mdme(idc,1),mdme(idc,2),brat(idc),
6680 & (chad(j),j=1,5)
6681 260 CONTINUE
6682 270 CONTINUE
6683 mstj(24)=mstj24
6684
6685C...List parameter value table.
6686 ELSEIF(mlist.EQ.13) THEN
6687 WRITE(mstu(11),7100)
6688 DO 280 i=1,200
6689 WRITE(mstu(11),7200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
6690 280 CONTINUE
6691 ENDIF
6692
6693C...Format statements for output on unit MSTU(11) (by default 6).
6694 5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
6695 &5x,'KF orig p_x p_y p_z E m'/)
6696 5200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
6697 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
6698 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
6699 5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
6700 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
6701 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
6702 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
6703 5400 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.3)
6704 5500 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.2)
6705 5600 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.1)
6706 5700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i1,2i4),5f13.5)
6707 5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i9),5f13.5)
6708 5900 FORMAT(66x,5(1x,f12.3))
6709 6000 FORMAT(1x,78('='))
6710 6100 FORMAT(1x,130('='))
6711 6200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
6712 6300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
6713 6400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
6714 6500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
6715 &5f13.5)
6716 6600 FORMAT(///20x,'List of KF codes in program'/)
6717 6700 FORMAT(4x,i6,4x,a16,6x,i6,4x,a16)
6718 6800 FORMAT(///30x,'Particle/parton data table'//5x,'KF',5x,'KC',4x,
6719 &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
6720 &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
6721 &1x,'ME',3x,'Br.rat.',4x,'decay products')
6722 6900 FORMAT(/1x,i6,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
6723 &2x,f12.5,3x,i2)
6724 7000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f8.5,4x,5a16)
6725 7100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
6726 &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
6727 7200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
6728
6729 RETURN
6730 END
6731
6732C*********************************************************************
6733
6734 SUBROUTINE lulogo
6735
6736C...Purpose: to write logo for JETSET and PYTHIA programs.
6737 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6738 common/pypars/mstp(200),parp(200),msti(200),pari(200)
6739 SAVE /ludat1/
6740 SAVE /pypars/
6741 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(22)*36, LINE*79,
6742 &VERS*1, SUBV*3, DATE*2, YEAR*4
6743
6744C...Data on months, logo, titles, and references.
6745 DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
6746 &'Oct','Nov','Dec'/
6747 DATA (logo(j),j=1,10)/
6748 &'PPP Y Y TTTTT H H III A ',
6749 &'P P Y Y T H H I A A ',
6750 &'PPP Y T HHHHH I AAAAA',
6751 &'P Y T H H I A A',
6752 &'P Y T H H III A A',
6753 &'JJJJ EEEE TTTTT SSS EEEE TTTTT',
6754 &' J E T S E T ',
6755 &' J EEE T SSS EEE T ',
6756 &'J J E T S E T ',
6757 &' JJ EEEE T SSS EEEE T '/
6758 DATA (logo(j),j=11,29)/
6759 &' *......* ',
6760 &' *:::!!:::::::::::* ',
6761 &' *::::::!!::::::::::::::* ',
6762 &' *::::::::!!::::::::::::::::* ',
6763 &' *:::::::::!!:::::::::::::::::* ',
6764 &' *:::::::::!!:::::::::::::::::* ',
6765 &' *::::::::!!::::::::::::::::*! ',
6766 &' *::::::!!::::::::::::::* !! ',
6767 &' !! *:::!!:::::::::::* !! ',
6768 &' !! !* -><- * !! ',
6769 &' !! !! !! ',
6770 &' !! !! !! ',
6771 &' !! !! ',
6772 &' !! ep !! ',
6773 &' !! !! ',
6774 &' !! pp !! ',
6775 &' !! e+e- !! ',
6776 &' !! !! ',
6777 &' !! '/
6778 DATA (logo(j),j=30,48)/
6779 &'Welcome to the Lund Monte Carlo!',
6780 &' ',
6781 &' This is PYTHIA version x.xxx ',
6782 &'Last date of change: xx xxx 199x',
6783 &' ',
6784 &' This is JETSET version x.xxx ',
6785 &'Last date of change: xx xxx 199x',
6786 &' ',
6787 &' ',
6788 &' Main author: ',
6789 &' Torbjorn Sjostrand ',
6790 &' Theory Division, CERN, ',
6791 &' CH-1211 Geneva 23, ',
6792 &' Switzerland ',
6793 &' phone +41 - 22 - 767 28 20 ',
6794 &' E-mail TORSJO@CERNVM.CERN.CH ',
6795 &' ',
6796 &' Copyright Torbjorn Sjostrand ',
6797 &' and CERN, Geneva 1993 '/
6798 DATA (refer(j),j=1,16)/
6799 &'When you cite these programs, priori',
6800 &'ty should always be given to the ',
6801 &'latest published description. ',
6802 &' ',
6803 &'Currently this is, for JETSET ',
6804 &' ',
6805 &'T. Sjostrand and M. Bengtsson, Compu',
6806 &'ter Physics Commun. 43 (1987) 367, ',
6807 &'and for PYTHIA ',
6808 &' ',
6809 &'H.-U. Bengtsson and T. Sjostrand, Co',
6810 &'mputer Physics Commun. 46 (1987) 43.',
6811 &'The most recent long description (un',
6812 &'published) is: ',
6813 &'T. Sjostrand, CERN-TH.7112/93 (1993)',
6814 &'. '/
6815 DATA (refer(j),j=17,22)/
6816 &'Also remember that the programs, to ',
6817 &'a large extent, represent original ',
6818 &'physics research. Other publications',
6819 &' of special relevance to your ',
6820 &'studies may therefore deserve separa',
6821 &'te mention. '/
6822
6823C...Check if PYTHIA linked.
6824 IF(mstp(183)/10.NE.199) THEN
6825 logo(32)=' Warning: PYTHIA is not loaded! '
6826 logo(33)='Did you remember to link PYDATA?'
6827 ELSE
6828 WRITE(vers,'(I1)') mstp(181)
6829 logo(32)(26:26)=vers
6830 WRITE(subv,'(I3)') mstp(182)
6831 logo(32)(28:30)=subv
6832 WRITE(date,'(I2)') mstp(185)
6833 logo(33)(22:23)=date
6834 logo(33)(25:27)=month(mstp(184))
6835 WRITE(year,'(I4)') mstp(183)
6836 logo(33)(29:32)=year
6837 ENDIF
6838
6839C...Check if JETSET linked.
6840 IF(mstu(183)/10.NE.199) THEN
6841 logo(35)=' Error: JETSET is not loaded! '
6842 logo(36)='Did you remember to link LUDATA?'
6843 ELSE
6844 WRITE(vers,'(I1)') mstu(181)
6845 logo(35)(26:26)=vers
6846 WRITE(subv,'(I3)') mstu(182)
6847 logo(35)(28:30)=subv
6848 WRITE(date,'(I2)') mstu(185)
6849 logo(36)(22:23)=date
6850 logo(36)(25:27)=month(mstu(184))
6851 WRITE(year,'(I4)') mstu(183)
6852 logo(36)(29:32)=year
6853 ENDIF
6854
6855C...Loop over lines in header. Define page feed and side borders.
6856 DO 100 ilin=1,48
6857 line=' '
6858 IF(ilin.EQ.1) THEN
6859 line(1:1)='1'
6860 ELSE
6861 line(2:3)='**'
6862 line(78:79)='**'
6863 ENDIF
6864
6865C...Separator lines and logos.
6866 IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.EQ.47.OR.ilin.EQ.48) THEN
6867 line(4:77)='***********************************************'//
6868 & '***************************'
6869 ELSEIF(ilin.GE.6.AND.ilin.LE.10) THEN
6870 line(6:37)=logo(ilin-5)
6871 line(44:75)=logo(ilin)
6872 ELSEIF(ilin.GE.13.AND.ilin.LE.31) THEN
6873 line(6:37)=logo(ilin-2)
6874 line(44:75)=logo(ilin+17)
6875 ELSEIF(ilin.GE.34.AND.ilin.LE.44) THEN
6876 line(5:40)=refer(2*ilin-67)
6877 line(41:76)=refer(2*ilin-66)
6878 ENDIF
6879
6880C...Write lines to appropriate unit.
6881 IF(mstu(183)/10.EQ.199) THEN
6882 WRITE(mstu(11),'(A79)') line
6883 ELSE
6884 WRITE(*,'(A79)') line
6885 ENDIF
6886 100 CONTINUE
6887
6888C...Check that matching subversions are linked.
6889 IF(mstu(183)/10.EQ.199.AND.mstp(183)/10.EQ.199) THEN
6890 IF(mstu(182).LT.mstp(186)) WRITE(mstu(11),
6891 & '(/'' Warning: JETSET subversion too old for PYTHIA''/)')
6892 IF(mstp(182).LT.mstu(186)) WRITE(mstu(11),
6893 & '(/'' Warning: PYTHIA subversion too old for JETSET''/)')
6894 ENDIF
6895
6896 RETURN
6897 END
6898
6899C*********************************************************************
6900
6901 SUBROUTINE luupda(MUPDA,LFN)
6902
6903C...Purpose: to facilitate the updating of particle and decay data.
6904 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6905 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6906 common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
6907 common/ludat4/chaf(500)
6908 CHARACTER CHAF*8
6909 SAVE /ludat1/,/ludat2/,/ludat3/,/ludat4/
6910 CHARACTER CHINL*80,CHKC*4,CHVAR(19)*9,CHLIN*72,
6911 &CHBLK(20)*72,CHOLD*12,CHTMP*12,CHNEW*12,CHCOM*12
6912 DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
6913 &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
6914 &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
6915 &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
6916
6917C...Write information on file for editing.
6918 IF(mstu(12).GE.1) CALL lulist(0)
6919 IF(mupda.EQ.1) THEN
6920 DO 110 kc=1,mstu(6)
6921 WRITE(lfn,5000) kc,chaf(kc),(kchg(kc,j1),j1=1,3),
6922 & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
6923 DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
6924 WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),
6925 & (kfdp(idc,j),j=1,5)
6926 100 CONTINUE
6927 110 CONTINUE
6928
6929C...Reset variables and read information from edited file.
6930 ELSEIF(mupda.EQ.2) THEN
6931 DO 130 i=1,mstu(7)
6932 mdme(i,1)=1
6933 mdme(i,2)=0
6934 brat(i)=0.
6935 DO 120 j=1,5
6936 kfdp(i,j)=0
6937 120 CONTINUE
6938 130 CONTINUE
6939 kc=0
6940 idc=0
6941 ndc=0
6942 140 READ(lfn,5200,END=150) chinl
6943 IF(chinl(2:5).NE.' ') THEN
6944 chkc=chinl(2:5)
6945 IF(kc.NE.0) THEN
6946 mdcy(kc,2)=0
6947 IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
6948 mdcy(kc,3)=ndc
6949 ENDIF
6950 READ(chkc,5300) kc
6951 IF(kc.LE.0.OR.kc.GT.mstu(6)) CALL luerrm(27,
6952 & '(LUUPDA:) Read KC code illegal, KC ='//chkc)
6953 READ(chinl,5000) kcr,chaf(kc),(kchg(kc,j1),j1=1,3),
6954 & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
6955 ndc=0
6956 ELSE
6957 idc=idc+1
6958 ndc=ndc+1
6959 IF(idc.GE.mstu(7)) CALL luerrm(27,
6960 & '(LUUPDA:) Decay data arrays full by KC ='//chkc)
6961 READ(chinl,5100) mdme(idc,1),mdme(idc,2),brat(idc),
6962 & (kfdp(idc,j),j=1,5)
6963 ENDIF
6964 GOTO 140
6965 150 mdcy(kc,2)=0
6966 IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
6967 mdcy(kc,3)=ndc
6968
6969C...Perform possible tests that new information is consistent.
6970 mstj24=mstj(24)
6971 mstj(24)=0
6972 DO 180 kc=1,mstu(6)
6973 WRITE(chkc,5300) kc
6974 IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
6975 & pmas(kc,4)).LT.0..OR.mdcy(kc,3).LT.0) CALL luerrm(17,
6976 & '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//chkc)
6977 brsum=0.
6978 DO 170 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
6979 IF(mdme(idc,2).GT.80) GOTO 170
6980 kq=kchg(kc,1)
6981 pms=pmas(kc,1)-pmas(kc,3)-parj(64)
6982 merr=0
6983 DO 160 j=1,5
6984 kp=kfdp(idc,j)
6985 IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
6986 ELSEIF(lucomp(kp).EQ.0) THEN
6987 merr=3
6988 ELSE
6989 kq=kq-luchge(kp)
6990 pms=pms-ulmass(kp)
6991 ENDIF
6992 160 CONTINUE
6993 IF(kq.NE.0) merr=max(2,merr)
6994 IF(kfdp(idc,2).NE.0.AND.(kc.LE.20.OR.kc.GT.40).AND.
6995 & (kc.LE.80.OR.kc.GT.100).AND.mdme(idc,2).NE.34.AND.
6996 & mdme(idc,2).NE.61.AND.pms.LT.0.) merr=max(1,merr)
6997 IF(merr.EQ.3) CALL luerrm(17,
6998 & '(LUUPDA:) Unknown particle code in decay of KC ='//chkc)
6999 IF(merr.EQ.2) CALL luerrm(17,
7000 & '(LUUPDA:) Charge not conserved in decay of KC ='//chkc)
7001 IF(merr.EQ.1) CALL luerrm(7,
7002 & '(LUUPDA:) Kinematically unallowed decay of KC ='//chkc)
7003 brsum=brsum+brat(idc)
7004 170 CONTINUE
7005 WRITE(chtmp,5500) brsum
7006 IF(abs(brsum).GT.0.0005.AND.abs(brsum-1.).GT.0.0005) CALL
7007 & luerrm(7,'(LUUPDA:) Sum of branching ratios is '//chtmp(5:12)//
7008 & ' for KC ='//chkc)
7009 180 CONTINUE
7010 mstj(24)=mstj24
7011
7012C...Initialize writing of DATA statements for inclusion in program.
7013 ELSEIF(mupda.EQ.3) THEN
7014 DO 250 ivar=1,19
7015 ndim=mstu(6)
7016 IF(ivar.GE.11.AND.ivar.LE.18) ndim=mstu(7)
7017 nlin=1
7018 chlin=' '
7019 chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
7020 llin=35
7021 chold='START'
7022
7023C...Loop through variables for conversion to characters.
7024 DO 230 idim=1,ndim
7025 IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)
7026 IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)
7027 IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)
7028 IF(ivar.EQ.4) WRITE(chtmp,5500) pmas(idim,1)
7029 IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,2)
7030 IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,3)
7031 IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,4)
7032 IF(ivar.EQ.8) WRITE(chtmp,5400) mdcy(idim,1)
7033 IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,2)
7034 IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,3)
7035 IF(ivar.EQ.11) WRITE(chtmp,5400) mdme(idim,1)
7036 IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,2)
7037 IF(ivar.EQ.13) WRITE(chtmp,5500) brat(idim)
7038 IF(ivar.EQ.14) WRITE(chtmp,5400) kfdp(idim,1)
7039 IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,2)
7040 IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,3)
7041 IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,4)
7042 IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,5)
7043 IF(ivar.EQ.19) chtmp=chaf(idim)
7044
7045C...Length of variable, trailing decimal zeros, quotation marks.
7046 llow=1
7047 lhig=1
7048 DO 190 ll=1,12
7049 IF(chtmp(13-ll:13-ll).NE.' ') llow=13-ll
7050 IF(chtmp(ll:ll).NE.' ') lhig=ll
7051 190 CONTINUE
7052 chnew=chtmp(llow:lhig)//' '
7053 lnew=1+lhig-llow
7054 IF((ivar.GE.4.AND.ivar.LE.7).OR.ivar.EQ.13) THEN
7055 lnew=lnew+1
7056 200 lnew=lnew-1
7057 IF(chnew(lnew:lnew).EQ.'0') GOTO 200
7058 IF(lnew.EQ.1) chnew(1:2)='0.'
7059 IF(lnew.EQ.1) lnew=2
7060 ELSEIF(ivar.EQ.19) THEN
7061 DO 210 ll=lnew,1,-1
7062 IF(chnew(ll:ll).EQ.'''') THEN
7063 chtmp=chnew
7064 chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
7065 lnew=lnew+1
7066 ENDIF
7067 210 CONTINUE
7068 chtmp=chnew
7069 chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
7070 lnew=lnew+2
7071 ENDIF
7072
7073C...Form composite character string, often including repetition counter.
7074 IF(chnew.NE.chold) THEN
7075 nrpt=1
7076 chold=chnew
7077 chcom=chnew
7078 lcom=lnew
7079 ELSE
7080 lrpt=lnew+1
7081 IF(nrpt.GE.2) lrpt=lnew+3
7082 IF(nrpt.GE.10) lrpt=lnew+4
7083 IF(nrpt.GE.100) lrpt=lnew+5
7084 IF(nrpt.GE.1000) lrpt=lnew+6
7085 llin=llin-lrpt
7086 nrpt=nrpt+1
7087 WRITE(chtmp,5400) nrpt
7088 lrpt=1
7089 IF(nrpt.GE.10) lrpt=2
7090 IF(nrpt.GE.100) lrpt=3
7091 IF(nrpt.GE.1000) lrpt=4
7092 chcom(1:lrpt+1+lnew)=chtmp(13-lrpt:12)//'*'//chnew(1:lnew)
7093 lcom=lrpt+1+lnew
7094 ENDIF
7095
7096C...Add characters to end of line, to new line (after storing old line),
7097C...or to new block of lines (after writing old block).
7098 IF(llin+lcom.LE.70) THEN
7099 chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
7100 llin=llin+lcom+1
7101 ELSEIF(nlin.LE.19) THEN
7102 chlin(llin+1:72)=' '
7103 chblk(nlin)=chlin
7104 nlin=nlin+1
7105 chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
7106 llin=6+lcom+1
7107 ELSE
7108 chlin(llin:72)='/'//' '
7109 chblk(nlin)=chlin
7110 WRITE(chtmp,5400) idim-nrpt
7111 chblk(1)(30:33)=chtmp(9:12)
7112 DO 220 ilin=1,nlin
7113 WRITE(lfn,5600) chblk(ilin)
7114 220 CONTINUE
7115 nlin=1
7116 chlin=' '
7117 chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//',I= , )/'//
7118 & chcom(1:lcom)//','
7119 WRITE(chtmp,5400) idim-nrpt+1
7120 chlin(25:28)=chtmp(9:12)
7121 llin=35+lcom+1
7122 ENDIF
7123 230 CONTINUE
7124
7125C...Write final block of lines.
7126 chlin(llin:72)='/'//' '
7127 chblk(nlin)=chlin
7128 WRITE(chtmp,5400) ndim
7129 chblk(1)(30:33)=chtmp(9:12)
7130 DO 240 ilin=1,nlin
7131 WRITE(lfn,5600) chblk(ilin)
7132 240 CONTINUE
7133 250 CONTINUE
7134 ENDIF
7135
7136C...Formats for reading and writing particle data.
7137 5000 FORMAT(1x,i4,2x,a8,3i3,3f12.5,2x,f12.5,i3)
7138 5100 FORMAT(5x,2i5,f12.5,5i8)
7139 5200 FORMAT(a80)
7140 5300 FORMAT(i4)
7141 5400 FORMAT(i12)
7142 5500 FORMAT(f12.5)
7143 5600 FORMAT(a72)
7144
7145 RETURN
7146 END
7147
7148C*********************************************************************
7149
7150 FUNCTION klu(I,J)
7151
7152C...Purpose: to provide various integer-valued event related data.
7153 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7154 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7155 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7156 SAVE /lujets/,/ludat1/,/ludat2/
7157
7158C...Default value. For I=0 number of entries, number of stable entries
7159C...or 3 times total charge.
7160 klu=0
7161 IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
7162 ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
7163 klu=n
7164 ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
7165 DO 100 i1=1,n
7166 IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+1
7167 IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+
7168 & luchge(k(i1,2))
7169 100 CONTINUE
7170 ELSEIF(i.EQ.0) THEN
7171
7172C...For I > 0 direct readout of K matrix or charge.
7173 ELSEIF(j.LE.5) THEN
7174 klu=k(i,j)
7175 ELSEIF(j.EQ.6) THEN
7176 klu=luchge(k(i,2))
7177
7178C...Status (existing/fragmented/decayed), parton/hadron separation.
7179 ELSEIF(j.LE.8) THEN
7180 IF(k(i,1).GE.1.AND.k(i,1).LE.10) klu=1
7181 IF(j.EQ.8) klu=klu*k(i,2)
7182 ELSEIF(j.LE.12) THEN
7183 kfa=iabs(k(i,2))
7184 kc=lucomp(kfa)
7185 kq=0
7186 IF(kc.NE.0) kq=kchg(kc,2)
7187 IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) klu=k(i,2)
7188 IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) klu=k(i,2)
7189 IF(j.EQ.11) klu=kc
7190 IF(j.EQ.12) klu=kq*isign(1,k(i,2))
7191
7192C...Heaviest flavour in hadron/diquark.
7193 ELSEIF(j.EQ.13) THEN
7194 kfa=iabs(k(i,2))
7195 klu=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
7196 IF(kfa.LT.10) klu=kfa
7197 IF(mod(kfa/1000,10).NE.0) klu=mod(kfa/1000,10)
7198 klu=klu*isign(1,k(i,2))
7199
7200C...Particle history: generation, ancestor, rank.
7201 ELSEIF(j.LE.16) THEN
7202 i2=i
7203 i1=i
7204 110 klu=klu+1
7205 i3=i2
7206 i2=i1
7207 i1=k(i1,3)
7208 IF(i1.GT.0.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) GOTO 110
7209 IF(j.EQ.15) klu=i2
7210 IF(j.EQ.16) THEN
7211 klu=0
7212 DO 120 i1=i2+1,i3
7213 IF(k(i1,3).EQ.i2.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) klu=klu+1
7214 120 CONTINUE
7215 ENDIF
7216
7217C...Particle coming from collapsing jet system or not.
7218 ELSEIF(j.EQ.17) THEN
7219 i1=i
7220 130 klu=klu+1
7221 i3=i1
7222 i1=k(i1,3)
7223 i0=max(1,i1)
7224 kc=lucomp(k(i0,2))
7225 IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
7226 IF(klu.EQ.1) klu=-1
7227 IF(klu.GT.1) klu=0
7228 RETURN
7229 ENDIF
7230 IF(kchg(kc,2).EQ.0) GOTO 130
7231 IF(k(i1,1).NE.12) klu=0
7232 IF(k(i1,1).NE.12) RETURN
7233 i2=i1
7234 140 i2=i2+1
7235 IF(i2.LT.n.AND.k(i2,1).NE.11) GOTO 140
7236 k3m=k(i3-1,3)
7237 IF(k3m.GE.i1.AND.k3m.LE.i2) klu=0
7238 k3p=k(i3+1,3)
7239 IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) klu=0
7240
7241C...Number of decay products. Colour flow.
7242 ELSEIF(j.EQ.18) THEN
7243 IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) klu=max(0,k(i,5)-k(i,4)+1)
7244 IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) klu=0
7245 ELSEIF(j.LE.22) THEN
7246 IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
7247 IF(j.EQ.19) klu=mod(k(i,4)/mstu(5),mstu(5))
7248 IF(j.EQ.20) klu=mod(k(i,5)/mstu(5),mstu(5))
7249 IF(j.EQ.21) klu=mod(k(i,4),mstu(5))
7250 IF(j.EQ.22) klu=mod(k(i,5),mstu(5))
7251 ELSE
7252 ENDIF
7253
7254 RETURN
7255 END
7256
7257C*********************************************************************
7258
7259 FUNCTION plu(I,J)
7260
7261C...Purpose: to provide various real-valued event related data.
7262 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7263 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7264 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7265 SAVE /lujets/,/ludat1/,/ludat2/
7266 dimension psum(4)
7267
7268C...Set default value. For I = 0 sum of momenta or charges,
7269C...or invariant mass of system.
7270 plu=0.
7271 IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
7272 ELSEIF(i.EQ.0.AND.j.LE.4) THEN
7273 DO 100 i1=1,n
7274 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+p(i1,j)
7275 100 CONTINUE
7276 ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
7277 DO 120 j1=1,4
7278 psum(j1)=0.
7279 DO 110 i1=1,n
7280 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+p(i1,j1)
7281 110 CONTINUE
7282 120 CONTINUE
7283 plu=sqrt(max(0.,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
7284 ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
7285 DO 130 i1=1,n
7286 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+luchge(k(i1,2))/3.
7287 130 CONTINUE
7288 ELSEIF(i.EQ.0) THEN
7289
7290C...Direct readout of P matrix.
7291 ELSEIF(j.LE.5) THEN
7292 plu=p(i,j)
7293
7294C...Charge, total momentum, transverse momentum, transverse mass.
7295 ELSEIF(j.LE.12) THEN
7296 IF(j.EQ.6) plu=luchge(k(i,2))/3.
7297 IF(j.EQ.7.OR.j.EQ.8) plu=p(i,1)**2+p(i,2)**2+p(i,3)**2
7298 IF(j.EQ.9.OR.j.EQ.10) plu=p(i,1)**2+p(i,2)**2
7299 IF(j.EQ.11.OR.j.EQ.12) plu=p(i,5)**2+p(i,1)**2+p(i,2)**2
7300 IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) plu=sqrt(plu)
7301
7302C...Theta and phi angle in radians or degrees.
7303 ELSEIF(j.LE.16) THEN
7304 IF(j.LE.14) plu=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
7305 IF(j.GE.15) plu=ulangl(p(i,1),p(i,2))
7306 IF(j.EQ.14.OR.j.EQ.16) plu=plu*180./paru(1)
7307
7308C...True rapidity, rapidity with pion mass, pseudorapidity.
7309 ELSEIF(j.LE.19) THEN
7310 pmr=0.
7311 IF(j.EQ.17) pmr=p(i,5)
7312 IF(j.EQ.18) pmr=ulmass(211)
7313 pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
7314 plu=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
7315 & 1e20)),p(i,3))
7316
7317C...Energy and momentum fractions (only to be used in CM frame).
7318 ELSEIF(j.LE.25) THEN
7319 IF(j.EQ.20) plu=2.*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
7320 IF(j.EQ.21) plu=2.*p(i,3)/paru(21)
7321 IF(j.EQ.22) plu=2.*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
7322 IF(j.EQ.23) plu=2.*p(i,4)/paru(21)
7323 IF(j.EQ.24) plu=(p(i,4)+p(i,3))/paru(21)
7324 IF(j.EQ.25) plu=(p(i,4)-p(i,3))/paru(21)
7325 ENDIF
7326
7327 RETURN
7328 END
7329
7330C*********************************************************************
7331
7332 SUBROUTINE lusphe(SPH,APL)
7333
7334C...Purpose: to perform sphericity tensor analysis to give sphericity,
7335C...aplanarity and the related event axes.
7336 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7337 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7338 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7339 SAVE /lujets/,/ludat1/,/ludat2/
7340 dimension sm(3,3),sv(3,3)
7341
7342C...Calculate matrix to be diagonalized.
7343 np=0
7344 DO 110 j1=1,3
7345 DO 100 j2=j1,3
7346 sm(j1,j2)=0.
7347 100 CONTINUE
7348 110 CONTINUE
7349 ps=0.
7350 DO 140 i=1,n
7351 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140
7352 IF(mstu(41).GE.2) THEN
7353 kc=lucomp(k(i,2))
7354 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7355 & kc.EQ.18) GOTO 140
7356 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7357 & GOTO 140
7358 ENDIF
7359 np=np+1
7360 pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7361 pwt=1.
7362 IF(abs(paru(41)-2.).GT.0.001) pwt=max(1e-10,pa)**(paru(41)-2.)
7363 DO 130 j1=1,3
7364 DO 120 j2=j1,3
7365 sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
7366 120 CONTINUE
7367 130 CONTINUE
7368 ps=ps+pwt*pa**2
7369 140 CONTINUE
7370
7371C...Very low multiplicities (0 or 1) not considered.
7372 IF(np.LE.1) THEN
7373 CALL luerrm(8,'(LUSPHE:) too few particles for analysis')
7374 sph=-1.
7375 apl=-1.
7376 RETURN
7377 ENDIF
7378 DO 160 j1=1,3
7379 DO 150 j2=j1,3
7380 sm(j1,j2)=sm(j1,j2)/ps
7381 150 CONTINUE
7382 160 CONTINUE
7383
7384C...Find eigenvalues to matrix (third degree equation).
7385 sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
7386 &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
7387 sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
7388 &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
7389 sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
7390 p(n+1,4)=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
7391 p(n+3,4)=1./3.+sqrt(-sq)*min(2.*sp,-sqrt(3.*(1.-sp**2))-sp)
7392 p(n+2,4)=1.-p(n+1,4)-p(n+3,4)
7393 IF(p(n+2,4).LT.1e-5) THEN
7394 CALL luerrm(8,'(LUSPHE:) all particles back-to-back')
7395 sph=-1.
7396 apl=-1.
7397 RETURN
7398 ENDIF
7399
7400C...Find first and last eigenvector by solving equation system.
7401 DO 240 i=1,3,2
7402 DO 180 j1=1,3
7403 sv(j1,j1)=sm(j1,j1)-p(n+i,4)
7404 DO 170 j2=j1+1,3
7405 sv(j1,j2)=sm(j1,j2)
7406 sv(j2,j1)=sm(j1,j2)
7407 170 CONTINUE
7408 180 CONTINUE
7409 smax=0.
7410 DO 200 j1=1,3
7411 DO 190 j2=1,3
7412 IF(abs(sv(j1,j2)).LE.smax) GOTO 190
7413 ja=j1
7414 jb=j2
7415 smax=abs(sv(j1,j2))
7416 190 CONTINUE
7417 200 CONTINUE
7418 smax=0.
7419 DO 220 j3=ja+1,ja+2
7420 j1=j3-3*((j3-1)/3)
7421 rl=sv(j1,jb)/sv(ja,jb)
7422 DO 210 j2=1,3
7423 sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
7424 IF(abs(sv(j1,j2)).LE.smax) GOTO 210
7425 jc=j1
7426 smax=abs(sv(j1,j2))
7427 210 CONTINUE
7428 220 CONTINUE
7429 jb1=jb+1-3*(jb/3)
7430 jb2=jb+2-3*((jb+1)/3)
7431 p(n+i,jb1)=-sv(jc,jb2)
7432 p(n+i,jb2)=sv(jc,jb1)
7433 p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
7434 &sv(ja,jb)
7435 pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
7436 sgn=(-1.)**int(rlu(0)+0.5)
7437 DO 230 j=1,3
7438 p(n+i,j)=sgn*p(n+i,j)/pa
7439 230 CONTINUE
7440 240 CONTINUE
7441
7442C...Middle axis orthogonal to other two. Fill other codes.
7443 sgn=(-1.)**int(rlu(0)+0.5)
7444 p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
7445 p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
7446 p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
7447 DO 260 i=1,3
7448 k(n+i,1)=31
7449 k(n+i,2)=95
7450 k(n+i,3)=i
7451 k(n+i,4)=0
7452 k(n+i,5)=0
7453 p(n+i,5)=0.
7454 DO 250 j=1,5
7455 v(i,j)=0.
7456 250 CONTINUE
7457 260 CONTINUE
7458
7459C...Calculate sphericity and aplanarity. Select storing option.
7460 sph=1.5*(p(n+2,4)+p(n+3,4))
7461 apl=1.5*p(n+3,4)
7462 mstu(61)=n+1
7463 mstu(62)=np
7464 IF(mstu(43).LE.1) mstu(3)=3
7465 IF(mstu(43).GE.2) n=n+3
7466
7467 RETURN
7468 END
7469
7470C*********************************************************************
7471
7472 SUBROUTINE luthru(THR,OBL)
7473
7474C...Purpose: to perform thrust analysis to give thrust, oblateness
7475C...and the related event axes.
7476 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7477 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7478 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7479 SAVE /lujets/,/ludat1/,/ludat2/
7480 dimension tdi(3),tpr(3)
7481
7482C...Take copy of particles that are to be considered in thrust analysis.
7483 np=0
7484 ps=0.
7485 DO 100 i=1,n
7486 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
7487 IF(mstu(41).GE.2) THEN
7488 kc=lucomp(k(i,2))
7489 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7490 & kc.EQ.18) GOTO 100
7491 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7492 & GOTO 100
7493 ENDIF
7494 IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
7495 CALL luerrm(11,'(LUTHRU:) no more memory left in LUJETS')
7496 thr=-2.
7497 obl=-2.
7498 RETURN
7499 ENDIF
7500 np=np+1
7501 k(n+np,1)=23
7502 p(n+np,1)=p(i,1)
7503 p(n+np,2)=p(i,2)
7504 p(n+np,3)=p(i,3)
7505 p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7506 p(n+np,5)=1.
7507 IF(abs(paru(42)-1.).GT.0.001) p(n+np,5)=p(n+np,4)**(paru(42)-1.)
7508 ps=ps+p(n+np,4)*p(n+np,5)
7509 100 CONTINUE
7510
7511C...Very low multiplicities (0 or 1) not considered.
7512 IF(np.LE.1) THEN
7513 CALL luerrm(8,'(LUTHRU:) too few particles for analysis')
7514 thr=-1.
7515 obl=-1.
7516 RETURN
7517 ENDIF
7518
7519C...Loop over thrust and major. T axis along z direction in latter case.
7520 DO 320 ild=1,2
7521 IF(ild.EQ.2) THEN
7522 k(n+np+1,1)=31
7523 phi=ulangl(p(n+np+1,1),p(n+np+1,2))
7524 mstu(33)=1
7525 CALL ludbrb(n+1,n+np+1,0.,-phi,0d0,0d0,0d0)
7526 the=ulangl(p(n+np+1,3),p(n+np+1,1))
7527 CALL ludbrb(n+1,n+np+1,-the,0.,0d0,0d0,0d0)
7528 ENDIF
7529
7530C...Find and order particles with highest p (pT for major).
7531 DO 110 ilf=n+np+4,n+np+mstu(44)+4
7532 p(ilf,4)=0.
7533 110 CONTINUE
7534 DO 160 i=n+1,n+np
7535 IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
7536 DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1
7537 IF(p(i,4).LE.p(ilf,4)) GOTO 140
7538 DO 120 j=1,5
7539 p(ilf+1,j)=p(ilf,j)
7540 120 CONTINUE
7541 130 CONTINUE
7542 ilf=n+np+3
7543 140 DO 150 j=1,5
7544 p(ilf+1,j)=p(i,j)
7545 150 CONTINUE
7546 160 CONTINUE
7547
7548C...Find and order initial axes with highest thrust (major).
7549 DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
7550 p(ilg,4)=0.
7551 170 CONTINUE
7552 nc=2**(min(mstu(44),np)-1)
7553 DO 250 ilc=1,nc
7554 DO 180 j=1,3
7555 tdi(j)=0.
7556 180 CONTINUE
7557 DO 200 ilf=1,min(mstu(44),np)
7558 sgn=p(n+np+ilf+3,5)
7559 IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
7560 DO 190 j=1,4-ild
7561 tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
7562 190 CONTINUE
7563 200 CONTINUE
7564 tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
7565 DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
7566 IF(tds.LE.p(ilg,4)) GOTO 230
7567 DO 210 j=1,4
7568 p(ilg+1,j)=p(ilg,j)
7569 210 CONTINUE
7570 220 CONTINUE
7571 ilg=n+np+mstu(44)+4
7572 230 DO 240 j=1,3
7573 p(ilg+1,j)=tdi(j)
7574 240 CONTINUE
7575 p(ilg+1,4)=tds
7576 250 CONTINUE
7577
7578C...Iterate direction of axis until stable maximum.
7579 p(n+np+ild,4)=0.
7580 ilg=0
7581 260 ilg=ilg+1
7582 thp=0.
7583 270 thps=thp
7584 DO 280 j=1,3
7585 IF(thp.LE.1e-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
7586 IF(thp.GT.1e-10) tdi(j)=tpr(j)
7587 tpr(j)=0.
7588 280 CONTINUE
7589 DO 300 i=n+1,n+np
7590 sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
7591 DO 290 j=1,4-ild
7592 tpr(j)=tpr(j)+sgn*p(i,j)
7593 290 CONTINUE
7594 300 CONTINUE
7595 thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
7596 IF(thp.GE.thps+paru(48)) GOTO 270
7597
7598C...Save good axis. Try new initial axis until a number of tries agree.
7599 IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) GOTO 260
7600 IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
7601 iagr=0
7602 sgn=(-1.)**int(rlu(0)+0.5)
7603 DO 310 j=1,3
7604 p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
7605 310 CONTINUE
7606 p(n+np+ild,4)=thp
7607 p(n+np+ild,5)=0.
7608 ENDIF
7609 iagr=iagr+1
7610 IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) GOTO 260
7611 320 CONTINUE
7612
7613C...Find minor axis and value by orthogonality.
7614 sgn=(-1.)**int(rlu(0)+0.5)
7615 p(n+np+3,1)=-sgn*p(n+np+2,2)
7616 p(n+np+3,2)=sgn*p(n+np+2,1)
7617 p(n+np+3,3)=0.
7618 thp=0.
7619 DO 330 i=n+1,n+np
7620 thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
7621 330 CONTINUE
7622 p(n+np+3,4)=thp/ps
7623 p(n+np+3,5)=0.
7624
7625C...Fill axis information. Rotate back to original coordinate system.
7626 DO 350 ild=1,3
7627 k(n+ild,1)=31
7628 k(n+ild,2)=96
7629 k(n+ild,3)=ild
7630 k(n+ild,4)=0
7631 k(n+ild,5)=0
7632 DO 340 j=1,5
7633 p(n+ild,j)=p(n+np+ild,j)
7634 v(n+ild,j)=0.
7635 340 CONTINUE
7636 350 CONTINUE
7637 CALL ludbrb(n+1,n+3,the,phi,0d0,0d0,0d0)
7638
7639C...Calculate thrust and oblateness. Select storing option.
7640 thr=p(n+1,4)
7641 obl=p(n+2,4)-p(n+3,4)
7642 mstu(61)=n+1
7643 mstu(62)=np
7644 IF(mstu(43).LE.1) mstu(3)=3
7645 IF(mstu(43).GE.2) n=n+3
7646
7647 RETURN
7648 END
7649
7650C*********************************************************************
7651
7652 SUBROUTINE luclus(NJET)
7653
7654C...Purpose: to subdivide the particle content of an event into
7655C...jets/clusters.
7656 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7657 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7658 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7659 SAVE /lujets/,/ludat1/,/ludat2/
7660 dimension ps(5)
7661 SAVE nsav,np,ps,pss,rinit,npre,nrem
7662
7663C...Functions: distance measure in pT or (pseudo)mass.
7664 r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
7665 &p(i1,3)*p(i2,3))*2.*p(i1,5)*p(i2,5)/(0.0001+p(i1,5)+p(i2,5))**2
7666 r2m(i1,i2)=2.*p(i1,4)*p(i2,4)*(1.-(p(i1,1)*p(i2,1)+p(i1,2)*
7667 &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
7668
7669C...If first time, reset. If reentering, skip preliminaries.
7670 IF(mstu(48).LE.0) THEN
7671 np=0
7672 DO 100 j=1,5
7673 ps(j)=0.
7674 100 CONTINUE
7675 pss=0.
7676 ELSE
7677 njet=nsav
7678 IF(mstu(43).GE.2) n=n-njet
7679 DO 110 i=n+1,n+njet
7680 p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7681 110 CONTINUE
7682 IF(mstu(46).LE.3) r2acc=paru(44)**2
7683 IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2
7684 nloop=0
7685 GOTO 300
7686 ENDIF
7687
7688C...Find which particles are to be considered in cluster search.
7689 DO 140 i=1,n
7690 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140
7691 IF(mstu(41).GE.2) THEN
7692 kc=lucomp(k(i,2))
7693 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7694 & kc.EQ.18) GOTO 140
7695 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7696 & GOTO 140
7697 ENDIF
7698 IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
7699 CALL luerrm(11,'(LUCLUS:) no more memory left in LUJETS')
7700 njet=-1
7701 RETURN
7702 ENDIF
7703
7704C...Take copy of these particles, with space left for jets later on.
7705 np=np+1
7706 k(n+np,3)=i
7707 DO 120 j=1,5
7708 p(n+np,j)=p(i,j)
7709 120 CONTINUE
7710 IF(mstu(42).EQ.0) p(n+np,5)=0.
7711 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
7712 p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
7713 p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7714 DO 130 j=1,4
7715 ps(j)=ps(j)+p(n+np,j)
7716 130 CONTINUE
7717 pss=pss+p(n+np,5)
7718 140 CONTINUE
7719 DO 160 i=n+1,n+np
7720 k(i+np,3)=k(i,3)
7721 DO 150 j=1,5
7722 p(i+np,j)=p(i,j)
7723 150 CONTINUE
7724 160 CONTINUE
7725 ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
7726
7727C...Very low multiplicities not considered.
7728 IF(np.LT.mstu(47)) THEN
7729 CALL luerrm(8,'(LUCLUS:) too few particles for analysis')
7730 njet=-1
7731 RETURN
7732 ENDIF
7733
7734C...Find precluster configuration. If too few jets, make harder cuts.
7735 nloop=0
7736 IF(mstu(46).LE.3) r2acc=paru(44)**2
7737 IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2
7738 rinit=1.25*paru(43)
7739 IF(np.LE.mstu(47)+2) rinit=0.
7740 170 rinit=0.8*rinit
7741 npre=0
7742 nrem=np
7743 DO 180 i=n+np+1,n+2*np
7744 k(i,4)=0
7745 180 CONTINUE
7746
7747C...Sum up small momentum region. Jet if enough absolute momentum.
7748 IF(mstu(46).LE.2) THEN
7749 DO 190 j=1,4
7750 p(n+1,j)=0.
7751 190 CONTINUE
7752 DO 210 i=n+np+1,n+2*np
7753 IF(p(i,5).GT.2.*rinit) GOTO 210
7754 nrem=nrem-1
7755 k(i,4)=1
7756 DO 200 j=1,4
7757 p(n+1,j)=p(n+1,j)+p(i,j)
7758 200 CONTINUE
7759 210 CONTINUE
7760 p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
7761 IF(p(n+1,5).GT.2.*rinit) npre=1
7762 IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 170
7763 IF(nrem.EQ.0) GOTO 170
7764 ENDIF
7765
7766C...Find fastest remaining particle.
7767 220 npre=npre+1
7768 pmax=0.
7769 DO 230 i=n+np+1,n+2*np
7770 IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) GOTO 230
7771 imax=i
7772 pmax=p(i,5)
7773 230 CONTINUE
7774 DO 240 j=1,5
7775 p(n+npre,j)=p(imax,j)
7776 240 CONTINUE
7777 nrem=nrem-1
7778 k(imax,4)=npre
7779
7780C...Sum up precluster around it according to pT separation.
7781 IF(mstu(46).LE.2) THEN
7782 DO 260 i=n+np+1,n+2*np
7783 IF(k(i,4).NE.0) GOTO 260
7784 r2=r2t(i,imax)
7785 IF(r2.GT.rinit**2) GOTO 260
7786 nrem=nrem-1
7787 k(i,4)=npre
7788 DO 250 j=1,4
7789 p(n+npre,j)=p(n+npre,j)+p(i,j)
7790 250 CONTINUE
7791 260 CONTINUE
7792 p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
7793
7794C...Sum up precluster around it according to mass separation.
7795 ELSE
7796 270 imin=0
7797 r2min=rinit**2
7798 DO 280 i=n+np+1,n+2*np
7799 IF(k(i,4).NE.0) GOTO 280
7800 r2=r2m(i,n+npre)
7801 IF(r2.GE.r2min) GOTO 280
7802 imin=i
7803 r2min=r2
7804 280 CONTINUE
7805 IF(imin.NE.0) THEN
7806 DO 290 j=1,4
7807 p(n+npre,j)=p(n+npre,j)+p(imin,j)
7808 290 CONTINUE
7809 p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
7810 nrem=nrem-1
7811 k(imin,4)=npre
7812 GOTO 270
7813 ENDIF
7814 ENDIF
7815
7816C...Check if more preclusters to be found. Start over if too few.
7817 IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 170
7818 IF(nrem.GT.0) GOTO 220
7819 njet=npre
7820
7821C...Reassign all particles to nearest jet. Sum up new jet momenta.
7822 300 tsav=0.
7823 psjt=0.
7824 310 IF(mstu(46).LE.1) THEN
7825 DO 330 i=n+1,n+njet
7826 DO 320 j=1,4
7827 v(i,j)=0.
7828 320 CONTINUE
7829 330 CONTINUE
7830 DO 360 i=n+np+1,n+2*np
7831 r2min=pss**2
7832 DO 340 ijet=n+1,n+njet
7833 IF(p(ijet,5).LT.rinit) GOTO 340
7834 r2=r2t(i,ijet)
7835 IF(r2.GE.r2min) GOTO 340
7836 imin=ijet
7837 r2min=r2
7838 340 CONTINUE
7839 k(i,4)=imin-n
7840 DO 350 j=1,4
7841 v(imin,j)=v(imin,j)+p(i,j)
7842 350 CONTINUE
7843 360 CONTINUE
7844 psjt=0.
7845 DO 380 i=n+1,n+njet
7846 DO 370 j=1,4
7847 p(i,j)=v(i,j)
7848 370 CONTINUE
7849 p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7850 psjt=psjt+p(i,5)
7851 380 CONTINUE
7852 ENDIF
7853
7854C...Find two closest jets.
7855 r2min=2.*max(r2acc,ps(5)**2)
7856 DO 400 itry1=n+1,n+njet-1
7857 DO 390 itry2=itry1+1,n+njet
7858 IF(mstu(46).LE.2) r2=r2t(itry1,itry2)
7859 IF(mstu(46).GE.3) r2=r2m(itry1,itry2)
7860 IF(r2.GE.r2min) GOTO 390
7861 imin1=itry1
7862 imin2=itry2
7863 r2min=r2
7864 390 CONTINUE
7865 400 CONTINUE
7866
7867C...If allowed, join two closest jets and start over.
7868 IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
7869 irec=min(imin1,imin2)
7870 idel=max(imin1,imin2)
7871 DO 410 j=1,4
7872 p(irec,j)=p(imin1,j)+p(imin2,j)
7873 410 CONTINUE
7874 p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
7875 DO 430 i=idel+1,n+njet
7876 DO 420 j=1,5
7877 p(i-1,j)=p(i,j)
7878 420 CONTINUE
7879 430 CONTINUE
7880 IF(mstu(46).GE.2) THEN
7881 DO 440 i=n+np+1,n+2*np
7882 iori=n+k(i,4)
7883 IF(iori.EQ.idel) k(i,4)=irec-n
7884 IF(iori.GT.idel) k(i,4)=k(i,4)-1
7885 440 CONTINUE
7886 ENDIF
7887 njet=njet-1
7888 GOTO 300
7889
7890C...Divide up broad jet if empty cluster in list of final ones.
7891 ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
7892 DO 450 i=n+1,n+njet
7893 k(i,5)=0
7894 450 CONTINUE
7895 DO 460 i=n+np+1,n+2*np
7896 k(n+k(i,4),5)=k(n+k(i,4),5)+1
7897 460 CONTINUE
7898 iemp=0
7899 DO 470 i=n+1,n+njet
7900 IF(k(i,5).EQ.0) iemp=i
7901 470 CONTINUE
7902 IF(iemp.NE.0) THEN
7903 nloop=nloop+1
7904 ispl=0
7905 r2max=0.
7906 DO 480 i=n+np+1,n+2*np
7907 IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) GOTO 480
7908 ijet=n+k(i,4)
7909 r2=r2t(i,ijet)
7910 IF(r2.LE.r2max) GOTO 480
7911 ispl=i
7912 r2max=r2
7913 480 CONTINUE
7914 IF(ispl.NE.0) THEN
7915 ijet=n+k(ispl,4)
7916 DO 490 j=1,4
7917 p(iemp,j)=p(ispl,j)
7918 p(ijet,j)=p(ijet,j)-p(ispl,j)
7919 490 CONTINUE
7920 p(iemp,5)=p(ispl,5)
7921 p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
7922 IF(nloop.LE.2) GOTO 300
7923 ENDIF
7924 ENDIF
7925 ENDIF
7926
7927C...If generalized thrust has not yet converged, continue iteration.
7928 IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
7929 &THEN
7930 tsav=psjt/pss
7931 GOTO 310
7932 ENDIF
7933
7934C...Reorder jets according to energy.
7935 DO 510 i=n+1,n+njet
7936 DO 500 j=1,5
7937 v(i,j)=p(i,j)
7938 500 CONTINUE
7939 510 CONTINUE
7940 DO 540 inew=n+1,n+njet
7941 pemax=0.
7942 DO 520 itry=n+1,n+njet
7943 IF(v(itry,4).LE.pemax) GOTO 520
7944 imax=itry
7945 pemax=v(itry,4)
7946 520 CONTINUE
7947 k(inew,1)=31
7948 k(inew,2)=97
7949 k(inew,3)=inew-n
7950 k(inew,4)=0
7951 DO 530 j=1,5
7952 p(inew,j)=v(imax,j)
7953 530 CONTINUE
7954 v(imax,4)=-1.
7955 k(imax,5)=inew
7956 540 CONTINUE
7957
7958C...Clean up particle-jet assignments and jet information.
7959 DO 550 i=n+np+1,n+2*np
7960 iori=k(n+k(i,4),5)
7961 k(i,4)=iori-n
7962 IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
7963 k(iori,4)=k(iori,4)+1
7964 550 CONTINUE
7965 iemp=0
7966 psjt=0.
7967 DO 570 i=n+1,n+njet
7968 k(i,5)=0
7969 psjt=psjt+p(i,5)
7970 p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0.))
7971 DO 560 j=1,5
7972 v(i,j)=0.
7973 560 CONTINUE
7974 IF(k(i,4).EQ.0) iemp=i
7975 570 CONTINUE
7976
7977C...Select storing option. Output variables. Check for failure.
7978 mstu(61)=n+1
7979 mstu(62)=np
7980 mstu(63)=npre
7981 paru(61)=ps(5)
7982 paru(62)=psjt/pss
7983 paru(63)=sqrt(r2min)
7984 IF(njet.LE.1) paru(63)=0.
7985 IF(iemp.NE.0) THEN
7986 CALL luerrm(8,'(LUCLUS:) failed to reconstruct as requested')
7987 njet=-1
7988 ENDIF
7989 IF(mstu(43).LE.1) mstu(3)=njet
7990 IF(mstu(43).GE.2) n=n+njet
7991 nsav=njet
7992
7993 RETURN
7994 END
7995
7996C*********************************************************************
7997
7998 SUBROUTINE lucell(NJET)
7999
8000C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
8001C...coordinate frame, as used for calorimeters at hadron colliders.
8002 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8003 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8004 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8005 SAVE /lujets/,/ludat1/,/ludat2/
8006
8007C...Loop over all particles. Find cell that was hit by given particle.
8008 ptlrat=1./sinh(paru(51))**2
8009 np=0
8010 nc=n
8011 DO 110 i=1,n
8012 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
8013 IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) GOTO 110
8014 IF(mstu(41).GE.2) THEN
8015 kc=lucomp(k(i,2))
8016 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8017 & kc.EQ.18) GOTO 110
8018 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8019 & GOTO 110
8020 ENDIF
8021 np=np+1
8022 pt=sqrt(p(i,1)**2+p(i,2)**2)
8023 eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
8024 ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5*(eta/paru(51)+1.))))
8025 phi=ulangl(p(i,1),p(i,2))
8026 iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5*(phi/paru(1)+1.))))
8027 ietph=mstu(52)*ieta+iphi
8028
8029C...Add to cell already hit, or book new cell.
8030 DO 100 ic=n+1,nc
8031 IF(ietph.EQ.k(ic,3)) THEN
8032 k(ic,4)=k(ic,4)+1
8033 p(ic,5)=p(ic,5)+pt
8034 GOTO 110
8035 ENDIF
8036 100 CONTINUE
8037 IF(nc.GE.mstu(4)-mstu(32)-5) THEN
8038 CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
8039 njet=-2
8040 RETURN
8041 ENDIF
8042 nc=nc+1
8043 k(nc,3)=ietph
8044 k(nc,4)=1
8045 k(nc,5)=2
8046 p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
8047 p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
8048 p(nc,5)=pt
8049 110 CONTINUE
8050
8051C...Smear true bin content by calorimeter resolution.
8052 IF(mstu(53).GE.1) THEN
8053 DO 130 ic=n+1,nc
8054 pei=p(ic,5)
8055 IF(mstu(53).EQ.2) pei=p(ic,5)/cosh(p(ic,1))
8056 120 pef=pei+paru(55)*sqrt(-2.*log(max(1e-10,rlu(0)))*pei)*
8057 & cos(paru(2)*rlu(0))
8058 IF(pef.LT.0..OR.pef.GT.paru(56)*pei) GOTO 120
8059 p(ic,5)=pef
8060 IF(mstu(53).EQ.2) p(ic,5)=pef*cosh(p(ic,1))
8061 130 CONTINUE
8062 ENDIF
8063
8064C...Remove cells below threshold.
8065 IF(paru(58).GT.0.) THEN
8066 ncc=nc
8067 nc=n
8068 DO 140 ic=n+1,ncc
8069 IF(p(ic,5).GT.paru(58)) THEN
8070 nc=nc+1
8071 k(nc,3)=k(ic,3)
8072 k(nc,4)=k(ic,4)
8073 k(nc,5)=k(ic,5)
8074 p(nc,1)=p(ic,1)
8075 p(nc,2)=p(ic,2)
8076 p(nc,5)=p(ic,5)
8077 ENDIF
8078 140 CONTINUE
8079 ENDIF
8080
8081C...Find initiator cell: the one with highest pT of not yet used ones.
8082 nj=nc
8083 150 etmax=0.
8084 DO 160 ic=n+1,nc
8085 IF(k(ic,5).NE.2) GOTO 160
8086 IF(p(ic,5).LE.etmax) GOTO 160
8087 icmax=ic
8088 eta=p(ic,1)
8089 phi=p(ic,2)
8090 etmax=p(ic,5)
8091 160 CONTINUE
8092 IF(etmax.LT.paru(52)) GOTO 220
8093 IF(nj.GE.mstu(4)-mstu(32)-5) THEN
8094 CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
8095 njet=-2
8096 RETURN
8097 ENDIF
8098 k(icmax,5)=1
8099 nj=nj+1
8100 k(nj,4)=0
8101 k(nj,5)=1
8102 p(nj,1)=eta
8103 p(nj,2)=phi
8104 p(nj,3)=0.
8105 p(nj,4)=0.
8106 p(nj,5)=0.
8107
8108C...Sum up unused cells within required distance of initiator.
8109 DO 170 ic=n+1,nc
8110 IF(k(ic,5).EQ.0) GOTO 170
8111 IF(abs(p(ic,1)-eta).GT.paru(54)) GOTO 170
8112 dphia=abs(p(ic,2)-phi)
8113 IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) GOTO 170
8114 phic=p(ic,2)
8115 IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
8116 IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) GOTO 170
8117 k(ic,5)=-k(ic,5)
8118 k(nj,4)=k(nj,4)+k(ic,4)
8119 p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
8120 p(nj,4)=p(nj,4)+p(ic,5)*phic
8121 p(nj,5)=p(nj,5)+p(ic,5)
8122 170 CONTINUE
8123
8124C...Reject cluster below minimum ET, else accept.
8125 IF(p(nj,5).LT.paru(53)) THEN
8126 nj=nj-1
8127 DO 180 ic=n+1,nc
8128 IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
8129 180 CONTINUE
8130 ELSEIF(mstu(54).LE.2) THEN
8131 p(nj,3)=p(nj,3)/p(nj,5)
8132 p(nj,4)=p(nj,4)/p(nj,5)
8133 IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
8134 & p(nj,4))
8135 DO 190 ic=n+1,nc
8136 IF(k(ic,5).LT.0) k(ic,5)=0
8137 190 CONTINUE
8138 ELSE
8139 DO 200 j=1,4
8140 p(nj,j)=0.
8141 200 CONTINUE
8142 DO 210 ic=n+1,nc
8143 IF(k(ic,5).GE.0) GOTO 210
8144 p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
8145 p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
8146 p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
8147 p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
8148 k(ic,5)=0
8149 210 CONTINUE
8150 ENDIF
8151 GOTO 150
8152
8153C...Arrange clusters in falling ET sequence.
8154 220 DO 250 i=1,nj-nc
8155 etmax=0.
8156 DO 230 ij=nc+1,nj
8157 IF(k(ij,5).EQ.0) GOTO 230
8158 IF(p(ij,5).LT.etmax) GOTO 230
8159 ijmax=ij
8160 etmax=p(ij,5)
8161 230 CONTINUE
8162 k(ijmax,5)=0
8163 k(n+i,1)=31
8164 k(n+i,2)=98
8165 k(n+i,3)=i
8166 k(n+i,4)=k(ijmax,4)
8167 k(n+i,5)=0
8168 DO 240 j=1,5
8169 p(n+i,j)=p(ijmax,j)
8170 v(n+i,j)=0.
8171 240 CONTINUE
8172 250 CONTINUE
8173 njet=nj-nc
8174
8175C...Convert to massless or massive four-vectors.
8176 IF(mstu(54).EQ.2) THEN
8177 DO 260 i=n+1,n+njet
8178 eta=p(i,3)
8179 p(i,1)=p(i,5)*cos(p(i,4))
8180 p(i,2)=p(i,5)*sin(p(i,4))
8181 p(i,3)=p(i,5)*sinh(eta)
8182 p(i,4)=p(i,5)*cosh(eta)
8183 p(i,5)=0.
8184 260 CONTINUE
8185 ELSEIF(mstu(54).GE.3) THEN
8186 DO 270 i=n+1,n+njet
8187 p(i,5)=sqrt(max(0.,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
8188 270 CONTINUE
8189 ENDIF
8190
8191C...Information about storage.
8192 mstu(61)=n+1
8193 mstu(62)=np
8194 mstu(63)=nc-n
8195 IF(mstu(43).LE.1) mstu(3)=njet
8196 IF(mstu(43).GE.2) n=n+njet
8197
8198 RETURN
8199 END
8200
8201C*********************************************************************
8202
8203 SUBROUTINE lujmas(PMH,PML)
8204
8205C...Purpose: to determine, approximately, the two jet masses that
8206C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
8207 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8208 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8209 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8210 SAVE /lujets/,/ludat1/,/ludat2/
8211 dimension sm(3,3),sax(3),ps(3,5)
8212
8213C...Reset.
8214 np=0
8215 DO 120 j1=1,3
8216 DO 100 j2=j1,3
8217 sm(j1,j2)=0.
8218 100 CONTINUE
8219 DO 110 j2=1,4
8220 ps(j1,j2)=0.
8221 110 CONTINUE
8222 120 CONTINUE
8223 pss=0.
8224
8225C...Take copy of particles that are to be considered in mass analysis.
8226 DO 170 i=1,n
8227 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 170
8228 IF(mstu(41).GE.2) THEN
8229 kc=lucomp(k(i,2))
8230 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8231 & kc.EQ.18) GOTO 170
8232 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8233 & GOTO 170
8234 ENDIF
8235 IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
8236 CALL luerrm(11,'(LUJMAS:) no more memory left in LUJETS')
8237 pmh=-2.
8238 pml=-2.
8239 RETURN
8240 ENDIF
8241 np=np+1
8242 DO 130 j=1,5
8243 p(n+np,j)=p(i,j)
8244 130 CONTINUE
8245 IF(mstu(42).EQ.0) p(n+np,5)=0.
8246 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
8247 p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
8248
8249C...Fill information in sphericity tensor and total momentum vector.
8250 DO 150 j1=1,3
8251 DO 140 j2=j1,3
8252 sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
8253 140 CONTINUE
8254 150 CONTINUE
8255 pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
8256 DO 160 j=1,4
8257 ps(3,j)=ps(3,j)+p(n+np,j)
8258 160 CONTINUE
8259 170 CONTINUE
8260
8261C...Very low multiplicities (0 or 1) not considered.
8262 IF(np.LE.1) THEN
8263 CALL luerrm(8,'(LUJMAS:) too few particles for analysis')
8264 pmh=-1.
8265 pml=-1.
8266 RETURN
8267 ENDIF
8268 paru(61)=sqrt(max(0.,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-ps(3,3)**2))
8269
8270C...Find largest eigenvalue to matrix (third degree equation).
8271 DO 190 j1=1,3
8272 DO 180 j2=j1,3
8273 sm(j1,j2)=sm(j1,j2)/pss
8274 180 CONTINUE
8275 190 CONTINUE
8276 sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
8277 &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
8278 sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
8279 &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
8280 sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
8281 sma=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
8282
8283C...Find largest eigenvector by solving equation system.
8284 DO 210 j1=1,3
8285 sm(j1,j1)=sm(j1,j1)-sma
8286 DO 200 j2=j1+1,3
8287 sm(j2,j1)=sm(j1,j2)
8288 200 CONTINUE
8289 210 CONTINUE
8290 smax=0.
8291 DO 230 j1=1,3
8292 DO 220 j2=1,3
8293 IF(abs(sm(j1,j2)).LE.smax) GOTO 220
8294 ja=j1
8295 jb=j2
8296 smax=abs(sm(j1,j2))
8297 220 CONTINUE
8298 230 CONTINUE
8299 smax=0.
8300 DO 250 j3=ja+1,ja+2
8301 j1=j3-3*((j3-1)/3)
8302 rl=sm(j1,jb)/sm(ja,jb)
8303 DO 240 j2=1,3
8304 sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
8305 IF(abs(sm(j1,j2)).LE.smax) GOTO 240
8306 jc=j1
8307 smax=abs(sm(j1,j2))
8308 240 CONTINUE
8309 250 CONTINUE
8310 jb1=jb+1-3*(jb/3)
8311 jb2=jb+2-3*((jb+1)/3)
8312 sax(jb1)=-sm(jc,jb2)
8313 sax(jb2)=sm(jc,jb1)
8314 sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
8315
8316C...Divide particles into two initial clusters by hemisphere.
8317 DO 270 i=n+1,n+np
8318 psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
8319 is=1
8320 IF(psax.LT.0.) is=2
8321 k(i,3)=is
8322 DO 260 j=1,4
8323 ps(is,j)=ps(is,j)+p(i,j)
8324 260 CONTINUE
8325 270 CONTINUE
8326 pms=max(1e-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
8327 &max(1e-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
8328
8329C...Reassign one particle at a time; find maximum decrease of m^2 sum.
8330 280 pmd=0.
8331 im=0
8332 DO 290 j=1,4
8333 ps(3,j)=ps(1,j)-ps(2,j)
8334 290 CONTINUE
8335 DO 300 i=n+1,n+np
8336 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)
8337 IF(k(i,3).EQ.1) pmdi=2.*(p(i,5)**2-pps)
8338 IF(k(i,3).EQ.2) pmdi=2.*(p(i,5)**2+pps)
8339 IF(pmdi.LT.pmd) THEN
8340 pmd=pmdi
8341 im=i
8342 ENDIF
8343 300 CONTINUE
8344
8345C...Loop back if significant reduction in sum of m^2.
8346 IF(pmd.LT.-paru(48)*pms) THEN
8347 pms=pms+pmd
8348 is=k(im,3)
8349 DO 310 j=1,4
8350 ps(is,j)=ps(is,j)-p(im,j)
8351 ps(3-is,j)=ps(3-is,j)+p(im,j)
8352 310 CONTINUE
8353 k(im,3)=3-is
8354 GOTO 280
8355 ENDIF
8356
8357C...Final masses and output.
8358 mstu(61)=n+1
8359 mstu(62)=np
8360 ps(1,5)=sqrt(max(0.,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
8361 ps(2,5)=sqrt(max(0.,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
8362 pmh=max(ps(1,5),ps(2,5))
8363 pml=min(ps(1,5),ps(2,5))
8364
8365 RETURN
8366 END
8367
8368C*********************************************************************
8369
8370 SUBROUTINE lufowo(H10,H20,H30,H40)
8371
8372C...Purpose: to calculate the first few Fox-Wolfram moments.
8373 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8374 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8375 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8376 SAVE /lujets/,/ludat1/,/ludat2/
8377
8378C...Copy momenta for particles and calculate H0.
8379 np=0
8380 h0=0.
8381 hd=0.
8382 DO 110 i=1,n
8383 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
8384 IF(mstu(41).GE.2) THEN
8385 kc=lucomp(k(i,2))
8386 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8387 & kc.EQ.18) GOTO 110
8388 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8389 & GOTO 110
8390 ENDIF
8391 IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
8392 CALL luerrm(11,'(LUFOWO:) no more memory left in LUJETS')
8393 h10=-1.
8394 h20=-1.
8395 h30=-1.
8396 h40=-1.
8397 RETURN
8398 ENDIF
8399 np=np+1
8400 DO 100 j=1,3
8401 p(n+np,j)=p(i,j)
8402 100 CONTINUE
8403 p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
8404 h0=h0+p(n+np,4)
8405 hd=hd+p(n+np,4)**2
8406 110 CONTINUE
8407 h0=h0**2
8408
8409C...Very low multiplicities (0 or 1) not considered.
8410 IF(np.LE.1) THEN
8411 CALL luerrm(8,'(LUFOWO:) too few particles for analysis')
8412 h10=-1.
8413 h20=-1.
8414 h30=-1.
8415 h40=-1.
8416 RETURN
8417 ENDIF
8418
8419C...Calculate H1 - H4.
8420 h10=0.
8421 h20=0.
8422 h30=0.
8423 h40=0.
8424 DO 130 i1=n+1,n+np
8425 DO 120 i2=i1+1,n+np
8426 cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
8427 &(p(i1,4)*p(i2,4))
8428 h10=h10+p(i1,4)*p(i2,4)*cthe
8429 h20=h20+p(i1,4)*p(i2,4)*(1.5*cthe**2-0.5)
8430 h30=h30+p(i1,4)*p(i2,4)*(2.5*cthe**3-1.5*cthe)
8431 h40=h40+p(i1,4)*p(i2,4)*(4.375*cthe**4-3.75*cthe**2+0.375)
8432 120 CONTINUE
8433 130 CONTINUE
8434
8435C...Calculate H1/H0 - H4/H0. Output.
8436 mstu(61)=n+1
8437 mstu(62)=np
8438 h10=(hd+2.*h10)/h0
8439 h20=(hd+2.*h20)/h0
8440 h30=(hd+2.*h30)/h0
8441 h40=(hd+2.*h40)/h0
8442
8443 RETURN
8444 END
8445
8446C*********************************************************************
8447
8448 SUBROUTINE lutabu(MTABU)
8449
8450C...Purpose: to evaluate various properties of an event, with
8451C...statistics accumulated during the course of the run and
8452C...printed at the end.
8453 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8454 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8455 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8456 common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
8457 SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
8458 dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
8459 &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
8460 &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
8461 &kfdm(8),kfdc(200,0:8),npdc(200)
8462 SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
8463 &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
8464 &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
8465 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
8466 DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,
8467 &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0./,fm2fm/120*0./,
8468 &nevee/0/,fe1ec/50*0./,fe2ec/50*0./,fe1ea/25*0./,fe2ea/25*0./,
8469 &nevdc/0/,nkfdc/0/,nredc/0/
8470
8471C...Reset statistics on initial parton state.
8472 IF(mtabu.EQ.10) THEN
8473 nevis=0
8474 nkfis=0
8475
8476C...Identify and order flavour content of initial state.
8477 ELSEIF(mtabu.EQ.11) THEN
8478 nevis=nevis+1
8479 kfm1=2*iabs(mstu(161))
8480 IF(mstu(161).GT.0) kfm1=kfm1-1
8481 kfm2=2*iabs(mstu(162))
8482 IF(mstu(162).GT.0) kfm2=kfm2-1
8483 kfmn=min(kfm1,kfm2)
8484 kfmx=max(kfm1,kfm2)
8485 DO 100 i=1,nkfis
8486 IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
8487 ikfis=-i
8488 GOTO 110
8489 ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
8490 & kfmx.LT.kfis(i,2))) THEN
8491 ikfis=i
8492 GOTO 110
8493 ENDIF
8494 100 CONTINUE
8495 ikfis=nkfis+1
8496 110 IF(ikfis.LT.0) THEN
8497 ikfis=-ikfis
8498 ELSE
8499 IF(nkfis.GE.100) RETURN
8500 DO 130 i=nkfis,ikfis,-1
8501 kfis(i+1,1)=kfis(i,1)
8502 kfis(i+1,2)=kfis(i,2)
8503 DO 120 j=0,10
8504 npis(i+1,j)=npis(i,j)
8505 120 CONTINUE
8506 130 CONTINUE
8507 nkfis=nkfis+1
8508 kfis(ikfis,1)=kfmn
8509 kfis(ikfis,2)=kfmx
8510 DO 140 j=0,10
8511 npis(ikfis,j)=0
8512 140 CONTINUE
8513 ENDIF
8514 npis(ikfis,0)=npis(ikfis,0)+1
8515
8516C...Count number of partons in initial state.
8517 np=0
8518 DO 160 i=1,n
8519 IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
8520 ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
8521 ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
8522 & THEN
8523 ELSE
8524 im=i
8525 150 im=k(im,3)
8526 IF(im.LE.0.OR.im.GT.n) THEN
8527 np=np+1
8528 ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
8529 np=np+1
8530 ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
8531 ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10).NE.0)
8532 & THEN
8533 ELSE
8534 GOTO 150
8535 ENDIF
8536 ENDIF
8537 160 CONTINUE
8538 npco=max(np,1)
8539 IF(np.GE.6) npco=6
8540 IF(np.GE.8) npco=7
8541 IF(np.GE.11) npco=8
8542 IF(np.GE.16) npco=9
8543 IF(np.GE.26) npco=10
8544 npis(ikfis,npco)=npis(ikfis,npco)+1
8545 mstu(62)=np
8546
8547C...Write statistics on initial parton state.
8548 ELSEIF(mtabu.EQ.12) THEN
8549 fac=1./max(1,nevis)
8550 WRITE(mstu(11),5000) nevis
8551 DO 170 i=1,nkfis
8552 kfmn=kfis(i,1)
8553 IF(kfmn.EQ.0) kfmn=kfis(i,2)
8554 kfm1=(kfmn+1)/2
8555 IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
8556 CALL luname(kfm1,chau)
8557 chis(1)=chau(1:12)
8558 IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
8559 kfmx=kfis(i,2)
8560 IF(kfis(i,1).EQ.0) kfmx=0
8561 kfm2=(kfmx+1)/2
8562 IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
8563 CALL luname(kfm2,chau)
8564 chis(2)=chau(1:12)
8565 IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
8566 WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),
8567 & (npis(i,j)/float(npis(i,0)),j=1,10)
8568 170 CONTINUE
8569
8570C...Copy statistics on initial parton state into /LUJETS/.
8571 ELSEIF(mtabu.EQ.13) THEN
8572 fac=1./max(1,nevis)
8573 DO 190 i=1,nkfis
8574 kfmn=kfis(i,1)
8575 IF(kfmn.EQ.0) kfmn=kfis(i,2)
8576 kfm1=(kfmn+1)/2
8577 IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
8578 kfmx=kfis(i,2)
8579 IF(kfis(i,1).EQ.0) kfmx=0
8580 kfm2=(kfmx+1)/2
8581 IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
8582 k(i,1)=32
8583 k(i,2)=99
8584 k(i,3)=kfm1
8585 k(i,4)=kfm2
8586 k(i,5)=npis(i,0)
8587 DO 180 j=1,5
8588 p(i,j)=fac*npis(i,j)
8589 v(i,j)=fac*npis(i,j+5)
8590 180 CONTINUE
8591 190 CONTINUE
8592 n=nkfis
8593 DO 200 j=1,5
8594 k(n+1,j)=0
8595 p(n+1,j)=0.
8596 v(n+1,j)=0.
8597 200 CONTINUE
8598 k(n+1,1)=32
8599 k(n+1,2)=99
8600 k(n+1,5)=nevis
8601 mstu(3)=1
8602
8603C...Reset statistics on number of particles/partons.
8604 ELSEIF(mtabu.EQ.20) THEN
8605 nevfs=0
8606 nprfs=0
8607 nfifs=0
8608 nchfs=0
8609 nkffs=0
8610
8611C...Identify whether particle/parton is primary or not.
8612 ELSEIF(mtabu.EQ.21) THEN
8613 nevfs=nevfs+1
8614 mstu(62)=0
8615 DO 260 i=1,n
8616 IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) GOTO 260
8617 mstu(62)=mstu(62)+1
8618 kc=lucomp(k(i,2))
8619 mpri=0
8620 IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
8621 mpri=1
8622 ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
8623 mpri=1
8624 ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN
8625 mpri=1
8626 ELSEIF(kc.EQ.0) THEN
8627 ELSEIF(k(k(i,3),1).EQ.13) THEN
8628 im=k(k(i,3),3)
8629 IF(im.LE.0.OR.im.GT.n) THEN
8630 mpri=1
8631 ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
8632 mpri=1
8633 ENDIF
8634 ELSEIF(kchg(kc,2).EQ.0) THEN
8635 kcm=lucomp(k(k(i,3),2))
8636 IF(kcm.NE.0) THEN
8637 IF(kchg(kcm,2).NE.0) mpri=1
8638 ENDIF
8639 ENDIF
8640 IF(kc.NE.0.AND.mpri.EQ.1) THEN
8641 IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
8642 ENDIF
8643 IF(k(i,1).LE.10) THEN
8644 nfifs=nfifs+1
8645 IF(luchge(k(i,2)).NE.0) nchfs=nchfs+1
8646 ENDIF
8647
8648C...Fill statistics on number of particles/partons in event.
8649 kfa=iabs(k(i,2))
8650 kfs=3-isign(1,k(i,2))-mpri
8651 DO 210 ip=1,nkffs
8652 IF(kfa.EQ.kffs(ip)) THEN
8653 ikffs=-ip
8654 GOTO 220
8655 ELSEIF(kfa.LT.kffs(ip)) THEN
8656 ikffs=ip
8657 GOTO 220
8658 ENDIF
8659 210 CONTINUE
8660 ikffs=nkffs+1
8661 220 IF(ikffs.LT.0) THEN
8662 ikffs=-ikffs
8663 ELSE
8664 IF(nkffs.GE.400) RETURN
8665 DO 240 ip=nkffs,ikffs,-1
8666 kffs(ip+1)=kffs(ip)
8667 DO 230 j=1,4
8668 npfs(ip+1,j)=npfs(ip,j)
8669 230 CONTINUE
8670 240 CONTINUE
8671 nkffs=nkffs+1
8672 kffs(ikffs)=kfa
8673 DO 250 j=1,4
8674 npfs(ikffs,j)=0
8675 250 CONTINUE
8676 ENDIF
8677 npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
8678 260 CONTINUE
8679
8680C...Write statistics on particle/parton composition of events.
8681 ELSEIF(mtabu.EQ.22) THEN
8682 fac=1./max(1,nevfs)
8683 WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
8684 DO 270 i=1,nkffs
8685 CALL luname(kffs(i),chau)
8686 kc=lucomp(kffs(i))
8687 mdcyf=0
8688 IF(kc.NE.0) mdcyf=mdcy(kc,1)
8689 WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
8690 & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
8691 270 CONTINUE
8692
8693C...Copy particle/parton composition information into /LUJETS/.
8694 ELSEIF(mtabu.EQ.23) THEN
8695 fac=1./max(1,nevfs)
8696 DO 290 i=1,nkffs
8697 k(i,1)=32
8698 k(i,2)=99
8699 k(i,3)=kffs(i)
8700 k(i,4)=0
8701 k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
8702 DO 280 j=1,4
8703 p(i,j)=fac*npfs(i,j)
8704 v(i,j)=0.
8705 280 CONTINUE
8706 p(i,5)=fac*k(i,5)
8707 v(i,5)=0.
8708 290 CONTINUE
8709 n=nkffs
8710 DO 300 j=1,5
8711 k(n+1,j)=0
8712 p(n+1,j)=0.
8713 v(n+1,j)=0.
8714 300 CONTINUE
8715 k(n+1,1)=32
8716 k(n+1,2)=99
8717 k(n+1,5)=nevfs
8718 p(n+1,1)=fac*nprfs
8719 p(n+1,2)=fac*nfifs
8720 p(n+1,3)=fac*nchfs
8721 mstu(3)=1
8722
8723C...Reset factorial moments statistics.
8724 ELSEIF(mtabu.EQ.30) THEN
8725 nevfm=0
8726 nmufm=0
8727 DO 330 im=1,3
8728 DO 320 ib=1,10
8729 DO 310 ip=1,4
8730 fm1fm(im,ib,ip)=0.
8731 fm2fm(im,ib,ip)=0.
8732 310 CONTINUE
8733 320 CONTINUE
8734 330 CONTINUE
8735
8736C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
8737 ELSEIF(mtabu.EQ.31) THEN
8738 nevfm=nevfm+1
8739 nlow=n+mstu(3)
8740 nupp=nlow
8741 DO 410 i=1,n
8742 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 410
8743 IF(mstu(41).GE.2) THEN
8744 kc=lucomp(k(i,2))
8745 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8746 & kc.EQ.18) GOTO 410
8747 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8748 & GOTO 410
8749 ENDIF
8750 pmr=0.
8751 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
8752 IF(mstu(42).GE.2) pmr=p(i,5)
8753 pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
8754 yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
8755 & 1e20)),p(i,3))
8756 IF(abs(yeta).GT.paru(57)) GOTO 410
8757 phi=ulangl(p(i,1),p(i,2))
8758 iyeta=512.*(yeta+paru(57))/(2.*paru(57))
8759 iyeta=max(0,min(511,iyeta))
8760 iphi=512.*(phi+paru(1))/paru(2)
8761 iphi=max(0,min(511,iphi))
8762 iyep=0
8763 DO 340 ib=0,9
8764 iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
8765 340 CONTINUE
8766
8767C...Order particles in (pseudo)rapidity and/or azimuth.
8768 IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
8769 CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
8770 RETURN
8771 ENDIF
8772 nupp=nupp+1
8773 IF(nupp.EQ.nlow+1) THEN
8774 k(nupp,1)=iyeta
8775 k(nupp,2)=iphi
8776 k(nupp,3)=iyep
8777 ELSE
8778 DO 350 i1=nupp-1,nlow+1,-1
8779 IF(iyeta.GE.k(i1,1)) GOTO 360
8780 k(i1+1,1)=k(i1,1)
8781 350 CONTINUE
8782 360 k(i1+1,1)=iyeta
8783 DO 370 i1=nupp-1,nlow+1,-1
8784 IF(iphi.GE.k(i1,2)) GOTO 380
8785 k(i1+1,2)=k(i1,2)
8786 370 CONTINUE
8787 380 k(i1+1,2)=iphi
8788 DO 390 i1=nupp-1,nlow+1,-1
8789 IF(iyep.GE.k(i1,3)) GOTO 400
8790 k(i1+1,3)=k(i1,3)
8791 390 CONTINUE
8792 400 k(i1+1,3)=iyep
8793 ENDIF
8794 410 CONTINUE
8795 k(nupp+1,1)=2**10
8796 k(nupp+1,2)=2**10
8797 k(nupp+1,3)=4**10
8798
8799C...Calculate sum of factorial moments in event.
8800 DO 480 im=1,3
8801 DO 430 ib=1,10
8802 DO 420 ip=1,4
8803 fevfm(ib,ip)=0.
8804 420 CONTINUE
8805 430 CONTINUE
8806 DO 450 ib=1,10
8807 IF(im.LE.2) ibin=2**(10-ib)
8808 IF(im.EQ.3) ibin=4**(10-ib)
8809 iagr=k(nlow+1,im)/ibin
8810 nagr=1
8811 DO 440 i=nlow+2,nupp+1
8812 icut=k(i,im)/ibin
8813 IF(icut.EQ.iagr) THEN
8814 nagr=nagr+1
8815 ELSE
8816 IF(nagr.EQ.1) THEN
8817 ELSEIF(nagr.EQ.2) THEN
8818 fevfm(ib,1)=fevfm(ib,1)+2.
8819 ELSEIF(nagr.EQ.3) THEN
8820 fevfm(ib,1)=fevfm(ib,1)+6.
8821 fevfm(ib,2)=fevfm(ib,2)+6.
8822 ELSEIF(nagr.EQ.4) THEN
8823 fevfm(ib,1)=fevfm(ib,1)+12.
8824 fevfm(ib,2)=fevfm(ib,2)+24.
8825 fevfm(ib,3)=fevfm(ib,3)+24.
8826 ELSE
8827 fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1.)
8828 fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1.)*(nagr-2.)
8829 fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)
8830 fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)*
8831 & (nagr-4.)
8832 ENDIF
8833 iagr=icut
8834 nagr=1
8835 ENDIF
8836 440 CONTINUE
8837 450 CONTINUE
8838
8839C...Add results to total statistics.
8840 DO 470 ib=10,1,-1
8841 DO 460 ip=1,4
8842 IF(fevfm(1,ip).LT.0.5) THEN
8843 fevfm(ib,ip)=0.
8844 ELSEIF(im.LE.2) THEN
8845 fevfm(ib,ip)=2.**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
8846 ELSE
8847 fevfm(ib,ip)=4.**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
8848 ENDIF
8849 fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
8850 fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
8851 460 CONTINUE
8852 470 CONTINUE
8853 480 CONTINUE
8854 nmufm=nmufm+(nupp-nlow)
8855 mstu(62)=nupp-nlow
8856
8857C...Write accumulated statistics on factorial moments.
8858 ELSEIF(mtabu.EQ.32) THEN
8859 fac=1./max(1,nevfm)
8860 IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'
8861 IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'
8862 IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y '
8863 DO 510 im=1,3
8864 WRITE(mstu(11),5500)
8865 DO 500 ib=1,10
8866 byeta=2.*paru(57)
8867 IF(im.NE.2) byeta=byeta/2**(ib-1)
8868 bphi=paru(2)
8869 IF(im.NE.1) bphi=bphi/2**(ib-1)
8870 IF(im.LE.2) bnave=fac*nmufm/float(2**(ib-1))
8871 IF(im.EQ.3) bnave=fac*nmufm/float(4**(ib-1))
8872 DO 490 ip=1,4
8873 fmoma(ip)=fac*fm1fm(im,ib,ip)
8874 fmoms(ip)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-fmoma(ip)**2)))
8875 490 CONTINUE
8876 WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
8877 & ip=1,4)
8878 500 CONTINUE
8879 510 CONTINUE
8880
8881C...Copy statistics on factorial moments into /LUJETS/.
8882 ELSEIF(mtabu.EQ.33) THEN
8883 fac=1./max(1,nevfm)
8884 DO 540 im=1,3
8885 DO 530 ib=1,10
8886 i=10*(im-1)+ib
8887 k(i,1)=32
8888 k(i,2)=99
8889 k(i,3)=1
8890 IF(im.NE.2) k(i,3)=2**(ib-1)
8891 k(i,4)=1
8892 IF(im.NE.1) k(i,4)=2**(ib-1)
8893 k(i,5)=0
8894 p(i,1)=2.*paru(57)/k(i,3)
8895 v(i,1)=paru(2)/k(i,4)
8896 DO 520 ip=1,4
8897 p(i,ip+1)=fac*fm1fm(im,ib,ip)
8898 v(i,ip+1)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-p(i,ip+1)**2)))
8899 520 CONTINUE
8900 530 CONTINUE
8901 540 CONTINUE
8902 n=30
8903 DO 550 j=1,5
8904 k(n+1,j)=0
8905 p(n+1,j)=0.
8906 v(n+1,j)=0.
8907 550 CONTINUE
8908 k(n+1,1)=32
8909 k(n+1,2)=99
8910 k(n+1,5)=nevfm
8911 mstu(3)=1
8912
8913C...Reset statistics on Energy-Energy Correlation.
8914 ELSEIF(mtabu.EQ.40) THEN
8915 nevee=0
8916 DO 560 j=1,25
8917 fe1ec(j)=0.
8918 fe2ec(j)=0.
8919 fe1ec(51-j)=0.
8920 fe2ec(51-j)=0.
8921 fe1ea(j)=0.
8922 fe2ea(j)=0.
8923 560 CONTINUE
8924
8925C...Find particles to include, with proper assumed mass.
8926 ELSEIF(mtabu.EQ.41) THEN
8927 nevee=nevee+1
8928 nlow=n+mstu(3)
8929 nupp=nlow
8930 ecm=0.
8931 DO 570 i=1,n
8932 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 570
8933 IF(mstu(41).GE.2) THEN
8934 kc=lucomp(k(i,2))
8935 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
8936 & kc.EQ.18) GOTO 570
8937 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
8938 & GOTO 570
8939 ENDIF
8940 pmr=0.
8941 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
8942 IF(mstu(42).GE.2) pmr=p(i,5)
8943 IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
8944 CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
8945 RETURN
8946 ENDIF
8947 nupp=nupp+1
8948 p(nupp,1)=p(i,1)
8949 p(nupp,2)=p(i,2)
8950 p(nupp,3)=p(i,3)
8951 p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
8952 p(nupp,5)=max(1e-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
8953 ecm=ecm+p(nupp,4)
8954 570 CONTINUE
8955 IF(nupp.EQ.nlow) RETURN
8956
8957C...Analyze Energy-Energy Correlation in event.
8958 fac=(2./ecm**2)*50./paru(1)
8959 DO 580 j=1,50
8960 fevee(j)=0.
8961 580 CONTINUE
8962 DO 600 i1=nlow+2,nupp
8963 DO 590 i2=nlow+1,i1-1
8964 cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
8965 & (p(i1,5)*p(i2,5))
8966 the=acos(max(-1.,min(1.,cthe)))
8967 ithe=max(1,min(50,1+int(50.*the/paru(1))))
8968 fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
8969 590 CONTINUE
8970 600 CONTINUE
8971 DO 610 j=1,25
8972 fe1ec(j)=fe1ec(j)+fevee(j)
8973 fe2ec(j)=fe2ec(j)+fevee(j)**2
8974 fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
8975 fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
8976 fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
8977 fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
8978 610 CONTINUE
8979 mstu(62)=nupp-nlow
8980
8981C...Write statistics on Energy-Energy Correlation.
8982 ELSEIF(mtabu.EQ.42) THEN
8983 fac=1./max(1,nevee)
8984 WRITE(mstu(11),5700) nevee
8985 DO 620 j=1,25
8986 feec1=fac*fe1ec(j)
8987 fees1=sqrt(max(0.,fac*(fac*fe2ec(j)-feec1**2)))
8988 feec2=fac*fe1ec(51-j)
8989 fees2=sqrt(max(0.,fac*(fac*fe2ec(51-j)-feec2**2)))
8990 feeca=fac*fe1ea(j)
8991 feesa=sqrt(max(0.,fac*(fac*fe2ea(j)-feeca**2)))
8992 WRITE(mstu(11),5800) 3.6*(j-1),3.6*j,feec1,fees1,feec2,fees2,
8993 & feeca,feesa
8994 620 CONTINUE
8995
8996C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
8997 ELSEIF(mtabu.EQ.43) THEN
8998 fac=1./max(1,nevee)
8999 DO 630 i=1,25
9000 k(i,1)=32
9001 k(i,2)=99
9002 k(i,3)=0
9003 k(i,4)=0
9004 k(i,5)=0
9005 p(i,1)=fac*fe1ec(i)
9006 v(i,1)=sqrt(max(0.,fac*(fac*fe2ec(i)-p(i,1)**2)))
9007 p(i,2)=fac*fe1ec(51-i)
9008 v(i,2)=sqrt(max(0.,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
9009 p(i,3)=fac*fe1ea(i)
9010 v(i,3)=sqrt(max(0.,fac*(fac*fe2ea(i)-p(i,3)**2)))
9011 p(i,4)=paru(1)*(i-1)/50.
9012 p(i,5)=paru(1)*i/50.
9013 v(i,4)=3.6*(i-1)
9014 v(i,5)=3.6*i
9015 630 CONTINUE
9016 n=25
9017 DO 640 j=1,5
9018 k(n+1,j)=0
9019 p(n+1,j)=0.
9020 v(n+1,j)=0.
9021 640 CONTINUE
9022 k(n+1,1)=32
9023 k(n+1,2)=99
9024 k(n+1,5)=nevee
9025 mstu(3)=1
9026
9027C...Reset statistics on decay channels.
9028 ELSEIF(mtabu.EQ.50) THEN
9029 nevdc=0
9030 nkfdc=0
9031 nredc=0
9032
9033C...Identify and order flavour content of final state.
9034 ELSEIF(mtabu.EQ.51) THEN
9035 nevdc=nevdc+1
9036 nds=0
9037 DO 670 i=1,n
9038 IF(k(i,1).LE.0.OR.k(i,1).GE.6) GOTO 670
9039 nds=nds+1
9040 IF(nds.GT.8) THEN
9041 nredc=nredc+1
9042 RETURN
9043 ENDIF
9044 kfm=2*iabs(k(i,2))
9045 IF(k(i,2).LT.0) kfm=kfm-1
9046 DO 650 ids=nds-1,1,-1
9047 iin=ids+1
9048 IF(kfm.LT.kfdm(ids)) GOTO 660
9049 kfdm(ids+1)=kfdm(ids)
9050 650 CONTINUE
9051 iin=1
9052 660 kfdm(iin)=kfm
9053 670 CONTINUE
9054
9055C...Find whether old or new final state.
9056 DO 690 idc=1,nkfdc
9057 IF(nds.LT.kfdc(idc,0)) THEN
9058 ikfdc=idc
9059 GOTO 700
9060 ELSEIF(nds.EQ.kfdc(idc,0)) THEN
9061 DO 680 i=1,nds
9062 IF(kfdm(i).LT.kfdc(idc,i)) THEN
9063 ikfdc=idc
9064 GOTO 700
9065 ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
9066 GOTO 690
9067 ENDIF
9068 680 CONTINUE
9069 ikfdc=-idc
9070 GOTO 700
9071 ENDIF
9072 690 CONTINUE
9073 ikfdc=nkfdc+1
9074 700 IF(ikfdc.LT.0) THEN
9075 ikfdc=-ikfdc
9076 ELSEIF(nkfdc.GE.200) THEN
9077 nredc=nredc+1
9078 RETURN
9079 ELSE
9080 DO 720 idc=nkfdc,ikfdc,-1
9081 npdc(idc+1)=npdc(idc)
9082 DO 710 i=0,8
9083 kfdc(idc+1,i)=kfdc(idc,i)
9084 710 CONTINUE
9085 720 CONTINUE
9086 nkfdc=nkfdc+1
9087 kfdc(ikfdc,0)=nds
9088 DO 730 i=1,nds
9089 kfdc(ikfdc,i)=kfdm(i)
9090 730 CONTINUE
9091 npdc(ikfdc)=0
9092 ENDIF
9093 npdc(ikfdc)=npdc(ikfdc)+1
9094
9095C...Write statistics on decay channels.
9096 ELSEIF(mtabu.EQ.52) THEN
9097 fac=1./max(1,nevdc)
9098 WRITE(mstu(11),5900) nevdc
9099 DO 750 idc=1,nkfdc
9100 DO 740 i=1,kfdc(idc,0)
9101 kfm=kfdc(idc,i)
9102 kf=(kfm+1)/2
9103 IF(2*kf.NE.kfm) kf=-kf
9104 CALL luname(kf,chau)
9105 chdc(i)=chau(1:12)
9106 IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
9107 740 CONTINUE
9108 WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
9109 750 CONTINUE
9110 IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc
9111
9112C...Copy statistics on decay channels into /LUJETS/.
9113 ELSEIF(mtabu.EQ.53) THEN
9114 fac=1./max(1,nevdc)
9115 DO 780 idc=1,nkfdc
9116 k(idc,1)=32
9117 k(idc,2)=99
9118 k(idc,3)=0
9119 k(idc,4)=0
9120 k(idc,5)=kfdc(idc,0)
9121 DO 760 j=1,5
9122 p(idc,j)=0.
9123 v(idc,j)=0.
9124 760 CONTINUE
9125 DO 770 i=1,kfdc(idc,0)
9126 kfm=kfdc(idc,i)
9127 kf=(kfm+1)/2
9128 IF(2*kf.NE.kfm) kf=-kf
9129 IF(i.LE.5) p(idc,i)=kf
9130 IF(i.GE.6) v(idc,i-5)=kf
9131 770 CONTINUE
9132 v(idc,5)=fac*npdc(idc)
9133 780 CONTINUE
9134 n=nkfdc
9135 DO 790 j=1,5
9136 k(n+1,j)=0
9137 p(n+1,j)=0.
9138 v(n+1,j)=0.
9139 790 CONTINUE
9140 k(n+1,1)=32
9141 k(n+1,2)=99
9142 k(n+1,5)=nevdc
9143 v(n+1,5)=fac*nredc
9144 mstu(3)=1
9145 ENDIF
9146
9147C...Format statements for output on unit MSTU(11) (default 6).
9148 5000 FORMAT(///20x,'Event statistics - initial state'/
9149 &20x,'based on an analysis of ',i6,' events'//
9150 &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
9151 &'according to fragmenting system multiplicity'/
9152 &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
9153 &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
9154 5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
9155 5200 FORMAT(///20x,'Event statistics - final state'/
9156 &20x,'based on an analysis of ',i7,' events'//
9157 &5x,'Mean primary multiplicity =',f10.4/
9158 &5x,'Mean final multiplicity =',f10.4/
9159 &5x,'Mean charged multiplicity =',f10.4//
9160 &5x,'Number of particles produced per event (directly and via ',
9161 &'decays/branchings)'/
9162 &5x,'KF Particle/jet MDCY',10x,'Particles',13x,'Antiparticles',
9163 &8x,'Total'/35x,'prim seco prim seco'/)
9164 5300 FORMAT(1x,i6,4x,a16,i2,5(1x,f11.6))
9165 5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
9166 &20x,'based on an analysis of ',i6,' events'//
9167 &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
9168 &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
9169 5500 FORMAT(10x)
9170 5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
9171 5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
9172 &20x,'based on an analysis of ',i6,' events'//
9173 &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
9174 &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
9175 5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
9176 5900 FORMAT(///20x,'Decay channel analysis - final state'/
9177 &20x,'based on an analysis of ',i6,' events'//
9178 &2x,'Probability',10x,'Complete final state'/)
9179 6000 FORMAT(2x,f9.5,5x,8(a12,1x))
9180 6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
9181 &'or table overflow)')
9182
9183 RETURN
9184 END
9185
9186C*********************************************************************
9187
9188 SUBROUTINE lueevt(KFL,ECM)
9189
9190C...Purpose: to handle the generation of an e+e- annihilation jet event.
9191 IMPLICIT DOUBLE PRECISION(d)
9192 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
9193 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9194 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9195 SAVE /lujets/,/ludat1/,/ludat2/
9196
9197C...Check input parameters.
9198 IF(mstu(12).GE.1) CALL lulist(0)
9199 IF(kfl.LT.0.OR.kfl.GT.8) THEN
9200 CALL luerrm(16,'(LUEEVT:) called with unknown flavour code')
9201 IF(mstu(21).GE.1) RETURN
9202 ENDIF
9203 IF(kfl.LE.5) ecmmin=parj(127)+2.02*parf(100+max(1,kfl))
9204 IF(kfl.GE.6) ecmmin=parj(127)+2.02*pmas(kfl,1)
9205 IF(ecm.LT.ecmmin) THEN
9206 CALL luerrm(16,'(LUEEVT:) called with too small CM energy')
9207 IF(mstu(21).GE.1) RETURN
9208 ENDIF
9209
9210C...Check consistency of MSTJ options set.
9211 IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
9212 CALL luerrm(6,
9213 & '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
9214 mstj(110)=1
9215 ENDIF
9216 IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
9217 CALL luerrm(6,
9218 & '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
9219 mstj(111)=0
9220 ENDIF
9221
9222C...Initialize alpha_strong and total cross-section.
9223 mstu(111)=mstj(108)
9224 IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
9225 &mstu(111)=1
9226 paru(112)=parj(121)
9227 IF(mstu(111).EQ.2) paru(112)=parj(122)
9228 IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
9229 &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL luxtot(kfl,ecm,
9230 &xtot)
9231 IF(mstj(116).GE.3) mstj(116)=1
9232 parj(171)=0.
9233
9234C...Add initial e+e- to event record (documentation only).
9235 ntry=0
9236 100 ntry=ntry+1
9237 IF(ntry.GT.100) THEN
9238 CALL luerrm(14,'(LUEEVT:) caught in an infinite loop')
9239 RETURN
9240 ENDIF
9241 mstu(24)=0
9242 nc=0
9243 IF(mstj(115).GE.2) THEN
9244 nc=nc+2
9245 CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
9246 k(nc-1,1)=21
9247 CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
9248 k(nc,1)=21
9249 ENDIF
9250
9251C...Radiative photon (in initial state).
9252 mk=0
9253 ecmc=ecm
9254 IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL luradk(ecm,mk,pak,
9255 &thek,phik,alpk)
9256 IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2.*pak))
9257 IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
9258 nc=nc+1
9259 CALL lu1ent(nc,22,pak,thek,phik)
9260 k(nc,3)=min(mstj(115)/2,1)
9261 ENDIF
9262
9263C...Virtual exchange boson (gamma or Z0).
9264 IF(mstj(115).GE.3) THEN
9265 nc=nc+1
9266 kf=22
9267 IF(mstj(102).EQ.2) kf=23
9268 mstu10=mstu(10)
9269 mstu(10)=1
9270 p(nc,5)=ecmc
9271 CALL lu1ent(nc,kf,ecmc,0.,0.)
9272 k(nc,1)=21
9273 k(nc,3)=1
9274 mstu(10)=mstu10
9275 ENDIF
9276
9277C...Choice of flavour and jet configuration.
9278 CALL luxkfl(kfl,ecm,ecmc,kflc)
9279 IF(kflc.EQ.0) GOTO 100
9280 CALL luxjet(ecmc,njet,cut)
9281 kfln=21
9282 IF(njet.EQ.4) CALL lux4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
9283 &x12,x14)
9284 IF(njet.EQ.3) CALL lux3jt(njet,cut,kflc,ecmc,x1,x3)
9285 IF(njet.EQ.2) mstj(120)=1
9286
9287C...Fill jet configuration and origin.
9288 IF(njet.EQ.2.AND.mstj(101).NE.5) CALL lu2ent(nc+1,kflc,-kflc,ecmc)
9289 IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL lu2ent(-(nc+1),kflc,-kflc,
9290 &ecmc)
9291 IF(njet.EQ.3) CALL lu3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
9292 IF(njet.EQ.4.AND.kfln.EQ.21) CALL lu4ent(nc+1,kflc,kfln,kfln,
9293 &-kflc,ecmc,x1,x2,x4,x12,x14)
9294 IF(njet.EQ.4.AND.kfln.NE.21) CALL lu4ent(nc+1,kflc,-kfln,kfln,
9295 &-kflc,ecmc,x1,x2,x4,x12,x14)
9296 IF(mstu(24).NE.0) GOTO 100
9297 DO 110 ip=nc+1,n
9298 k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
9299 110 CONTINUE
9300
9301C...Angular orientation according to matrix element.
9302 IF(mstj(106).EQ.1) THEN
9303 CALL luxdif(nc,njet,kflc,ecmc,chi,the,phi)
9304 CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
9305 CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
9306 ENDIF
9307
9308C...Rotation and boost from radiative photon.
9309 IF(mk.EQ.1) THEN
9310 dbek=-pak/(ecm-pak)
9311 nmin=nc+1-mstj(115)/3
9312 CALL ludbrb(nmin,n,0.,-phik,0d0,0d0,0d0)
9313 CALL ludbrb(nmin,n,alpk,0.,dbek*sin(thek),0d0,dbek*cos(thek))
9314 CALL ludbrb(nmin,n,0.,phik,0d0,0d0,0d0)
9315 ENDIF
9316
9317C...Generate parton shower. Rearrange along strings and check.
9318 IF(mstj(101).EQ.5) THEN
9319 CALL lushow(n-1,n,ecmc)
9320 mstj14=mstj(14)
9321 IF(mstj(105).EQ.-1) mstj(14)=-1
9322 IF(mstj(105).GE.0) mstu(28)=0
9323 CALL luprep(0)
9324 mstj(14)=mstj14
9325 IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
9326 ENDIF
9327
9328C...Fragmentation/decay generation. Information for LUTABU.
9329 IF(mstj(105).EQ.1) CALL luexec
9330 mstu(161)=kflc
9331 mstu(162)=-kflc
9332
9333 RETURN
9334 END
9335
9336C*********************************************************************
9337
9338 SUBROUTINE luxtot(KFL,ECM,XTOT)
9339
9340C...Purpose: to calculate total cross-section, including initial
9341C...state radiation effects.
9342 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9343 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9344 SAVE /ludat1/,/ludat2/
9345
9346C...Status, (optimized) Q^2 scale, alpha_strong.
9347 parj(151)=ecm
9348 mstj(119)=10*mstj(102)+kfl
9349 IF(mstj(111).EQ.0) THEN
9350 q2r=ecm**2
9351 ELSEIF(mstu(111).EQ.0) THEN
9352 parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
9353 & ((33.-2.*mstu(112))*paru(111)))))
9354 q2r=parj(168)*ecm**2
9355 ELSE
9356 parj(168)=min(1.,max(parj(128),paru(112)/ecm,
9357 & (2.*paru(112)/ecm)**2))
9358 q2r=parj(168)*ecm**2
9359 ENDIF
9360 alspi=ulalps(q2r)/paru(1)
9361
9362C...QCD corrections factor in R.
9363 IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
9364 rqcd=1.
9365 ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
9366 rqcd=1.+alspi
9367 ELSEIF(mstj(109).EQ.0) THEN
9368 rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
9369 IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
9370 & log(parj(168))*alspi**2)
9371 ELSEIF(iabs(mstj(101)).EQ.1) THEN
9372 rqcd=1.+(3./4.)*alspi
9373 ELSE
9374 rqcd=1.+(3./4.)*alspi-(3./32.+0.519*mstu(118))*alspi**2
9375 ENDIF
9376
9377C...Calculate Z0 width if default value not acceptable.
9378 IF(mstj(102).GE.3) THEN
9379 rva=3.*(3.+(4.*paru(102)-1.)**2)+6.*rqcd*(2.+(1.-8.*paru(102)/
9380 & 3.)**2+(4.*paru(102)/3.-1.)**2)
9381 DO 100 kflc=5,6
9382 vq=1.
9383 IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*ulmass(kflc)/
9384 & ecm)**2))
9385 IF(kflc.EQ.5) vf=4.*paru(102)/3.-1.
9386 IF(kflc.EQ.6) vf=1.-8.*paru(102)/3.
9387 rva=rva+3.*rqcd*(0.5*vq*(3.-vq**2)*vf**2+vq**3)
9388 100 CONTINUE
9389 parj(124)=paru(101)*parj(123)*rva/(48.*paru(102)*(1.-paru(102)))
9390 ENDIF
9391
9392C...Calculate propagator and related constants for QFD case.
9393 poll=1.-parj(131)*parj(132)
9394 IF(mstj(102).GE.2) THEN
9395 sff=1./(16.*paru(102)*(1.-paru(102)))
9396 sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
9397 sfi=sfw*(1.-(parj(123)/ecm)**2)
9398 ve=4.*paru(102)-1.
9399 sf1i=sff*(ve*poll+parj(132)-parj(131))
9400 sf1w=sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
9401 hf1i=sfi*sf1i
9402 hf1w=sfw*sf1w
9403 ENDIF
9404
9405C...Loop over different flavours: charge, velocity.
9406 rtot=0.
9407 rqq=0.
9408 rqv=0.
9409 rva=0.
9410 DO 110 kflc=1,max(mstj(104),kfl)
9411 IF(kfl.GT.0.AND.kflc.NE.kfl) GOTO 110
9412 mstj(93)=1
9413 pmq=ulmass(kflc)
9414 IF(ecm.LT.2.*pmq+parj(127)) GOTO 110
9415 qf=kchg(kflc,1)/3.
9416 vq=1.
9417 IF(mod(mstj(103),2).EQ.1) vq=sqrt(1.-(2.*pmq/ecm)**2)
9418
9419C...Calculate R and sum of charges for QED or QFD case.
9420 rqq=rqq+3.*qf**2*poll
9421 IF(mstj(102).LE.1) THEN
9422 rtot=rtot+3.*0.5*vq*(3.-vq**2)*qf**2*poll
9423 ELSE
9424 vf=sign(1.,qf)-4.*qf*paru(102)
9425 rqv=rqv-6.*qf*vf*sf1i
9426 rva=rva+3.*(vf**2+1.)*sf1w
9427 rtot=rtot+3.*(0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+
9428 & vf**2*hf1w)+vq**3*hf1w)
9429 ENDIF
9430 110 CONTINUE
9431 rsum=rqq
9432 IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
9433
9434C...Calculate cross-section, including QCD corrections.
9435 parj(141)=rqq
9436 parj(142)=rtot
9437 parj(143)=rtot*rqcd
9438 parj(144)=parj(143)
9439 parj(145)=parj(141)*86.8/ecm**2
9440 parj(146)=parj(142)*86.8/ecm**2
9441 parj(147)=parj(143)*86.8/ecm**2
9442 parj(148)=parj(147)
9443 parj(157)=rsum*rqcd
9444 parj(158)=0.
9445 parj(159)=0.
9446 xtot=parj(147)
9447 IF(mstj(107).LE.0) RETURN
9448
9449C...Virtual cross-section.
9450 xkl=parj(135)
9451 xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
9452 ale=2.*log(ecm/ulmass(11))-1.
9453 sigv=ale/3.+2.*log(ecm**2/(ulmass(13)*ulmass(15)))/3.-4./3.+
9454 &1.526*log(ecm**2/0.932)
9455
9456C...Soft and hard radiative cross-section in QED case.
9457 IF(mstj(102).LE.1) THEN
9458 sigv=1.5*ale-0.5+paru(1)**2/3.+2.*sigv
9459 sigs=ale*(2.*log(xkl)-log(1.-xkl)-xkl)
9460 sigh=ale*(2.*log(xku/xkl)-log((1.-xku)/(1.-xkl))-(xku-xkl))
9461
9462C...Soft and hard radiative cross-section in QFD case.
9463 ELSE
9464 szm=1.-(parj(123)/ecm)**2
9465 szw=parj(123)*parj(124)/ecm**2
9466 parj(161)=-rqq/rsum
9467 parj(162)=-(rqq+rqv+rva)/rsum
9468 parj(163)=(rqv*(1.-0.5*szm-sfi)+rva*(1.5-szm-sfw))/rsum
9469 parj(164)=(rqv*szw**2*(1.-2.*sfw)+rva*(2.*sfi+szw**2-4.+3.*szm-
9470 & szm**2))/(szw*rsum)
9471 sigv=1.5*ale-0.5+paru(1)**2/3.+((2.*rqq+sfi*rqv)/rsum)*sigv+
9472 & (szw*sfw*rqv/rsum)*paru(1)*20./9.
9473 sigs=ale*(2.*log(xkl)+parj(161)*log(1.-xkl)+parj(162)*xkl+
9474 & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
9475 & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
9476 sigh=ale*(2.*log(xku/xkl)+parj(161)*log((1.-xku)/(1.-xkl))+
9477 & parj(162)*(xku-xkl)+parj(163)*log(((xku-szm)**2+szw**2)/
9478 & ((xkl-szm)**2+szw**2))+parj(164)*(atan((xku-szm)/szw)-
9479 & atan((xkl-szm)/szw)))
9480 ENDIF
9481
9482C...Total cross-section and fraction of hard photon events.
9483 parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
9484 parj(157)=rsum*(1.+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
9485 parj(144)=parj(157)
9486 parj(148)=parj(144)*86.8/ecm**2
9487 xtot=parj(148)
9488
9489 RETURN
9490 END
9491
9492C*********************************************************************
9493
9494 SUBROUTINE luradk(ECM,MK,PAK,THEK,PHIK,ALPK)
9495
9496C...Purpose: to generate initial state photon radiation.
9497 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9498 SAVE /ludat1/
9499
9500C...Function: cumulative hard photon spectrum in QFD case.
9501 fxk(xx)=2.*log(xx)+parj(161)*log(1.-xx)+parj(162)*xx+
9502 &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
9503
9504C...Determine whether radiative photon or not.
9505 mk=0
9506 pak=0.
9507 IF(parj(160).LT.rlu(0)) RETURN
9508 mk=1
9509
9510C...Photon energy range. Find photon momentum in QED case.
9511 xkl=parj(135)
9512 xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
9513 IF(mstj(102).LE.1) THEN
9514 100 xk=1./(1.+(1./xkl-1.)*((1./xku-1.)/(1./xkl-1.))**rlu(0))
9515 IF(1.+(1.-xk)**2.LT.2.*rlu(0)) GOTO 100
9516
9517C...Ditto in QFD case, by numerical inversion of integrated spectrum.
9518 ELSE
9519 szm=1.-(parj(123)/ecm)**2
9520 szw=parj(123)*parj(124)/ecm**2
9521 fxkl=fxk(xkl)
9522 fxku=fxk(xku)
9523 fxkd=1e-4*(fxku-fxkl)
9524 fxkr=fxkl+rlu(0)*(fxku-fxkl)
9525 nxk=0
9526 110 nxk=nxk+1
9527 xk=0.5*(xkl+xku)
9528 fxkv=fxk(xk)
9529 IF(fxkv.GT.fxkr) THEN
9530 xku=xk
9531 fxku=fxkv
9532 ELSE
9533 xkl=xk
9534 fxkl=fxkv
9535 ENDIF
9536 IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) GOTO 110
9537 xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
9538 ENDIF
9539 pak=0.5*ecm*xk
9540
9541C...Photon polar and azimuthal angle.
9542 pme=2.*(ulmass(11)/ecm)**2
9543 120 cthm=pme*(2./pme)**rlu(0)
9544 IF(1.-(xk**2*cthm*(1.-0.5*cthm)+2.*(1.-xk)*pme/max(pme,
9545 &cthm*(1.-0.5*cthm)))/(1.+(1.-xk)**2).LT.rlu(0)) GOTO 120
9546 cthe=1.-cthm
9547 IF(rlu(0).GT.0.5) cthe=-cthe
9548 sthe=sqrt(max(0.,(cthm-pme)*(2.-cthm)))
9549 thek=ulangl(cthe,sthe)
9550 phik=paru(2)*rlu(0)
9551
9552C...Rotation angle for hadronic system.
9553 sgn=1.
9554 IF(0.5*(2.-xk*(1.-cthe))**2/((2.-xk)**2+(xk*cthe)**2).GT.
9555 &rlu(0)) sgn=-1.
9556 alpk=asin(sgn*sthe*(xk-sgn*(2.*sqrt(1.-xk)-2.+xk)*cthe)/
9557 &(2.-xk*(1.-sgn*cthe)))
9558
9559 RETURN
9560 END
9561
9562C*********************************************************************
9563
9564 SUBROUTINE luxkfl(KFL,ECM,ECMC,KFLC)
9565
9566C...Purpose: to select flavour for produced qqbar pair.
9567 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9568 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9569 SAVE /ludat1/,/ludat2/
9570
9571C...Calculate maximum weight in QED or QFD case.
9572 IF(mstj(102).LE.1) THEN
9573 rfmax=4./9.
9574 ELSE
9575 poll=1.-parj(131)*parj(132)
9576 sff=1./(16.*paru(102)*(1.-paru(102)))
9577 sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
9578 sfi=sfw*(1.-(parj(123)/ecmc)**2)
9579 ve=4.*paru(102)-1.
9580 hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
9581 hf1w=sfw*sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
9582 rfmax=max(4./9.*poll-4./3.*(1.-8.*paru(102)/3.)*hf1i+
9583 & ((1.-8.*paru(102)/3.)**2+1.)*hf1w,1./9.*poll+2./3.*
9584 & (-1.+4.*paru(102)/3.)*hf1i+((-1.+4.*paru(102)/3.)**2+1.)*hf1w)
9585 ENDIF
9586
9587C...Choose flavour. Gives charge and velocity.
9588 ntry=0
9589 100 ntry=ntry+1
9590 IF(ntry.GT.100) THEN
9591 CALL luerrm(14,'(LUXKFL:) caught in an infinite loop')
9592 kflc=0
9593 RETURN
9594 ENDIF
9595 kflc=kfl
9596 IF(kfl.LE.0) kflc=1+int(mstj(104)*rlu(0))
9597 mstj(93)=1
9598 pmq=ulmass(kflc)
9599 IF(ecm.LT.2.*pmq+parj(127)) GOTO 100
9600 qf=kchg(kflc,1)/3.
9601 vq=1.
9602 IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*pmq/ecmc)**2))
9603
9604C...Calculate weight in QED or QFD case.
9605 IF(mstj(102).LE.1) THEN
9606 rf=qf**2
9607 rfv=0.5*vq*(3.-vq**2)*qf**2
9608 ELSE
9609 vf=sign(1.,qf)-4.*qf*paru(102)
9610 rf=qf**2*poll-2.*qf*vf*hf1i+(vf**2+1.)*hf1w
9611 rfv=0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+vf**2*hf1w)+
9612 & vq**3*hf1w
9613 IF(rfv.GT.0.) parj(171)=min(1.,vq**3*hf1w/rfv)
9614 ENDIF
9615
9616C...Weighting or new event (radiative photon). Cross-section update.
9617 IF(kfl.LE.0.AND.rf.LT.rlu(0)*rfmax) GOTO 100
9618 parj(158)=parj(158)+1.
9619 IF(ecmc.LT.2.*pmq+parj(127).OR.rfv.LT.rlu(0)*rf) kflc=0
9620 IF(mstj(107).LE.0.AND.kflc.EQ.0) GOTO 100
9621 IF(kflc.NE.0) parj(159)=parj(159)+1.
9622 parj(144)=parj(157)*parj(159)/parj(158)
9623 parj(148)=parj(144)*86.8/ecm**2
9624
9625 RETURN
9626 END
9627
9628C*********************************************************************
9629
9630 SUBROUTINE luxjet(ECM,NJET,CUT)
9631
9632C...Purpose: to select number of jets in matrix element approach.
9633 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9634 SAVE /ludat1/
9635 dimension zhut(5)
9636
9637C...Relative three-jet rate in Zhu second order parametrization.
9638 DATA zhut/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
9639
9640C...Trivial result for two-jets only, including parton shower.
9641 IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
9642 cut=0.
9643
9644C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
9645 ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
9646 cf=4./3.
9647 IF(mstj(109).EQ.2) cf=1.
9648 IF(mstj(111).EQ.0) THEN
9649 q2=ecm**2
9650 q2r=ecm**2
9651 ELSEIF(mstu(111).EQ.0) THEN
9652 parj(169)=min(1.,parj(129))
9653 q2=parj(169)*ecm**2
9654 parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
9655 & ((33.-2.*mstu(112))*paru(111)))))
9656 q2r=parj(168)*ecm**2
9657 ELSE
9658 parj(169)=min(1.,max(parj(129),(2.*paru(112)/ecm)**2))
9659 q2=parj(169)*ecm**2
9660 parj(168)=min(1.,max(parj(128),paru(112)/ecm,
9661 & (2.*paru(112)/ecm)**2))
9662 q2r=parj(168)*ecm**2
9663 ENDIF
9664
9665C...alpha_strong for R and R itself.
9666 alspi=(3./4.)*cf*ulalps(q2r)/paru(1)
9667 IF(iabs(mstj(101)).EQ.1) THEN
9668 rqcd=1.+alspi
9669 ELSEIF(mstj(109).EQ.0) THEN
9670 rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
9671 IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
9672 & log(parj(168))*alspi**2)
9673 ELSE
9674 rqcd=1.+alspi-(3./32.+0.519*mstu(118))*(4.*alspi/3.)**2
9675 ENDIF
9676
9677C...alpha_strong for jet rate. Initial value for y cut.
9678 alspi=(3./4.)*cf*ulalps(q2)/paru(1)
9679 cut=max(0.001,parj(125),(parj(126)/ecm)**2)
9680 IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
9681 & cut=max(cut,exp(-sqrt(0.75/alspi))/2.)
9682 IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
9683
9684C...Parametrization of first order three-jet cross-section.
9685 100 IF(mstj(101).EQ.0.OR.cut.GE.0.25) THEN
9686 parj(152)=0.
9687 ELSE
9688 parj(152)=(2.*alspi/3.)*((3.-6.*cut+2.*log(cut))*
9689 & log(cut/(1.-2.*cut))+(2.5+1.5*cut-6.571)*(1.-3.*cut)+
9690 & 5.833*(1.-3.*cut)**2-3.894*(1.-3.*cut)**3+
9691 & 1.342*(1.-3.*cut)**4)/rqcd
9692 IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
9693 & parj(152)=0.
9694 ENDIF
9695
9696C...Parametrization of second order three-jet cross-section.
9697 IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
9698 & cut.GE.0.25) THEN
9699 parj(153)=0.
9700 ELSEIF(mstj(110).LE.1) THEN
9701 ct=log(1./cut-2.)
9702 parj(153)=alspi**2*ct**2*(2.419+0.5989*ct+0.6782*ct**2-
9703 & 0.2661*ct**3+0.01159*ct**4)/rqcd
9704
9705C...Interpolation in second/first order ratio for Zhu parametrization.
9706 ELSEIF(mstj(110).EQ.2) THEN
9707 iza=0
9708 DO 110 iy=1,5
9709 IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
9710 110 CONTINUE
9711 IF(iza.NE.0) THEN
9712 zhurat=zhut(iza)
9713 ELSE
9714 iz=100.*cut
9715 zhurat=zhut(iz)+(100.*cut-iz)*(zhut(iz+1)-zhut(iz))
9716 ENDIF
9717 parj(153)=alspi*parj(152)*zhurat
9718 ENDIF
9719
9720C...Shift in second order three-jet cross-section with optimized Q^2.
9721 IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3.
9722 & and.cut.LT.0.25) parj(153)=parj(153)+(33.-2.*mstu(112))/12.*
9723 & log(parj(169))*alspi*parj(152)
9724
9725C...Parametrization of second order four-jet cross-section.
9726 IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125) THEN
9727 parj(154)=0.
9728 ELSE
9729 ct=log(1./cut-5.)
9730 IF(cut.LE.0.018) THEN
9731 xqqgg=6.349-4.330*ct+0.8304*ct**2
9732 IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(3.035-2.091*ct+
9733 & 0.4059*ct**2)
9734 xqqqq=1.25*(-0.1080+0.01486*ct+0.009364*ct**2)
9735 IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
9736 ELSE
9737 xqqgg=-0.09773+0.2959*ct-0.2764*ct**2+0.08832*ct**3
9738 IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(-0.04079+0.1340*ct-
9739 & 0.1326*ct**2+0.04365*ct**3)
9740 xqqqq=1.25*(0.003661-0.004888*ct-0.001081*ct**2+0.002093*
9741 & ct**3)
9742 IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
9743 ENDIF
9744 parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
9745 parj(155)=xqqqq/(xqqgg+xqqqq)
9746 ENDIF
9747
9748C...If negative three-jet rate, change y' optimization parameter.
9749 IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0..AND.
9750 & parj(169).LT.0.99) THEN
9751 parj(169)=min(1.,1.2*parj(169))
9752 q2=parj(169)*ecm**2
9753 alspi=(3./4.)*cf*ulalps(q2)/paru(1)
9754 GOTO 100
9755 ENDIF
9756
9757C...If too high cross-section, use harder cuts, or fail.
9758 IF(parj(152)+parj(153)+parj(154).GE.1) THEN
9759 IF(mstj(110).EQ.2.AND.cut.GT.0.0499.AND.mstj(111).EQ.1.AND.
9760 & parj(169).LT.0.99) THEN
9761 parj(169)=min(1.,1.2*parj(169))
9762 q2=parj(169)*ecm**2
9763 alspi=(3./4.)*cf*ulalps(q2)/paru(1)
9764 GOTO 100
9765 ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499) THEN
9766 CALL luerrm(26,
9767 & '(LUXJET:) no allowed y cut value for Zhu parametrization')
9768 ENDIF
9769 cut=0.26*(4.*cut)**(parj(152)+parj(153)+parj(154))**(-1./3.)
9770 IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
9771 GOTO 100
9772 ENDIF
9773
9774C...Scalar gluon (first order only).
9775 ELSE
9776 alspi=ulalps(ecm**2)/paru(1)
9777 cut=max(0.001,parj(125),(parj(126)/ecm)**2,exp(-3./alspi))
9778 parj(152)=0.
9779 IF(cut.LT.0.25) parj(152)=(alspi/3.)*((1.-2.*cut)*
9780 & log((1.-2.*cut)/cut)+0.5*(9.*cut**2-1.))
9781 parj(153)=0.
9782 parj(154)=0.
9783 ENDIF
9784
9785C...Select number of jets.
9786 parj(150)=cut
9787 IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
9788 njet=2
9789 ELSEIF(mstj(101).LE.0) THEN
9790 njet=min(4,2-mstj(101))
9791 ELSE
9792 rnj=rlu(0)
9793 njet=2
9794 IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
9795 IF(parj(154).GT.rnj) njet=4
9796 ENDIF
9797
9798 RETURN
9799 END
9800
9801C*********************************************************************
9802
9803 SUBROUTINE lux3jt(NJET,CUT,KFL,ECM,X1,X2)
9804
9805C...Purpose: to select the kinematical variables of three-jet events.
9806 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9807 SAVE /ludat1/
9808 dimension zhup(5,12)
9809
9810C...Coefficients of Zhu second order parametrization.
9811 DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
9812 & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90,
9813 & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537,
9814 & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855,
9815 & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095,
9816 & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806,
9817 & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062,
9818 & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19,
9819 & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439,
9820 & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99,
9821 & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/
9822
9823C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
9824 dilog(x)=x+x**2/4.+x**3/9.+x**4/16.+x**5/25.+x**6/36.+x**7/49.
9825
9826C...Event type. Mass effect factors and other common constants.
9827 mstj(120)=2
9828 mstj(121)=0
9829 pmq=ulmass(kfl)
9830 qme=(2.*pmq/ecm)**2
9831 IF(mstj(109).NE.1) THEN
9832 cutl=log(cut)
9833 cutd=log(1./cut-2.)
9834 IF(mstj(109).EQ.0) THEN
9835 cf=4./3.
9836 cn=3.
9837 tr=2.
9838 wtmx=min(20.,37.-6.*cutd)
9839 IF(mstj(110).EQ.2) wtmx=2.*(7.5+80.*cut)
9840 ELSE
9841 cf=1.
9842 cn=0.
9843 tr=12.
9844 wtmx=0.
9845 ENDIF
9846
9847C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
9848 als2pi=paru(118)/paru(2)
9849 wtopt=0.
9850 IF(mstj(111).EQ.1) wtopt=(33.-2.*mstu(112))/6.*log(parj(169))*
9851 & als2pi
9852 wtmax=max(0.,1.+wtopt+als2pi*wtmx)
9853
9854C...Choose three-jet events in allowed region.
9855 100 njet=3
9856 110 y13l=cutl+cutd*rlu(0)
9857 y23l=cutl+cutd*rlu(0)
9858 y13=exp(y13l)
9859 y23=exp(y23l)
9860 y12=1.-y13-y23
9861 IF(y12.LE.cut) GOTO 110
9862 IF(y13**2+y23**2+2.*y12.LE.2.*rlu(0)) GOTO 110
9863
9864C...Second order corrections.
9865 IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
9866 y12l=log(y12)
9867 y13m=log(1.-y13)
9868 y23m=log(1.-y23)
9869 y12m=log(1.-y12)
9870 IF(y13.LE.0.5) y13i=dilog(y13)
9871 IF(y13.GE.0.5) y13i=1.644934-y13l*y13m-dilog(1.-y13)
9872 IF(y23.LE.0.5) y23i=dilog(y23)
9873 IF(y23.GE.0.5) y23i=1.644934-y23l*y23m-dilog(1.-y23)
9874 IF(y12.LE.0.5) y12i=dilog(y12)
9875 IF(y12.GE.0.5) y12i=1.644934-y12l*y12m-dilog(1.-y12)
9876 wt1=(y13**2+y23**2+2.*y12)/(y13*y23)
9877 wt2=cf*(-2.*(cutl-y12l)**2-3.*cutl-1.+3.289868+
9878 & 2.*(2.*cutl-y12l)*cut/y12)+
9879 & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-11.*cutl/6.+
9880 & 67./18.+1.644934-(2.*cutl-y12l)*cut/y12+(2.*cutl-y13l)*
9881 & cut/y13+(2.*cutl-y23l)*cut/y23)+
9882 & tr*(2.*cutl/3.-10./9.)+
9883 & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
9884 & y13l*(4.*y12**2+2.*y12*y13+4.*y12*y23+y13*y23)/(y12+y23)**2+
9885 & y23l*(4.*y12**2+2.*y12*y23+4.*y12*y13+y13*y23)/(y12+y13)**2)/
9886 & wt1+
9887 & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+
9888 & (cn-2.*cf)*((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
9889 & y23m+1.644934-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
9890 & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934-y12i-y13i)/
9891 & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
9892 & 2.*y12l*y12**2/(y13+y23)**2-4.*y12l*y12/(y13+y23))/wt1-
9893 & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934-y13i-y23i)
9894 IF(1.+wtopt+als2pi*wt2.LE.0.) mstj(121)=1
9895 IF(1.+wtopt+als2pi*wt2.LE.wtmax*rlu(0)) GOTO 110
9896 parj(156)=(wtopt+als2pi*wt2)/(1.+wtopt+als2pi*wt2)
9897
9898 ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
9899C...Second order corrections; Zhu parametrization of ERT.
9900 zx=(y23-y13)**2
9901 zy=1.-y12
9902 iza=0
9903 DO 120 iy=1,5
9904 IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
9905 120 CONTINUE
9906 IF(iza.NE.0) THEN
9907 iz=iza
9908 wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
9909 & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
9910 & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
9911 & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
9912 ELSE
9913 iz=100.*cut
9914 wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
9915 & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
9916 & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
9917 & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
9918 iz=iz+1
9919 wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
9920 & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
9921 & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
9922 & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
9923 wt2=wtl+(wtu-wtl)*(100.*cut+1.-iz)
9924 ENDIF
9925 IF(1.+wtopt+2.*als2pi*wt2.LE.0.) mstj(121)=1
9926 IF(1.+wtopt+2.*als2pi*wt2.LE.wtmax*rlu(0)) GOTO 110
9927 parj(156)=(wtopt+2.*als2pi*wt2)/(1.+wtopt+2.*als2pi*wt2)
9928 ENDIF
9929
9930C...Impose mass cuts (gives two jets). For fixed jet number new try.
9931 x1=1.-y23
9932 x2=1.-y13
9933 x3=1.-y12
9934 IF(4.*y23*y13*y12/x3**2.LE.qme) njet=2
9935 IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
9936 & 0.5*qme**2+(0.5*qme+0.25*qme**2)*((1.-x2)/(1.-x1)+
9937 & (1.-x1)/(1.-x2)).GT.(x1**2+x2**2)*rlu(0)) njet=2
9938 IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 100
9939
9940C...Scalar gluon model (first order only, no mass effects).
9941 ELSE
9942 130 njet=3
9943 140 x3=sqrt(4.*cut**2+rlu(0)*((1.-cut)**2-4.*cut**2))
9944 IF(log((x3-cut)/cut).LE.rlu(0)*log((1.-2.*cut)/cut)) GOTO 140
9945 yd=sign(2.*cut*((x3-cut)/cut)**rlu(0)-x3,rlu(0)-0.5)
9946 x1=1.-0.5*(x3+yd)
9947 x2=1.-0.5*(x3-yd)
9948 IF(4.*(1.-x1)*(1.-x2)*(1.-x3)/x3**2.LE.qme) njet=2
9949 IF(mstj(102).GE.2) THEN
9950 IF(x3**2-2.*(1.+x3)*(1.-x1)*(1.-x2)*parj(171).LT.
9951 & x3**2*rlu(0)) njet=2
9952 ENDIF
9953 IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 130
9954 ENDIF
9955
9956 RETURN
9957 END
9958
9959C*********************************************************************
9960
9961 SUBROUTINE lux4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
9962
9963C...Purpose: to select the kinematical variables of four-jet events.
9964 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9965 SAVE /ludat1/
9966 dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
9967
9968C...Common constants. Colour factors for QCD and Abelian gluon theory.
9969 pmq=ulmass(kfl)
9970 qme=(2.*pmq/ecm)**2
9971 ct=log(1./cut-5.)
9972 IF(mstj(109).EQ.0) THEN
9973 cf=4./3.
9974 cn=3.
9975 tr=2.5
9976 ELSE
9977 cf=1.
9978 cn=0.
9979 tr=15.
9980 ENDIF
9981
9982C...Choice of process (qqbargg or qqbarqqbar).
9983 100 njet=4
9984 it=1
9985 IF(parj(155).GT.rlu(0)) it=2
9986 IF(mstj(101).LE.-3) it=-mstj(101)-2
9987 IF(it.EQ.1) wtmx=0.7/cut**2
9988 IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6/cut**2
9989 IF(it.EQ.2) wtmx=0.1125*cf*tr/cut**2
9990 id=1
9991
9992C...Sample the five kinematical variables (for qqgg preweighted in y34).
9993 110 y134=3.*cut+(1.-6.*cut)*rlu(0)
9994 y234=3.*cut+(1.-6.*cut)*rlu(0)
9995 IF(it.EQ.1) y34=(1.-5.*cut)*exp(-ct*rlu(0))
9996 IF(it.EQ.2) y34=cut+(1.-6.*cut)*rlu(0)
9997 IF(y34.LE.y134+y234-1..OR.y34.GE.y134*y234) GOTO 110
9998 vt=rlu(0)
9999 cp=cos(paru(1)*rlu(0))
10000 y14=(y134-y34)*vt
10001 y13=y134-y14-y34
10002 vb=y34*(1.-y134-y234+y34)/((y134-y34)*(y234-y34))
10003 y24=0.5*(y234-y34)*(1.-4.*sqrt(max(0.,vt*(1.-vt)*vb*(1.-vb)))*
10004 &cp-(1.-2.*vt)*(1.-2.*vb))
10005 y23=y234-y34-y24
10006 y12=1.-y134-y23-y24
10007 IF(min(y12,y13,y14,y23,y24).LE.cut) GOTO 110
10008 y123=y12+y13+y23
10009 y124=y12+y14+y24
10010
10011C...Calculate matrix elements for qqgg or qqqq process.
10012 ic=0
10013 wttot=0.
10014 120 ic=ic+1
10015 IF(it.EQ.1) THEN
10016 wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3.*y12*y23*y34+
10017 & 3.*y12*y14*y34+4.*y12**2*y34-y13*y23*y24+2.*y12*y23*y24-
10018 & y13*y14*y24-2.*y12*y13*y24+2.*y12**2*y24+y14*y23**2+2.*y12*
10019 & y23**2+y14**2*y23+4.*y12*y14*y23+4.*y12**2*y23+2.*y12*y14**2+
10020 & 2.*y12*y13*y14+4.*y12**2*y14+2.*y12**2*y13+2.*y12**3)/(2.*y13*
10021 & y134*y234*y24)+(y24*y34+y12*y34+y13*y24-y14*y23+y12*y13)/(y13*
10022 & y134**2)+2.*y23*(1.-y13)/(y13*y134*y24)+y34/(2.*y13*y24)
10023 wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2.*y12*
10024 & y14*y24)/(y13*y134*y23*y14)+y12*(1.+y34)*y124/(y134*y234*y14*
10025 & y24)-(2.*y13*y24+y14**2+y13*y23+2.*y12*y13)/(y13*y134*y14)+
10026 & y12*y123*y124/(2.*y13*y14*y23*y24)
10027 wtc(ic)=-(5.*y12*y34**2+2.*y12*y24*y34+2.*y12*y23*y34+2.*y12*
10028 & y14*y34+2.*y12*y13*y34+4.*y12**2*y34-y13*y24**2+y14*y23*y24+
10029 & y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-3.*y12*y13*y24-
10030 & y14*y23**2-y14**2*y23+y13*y14*y23-3.*y12*y14*y23-y12*y13*y23)/
10031 & (4.*y134*y234*y34**2)+(3.*y12*y34**2-3.*y13*y24*y34+3.*y12*y24*
10032 & y34+3.*y14*y23*y34-y13*y24**2-y12*y23*y34+6.*y12*y14*y34+2.*y12*
10033 & y13*y34-2.*y12**2*y34+y14*y23*y24-3.*y13*y23*y24-2.*y13*y14*
10034 & y24+4.*y12*y14*y24+2.*y12*y13*y24+3.*y14*y23**2+2.*y14**2*y23+
10035 & 2.*y14**2*y12+2.*y12**2*y14+6.*y12*y14*y23-2.*y12*y13**2-
10036 & 2.*y12**2*y13)/(4.*y13*y134*y234*y34)
10037 wtc(ic)=wtc(ic)+(2.*y12*y34**2-2.*y13*y24*y34+y12*y24*y34+
10038 & 4.*y13*y23*y34+4.*y12*y14*y34+2.*y12*y13*y34+2.*y12**2*y34-
10039 & y13*y24**2+3.*y14*y23*y24+4.*y13*y23*y24-2.*y13*y14*y24+
10040 & 4.*y12*y14*y24+2.*y12*y13*y24+2.*y14*y23**2+4.*y13*y23**2+
10041 & 2.*y13*y14*y23+2.*y12*y14*y23+4.*y12*y13*y23+2.*y12*y14**2+4.*
10042 & y12**2*y13+4.*y12*y13*y14+2.*y12**2*y14)/(4.*y13*y134*y24*y34)-
10043 & (y12*y34**2-2.*y14*y24*y34-2.*y13*y24*y34-y14*y23*y34+y13*y23*
10044 & y34+y12*y14*y34+2.*y12*y13*y34-2.*y14**2*y24-4.*y13*y14*y24-
10045 & 4.*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-y12*y13**2)/
10046 & (2.*y13*y34*y134**2)+(y12*y34**2-4.*y14*y24*y34-2.*y13*y24*y34-
10047 & 2.*y14*y23*y34-4.*y13*y23*y34-4.*y12*y14*y34-4.*y12*y13*y34-
10048 & 2.*y13*y14*y24+2.*y13**2*y24+2.*y14**2*y23-2.*y13*y14*y23-
10049 & y12*y14**2-6.*y12*y13*y14-y12*y13**2)/(4.*y34**2*y134**2)
10050 wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5*cn)*wtb(ic)+cn*wtc(ic))/
10051 & 8.
10052 ELSE
10053 wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2.*y12*
10054 & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
10055 & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
10056 & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
10057 & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
10058 & y13*y14*y24+2.*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
10059 & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
10060 & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
10061 & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
10062 wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
10063 & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
10064 & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
10065 & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
10066 & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
10067 & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
10068 & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
10069 & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
10070 wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5*cn)*wte(ic))/16.
10071 ENDIF
10072
10073C...Permutations of momenta in matrix element. Weighting.
10074 130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
10075 ysav=y13
10076 y13=y14
10077 y14=ysav
10078 ysav=y23
10079 y23=y24
10080 y24=ysav
10081 ysav=y123
10082 y123=y124
10083 y124=ysav
10084 ENDIF
10085 IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
10086 ysav=y13
10087 y13=y23
10088 y23=ysav
10089 ysav=y14
10090 y14=y24
10091 y24=ysav
10092 ysav=y134
10093 y134=y234
10094 y234=ysav
10095 ENDIF
10096 IF(ic.LE.3) GOTO 120
10097 IF(id.EQ.1.AND.wttot.LT.rlu(0)*wtmx) GOTO 110
10098 ic=5
10099
10100C...qqgg events: string configuration and event type.
10101 IF(it.EQ.1) THEN
10102 IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
10103 parj(156)=y34*(2.*(wta(1)+wta(2)+wta(3)+wta(4))+4.*(wtc(1)+
10104 & wtc(2)+wtc(3)+wtc(4)))/(9.*wttot)
10105 IF(wta(2)+wta(4)+2.*(wtc(2)+wtc(4)).GT.rlu(0)*(wta(1)+wta(2)+
10106 & wta(3)+wta(4)+2.*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
10107 IF(id.EQ.2) GOTO 130
10108 ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
10109 parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8.*wttot)
10110 IF(wta(2)+wta(4).GT.rlu(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
10111 IF(id.EQ.2) GOTO 130
10112 ENDIF
10113 mstj(120)=3
10114 IF(mstj(109).EQ.0.AND.0.5*y34*(wtc(1)+wtc(2)+wtc(3)+wtc(4)).GT.
10115 & rlu(0)*wttot) mstj(120)=4
10116 kfln=21
10117
10118C...Mass cuts. Kinematical variables out.
10119 IF(y12.LE.cut+qme) njet=2
10120 IF(njet.EQ.2) GOTO 150
10121 q12=0.5*(1.-sqrt(1.-qme/y12))
10122 x1=1.-(1.-q12)*y234-q12*y134
10123 x4=1.-(1.-q12)*y134-q12*y234
10124 x2=1.-y124
10125 x12=(1.-q12)*y13+q12*y23
10126 x14=y12-0.5*qme
10127 IF(y134*y234/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
10128
10129C...qqbarqqbar events: string configuration, choose new flavour.
10130 ELSE
10131 IF(id.EQ.1) THEN
10132 wtr=rlu(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
10133 IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
10134 IF(wtr.LT.wtd(3)+wtd(4)) id=3
10135 IF(wtr.LT.wtd(4)) id=4
10136 IF(id.GE.2) GOTO 130
10137 ENDIF
10138 mstj(120)=5
10139 parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16.*wttot)
10140 140 kfln=1+int(5.*rlu(0))
10141 IF(kfln.NE.kfl.AND.0.2*parj(156).LE.rlu(0)) GOTO 140
10142 IF(kfln.EQ.kfl.AND.1.-0.8*parj(156).LE.rlu(0)) GOTO 140
10143 IF(kfln.GT.mstj(104)) njet=2
10144 pmqn=ulmass(kfln)
10145 qmen=(2.*pmqn/ecm)**2
10146
10147C...Mass cuts. Kinematical variables out.
10148 IF(y24.LE.cut+qme.OR.y13.LE.1.1*qmen) njet=2
10149 IF(njet.EQ.2) GOTO 150
10150 q24=0.5*(1.-sqrt(1.-qme/y24))
10151 q13=0.5*(1.-sqrt(1.-qmen/y13))
10152 x1=1.-(1.-q24)*y123-q24*y134
10153 x4=1.-(1.-q24)*y134-q24*y123
10154 x2=1.-(1.-q13)*y234-q13*y124
10155 x12=(1.-q24)*((1.-q13)*y14+q13*y34)+q24*((1.-q13)*y12+q13*y23)
10156 x14=y24-0.5*qme
10157 x34=(1.-q24)*((1.-q13)*y23+q13*y12)+q24*((1.-q13)*y34+q13*y14)
10158 IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
10159 & (parj(127)+pmq+pmqn)**2) njet=2
10160 IF(y123*y134/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
10161 ENDIF
10162 150 IF(mstj(101).LE.-2.AND.njet.EQ.2) GOTO 100
10163
10164 RETURN
10165 END
10166
10167C*********************************************************************
10168
10169 SUBROUTINE luxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
10170
10171C...Purpose: to give the angular orientation of events.
10172 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10173 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10174 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10175 SAVE /lujets/,/ludat1/,/ludat2/
10176
10177C...Charge. Factors depending on polarization for QED case.
10178 qf=kchg(kfl,1)/3.
10179 poll=1.-parj(131)*parj(132)
10180 pold=parj(132)-parj(131)
10181 IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
10182 hf1=poll
10183 hf2=0.
10184 hf3=parj(133)**2
10185 hf4=0.
10186
10187C...Factors depending on flavour, energy and polarization for QFD case.
10188 ELSE
10189 sff=1./(16.*paru(102)*(1.-paru(102)))
10190 sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
10191 sfi=sfw*(1.-(parj(123)/ecm)**2)
10192 ae=-1.
10193 ve=4.*paru(102)-1.
10194 af=sign(1.,qf)
10195 vf=af-4.*qf*paru(102)
10196 hf1=qf**2*poll-2.*qf*vf*sfi*sff*(ve*poll-ae*pold)+
10197 & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2.*ve*ae*pold)
10198 hf2=-2.*qf*af*sfi*sff*(ae*poll-ve*pold)+2.*vf*af*sfw*sff**2*
10199 & (2.*ve*ae*poll-(ve**2+ae**2)*pold)
10200 hf3=parj(133)**2*(qf**2-2.*qf*vf*sfi*sff*ve+(vf**2+af**2)*
10201 & sfw*sff**2*(ve**2-ae**2))
10202 hf4=-parj(133)**2*2.*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
10203 & sff*ae
10204 ENDIF
10205
10206C...Mass factor. Differential cross-sections for two-jet events.
10207 sq2=sqrt(2.)
10208 qme=0.
10209 IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
10210 &mstj(109).NE.1) qme=(2.*ulmass(kfl)/ecm)**2
10211 IF(njet.EQ.2) THEN
10212 sigu=4.*sqrt(1.-qme)
10213 sigl=2.*qme*sqrt(1.-qme)
10214 sigt=0.
10215 sigi=0.
10216 siga=0.
10217 sigp=4.
10218
10219C...Kinematical variables. Reduce four-jet event to three-jet one.
10220 ELSE
10221 IF(njet.EQ.3) THEN
10222 x1=2.*p(nc+1,4)/ecm
10223 x2=2.*p(nc+3,4)/ecm
10224 ELSE
10225 ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
10226 & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
10227 x1=2.*p(nc+1,4)/ecmr
10228 x2=2.*p(nc+4,4)/ecmr
10229 ENDIF
10230
10231C...Differential cross-sections for three-jet (or reduced four-jet).
10232 xq=(1.-x1)/(1.-x2)
10233 ct12=(x1*x2-2.*x1-2.*x2+2.+qme)/sqrt((x1**2-qme)*(x2**2-qme))
10234 st12=sqrt(1.-ct12**2)
10235 IF(mstj(109).NE.1) THEN
10236 sigu=2.*x1**2+x2**2*(1.+ct12**2)-qme*(3.+ct12**2-x1-x2)-
10237 & qme*x1/xq+0.5*qme*((x2**2-qme)*st12**2-2.*x2)*xq
10238 sigl=(x2*st12)**2-qme*(3.-ct12**2-2.5*(x1+x2)+x1*x2+qme)+
10239 & 0.5*qme*(x1**2-x1-qme)/xq+0.5*qme*((x2**2-qme)*ct12**2-x2)*xq
10240 sigt=0.5*(x2**2-qme-0.5*qme*(x2**2-qme)/xq)*st12**2
10241 sigi=((1.-0.5*qme*xq)*(x2**2-qme)*st12*ct12+qme*(1.-x1-x2+
10242 & 0.5*x1*x2+0.5*qme)*st12/ct12)/sq2
10243 siga=x2**2*st12/sq2
10244 sigp=2.*(x1**2-x2**2*ct12)
10245
10246C...Differential cross-sect for scalar gluons (no mass effects).
10247 ELSE
10248 x3=2.-x1-x2
10249 xt=x2*st12
10250 ct13=sqrt(max(0.,1.-(xt/x3)**2))
10251 sigu=(1.-parj(171))*(x3**2-0.5*xt**2)+
10252 & parj(171)*(x3**2-0.5*xt**2-4.*(1.-x1)*(1.-x2)**2/x1)
10253 sigl=(1.-parj(171))*0.5*xt**2+
10254 & parj(171)*0.5*(1.-x1)**2*xt**2
10255 sigt=(1.-parj(171))*0.25*xt**2+
10256 & parj(171)*0.25*xt**2*(1.-2.*x1)
10257 sigi=-(0.5/sq2)*((1.-parj(171))*xt*x3*ct13+
10258 & parj(171)*xt*((1.-2.*x1)*x3*ct13-x1*(x1-x2)))
10259 siga=(0.25/sq2)*xt*(2.*(1.-x1)-x1*x3)
10260 sigp=x3**2-2.*(1.-x1)*(1.-x2)/x1
10261 ENDIF
10262 ENDIF
10263
10264C...Upper bounds for differential cross-section.
10265 hf1a=abs(hf1)
10266 hf2a=abs(hf2)
10267 hf3a=abs(hf3)
10268 hf4a=abs(hf4)
10269 sigmax=(2.*hf1a+hf3a+hf4a)*abs(sigu)+2.*(hf1a+hf3a+hf4a)*
10270 &abs(sigl)+2.*(hf1a+2.*hf3a+2.*hf4a)*abs(sigt)+2.*sq2*
10271 &(hf1a+2.*hf3a+2.*hf4a)*abs(sigi)+4.*sq2*hf2a*abs(siga)+
10272 &2.*hf2a*abs(sigp)
10273
10274C...Generate angular orientation according to differential cross-sect.
10275 100 chi=paru(2)*rlu(0)
10276 cthe=2.*rlu(0)-1.
10277 phi=paru(2)*rlu(0)
10278 cchi=cos(chi)
10279 schi=sin(chi)
10280 c2chi=cos(2.*chi)
10281 s2chi=sin(2.*chi)
10282 the=acos(cthe)
10283 sthe=sin(the)
10284 c2phi=cos(2.*(phi-parj(134)))
10285 s2phi=sin(2.*(phi-parj(134)))
10286 sig=((1.+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
10287 &2.*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
10288 &2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*c2chi*c2phi-2.*cthe*s2chi*
10289 &s2phi)*hf3-((1.+cthe**2)*c2chi*s2phi+2.*cthe*s2chi*c2phi)*hf4)*
10290 &sigt-2.*sq2*(2.*sthe*cthe*cchi*hf1-2.*sthe*(cthe*cchi*c2phi-
10291 &schi*s2phi)*hf3+2.*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
10292 &4.*sq2*sthe*cchi*hf2*siga+2.*cthe*hf2*sigp
10293 IF(sig.LT.sigmax*rlu(0)) GOTO 100
10294
10295 RETURN
10296 END
10297
10298C*********************************************************************
10299
10300 SUBROUTINE luonia(KFL,ECM)
10301
10302C...Purpose: to generate Upsilon and toponium decays into three
10303C...gluons or two gluons and a photon.
10304 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10305 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10306 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10307 SAVE /lujets/,/ludat1/,/ludat2/
10308
10309C...Printout. Check input parameters.
10310 IF(mstu(12).GE.1) CALL lulist(0)
10311 IF(kfl.LT.0.OR.kfl.GT.8) THEN
10312 CALL luerrm(16,'(LUONIA:) called with unknown flavour code')
10313 IF(mstu(21).GE.1) RETURN
10314 ENDIF
10315 IF(ecm.LT.parj(127)+2.02*parf(101)) THEN
10316 CALL luerrm(16,'(LUONIA:) called with too small CM energy')
10317 IF(mstu(21).GE.1) RETURN
10318 ENDIF
10319
10320C...Initial e+e- and onium state (optional).
10321 nc=0
10322 IF(mstj(115).GE.2) THEN
10323 nc=nc+2
10324 CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
10325 k(nc-1,1)=21
10326 CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
10327 k(nc,1)=21
10328 ENDIF
10329 kflc=iabs(kfl)
10330 IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
10331 nc=nc+1
10332 kf=110*kflc+3
10333 mstu10=mstu(10)
10334 mstu(10)=1
10335 p(nc,5)=ecm
10336 CALL lu1ent(nc,kf,ecm,0.,0.)
10337 k(nc,1)=21
10338 k(nc,3)=1
10339 mstu(10)=mstu10
10340 ENDIF
10341
10342C...Choose x1 and x2 according to matrix element.
10343 ntry=0
10344 100 x1=rlu(0)
10345 x2=rlu(0)
10346 x3=2.-x1-x2
10347 IF(x3.GE.1..OR.((1.-x1)/(x2*x3))**2+((1.-x2)/(x1*x3))**2+
10348 &((1.-x3)/(x1*x2))**2.LE.2.*rlu(0)) GOTO 100
10349 ntry=ntry+1
10350 njet=3
10351 IF(mstj(101).LE.4) CALL lu3ent(nc+1,21,21,21,ecm,x1,x3)
10352 IF(mstj(101).GE.5) CALL lu3ent(-(nc+1),21,21,21,ecm,x1,x3)
10353
10354C...Photon-gluon-gluon events. Small system modifications. Jet origin.
10355 mstu(111)=mstj(108)
10356 IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
10357 &mstu(111)=1
10358 paru(112)=parj(121)
10359 IF(mstu(111).EQ.2) paru(112)=parj(122)
10360 qf=0.
10361 IF(kflc.NE.0) qf=kchg(kflc,1)/3.
10362 rgam=7.2*qf**2*paru(101)/ulalps(ecm**2)
10363 mk=0
10364 ecmc=ecm
10365 IF(rlu(0).GT.rgam/(1.+rgam)) THEN
10366 IF(1.-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
10367 & njet=2
10368 IF(njet.EQ.2.AND.mstj(101).LE.4) CALL lu2ent(nc+1,21,21,ecm)
10369 IF(njet.EQ.2.AND.mstj(101).GE.5) CALL lu2ent(-(nc+1),21,21,ecm)
10370 ELSE
10371 mk=1
10372 ecmc=sqrt(1.-x1)*ecm
10373 IF(ecmc.LT.2.*parj(127)) GOTO 100
10374 k(nc+1,1)=1
10375 k(nc+1,2)=22
10376 k(nc+1,4)=0
10377 k(nc+1,5)=0
10378 IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
10379 IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
10380 IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
10381 IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
10382 njet=2
10383 IF(ecmc.LT.4.*parj(127)) THEN
10384 mstu10=mstu(10)
10385 mstu(10)=1
10386 p(nc+2,5)=ecmc
10387 CALL lu1ent(nc+2,83,0.5*(x2+x3)*ecm,paru(1),0.)
10388 mstu(10)=mstu10
10389 njet=0
10390 ENDIF
10391 ENDIF
10392 DO 110 ip=nc+1,n
10393 k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
10394 110 CONTINUE
10395
10396C...Differential cross-sections. Upper limit for cross-section.
10397 IF(mstj(106).EQ.1) THEN
10398 sq2=sqrt(2.)
10399 hf1=1.-parj(131)*parj(132)
10400 hf3=parj(133)**2
10401 ct13=(x1*x3-2.*x1-2.*x3+2.)/(x1*x3)
10402 st13=sqrt(1.-ct13**2)
10403 sigl=0.5*x3**2*((1.-x2)**2+(1.-x3)**2)*st13**2
10404 sigu=(x1*(1.-x1))**2+(x2*(1.-x2))**2+(x3*(1.-x3))**2-sigl
10405 sigt=0.5*sigl
10406 sigi=(sigl*ct13/st13+0.5*x1*x3*(1.-x2)**2*st13)/sq2
10407 sigmax=(2.*hf1+hf3)*abs(sigu)+2.*(hf1+hf3)*abs(sigl)+2.*(hf1+
10408 & 2.*hf3)*abs(sigt)+2.*sq2*(hf1+2.*hf3)*abs(sigi)
10409
10410C...Angular orientation of event.
10411 120 chi=paru(2)*rlu(0)
10412 cthe=2.*rlu(0)-1.
10413 phi=paru(2)*rlu(0)
10414 cchi=cos(chi)
10415 schi=sin(chi)
10416 c2chi=cos(2.*chi)
10417 s2chi=sin(2.*chi)
10418 the=acos(cthe)
10419 sthe=sin(the)
10420 c2phi=cos(2.*(phi-parj(134)))
10421 s2phi=sin(2.*(phi-parj(134)))
10422 sig=((1.+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2.*(sthe**2*hf1-
10423 & sthe**2*c2phi*hf3)*sigl+2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*
10424 & c2chi*c2phi-2.*cthe*s2chi*s2phi)*hf3)*sigt-2.*sq2*(2.*sthe*cthe*
10425 & cchi*hf1-2.*sthe*(cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
10426 IF(sig.LT.sigmax*rlu(0)) GOTO 120
10427 CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
10428 CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
10429 ENDIF
10430
10431C...Generate parton shower. Rearrange along strings and check.
10432 IF(mstj(101).GE.5.AND.njet.GE.2) THEN
10433 CALL lushow(nc+mk+1,-njet,ecmc)
10434 mstj14=mstj(14)
10435 IF(mstj(105).EQ.-1) mstj(14)=-1
10436 IF(mstj(105).GE.0) mstu(28)=0
10437 CALL luprep(0)
10438 mstj(14)=mstj14
10439 IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
10440 ENDIF
10441
10442C...Generate fragmentation. Information for LUTABU:
10443 IF(mstj(105).EQ.1) CALL luexec
10444 mstu(161)=110*kflc+3
10445 mstu(162)=0
10446
10447 RETURN
10448 END
10449
10450C*********************************************************************
10451
10452 SUBROUTINE luhepc(MCONV)
10453
10454C...Purpose: to convert JETSET event record contents to or from
10455C...the standard event record commonblock.
10456 include '../include/HEPEVT.h'
10457C PARAMETER (NMXHEP=2000)
10458C COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
10459C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
10460 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10461 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10462 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10463 SAVE /hepevt/
10464 SAVE /lujets/,/ludat1/,/ludat2/
10465
10466C...Conversion from JETSET to standard, the easy part.
10467 IF(mconv.EQ.1) THEN
10468 nevhep=0
10469 IF(n.GT.nmxhep) CALL luerrm(8,
10470 & '(LUHEPC:) no more space in /HEPEVT/')
10471 nhep=min(n,nmxhep)
10472 DO 140 i=1,nhep
10473 isthep(i)=0
10474 IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
10475 IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
10476 IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
10477 IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
10478 idhep(i)=k(i,2)
10479 jmohep(1,i)=k(i,3)
10480 jmohep(2,i)=0
10481 IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
10482 jdahep(1,i)=k(i,4)
10483 jdahep(2,i)=k(i,5)
10484 ELSE
10485 jdahep(1,i)=0
10486 jdahep(2,i)=0
10487 ENDIF
10488 DO 100 j=1,5
10489 phep(j,i)=p(i,j)
10490 100 CONTINUE
10491 DO 110 j=1,4
10492 vhep(j,i)=v(i,j)
10493 110 CONTINUE
10494
10495C...Check if new event (from pileup).
10496 IF(i.EQ.1) THEN
10497 inew=1
10498 ELSE
10499 IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i
10500 ENDIF
10501
10502C...Fill in missing mother information.
10503 IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
10504 imo1=i-2
10505 IF(i.GE.inew+3.AND.k(i-1,1).EQ.21.AND.k(i-1,3).EQ.0)
10506 & imo1=imo1-1
10507 jmohep(1,i)=imo1
10508 jmohep(2,i)=imo1+1
10509 ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
10510 i1=k(i,3)-1
10511 120 i1=i1+1
10512 IF(i1.GE.i) CALL luerrm(8,
10513 & '(LUHEPC:) translation of inconsistent event history')
10514 IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) GOTO 120
10515 kc=lucomp(k(i1,2))
10516 IF(i1.LT.i.AND.kc.EQ.0) GOTO 120
10517 IF(i1.LT.i.AND.kchg(kc,2).EQ.0) GOTO 120
10518 jmohep(2,i)=i1
10519 ELSEIF(k(i,2).EQ.94) THEN
10520 njet=2
10521 IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
10522 IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
10523 jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
10524 IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
10525 & mod(k(i+1,4)/mstu(5),mstu(5))
10526 ENDIF
10527
10528C...Fill in missing daughter information.
10529 IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
10530 DO 130 i1=jdahep(1,i),jdahep(2,i)
10531 i2=mod(k(i1,4)/mstu(5),mstu(5))
10532 jdahep(1,i2)=i
10533 130 CONTINUE
10534 ENDIF
10535 IF(k(i,2).GE.91.AND.k(i,2).LE.94) GOTO 140
10536 i1=jmohep(1,i)
10537 IF(i1.LE.0.OR.i1.GT.nhep) GOTO 140
10538 IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) GOTO 140
10539 IF(jdahep(1,i1).EQ.0) THEN
10540 jdahep(1,i1)=i
10541 ELSE
10542 jdahep(2,i1)=i
10543 ENDIF
10544 140 CONTINUE
10545 DO 150 i=1,nhep
10546 IF(k(i,1).NE.13.AND.k(i,1).NE.14) GOTO 150
10547 IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
10548 150 CONTINUE
10549
10550C...Conversion from standard to JETSET, the easy part.
10551 ELSE
10552 IF(nhep.GT.mstu(4)) CALL luerrm(8,
10553 & '(LUHEPC:) no more space in /LUJETS/')
10554 n=min(nhep,mstu(4))
10555 nkq=0
10556 kqsum=0
10557 DO 180 i=1,n
10558 k(i,1)=0
10559 IF(isthep(i).EQ.1) k(i,1)=1
10560 IF(isthep(i).EQ.2) k(i,1)=11
10561 IF(isthep(i).EQ.3) k(i,1)=21
10562 k(i,2)=idhep(i)
10563 k(i,3)=jmohep(1,i)
10564 k(i,4)=jdahep(1,i)
10565 k(i,5)=jdahep(2,i)
10566 DO 160 j=1,5
10567 p(i,j)=phep(j,i)
10568 160 CONTINUE
10569 DO 170 j=1,4
10570 v(i,j)=vhep(j,i)
10571 170 CONTINUE
10572 v(i,5)=0.
10573 IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
10574 i1=jdahep(1,i)
10575 IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
10576 & phep(5,i)/phep(4,i)
10577 ENDIF
10578
10579C...Fill in missing information on colour connection in jet systems.
10580 IF(isthep(i).EQ.1) THEN
10581 kc=lucomp(k(i,2))
10582 kq=0
10583 IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
10584 IF(kq.NE.0) nkq=nkq+1
10585 IF(kq.NE.2) kqsum=kqsum+kq
10586 IF(kq.NE.0.AND.kqsum.NE.0) THEN
10587 k(i,1)=2
10588 ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
10589 IF(k(i+1,2).EQ.21) k(i,1)=2
10590 ENDIF
10591 ENDIF
10592 180 CONTINUE
10593 IF(nkq.EQ.1.OR.kqsum.NE.0) CALL luerrm(8,
10594 & '(LUHEPC:) input parton configuration not colour singlet')
10595 ENDIF
10596
10597 END
10598
10599C*********************************************************************
10600
10601 SUBROUTINE lutest(MTEST)
10602
10603C...Purpose: to provide a simple program (disguised as subroutine) to
10604C...run at installation as a check that the program works as intended.
10605 common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10606 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10607 SAVE /lujets/,/ludat1/
10608 dimension psum(5),pini(6),pfin(6)
10609
10610C...Loop over events to be generated.
10611 IF(mtest.GE.1) CALL lutabu(20)
10612 nerr=0
10613 DO 180 iev=1,600
10614
10615C...Reset parameter values. Switch on some nonstandard features.
10616 mstj(1)=1
10617 mstj(3)=0
10618 mstj(11)=1
10619 mstj(42)=2
10620 mstj(43)=4
10621 mstj(44)=2
10622 parj(17)=0.1
10623 parj(22)=1.5
10624 parj(43)=1.
10625 parj(54)=-0.05
10626 mstj(101)=5
10627 mstj(104)=5
10628 mstj(105)=0
10629 mstj(107)=1
10630 IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
10631
10632C...Ten events each for some single jets configurations.
10633 IF(iev.LE.50) THEN
10634 ity=(iev+9)/10
10635 mstj(3)=-1
10636 IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
10637 IF(ity.EQ.1) CALL lu1ent(1,1,15.,0.,0.)
10638 IF(ity.EQ.2) CALL lu1ent(1,3101,15.,0.,0.)
10639 IF(ity.EQ.3) CALL lu1ent(1,-2203,15.,0.,0.)
10640 IF(ity.EQ.4) CALL lu1ent(1,-4,30.,0.,0.)
10641 IF(ity.EQ.5) CALL lu1ent(1,21,15.,0.,0.)
10642
10643C...Ten events each for some simple jet systems; string fragmentation.
10644 ELSEIF(iev.LE.130) THEN
10645 ity=(iev-41)/10
10646 IF(ity.EQ.1) CALL lu2ent(1,1,-1,40.)
10647 IF(ity.EQ.2) CALL lu2ent(1,4,-4,30.)
10648 IF(ity.EQ.3) CALL lu2ent(1,2,2103,100.)
10649 IF(ity.EQ.4) CALL lu2ent(1,21,21,40.)
10650 IF(ity.EQ.5) CALL lu3ent(1,2101,21,-3203,30.,0.6,0.8)
10651 IF(ity.EQ.6) CALL lu3ent(1,5,21,-5,40.,0.9,0.8)
10652 IF(ity.EQ.7) CALL lu3ent(1,21,21,21,60.,0.7,0.5)
10653 IF(ity.EQ.8) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
10654
10655C...Seventy events with independent fragmentation and momentum cons.
10656 ELSEIF(iev.LE.200) THEN
10657 ity=1+(iev-131)/16
10658 mstj(2)=1+mod(iev-131,4)
10659 mstj(3)=1+mod((iev-131)/4,4)
10660 IF(ity.EQ.1) CALL lu2ent(1,4,-5,40.)
10661 IF(ity.EQ.2) CALL lu3ent(1,3,21,-3,40.,0.9,0.4)
10662 IF(ity.EQ.3) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
10663 IF(ity.GE.4) CALL lu4ent(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
10664
10665C...A hundred events with random jets (check invariant mass).
10666 ELSEIF(iev.LE.300) THEN
10667 100 DO 110 j=1,5
10668 psum(j)=0.
10669 110 CONTINUE
10670 njet=2.+6.*rlu(0)
10671 DO 130 i=1,njet
10672 kfl=21
10673 IF(i.EQ.1) kfl=int(1.+4.*rlu(0))
10674 IF(i.EQ.njet) kfl=-int(1.+4.*rlu(0))
10675 ejet=5.+20.*rlu(0)
10676 theta=acos(2.*rlu(0)-1.)
10677 phi=6.2832*rlu(0)
10678 IF(i.LT.njet) CALL lu1ent(-i,kfl,ejet,theta,phi)
10679 IF(i.EQ.njet) CALL lu1ent(i,kfl,ejet,theta,phi)
10680 IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1
10681 IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+ulmass(kfl)
10682 DO 120 j=1,4
10683 psum(j)=psum(j)+p(i,j)
10684 120 CONTINUE
10685 130 CONTINUE
10686 IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
10687 & (psum(5)+parj(32))**2) GOTO 100
10688
10689C...Fifty e+e- continuum events with matrix elements.
10690 ELSEIF(iev.LE.350) THEN
10691 mstj(101)=2
10692 CALL lueevt(0,40.)
10693
10694C...Fifty e+e- continuum event with varying shower options.
10695 ELSEIF(iev.LE.400) THEN
10696 mstj(42)=1+mod(iev,2)
10697 mstj(43)=1+mod(iev/2,4)
10698 mstj(44)=mod(iev/8,3)
10699 CALL lueevt(0,90.)
10700
10701C...Fifty e+e- continuum events with coherent shower, including top.
10702 ELSEIF(iev.LE.450) THEN
10703 mstj(104)=6
10704 CALL lueevt(0,500.)
10705
10706C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
10707 ELSEIF(iev.LE.500) THEN
10708 CALL luonia(5,9.46)
10709
10710C...One decay each for some heavy mesons.
10711 ELSEIF(iev.LE.560) THEN
10712 ity=iev-501
10713 kfls=2*(ity/20)+1
10714 kflb=8-mod(ity/5,4)
10715 kflc=kflb-mod(ity,5)
10716 CALL lu1ent(1,100*kflb+10*kflc+kfls,0.,0.,0.)
10717
10718C...One decay each for some heavy baryons.
10719 ELSEIF(iev.LE.600) THEN
10720 ity=iev-561
10721 kfls=2*(ity/20)+2
10722 kfla=8-mod(ity/5,4)
10723 kflb=kfla-mod(ity,5)
10724 kflc=max(1,kflb-1)
10725 CALL lu1ent(1,1000*kfla+100*kflb+10*kflc+kfls,0.,0.,0.)
10726 ENDIF
10727
10728C...Generate event. Find total momentum, energy and charge.
10729 DO 140 j=1,4
10730 pini(j)=plu(0,j)
10731 140 CONTINUE
10732 pini(6)=plu(0,6)
10733 CALL luexec
10734 DO 150 j=1,4
10735 pfin(j)=plu(0,j)
10736 150 CONTINUE
10737 pfin(6)=plu(0,6)
10738
10739C...Check conservation of energy, momentum and charge;
10740C...usually exact, but only approximate for single jets.
10741 merr=0
10742 IF(iev.LE.50) THEN
10743 IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.4.) merr=merr+1
10744 epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
10745 IF(epzrem.LT.0..OR.epzrem.GT.2.*parj(31)) merr=merr+1
10746 IF(abs(pfin(6)-pini(6)).GT.2.1) merr=merr+1
10747 ELSE
10748 DO 160 j=1,4
10749 IF(abs(pfin(j)-pini(j)).GT.0001*pini(4)) merr=merr+1
10750 160 CONTINUE
10751 IF(abs(pfin(6)-pini(6)).GT.0.1) merr=merr+1
10752 ENDIF
10753 IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
10754 &(pfin(j),j=1,4),pfin(6)
10755
10756C...Check that all KF codes are known ones, and that partons/particles
10757C...satisfy energy-momentum-mass relation. Store particle statistics.
10758 DO 170 i=1,n
10759 IF(k(i,1).GT.20) GOTO 170
10760 IF(lucomp(k(i,2)).EQ.0) THEN
10761 WRITE(mstu(11),5100) i
10762 merr=merr+1
10763 ENDIF
10764 pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
10765 IF(abs(pd).GT.max(0.1,0.001*p(i,4)**2).OR.p(i,4).LT.0.) THEN
10766 WRITE(mstu(11),5200) i
10767 merr=merr+1
10768 ENDIF
10769 170 CONTINUE
10770 IF(mtest.GE.1) CALL lutabu(21)
10771
10772C...List all erroneous events and some normal ones.
10773 IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
10774 CALL lulist(2)
10775 ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
10776 CALL lulist(1)
10777 ENDIF
10778
10779C...Stop execution if too many errors.
10780 IF(merr.NE.0) nerr=nerr+1
10781 IF(nerr.GE.10) THEN
10782 WRITE(mstu(11),5300) iev
10783 stop
10784 ENDIF
10785 180 CONTINUE
10786
10787C...Summarize result of run.
10788 IF(mtest.GE.1) CALL lutabu(22)
10789 IF(nerr.EQ.0) WRITE(mstu(11),5400)
10790 IF(nerr.GT.0) WRITE(mstu(11),5500) nerr
10791
10792C...Reset commonblock variables changed during run.
10793 mstj(2)=3
10794 parj(17)=0.
10795 parj(22)=1.
10796 parj(43)=0.5
10797 parj(54)=0.
10798 mstj(105)=1
10799 mstj(107)=0
10800
10801C...Format statements for output.
10802 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
10803 &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
10804 &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
10805 &4(1x,f12.5),1x,f8.2)
10806 5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
10807 5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
10808 &'kinematics')
10809 5300 FORMAT(/5x,'Ten errors experienced by event ',i3/
10810 &5x,'Something is seriously wrong! Execution stopped now!')
10811 5400 FORMAT(//5x,'End result of LUTEST: no errors detected.')
10812 5500 FORMAT(//5x,'End result of LUTEST:',i2,' errors detected.'/
10813 &5x,'This should not have happened!')
10814
10815 RETURN
10816 END
10817
10818C*********************************************************************
10819
10820 BLOCK DATA ludata
10821
10822C...Purpose: to give default values to parameters and particle and
10823C...decay data.
10824 common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10825 common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
10826 common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
10827 common/ludat4/chaf(500)
10828 CHARACTER CHAF*8
10829 common/ludatr/mrlu(6),rrlu(100)
10830 SAVE /ludat1/,/ludat2/,/ludat3/,/ludat4/,/ludatr/
10831
10832C...LUDAT1, containing status codes and most parameters.
10833 DATA mstu/
10834 & 0, 0, 0, 4000,10000, 500, 2000, 0, 0, 2,
10835 1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
10836 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
10837 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10838 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
10839 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
10840 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10841 7 30*0,
10842 & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10843 1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
10844 2 60*0,
10845 8 7, 401, 1994, 02, 11, 700, 0, 0, 0, 0,
10846 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
10847 DATA paru/
10848 & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
10849 1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
10850 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10851 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10852 4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
10853 5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
10854 6 40*0.,
10855 & 0.00729735, 0.232, 0., 0., 0., 0., 0., 0., 0., 0.,
10856 1 0.20, 0.25, 1.0, 4.0, 10., 0., 0., 0., 0., 0.,
10857 2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0, 0.,
10858 3 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 0., 0., 0.,
10859 4 5.0, 1.0, 1.0, 0., 1.0, 1.0, 0., 0., 0., 0.,
10860 5 1.0, 0., 0., 0., 1000., 1.0, 1.0, 1.0, 1.0, 0.,
10861 6 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., 0., 0.,
10862 7 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0.,
10863 8 1.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.,
10864 9 0., 0., 0., 0., 1.0, 0., 0., 0., 0., 0./
10865 DATA mstj/
10866 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
10867 1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
10868 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
10869 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
10870 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 0,
10871 5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
10872 6 40*0,
10873 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
10874 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
10875 2 80*0/
10876 DATA parj/
10877 & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
10878 1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
10879 2 0.36, 1.0, 0.01, 2.0, 1.0, 0.4, 0., 0., 0., 0.,
10880 3 0.10, 1.0, 0.8, 1.5, 0., 2.0, 0.2, 2.5, 0.6, 0.,
10881 4 0.3, 0.58, 0.5, 0.9, 0.5, 1.0, 1.0, 1.0, 0., 0.,
10882 5 0.77,0.77,0.77,-0.05,-0.005,-0.00001,-0.00001,-0.00001,1.0,0.,
10883 6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
10884 7 10., 1000., 100., 1000., 0., 0.7, 10., 0., 0., 0.,
10885 8 0.29, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
10886 9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
10887 & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10888 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10889 2 1.0, 0.25,91.187,2.489, 0.01, 2.0, 1.0, 0.25,0.002, 0.,
10890 3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
10891 4 60*0./
10892
10893C...LUDAT2, with particle data and flavour treatment parameters.
10894 DATA (kchg(i,1),i= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
10895 &-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,
10896 &3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,
10897 &3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,3,0,3,10*0,3,0,2*3,0,3,0,
10898 &3,0,3,70*0,3,0,3,28*0,3,2*0,3,8*0,-3,8*0,3,0,-3,0,3,-3,3*0,3,6,0,
10899 &3,5*0,-3,0,3,-3,0,-3,4*0,-3,0,3,6,-3,0,3,-3,0,-3,0,3,6,0,3,5*0,
10900 &-3,0,3,-3,0,-3,114*0/
10901 DATA (kchg(i,2),i= 1, 500)/8*1,12*0,2,16*0,2,1,50*0,-1,410*0/
10902 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,
10903 &41*0,1,0,7*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1,10*0,10*1,
10904 &10*0,10*1,70*0,3*1,22*0,1,5*0,1,0,2*1,6*0,1,0,2*1,6*0,2*1,0,5*1,
10905 &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
10906 DATA (pmas(i,1),i= 1, 500)/0.0099,0.0056,0.199,1.35,5.,160.,
10907 &2*250.,2*0.,0.00051,0.,0.1057,0.,1.777,0.,250.,5*0.,91.187,80.25,
10908 &80.,6*0.,500.,900.,500.,3*300.,350.,200.,5000.,60*0.,0.1396,
10909 &0.4977,0.4936,1.8693,1.8645,1.9688,5.2787,5.2786,5.47972,6.594,
10910 &0.135,0.5475,0.9578,2.9788,9.4,320.,2*500.,2*0.,0.7669,0.8961,
10911 &0.8916,2.0101,2.0071,2.11,2*5.325,5.5068,6.602,0.7683,0.782,
10912 &1.0194,3.0969,9.4603,320.,2*500.,2*0.,1.232,2*1.29,2*2.424,2.536,
10913 &2*5.73,5.97,7.3,1.232,1.17,1.4,3.46,9.875,320.,2*500.,2*0.,0.983,
10914 &2*1.429,2*2.272,2.5,2*5.68,5.92,7.25,0.9827,1.,1.4,3.4151,9.8598,
10915 &320.,2*500.,2*0.,1.26,2*1.402,2*2.372,2.56,2*5.78,6.02,7.3,1.26,
10916 &1.282,1.42,3.5106,9.8919,320.,2*500.,2*0.,1.318,1.432,1.425,
10917 &2*2.46,2.61,2*5.83,6.07,7.35,1.318,1.275,1.525,3.5562,9.9132,
10918 &320.,2*500.,2*0.,2*0.4977,8*0.,3.686,3*0.,10.0233,70*0.,1.1156,
10919 &5*0.,2.2849,0.,2.473,2.466,6*0.,5.641,0.,2*5.84,6*0.,0.9396,
10920 &0.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.4525,2.4529,
10921 &2.4527,2*2.55,2.73,4*0.,3*5.8,2*5.96,6.12,4*0.,1.234,1.233,1.232,
10922 &1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8,
10923 &4*0.,3*5.81,2*5.97,6.13,114*0./
10924 DATA (pmas(i,2),i= 1, 500)/22*0.,2.489,2.066,88*0.,0.0002,
10925 &0.001,6*0.,0.149,0.0505,0.0498,7*0.,0.151,0.00843,0.0044,7*0.,
10926 &0.155,2*0.09,2*0.02,0.,4*0.05,0.155,0.36,0.08,2*0.01,5*0.,0.057,
10927 &2*0.287,7*0.05,0.057,0.,0.25,0.014,6*0.,0.4,2*0.174,7*0.05,0.4,
10928 &0.024,0.06,0.0009,6*0.,0.11,0.109,0.098,2*0.019,5*0.02,0.11,
10929 &0.185,0.076,0.002,146*0.,4*0.12,0.0394,0.036,0.0358,0.0099,
10930 &0.0091,131*0./
10931 DATA (pmas(i,3),i= 1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0.,
10932 &0.4,2*0.2,7*0.,0.4,0.1,0.015,7*0.,0.25,0.005,0.01,2*0.08,0.,
10933 &4*0.1,0.25,0.2,0.001,2*0.02,5*0.,0.05,2*0.4,6*0.1,2*0.05,0.,0.35,
10934 &0.05,6*0.,3*0.3,2*0.1,0.03,4*0.1,0.3,0.05,0.02,0.001,6*0.,0.25,
10935 &4*0.12,5*0.05,0.25,0.17,0.2,0.01,146*0.,4*0.14,0.04,2*0.035,
10936 &2*0.05,131*0./
10937 DATA (pmas(i,4),i= 1, 500)/12*0.,658650.,0.,0.0914,68*0.,0.1,
10938 &0.387,15*0.,7804.,0.,3709.,0.32,0.1259,0.135,3*0.387,0.15,110*0.,
10939 &15500.,26.75,83*0.,78.88,5*0.,0.057,0.,0.025,0.09,6*0.,0.387,0.,
10940 &2*0.387,9*0.,44.3,0.,23.95,49.1,86.9,6*0.,0.13,9*0.,0.387,13*0.,
10941 &24.60001,130*0./
10942 DATA parf/
10943 & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
10944 1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10945 2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10946 3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10947 4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10948 5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
10949 6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
10950 7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
10951 8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10952 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
10953 & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
10954 1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
10955 2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
10956 3 1870*0./
10957 DATA ((vckm(i,j),j=1,4),i=1,4)/
10958 1 0.95113, 0.04884, 0.00003, 0.00000,
10959 2 0.04884, 0.94940, 0.00176, 0.00000,
10960 3 0.00003, 0.00176, 0.99821, 0.00000,
10961 4 0.00000, 0.00000, 0.00000, 1.00000/
10962
10963C...LUDAT3, with particle decay parameters and data.
10964 DATA (mdcy(i,1),i= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,1,
10965 &2*0,4*1,42*0,7*1,12*0,1,0,15*1,2*0,18*1,2*0,18*1,2*0,18*1,2*0,
10966 &18*1,2*0,18*1,3*0,1,8*0,1,3*0,1,70*0,1,5*0,1,0,2*1,6*0,1,0,2*1,
10967 &9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
10968 DATA (mdcy(i,2),i= 1, 500)/1,9,17,25,33,41,50,60,2*0,70,74,76,
10969 &81,83,124,126,132,2*0,135,144,156,172,192,6*0,209,0,231,254,274,
10970 &292,301,304,305,42*0,314,315,319,328,331,336,338,11*0,358,359,
10971 &361,367,430,491,524,560,596,635,666,668,675,681,682,683,684,685,
10972 &2*0,686,688,691,694,697,699,700,701,702,703,704,708,713,721,724,
10973 &733,734,735,2*0,736,737,742,747,749,751,753,755,757,759,761,762,
10974 &765,769,770,771,772,773,2*0,774,775,777,779,781,783,785,787,789,
10975 &791,793,794,799,804,806,808,809,810,2*0,811,813,815,817,819,821,
10976 &823,825,827,829,831,833,846,850,852,854,855,856,2*0,857,863,873,
10977 &884,892,900,904,912,920,924,928,936,945,951,953,955,956,957,2*0,
10978 &958,966,8*0,968,3*0,979,70*0,993,5*0,997,0,1073,1074,6*0,1075,0,
10979 &1092,1093,9*0,1094,1096,1097,1100,1101,0,1103,1104,1105,1106,
10980 &1107,1108,4*0,1109,1110,1111,1112,1113,1114,4*0,1115,1116,1119,
10981 &1122,1123,1126,1129,1132,1134,1136,1140,1141,1142,1143,1145,1147,
10982 &4*0,1148,1149,1150,1151,1152,1153,114*0/
10983 DATA (mdcy(i,3),i= 1, 500)/5*8,9,2*10,2*0,4,2,5,2,41,2,6,3,2*0,
10984 &9,12,16,20,17,6*0,22,0,23,20,18,9,3,1,9,42*0,1,4,9,3,5,2,20,11*0,
10985 &1,2,6,63,61,33,2*36,39,31,2,7,6,5*1,2*0,2,3*3,2,5*1,4,5,8,3,9,
10986 &3*1,2*0,1,2*5,7*2,1,3,4,5*1,2*0,1,9*2,1,2*5,2*2,3*1,2*0,11*2,13,
10987 &4,2*2,3*1,2*0,6,10,11,2*8,4,2*8,2*4,8,9,6,2*2,3*1,2*0,8,2,8*0,11,
10988 &3*0,14,70*0,4,5*0,76,0,2*1,6*0,17,0,2*1,9*0,2,1,3,1,2,0,6*1,4*0,
10989 &6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
10990 DATA (mdme(i,1),i= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
10991 &7*1,-1,1,-1,8*1,2*-1,8*1,2*-1,61*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
10992 &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,2*-1,
10993 &3*1,-1,11*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,6*1,
10994 &2*-1,3*1,-1,5*1,-1,8*1,2*-1,3*1,-1,9*1,-1,3*1,-1,9*1,2*-1,2*1,-1,
10995 &16*1,-1,2*1,3*-1,1665*1/
10996 DATA (mdme(i,2),i= 1,2000)/75*102,42,6*102,2*42,2*0,7*41,2*0,
10997 &24*41,6*102,45,29*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
10998 &14*0,16*32,7*0,8*32,4*0,32,7*0,8*32,4*0,32,5*0,4*32,5*0,3*32,0,
10999 &6*32,3*0,12,2*42,2*11,9*42,2*45,31,2*45,2*33,31,2*45,20*46,7*0,
11000 &24*42,41*0,16*42,46*0,10*42,20*0,2*13,14*42,16*0,48,3*13,16*42,
11001 &16*0,48,3*13,16*42,19*0,48,3*13,2*42,0,2*11,28*42,0,2,4*0,2,8*0,
11002 &12,32,86,87,88,3,0,2*3,0,2*3,0,2*3,0,3,6*0,3,3*0,1,0,3,2*0,2*3,
11003 &3*0,1,4*0,12,3*0,4*32,2*4,86,87,88,33*0,12,32,86,87,88,31*0,12,0,
11004 &32,86,87,88,40*0,12,0,32,86,87,88,95*0,12,0,32,86,87,88,2*0,4*42,
11005 &6*0,12,11*0,4*32,2*4,9*0,14*42,52*0,10*13,2*84,3*42,8*0,48,3*13,
11006 &2*42,2*85,14*0,84,5*0,85,886*0/
11007 DATA (brat(i) ,i= 1, 439)/75*0.,1.,6*0.,0.179,0.178,0.116,
11008 &0.235,0.005,0.056,0.018,0.023,0.011,2*0.004,0.0067,0.014,2*0.002,
11009 &2*0.001,0.0022,0.054,0.002,0.016,0.005,0.011,0.0101,5*0.006,
11010 &0.002,2*0.001,5*0.002,6*0.,1.,29*0.,0.15394,0.11936,0.15394,
11011 &0.11926,0.15254,3*0.,0.03368,0.06664,0.03368,0.06664,0.03368,
11012 &0.06664,2*0.,0.3214,0.0165,2*0.,0.0165,0.3207,2*0.,0.00001,
11013 &0.00059,6*0.,3*0.1081,3*0.,0.0003,0.048,0.8705,4*0.,0.0002,
11014 &0.0603,0.,0.0199,0.0008,3*0.,0.143,0.111,0.143,0.111,0.143,0.085,
11015 &2*0.,0.03,0.058,0.03,0.058,0.03,0.058,8*0.,0.25,0.01,2*0.,0.01,
11016 &0.25,4*0.,0.24,5*0.,3*0.08,6*0.,0.01,0.08,0.82,5*0.,0.09,11*0.,
11017 &0.01,0.08,0.82,5*0.,0.09,9*0.,1.,6*0.,0.01,0.98,0.01,1.,4*0.215,
11018 &2*0.,2*0.07,0.,1.,2*0.08,0.76,0.08,2*0.105,0.04,0.5,0.08,0.14,
11019 &0.01,0.015,0.005,1.,3*0.,1.,4*0.,1.,0.25,0.01,2*0.,0.01,0.25,
11020 &4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,0.017,0.048,
11021 &0.032,0.07,0.065,2*0.005,2*0.011,5*0.001,0.07,0.065,2*0.005,
11022 &2*0.011,5*0.001,0.026,0.019,0.066,0.041,0.045,0.076,0.0073,
11023 &2*0.0047,0.026,0.001,0.0006,0.0066,0.005,2*0.003,2*0.0006,
11024 &2*0.001,0.006,0.005,0.012,0.0057,0.067,0.008,0.0022,0.027,0.004,
11025 &0.019,0.012,0.002,0.009,0.0218,0.001,0.022,0.087,0.001,0.0019,
11026 &0.0015,0.0028,0.034,0.027,2*0.002,2*0.004,2*0.002,0.034,0.027/
11027 DATA (brat(i) ,i= 440, 655)/2*0.002,2*0.004,2*0.002,0.0365,
11028 &0.045,0.073,0.062,3*0.021,0.0061,0.015,0.025,0.0088,0.074,0.0109,
11029 &0.0041,0.002,0.0035,0.0011,0.001,0.0027,2*0.0016,0.0018,0.011,
11030 &0.0063,0.0052,0.018,0.016,0.0034,0.0036,0.0009,0.0006,0.015,
11031 &0.0923,0.018,0.022,0.0077,0.009,0.0075,0.024,0.0085,0.067,0.0511,
11032 &0.017,0.0004,0.0028,0.01,2*0.02,0.03,2*0.005,2*0.02,0.03,2*0.005,
11033 &0.015,0.037,0.028,0.079,0.095,0.052,0.0078,4*0.001,0.028,0.033,
11034 &0.026,0.05,0.01,4*0.005,0.25,0.0952,0.02,0.055,2*0.005,0.008,
11035 &0.012,0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,
11036 &0.0055,0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,0.0004,
11037 &0.0007,0.0008,0.0014,0.0019,0.0025,0.4291,0.08,0.07,0.02,0.015,
11038 &0.005,0.02,0.055,2*0.005,0.008,0.012,0.02,0.055,2*0.005,0.008,
11039 &0.012,0.01,0.03,0.0035,0.011,0.0055,0.0042,0.009,0.018,0.015,
11040 &0.0185,0.0135,0.025,0.0004,0.0007,0.0008,0.0014,0.0019,0.0025,
11041 &0.4291,0.08,0.07,0.02,0.015,0.005,0.02,0.055,2*0.005,0.008,0.012,
11042 &0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,0.0055,
11043 &0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,2*0.0002,0.0007,
11044 &2*0.0004,0.0014,0.001,0.0009,0.0025,0.4291,0.08,0.07,0.02,0.015,
11045 &0.005,0.047,0.122,0.006,0.012,0.035,0.012,0.035,0.003,0.007,0.15,
11046 &0.037,0.008,0.002,0.05,0.015,0.003,0.001,0.014,0.042,0.014,0.042/
11047 DATA (brat(i) ,i= 656, 931)/0.24,0.065,0.012,0.003,0.001,0.002,
11048 &0.001,0.002,0.014,0.003,0.988,0.012,0.389,0.319,0.2367,0.049,
11049 &0.005,0.001,0.0003,0.441,0.206,0.3,0.03,0.022,0.001,5*1.,0.99955,
11050 &0.00045,0.665,0.333,0.002,0.666,0.333,0.001,0.65,0.3,0.05,0.56,
11051 &0.44,5*1.,0.99912,0.00079,0.00005,0.00004,0.888,0.085,0.021,
11052 &2*0.003,0.49,0.344,3*0.043,0.023,0.013,0.001,0.0627,0.0597,
11053 &0.8776,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,4*1.,0.28,0.14,
11054 &0.313,0.157,0.11,0.28,0.14,0.313,0.157,0.11,0.667,0.333,0.667,
11055 &0.333,2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.333,0.334,0.333,
11056 &4*0.25,6*1.,0.667,0.333,0.667,0.333,0.667,0.333,0.667,0.333,
11057 &2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.52,0.26,0.11,2*0.055,
11058 &0.62,0.31,0.035,2*0.0175,0.007,0.993,0.02,0.98,3*1.,2*0.5,0.667,
11059 &0.333,0.667,0.333,0.667,0.333,0.667,0.333,2*0.5,0.667,0.333,
11060 &0.667,0.333,6*0.5,3*0.12,0.097,0.043,4*0.095,4*0.03,4*0.25,0.273,
11061 &0.727,0.35,0.65,3*1.,2*0.35,0.144,0.105,0.048,0.003,0.333,0.166,
11062 &0.168,0.084,0.087,0.043,0.059,2*0.029,0.002,0.332,0.166,0.168,
11063 &0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,0.15,0.16,0.08,0.13,
11064 &0.06,0.08,0.04,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,2*0.3,
11065 &2*0.2,0.3,0.15,0.16,0.08,0.13,0.06,0.08,0.04,0.3,0.15,0.16,0.08,
11066 &0.13,0.06,0.08,0.04,2*0.3,2*0.2,2*0.3,2*0.2,2*0.35,0.144,0.105/
11067 DATA (brat(i) ,i= 932,2000)/0.024,2*0.012,0.003,0.566,0.283,
11068 &0.069,0.028,0.023,2*0.0115,0.005,0.003,0.356,2*0.178,0.28,
11069 &2*0.004,0.135,0.865,0.22,0.78,3*1.,0.217,0.124,2*0.193,2*0.135,
11070 &0.002,0.001,0.686,0.314,2*0.0083,0.1866,0.324,0.184,0.027,0.001,
11071 &0.093,0.087,0.078,0.0028,3*0.014,0.008,0.024,0.008,0.024,0.425,
11072 &0.02,0.185,0.088,0.043,0.067,0.066,0.641,0.357,2*0.001,0.018,
11073 &2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,2*0.006,
11074 &0.0066,0.025,0.016,0.0088,2*0.005,0.0058,0.005,0.0055,4*0.004,
11075 &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002,
11076 &2*0.001,2*0.002,0.0013,0.0018,5*0.001,4*0.003,2*0.005,2*0.002,
11077 &2*0.001,2*0.002,2*0.001,0.2432,0.057,2*0.035,0.15,2*0.075,0.03,
11078 &2*0.015,2*1.,2*0.105,0.04,0.0077,0.02,0.0235,0.0285,0.0435,
11079 &0.0011,0.0022,0.0044,0.4291,0.08,0.07,0.02,0.015,0.005,2*1.,
11080 &0.999,0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331,
11081 &0.663,0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88,
11082 &2*0.06,0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5,
11083 &7*1.,847*0./
11084 DATA (kfdp(i,1),i= 1, 507)/21,22,23,4*-24,25,21,22,23,4*24,25,
11085 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
11086 &4*24,25,37,21,22,23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,
11087 &-24,25,23,24,-12,22,23,-24,25,23,24,-12,-14,35*16,22,23,-24,25,
11088 &23,24,-89,22,23,-24,25,-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,
11089 &6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,
11090 &4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,
11091 &2*22,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,24,37,2*23,25,
11092 &35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11,
11093 &13,15,17,21,2*22,23,24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21,
11094 &2*22,23,24,23,-1,-3,-5,-7,-11,-13,-15,-17,24,5,6,21,2,1,2,3,4,5,
11095 &6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37,
11096 &2*-89,2*5,-37,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
11097 &310,-13,3*211,12,14,11*-11,11*-13,-311,-313,-311,-313,-20313,
11098 &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,
11099 &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311,
11100 &-321,211,113,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
11101 &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
11102 &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
11103 &-321,3*-311,211,113,321,-15,5*-11,5*-13,221,331,333,221,331,333/
11104 DATA (kfdp(i,1),i= 508, 924)/10221,211,213,211,213,321,323,321,
11105 &323,2212,221,331,333,221,2*2,6*12,6*14,2*16,3*-411,3*-413,2*-411,
11106 &2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,2*16,3*-421,
11107 &3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,
11108 &2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,
11109 &16,2*4,2*12,2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,
11110 &2*-1,3*22,111,211,2*22,211,22,211,111,3*22,111,82,21,3*0,2*211,
11111 &321,3*311,2*321,421,2*411,2*421,431,511,521,531,541,211,111,13,
11112 &11,211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,82,11,
11113 &13,15,1,2,3,4,21,22,3*0,223,321,311,323,313,2*311,321,313,323,
11114 &321,423,2*413,2*423,413,523,2*513,2*523,2*513,523,223,213,113,
11115 &-213,313,-313,323,-323,82,21,3*0,221,321,2*311,321,421,2*411,421,
11116 &411,421,521,2*511,2*521,2*511,521,221,211,111,321,130,310,211,
11117 &111,321,130,310,443,82,553,21,3*0,113,213,323,2*313,323,423,
11118 &2*413,2*423,413,523,2*513,2*523,2*513,523,213,-213,10211,10111,
11119 &-10211,2*221,213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82,
11120 &553,21,3*0,213,113,221,223,321,211,321,311,323,313,323,313,321,
11121 &4*311,321,313,323,313,323,311,4*321,421,411,423,413,423,413,421,
11122 &2*411,421,413,423,413,423,411,2*421,411,423,413,521,511,523,513,
11123 &523,513,521,2*511,521,513,523,513,523,511,2*521,511,523,513,511/
11124 DATA (kfdp(i,1),i= 925,2000)/521,513,523,213,-213,221,223,321,
11125 &130,310,111,211,111,2*211,321,130,310,221,111,321,130,310,221,
11126 &211,111,443,82,553,21,3*0,111,211,-12,12,-14,14,211,111,211,111,
11127 &11,13,82,4*443,10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,
11128 &10551,20553,555,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
11129 &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,7*2212,
11130 &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
11131 &2*2,1,2*2,2*0,-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,
11132 &2*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,4232,0,
11133 &3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,3212,
11134 &3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,3322,
11135 &3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,847*0/
11136 DATA (kfdp(i,2),i= 1, 476)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
11137 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,3*7,2,4,6,8,7,
11138 &4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,13,11,13,
11139 &-211,-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,3*-321,
11140 &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
11141 &16,15,16,15,18,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
11142 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
11143 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
11144 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
11145 &-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
11146 &-37,22,25,2*36,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,
11147 &25,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,
11148 &36,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4,
11149 &6,8,12,14,16,18,25,-5,-6,21,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,
11150 &12,14,-1,-3,11,13,15,1,4,3,4,1,3,5,3,5,6,4,21,22,4,7,5,2,4,6,8,2,
11151 &4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,
11152 &11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,213,211,213,
11153 &211,213,211,213,211,213,211,213,3*211,213,211,2*321,8*211,2*113,
11154 &2*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,211,
11155 &2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,211/
11156 DATA (kfdp(i,2),i= 477, 857)/-211,4*211,321,4*211,113,2*211,-321,
11157 &16,5*12,5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,
11158 &3*321,323,2*-1,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,
11159 &433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,6*-11,
11160 &6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,321,323,
11161 &321,323,321,323,-1,-4,-3,-4,-1,-3,6*-11,6*-13,2*-15,211,213,
11162 &20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,221,
11163 &331,333,-1,-4,-3,-4,-1,-3,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,
11164 &-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,11,22,111,-211,
11165 &211,11,-211,13,-211,111,113,223,22,111,-82,21,3*0,111,22,-211,
11166 &111,22,211,111,22,211,111,22,111,6*22,-211,22,-13,-11,-211,111,
11167 &-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,-11,-13,
11168 &-15,-1,-2,-3,-4,2*21,3*0,211,-213,113,-211,111,223,213,113,211,
11169 &111,223,211,111,-211,111,321,311,-211,111,211,111,-321,-311,411,
11170 &421,111,-211,111,211,-311,311,-321,321,-82,21,3*0,211,-211,111,
11171 &211,111,211,111,-211,111,311,321,-211,111,211,111,-321,-311,411,
11172 &421,111,-211,111,-321,130,310,-211,111,-321,130,310,22,-82,22,21,
11173 &3*0,211,111,-211,111,211,111,211,111,-211,111,321,311,-211,111,
11174 &211,111,-321,-311,411,421,-211,211,-211,111,2*211,111,-211,211,
11175 &111,211,-321,2*-311,-321,-311,311,-321,321,22,-82,22,21,3*0,111/
11176 DATA (kfdp(i,2),i= 858,2000)/3*211,-311,22,-211,111,-211,111,
11177 &-211,211,-213,113,223,221,211,111,211,111,2*211,213,113,223,221,
11178 &22,211,111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,
11179 &311,321,311,-211,111,-211,111,-211,211,-211,2*211,111,211,111,
11180 &4*211,-321,-311,-321,-311,411,421,411,421,-211,211,111,211,-321,
11181 &130,310,22,-211,111,2*-211,-321,130,310,221,111,-321,130,310,221,
11182 &-211,111,22,-82,22,21,3*0,111,-211,11,-11,13,-13,-211,111,-211,
11183 &111,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
11184 &2*21,211,111,3*22,-211,111,22,11,7*12,7*14,-321,-323,-311,-313,
11185 &-311,-313,211,213,211,213,211,213,111,221,331,113,223,111,221,
11186 &113,223,321,323,321,-211,-213,111,221,331,113,223,333,10221,111,
11187 &221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,313,
11188 &311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,2*0,11,13,15,
11189 &-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,2*0,-211,11,22,111,
11190 &211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,0,
11191 &2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211,
11192 &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22,
11193 &-211,111,211,3*22,847*0/
11194 DATA (kfdp(i,3),i= 1, 944)/75*0,14,6*0,2*16,2*0,5*111,310,130,
11195 &2*0,2*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
11196 &2*113,221,113,2*213,-213,195*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211,
11197 &3*111,-311,-313,-311,-321,-313,-323,111,221,331,113,223,-311,
11198 &-313,-311,-321,-313,-323,111,221,331,113,223,22*0,111,113,2*211,
11199 &-211,-311,211,111,3*211,-211,7*211,-321,-323,-311,-321,-313,-323,
11200 &-211,-213,-321,-323,-311,-321,-313,-323,-211,-213,22*0,111,113,
11201 &-311,2*-211,211,-211,310,-211,2*111,211,2*-211,-321,-211,2*211,
11202 &-211,111,-211,2*211,0,221,331,333,321,311,221,331,333,321,311,
11203 &20*0,3,0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
11204 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,-421,-423,
11205 &-10423,-10421,-20423,-425,-421,-423,-10423,-10421,-20423,-425,
11206 &-421,-423,16*0,-4,-1,-4,-3,2*-2,-431,-433,-10433,-10431,-20433,
11207 &-435,-431,-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,
11208 &-3,2*-2,3*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,
11209 &533,531,533,3,2,3,2,511,513,511,513,1,2,0,-11,0,2*111,-211,-11,
11210 &11,-13,2*221,3*0,111,27*0,111,2*0,22,111,5*0,111,12*0,2*21,103*0,
11211 &-211,2*111,-211,3*111,-211,111,211,14*0,111,6*0,111,-211,8*0,111,
11212 &-211,9*0,111,-211,111,-211,4*0,111,-211,111,-211,8*0,111,-211,
11213 &111,-211,4*0,111,-211,111,-211,11*0,-211,6*0,111,211,4*0,111/
11214 DATA (kfdp(i,3),i= 945,2000)/13*0,2*111,211,-211,211,-211,7*0,
11215 &-211,111,13*0,2*21,-211,111,6*0,2212,3122,3212,3214,2112,2114,
11216 &2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,8*0,
11217 &3*4122,8*0,4,1,4,3,2*2,3*0,2112,43*0,3322,861*0/
11218 DATA (kfdp(i,4),i= 1,2000)/88*0,3*111,8*0,-211,0,-211,3*0,111,
11219 &2*-211,0,111,0,2*111,113,221,111,-213,-211,211,195*0,13*81,41*0,
11220 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
11221 &-211,2*211,2*-211,2*0,-211,111,-211,111,4*0,-211,111,-211,111,
11222 &34*0,111,-211,3*111,3*-211,2*111,3*-211,4*0,-321,-311,3*0,-321,
11223 &-311,20*0,-3,31*0,6*1,30*0,6*2,33*0,6*3,9*0,8*4,4*0,4*-5,4*0,
11224 &2*-5,7*0,-11,264*0,111,-211,4*0,111,57*0,-211,111,5*0,-211,111,
11225 &52*0,2101,2103,2*2101,19*0,6*2101,909*0/
11226 DATA (kfdp(i,5),i= 1,2000)/90*0,111,16*0,111,7*0,111,0,2*111,
11227 &303*0,-211,2*111,-211,111,-211,111,54*0,111,-211,3*111,-211,111,
11228 &1510*0/
11229
11230C...LUDAT4, with character strings.
11231 DATA (chaf(i) ,i= 1, 281)/'d','u','s','c','b','t','l','h',
11232 &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
11233 &2*' ','g','gamma','Z','W','H',2*' ','reggeon','pomeron',2*' ',
11234 &'Z''','Z"','W''','H''','A','H','eta_tech','LQ_ue','R',40*' ',
11235 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',
11236 &'t-hadron','l-hadron','h-hadron','Wvirt','diquark','cluster',
11237 &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
11238 &'CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B','B_s','B_c',
11239 &'pi','eta','eta''','eta_c','eta_b','eta_t','eta_l','eta_h',2*' ',
11240 &'rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s','B*_c','rho','omega',
11241 &'phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',2*' ','b_1',
11242 &2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s','B_1c','b_1','h_1','h''_1',
11243 &'h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',2*'K*_0',2*'D*_0',
11244 &'D*_0s',2*'B*_0','B*_0s','B*_0c','a_0','f_0','f''_0','chi_0c',
11245 &'chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',2*'K*_1',
11246 &2*'D*_1','D*_1s',2*'B*_1','B*_1s','B*_1c','a_1','f_1','f''_1',
11247 &'chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
11248 &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s','B*_2c','a_2','f_2',
11249 &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
11250 &'K_S',8*' ','psi''',3*' ','Upsilon''',45*' ','pi_diffr'/
11251 DATA (chaf(i) ,i= 282, 500)/'n_diffr','p_diffr','rho_diff',
11252 &'omega_di','phi_diff','J/psi_di',18*' ','Lambda',5*' ',
11253 &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' ','n',
11254 &'p',' ',3*'Sigma',2*'Xi',' ',3*'Sigma_c',2*'Xi''_c','Omega_c',
11255 &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
11256 &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
11257 &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
11258
11259C...LUDATR, with initial values for the random number generator.
11260 DATA mrlu/19780503,0,0,97,33,0/
11261
11262 END
11263
11264