Geant4  9.6.p02
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
jetset74ku.f
Go to the documentation of this file.
1 C*********************************************************************
2 C*********************************************************************
3 C* **
4 C* December 1993 **
5 C* **
6 C* The Lund Monte Carlo for Jet Fragmentation and e+e- Physics **
7 C* **
8 C* JETSET version 7.4 **
9 C* **
10 C* Torbjorn Sjostrand **
11 C* Department of theoretical physics 2 **
12 C* University of Lund **
13 C* Solvegatan 14A, S-223 62 Lund, Sweden **
14 C* E-mail torbjorn@thep.lu.se **
15 C* phone +46 - 46 - 222 48 16 **
16 C* **
17 C* LUSHOW is written together with Mats Bengtsson **
18 C* **
19 C* The latest program version and documentation is found on WWW **
20 C* http://thep.lu.se/tf2/staff/torbjorn/Welcome.html **
21 C* **
22 C* Copyright Torbjorn Sjostrand and CERN, Geneva 1993 **
23 C* **
24 C*********************************************************************
25 C*********************************************************************
26 C *
27 C List of subprograms in order of appearance, with main purpose *
28 C (S = subroutine, F = function, B = block data) *
29 C *
30 C S LU1ENT to fill one entry (= parton or particle) *
31 C S LU2ENT to fill two entries *
32 C S LU3ENT to fill three entries *
33 C S LU4ENT to fill four entries *
34 C S LUJOIN to connect entries with colour flow information *
35 C S LUGIVE to fill (or query) commonblock variables *
36 C S LUEXEC to administrate fragmentation and decay chain *
37 C S LUPREP to rearrange showered partons along strings *
38 C S LUSTRF to do string fragmentation of jet system *
39 C S LUINDF to do independent fragmentation of one or many jets *
40 C S LUDECY to do the decay of a particle *
41 C S LUKFDI to select parton and hadron flavours in fragm *
42 C S LUPTDI to select transverse momenta in fragm *
43 C S LUZDIS to select longitudinal scaling variable in fragm *
44 C S LUSHOW to do timelike parton shower evolution *
45 C S LUBOEI to include Bose-Einstein effects (crudely) *
46 C F ULMASS to give the mass of a particle or parton *
47 C S LUNAME to give the name of a particle or parton *
48 C F LUCHGE to give three times the electric charge *
49 C F LUCOMP to compress standard KF flavour code to internal KC *
50 C S LUERRM to write error messages and abort faulty run *
51 C F ULALEM to give the alpha_electromagnetic value *
52 C F ULALPS to give the alpha_strong value *
53 C F ULANGL to give the angle from known x and y components *
54 C F RLU to provide a random number generator *
55 C S RLUGET to save the state of the random number generator *
56 C S RLUSET to set the state of the random number generator *
57 C S LUROBO to rotate and/or boost an event *
58 C S LUEDIT to remove unwanted entries from record *
59 C S LULIST to list event record or particle data *
60 C S LULOGO to write a logo for JETSET and PYTHIA *
61 C S LUUPDA to update particle data *
62 C F KLU to provide integer-valued event information *
63 C F PLU to provide real-valued event information *
64 C S LUSPHE to perform sphericity analysis *
65 C S LUTHRU to perform thrust analysis *
66 C S LUCLUS to perform three-dimensional cluster analysis *
67 C S LUCELL to perform cluster analysis in (eta, phi, E_T) *
68 C S LUJMAS to give high and low jet mass of event *
69 C S LUFOWO to give Fox-Wolfram moments *
70 C S LUTABU to analyze events, with tabular output *
71 C *
72 C S LUEEVT to administrate the generation of an e+e- event *
73 C S LUXTOT to give the total cross-section at given CM energy *
74 C S LURADK to generate initial state photon radiation *
75 C S LUXKFL to select flavour of primary qqbar pair *
76 C S LUXJET to select (matrix element) jet multiplicity *
77 C S LUX3JT to select kinematics of three-jet event *
78 C S LUX4JT to select kinematics of four-jet event *
79 C S LUXDIF to select angular orientation of event *
80 C S LUONIA to perform generation of onium decay to gluons *
81 C *
82 C S LUHEPC to convert between /LUJETS/ and /HEPEVT/ records *
83 C S LUTEST to test the proper functioning of the package *
84 C B LUDATA to contain default values and particle data *
85 C *
86 C*********************************************************************
87 
88  SUBROUTINE lu1ent(IP,KF,PE,THE,PHI)
89 
90 C...Purpose: to store one parton/particle in commonblock LUJETS.
91  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
92  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
93  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
94  SAVE /lujets/,/ludat1/,/ludat2/
95 
96 C...Standard checks.
97  mstu(28)=0
98  IF(mstu(12).GE.1) CALL lulist(0)
99  ipa=max(1,iabs(ip))
100  IF(ipa.GT.mstu(4)) CALL luerrm(21,
101  &'(LU1ENT:) writing outside LUJETS memory')
102  kc=lucomp(kf)
103  IF(kc.EQ.0) CALL luerrm(12,'(LU1ENT:) unknown flavour code')
104 
105 C...Find mass. Reset K, P and V vectors.
106  pm=0.
107  IF(mstu(10).EQ.1) pm=p(ipa,5)
108  IF(mstu(10).GE.2) pm=ulmass(kf)
109  DO 100 j=1,5
110  k(ipa,j)=0
111  p(ipa,j)=0.
112  v(ipa,j)=0.
113  100 CONTINUE
114 
115 C...Store parton/particle in K and P vectors.
116  k(ipa,1)=1
117  IF(ip.LT.0) k(ipa,1)=2
118  k(ipa,2)=kf
119  p(ipa,5)=pm
120  p(ipa,4)=max(pe,pm)
121  pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)
122  p(ipa,1)=pa*sin(the)*cos(phi)
123  p(ipa,2)=pa*sin(the)*sin(phi)
124  p(ipa,3)=pa*cos(the)
125 
126 C...Set N. Optionally fragment/decay.
127  n=ipa
128  IF(ip.EQ.0) CALL luexec
129 
130  RETURN
131  END
132 
133 C*********************************************************************
134 
135  SUBROUTINE lu2ent(IP,KF1,KF2,PECM)
136 
137 C...Purpose: to store two partons/particles in their CM frame,
138 C...with the first along the +z axis.
139  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
140  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
141  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
142  SAVE /lujets/,/ludat1/,/ludat2/
143 
144 C...Standard checks.
145  mstu(28)=0
146  IF(mstu(12).GE.1) CALL lulist(0)
147  ipa=max(1,iabs(ip))
148  IF(ipa.GT.mstu(4)-1) CALL luerrm(21,
149  &'(LU2ENT:) writing outside LUJETS memory')
150  kc1=lucomp(kf1)
151  kc2=lucomp(kf2)
152  IF(kc1.EQ.0.OR.kc2.EQ.0) CALL luerrm(12,
153  &'(LU2ENT:) unknown flavour code')
154 
155 C...Find masses. Reset K, P and V vectors.
156  pm1=0.
157  IF(mstu(10).EQ.1) pm1=p(ipa,5)
158  IF(mstu(10).GE.2) pm1=ulmass(kf1)
159  pm2=0.
160  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
161  IF(mstu(10).GE.2) pm2=ulmass(kf2)
162  DO 110 i=ipa,ipa+1
163  DO 100 j=1,5
164  k(i,j)=0
165  p(i,j)=0.
166  v(i,j)=0.
167  100 CONTINUE
168  110 CONTINUE
169 
170 C...Check flavours.
171  kq1=kchg(kc1,2)*isign(1,kf1)
172  kq2=kchg(kc2,2)*isign(1,kf2)
173  IF(mstu(19).EQ.1) THEN
174  mstu(19)=0
175  ELSE
176  IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL luerrm(2,
177  & '(LU2ENT:) unphysical flavour combination')
178  ENDIF
179  k(ipa,2)=kf1
180  k(ipa+1,2)=kf2
181 
182 C...Store partons/particles in K vectors for normal case.
183  IF(ip.GE.0) THEN
184  k(ipa,1)=1
185  IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2
186  k(ipa+1,1)=1
187 
188 C...Store partons in K vectors for parton shower evolution.
189  ELSE
190  k(ipa,1)=3
191  k(ipa+1,1)=3
192  k(ipa,4)=mstu(5)*(ipa+1)
193  k(ipa,5)=k(ipa,4)
194  k(ipa+1,4)=mstu(5)*ipa
195  k(ipa+1,5)=k(ipa+1,4)
196  ENDIF
197 
198 C...Check kinematics and store partons/particles in P vectors.
199  IF(pecm.LE.pm1+pm2) CALL luerrm(13,
200  &'(LU2ENT:) energy smaller than sum of masses')
201  pa=sqrt(max(0.,(pecm**2-pm1**2-pm2**2)**2-(2.*pm1*pm2)**2))/
202  &(2.*pecm)
203  p(ipa,3)=pa
204  p(ipa,4)=sqrt(pm1**2+pa**2)
205  p(ipa,5)=pm1
206  p(ipa+1,3)=-pa
207  p(ipa+1,4)=sqrt(pm2**2+pa**2)
208  p(ipa+1,5)=pm2
209 
210 C...Set N. Optionally fragment/decay.
211  n=ipa+1
212  IF(ip.EQ.0) CALL luexec
213 
214  RETURN
215  END
216 
217 C*********************************************************************
218 
219  SUBROUTINE lu3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
220 
221 C...Purpose: to store three partons or particles in their CM frame,
222 C...with the first along the +z axis and the third in the (x,z)
223 C...plane with x > 0.
224  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
225  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
226  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
227  SAVE /lujets/,/ludat1/,/ludat2/
228 
229 C...Standard checks.
230  mstu(28)=0
231  IF(mstu(12).GE.1) CALL lulist(0)
232  ipa=max(1,iabs(ip))
233  IF(ipa.GT.mstu(4)-2) CALL luerrm(21,
234  &'(LU3ENT:) writing outside LUJETS memory')
235  kc1=lucomp(kf1)
236  kc2=lucomp(kf2)
237  kc3=lucomp(kf3)
238  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL luerrm(12,
239  &'(LU3ENT:) unknown flavour code')
240 
241 C...Find masses. Reset K, P and V vectors.
242  pm1=0.
243  IF(mstu(10).EQ.1) pm1=p(ipa,5)
244  IF(mstu(10).GE.2) pm1=ulmass(kf1)
245  pm2=0.
246  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
247  IF(mstu(10).GE.2) pm2=ulmass(kf2)
248  pm3=0.
249  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
250  IF(mstu(10).GE.2) pm3=ulmass(kf3)
251  DO 110 i=ipa,ipa+2
252  DO 100 j=1,5
253  k(i,j)=0
254  p(i,j)=0.
255  v(i,j)=0.
256  100 CONTINUE
257  110 CONTINUE
258 
259 C...Check flavours.
260  kq1=kchg(kc1,2)*isign(1,kf1)
261  kq2=kchg(kc2,2)*isign(1,kf2)
262  kq3=kchg(kc3,2)*isign(1,kf3)
263  IF(mstu(19).EQ.1) THEN
264  mstu(19)=0
265  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN
266  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.
267  &kq1+kq3.EQ.4)) THEN
268  ELSE
269  CALL luerrm(2,'(LU3ENT:) unphysical flavour combination')
270  ENDIF
271  k(ipa,2)=kf1
272  k(ipa+1,2)=kf2
273  k(ipa+2,2)=kf3
274 
275 C...Store partons/particles in K vectors for normal case.
276  IF(ip.GE.0) THEN
277  k(ipa,1)=1
278  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2
279  k(ipa+1,1)=1
280  IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2
281  k(ipa+2,1)=1
282 
283 C...Store partons in K vectors for parton shower evolution.
284  ELSE
285  k(ipa,1)=3
286  k(ipa+1,1)=3
287  k(ipa+2,1)=3
288  kcs=4
289  IF(kq1.EQ.-1) kcs=5
290  k(ipa,kcs)=mstu(5)*(ipa+1)
291  k(ipa,9-kcs)=mstu(5)*(ipa+2)
292  k(ipa+1,kcs)=mstu(5)*(ipa+2)
293  k(ipa+1,9-kcs)=mstu(5)*ipa
294  k(ipa+2,kcs)=mstu(5)*ipa
295  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
296  ENDIF
297 
298 C...Check kinematics.
299  mkerr=0
300  IF(0.5*x1*pecm.LE.pm1.OR.0.5*(2.-x1-x3)*pecm.LE.pm2.OR.
301  &0.5*x3*pecm.LE.pm3) mkerr=1
302  pa1=sqrt(max(1e-10,(0.5*x1*pecm)**2-pm1**2))
303  pa2=sqrt(max(1e-10,(0.5*(2.-x1-x3)*pecm)**2-pm2**2))
304  pa3=sqrt(max(1e-10,(0.5*x3*pecm)**2-pm3**2))
305  cthe2=(pa3**2-pa1**2-pa2**2)/(2.*pa1*pa2)
306  cthe3=(pa2**2-pa1**2-pa3**2)/(2.*pa1*pa3)
307  IF(abs(cthe2).GE.1.001.OR.abs(cthe3).GE.1.001) mkerr=1
308  cthe3=max(-1.,min(1.,cthe3))
309  IF(mkerr.NE.0) CALL luerrm(13,
310  &'(LU3ENT:) unphysical kinematical variable setup')
311 
312 C...Store partons/particles in P vectors.
313  p(ipa,3)=pa1
314  p(ipa,4)=sqrt(pa1**2+pm1**2)
315  p(ipa,5)=pm1
316  p(ipa+2,1)=pa3*sqrt(1.-cthe3**2)
317  p(ipa+2,3)=pa3*cthe3
318  p(ipa+2,4)=sqrt(pa3**2+pm3**2)
319  p(ipa+2,5)=pm3
320  p(ipa+1,1)=-p(ipa+2,1)
321  p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)
322  p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)
323  p(ipa+1,5)=pm2
324 
325 C...Set N. Optionally fragment/decay.
326  n=ipa+2
327  IF(ip.EQ.0) CALL luexec
328 
329  RETURN
330  END
331 
332 C*********************************************************************
333 
334  SUBROUTINE lu4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
335 
336 C...Purpose: to store four partons or particles in their CM frame, with
337 C...the first along the +z axis, the last in the xz plane with x > 0
338 C...and the second having y < 0 and y > 0 with equal probability.
339  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
340  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
341  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
342  SAVE /lujets/,/ludat1/,/ludat2/
343 
344 C...Standard checks.
345  mstu(28)=0
346  IF(mstu(12).GE.1) CALL lulist(0)
347  ipa=max(1,iabs(ip))
348  IF(ipa.GT.mstu(4)-3) CALL luerrm(21,
349  &'(LU4ENT:) writing outside LUJETS momory')
350  kc1=lucomp(kf1)
351  kc2=lucomp(kf2)
352  kc3=lucomp(kf3)
353  kc4=lucomp(kf4)
354  IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL luerrm(12,
355  &'(LU4ENT:) unknown flavour code')
356 
357 C...Find masses. Reset K, P and V vectors.
358  pm1=0.
359  IF(mstu(10).EQ.1) pm1=p(ipa,5)
360  IF(mstu(10).GE.2) pm1=ulmass(kf1)
361  pm2=0.
362  IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
363  IF(mstu(10).GE.2) pm2=ulmass(kf2)
364  pm3=0.
365  IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
366  IF(mstu(10).GE.2) pm3=ulmass(kf3)
367  pm4=0.
368  IF(mstu(10).EQ.1) pm4=p(ipa+3,5)
369  IF(mstu(10).GE.2) pm4=ulmass(kf4)
370  DO 110 i=ipa,ipa+3
371  DO 100 j=1,5
372  k(i,j)=0
373  p(i,j)=0.
374  v(i,j)=0.
375  100 CONTINUE
376  110 CONTINUE
377 
378 C...Check flavours.
379  kq1=kchg(kc1,2)*isign(1,kf1)
380  kq2=kchg(kc2,2)*isign(1,kf2)
381  kq3=kchg(kc3,2)*isign(1,kf3)
382  kq4=kchg(kc4,2)*isign(1,kf4)
383  IF(mstu(19).EQ.1) THEN
384  mstu(19)=0
385  ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN
386  ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.
387  &kq1+kq4.EQ.4)) THEN
388  ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0.)
389  &THEN
390  ELSE
391  CALL luerrm(2,'(LU4ENT:) unphysical flavour combination')
392  ENDIF
393  k(ipa,2)=kf1
394  k(ipa+1,2)=kf2
395  k(ipa+2,2)=kf3
396  k(ipa+3,2)=kf4
397 
398 C...Store partons/particles in K vectors for normal case.
399  IF(ip.GE.0) THEN
400  k(ipa,1)=1
401  IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2
402  k(ipa+1,1)=1
403  IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))
404  & k(ipa+1,1)=2
405  k(ipa+2,1)=1
406  IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2
407  k(ipa+3,1)=1
408 
409 C...Store partons for parton shower evolution from q-g-g-qbar or
410 C...g-g-g-g event.
411  ELSEIF(kq1+kq2.NE.0) THEN
412  k(ipa,1)=3
413  k(ipa+1,1)=3
414  k(ipa+2,1)=3
415  k(ipa+3,1)=3
416  kcs=4
417  IF(kq1.EQ.-1) kcs=5
418  k(ipa,kcs)=mstu(5)*(ipa+1)
419  k(ipa,9-kcs)=mstu(5)*(ipa+3)
420  k(ipa+1,kcs)=mstu(5)*(ipa+2)
421  k(ipa+1,9-kcs)=mstu(5)*ipa
422  k(ipa+2,kcs)=mstu(5)*(ipa+3)
423  k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
424  k(ipa+3,kcs)=mstu(5)*ipa
425  k(ipa+3,9-kcs)=mstu(5)*(ipa+2)
426 
427 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
428  ELSE
429  k(ipa,1)=3
430  k(ipa+1,1)=3
431  k(ipa+2,1)=3
432  k(ipa+3,1)=3
433  k(ipa,4)=mstu(5)*(ipa+1)
434  k(ipa,5)=k(ipa,4)
435  k(ipa+1,4)=mstu(5)*ipa
436  k(ipa+1,5)=k(ipa+1,4)
437  k(ipa+2,4)=mstu(5)*(ipa+3)
438  k(ipa+2,5)=k(ipa+2,4)
439  k(ipa+3,4)=mstu(5)*(ipa+2)
440  k(ipa+3,5)=k(ipa+3,4)
441  ENDIF
442 
443 C...Check kinematics.
444  mkerr=0
445  IF(0.5*x1*pecm.LE.pm1.OR.0.5*x2*pecm.LE.pm2.OR.0.5*(2.-x1-x2-x4)*
446  &pecm.LE.pm3.OR.0.5*x4*pecm.LE.pm4) mkerr=1
447  pa1=sqrt(max(1e-10,(0.5*x1*pecm)**2-pm1**2))
448  pa2=sqrt(max(1e-10,(0.5*x2*pecm)**2-pm2**2))
449  pa4=sqrt(max(1e-10,(0.5*x4*pecm)**2-pm4**2))
450  x24=x1+x2+x4-1.-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2
451  cthe4=(x1*x4-2.*x14)*pecm**2/(4.*pa1*pa4)
452  IF(abs(cthe4).GE.1.002) mkerr=1
453  cthe4=max(-1.,min(1.,cthe4))
454  sthe4=sqrt(1.-cthe4**2)
455  cthe2=(x1*x2-2.*x12)*pecm**2/(4.*pa1*pa2)
456  IF(abs(cthe2).GE.1.002) mkerr=1
457  cthe2=max(-1.,min(1.,cthe2))
458  sthe2=sqrt(1.-cthe2**2)
459  cphi2=((x2*x4-2.*x24)*pecm**2-4.*pa2*cthe2*pa4*cthe4)/
460  &max(1e-8*pecm**2,4.*pa2*sthe2*pa4*sthe4)
461  IF(abs(cphi2).GE.1.05) mkerr=1
462  cphi2=max(-1.,min(1.,cphi2))
463  IF(mkerr.EQ.1) CALL luerrm(13,
464  &'(LU4ENT:) unphysical kinematical variable setup')
465 
466 C...Store partons/particles in P vectors.
467  p(ipa,3)=pa1
468  p(ipa,4)=sqrt(pa1**2+pm1**2)
469  p(ipa,5)=pm1
470  p(ipa+3,1)=pa4*sthe4
471  p(ipa+3,3)=pa4*cthe4
472  p(ipa+3,4)=sqrt(pa4**2+pm4**2)
473  p(ipa+3,5)=pm4
474  p(ipa+1,1)=pa2*sthe2*cphi2
475  p(ipa+1,2)=pa2*sthe2*sqrt(1.-cphi2**2)*(-1.)**int(rlu(0)+0.5)
476  p(ipa+1,3)=pa2*cthe2
477  p(ipa+1,4)=sqrt(pa2**2+pm2**2)
478  p(ipa+1,5)=pm2
479  p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)
480  p(ipa+2,2)=-p(ipa+1,2)
481  p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)
482  p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)
483  p(ipa+2,5)=pm3
484 
485 C...Set N. Optionally fragment/decay.
486  n=ipa+3
487  IF(ip.EQ.0) CALL luexec
488 
489  RETURN
490  END
491 
492 C*********************************************************************
493 
494  SUBROUTINE lujoin(NJOIN,IJOIN)
495 
496 C...Purpose: to connect a sequence of partons with colour flow indices,
497 C...as required for subsequent shower evolution (or other operations).
498  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
499  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
500  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
501  SAVE /lujets/,/ludat1/,/ludat2/
502  dimension ijoin(*)
503 
504 C...Check that partons are of right types to be connected.
505  IF(njoin.LT.2) goto 120
506  kqsum=0
507  DO 100 ijn=1,njoin
508  i=ijoin(ijn)
509  IF(i.LE.0.OR.i.GT.n) goto 120
510  IF(k(i,1).LT.1.OR.k(i,1).GT.3) goto 120
511  kc=lucomp(k(i,2))
512  IF(kc.EQ.0) goto 120
513  kq=kchg(kc,2)*isign(1,k(i,2))
514  IF(kq.EQ.0) goto 120
515  IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) goto 120
516  IF(kq.NE.2) kqsum=kqsum+kq
517  IF(ijn.EQ.1) kqs=kq
518  100 CONTINUE
519  IF(kqsum.NE.0) goto 120
520 
521 C...Connect the partons sequentially (closing for gluon loop).
522  kcs=(9-kqs)/2
523  IF(kqs.EQ.2) kcs=int(4.5+rlu(0))
524  DO 110 ijn=1,njoin
525  i=ijoin(ijn)
526  k(i,1)=3
527  IF(ijn.NE.1) ip=ijoin(ijn-1)
528  IF(ijn.EQ.1) ip=ijoin(njoin)
529  IF(ijn.NE.njoin) in=ijoin(ijn+1)
530  IF(ijn.EQ.njoin) in=ijoin(1)
531  k(i,kcs)=mstu(5)*in
532  k(i,9-kcs)=mstu(5)*ip
533  IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0
534  IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0
535  110 CONTINUE
536 
537 C...Error exit: no action taken.
538  RETURN
539  120 CALL luerrm(12,
540  &'(LUJOIN:) given entries can not be joined by one string')
541 
542  RETURN
543  END
544 
545 C*********************************************************************
546 
547  SUBROUTINE lugive(CHIN)
548 
549 C...Purpose: to set values of commonblock variables (also in PYTHIA!).
550  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
551  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
552  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
553  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
554  common/ludat4/chaf(500)
555  CHARACTER chaf*8
556  common/ludatr/mrlu(6),rrlu(100)
557  common/pysubs/msel,msub(200),kfin(2,-40:40),ckin(200)
558  common/pypars/mstp(200),parp(200),msti(200),pari(200)
559  common/pyint1/mint(400),vint(400)
560  common/pyint2/iset(200),kfpr(200,2),coef(200,20),icol(40,4,2)
561  common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
562  common/pyint4/widp(21:40,0:40),wide(21:40,0:40),wids(21:40,3)
563  common/pyint5/ngen(0:200,3),xsec(0:200,3)
564  common/pyint6/proc(0:200)
565  common/pyint7/sigt(0:6,0:6,0:5)
566  CHARACTER proc*28
567  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/,/ludat4/,/ludatr/
568  SAVE /pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,
569  &/pyint5/,/pyint6/,/pyint7/
570  CHARACTER chin*(*),chfix*104,chbit*104,chold*8,chnew*8,chold2*28,
571  &chnew2*28,chnam*4,chvar(43)*4,chalp(2)*26,chind*8,chini*10,
572  &chinr*16
573  dimension msvar(43,8)
574 
575 C...For each variable to be translated give: name,
576 C...integer/real/character, no. of indices, lower&upper index bounds.
577  DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
578  &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRLU',
579  &'RRLU','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
580  &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
581  &'WIDP','WIDE','WIDS','NGEN','XSEC','PROC','SIGT'/
582  DATA ((msvar(i,j),j=1,8),i=1,43)/ 1,7*0, 1,2,1,4000,1,5,2*0,
583  & 2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
584  & 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
585  & 1,2,1,500,1,3,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
586  & 2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,2000,1,2,2*0,
587  & 2,1,1,2000,4*0, 1,2,1,2000,1,5,2*0, 3,1,1,500,4*0,
588  & 1,1,1,6,4*0, 2,1,1,100,4*0,
589  & 1,7*0, 1,1,1,200,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
590  & 1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
591  & 1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,200,4*0,
592  & 1,2,1,200,1,2,2*0, 2,2,1,200,1,20,2*0, 1,3,1,40,1,4,1,2,
593  & 2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
594  & 2,2,21,40,0,40,2*0, 2,2,21,40,0,40,2*0, 2,2,21,40,1,3,2*0,
595  & 1,2,0,200,1,3,2*0, 2,2,0,200,1,3,2*0, 4,1,0,200,4*0,
596  & 2,3,0,6,0,6,0,5/
597  DATA chalp/'abcdefghijklmnopqrstuvwxyz',
598  &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
599 
600 C...Length of character variable. Subdivide it into instructions.
601  IF(mstu(12).GE.1) CALL lulist(0)
602  chbit=chin//' '
603  lbit=101
604  100 lbit=lbit-1
605  IF(chbit(lbit:lbit).EQ.' ') goto 100
606  ltot=0
607  DO 110 lcom=1,lbit
608  IF(chbit(lcom:lcom).EQ.' ') goto 110
609  ltot=ltot+1
610  chfix(ltot:ltot)=chbit(lcom:lcom)
611  110 CONTINUE
612  llow=0
613  120 lhig=llow+1
614  130 lhig=lhig+1
615  IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') goto 130
616  lbit=lhig-llow-1
617  chbit(1:lbit)=chfix(llow+1:lhig-1)
618 
619 C...Identify commonblock variable.
620  lnam=1
621  140 lnam=lnam+1
622  IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.
623  &lnam.LE.4) goto 140
624  chnam=chbit(1:lnam-1)//' '
625  DO 160 lcom=1,lnam-1
626  DO 150 lalp=1,26
627  IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=
628  &chalp(2)(lalp:lalp)
629  150 CONTINUE
630  160 CONTINUE
631  ivar=0
632  DO 170 iv=1,43
633  IF(chnam.EQ.chvar(iv)) ivar=iv
634  170 CONTINUE
635  IF(ivar.EQ.0) THEN
636  CALL luerrm(18,'(LUGIVE:) do not recognize variable '//chnam)
637  llow=lhig
638  IF(llow.LT.ltot) goto 120
639  RETURN
640  ENDIF
641 
642 C...Identify any indices.
643  i1=0
644  i2=0
645  i3=0
646  nindx=0
647  IF(chbit(lnam:lnam).EQ.'(') THEN
648  lind=lnam
649  180 lind=lind+1
650  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 180
651  chind=' '
652  IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c').
653  & and.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17)) THEN
654  chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)
655  READ(chind,'(I8)') kf
656  i1=lucomp(kf)
657  ELSEIF(chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.
658  & 'c') THEN
659  CALL luerrm(18,'(LUGIVE:) not allowed to use C index for '//
660  & chnam)
661  llow=lhig
662  IF(llow.LT.ltot) goto 120
663  RETURN
664  ELSE
665  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
666  READ(chind,'(I8)') i1
667  ENDIF
668  lnam=lind
669  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
670  nindx=1
671  ENDIF
672  IF(chbit(lnam:lnam).EQ.',') THEN
673  lind=lnam
674  190 lind=lind+1
675  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 190
676  chind=' '
677  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
678  READ(chind,'(I8)') i2
679  lnam=lind
680  IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
681  nindx=2
682  ENDIF
683  IF(chbit(lnam:lnam).EQ.',') THEN
684  lind=lnam
685  200 lind=lind+1
686  IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 200
687  chind=' '
688  chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
689  READ(chind,'(I8)') i3
690  lnam=lind+1
691  nindx=3
692  ENDIF
693 
694 C...Check that indices allowed.
695  ierr=0
696  IF(nindx.NE.msvar(ivar,2)) ierr=1
697  IF(nindx.GE.1.AND.(i1.LT.msvar(ivar,3).OR.i1.GT.msvar(ivar,4)))
698  &ierr=2
699  IF(nindx.GE.2.AND.(i2.LT.msvar(ivar,5).OR.i2.GT.msvar(ivar,6)))
700  &ierr=3
701  IF(nindx.EQ.3.AND.(i3.LT.msvar(ivar,7).OR.i3.GT.msvar(ivar,8)))
702  &ierr=4
703  IF(chbit(lnam:lnam).NE.'=') ierr=5
704  IF(ierr.GE.1) THEN
705  CALL luerrm(18,'(LUGIVE:) unallowed indices for '//
706  & chbit(1:lnam-1))
707  llow=lhig
708  IF(llow.LT.ltot) goto 120
709  RETURN
710  ENDIF
711 
712 C...Save old value of variable.
713  IF(ivar.EQ.1) THEN
714  iold=n
715  ELSEIF(ivar.EQ.2) THEN
716  iold=k(i1,i2)
717  ELSEIF(ivar.EQ.3) THEN
718  rold=p(i1,i2)
719  ELSEIF(ivar.EQ.4) THEN
720  rold=v(i1,i2)
721  ELSEIF(ivar.EQ.5) THEN
722  iold=mstu(i1)
723  ELSEIF(ivar.EQ.6) THEN
724  rold=paru(i1)
725  ELSEIF(ivar.EQ.7) THEN
726  iold=mstj(i1)
727  ELSEIF(ivar.EQ.8) THEN
728  rold=parj(i1)
729  ELSEIF(ivar.EQ.9) THEN
730  iold=kchg(i1,i2)
731  ELSEIF(ivar.EQ.10) THEN
732  rold=pmas(i1,i2)
733  ELSEIF(ivar.EQ.11) THEN
734  rold=parf(i1)
735  ELSEIF(ivar.EQ.12) THEN
736  rold=vckm(i1,i2)
737  ELSEIF(ivar.EQ.13) THEN
738  iold=mdcy(i1,i2)
739  ELSEIF(ivar.EQ.14) THEN
740  iold=mdme(i1,i2)
741  ELSEIF(ivar.EQ.15) THEN
742  rold=brat(i1)
743  ELSEIF(ivar.EQ.16) THEN
744  iold=kfdp(i1,i2)
745  ELSEIF(ivar.EQ.17) THEN
746  chold=chaf(i1)
747  ELSEIF(ivar.EQ.18) THEN
748  iold=mrlu(i1)
749  ELSEIF(ivar.EQ.19) THEN
750  rold=rrlu(i1)
751  ELSEIF(ivar.EQ.20) THEN
752  iold=msel
753  ELSEIF(ivar.EQ.21) THEN
754  iold=msub(i1)
755  ELSEIF(ivar.EQ.22) THEN
756  iold=kfin(i1,i2)
757  ELSEIF(ivar.EQ.23) THEN
758  rold=ckin(i1)
759  ELSEIF(ivar.EQ.24) THEN
760  iold=mstp(i1)
761  ELSEIF(ivar.EQ.25) THEN
762  rold=parp(i1)
763  ELSEIF(ivar.EQ.26) THEN
764  iold=msti(i1)
765  ELSEIF(ivar.EQ.27) THEN
766  rold=pari(i1)
767  ELSEIF(ivar.EQ.28) THEN
768  iold=mint(i1)
769  ELSEIF(ivar.EQ.29) THEN
770  rold=vint(i1)
771  ELSEIF(ivar.EQ.30) THEN
772  iold=iset(i1)
773  ELSEIF(ivar.EQ.31) THEN
774  iold=kfpr(i1,i2)
775  ELSEIF(ivar.EQ.32) THEN
776  rold=coef(i1,i2)
777  ELSEIF(ivar.EQ.33) THEN
778  iold=icol(i1,i2,i3)
779  ELSEIF(ivar.EQ.34) THEN
780  rold=xsfx(i1,i2)
781  ELSEIF(ivar.EQ.35) THEN
782  iold=isig(i1,i2)
783  ELSEIF(ivar.EQ.36) THEN
784  rold=sigh(i1)
785  ELSEIF(ivar.EQ.37) THEN
786  rold=widp(i1,i2)
787  ELSEIF(ivar.EQ.38) THEN
788  rold=wide(i1,i2)
789  ELSEIF(ivar.EQ.39) THEN
790  rold=wids(i1,i2)
791  ELSEIF(ivar.EQ.40) THEN
792  iold=ngen(i1,i2)
793  ELSEIF(ivar.EQ.41) THEN
794  rold=xsec(i1,i2)
795  ELSEIF(ivar.EQ.42) THEN
796  chold2=proc(i1)
797  ELSEIF(ivar.EQ.43) THEN
798  rold=sigt(i1,i2,i3)
799  ENDIF
800 
801 C...Print current value of variable. Loop back.
802  IF(lnam.GE.lbit) THEN
803  chbit(lnam:14)=' '
804  chbit(15:60)=' has the value '
805  IF(msvar(ivar,1).EQ.1) THEN
806  WRITE(chbit(51:60),'(I10)') iold
807  ELSEIF(msvar(ivar,1).EQ.2) THEN
808  WRITE(chbit(47:60),'(F14.5)') rold
809  ELSEIF(msvar(ivar,1).EQ.3) THEN
810  chbit(53:60)=chold
811  ELSE
812  chbit(33:60)=chold
813  ENDIF
814  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
815  llow=lhig
816  IF(llow.LT.ltot) goto 120
817  RETURN
818  ENDIF
819 
820 C...Read in new variable value.
821  IF(msvar(ivar,1).EQ.1) THEN
822  chini=' '
823  chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)
824  READ(chini,'(I10)') inew
825  ELSEIF(msvar(ivar,1).EQ.2) THEN
826  chinr=' '
827  chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)
828  READ(chinr,'(F16.2)') rnew
829  ELSEIF(msvar(ivar,1).EQ.3) THEN
830  chnew=chbit(lnam+1:lbit)//' '
831  ELSE
832  chnew2=chbit(lnam+1:lbit)//' '
833  ENDIF
834 
835 C...Store new variable value.
836  IF(ivar.EQ.1) THEN
837  n=inew
838  ELSEIF(ivar.EQ.2) THEN
839  k(i1,i2)=inew
840  ELSEIF(ivar.EQ.3) THEN
841  p(i1,i2)=rnew
842  ELSEIF(ivar.EQ.4) THEN
843  v(i1,i2)=rnew
844  ELSEIF(ivar.EQ.5) THEN
845  mstu(i1)=inew
846  ELSEIF(ivar.EQ.6) THEN
847  paru(i1)=rnew
848  ELSEIF(ivar.EQ.7) THEN
849  mstj(i1)=inew
850  ELSEIF(ivar.EQ.8) THEN
851  parj(i1)=rnew
852  ELSEIF(ivar.EQ.9) THEN
853  kchg(i1,i2)=inew
854  ELSEIF(ivar.EQ.10) THEN
855  pmas(i1,i2)=rnew
856  ELSEIF(ivar.EQ.11) THEN
857  parf(i1)=rnew
858  ELSEIF(ivar.EQ.12) THEN
859  vckm(i1,i2)=rnew
860  ELSEIF(ivar.EQ.13) THEN
861  mdcy(i1,i2)=inew
862  ELSEIF(ivar.EQ.14) THEN
863  mdme(i1,i2)=inew
864  ELSEIF(ivar.EQ.15) THEN
865  brat(i1)=rnew
866  ELSEIF(ivar.EQ.16) THEN
867  kfdp(i1,i2)=inew
868  ELSEIF(ivar.EQ.17) THEN
869  chaf(i1)=chnew
870  ELSEIF(ivar.EQ.18) THEN
871  mrlu(i1)=inew
872  ELSEIF(ivar.EQ.19) THEN
873  rrlu(i1)=rnew
874  ELSEIF(ivar.EQ.20) THEN
875  msel=inew
876  ELSEIF(ivar.EQ.21) THEN
877  msub(i1)=inew
878  ELSEIF(ivar.EQ.22) THEN
879  kfin(i1,i2)=inew
880  ELSEIF(ivar.EQ.23) THEN
881  ckin(i1)=rnew
882  ELSEIF(ivar.EQ.24) THEN
883  mstp(i1)=inew
884  ELSEIF(ivar.EQ.25) THEN
885  parp(i1)=rnew
886  ELSEIF(ivar.EQ.26) THEN
887  msti(i1)=inew
888  ELSEIF(ivar.EQ.27) THEN
889  pari(i1)=rnew
890  ELSEIF(ivar.EQ.28) THEN
891  mint(i1)=inew
892  ELSEIF(ivar.EQ.29) THEN
893  vint(i1)=rnew
894  ELSEIF(ivar.EQ.30) THEN
895  iset(i1)=inew
896  ELSEIF(ivar.EQ.31) THEN
897  kfpr(i1,i2)=inew
898  ELSEIF(ivar.EQ.32) THEN
899  coef(i1,i2)=rnew
900  ELSEIF(ivar.EQ.33) THEN
901  icol(i1,i2,i3)=inew
902  ELSEIF(ivar.EQ.34) THEN
903  xsfx(i1,i2)=rnew
904  ELSEIF(ivar.EQ.35) THEN
905  isig(i1,i2)=inew
906  ELSEIF(ivar.EQ.36) THEN
907  sigh(i1)=rnew
908  ELSEIF(ivar.EQ.37) THEN
909  widp(i1,i2)=rnew
910  ELSEIF(ivar.EQ.38) THEN
911  wide(i1,i2)=rnew
912  ELSEIF(ivar.EQ.39) THEN
913  wids(i1,i2)=rnew
914  ELSEIF(ivar.EQ.40) THEN
915  ngen(i1,i2)=inew
916  ELSEIF(ivar.EQ.41) THEN
917  xsec(i1,i2)=rnew
918  ELSEIF(ivar.EQ.42) THEN
919  proc(i1)=chnew2
920  ELSEIF(ivar.EQ.43) THEN
921  sigt(i1,i2,i3)=rnew
922  ENDIF
923 
924 C...Write old and new value. Loop back.
925  chbit(lnam:14)=' '
926  chbit(15:60)=' changed from to '
927  IF(msvar(ivar,1).EQ.1) THEN
928  WRITE(chbit(33:42),'(I10)') iold
929  WRITE(chbit(51:60),'(I10)') inew
930  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
931  ELSEIF(msvar(ivar,1).EQ.2) THEN
932  WRITE(chbit(29:42),'(F14.5)') rold
933  WRITE(chbit(47:60),'(F14.5)') rnew
934  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
935  ELSEIF(msvar(ivar,1).EQ.3) THEN
936  chbit(35:42)=chold
937  chbit(53:60)=chnew
938  IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
939  ELSE
940  chbit(15:88)=' changed from '//chold2//' to '//chnew2
941  IF(mstu(13).GE.1) WRITE(mstu(11),5100) chbit(1:88)
942  ENDIF
943  llow=lhig
944  IF(llow.LT.ltot) goto 120
945 
946 C...Format statement for output on unit MSTU(11) (by default 6).
947  5000 FORMAT(5x,a60)
948  5100 FORMAT(5x,a88)
949 
950  RETURN
951  END
952 
953 C*********************************************************************
954 
955  SUBROUTINE luexec
956 
957 C...Purpose: to administrate the fragmentation and decay chain.
958  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
959  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
960  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
961  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
962  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
963  dimension ps(2,6)
964 
965 C...Initialize and reset.
966  mstu(24)=0
967  IF(mstu(12).GE.1) CALL lulist(0)
968  mstu(31)=mstu(31)+1
969  mstu(1)=0
970  mstu(2)=0
971  mstu(3)=0
972  IF(mstu(17).LE.0) mstu(90)=0
973  mcons=1
974 
975 C...Sum up momentum, energy and charge for starting entries.
976  nsav=n
977  DO 110 i=1,2
978  DO 100 j=1,6
979  ps(i,j)=0.
980  100 CONTINUE
981  110 CONTINUE
982  DO 130 i=1,n
983  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 130
984  DO 120 j=1,4
985  ps(1,j)=ps(1,j)+p(i,j)
986  120 CONTINUE
987  ps(1,6)=ps(1,6)+luchge(k(i,2))
988  130 CONTINUE
989  paru(21)=ps(1,4)
990 
991 C...Prepare system for subsequent fragmentation/decay.
992  CALL luprep(0)
993 
994 C...Loop through jet fragmentation and particle decays.
995  mbe=0
996  140 mbe=mbe+1
997  ip=0
998  150 ip=ip+1
999  kc=0
1000  IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=lucomp(k(ip,2))
1001  IF(kc.EQ.0) THEN
1002 
1003 C...Particle decay if unstable and allowed. Save long-lived particle
1004 C...decays until second pass after Bose-Einstein effects.
1005  ELSEIF(kchg(kc,2).EQ.0) THEN
1006  IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe
1007  & .EQ.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))
1008  & CALL ludecy(ip)
1009 
1010 C...Decay products may develop a shower.
1011  IF(mstj(92).GT.0) THEN
1012  ip1=mstj(92)
1013  qmax=sqrt(max(0.,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,
1014  & 1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))
1015  CALL lushow(ip1,ip1+1,qmax)
1016  CALL luprep(ip1)
1017  mstj(92)=0
1018  ELSEIF(mstj(92).LT.0) THEN
1019  ip1=-mstj(92)
1020  CALL lushow(ip1,-3,p(ip,5))
1021  CALL luprep(ip1)
1022  mstj(92)=0
1023  ENDIF
1024 
1025 C...Jet fragmentation: string or independent fragmentation.
1026  ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN
1027  mfrag=mstj(1)
1028  IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2
1029  IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN
1030  IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.
1031  & k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN
1032  IF(kchg(lucomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)
1033  ENDIF
1034  ENDIF
1035  IF(mfrag.EQ.1) CALL lustrf(ip)
1036  IF(mfrag.EQ.2) CALL luindf(ip)
1037  IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0
1038  IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0
1039  ENDIF
1040 
1041 C...Loop back if enough space left in LUJETS and no error abort.
1042  IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN
1043  ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN
1044  goto 150
1045  ELSEIF(ip.LT.n) THEN
1046  CALL luerrm(11,'(LUEXEC:) no more memory left in LUJETS')
1047  ENDIF
1048 
1049 C...Include simple Bose-Einstein effect parametrization if desired.
1050  IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN
1051  CALL luboei(nsav)
1052  goto 140
1053  ENDIF
1054 
1055 C...Check that momentum, energy and charge were conserved.
1056  DO 170 i=1,n
1057  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 170
1058  DO 160 j=1,4
1059  ps(2,j)=ps(2,j)+p(i,j)
1060  160 CONTINUE
1061  ps(2,6)=ps(2,6)+luchge(k(i,2))
1062  170 CONTINUE
1063  pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-
1064  &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1.+abs(ps(2,4))+abs(ps(1,4)))
1065  IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL luerrm(15,
1066  &'(LUEXEC:) four-momentum was not conserved')
1067  IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1) CALL luerrm(15,
1068  &'(LUEXEC:) charge was not conserved')
1069 
1070  RETURN
1071  END
1072 
1073 C*********************************************************************
1074 
1075  SUBROUTINE luprep(IP)
1076 
1077 C...Purpose: to rearrange partons along strings, to allow small systems
1078 C...to collapse into one or two particles and to check flavours.
1079  IMPLICIT DOUBLE PRECISION(d)
1080  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1081  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1082  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1083  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
1084  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
1085  dimension dps(5),dpc(5),ue(3)
1086 
1087 C...Rearrange parton shower product listing along strings: begin loop.
1088  i1=n
1089  DO 130 mqgst=1,2
1090  DO 120 i=max(1,ip),n
1091  IF(k(i,1).NE.3) goto 120
1092  kc=lucomp(k(i,2))
1093  IF(kc.EQ.0) goto 120
1094  kq=kchg(kc,2)
1095  IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) goto 120
1096 
1097 C...Pick up loose string end.
1098  kcs=4
1099  IF(kq*isign(1,k(i,2)).LT.0) kcs=5
1100  ia=i
1101  nstp=0
1102  100 nstp=nstp+1
1103  IF(nstp.GT.4*n) THEN
1104  CALL luerrm(14,'(LUPREP:) caught in infinite loop')
1105  RETURN
1106  ENDIF
1107 
1108 C...Copy undecayed parton.
1109  IF(k(ia,1).EQ.3) THEN
1110  IF(i1.GE.mstu(4)-mstu(32)-5) THEN
1111  CALL luerrm(11,'(LUPREP:) no more memory left in LUJETS')
1112  RETURN
1113  ENDIF
1114  i1=i1+1
1115  k(i1,1)=2
1116  IF(nstp.GE.2.AND.iabs(k(ia,2)).NE.21) k(i1,1)=1
1117  k(i1,2)=k(ia,2)
1118  k(i1,3)=ia
1119  k(i1,4)=0
1120  k(i1,5)=0
1121  DO 110 j=1,5
1122  p(i1,j)=p(ia,j)
1123  v(i1,j)=v(ia,j)
1124  110 CONTINUE
1125  k(ia,1)=k(ia,1)+10
1126  IF(k(i1,1).EQ.1) goto 120
1127  ENDIF
1128 
1129 C...Go to next parton in colour space.
1130  ib=ia
1131  IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5))
1132  &.NE.0) THEN
1133  ia=mod(k(ib,kcs),mstu(5))
1134  k(ib,kcs)=k(ib,kcs)+mstu(5)**2
1135  mrev=0
1136  ELSE
1137  IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),mstu(5))
1138  & .EQ.0) kcs=9-kcs
1139  ia=mod(k(ib,kcs)/mstu(5),mstu(5))
1140  k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
1141  mrev=1
1142  ENDIF
1143  IF(ia.LE.0.OR.ia.GT.n) THEN
1144  CALL luerrm(12,'(LUPREP:) colour rearrangement failed')
1145  RETURN
1146  ENDIF
1147  IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
1148  &mstu(5)).EQ.ib) THEN
1149  IF(mrev.EQ.1) kcs=9-kcs
1150  IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
1151  k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
1152  ELSE
1153  IF(mrev.EQ.0) kcs=9-kcs
1154  IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
1155  k(ia,kcs)=k(ia,kcs)+mstu(5)**2
1156  ENDIF
1157  IF(ia.NE.i) goto 100
1158  k(i1,1)=1
1159  120 CONTINUE
1160  130 CONTINUE
1161  n=i1
1162  IF(mstj(14).LT.0) RETURN
1163 
1164 C...Find lowest-mass colour singlet jet system, OK if above threshold.
1165  IF(mstj(14).EQ.0) goto 320
1166  ns=n
1167  140 nsin=n-ns
1168  pdm=1.+parj(32)
1169  ic=0
1170  DO 190 i=max(1,ip),ns
1171  IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
1172  ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
1173  nsin=nsin+1
1174  ic=i
1175  DO 150 j=1,4
1176  dps(j)=p(i,j)
1177  150 CONTINUE
1178  mstj(93)=1
1179  dps(5)=ulmass(k(i,2))
1180  ELSEIF(k(i,1).EQ.2) THEN
1181  DO 160 j=1,4
1182  dps(j)=dps(j)+p(i,j)
1183  160 CONTINUE
1184  ELSEIF(ic.NE.0.AND.kchg(lucomp(k(i,2)),2).NE.0) THEN
1185  DO 170 j=1,4
1186  dps(j)=dps(j)+p(i,j)
1187  170 CONTINUE
1188  mstj(93)=1
1189  dps(5)=dps(5)+ulmass(k(i,2))
1190  pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-dps(5)
1191  IF(pd.LT.pdm) THEN
1192  pdm=pd
1193  DO 180 j=1,5
1194  dpc(j)=dps(j)
1195  180 CONTINUE
1196  ic1=ic
1197  ic2=i
1198  ENDIF
1199  ic=0
1200  ELSE
1201  nsin=nsin+1
1202  ENDIF
1203  190 CONTINUE
1204  IF(pdm.GE.parj(32)) goto 320
1205 
1206 C...Fill small-mass system as cluster.
1207  nsav=n
1208  pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
1209  k(n+1,1)=11
1210  k(n+1,2)=91
1211  k(n+1,3)=ic1
1212  k(n+1,4)=n+2
1213  k(n+1,5)=n+3
1214  p(n+1,1)=dpc(1)
1215  p(n+1,2)=dpc(2)
1216  p(n+1,3)=dpc(3)
1217  p(n+1,4)=dpc(4)
1218  p(n+1,5)=pecm
1219 
1220 C...Form two particles from flavours of lowest-mass system, if feasible.
1221  k(n+2,1)=1
1222  k(n+3,1)=1
1223  IF(mstu(16).NE.2) THEN
1224  k(n+2,3)=n+1
1225  k(n+3,3)=n+1
1226  ELSE
1227  k(n+2,3)=ic1
1228  k(n+3,3)=ic2
1229  ENDIF
1230  k(n+2,4)=0
1231  k(n+3,4)=0
1232  k(n+2,5)=0
1233  k(n+3,5)=0
1234  IF(iabs(k(ic1,2)).NE.21) THEN
1235  kc1=lucomp(k(ic1,2))
1236  kc2=lucomp(k(ic2,2))
1237  IF(kc1.EQ.0.OR.kc2.EQ.0) goto 320
1238  kq1=kchg(kc1,2)*isign(1,k(ic1,2))
1239  kq2=kchg(kc2,2)*isign(1,k(ic2,2))
1240  IF(kq1+kq2.NE.0) goto 320
1241  200 CALL lukfdi(k(ic1,2),0,kfln,k(n+2,2))
1242  CALL lukfdi(k(ic2,2),-kfln,kfldmp,k(n+3,2))
1243  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 200
1244  ELSE
1245  IF(iabs(k(ic2,2)).NE.21) goto 320
1246  210 CALL lukfdi(1+int((2.+parj(2))*rlu(0)),0,kfln,kfdmp)
1247  CALL lukfdi(kfln,0,kflm,k(n+2,2))
1248  CALL lukfdi(-kfln,-kflm,kfldmp,k(n+3,2))
1249  IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 210
1250  ENDIF
1251  p(n+2,5)=ulmass(k(n+2,2))
1252  p(n+3,5)=ulmass(k(n+3,2))
1253  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm.AND.nsin.EQ.1) goto 320
1254  IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) goto 260
1255 
1256 C...Perform two-particle decay of jet system, if possible.
1257  IF(pecm.GE.0.02*dpc(4)) THEN
1258  pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
1259  & (p(n+2,5)-p(n+3,5))**2))/(2.*pecm)
1260  ue(3)=2.*rlu(0)-1.
1261  phi=paru(2)*rlu(0)
1262  ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
1263  ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
1264  DO 220 j=1,3
1265  p(n+2,j)=pa*ue(j)
1266  p(n+3,j)=-pa*ue(j)
1267  220 CONTINUE
1268  p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
1269  p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
1270  mstu(33)=1
1271  CALL ludbrb(n+2,n+3,0.,0.,dpc(1)/dpc(4),dpc(2)/dpc(4),
1272  & dpc(3)/dpc(4))
1273  ELSE
1274  np=0
1275  DO 230 i=ic1,ic2
1276  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2) np=np+1
1277  230 CONTINUE
1278  ha=p(ic1,4)*p(ic2,4)-p(ic1,1)*p(ic2,1)-p(ic1,2)*p(ic2,2)-
1279  & p(ic1,3)*p(ic2,3)
1280  IF(np.GE.3.OR.ha.LE.1.25*p(ic1,5)*p(ic2,5)) goto 260
1281  hd1=0.5*(p(n+2,5)**2-p(ic1,5)**2)
1282  hd2=0.5*(p(n+3,5)**2-p(ic2,5)**2)
1283  hr=sqrt(max(0.,((ha-hd1-hd2)**2-(p(n+2,5)*p(n+3,5))**2)/
1284  & (ha**2-(p(ic1,5)*p(ic2,5))**2)))-1.
1285  hc=p(ic1,5)**2+2.*ha+p(ic2,5)**2
1286  hk1=((p(ic2,5)**2+ha)*hr+hd1-hd2)/hc
1287  hk2=((p(ic1,5)**2+ha)*hr+hd2-hd1)/hc
1288  DO 240 j=1,4
1289  p(n+2,j)=(1.+hk1)*p(ic1,j)-hk2*p(ic2,j)
1290  p(n+3,j)=(1.+hk2)*p(ic2,j)-hk1*p(ic1,j)
1291  240 CONTINUE
1292  ENDIF
1293  DO 250 j=1,4
1294  v(n+1,j)=v(ic1,j)
1295  v(n+2,j)=v(ic1,j)
1296  v(n+3,j)=v(ic2,j)
1297  250 CONTINUE
1298  v(n+1,5)=0.
1299  v(n+2,5)=0.
1300  v(n+3,5)=0.
1301  n=n+3
1302  goto 300
1303 
1304 C...Else form one particle from the flavours available, if possible.
1305  260 k(n+1,5)=n+2
1306  IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN
1307  goto 320
1308  ELSEIF(iabs(k(ic1,2)).NE.21) THEN
1309  CALL lukfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))
1310  ELSE
1311  kfln=1+int((2.+parj(2))*rlu(0))
1312  CALL lukfdi(kfln,-kfln,kfldmp,k(n+2,2))
1313  ENDIF
1314  IF(k(n+2,2).EQ.0) goto 260
1315  p(n+2,5)=ulmass(k(n+2,2))
1316 
1317 C...Find parton/particle which combines to largest extra mass.
1318  ir=0
1319  ha=0.
1320  hsm=0.
1321  DO 280 mcomb=1,3
1322  IF(ir.NE.0) goto 280
1323  DO 270 i=max(1,ip),n
1324  IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2
1325  &.AND.k(i,1).GE.1.AND.k(i,1).LE.2)) goto 270
1326  IF(mcomb.EQ.1) kci=lucomp(k(i,2))
1327  IF(mcomb.EQ.1.AND.kci.EQ.0) goto 270
1328  IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) goto 270
1329  IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
1330  &goto 270
1331  hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
1332  hsr=2.*hcr+pecm**2-p(n+2,5)**2-2.*p(n+2,5)*p(i,5)
1333  IF(hsr.GT.hsm) THEN
1334  ir=i
1335  ha=hcr
1336  hsm=hsr
1337  ENDIF
1338  270 CONTINUE
1339  280 CONTINUE
1340 
1341 C...Shuffle energy and momentum to put new particle on mass shell.
1342  IF(ir.NE.0) THEN
1343  hb=pecm**2+ha
1344  hc=p(n+2,5)**2+ha
1345  hd=p(ir,5)**2+ha
1346  hk2=0.5*(hb*sqrt(max(0.,((hb+hc)**2-4.*(hb+hd)*p(n+2,5)**2)/
1347  & (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)
1348  hk1=(0.5*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
1349  DO 290 j=1,4
1350  p(n+2,j)=(1.+hk1)*dpc(j)-hk2*p(ir,j)
1351  p(ir,j)=(1.+hk2)*p(ir,j)-hk1*dpc(j)
1352  v(n+1,j)=v(ic1,j)
1353  v(n+2,j)=v(ic1,j)
1354  290 CONTINUE
1355  v(n+1,5)=0.
1356  v(n+2,5)=0.
1357  n=n+2
1358  ELSE
1359  CALL luerrm(3,'(LUPREP:) no match for collapsing cluster')
1360  RETURN
1361  ENDIF
1362 
1363 C...Mark collapsed system and store daughter pointers. Iterate.
1364  300 DO 310 i=ic1,ic2
1365  IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.kchg(lucomp(k(i,2)),2).NE.0)
1366  &THEN
1367  k(i,1)=k(i,1)+10
1368  IF(mstu(16).NE.2) THEN
1369  k(i,4)=nsav+1
1370  k(i,5)=nsav+1
1371  ELSE
1372  k(i,4)=nsav+2
1373  k(i,5)=n
1374  ENDIF
1375  ENDIF
1376  310 CONTINUE
1377  IF(n.LT.mstu(4)-mstu(32)-5) goto 140
1378 
1379 C...Check flavours and invariant masses in parton systems.
1380  320 np=0
1381  kfn=0
1382  kqs=0
1383  DO 330 j=1,5
1384  dps(j)=0.
1385  330 CONTINUE
1386  DO 360 i=max(1,ip),n
1387  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 360
1388  kc=lucomp(k(i,2))
1389  IF(kc.EQ.0) goto 360
1390  kq=kchg(kc,2)*isign(1,k(i,2))
1391  IF(kq.EQ.0) goto 360
1392  np=np+1
1393  IF(kq.NE.2) THEN
1394  kfn=kfn+1
1395  kqs=kqs+kq
1396  mstj(93)=1
1397  dps(5)=dps(5)+ulmass(k(i,2))
1398  ENDIF
1399  DO 340 j=1,4
1400  dps(j)=dps(j)+p(i,j)
1401  340 CONTINUE
1402  IF(k(i,1).EQ.1) THEN
1403  IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) CALL
1404  & luerrm(2,'(LUPREP:) unphysical flavour combination')
1405  IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
1406  & (0.9*parj(32)+dps(5))**2) CALL luerrm(3,
1407  & '(LUPREP:) too small mass in jet system')
1408  np=0
1409  kfn=0
1410  kqs=0
1411  DO 350 j=1,5
1412  dps(j)=0.
1413  350 CONTINUE
1414  ENDIF
1415  360 CONTINUE
1416 
1417  RETURN
1418  END
1419 
1420 C*********************************************************************
1421 
1422 C*********************************************************************
1423 
1424  SUBROUTINE luindf(IP)
1425 
1426 C...Purpose: to handle the fragmentation of a jet system (or a single
1427 C...jet) according to independent fragmentation models.
1428  IMPLICIT DOUBLE PRECISION(d)
1429  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1430  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1431  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1432  SAVE /lujets/,/ludat1/,/ludat2/
1433  dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
1434  &kflo(2),pxo(2),pyo(2),wo(2)
1435 
1436 C...Reset counters. Identify parton system and take copy. Check flavour.
1437  nsav=n
1438  mstu90=mstu(90)
1439  njet=0
1440  kqsum=0
1441  DO 100 j=1,5
1442  dps(j)=0.
1443  100 CONTINUE
1444  i=ip-1
1445  110 i=i+1
1446  IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
1447  CALL luerrm(12,'(LUINDF:) failed to reconstruct jet system')
1448  IF(mstu(21).GE.1) RETURN
1449  ENDIF
1450  IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 110
1451  kc=lucomp(k(i,2))
1452  IF(kc.EQ.0) goto 110
1453  kq=kchg(kc,2)*isign(1,k(i,2))
1454  IF(kq.EQ.0) goto 110
1455  njet=njet+1
1456  IF(kq.NE.2) kqsum=kqsum+kq
1457  DO 120 j=1,5
1458  k(nsav+njet,j)=k(i,j)
1459  p(nsav+njet,j)=p(i,j)
1460  dps(j)=dps(j)+p(i,j)
1461  120 CONTINUE
1462  k(nsav+njet,3)=i
1463  IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
1464  &k(i+1,1).EQ.2)) goto 110
1465  IF(njet.NE.1.AND.kqsum.NE.0) THEN
1466  CALL luerrm(12,'(LUINDF:) unphysical flavour combination')
1467  IF(mstu(21).GE.1) RETURN
1468  ENDIF
1469 
1470 C...Boost copied system to CM frame. Find CM energy and sum flavours.
1471  IF(njet.NE.1) THEN
1472  mstu(33)=1
1473  CALL ludbrb(nsav+1,nsav+njet,0.,0.,-dps(1)/dps(4),
1474  & -dps(2)/dps(4),-dps(3)/dps(4))
1475  ENDIF
1476  pecm=0.
1477  DO 130 j=1,3
1478  nfi(j)=0
1479  130 CONTINUE
1480  DO 140 i=nsav+1,nsav+njet
1481  pecm=pecm+p(i,4)
1482  kfa=iabs(k(i,2))
1483  IF(kfa.LE.3) THEN
1484  nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
1485  ELSEIF(kfa.GT.1000) THEN
1486  kfla=mod(kfa/1000,10)
1487  kflb=mod(kfa/100,10)
1488  IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
1489  IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
1490  ENDIF
1491  140 CONTINUE
1492 
1493 C...Loop over attempts made. Reset counters.
1494  ntry=0
1495  150 ntry=ntry+1
1496  IF(ntry.GT.200) THEN
1497  CALL luerrm(14,'(LUINDF:) caught in infinite loop')
1498  IF(mstu(21).GE.1) RETURN
1499  ENDIF
1500  n=nsav+njet
1501  mstu(90)=mstu90
1502  DO 160 j=1,3
1503  nfl(j)=nfi(j)
1504  ifet(j)=0
1505  kflf(j)=0
1506  160 CONTINUE
1507 
1508 C...Loop over jets to be fragmented.
1509  DO 230 ip1=nsav+1,nsav+njet
1510  mstj(91)=0
1511  nsav1=n
1512  mstu91=mstu(90)
1513 
1514 C...Initial flavour and momentum values. Jet along +z axis.
1515  kflh=iabs(k(ip1,2))
1516  IF(kflh.GT.10) kflh=mod(kflh/1000,10)
1517  kflo(2)=0
1518  wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
1519 
1520 C...Initial values for quark or diquark jet.
1521  170 IF(iabs(k(ip1,2)).NE.21) THEN
1522  nstr=1
1523  kflo(1)=k(ip1,2)
1524  CALL luptdi(0,pxo(1),pyo(1))
1525  wo(1)=wf
1526 
1527 C...Initial values for gluon treated like random quark jet.
1528  ELSEIF(mstj(2).LE.2) THEN
1529  nstr=1
1530  IF(mstj(2).EQ.2) mstj(91)=1
1531  kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
1532  CALL luptdi(0,pxo(1),pyo(1))
1533  wo(1)=wf
1534 
1535 C...Initial values for gluon treated like quark-antiquark jet pair,
1536 C...sharing energy according to Altarelli-Parisi splitting function.
1537  ELSE
1538  nstr=2
1539  IF(mstj(2).EQ.4) mstj(91)=1
1540  kflo(1)=int(1.+(2.+parj(2))*rlu(0))*(-1)**int(rlu(0)+0.5)
1541  kflo(2)=-kflo(1)
1542  CALL luptdi(0,pxo(1),pyo(1))
1543  pxo(2)=-pxo(1)
1544  pyo(2)=-pyo(1)
1545  wo(1)=wf*rlu(0)**(1./3.)
1546  wo(2)=wf-wo(1)
1547  ENDIF
1548 
1549 C...Initial values for rank, flavour, pT and W+.
1550  DO 220 istr=1,nstr
1551  180 i=n
1552  mstu(90)=mstu91
1553  irank=0
1554  kfl1=kflo(istr)
1555  px1=pxo(istr)
1556  py1=pyo(istr)
1557  w=wo(istr)
1558 
1559 C...New hadron. Generate flavour and hadron species.
1560  190 i=i+1
1561  IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
1562  CALL luerrm(11,'(LUINDF:) no more memory left in LUJETS')
1563  IF(mstu(21).GE.1) RETURN
1564  ENDIF
1565  irank=irank+1
1566  k(i,1)=1
1567  k(i,3)=ip1
1568  k(i,4)=0
1569  k(i,5)=0
1570  200 CALL lukfdi(kfl1,0,kfl2,k(i,2))
1571  IF(k(i,2).EQ.0) goto 180
1572  IF(mstj(12).GE.3.AND.irank.EQ.1.AND.iabs(kfl1).LE.10.AND.
1573  &iabs(kfl2).GT.10) THEN
1574  IF(rlu(0).GT.parj(19)) goto 200
1575  ENDIF
1576 
1577 C...Find hadron mass. Generate four-momentum.
1578  p(i,5)=ulmass(k(i,2))
1579  CALL luptdi(kfl1,px2,py2)
1580  p(i,1)=px1+px2
1581  p(i,2)=py1+py2
1582  pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
1583  CALL luzdis(kfl1,kfl2,pr,z)
1584  mzsav=0
1585  IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN
1586  mzsav=1
1587  mstu(90)=mstu(90)+1
1588  mstu(90+mstu(90))=i
1589  paru(90+mstu(90))=z
1590  ENDIF
1591  p(i,3)=0.5*(z*w-pr/max(1e-4,z*w))
1592  p(i,4)=0.5*(z*w+pr/max(1e-4,z*w))
1593  IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
1594  &p(i,3).LE.0.001) THEN
1595  IF(w.GE.p(i,5)+0.5*parj(32)) goto 180
1596  p(i,3)=0.0001
1597  p(i,4)=sqrt(pr)
1598  z=p(i,4)/w
1599  ENDIF
1600 
1601 C...Remaining flavour and momentum.
1602  kfl1=-kfl2
1603  px1=-px2
1604  py1=-py2
1605  w=(1.-z)*w
1606  DO 210 j=1,5
1607  v(i,j)=0.
1608  210 CONTINUE
1609 
1610 C...Check if pL acceptable. Go back for new hadron if enough energy.
1611  IF(mstj(3).GE.0.AND.p(i,3).LT.0.) THEN
1612  i=i-1
1613  IF(mzsav.EQ.1) mstu(90)=mstu(90)-1
1614  ENDIF
1615  IF(w.GT.parj(31)) goto 190
1616  n=i
1617  220 CONTINUE
1618  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1*parj(32)
1619  IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) goto 170
1620 
1621 C...Rotate jet to new direction.
1622  the=ulangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
1623  phi=ulangl(p(ip1,1),p(ip1,2))
1624  mstu(33)=1
1625  CALL ludbrb(nsav1+1,n,the,phi,0d0,0d0,0d0)
1626  k(k(ip1,3),4)=nsav1+1
1627  k(k(ip1,3),5)=n
1628 
1629 C...End of jet generation loop. Skip conservation in some cases.
1630  230 CONTINUE
1631  IF(njet.EQ.1.OR.mstj(3).LE.0) goto 490
1632  IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) goto 150
1633 
1634 C...Subtract off produced hadron flavours, finished if zero.
1635  DO 240 i=nsav+njet+1,n
1636  kfa=iabs(k(i,2))
1637  kfla=mod(kfa/1000,10)
1638  kflb=mod(kfa/100,10)
1639  kflc=mod(kfa/10,10)
1640  IF(kfla.EQ.0) THEN
1641  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
1642  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
1643  ELSE
1644  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
1645  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
1646  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
1647  ENDIF
1648  240 CONTINUE
1649  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
1650  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
1651  IF(nreq.EQ.0) goto 320
1652 
1653 C...Take away flavour of low-momentum particles until enough freedom.
1654  nrem=0
1655  250 irem=0
1656  p2min=pecm**2
1657  DO 260 i=nsav+njet+1,n
1658  p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
1659  IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
1660  IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
1661  260 CONTINUE
1662  IF(irem.EQ.0) goto 150
1663  k(irem,1)=7
1664  kfa=iabs(k(irem,2))
1665  kfla=mod(kfa/1000,10)
1666  kflb=mod(kfa/100,10)
1667  kflc=mod(kfa/10,10)
1668  IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
1669  IF(k(irem,1).EQ.8) goto 250
1670  IF(kfla.EQ.0) THEN
1671  isgn=isign(1,k(irem,2))*(-1)**kflb
1672  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
1673  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
1674  ELSE
1675  IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
1676  IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
1677  IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
1678  ENDIF
1679  nrem=nrem+1
1680  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
1681  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
1682  IF(nreq.GT.nrem) goto 250
1683  DO 270 i=nsav+njet+1,n
1684  IF(k(i,1).EQ.8) k(i,1)=1
1685  270 CONTINUE
1686 
1687 C...Find combination of existing and new flavours for hadron.
1688  280 nfet=2
1689  IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
1690  IF(nreq.LT.nrem) nfet=1
1691  IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
1692  DO 290 j=1,nfet
1693  ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*rlu(0)
1694  kflf(j)=isign(1,nfl(1))
1695  IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
1696  IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
1697  290 CONTINUE
1698  IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
1699  &goto 280
1700  IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
1701  &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3)
1702  &.LT.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) goto 280
1703  IF(nfet.EQ.0) kflf(1)=1+int((2.+parj(2))*rlu(0))
1704  IF(nfet.EQ.0) kflf(2)=-kflf(1)
1705  IF(nfet.EQ.1) kflf(2)=isign(1+int((2.+parj(2))*rlu(0)),-kflf(1))
1706  IF(nfet.LE.2) kflf(3)=0
1707  IF(kflf(3).NE.0) THEN
1708  kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
1709  & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
1710  IF(kflf(1).EQ.kflf(3).OR.(1.+3.*parj(4))*rlu(0).GT.1.)
1711  & kflfc=kflfc+isign(2,kflfc)
1712  ELSE
1713  kflfc=kflf(1)
1714  ENDIF
1715  CALL lukfdi(kflfc,kflf(2),kfldmp,kf)
1716  IF(kf.EQ.0) goto 280
1717  DO 300 j=1,max(2,nfet)
1718  nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
1719  300 CONTINUE
1720 
1721 C...Store hadron at random among free positions.
1722  npos=min(1+int(rlu(0)*nrem),nrem)
1723  DO 310 i=nsav+njet+1,n
1724  IF(k(i,1).EQ.7) npos=npos-1
1725  IF(k(i,1).EQ.1.OR.npos.NE.0) goto 310
1726  k(i,1)=1
1727  k(i,2)=kf
1728  p(i,5)=ulmass(k(i,2))
1729  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
1730  310 CONTINUE
1731  nrem=nrem-1
1732  nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
1733  &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
1734  IF(nrem.GT.0) goto 280
1735 
1736 C...Compensate for missing momentum in global scheme (3 options).
1737  320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
1738  DO 340 j=1,3
1739  psi(j)=0.
1740  DO 330 i=nsav+njet+1,n
1741  psi(j)=psi(j)+p(i,j)
1742  330 CONTINUE
1743  340 CONTINUE
1744  psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
1745  pws=0.
1746  DO 350 i=nsav+njet+1,n
1747  IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
1748  IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
1749  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
1750  IF(mod(mstj(3),5).EQ.3) pws=pws+1.
1751  350 CONTINUE
1752  DO 370 i=nsav+njet+1,n
1753  IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
1754  IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
1755  & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
1756  IF(mod(mstj(3),5).EQ.3) pw=1.
1757  DO 360 j=1,3
1758  p(i,j)=p(i,j)-psi(j)*pw/pws
1759  360 CONTINUE
1760  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
1761  370 CONTINUE
1762 
1763 C...Compensate for missing momentum withing each jet separately.
1764  ELSEIF(mod(mstj(3),5).EQ.4) THEN
1765  DO 390 i=n+1,n+njet
1766  k(i,1)=0
1767  DO 380 j=1,5
1768  p(i,j)=0.
1769  380 CONTINUE
1770  390 CONTINUE
1771  DO 410 i=nsav+njet+1,n
1772  ir1=k(i,3)
1773  ir2=n+ir1-nsav
1774  k(ir2,1)=k(ir2,1)+1
1775  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
1776  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
1777  DO 400 j=1,3
1778  p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
1779  400 CONTINUE
1780  p(ir2,4)=p(ir2,4)+p(i,4)
1781  p(ir2,5)=p(ir2,5)+pls
1782  410 CONTINUE
1783  pss=0.
1784  DO 420 i=n+1,n+njet
1785  IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8*p(i,5)+0.2))
1786  420 CONTINUE
1787  DO 440 i=nsav+njet+1,n
1788  ir1=k(i,3)
1789  ir2=n+ir1-nsav
1790  pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
1791  & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
1792  DO 430 j=1,3
1793  p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1./(p(ir2,5)*pss)-1.)*pls*
1794  & p(ir1,j)
1795  430 CONTINUE
1796  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
1797  440 CONTINUE
1798  ENDIF
1799 
1800 C...Scale momenta for energy conservation.
1801  IF(mod(mstj(3),5).NE.0) THEN
1802  pms=0.
1803  pes=0.
1804  pqs=0.
1805  DO 450 i=nsav+njet+1,n
1806  pms=pms+p(i,5)
1807  pes=pes+p(i,4)
1808  pqs=pqs+p(i,5)**2/p(i,4)
1809  450 CONTINUE
1810  IF(pms.GE.pecm) goto 150
1811  neco=0
1812  460 neco=neco+1
1813  pfac=(pecm-pqs)/(pes-pqs)
1814  pes=0.
1815  pqs=0.
1816  DO 480 i=nsav+njet+1,n
1817  DO 470 j=1,3
1818  p(i,j)=pfac*p(i,j)
1819  470 CONTINUE
1820  p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
1821  pes=pes+p(i,4)
1822  pqs=pqs+p(i,5)**2/p(i,4)
1823  480 CONTINUE
1824  IF(neco.LT.10.AND.abs(pecm-pes).GT.2e-6*pecm) goto 460
1825  ENDIF
1826 
1827 C...Origin of produced particles and parton daughter pointers.
1828  490 DO 500 i=nsav+njet+1,n
1829  IF(mstu(16).NE.2) k(i,3)=nsav+1
1830  IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
1831  500 CONTINUE
1832  DO 510 i=nsav+1,nsav+njet
1833  i1=k(i,3)
1834  k(i1,1)=k(i1,1)+10
1835  IF(mstu(16).NE.2) THEN
1836  k(i1,4)=nsav+1
1837  k(i1,5)=nsav+1
1838  ELSE
1839  k(i1,4)=k(i1,4)-njet+1
1840  k(i1,5)=k(i1,5)-njet+1
1841  IF(k(i1,5).LT.k(i1,4)) THEN
1842  k(i1,4)=0
1843  k(i1,5)=0
1844  ENDIF
1845  ENDIF
1846  510 CONTINUE
1847 
1848 C...Document independent fragmentation system. Remove copy of jets.
1849  nsav=nsav+1
1850  k(nsav,1)=11
1851  k(nsav,2)=93
1852  k(nsav,3)=ip
1853  k(nsav,4)=nsav+1
1854  k(nsav,5)=n-njet+1
1855  DO 520 j=1,4
1856  p(nsav,j)=dps(j)
1857  v(nsav,j)=v(ip,j)
1858  520 CONTINUE
1859  p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
1860  v(nsav,5)=0.
1861  DO 540 i=nsav+njet,n
1862  DO 530 j=1,5
1863  k(i-njet+1,j)=k(i,j)
1864  p(i-njet+1,j)=p(i,j)
1865  v(i-njet+1,j)=v(i,j)
1866  530 CONTINUE
1867  540 CONTINUE
1868  n=n-njet+1
1869  DO 550 iz=mstu90+1,mstu(90)
1870  mstu(90+iz)=mstu(90+iz)-njet+1
1871  550 CONTINUE
1872 
1873 C...Boost back particle system. Set production vertices.
1874  IF(njet.NE.1) CALL ludbrb(nsav+1,n,0.,0.,dps(1)/dps(4),
1875  &dps(2)/dps(4),dps(3)/dps(4))
1876  DO 570 i=nsav+1,n
1877  DO 560 j=1,4
1878  v(i,j)=v(ip,j)
1879  560 CONTINUE
1880  570 CONTINUE
1881 
1882  RETURN
1883  END
1884 
1885 C*********************************************************************
1886 
1887  SUBROUTINE ludecy(IP)
1888 
1889 C...Purpose: to handle the decay of unstable particles.
1890  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
1891  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
1892  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
1893  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
1894  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
1895  dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
1896  &wtcor(10),ptau(4),pcmtau(4)
1897  DOUBLE PRECISION dbetau(3)
1898  DATA wtcor/2.,5.,15.,60.,250.,1500.,1.2e4,1.2e5,150.,16./
1899 
1900 C...Functions: momentum in two-particle decays, four-product and
1901 C...matrix element times phase space in weak decays.
1902  pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2.*a)
1903  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)
1904  hmeps(ha)=((1.-hrq-ha)**2+3.*ha*(1.+hrq-ha))*
1905  &sqrt((1.-hrq-ha)**2-4.*hrq*ha)
1906 
1907 C...Initial values.
1908  ntry=0
1909  nsav=n
1910  kfa=iabs(k(ip,2))
1911  kfs=isign(1,k(ip,2))
1912  kc=lucomp(kfa)
1913  mstj(92)=0
1914 
1915 C...Choose lifetime and determine decay vertex.
1916  IF(k(ip,1).EQ.5) THEN
1917  v(ip,5)=0.
1918  ELSEIF(k(ip,1).NE.4) THEN
1919  v(ip,5)=-pmas(kc,4)*log(rlu(0))
1920  ENDIF
1921  DO 100 j=1,4
1922  vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
1923  100 CONTINUE
1924 
1925 C...Determine whether decay allowed or not.
1926  mout=0
1927  IF(mstj(22).EQ.2) THEN
1928  IF(pmas(kc,4).GT.parj(71)) mout=1
1929  ELSEIF(mstj(22).EQ.3) THEN
1930  IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
1931  ELSEIF(mstj(22).EQ.4) THEN
1932  IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
1933  IF(abs(vdcy(3)).GT.parj(74)) mout=1
1934  ENDIF
1935  IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
1936  k(ip,1)=4
1937  RETURN
1938  ENDIF
1939 
1940 C...Interface to external tau decay library (for tau polarization).
1941  IF(kfa.EQ.15.AND.mstj(28).GE.1) THEN
1942 
1943 C...Starting values for pointers and momenta.
1944  itau=ip
1945  DO 110 j=1,4
1946  ptau(j)=p(itau,j)
1947  pcmtau(j)=p(itau,j)
1948  110 CONTINUE
1949 
1950 C...Iterate to find position and code of mother of tau.
1951  imtau=itau
1952  120 imtau=k(imtau,3)
1953 
1954  IF(imtau.EQ.0) THEN
1955 C...If no known origin then impossible to do anything further.
1956  kforig=0
1957  iorig=0
1958 
1959  ELSEIF(k(imtau,2).EQ.k(itau,2)) THEN
1960 C...If tau -> tau + gamma then add gamma energy and loop.
1961  IF(k(k(imtau,4),2).EQ.22) THEN
1962  DO 130 j=1,4
1963  pcmtau(j)=pcmtau(j)+p(k(imtau,4),j)
1964  130 CONTINUE
1965  ELSEIF(k(k(imtau,5),2).EQ.22) THEN
1966  DO 140 j=1,4
1967  pcmtau(j)=pcmtau(j)+p(k(imtau,5),j)
1968  140 CONTINUE
1969  ENDIF
1970  goto 120
1971 
1972  ELSEIF(iabs(k(imtau,2)).GT.100) THEN
1973 C...If coming from weak decay of hadron then W is not stored in record,
1974 C...but can be reconstructed by adding neutrino momentum.
1975  kforig=-isign(24,k(itau,2))
1976  iorig=0
1977  DO 160 ii=k(imtau,4),k(imtau,5)
1978  IF(k(ii,2)*isign(1,k(itau,2)).EQ.-16) THEN
1979  DO 150 j=1,4
1980  pcmtau(j)=pcmtau(j)+p(ii,j)
1981  150 CONTINUE
1982  ENDIF
1983  160 CONTINUE
1984 
1985  ELSE
1986 C...If coming from resonance decay then find latest copy of this
1987 C...resonance (may not completely agree).
1988  kforig=k(imtau,2)
1989  iorig=imtau
1990  DO 170 ii=imtau+1,ip-1
1991  IF(k(ii,2).EQ.kforig.AND.k(ii,3).EQ.iorig.AND.
1992  & abs(p(ii,5)-p(iorig,5)).LT.1e-5*p(iorig,5)) iorig=ii
1993  170 CONTINUE
1994  DO 180 j=1,4
1995  pcmtau(j)=p(iorig,j)
1996  180 CONTINUE
1997  ENDIF
1998 
1999 C...Boost tau to rest frame of production process (where known)
2000 C...and rotate it to sit along +z axis.
2001  DO 190 j=1,3
2002  dbetau(j)=pcmtau(j)/pcmtau(4)
2003  190 CONTINUE
2004  IF(kforig.NE.0) CALL ludbrb(itau,itau,0.,0.,-dbetau(1),
2005  & -dbetau(2),-dbetau(3))
2006  phitau=ulangl(p(itau,1),p(itau,2))
2007  CALL ludbrb(itau,itau,0.,-phitau,0d0,0d0,0d0)
2008  thetau=ulangl(p(itau,3),p(itau,1))
2009  CALL ludbrb(itau,itau,-thetau,0.,0d0,0d0,0d0)
2010 
2011 C...Call tau decay routine (if meaningful) and fill extra info.
2012  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
2013  CALL lutaud(itau,iorig,kforig,ndecay)
2014  DO 200 ii=nsav+1,nsav+ndecay
2015  k(ii,1)=1
2016  k(ii,3)=ip
2017  k(ii,4)=0
2018  k(ii,5)=0
2019  200 CONTINUE
2020  n=nsav+ndecay
2021  ENDIF
2022 
2023 C...Boost back decay tau and decay products.
2024  DO 210 j=1,4
2025  p(itau,j)=ptau(j)
2026  210 CONTINUE
2027  IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
2028  CALL ludbrb(nsav+1,n,thetau,phitau,0d0,0d0,0d0)
2029  IF(kforig.NE.0) CALL ludbrb(nsav+1,n,0.,0.,dbetau(1),
2030  & dbetau(2),dbetau(3))
2031 
2032 C...Skip past ordinary tau decay treatment.
2033  mmat=0
2034  mbst=0
2035  nd=0
2036  goto 660
2037  ENDIF
2038  ENDIF
2039 
2040 C...B-B~ mixing: flip sign of meson appropriately.
2041  mmix=0
2042  IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN
2043  xbbmix=parj(76)
2044  IF(kfa.EQ.531) xbbmix=parj(77)
2045  IF(sin(0.5*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.rlu(0)) mmix=1
2046  IF(mmix.EQ.1) kfs=-kfs
2047  ENDIF
2048 
2049 C...Check existence of decay channels. Particle/antiparticle rules.
2050  kca=kc
2051  IF(mdcy(kc,2).GT.0) THEN
2052  mdmdcy=mdme(mdcy(kc,2),2)
2053  IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
2054  ENDIF
2055  IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
2056  CALL luerrm(9,'(LUDECY:) no decay channel defined')
2057  RETURN
2058  ENDIF
2059  IF(mod(kfa/1000,10).EQ.0.AND.(kca.EQ.85.OR.kca.EQ.87)) kfs=-kfs
2060  IF(kchg(kc,3).EQ.0) THEN
2061  kfsp=1
2062  kfsn=0
2063  IF(rlu(0).GT.0.5) kfs=-kfs
2064  ELSEIF(kfs.GT.0) THEN
2065  kfsp=1
2066  kfsn=0
2067  ELSE
2068  kfsp=0
2069  kfsn=1
2070  ENDIF
2071 
2072 C...Sum branching ratios of allowed decay channels.
2073  220 nope=0
2074  brsu=0.
2075  DO 230 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
2076  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
2077  &kfsn*mdme(idl,1).NE.3) goto 230
2078  IF(mdme(idl,2).GT.100) goto 230
2079  nope=nope+1
2080  brsu=brsu+brat(idl)
2081  230 CONTINUE
2082  IF(nope.EQ.0) THEN
2083  CALL luerrm(2,'(LUDECY:) all decay channels closed by user')
2084  RETURN
2085  ENDIF
2086 
2087 C...Select decay channel among allowed ones.
2088  240 rbr=brsu*rlu(0)
2089  idl=mdcy(kca,2)-1
2090  250 idl=idl+1
2091  IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
2092  &kfsn*mdme(idl,1).NE.3) THEN
2093  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250
2094  ELSEIF(mdme(idl,2).GT.100) THEN
2095  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250
2096  ELSE
2097  idc=idl
2098  rbr=rbr-brat(idl)
2099  IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0.) goto 250
2100  ENDIF
2101 
2102 C...Start readout of decay channel: matrix element, reset counters.
2103  mmat=mdme(idc,2)
2104  260 ntry=ntry+1
2105  IF(ntry.GT.1000) THEN
2106  CALL luerrm(14,'(LUDECY:) caught in infinite loop')
2107  IF(mstu(21).GE.1) RETURN
2108  ENDIF
2109  i=n
2110  np=0
2111  nq=0
2112  mbst=0
2113  IF(mmat.GE.11.AND.mmat.NE.46.AND.p(ip,4).GT.20.*p(ip,5)) mbst=1
2114  DO 270 j=1,4
2115  pv(1,j)=0.
2116  IF(mbst.EQ.0) pv(1,j)=p(ip,j)
2117  270 CONTINUE
2118  IF(mbst.EQ.1) pv(1,4)=p(ip,5)
2119  pv(1,5)=p(ip,5)
2120  ps=0.
2121  psq=0.
2122  mrem=0
2123  mhaddy=0
2124  IF(kfa.GT.80) mhaddy=1
2125 
2126 C...Read out decay products. Convert to standard flavour code.
2127  jtmax=5
2128  IF(mdme(idc+1,2).EQ.101) jtmax=10
2129  DO 280 jt=1,jtmax
2130  IF(jt.LE.5) kp=kfdp(idc,jt)
2131  IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
2132  IF(kp.EQ.0) goto 280
2133  kpa=iabs(kp)
2134  kcp=lucomp(kpa)
2135  IF(kpa.GT.80) mhaddy=1
2136  IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
2137  kfp=kp
2138  ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
2139  kfp=kfs*kp
2140  ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
2141  kfp=-kfs*mod(kfa/10,10)
2142  ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
2143  kfp=kfs*(100*mod(kfa/10,100)+3)
2144  ELSEIF(kpa.EQ.81) THEN
2145  kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
2146  ELSEIF(kp.EQ.82) THEN
2147  CALL lukfdi(-kfs*int(1.+(2.+parj(2))*rlu(0)),0,kfp,kdump)
2148  IF(kfp.EQ.0) goto 260
2149  mstj(93)=1
2150  IF(pv(1,5).LT.parj(32)+2.*ulmass(kfp)) goto 260
2151  ELSEIF(kp.EQ.-82) THEN
2152  kfp=-kfp
2153  IF(iabs(kfp).GT.10) kfp=kfp+isign(10000,kfp)
2154  ENDIF
2155  IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=lucomp(kfp)
2156 
2157 C...Add decay product to event record or to quark flavour list.
2158  kfpa=iabs(kfp)
2159  kqp=kchg(kcp,2)
2160  IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
2161  nq=nq+1
2162  kflo(nq)=kfp
2163  mstj(93)=2
2164  psq=psq+ulmass(kflo(nq))
2165  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.
2166  &mod(nq,2).EQ.1) THEN
2167  nq=nq-1
2168  ps=ps-p(i,5)
2169  k(i,1)=1
2170  kfi=k(i,2)
2171  CALL lukfdi(kfp,kfi,kfldmp,k(i,2))
2172  IF(k(i,2).EQ.0) goto 260
2173  mstj(93)=1
2174  p(i,5)=ulmass(k(i,2))
2175  ps=ps+p(i,5)
2176  ELSE
2177  i=i+1
2178  np=np+1
2179  IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
2180  IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
2181  k(i,1)=1+mod(nq,2)
2182  IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
2183  IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
2184  k(i,2)=kfp
2185  k(i,3)=ip
2186  k(i,4)=0
2187  k(i,5)=0
2188  p(i,5)=ulmass(kfp)
2189  IF(mmat.EQ.45.AND.kfpa.EQ.89) p(i,5)=parj(32)
2190  ps=ps+p(i,5)
2191  ENDIF
2192  280 CONTINUE
2193 
2194 C...Check masses for resonance decays.
2195  IF(mhaddy.EQ.0) THEN
2196  IF(ps+parj(64).GT.pv(1,5)) goto 240
2197  ENDIF
2198 
2199 C...Choose decay multiplicity in phase space model.
2200  290 IF(mmat.GE.11.AND.mmat.LE.30) THEN
2201  psp=ps
2202  cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1))
2203  IF(mmat.EQ.12) cnde=cnde+parj(63)
2204  300 ntry=ntry+1
2205  IF(ntry.GT.1000) THEN
2206  CALL luerrm(14,'(LUDECY:) caught in infinite loop')
2207  IF(mstu(21).GE.1) RETURN
2208  ENDIF
2209  IF(mmat.LE.20) THEN
2210  gauss=sqrt(-2.*cnde*log(max(1e-10,rlu(0))))*
2211  & sin(paru(2)*rlu(0))
2212  nd=0.5+0.5*np+0.25*nq+cnde+gauss
2213  IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) goto 300
2214  IF(mmat.EQ.13.AND.nd.EQ.2) goto 300
2215  IF(mmat.EQ.14.AND.nd.LE.3) goto 300
2216  IF(mmat.EQ.15.AND.nd.LE.4) goto 300
2217  ELSE
2218  nd=mmat-20
2219  ENDIF
2220 
2221 C...Form hadrons from flavour content.
2222  DO 310 jt=1,4
2223  kfl1(jt)=kflo(jt)
2224  310 CONTINUE
2225  IF(nd.EQ.np+nq/2) goto 330
2226  DO 320 i=n+np+1,n+nd-nq/2
2227  jt=1+int((nq-1)*rlu(0))
2228  CALL lukfdi(kfl1(jt),0,kfl2,k(i,2))
2229  IF(k(i,2).EQ.0) goto 300
2230  kfl1(jt)=-kfl2
2231  320 CONTINUE
2232  330 jt=2
2233  jt2=3
2234  jt3=4
2235  IF(nq.EQ.4.AND.rlu(0).LT.parj(66)) jt=4
2236  IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
2237  & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
2238  IF(jt.EQ.3) jt2=2
2239  IF(jt.EQ.4) jt3=2
2240  CALL lukfdi(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
2241  IF(k(n+nd-nq/2+1,2).EQ.0) goto 300
2242  IF(nq.EQ.4) CALL lukfdi(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
2243  IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) goto 300
2244 
2245 C...Check that sum of decay product masses not too large.
2246  ps=psp
2247  DO 340 i=n+np+1,n+nd
2248  k(i,1)=1
2249  k(i,3)=ip
2250  k(i,4)=0
2251  k(i,5)=0
2252  p(i,5)=ulmass(k(i,2))
2253  ps=ps+p(i,5)
2254  340 CONTINUE
2255  IF(ps+parj(64).GT.pv(1,5)) goto 300
2256 
2257 C...Rescale energy to subtract off spectator quark mass.
2258  ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44.OR.mmat.EQ.45)
2259  &.AND.np.GE.3) THEN
2260  ps=ps-p(n+np,5)
2261  pqt=(p(n+np,5)+parj(65))/pv(1,5)
2262  DO 350 j=1,5
2263  p(n+np,j)=pqt*pv(1,j)
2264  pv(1,j)=(1.-pqt)*pv(1,j)
2265  350 CONTINUE
2266  IF(ps+parj(64).GT.pv(1,5)) goto 260
2267  nd=np-1
2268  mrem=1
2269 
2270 C...Phase space factors imposed in W decay.
2271  ELSEIF(mmat.EQ.46) THEN
2272  mstj(93)=1
2273  psmc=ulmass(k(n+1,2))
2274  mstj(93)=1
2275  psmc=psmc+ulmass(k(n+2,2))
2276  IF(max(ps,psmc)+parj(32).GT.pv(1,5)) goto 240
2277  hr1=(p(n+1,5)/pv(1,5))**2
2278  hr2=(p(n+2,5)/pv(1,5))**2
2279  IF((1.-hr1-hr2)*(2.+hr1+hr2)*sqrt((1.-hr1-hr2)**2-4.*hr1*hr2)
2280  & .LT.2.*rlu(0)) goto 240
2281  nd=np
2282 
2283 C...Fully specified final state: check mass broadening effects.
2284  ELSE
2285  IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) goto 260
2286  nd=np
2287  ENDIF
2288 
2289 C...Select W mass in decay Q -> W + q, without W propagator.
2290  IF(mmat.EQ.45.AND.mstj(25).LE.0) THEN
2291  hlq=(parj(32)/pv(1,5))**2
2292  huq=(1.-(p(n+2,5)+parj(64))/pv(1,5))**2
2293  hrq=(p(n+2,5)/pv(1,5))**2
2294  360 hw=hlq+rlu(0)*(huq-hlq)
2295  IF(hmeps(hw).LT.rlu(0)) goto 360
2296  p(n+1,5)=pv(1,5)*sqrt(hw)
2297 
2298 C...Ditto, including W propagator. Divide mass range into three regions.
2299  ELSEIF(mmat.EQ.45) THEN
2300  hqw=(pv(1,5)/pmas(24,1))**2
2301  hlw=(parj(32)/pmas(24,1))**2
2302  huw=((pv(1,5)-p(n+2,5)-parj(64))/pmas(24,1))**2
2303  hrq=(p(n+2,5)/pv(1,5))**2
2304  hg=pmas(24,2)/pmas(24,1)
2305  hatl=atan((hlw-1.)/hg)
2306  hm=min(1.,huw-0.001)
2307  hmv1=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
2308  370 hm=hm-hg
2309  hmv2=hmeps(hm/hqw)/((hm-1.)**2+hg**2)
2310  IF(hmv2.GT.hmv1.AND.hm-hg.GT.hlw) THEN
2311  hmv1=hmv2
2312  goto 370
2313  ENDIF
2314  hmv=min(2.*hmv1,hmeps(hm/hqw)/hg**2)
2315  hm1=1.-sqrt(1./hmv-hg**2)
2316  IF(hm1.GT.hlw.AND.hm1.LT.hm) THEN
2317  hm=hm1
2318  ELSEIF(hmv2.LE.hmv1) THEN
2319  hm=max(hlw,hm-min(0.1,1.-hm))
2320  ENDIF
2321  hatm=atan((hm-1.)/hg)
2322  hwt1=(hatm-hatl)/hg
2323  hwt2=hmv*(min(1.,huw)-hm)
2324  hwt3=0.
2325  IF(huw.GT.1.) THEN
2326  hatu=atan((huw-1.)/hg)
2327  hmp1=hmeps(1./hqw)
2328  hwt3=hmp1*hatu/hg
2329  ENDIF
2330 
2331 C...Select mass region and W mass there. Accept according to weight.
2332  380 hreg=rlu(0)*(hwt1+hwt2+hwt3)
2333  IF(hreg.LE.hwt1) THEN
2334  hw=1.+hg*tan(hatl+rlu(0)*(hatm-hatl))
2335  hacc=hmeps(hw/hqw)
2336  ELSEIF(hreg.LE.hwt1+hwt2) THEN
2337  hw=hm+rlu(0)*(min(1.,huw)-hm)
2338  hacc=hmeps(hw/hqw)/((hw-1.)**2+hg**2)/hmv
2339  ELSE
2340  hw=1.+hg*tan(rlu(0)*hatu)
2341  hacc=hmeps(hw/hqw)/hmp1
2342  ENDIF
2343  IF(hacc.LT.rlu(0)) goto 380
2344  p(n+1,5)=pmas(24,1)*sqrt(hw)
2345  ENDIF
2346 
2347 C...Determine position of grandmother, number of sisters, Q -> W sign.
2348  nm=0
2349  kfas=0
2350  msgn=0
2351  IF(mmat.EQ.3.OR.mmat.EQ.46) THEN
2352  im=k(ip,3)
2353  IF(im.LT.0.OR.im.GE.ip) im=0
2354  IF(mmat.EQ.46.AND.mstj(27).EQ.1) THEN
2355  im=0
2356  ELSEIF(mmat.EQ.46.AND.mstj(27).GE.2.AND.im.NE.0) THEN
2357  IF(k(im,2).EQ.94) THEN
2358  im=k(k(im,3),3)
2359  IF(im.LT.0.OR.im.GE.ip) im=0
2360  ENDIF
2361  ENDIF
2362  IF(im.NE.0) kfam=iabs(k(im,2))
2363  IF(im.NE.0.AND.mmat.EQ.3) THEN
2364  DO 390 il=max(ip-2,im+1),min(ip+2,n)
2365  IF(k(il,3).EQ.im) nm=nm+1
2366  IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il
2367  390 CONTINUE
2368  IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
2369  & mod(kfam/1000,10).NE.0) nm=0
2370  IF(nm.EQ.2) THEN
2371  kfas=iabs(k(isis,2))
2372  IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.
2373  & mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0
2374  ENDIF
2375  ELSEIF(im.NE.0.AND.mmat.EQ.46) THEN
2376  msgn=isign(1,k(im,2)*k(ip,2))
2377  IF(kfam.GT.100.AND.mod(kfam/1000,10).EQ.0) msgn=
2378  & msgn*(-1)**mod(kfam/100,10)
2379  ENDIF
2380  ENDIF
2381 
2382 C...Kinematics of one-particle decays.
2383  IF(nd.EQ.1) THEN
2384  DO 400 j=1,4
2385  p(n+1,j)=p(ip,j)
2386  400 CONTINUE
2387  goto 660
2388  ENDIF
2389 
2390 C...Calculate maximum weight ND-particle decay.
2391  pv(nd,5)=p(n+nd,5)
2392  IF(nd.GE.3) THEN
2393  wtmax=1./wtcor(nd-2)
2394  pmax=pv(1,5)-ps+p(n+nd,5)
2395  pmin=0.
2396  DO 410 il=nd-1,1,-1
2397  pmax=pmax+p(n+il,5)
2398  pmin=pmin+p(n+il+1,5)
2399  wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
2400  410 CONTINUE
2401  ENDIF
2402 
2403 C...Find virtual gamma mass in Dalitz decay.
2404  420 IF(nd.EQ.2) THEN
2405  ELSEIF(mmat.EQ.2) THEN
2406  pmes=4.*pmas(11,1)**2
2407  pmrho2=pmas(131,1)**2
2408  pgrho2=pmas(131,2)**2
2409  430 pmst=pmes*(p(ip,5)**2/pmes)**rlu(0)
2410  wt=(1+0.5*pmes/pmst)*sqrt(max(0.,1.-pmes/pmst))*
2411  & (1.-pmst/p(ip,5)**2)**3*(1.+pgrho2/pmrho2)/
2412  & ((1.-pmst/pmrho2)**2+pgrho2/pmrho2)
2413  IF(wt.LT.rlu(0)) goto 430
2414  pv(2,5)=max(2.00001*pmas(11,1),sqrt(pmst))
2415 
2416 C...M-generator gives weight. If rejected, try again.
2417  ELSE
2418  440 rord(1)=1.
2419  DO 470 il1=2,nd-1
2420  rsav=rlu(0)
2421  DO 450 il2=il1-1,1,-1
2422  IF(rsav.LE.rord(il2)) goto 460
2423  rord(il2+1)=rord(il2)
2424  450 CONTINUE
2425  460 rord(il2+1)=rsav
2426  470 CONTINUE
2427  rord(nd)=0.
2428  wt=1.
2429  DO 480 il=nd-1,1,-1
2430  pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*(pv(1,5)-ps)
2431  wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
2432  480 CONTINUE
2433  IF(wt.LT.rlu(0)*wtmax) goto 440
2434  ENDIF
2435 
2436 C...Perform two-particle decays in respective CM frame.
2437  490 DO 510 il=1,nd-1
2438  pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
2439  ue(3)=2.*rlu(0)-1.
2440  phi=paru(2)*rlu(0)
2441  ue(1)=sqrt(1.-ue(3)**2)*cos(phi)
2442  ue(2)=sqrt(1.-ue(3)**2)*sin(phi)
2443  DO 500 j=1,3
2444  p(n+il,j)=pa*ue(j)
2445  pv(il+1,j)=-pa*ue(j)
2446  500 CONTINUE
2447  p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
2448  pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
2449  510 CONTINUE
2450 
2451 C...Lorentz transform decay products to lab frame.
2452  DO 520 j=1,4
2453  p(n+nd,j)=pv(nd,j)
2454  520 CONTINUE
2455  DO 560 il=nd-1,1,-1
2456  DO 530 j=1,3
2457  be(j)=pv(il,j)/pv(il,4)
2458  530 CONTINUE
2459  ga=pv(il,4)/pv(il,5)
2460  DO 550 i=n+il,n+nd
2461  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
2462  DO 540 j=1,3
2463  p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
2464  540 CONTINUE
2465  p(i,4)=ga*(p(i,4)+bep)
2466  550 CONTINUE
2467  560 CONTINUE
2468 
2469 C...Check that no infinite loop in matrix element weight.
2470  ntry=ntry+1
2471  IF(ntry.GT.800) goto 590
2472 
2473 C...Matrix elements for omega and phi decays.
2474  IF(mmat.EQ.1) THEN
2475  wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
2476  & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
2477  & +2.*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
2478  IF(max(wt*wtcor(9)/p(ip,5)**6,0.001).LT.rlu(0)) goto 420
2479 
2480 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
2481  ELSEIF(mmat.EQ.2) THEN
2482  four12=four(n+1,n+2)
2483  four13=four(n+1,n+3)
2484  wt=(pmst-0.5*pmes)*(four12**2+four13**2)+
2485  & pmes*(four12*four13+four12**2+four13**2)
2486  IF(wt.LT.rlu(0)*0.25*pmst*(p(ip,5)**2-pmst)**2) goto 490
2487 
2488 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
2489 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
2490 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
2491  ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
2492  four10=four(ip,im)
2493  four12=four(ip,n+1)
2494  four02=four(im,n+1)
2495  pms1=p(ip,5)**2
2496  pms0=p(im,5)**2
2497  pms2=p(n+1,5)**2
2498  IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2
2499  IF(kfas.EQ.22) hnum=pms1*(2.*four10*four12*four02-
2500  & pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)
2501  hnum=max(1e-6*pms1**2*pms0*pms2,hnum)
2502  hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)
2503  IF(hnum.LT.rlu(0)*hden) goto 490
2504 
2505 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
2506  ELSEIF(mmat.EQ.4) THEN
2507  hx1=2.*four(ip,n+1)/p(ip,5)**2
2508  hx2=2.*four(ip,n+2)/p(ip,5)**2
2509  hx3=2.*four(ip,n+3)/p(ip,5)**2
2510  wt=((1.-hx1)/(hx2*hx3))**2+((1.-hx2)/(hx1*hx3))**2+
2511  & ((1.-hx3)/(hx1*hx2))**2
2512  IF(wt.LT.2.*rlu(0)) goto 420
2513  IF(k(ip+1,2).EQ.22.AND.(1.-hx1)*p(ip,5)**2.LT.4.*parj(32)**2)
2514  & goto 420
2515 
2516 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
2517  ELSEIF(mmat.EQ.41) THEN
2518  hx1=2.*four(ip,n+1)/p(ip,5)**2
2519  hxm=min(0.75,2.*(1.-ps/p(ip,5)))
2520  IF(hx1*(3.-2.*hx1).LT.rlu(0)*hxm*(3.-2.*hxm)) goto 420
2521 
2522 C...Matrix elements for weak decays (only semileptonic for c and b)
2523  ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
2524  &.AND.nd.EQ.3) THEN
2525  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
2526  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
2527  IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 420
2528  ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN
2529  DO 580 j=1,4
2530  p(n+np+1,j)=0.
2531  DO 570 is=n+3,n+np
2532  p(n+np+1,j)=p(n+np+1,j)+p(is,j)
2533  570 CONTINUE
2534  580 CONTINUE
2535  IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
2536  IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
2537  IF(wt.LT.rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 420
2538 
2539 C...Angular distribution in W decay.
2540  ELSEIF(mmat.EQ.46.AND.msgn.NE.0) THEN
2541  IF(msgn.GT.0) wt=four(im,n+1)*four(n+2,ip+1)
2542  IF(msgn.LT.0) wt=four(im,n+2)*four(n+1,ip+1)
2543  IF(wt.LT.rlu(0)*p(im,5)**4/wtcor(10)) goto 490
2544  ENDIF
2545 
2546 C...Scale back energy and reattach spectator.
2547  590 IF(mrem.EQ.1) THEN
2548  DO 600 j=1,5
2549  pv(1,j)=pv(1,j)/(1.-pqt)
2550  600 CONTINUE
2551  nd=nd+1
2552  mrem=0
2553  ENDIF
2554 
2555 C...Low invariant mass for system with spectator quark gives particle,
2556 C...not two jets. Readjust momenta accordingly.
2557  IF((mmat.EQ.31.OR.mmat.EQ.45).AND.nd.EQ.3) THEN
2558  mstj(93)=1
2559  pm2=ulmass(k(n+2,2))
2560  mstj(93)=1
2561  pm3=ulmass(k(n+3,2))
2562  IF(p(n+2,5)**2+p(n+3,5)**2+2.*four(n+2,n+3).GE.
2563  & (parj(32)+pm2+pm3)**2) goto 660
2564  k(n+2,1)=1
2565  kftemp=k(n+2,2)
2566  CALL lukfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
2567  IF(k(n+2,2).EQ.0) goto 260
2568  p(n+2,5)=ulmass(k(n+2,2))
2569  ps=p(n+1,5)+p(n+2,5)
2570  pv(2,5)=p(n+2,5)
2571  mmat=0
2572  nd=2
2573  goto 490
2574  ELSEIF(mmat.EQ.44) THEN
2575  mstj(93)=1
2576  pm3=ulmass(k(n+3,2))
2577  mstj(93)=1
2578  pm4=ulmass(k(n+4,2))
2579  IF(p(n+3,5)**2+p(n+4,5)**2+2.*four(n+3,n+4).GE.
2580  & (parj(32)+pm3+pm4)**2) goto 630
2581  k(n+3,1)=1
2582  kftemp=k(n+3,2)
2583  CALL lukfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
2584  IF(k(n+3,2).EQ.0) goto 260
2585  p(n+3,5)=ulmass(k(n+3,2))
2586  DO 610 j=1,3
2587  p(n+3,j)=p(n+3,j)+p(n+4,j)
2588  610 CONTINUE
2589  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)
2590  ha=p(n+1,4)**2-p(n+2,4)**2
2591  hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
2592  hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
2593  & (p(n+1,3)-p(n+2,3))**2
2594  hd=(pv(1,4)-p(n+3,4))**2
2595  he=ha**2-2.*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
2596  hf=hd*hc-hb**2
2597  hg=hd*hc-ha*hb
2598  hh=(sqrt(hg**2+he*hf)-hg)/(2.*hf)
2599  DO 620 j=1,3
2600  pcor=hh*(p(n+1,j)-p(n+2,j))
2601  p(n+1,j)=p(n+1,j)+pcor
2602  p(n+2,j)=p(n+2,j)-pcor
2603  620 CONTINUE
2604  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)
2605  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)
2606  nd=nd-1
2607  ENDIF
2608 
2609 C...Check invariant mass of W jets. May give one particle or start over.
2610  630 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
2611  &.AND.iabs(k(n+1,2)).LT.10) THEN
2612  pmr=sqrt(max(0.,p(n+1,5)**2+p(n+2,5)**2+2.*four(n+1,n+2)))
2613  mstj(93)=1
2614  pm1=ulmass(k(n+1,2))
2615  mstj(93)=1
2616  pm2=ulmass(k(n+2,2))
2617  IF(pmr.GT.parj(32)+pm1+pm2) goto 640
2618  kfldum=int(1.5+rlu(0))
2619  CALL lukfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
2620  CALL lukfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
2621  IF(kf1.EQ.0.OR.kf2.EQ.0) goto 260
2622  psm=ulmass(kf1)+ulmass(kf2)
2623  IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) goto 640
2624  IF(mmat.GE.43.AND.pmr.GT.0.2*parj(32)+psm) goto 640
2625  IF(mmat.EQ.48) goto 420
2626  IF(nd.EQ.4.OR.kfa.EQ.15) goto 260
2627  k(n+1,1)=1
2628  kftemp=k(n+1,2)
2629  CALL lukfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
2630  IF(k(n+1,2).EQ.0) goto 260
2631  p(n+1,5)=ulmass(k(n+1,2))
2632  k(n+2,2)=k(n+3,2)
2633  p(n+2,5)=p(n+3,5)
2634  ps=p(n+1,5)+p(n+2,5)
2635  IF(ps+parj(64).GT.pv(1,5)) goto 260
2636  pv(2,5)=p(n+3,5)
2637  mmat=0
2638  nd=2
2639  goto 490
2640  ENDIF
2641 
2642 C...Phase space decay of partons from W decay.
2643  640 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN
2644  kflo(1)=k(n+1,2)
2645  kflo(2)=k(n+2,2)
2646  k(n+1,1)=k(n+3,1)
2647  k(n+1,2)=k(n+3,2)
2648  DO 650 j=1,5
2649  pv(1,j)=p(n+1,j)+p(n+2,j)
2650  p(n+1,j)=p(n+3,j)
2651  650 CONTINUE
2652  pv(1,5)=pmr
2653  n=n+1
2654  np=0
2655  nq=2
2656  ps=0.
2657  mstj(93)=2
2658  psq=ulmass(kflo(1))
2659  mstj(93)=2
2660  psq=psq+ulmass(kflo(2))
2661  mmat=11
2662  goto 290
2663  ENDIF
2664 
2665 C...Boost back for rapidly moving particle.
2666  660 n=n+nd
2667  IF(mbst.EQ.1) THEN
2668  DO 670 j=1,3
2669  be(j)=p(ip,j)/p(ip,4)
2670  670 CONTINUE
2671  ga=p(ip,4)/p(ip,5)
2672  DO 690 i=nsav+1,n
2673  bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
2674  DO 680 j=1,3
2675  p(i,j)=p(i,j)+ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
2676  680 CONTINUE
2677  p(i,4)=ga*(p(i,4)+bep)
2678  690 CONTINUE
2679  ENDIF
2680 
2681 C...Fill in position of decay vertex.
2682  DO 710 i=nsav+1,n
2683  DO 700 j=1,4
2684  v(i,j)=vdcy(j)
2685  700 CONTINUE
2686  v(i,5)=0.
2687  710 CONTINUE
2688 
2689 C...Set up for parton shower evolution from jets.
2690  IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
2691  k(nsav+1,1)=3
2692  k(nsav+2,1)=3
2693  k(nsav+3,1)=3
2694  k(nsav+1,4)=mstu(5)*(nsav+2)
2695  k(nsav+1,5)=mstu(5)*(nsav+3)
2696  k(nsav+2,4)=mstu(5)*(nsav+3)
2697  k(nsav+2,5)=mstu(5)*(nsav+1)
2698  k(nsav+3,4)=mstu(5)*(nsav+1)
2699  k(nsav+3,5)=mstu(5)*(nsav+2)
2700  mstj(92)=-(nsav+1)
2701  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
2702  k(nsav+2,1)=3
2703  k(nsav+3,1)=3
2704  k(nsav+2,4)=mstu(5)*(nsav+3)
2705  k(nsav+2,5)=mstu(5)*(nsav+3)
2706  k(nsav+3,4)=mstu(5)*(nsav+2)
2707  k(nsav+3,5)=mstu(5)*(nsav+2)
2708  mstj(92)=nsav+2
2709  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46)
2710  &.AND.iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
2711  k(nsav+1,1)=3
2712  k(nsav+2,1)=3
2713  k(nsav+1,4)=mstu(5)*(nsav+2)
2714  k(nsav+1,5)=mstu(5)*(nsav+2)
2715  k(nsav+2,4)=mstu(5)*(nsav+1)
2716  k(nsav+2,5)=mstu(5)*(nsav+1)
2717  mstj(92)=nsav+1
2718  ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44.OR.mmat.EQ.46)
2719  &.AND.iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN
2720  mstj(92)=nsav+1
2721  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
2722  &THEN
2723  k(nsav+1,1)=3
2724  k(nsav+2,1)=3
2725  k(nsav+3,1)=3
2726  kcp=lucomp(k(nsav+1,2))
2727  kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
2728  jcon=4
2729  IF(kqp.LT.0) jcon=5
2730  k(nsav+1,jcon)=mstu(5)*(nsav+2)
2731  k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
2732  k(nsav+2,jcon)=mstu(5)*(nsav+3)
2733  k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
2734  mstj(92)=nsav+1
2735  ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
2736  k(nsav+1,1)=3
2737  k(nsav+3,1)=3
2738  k(nsav+1,4)=mstu(5)*(nsav+3)
2739  k(nsav+1,5)=mstu(5)*(nsav+3)
2740  k(nsav+3,4)=mstu(5)*(nsav+1)
2741  k(nsav+3,5)=mstu(5)*(nsav+1)
2742  mstj(92)=nsav+1
2743 
2744 C...Set up for parton shower evolution in t -> W + b.
2745  ELSEIF(mstj(27).GE.1.AND.mmat.EQ.45.AND.nd.EQ.3) THEN
2746  k(nsav+2,1)=3
2747  k(nsav+3,1)=3
2748  k(nsav+2,4)=mstu(5)*(nsav+3)
2749  k(nsav+2,5)=mstu(5)*(nsav+3)
2750  k(nsav+3,4)=mstu(5)*(nsav+2)
2751  k(nsav+3,5)=mstu(5)*(nsav+2)
2752  mstj(92)=nsav+1
2753  ENDIF
2754 
2755 C...Mark decayed particle; special option for B-B~ mixing.
2756  IF(k(ip,1).EQ.5) k(ip,1)=15
2757  IF(k(ip,1).LE.10) k(ip,1)=11
2758  IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12
2759  k(ip,4)=nsav+1
2760  k(ip,5)=n
2761 
2762  RETURN
2763  END
2764 
2765 C*********************************************************************
2766 
2767  SUBROUTINE lukfdi(KFL1,KFL2,KFL3,KF)
2768 
2769 C...Purpose: to generate a new flavour pair and combine off a hadron.
2770  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
2771  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
2772  SAVE /ludat1/,/ludat2/
2773 
2774 C...Default flavour values. Input consistency checks.
2775  kf1a=iabs(kfl1)
2776  kf2a=iabs(kfl2)
2777  kfl3=0
2778  kf=0
2779  IF(kf1a.EQ.0) RETURN
2780  IF(kf2a.NE.0) THEN
2781  IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
2782  IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
2783  IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
2784  ENDIF
2785 
2786 C...Check if tabulated flavour probabilities are to be used.
2787  IF(mstj(15).EQ.1) THEN
2788  ktab1=-1
2789  IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
2790  kfl1a=mod(kf1a/1000,10)
2791  kfl1b=mod(kf1a/100,10)
2792  kfl1s=mod(kf1a,10)
2793  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
2794  & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
2795  IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
2796  IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
2797  ktab2=0
2798  IF(kf2a.NE.0) THEN
2799  ktab2=-1
2800  IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
2801  kfl2a=mod(kf2a/1000,10)
2802  kfl2b=mod(kf2a/100,10)
2803  kfl2s=mod(kf2a,10)
2804  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
2805  & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
2806  IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
2807  ENDIF
2808  IF(ktab1.GE.0.AND.ktab2.GE.0) goto 150
2809  ENDIF
2810 
2811 C...Parameters and breaking diquark parameter combinations.
2812  100 par2=parj(2)
2813  par3=parj(3)
2814  par4=3.*parj(4)
2815  IF(mstj(12).GE.2) THEN
2816  par3m=sqrt(parj(3))
2817  par4m=1./(3.*sqrt(parj(4)))
2818  pardm=parj(7)/(parj(7)+par3m*parj(6))
2819  pars0=parj(5)*(2.+(1.+par2*par3m*parj(7))*(1.+par4m))
2820  pars1=parj(7)*pars0/(2.*par3m)+parj(5)*(parj(6)*(1.+par4m)+
2821  & par2*par3m*parj(6)*parj(7))
2822  pars2=parj(5)*2.*parj(6)*parj(7)*(par2*parj(7)+(1.+par4m)/par3m)
2823  parsm=max(pars0,pars1,pars2)
2824  par4=par4*(1.+parsm)/(1.+parsm/(3.*par4m))
2825  ENDIF
2826 
2827 C...Choice of whether to generate meson or baryon.
2828  110 mbary=0
2829  kfda=0
2830  IF(kf1a.LE.10) THEN
2831  IF(kf2a.EQ.0.AND.mstj(12).GE.1.AND.(1.+parj(1))*rlu(0).GT.1.)
2832  & mbary=1
2833  IF(kf2a.GT.10) mbary=2
2834  IF(kf2a.GT.10.AND.kf2a.LE.10000) kfda=kf2a
2835  ELSE
2836  mbary=2
2837  IF(kf1a.LE.10000) kfda=kf1a
2838  ENDIF
2839 
2840 C...Possibility of process diquark -> meson + new diquark.
2841  IF(kfda.NE.0.AND.mstj(12).GE.2) THEN
2842  kflda=mod(kfda/1000,10)
2843  kfldb=mod(kfda/100,10)
2844  kflds=mod(kfda,10)
2845  wtdq=pars0
2846  IF(max(kflda,kfldb).EQ.3) wtdq=pars1
2847  IF(min(kflda,kfldb).EQ.3) wtdq=pars2
2848  IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
2849  IF((1.+wtdq)*rlu(0).GT.1.) mbary=-1
2850  IF(mbary.EQ.-1.AND.kf2a.NE.0) RETURN
2851  ENDIF
2852 
2853 C...Flavour for meson, possibly with new flavour.
2854  IF(mbary.LE.0) THEN
2855  kfs=isign(1,kfl1)
2856  IF(mbary.EQ.0) THEN
2857  IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),-kfl1)
2858  kfla=max(kf1a,kf2a+iabs(kfl3))
2859  kflb=min(kf1a,kf2a+iabs(kfl3))
2860  IF(kfla.NE.kf1a) kfs=-kfs
2861 
2862 C...Splitting of diquark into meson plus new diquark.
2863  ELSE
2864  kfl1a=mod(kf1a/1000,10)
2865  kfl1b=mod(kf1a/100,10)
2866  120 kfl1d=kfl1a+int(rlu(0)+0.5)*(kfl1b-kfl1a)
2867  kfl1e=kfl1a+kfl1b-kfl1d
2868  IF((kfl1d.EQ.3.AND.rlu(0).GT.pardm).OR.(kfl1e.EQ.3.AND.
2869  & rlu(0).LT.pardm)) THEN
2870  kfl1d=kfl1a+kfl1b-kfl1d
2871  kfl1e=kfl1a+kfl1b-kfl1e
2872  ENDIF
2873  kfl3a=1+int((2.+par2*par3m*parj(7))*rlu(0))
2874  IF((kfl1e.NE.kfl3a.AND.rlu(0).GT.(1.+par4m)/max(2.,1.+par4m))
2875  & .OR.(kfl1e.EQ.kfl3a.AND.rlu(0).GT.2./max(2.,1.+par4m)))
2876  & goto 120
2877  kflds=3
2878  IF(kfl1e.NE.kfl3a) kflds=2*int(rlu(0)+1./(1.+par4m))+1
2879  kfl3=isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+
2880  & kflds,-kfl1)
2881  kfla=max(kfl1d,kfl3a)
2882  kflb=min(kfl1d,kfl3a)
2883  IF(kfla.NE.kfl1d) kfs=-kfs
2884  ENDIF
2885 
2886 C...Form meson, with spin and flavour mixing for diagonal states.
2887  IF(kfla.LE.2) kmul=int(parj(11)+rlu(0))
2888  IF(kfla.EQ.3) kmul=int(parj(12)+rlu(0))
2889  IF(kfla.GE.4) kmul=int(parj(13)+rlu(0))
2890  IF(kmul.EQ.0.AND.parj(14).GT.0.) THEN
2891  IF(rlu(0).LT.parj(14)) kmul=2
2892  ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0.) THEN
2893  rmul=rlu(0)
2894  IF(rmul.LT.parj(15)) kmul=3
2895  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
2896  IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
2897  ENDIF
2898  kfls=3
2899  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
2900  IF(kmul.EQ.5) kfls=5
2901  IF(kfla.NE.kflb) THEN
2902  kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
2903  ELSE
2904  rmix=rlu(0)
2905  imix=2*kfla+10*kmul
2906  IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
2907  & int(rmix+parf(imix)))+kfls
2908  IF(kfla.GE.4) kf=110*kfla+kfls
2909  ENDIF
2910  IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
2911  IF(kmul.EQ.4) kf=kf+isign(20000,kf)
2912 
2913 C...Optional extra suppression of eta and eta'.
2914  IF(kf.EQ.221) THEN
2915  IF(rlu(0).GT.parj(25)) goto 110
2916  ELSEIF(kf.EQ.331) THEN
2917  IF(rlu(0).GT.parj(26)) goto 110
2918  ENDIF
2919 
2920 C...Generate diquark flavour.
2921  ELSE
2922  130 IF(kf1a.LE.10.AND.kf2a.EQ.0) THEN
2923  kfla=kf1a
2924  140 kflb=1+int((2.+par2*par3)*rlu(0))
2925  kflc=1+int((2.+par2*par3)*rlu(0))
2926  kflds=1
2927  IF(kflb.GE.kflc) kflds=3
2928  IF(kflds.EQ.1.AND.par4*rlu(0).GT.1.) goto 140
2929  IF(kflds.EQ.3.AND.par4.LT.rlu(0)) goto 140
2930  kfl3=isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds,kfl1)
2931 
2932 C...Take diquark flavour from input.
2933  ELSEIF(kf1a.LE.10) THEN
2934  kfla=kf1a
2935  kflb=mod(kf2a/1000,10)
2936  kflc=mod(kf2a/100,10)
2937  kflds=mod(kf2a,10)
2938 
2939 C...Generate (or take from input) quark to go with diquark.
2940  ELSE
2941  IF(kf2a.EQ.0) kfl3=isign(1+int((2.+par2)*rlu(0)),kfl1)
2942  kfla=kf2a+iabs(kfl3)
2943  kflb=mod(kf1a/1000,10)
2944  kflc=mod(kf1a/100,10)
2945  kflds=mod(kf1a,10)
2946  ENDIF
2947 
2948 C...SU(6) factors for formation of baryon. Try again if fails.
2949  kbary=kflds
2950  IF(kflds.EQ.3.AND.kflb.NE.kflc) kbary=5
2951  IF(kfla.NE.kflb.AND.kfla.NE.kflc) kbary=kbary+1
2952  wt=parf(60+kbary)+parj(18)*parf(70+kbary)
2953  IF(mbary.EQ.1.AND.mstj(12).GE.2) THEN
2954  wtdq=pars0
2955  IF(max(kflb,kflc).EQ.3) wtdq=pars1
2956  IF(min(kflb,kflc).EQ.3) wtdq=pars2
2957  IF(kflds.EQ.1) wtdq=wtdq/(3.*par4m)
2958  IF(kflds.EQ.1) wt=wt*(1.+wtdq)/(1.+parsm/(3.*par4m))
2959  IF(kflds.EQ.3) wt=wt*(1.+wtdq)/(1.+parsm)
2960  ENDIF
2961  IF(kf2a.EQ.0.AND.wt.LT.rlu(0)) goto 130
2962 
2963 C...Form baryon. Distinguish Lambda- and Sigmalike baryons.
2964  kfld=max(kfla,kflb,kflc)
2965  kflf=min(kfla,kflb,kflc)
2966  kfle=kfla+kflb+kflc-kfld-kflf
2967  kfls=2
2968  IF((parf(60+kbary)+parj(18)*parf(70+kbary))*rlu(0).GT.
2969  & parf(60+kbary)) kfls=4
2970  kfll=0
2971  IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf) THEN
2972  IF(kflds.EQ.1.AND.kfla.EQ.kfld) kfll=1
2973  IF(kflds.EQ.1.AND.kfla.NE.kfld) kfll=int(0.25+rlu(0))
2974  IF(kflds.EQ.3.AND.kfla.NE.kfld) kfll=int(0.75+rlu(0))
2975  ENDIF
2976  IF(kfll.EQ.0) kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
2977  IF(kfll.EQ.1) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
2978  ENDIF
2979  RETURN
2980 
2981 C...Use tabulated probabilities to select new flavour and hadron.
2982  150 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
2983  kt3l=1
2984  kt3u=6
2985  ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
2986  kt3l=1
2987  kt3u=6
2988  ELSEIF(ktab2.EQ.0) THEN
2989  kt3l=1
2990  kt3u=22
2991  ELSE
2992  kt3l=ktab2
2993  kt3u=ktab2
2994  ENDIF
2995  rfl=0.
2996  DO 170 kts=0,2
2997  DO 160 kt3=kt3l,kt3u
2998  rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
2999  160 CONTINUE
3000  170 CONTINUE
3001  rfl=rlu(0)*rfl
3002  DO 190 kts=0,2
3003  ktabs=kts
3004  DO 180 kt3=kt3l,kt3u
3005  ktab3=kt3
3006  rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
3007  IF(rfl.LE.0.) goto 200
3008  180 CONTINUE
3009  190 CONTINUE
3010  200 CONTINUE
3011 
3012 C...Reconstruct flavour of produced quark/diquark.
3013  IF(ktab3.LE.6) THEN
3014  kfl3a=ktab3
3015  kfl3b=0
3016  kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
3017  ELSE
3018  kfl3a=1
3019  IF(ktab3.GE.8) kfl3a=2
3020  IF(ktab3.GE.11) kfl3a=3
3021  IF(ktab3.GE.16) kfl3a=4
3022  kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
3023  kfl3=1000*kfl3a+100*kfl3b+1
3024  IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
3025  & kfl3+2
3026  kfl3=isign(kfl3,kfl1*(13-2*ktab1))
3027  ENDIF
3028 
3029 C...Reconstruct meson code.
3030  IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
3031  &kfl3b.NE.0)) THEN
3032  rfl=rlu(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
3033  & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
3034  kf=110+2*ktabs+1
3035  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
3036  IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
3037  & 25*ktabs)) kf=330+2*ktabs+1
3038  ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
3039  kfla=max(ktab1,ktab3)
3040  kflb=min(ktab1,ktab3)
3041  kfs=isign(1,kfl1)
3042  IF(kfla.NE.kf1a) kfs=-kfs
3043  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
3044  ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
3045  kfs=isign(1,kfl1)
3046  IF(kfl1a.EQ.kfl3a) THEN
3047  kfla=max(kfl1b,kfl3b)
3048  kflb=min(kfl1b,kfl3b)
3049  IF(kfla.NE.kfl1b) kfs=-kfs
3050  ELSEIF(kfl1a.EQ.kfl3b) THEN
3051  kfla=kfl3a
3052  kflb=kfl1b
3053  kfs=-kfs
3054  ELSEIF(kfl1b.EQ.kfl3a) THEN
3055  kfla=kfl1a
3056  kflb=kfl3b
3057  ELSEIF(kfl1b.EQ.kfl3b) THEN
3058  kfla=max(kfl1a,kfl3a)
3059  kflb=min(kfl1a,kfl3a)
3060  IF(kfla.NE.kfl1a) kfs=-kfs
3061  ELSE
3062  CALL luerrm(2,'(LUKFDI:) no matching flavours for qq -> qq')
3063  goto 100
3064  ENDIF
3065  kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
3066 
3067 C...Reconstruct baryon code.
3068  ELSE
3069  IF(ktab1.GE.7) THEN
3070  kfla=kfl3a
3071  kflb=kfl1a
3072  kflc=kfl1b
3073  ELSE
3074  kfla=kfl1a
3075  kflb=kfl3a
3076  kflc=kfl3b
3077  ENDIF
3078  kfld=max(kfla,kflb,kflc)
3079  kflf=min(kfla,kflb,kflc)
3080  kfle=kfla+kflb+kflc-kfld-kflf
3081  IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
3082  IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
3083  ENDIF
3084 
3085 C...Check that constructed flavour code is an allowed one.
3086  IF(kfl2.NE.0) kfl3=0
3087  kc=lucomp(kf)
3088  IF(kc.EQ.0) THEN
3089  CALL luerrm(2,'(LUKFDI:) user-defined flavour probabilities '//
3090  & 'failed')
3091  goto 100
3092  ENDIF
3093 
3094  RETURN
3095  END
3096 
3097 C*********************************************************************
3098 
3099  SUBROUTINE luptdi(KFL,PX,PY)
3100 
3101 C...Purpose: to generate transverse momentum according to a Gaussian.
3102  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3103  SAVE /ludat1/
3104 
3105 C...Generate p_T and azimuthal angle, gives p_x and p_y.
3106  kfla=iabs(kfl)
3107  pt=parj(21)*sqrt(-log(max(1e-10,rlu(0))))
3108  IF(parj(23).GT.rlu(0)) pt=parj(24)*pt
3109  IF(mstj(91).EQ.1) pt=parj(22)*pt
3110  IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0.
3111  phi=paru(2)*rlu(0)
3112  px=pt*cos(phi)
3113  py=pt*sin(phi)
3114 
3115  RETURN
3116  END
3117 
3118 C*********************************************************************
3119 
3120  SUBROUTINE luzdis(KFL1,KFL2,PR,Z)
3121 
3122 C...Purpose: to generate the longitudinal splitting variable z.
3123  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3124  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3125  SAVE /ludat1/,/ludat2/
3126 
3127 C...Check if heavy flavour fragmentation.
3128  kfla=iabs(kfl1)
3129  kflb=iabs(kfl2)
3130  kflh=kfla
3131  IF(kfla.GE.10) kflh=mod(kfla/1000,10)
3132 
3133 C...Lund symmetric scaling function: determine parameters of shape.
3134  IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.
3135  &mstj(11).GE.4) THEN
3136  fa=parj(41)
3137  IF(mstj(91).EQ.1) fa=parj(43)
3138  IF(kflb.GE.10) fa=fa+parj(45)
3139  fbb=parj(42)
3140  IF(mstj(91).EQ.1) fbb=parj(44)
3141  fb=fbb*pr
3142  fc=1.
3143  IF(kfla.GE.10) fc=fc-parj(45)
3144  IF(kflb.GE.10) fc=fc+parj(45)
3145  IF(mstj(11).GE.4.AND.kflh.GE.4.AND.kflh.LE.5) THEN
3146  fred=parj(46)
3147  IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)
3148  fc=fc+fred*fbb*parf(100+kflh)**2
3149  ELSEIF(mstj(11).GE.4.AND.kflh.GE.6.AND.kflh.LE.8) THEN
3150  fred=parj(46)
3151  IF(mstj(11).EQ.5) fred=parj(48)
3152  fc=fc+fred*fbb*pmas(kflh,1)**2
3153  ENDIF
3154  mc=1
3155  IF(abs(fc-1.).GT.0.01) mc=2
3156 
3157 C...Determine position of maximum. Special cases for a = 0 or a = c.
3158  IF(fa.LT.0.02) THEN
3159  ma=1
3160  zmax=1.
3161  IF(fc.GT.fb) zmax=fb/fc
3162  ELSEIF(abs(fc-fa).LT.0.01) THEN
3163  ma=2
3164  zmax=fb/(fb+fc)
3165  ELSE
3166  ma=3
3167  zmax=0.5*(fb+fc-sqrt((fb-fc)**2+4.*fa*fb))/(fc-fa)
3168  IF(zmax.GT.0.9999.AND.fb.GT.100.) zmax=min(zmax,1.-fa/fb)
3169  ENDIF
3170 
3171 C...Subdivide z range if distribution very peaked near endpoint.
3172  mmax=2
3173  IF(zmax.LT.0.1) THEN
3174  mmax=1
3175  zdiv=2.75*zmax
3176  IF(mc.EQ.1) THEN
3177  fint=1.-log(zdiv)
3178  ELSE
3179  zdivc=zdiv**(1.-fc)
3180  fint=1.+(1.-1./zdivc)/(fc-1.)
3181  ENDIF
3182  ELSEIF(zmax.GT.0.85.AND.fb.GT.1.) THEN
3183  mmax=3
3184  fscb=sqrt(4.+(fc/fb)**2)
3185  zdiv=fscb-1./zmax-(fc/fb)*log(zmax*0.5*(fscb+fc/fb))
3186  IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1.-zmax)
3187  zdiv=min(zmax,max(0.,zdiv))
3188  fint=1.+fb*(1.-zdiv)
3189  ENDIF
3190 
3191 C...Choice of z, preweighted for peaks at low or high z.
3192  100 z=rlu(0)
3193  fpre=1.
3194  IF(mmax.EQ.1) THEN
3195  IF(fint*rlu(0).LE.1.) THEN
3196  z=zdiv*z
3197  ELSEIF(mc.EQ.1) THEN
3198  z=zdiv**z
3199  fpre=zdiv/z
3200  ELSE
3201  z=1./(zdivc+z*(1.-zdivc))**(1./(1.-fc))
3202  fpre=(zdiv/z)**fc
3203  ENDIF
3204  ELSEIF(mmax.EQ.3) THEN
3205  IF(fint*rlu(0).LE.1.) THEN
3206  z=zdiv+log(z)/fb
3207  fpre=exp(fb*(z-zdiv))
3208  ELSE
3209  z=zdiv+z*(1.-zdiv)
3210  ENDIF
3211  ENDIF
3212 
3213 C...Weighting according to correct formula.
3214  IF(z.LE.0..OR.z.GE.1.) goto 100
3215  fexp=fc*log(zmax/z)+fb*(1./zmax-1./z)
3216  IF(ma.GE.2) fexp=fexp+fa*log((1.-z)/(1.-zmax))
3217  fval=exp(max(-50.,min(50.,fexp)))
3218  IF(fval.LT.rlu(0)*fpre) goto 100
3219 
3220 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
3221  ELSE
3222  fc=parj(50+max(1,kflh))
3223  IF(mstj(91).EQ.1) fc=parj(59)
3224  110 z=rlu(0)
3225  IF(fc.GE.0..AND.fc.LE.1.) THEN
3226  IF(fc.GT.rlu(0)) z=1.-z**(1./3.)
3227  ELSEIF(fc.GT.-1.AND.fc.LT.0.) THEN
3228  IF(-4.*fc*z*(1.-z)**2.LT.rlu(0)*((1.-z)**2-fc*z)**2) goto 110
3229  ELSE
3230  IF(fc.GT.0.) z=1.-z**(1./fc)
3231  IF(fc.LT.0.) z=z**(-1./fc)
3232  ENDIF
3233  ENDIF
3234 
3235  RETURN
3236  END
3237 
3238 C*********************************************************************
3239 
3240  SUBROUTINE lushow(IP1,IP2,QMAX)
3241 
3242 C...Purpose: to generate timelike parton showers from given partons.
3243  IMPLICIT DOUBLE PRECISION(d)
3244  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
3245  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
3246  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
3247  SAVE /lujets/,/ludat1/,/ludat2/
3248  dimension pmth(5,50),ps(5),pma(4),pmsd(4),iep(4),ipa(4),
3249  &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4),
3250  &ksh(0:40),kcii(2),niis(2),iiis(2,2),theiis(2,2),phiiis(2,2),
3251  &isii(2)
3252 
3253 C...Initialization of cutoff masses etc.
3254  IF(mstj(41).LE.0.OR.(mstj(41).EQ.1.AND.qmax.LE.parj(82)).OR.
3255  &qmax.LE.min(parj(82),parj(83))) RETURN
3256  DO 100 ifl=0,40
3257  ksh(ifl)=0
3258  100 CONTINUE
3259  ksh(21)=1
3260  pmth(1,21)=ulmass(21)
3261  pmth(2,21)=sqrt(pmth(1,21)**2+0.25*parj(82)**2)
3262  pmth(3,21)=2.*pmth(2,21)
3263  pmth(4,21)=pmth(3,21)
3264  pmth(5,21)=pmth(3,21)
3265  pmth(1,22)=ulmass(22)
3266  pmth(2,22)=sqrt(pmth(1,22)**2+0.25*parj(83)**2)
3267  pmth(3,22)=2.*pmth(2,22)
3268  pmth(4,22)=pmth(3,22)
3269  pmth(5,22)=pmth(3,22)
3270  pmqth1=parj(82)
3271  IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))
3272  pmqth2=pmth(2,21)
3273  IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))
3274  DO 110 ifl=1,8
3275  ksh(ifl)=1
3276  pmth(1,ifl)=ulmass(ifl)
3277  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25*pmqth1**2)
3278  pmth(3,ifl)=pmth(2,ifl)+pmqth2
3279  pmth(4,ifl)=sqrt(pmth(1,ifl)**2+0.25*parj(82)**2)+pmth(2,21)
3280  pmth(5,ifl)=sqrt(pmth(1,ifl)**2+0.25*parj(83)**2)+pmth(2,22)
3281  110 CONTINUE
3282  DO 120 ifl=11,17,2
3283  IF(mstj(41).GE.2) ksh(ifl)=1
3284  pmth(1,ifl)=ulmass(ifl)
3285  pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25*parj(83)**2)
3286  pmth(3,ifl)=pmth(2,ifl)+pmth(2,22)
3287  pmth(4,ifl)=pmth(3,ifl)
3288  pmth(5,ifl)=pmth(3,ifl)
3289  120 CONTINUE
3290  pt2min=max(0.5*parj(82),1.1*parj(81))**2
3291  alams=parj(81)**2
3292  alfm=log(pt2min/alams)
3293 
3294 C...Store positions of shower initiating partons.
3295  IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
3296  npa=1
3297  ipa(1)=ip1
3298  ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
3299  &mstu(32))) THEN
3300  npa=2
3301  ipa(1)=ip1
3302  ipa(2)=ip2
3303  ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0
3304  &.AND.ip2.GE.-3) THEN
3305  npa=iabs(ip2)
3306  DO 130 i=1,npa
3307  ipa(i)=ip1+i-1
3308  130 CONTINUE
3309  ELSE
3310  CALL luerrm(12,
3311  & '(LUSHOW:) failed to reconstruct showering system')
3312  IF(mstu(21).GE.1) RETURN
3313  ENDIF
3314 
3315 C...Check on phase space available for emission.
3316  irej=0
3317  DO 140 j=1,5
3318  ps(j)=0.
3319  140 CONTINUE
3320  pm=0.
3321  DO 160 i=1,npa
3322  kfla(i)=iabs(k(ipa(i),2))
3323  pma(i)=p(ipa(i),5)
3324 C...Special cutoff masses for t, l, h with variable masses.
3325  ifla=kfla(i)
3326  IF(kfla(i).GE.6.AND.kfla(i).LE.8) THEN
3327  ifla=37+kfla(i)+isign(2,k(ipa(i),2))
3328  pmth(1,ifla)=pma(i)
3329  pmth(2,ifla)=sqrt(pmth(1,ifla)**2+0.25*pmqth1**2)
3330  pmth(3,ifla)=pmth(2,ifla)+pmqth2
3331  pmth(4,ifla)=sqrt(pmth(1,ifla)**2+0.25*parj(82)**2)+pmth(2,21)
3332  pmth(5,ifla)=sqrt(pmth(1,ifla)**2+0.25*parj(83)**2)+pmth(2,22)
3333  ENDIF
3334  IF(kfla(i).LE.40) THEN
3335  IF(ksh(kfla(i)).EQ.1) pma(i)=pmth(3,ifla)
3336  ENDIF
3337  pm=pm+pma(i)
3338  IF(kfla(i).GT.40) THEN
3339  irej=irej+1
3340  ELSE
3341  IF(ksh(kfla(i)).EQ.0.OR.pma(i).GT.qmax) irej=irej+1
3342  ENDIF
3343  DO 150 j=1,4
3344  ps(j)=ps(j)+p(ipa(i),j)
3345  150 CONTINUE
3346  160 CONTINUE
3347  IF(irej.EQ.npa) RETURN
3348  ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
3349  IF(npa.EQ.1) ps(5)=ps(4)
3350  IF(ps(5).LE.pm+pmqth1) RETURN
3351 
3352 C...Check if 3-jet matrix elements to be used.
3353  m3jc=0
3354  IF(npa.EQ.2.AND.mstj(47).GE.1) THEN
3355  IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.
3356  & kfla(2).LE.8) m3jc=1
3357  IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
3358  & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)) m3jc=1
3359  IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.
3360  & kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)+1) m3jc=1
3361  IF((kfla(1).EQ.12.OR.kfla(1).EQ.14.OR.kfla(1).EQ.16.OR.
3362  & kfla(1).EQ.18).AND.kfla(2).EQ.kfla(1)-1) m3jc=1
3363  IF(mstj(47).EQ.2.OR.mstj(47).EQ.4) m3jc=1
3364  m3jcm=0
3365  IF(m3jc.EQ.1.AND.mstj(47).GE.3.AND.kfla(1).EQ.kfla(2)) THEN
3366  m3jcm=1
3367  qme=(2.*pmth(1,kfla(1))/ps(5))**2
3368  ENDIF
3369  ENDIF
3370 
3371 C...Find if interference with initial state partons.
3372  miis=0
3373  IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2) miis=mstj(50)
3374  IF(miis.NE.0) THEN
3375  DO 180 i=1,2
3376  kcii(i)=0
3377  kca=lucomp(kfla(i))
3378  IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))
3379  niis(i)=0
3380  IF(kcii(i).NE.0) THEN
3381  DO 170 j=1,2
3382  icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))
3383  IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.
3384  & (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN
3385  niis(i)=niis(i)+1
3386  iiis(i,niis(i))=icsi
3387  ENDIF
3388  170 CONTINUE
3389  ENDIF
3390  180 CONTINUE
3391  IF(niis(1)+niis(2).EQ.0) miis=0
3392  ENDIF
3393 
3394 C...Boost interfering initial partons to rest frame
3395 C...and reconstruct their polar and azimuthal angles.
3396  IF(miis.NE.0) THEN
3397  DO 200 i=1,2
3398  DO 190 j=1,5
3399  k(n+i,j)=k(ipa(i),j)
3400  p(n+i,j)=p(ipa(i),j)
3401  v(n+i,j)=0.
3402  190 CONTINUE
3403  200 CONTINUE
3404  DO 220 i=3,2+niis(1)
3405  DO 210 j=1,5
3406  k(n+i,j)=k(iiis(1,i-2),j)
3407  p(n+i,j)=p(iiis(1,i-2),j)
3408  v(n+i,j)=0.
3409  210 CONTINUE
3410  220 CONTINUE
3411  DO 240 i=3+niis(1),2+niis(1)+niis(2)
3412  DO 230 j=1,5
3413  k(n+i,j)=k(iiis(2,i-2-niis(1)),j)
3414  p(n+i,j)=p(iiis(2,i-2-niis(1)),j)
3415  v(n+i,j)=0.
3416  230 CONTINUE
3417  240 CONTINUE
3418  CALL ludbrb(n+1,n+2+niis(1)+niis(2),0.,0.,-dble(ps(1)/ps(4)),
3419  & -dble(ps(2)/ps(4)),-dble(ps(3)/ps(4)))
3420  phi=ulangl(p(n+1,1),p(n+1,2))
3421  CALL ludbrb(n+1,n+2+niis(1)+niis(2),0.,-phi,0d0,0d0,0d0)
3422  the=ulangl(p(n+1,3),p(n+1,1))
3423  CALL ludbrb(n+1,n+2+niis(1)+niis(2),-the,0.,0d0,0d0,0d0)
3424  DO 250 i=3,2+niis(1)
3425  theiis(1,i-2)=ulangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))
3426  phiiis(1,i-2)=ulangl(p(n+i,1),p(n+i,2))
3427  250 CONTINUE
3428  DO 260 i=3+niis(1),2+niis(1)+niis(2)
3429  theiis(2,i-2-niis(1))=paru(1)-ulangl(p(n+i,3),
3430  & sqrt(p(n+i,1)**2+p(n+i,2)**2))
3431  phiiis(2,i-2-niis(1))=ulangl(p(n+i,1),p(n+i,2))
3432  260 CONTINUE
3433  ENDIF
3434 
3435 C...Define imagined single initiator of shower for parton system.
3436  ns=n
3437  IF(n.GT.mstu(4)-mstu(32)-5) THEN
3438  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
3439  IF(mstu(21).GE.1) RETURN
3440  ENDIF
3441  IF(npa.GE.2) THEN
3442  k(n+1,1)=11
3443  k(n+1,2)=21
3444  k(n+1,3)=0
3445  k(n+1,4)=0
3446  k(n+1,5)=0
3447  p(n+1,1)=0.
3448  p(n+1,2)=0.
3449  p(n+1,3)=0.
3450  p(n+1,4)=ps(5)
3451  p(n+1,5)=ps(5)
3452  v(n+1,5)=ps(5)**2
3453  n=n+1
3454  ENDIF
3455 
3456 C...Loop over partons that may branch.
3457  nep=npa
3458  im=ns
3459  IF(npa.EQ.1) im=ns-1
3460  270 im=im+1
3461  IF(n.GT.ns) THEN
3462  IF(im.GT.n) goto 510
3463  kflm=iabs(k(im,2))
3464  IF(kflm.GT.40) goto 270
3465  IF(ksh(kflm).EQ.0) goto 270
3466  iflm=kflm
3467  IF(kflm.GE.6.AND.kflm.LE.8) iflm=37+kflm+isign(2,k(im,2))
3468  IF(p(im,5).LT.pmth(2,iflm)) goto 270
3469  igm=k(im,3)
3470  ELSE
3471  igm=-1
3472  ENDIF
3473  IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN
3474  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
3475  IF(mstu(21).GE.1) RETURN
3476  ENDIF
3477 
3478 C...Position of aunt (sister to branching parton).
3479 C...Origin and flavour of daughters.
3480  iau=0
3481  IF(igm.GT.0) THEN
3482  IF(k(im-1,3).EQ.igm) iau=im-1
3483  IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
3484  ENDIF
3485  IF(igm.GE.0) THEN
3486  k(im,4)=n+1
3487  DO 280 i=1,nep
3488  k(n+i,3)=im
3489  280 CONTINUE
3490  ELSE
3491  k(n+1,3)=ipa(1)
3492  ENDIF
3493  IF(igm.LE.0) THEN
3494  DO 290 i=1,nep
3495  k(n+i,2)=k(ipa(i),2)
3496  290 CONTINUE
3497  ELSEIF(kflm.NE.21) THEN
3498  k(n+1,2)=k(im,2)
3499  k(n+2,2)=k(im,5)
3500  ELSEIF(k(im,5).EQ.21) THEN
3501  k(n+1,2)=21
3502  k(n+2,2)=21
3503  ELSE
3504  k(n+1,2)=k(im,5)
3505  k(n+2,2)=-k(im,5)
3506  ENDIF
3507 
3508 C...Reset flags on daughers and tries made.
3509  DO 300 ip=1,nep
3510  k(n+ip,1)=3
3511  k(n+ip,4)=0
3512  k(n+ip,5)=0
3513  kfld(ip)=iabs(k(n+ip,2))
3514  IF(kchg(lucomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1
3515  itry(ip)=0
3516  isl(ip)=0
3517  isi(ip)=0
3518  IF(kfld(ip).LE.40) THEN
3519  IF(ksh(kfld(ip)).EQ.1) isi(ip)=1
3520  ENDIF
3521  300 CONTINUE
3522  islm=0
3523 
3524 C...Maximum virtuality of daughters.
3525  IF(igm.LE.0) THEN
3526  DO 310 i=1,npa
3527  IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)-
3528  & ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)
3529  p(n+i,5)=min(qmax,ps(5))
3530  IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))
3531  IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
3532  310 CONTINUE
3533  ELSE
3534  IF(mstj(43).LE.2) pem=v(im,2)
3535  IF(mstj(43).GE.3) pem=p(im,4)
3536  p(n+1,5)=min(p(im,5),v(im,1)*pem)
3537  p(n+2,5)=min(p(im,5),(1.-v(im,1))*pem)
3538  IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
3539  ENDIF
3540  DO 320 i=1,nep
3541  pmsd(i)=p(n+i,5)
3542  IF(isi(i).EQ.1) THEN
3543  ifld=kfld(i)
3544  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
3545  & isign(2,k(n+i,2))
3546  IF(p(n+i,5).LE.pmth(3,ifld)) p(n+i,5)=pmth(1,ifld)
3547  ENDIF
3548  v(n+i,5)=p(n+i,5)**2
3549  320 CONTINUE
3550 
3551 C...Choose one of the daughters for evolution.
3552  330 inum=0
3553  IF(nep.EQ.1) inum=1
3554  DO 340 i=1,nep
3555  IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
3556  340 CONTINUE
3557  DO 350 i=1,nep
3558  IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
3559  ifld=kfld(i)
3560  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
3561  & isign(2,k(n+i,2))
3562  IF(p(n+i,5).GE.pmth(2,ifld)) inum=i
3563  ENDIF
3564  350 CONTINUE
3565  IF(inum.EQ.0) THEN
3566  rmax=0.
3567  DO 360 i=1,nep
3568  IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqth2) THEN
3569  rpm=p(n+i,5)/pmsd(i)
3570  ifld=kfld(i)
3571  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
3572  & isign(2,k(n+i,2))
3573  IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,ifld)) THEN
3574  rmax=rpm
3575  inum=i
3576  ENDIF
3577  ENDIF
3578  360 CONTINUE
3579  ENDIF
3580 
3581 C...Store information on choice of evolving daughter.
3582  inum=max(1,inum)
3583  iep(1)=n+inum
3584  DO 370 i=2,nep
3585  iep(i)=iep(i-1)+1
3586  IF(iep(i).GT.n+nep) iep(i)=n+1
3587  370 CONTINUE
3588  DO 380 i=1,nep
3589  kfl(i)=iabs(k(iep(i),2))
3590  380 CONTINUE
3591  itry(inum)=itry(inum)+1
3592  IF(itry(inum).GT.200) THEN
3593  CALL luerrm(14,'(LUSHOW:) caught in infinite loop')
3594  IF(mstu(21).GE.1) RETURN
3595  ENDIF
3596  z=0.5
3597  IF(kfl(1).GT.40) goto 430
3598  IF(ksh(kfl(1)).EQ.0) goto 430
3599  ifl=kfl(1)
3600  IF(kfl(1).GE.6.AND.kfl(1).LE.8) ifl=37+kfl(1)+
3601  &isign(2,k(iep(1),2))
3602  IF(p(iep(1),5).LT.pmth(2,ifl)) goto 430
3603 
3604 C...Select side for interference with initial state partons.
3605  IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN
3606  iii=iep(1)-ns-1
3607  isii(iii)=0
3608  IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN
3609  isii(iii)=1
3610  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN
3611  IF(rlu(0).GT.0.5) isii(iii)=1
3612  ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN
3613  isii(iii)=1
3614  IF(rlu(0).GT.0.5) isii(iii)=2
3615  ENDIF
3616  ENDIF
3617 
3618 C...Calculate allowed z range.
3619  IF(nep.EQ.1) THEN
3620  pmed=ps(4)
3621  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
3622  pmed=p(im,5)
3623  ELSE
3624  IF(inum.EQ.1) pmed=v(im,1)*pem
3625  IF(inum.EQ.2) pmed=(1.-v(im,1))*pem
3626  ENDIF
3627  IF(mod(mstj(43),2).EQ.1) THEN
3628  zc=pmth(2,21)/pmed
3629  zce=pmth(2,22)/pmed
3630  ELSE
3631  zc=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,21)/pmed)**2)))
3632  IF(zc.LT.1e-4) zc=(pmth(2,21)/pmed)**2
3633  zce=0.5*(1.-sqrt(max(0.,1.-(2.*pmth(2,22)/pmed)**2)))
3634  IF(zce.LT.1e-4) zce=(pmth(2,22)/pmed)**2
3635  ENDIF
3636  zc=min(zc,0.491)
3637  zce=min(zce,0.491)
3638  IF((mstj(41).EQ.1.AND.zc.GT.0.49).OR.(mstj(41).GE.2.AND.
3639  &min(zc,zce).GT.0.49)) THEN
3640  p(iep(1),5)=pmth(1,ifl)
3641  v(iep(1),5)=p(iep(1),5)**2
3642  goto 430
3643  ENDIF
3644 
3645 C...Integral of Altarelli-Parisi z kernel for QCD.
3646  IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
3647  fbr=6.*log((1.-zc)/zc)+mstj(45)*(0.5-zc)
3648  ELSEIF(mstj(49).EQ.0) THEN
3649  fbr=(8./3.)*log((1.-zc)/zc)
3650 
3651 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
3652  ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
3653  fbr=(parj(87)+mstj(45)*parj(88))*(1.-2.*zc)
3654  ELSEIF(mstj(49).EQ.1) THEN
3655  fbr=(1.-2.*zc)/3.
3656  IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4.*fbr
3657 
3658 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
3659  ELSEIF(kfl(1).EQ.21) THEN
3660  fbr=6.*mstj(45)*(0.5-zc)
3661  ELSE
3662  fbr=2.*log((1.-zc)/zc)
3663  ENDIF
3664 
3665 C...Reset QCD probability for lepton.
3666  IF(kfl(1).GE.11.AND.kfl(1).LE.18) fbr=0.
3667 
3668 C...Integral of Altarelli-Parisi kernel for photon emission.
3669  IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
3670  fbre=(kchg(kfl(1),1)/3.)**2*2.*log((1.-zce)/zce)
3671  IF(mstj(41).EQ.10) fbre=parj(84)*fbre
3672  ENDIF
3673 
3674 C...Inner veto algorithm starts. Find maximum mass for evolution.
3675  390 pms=v(iep(1),5)
3676  IF(igm.GE.0) THEN
3677  pm2=0.
3678  DO 400 i=2,nep
3679  pm=p(iep(i),5)
3680  IF(kfl(i).LE.40) THEN
3681  ifli=kfl(i)
3682  IF(kfl(i).GE.6.AND.kfl(i).LE.8) ifli=37+kfl(i)+
3683  & isign(2,k(iep(i),2))
3684  IF(ksh(kfl(i)).EQ.1) pm=pmth(2,ifli)
3685  ENDIF
3686  pm2=pm2+pm
3687  400 CONTINUE
3688  pms=min(pms,(p(im,5)-pm2)**2)
3689  ENDIF
3690 
3691 C...Select mass for daughter in QCD evolution.
3692  b0=27./6.
3693  DO 410 iff=4,mstj(45)
3694  IF(pms.GT.4.*pmth(2,iff)**2) b0=(33.-2.*iff)/6.
3695  410 CONTINUE
3696  IF(fbr.LT.1e-3) THEN
3697  pmsqcd=0.
3698  ELSEIF(mstj(44).LE.0) THEN
3699  pmsqcd=pms*exp(max(-50.,log(rlu(0))*paru(2)/(paru(111)*fbr)))
3700  ELSEIF(mstj(44).EQ.1) THEN
3701  pmsqcd=4.*alams*(0.25*pms/alams)**(rlu(0)**(b0/fbr))
3702  ELSE
3703  pmsqcd=pms*exp(max(-50.,alfm*b0*log(rlu(0))/fbr))
3704  ENDIF
3705  IF(zc.GT.0.49.OR.pmsqcd.LE.pmth(4,ifl)**2) pmsqcd=pmth(2,ifl)**2
3706  v(iep(1),5)=pmsqcd
3707  mce=1
3708 
3709 C...Select mass for daughter in QED evolution.
3710  IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN
3711  pmsqed=pms*exp(max(-50.,log(rlu(0))*paru(2)/(paru(101)*fbre)))
3712  IF(zce.GT.0.49.OR.pmsqed.LE.pmth(5,ifl)**2) pmsqed=
3713  & pmth(2,ifl)**2
3714  IF(pmsqed.GT.pmsqcd) THEN
3715  v(iep(1),5)=pmsqed
3716  mce=2
3717  ENDIF
3718  ENDIF
3719 
3720 C...Check whether daughter mass below cutoff.
3721  p(iep(1),5)=sqrt(v(iep(1),5))
3722  IF(p(iep(1),5).LE.pmth(3,ifl)) THEN
3723  p(iep(1),5)=pmth(1,ifl)
3724  v(iep(1),5)=p(iep(1),5)**2
3725  goto 430
3726  ENDIF
3727 
3728 C...Select z value of branching: q -> qgamma.
3729  IF(mce.EQ.2) THEN
3730  z=1.-(1.-zce)*(zce/(1.-zce))**rlu(0)
3731  IF(1.+z**2.LT.2.*rlu(0)) goto 390
3732  k(iep(1),5)=22
3733 
3734 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
3735  ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
3736  z=1.-(1.-zc)*(zc/(1.-zc))**rlu(0)
3737  IF(1.+z**2.LT.2.*rlu(0)) goto 390
3738  k(iep(1),5)=21
3739  ELSEIF(mstj(49).EQ.0.AND.mstj(45)*(0.5-zc).LT.rlu(0)*fbr) THEN
3740  z=(1.-zc)*(zc/(1.-zc))**rlu(0)
3741  IF(rlu(0).GT.0.5) z=1.-z
3742  IF((1.-z*(1.-z))**2.LT.rlu(0)) goto 390
3743  k(iep(1),5)=21
3744  ELSEIF(mstj(49).NE.1) THEN
3745  z=zc+(1.-2.*zc)*rlu(0)
3746  IF(z**2+(1.-z)**2.LT.rlu(0)) goto 390
3747  kflb=1+int(mstj(45)*rlu(0))
3748  pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
3749  IF(pmq.GE.1.) goto 390
3750  pmq0=4.*pmth(2,21)**2/v(iep(1),5)
3751  IF(mod(mstj(43),2).EQ.0.AND.(1.+0.5*pmq)*sqrt(1.-pmq).LT.
3752  & rlu(0)*(1.+0.5*pmq0)*sqrt(1.-pmq0)) goto 390
3753  k(iep(1),5)=kflb
3754 
3755 C...Ditto for scalar gluon model.
3756  ELSEIF(kfl(1).NE.21) THEN
3757  z=1.-sqrt(zc**2+rlu(0)*(1.-2.*zc))
3758  k(iep(1),5)=21
3759  ELSEIF(rlu(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
3760  z=zc+(1.-2.*zc)*rlu(0)
3761  k(iep(1),5)=21
3762  ELSE
3763  z=zc+(1.-2.*zc)*rlu(0)
3764  kflb=1+int(mstj(45)*rlu(0))
3765  pmq=4.*pmth(2,kflb)**2/v(iep(1),5)
3766  IF(pmq.GE.1.) goto 390
3767  k(iep(1),5)=kflb
3768  ENDIF
3769  IF(mce.EQ.1.AND.mstj(44).GE.2) THEN
3770  IF(z*(1.-z)*v(iep(1),5).LT.pt2min) goto 390
3771  IF(alfm/log(v(iep(1),5)*z*(1.-z)/alams).LT.rlu(0)) goto 390
3772  ENDIF
3773 
3774 C...Check if z consistent with chosen m.
3775  IF(kfl(1).EQ.21) THEN
3776  kflgd1=iabs(k(iep(1),5))
3777  kflgd2=kflgd1
3778  ELSE
3779  kflgd1=kfl(1)
3780  kflgd2=iabs(k(iep(1),5))
3781  ENDIF
3782  IF(nep.EQ.1) THEN
3783  ped=ps(4)
3784  ELSEIF(nep.GE.3) THEN
3785  ped=p(iep(1),4)
3786  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
3787  ped=0.5*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
3788  ELSE
3789  IF(iep(1).EQ.n+1) ped=v(im,1)*pem
3790  IF(iep(1).EQ.n+2) ped=(1.-v(im,1))*pem
3791  ENDIF
3792  IF(mod(mstj(43),2).EQ.1) THEN
3793  iflgd1=kflgd1
3794  IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=ifl
3795  pmqth3=0.5*parj(82)
3796  IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
3797  pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(iep(1),5)
3798  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)
3799  zd=sqrt(max(0.,(1.-v(iep(1),5)/ped**2)*((1.-pmq1-pmq2)**2-
3800  & 4.*pmq1*pmq2)))
3801  zh=1.+pmq1-pmq2
3802  ELSE
3803  zd=sqrt(max(0.,1.-v(iep(1),5)/ped**2))
3804  zh=1.
3805  ENDIF
3806  zl=0.5*(zh-zd)
3807  zu=0.5*(zh+zd)
3808  IF(z.LT.zl.OR.z.GT.zu) goto 390
3809  IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1.-zl)/max(1e-20,zl*
3810  &(1.-zu)))
3811  IF(kfl(1).NE.21) v(iep(1),3)=log((1.-zl)/max(1e-10,1.-zu))
3812 
3813 C...Width suppression for q -> q + g.
3814  IF(mstj(40).NE.0.AND.kfl(1).NE.21) THEN
3815  IF(igm.EQ.0) THEN
3816  eglu=0.5*ps(5)*(1.-z)*(1.+v(iep(1),5)/v(ns+1,5))
3817  ELSE
3818  eglu=pmed*(1.-z)
3819  ENDIF
3820  chi=parj(89)**2/(parj(89)**2+eglu**2)
3821  IF(mstj(40).EQ.1) THEN
3822  IF(chi.LT.rlu(0)) goto 390
3823  ELSEIF(mstj(40).EQ.2) THEN
3824  IF(1.-chi.LT.rlu(0)) goto 390
3825  ENDIF
3826  ENDIF
3827 
3828 C...Three-jet matrix element correction.
3829  IF(igm.EQ.0.AND.m3jc.EQ.1) THEN
3830  x1=z*(1.+v(iep(1),5)/v(ns+1,5))
3831  x2=1.-v(iep(1),5)/v(ns+1,5)
3832  x3=(1.-x1)+(1.-x2)
3833  IF(mce.EQ.2) THEN
3834  ki1=k(ipa(inum),2)
3835  ki2=k(ipa(3-inum),2)
3836  qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3.
3837  qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3.
3838  wshow=qf1**2*(1.-x1)/x3*(1.+(x1/(2.-x2))**2)+
3839  & qf2**2*(1.-x2)/x3*(1.+(x2/(2.-x1))**2)
3840  wme=(qf1*(1.-x1)/x3-qf2*(1.-x2)/x3)**2*(x1**2+x2**2)
3841  ELSEIF(mstj(49).NE.1) THEN
3842  wshow=1.+(1.-x1)/x3*(x1/(2.-x2))**2+
3843  & (1.-x2)/x3*(x2/(2.-x1))**2
3844  wme=x1**2+x2**2
3845  IF(m3jcm.EQ.1) wme=wme-qme*x3-0.5*qme**2-
3846  & (0.5*qme+0.25*qme**2)*((1.-x2)/max(1e-7,1.-x1)+
3847  & (1.-x1)/max(1e-7,1.-x2))
3848  ELSE
3849  wshow=4.*x3*((1.-x1)/(2.-x2)**2+(1.-x2)/(2.-x1)**2)
3850  wme=x3**2
3851  IF(mstj(102).GE.2) wme=x3**2-2.*(1.+x3)*(1.-x1)*(1.-x2)*
3852  & parj(171)
3853  ENDIF
3854  IF(wme.LT.rlu(0)*wshow) goto 390
3855 
3856 C...Impose angular ordering by rejection of nonordered emission.
3857  ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2) THEN
3858  maom=1
3859  zm=v(im,1)
3860  IF(iep(1).EQ.n+2) zm=1.-v(im,1)
3861  the2id=z*(1.-z)*(zm*p(im,4))**2/v(iep(1),5)
3862  iaom=im
3863  420 IF(k(iaom,5).EQ.22) THEN
3864  iaom=k(iaom,3)
3865  IF(k(iaom,3).LE.ns) maom=0
3866  IF(maom.EQ.1) goto 420
3867  ENDIF
3868  IF(maom.EQ.1) THEN
3869  the2im=v(iaom,1)*(1.-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
3870  IF(the2id.LT.the2im) goto 390
3871  ENDIF
3872  ENDIF
3873 
3874 C...Impose user-defined maximum angle at first branching.
3875  IF(mstj(48).EQ.1) THEN
3876  IF(nep.EQ.1.AND.im.EQ.ns) THEN
3877  the2id=z*(1.-z)*ps(4)**2/v(iep(1),5)
3878  IF(the2id.LT.1./parj(85)**2) goto 390
3879  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
3880  the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
3881  IF(the2id.LT.1./parj(85)**2) goto 390
3882  ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
3883  the2id=z*(1.-z)*(0.5*p(im,4))**2/v(iep(1),5)
3884  IF(the2id.LT.1./parj(86)**2) goto 390
3885  ENDIF
3886  ENDIF
3887 
3888 C...Impose angular constraint in first branching from interference
3889 C...with initial state partons.
3890  IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN
3891  the2d=max((1.-z)/z,z/(1.-z))*v(iep(1),5)/(0.5*p(im,4))**2
3892  IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN
3893  IF(the2d.GT.theiis(1,isii(1))**2) goto 390
3894  ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN
3895  IF(the2d.GT.theiis(2,isii(2))**2) goto 390
3896  ENDIF
3897  ENDIF
3898 
3899 C...End of inner veto algorithm. Check if only one leg evolved so far.
3900  430 v(iep(1),1)=z
3901  isl(1)=0
3902  isl(2)=0
3903  IF(nep.EQ.1) goto 460
3904  IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) goto 330
3905  DO 440 i=1,nep
3906  IF(itry(i).EQ.0.AND.kfld(i).LE.40) THEN
3907  IF(ksh(kfld(i)).EQ.1) THEN
3908  ifld=kfld(i)
3909  IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+
3910  & isign(2,k(n+i,2))
3911  IF(p(n+i,5).GE.pmth(2,ifld)) goto 330
3912  ENDIF
3913  ENDIF
3914  440 CONTINUE
3915 
3916 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
3917  IF(nep.EQ.3) THEN
3918  pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))
3919  pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))
3920  pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))
3921  pts=0.25*(2.*pa1s*pa2s+2.*pa1s*pa3s+2.*pa2s*pa3s-
3922  & pa1s**2-pa2s**2-pa3s**2)/pa1s
3923  IF(pts.LE.0.) goto 330
3924  ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
3925  DO 450 i1=n+1,n+2
3926  kflda=iabs(k(i1,2))
3927  IF(kflda.GT.40) goto 450
3928  IF(ksh(kflda).EQ.0) goto 450
3929  iflda=kflda
3930  IF(kflda.GE.6.AND.kflda.LE.8) iflda=37+kflda+
3931  & isign(2,k(i1,2))
3932  IF(p(i1,5).LT.pmth(2,iflda)) goto 450
3933  IF(kflda.EQ.21) THEN
3934  kflgd1=iabs(k(i1,5))
3935  kflgd2=kflgd1
3936  ELSE
3937  kflgd1=kflda
3938  kflgd2=iabs(k(i1,5))
3939  ENDIF
3940  i2=2*n+3-i1
3941  IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
3942  ped=0.5*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
3943  ELSE
3944  IF(i1.EQ.n+1) zm=v(im,1)
3945  IF(i1.EQ.n+2) zm=1.-v(im,1)
3946  pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
3947  & 4.*v(n+1,5)*v(n+2,5))
3948  ped=pem*(0.5*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/v(im,5)
3949  ENDIF
3950  IF(mod(mstj(43),2).EQ.1) THEN
3951  pmqth3=0.5*parj(82)
3952  IF(kflgd2.EQ.22) pmqth3=0.5*parj(83)
3953  iflgd1=kflgd1
3954  IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=iflda
3955  pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(i1,5)
3956  pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)
3957  zd=sqrt(max(0.,(1.-v(i1,5)/ped**2)*((1.-pmq1-pmq2)**2-
3958  & 4.*pmq1*pmq2)))
3959  zh=1.+pmq1-pmq2
3960  ELSE
3961  zd=sqrt(max(0.,1.-v(i1,5)/ped**2))
3962  zh=1.
3963  ENDIF
3964  zl=0.5*(zh-zd)
3965  zu=0.5*(zh+zd)
3966  IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(1)=1
3967  IF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(2)=1
3968  IF(kflda.EQ.21) v(i1,4)=log(zu*(1.-zl)/max(1e-20,zl*(1.-zu)))
3969  IF(kflda.NE.21) v(i1,4)=log((1.-zl)/max(1e-10,1.-zu))
3970  450 CONTINUE
3971  IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
3972  isl(3-islm)=0
3973  islm=3-islm
3974  ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
3975  zdr1=max(0.,v(n+1,3)/max(1e-6,v(n+1,4))-1.)
3976  zdr2=max(0.,v(n+2,3)/max(1e-6,v(n+2,4))-1.)
3977  IF(zdr2.GT.rlu(0)*(zdr1+zdr2)) isl(1)=0
3978  IF(isl(1).EQ.1) isl(2)=0
3979  IF(isl(1).EQ.0) islm=1
3980  IF(isl(2).EQ.0) islm=2
3981  ENDIF
3982  IF(isl(1).EQ.1.OR.isl(2).EQ.1) goto 330
3983  ENDIF
3984  ifld1=kfld(1)
3985  IF(kfld(1).GE.6.AND.kfld(1).LE.8) ifld1=37+kfld(1)+
3986  &isign(2,k(n+1,2))
3987  ifld2=kfld(2)
3988  IF(kfld(2).GE.6.AND.kfld(2).LE.8) ifld2=37+kfld(2)+
3989  &isign(2,k(n+2,2))
3990  IF(igm.GT.0.AND.mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
3991  &pmth(2,ifld1).OR.p(n+2,5).GE.pmth(2,ifld2))) THEN
3992  pmq1=v(n+1,5)/v(im,5)
3993  pmq2=v(n+2,5)/v(im,5)
3994  zd=sqrt(max(0.,(1.-v(im,5)/pem**2)*((1.-pmq1-pmq2)**2-
3995  & 4.*pmq1*pmq2)))
3996  zh=1.+pmq1-pmq2
3997  zl=0.5*(zh-zd)
3998  zu=0.5*(zh+zd)
3999  IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) goto 330
4000  ENDIF
4001 
4002 C...Accepted branch. Construct four-momentum for initial partons.
4003  460 mazip=0
4004  mazic=0
4005  IF(nep.EQ.1) THEN
4006  p(n+1,1)=0.
4007  p(n+1,2)=0.
4008  p(n+1,3)=sqrt(max(0.,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
4009  & p(n+1,5))))
4010  p(n+1,4)=p(ipa(1),4)
4011  v(n+1,2)=p(n+1,4)
4012  ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
4013  ped1=0.5*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
4014  p(n+1,1)=0.
4015  p(n+1,2)=0.
4016  p(n+1,3)=sqrt(max(0.,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
4017  p(n+1,4)=ped1
4018  p(n+2,1)=0.
4019  p(n+2,2)=0.
4020  p(n+2,3)=-p(n+1,3)
4021  p(n+2,4)=p(im,5)-ped1
4022  v(n+1,2)=p(n+1,4)
4023  v(n+2,2)=p(n+2,4)
4024  ELSEIF(nep.EQ.3) THEN
4025  p(n+1,1)=0.
4026  p(n+1,2)=0.
4027  p(n+1,3)=sqrt(max(0.,pa1s))
4028  p(n+2,1)=sqrt(pts)
4029  p(n+2,2)=0.
4030  p(n+2,3)=0.5*(pa3s-pa2s-pa1s)/p(n+1,3)
4031  p(n+3,1)=-p(n+2,1)
4032  p(n+3,2)=0.
4033  p(n+3,3)=-(p(n+1,3)+p(n+2,3))
4034  v(n+1,2)=p(n+1,4)
4035  v(n+2,2)=p(n+2,4)
4036  v(n+3,2)=p(n+3,4)
4037 
4038 C...Construct transverse momentum for ordinary branching in shower.
4039  ELSE
4040  zm=v(im,1)
4041  pzm=sqrt(max(0.,(pem+p(im,5))*(pem-p(im,5))))
4042  pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4.*v(n+1,5)*v(n+2,5)
4043  IF(pzm.LE.0.) THEN
4044  pts=0.
4045  ELSEIF(mod(mstj(43),2).EQ.1) THEN
4046  pts=(pem**2*(zm*(1.-zm)*v(im,5)-(1.-zm)*v(n+1,5)-
4047  & zm*v(n+2,5))-0.25*pmls)/pzm**2
4048  ELSE
4049  pts=pmls*(zm*(1.-zm)*pem**2/v(im,5)-0.25)/pzm**2
4050  ENDIF
4051  pt=sqrt(max(0.,pts))
4052 
4053 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
4054  hazip=0.
4055  IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21.
4056  & and.iau.NE.0) THEN
4057  IF(k(igm,3).NE.0) mazip=1
4058  zau=v(igm,1)
4059  IF(iau.EQ.im+1) zau=1.-v(igm,1)
4060  IF(mazip.EQ.0) zau=0.
4061  IF(k(igm,2).NE.21) THEN
4062  hazip=2.*zau/(1.+zau**2)
4063  ELSE
4064  hazip=(zau/(1.-zau*(1.-zau)))**2
4065  ENDIF
4066  IF(k(n+1,2).NE.21) THEN
4067  hazip=hazip*(-2.*zm*(1.-zm))/(1.-2.*zm*(1.-zm))
4068  ELSE
4069  hazip=hazip*(zm*(1.-zm)/(1.-zm*(1.-zm)))**2
4070  ENDIF
4071  ENDIF
4072 
4073 C...Find coefficient of azimuthal asymmetry due to soft gluon
4074 C...interference.
4075  hazic=0.
4076  IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.
4077  & k(n+2,2).EQ.21).AND.iau.NE.0) THEN
4078  IF(k(igm,3).NE.0) mazic=n+1
4079  IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
4080  IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
4081  & zm.GT.0.5) mazic=n+2
4082  IF(k(iau,2).EQ.22) mazic=0
4083  zs=zm
4084  IF(mazic.EQ.n+2) zs=1.-zm
4085  zgm=v(igm,1)
4086  IF(iau.EQ.im-1) zgm=1.-v(igm,1)
4087  IF(mazic.EQ.0) zgm=1.
4088  IF(mazic.NE.0) hazic=(p(im,5)/p(igm,5))*
4089  & sqrt((1.-zs)*(1.-zgm)/(zs*zgm))
4090  hazic=min(0.95,hazic)
4091  ENDIF
4092  ENDIF
4093 
4094 C...Construct kinematics for ordinary branching in shower.
4095  470 IF(nep.EQ.2.AND.igm.GT.0) THEN
4096  IF(mod(mstj(43),2).EQ.1) THEN
4097  p(n+1,4)=pem*v(im,1)
4098  ELSE
4099  p(n+1,4)=pem*(0.5*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
4100  & sqrt(pmls)*zm)/v(im,5)
4101  ENDIF
4102  phi=paru(2)*rlu(0)
4103  p(n+1,1)=pt*cos(phi)
4104  p(n+1,2)=pt*sin(phi)
4105  IF(pzm.GT.0.) THEN
4106  p(n+1,3)=0.5*(v(n+2,5)-v(n+1,5)-v(im,5)+2.*pem*p(n+1,4))/pzm
4107  ELSE
4108  p(n+1,3)=0.
4109  ENDIF
4110  p(n+2,1)=-p(n+1,1)
4111  p(n+2,2)=-p(n+1,2)
4112  p(n+2,3)=pzm-p(n+1,3)
4113  p(n+2,4)=pem-p(n+1,4)
4114  IF(mstj(43).LE.2) THEN
4115  v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
4116  v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
4117  ENDIF
4118  ENDIF
4119 
4120 C...Rotate and boost daughters.
4121  IF(igm.GT.0) THEN
4122  IF(mstj(43).LE.2) THEN
4123  bex=p(igm,1)/p(igm,4)
4124  bey=p(igm,2)/p(igm,4)
4125  bez=p(igm,3)/p(igm,4)
4126  ga=p(igm,4)/p(igm,5)
4127  gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1.+ga)-
4128  & p(im,4))
4129  ELSE
4130  bex=0.
4131  bey=0.
4132  bez=0.
4133  ga=1.
4134  gabep=0.
4135  ENDIF
4136  the=ulangl(p(im,3)+gabep*bez,sqrt((p(im,1)+gabep*bex)**2+
4137  & (p(im,2)+gabep*bey)**2))
4138  phi=ulangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
4139  DO 480 i=n+1,n+2
4140  dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
4141  & sin(the)*cos(phi)*p(i,3)
4142  dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
4143  & sin(the)*sin(phi)*p(i,3)
4144  dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
4145  dp(4)=p(i,4)
4146  dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
4147  dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
4148  p(i,1)=dp(1)+dgabp*bex
4149  p(i,2)=dp(2)+dgabp*bey
4150  p(i,3)=dp(3)+dgabp*bez
4151  p(i,4)=ga*(dp(4)+dbp)
4152  480 CONTINUE
4153  ENDIF
4154 
4155 C...Weight with azimuthal distribution, if required.
4156  IF(mazip.NE.0.OR.mazic.NE.0) THEN
4157  DO 490 j=1,3
4158  dpt(1,j)=p(im,j)
4159  dpt(2,j)=p(iau,j)
4160  dpt(3,j)=p(n+1,j)
4161  490 CONTINUE
4162  dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
4163  dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
4164  dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
4165  DO 500 j=1,3
4166  dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/dpmm
4167  dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/dpmm
4168  500 CONTINUE
4169  dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
4170  dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
4171  IF(min(dpt(4,4),dpt(5,4)).GT.0.1*parj(82)) THEN
4172  cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
4173  & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
4174  IF(mazip.NE.0) THEN
4175  IF(1.+hazip*(2.*cad**2-1.).LT.rlu(0)*(1.+abs(hazip)))
4176  & goto 470
4177  ENDIF
4178  IF(mazic.NE.0) THEN
4179  IF(mazic.EQ.n+2) cad=-cad
4180  IF((1.-hazic)*(1.-hazic*cad)/(1.+hazic**2-2.*hazic*cad)
4181  & .LT.rlu(0)) goto 470
4182  ENDIF
4183  ENDIF
4184  ENDIF
4185 
4186 C...Azimuthal anisotropy due to interference with initial state partons.
4187  IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.
4188  &k(n+2,2).EQ.21)) THEN
4189  iii=im-ns-1
4190  IF(isii(iii).GE.1) THEN
4191  iaziid=n+1
4192  IF(k(n+1,2).NE.21) iaziid=n+2
4193  IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
4194  & p(n+1,4).GT.p(n+2,4)) iaziid=n+2
4195  theiid=ulangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))
4196  IF(iii.EQ.2) theiid=paru(1)-theiid
4197  phiiid=ulangl(p(iaziid,1),p(iaziid,2))
4198  hazii=min(0.95,theiid/theiis(iii,isii(iii)))
4199  cad=cos(phiiid-phiiis(iii,isii(iii)))
4200  phirel=abs(phiiid-phiiis(iii,isii(iii)))
4201  IF(phirel.GT.paru(1)) phirel=paru(2)-phirel
4202  IF((1.-hazii)*(1.-hazii*cad)/(1.+hazii**2-2.*hazii*cad)
4203  & .LT.rlu(0)) goto 470
4204  ENDIF
4205  ENDIF
4206 
4207 C...Continue loop over partons that may branch, until none left.
4208  IF(igm.GE.0) k(im,1)=14
4209  n=n+nep
4210  nep=2
4211  IF(n.GT.mstu(4)-mstu(32)-5) THEN
4212  CALL luerrm(11,'(LUSHOW:) no more memory left in LUJETS')
4213  IF(mstu(21).GE.1) n=ns
4214  IF(mstu(21).GE.1) RETURN
4215  ENDIF
4216  goto 270
4217 
4218 C...Set information on imagined shower initiator.
4219  510 IF(npa.GE.2) THEN
4220  k(ns+1,1)=11
4221  k(ns+1,2)=94
4222  k(ns+1,3)=ip1
4223  IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
4224  k(ns+1,4)=ns+2
4225  k(ns+1,5)=ns+1+npa
4226  iim=1
4227  ELSE
4228  iim=0
4229  ENDIF
4230 
4231 C...Reconstruct string drawing information.
4232  DO 520 i=ns+1+iim,n
4233  IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
4234  k(i,1)=1
4235  ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.
4236  &iabs(k(i,2)).LE.18) THEN
4237  k(i,1)=1
4238  ELSEIF(k(i,1).LE.10) THEN
4239  k(i,4)=mstu(5)*(k(i,4)/mstu(5))
4240  k(i,5)=mstu(5)*(k(i,5)/mstu(5))
4241  ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
4242  id1=mod(k(i,4),mstu(5))
4243  IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1
4244  id2=2*mod(k(i,4),mstu(5))+1-id1
4245  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
4246  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
4247  k(id1,4)=k(id1,4)+mstu(5)*i
4248  k(id1,5)=k(id1,5)+mstu(5)*id2
4249  k(id2,4)=k(id2,4)+mstu(5)*id1
4250  k(id2,5)=k(id2,5)+mstu(5)*i
4251  ELSE
4252  id1=mod(k(i,4),mstu(5))
4253  id2=id1+1
4254  k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
4255  k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
4256  IF(iabs(k(i,2)).LE.10.OR.k(id1,1).GE.11) THEN
4257  k(id1,4)=k(id1,4)+mstu(5)*i
4258  k(id1,5)=k(id1,5)+mstu(5)*i
4259  ELSE
4260  k(id1,4)=0
4261  k(id1,5)=0
4262  ENDIF
4263  k(id2,4)=0
4264  k(id2,5)=0
4265  ENDIF
4266  520 CONTINUE
4267 
4268 C...Transformation from CM frame.
4269  IF(npa.GE.2) THEN
4270  bex=ps(1)/ps(4)
4271  bey=ps(2)/ps(4)
4272  bez=ps(3)/ps(4)
4273  ga=ps(4)/ps(5)
4274  gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
4275  & /(1.+ga)-p(ipa(1),4))
4276  ELSE
4277  bex=0.
4278  bey=0.
4279  bez=0.
4280  gabep=0.
4281  ENDIF
4282  the=ulangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
4283  &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
4284  phi=ulangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
4285  IF(npa.EQ.3) THEN
4286  chi=ulangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*
4287  & sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*
4288  & bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+
4289  & gabep*bey))
4290  mstu(33)=1
4291  CALL ludbrb(ns+1,n,0.,chi,0d0,0d0,0d0)
4292  ENDIF
4293  dbex=dble(bex)
4294  dbey=dble(bey)
4295  dbez=dble(bez)
4296  mstu(33)=1
4297  CALL ludbrb(ns+1,n,the,phi,dbex,dbey,dbez)
4298 
4299 C...Decay vertex of shower.
4300  DO 540 i=ns+1,n
4301  DO 530 j=1,5
4302  v(i,j)=v(ip1,j)
4303  530 CONTINUE
4304  540 CONTINUE
4305 
4306 C...Delete trivial shower, else connect initiators.
4307  IF(n.EQ.ns+npa+iim) THEN
4308  n=ns
4309  ELSE
4310  DO 550 ip=1,npa
4311  k(ipa(ip),1)=14
4312  k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
4313  k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
4314  k(ns+iim+ip,3)=ipa(ip)
4315  IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
4316  IF(k(ns+iim+ip,1).NE.1) THEN
4317  k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
4318  k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
4319  ENDIF
4320  550 CONTINUE
4321  ENDIF
4322 
4323  RETURN
4324  END
4325 
4326 C*********************************************************************
4327 
4328  SUBROUTINE luboei(NSAV)
4329 
4330 C...Purpose: to modify event so as to approximately take into account
4331 C...Bose-Einstein effects according to a simple phenomenological
4332 C...parametrization.
4333  IMPLICIT DOUBLE PRECISION(d)
4334  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
4335  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4336  SAVE /lujets/,/ludat1/
4337  dimension dps(4),kfbe(9),nbe(0:9),bei(100)
4338  DATA kfbe/211,-211,111,321,-321,130,310,221,331/
4339 
4340 C...Boost event to overall CM frame. Calculate CM energy.
4341  IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
4342  DO 100 j=1,4
4343  dps(j)=0.
4344  100 CONTINUE
4345  DO 120 i=1,n
4346  kfa=iabs(k(i,2))
4347  IF(k(i,1).LE.10.AND.((kfa.GT.10.AND.kfa.LE.20).OR.kfa.EQ.22).AND.
4348  &k(i,3).GT.0) THEN
4349  kfma=iabs(k(k(i,3),2))
4350  IF(kfma.GT.10.AND.kfma.LE.80) k(i,1)=-k(i,1)
4351  ENDIF
4352  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 120
4353  DO 110 j=1,4
4354  dps(j)=dps(j)+p(i,j)
4355  110 CONTINUE
4356  120 CONTINUE
4357  CALL ludbrb(0,0,0.,0.,-dps(1)/dps(4),-dps(2)/dps(4),
4358  &-dps(3)/dps(4))
4359  pecm=0.
4360  DO 130 i=1,n
4361  IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
4362  130 CONTINUE
4363 
4364 C...Reserve copy of particles by species at end of record.
4365  nbe(0)=n+mstu(3)
4366  DO 160 ibe=1,min(9,mstj(52))
4367  nbe(ibe)=nbe(ibe-1)
4368  DO 150 i=nsav+1,n
4369  IF(k(i,2).NE.kfbe(ibe)) goto 150
4370  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150
4371  IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
4372  CALL luerrm(11,'(LUBOEI:) no more memory left in LUJETS')
4373  RETURN
4374  ENDIF
4375  nbe(ibe)=nbe(ibe)+1
4376  k(nbe(ibe),1)=i
4377  DO 140 j=1,3
4378  p(nbe(ibe),j)=0.
4379  140 CONTINUE
4380  150 CONTINUE
4381  160 CONTINUE
4382  IF(nbe(min(9,mstj(52)))-nbe(0).LE.1) goto 280
4383 
4384 C...Tabulate integral for subsequent momentum shift.
4385  DO 220 ibe=1,min(9,mstj(52))
4386  IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) goto 180
4387  IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2))
4388  &.LE.1) goto 180
4389  IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
4390  &nbe(7)-nbe(6)).LE.1) goto 180
4391  IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) goto 180
4392  IF(ibe.EQ.1) pmhq=2.*ulmass(211)
4393  IF(ibe.EQ.4) pmhq=2.*ulmass(321)
4394  IF(ibe.EQ.8) pmhq=2.*ulmass(221)
4395  IF(ibe.EQ.9) pmhq=2.*ulmass(331)
4396  qdel=0.1*min(pmhq,parj(93))
4397  IF(mstj(51).EQ.1) THEN
4398  nbin=min(100,nint(9.*parj(93)/qdel))
4399  beex=exp(0.5*qdel/parj(93))
4400  bert=exp(-qdel/parj(93))
4401  ELSE
4402  nbin=min(100,nint(3.*parj(93)/qdel))
4403  ENDIF
4404  DO 170 ibin=1,nbin
4405  qbin=qdel*(ibin-0.5)
4406  bei(ibin)=qdel*(qbin**2+qdel**2/12.)/sqrt(qbin**2+pmhq**2)
4407  IF(mstj(51).EQ.1) THEN
4408  beex=beex*bert
4409  bei(ibin)=bei(ibin)*beex
4410  ELSE
4411  bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
4412  ENDIF
4413  IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
4414  170 CONTINUE
4415 
4416 C...Loop through particle pairs and find old relative momentum.
4417  180 DO 210 i1m=nbe(ibe-1)+1,nbe(ibe)-1
4418  i1=k(i1m,1)
4419  DO 200 i2m=i1m+1,nbe(ibe)
4420  i2=k(i2m,1)
4421  q2old=max(0.,(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+
4422  &p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2)
4423  qold=sqrt(q2old)
4424 
4425 C...Calculate new relative momentum.
4426  IF(qold.LT.1e-3*qdel) THEN
4427  goto 200
4428  ELSEIF(qold.LE.qdel) THEN
4429  qmov=qold/3.
4430  ELSEIF(qold.LT.(nbin-0.1)*qdel) THEN
4431  rbin=qold/qdel
4432  ibin=rbin
4433  rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
4434  qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
4435  & sqrt(q2old+pmhq**2)/q2old
4436  ELSE
4437  qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
4438  ENDIF
4439  q2new=q2old*(qold/(qold+3.*parj(92)*qmov))**(2./3.)
4440 
4441 C...Calculate and save shift to be performed on three-momenta.
4442  hc1=(p(i1,4)+p(i2,4))**2-(q2old-q2new)
4443  hc2=(q2old-q2new)*(p(i1,4)-p(i2,4))**2
4444  ha=0.5*(1.-sqrt(hc1*q2new/(hc1*q2old-hc2)))
4445  DO 190 j=1,3
4446  pd=ha*(p(i2,j)-p(i1,j))
4447  p(i1m,j)=p(i1m,j)+pd
4448  p(i2m,j)=p(i2m,j)-pd
4449  190 CONTINUE
4450  200 CONTINUE
4451  210 CONTINUE
4452  220 CONTINUE
4453 
4454 C...Shift momenta and recalculate energies.
4455  DO 240 im=nbe(0)+1,nbe(min(9,mstj(52)))
4456  i=k(im,1)
4457  DO 230 j=1,3
4458  p(i,j)=p(i,j)+p(im,j)
4459  230 CONTINUE
4460  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
4461  240 CONTINUE
4462 
4463 C...Rescale all momenta for energy conservation.
4464  pes=0.
4465  pqs=0.
4466  DO 250 i=1,n
4467  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 250
4468  pes=pes+p(i,4)
4469  pqs=pqs+p(i,5)**2/p(i,4)
4470  250 CONTINUE
4471  fac=(pecm-pqs)/(pes-pqs)
4472  DO 270 i=1,n
4473  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 270
4474  DO 260 j=1,3
4475  p(i,j)=fac*p(i,j)
4476  260 CONTINUE
4477  p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
4478  270 CONTINUE
4479 
4480 C...Boost back to correct reference frame.
4481  280 CALL ludbrb(0,0,0.,0.,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
4482  DO 290 i=1,n
4483  IF(k(i,1).LT.0) k(i,1)=-k(i,1)
4484  290 CONTINUE
4485 
4486  RETURN
4487  END
4488 
4489 C*********************************************************************
4490 
4491  FUNCTION ulmass(KF)
4492 
4493 C...Purpose: to give the mass of a particle/parton.
4494  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4495  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4496  SAVE /ludat1/,/ludat2/
4497 
4498 C...Reset variables. Compressed code.
4499  ulmass=0.
4500  kfa=iabs(kf)
4501  kc=lucomp(kf)
4502  IF(kc.EQ.0) RETURN
4503  parf(106)=pmas(6,1)
4504  parf(107)=pmas(7,1)
4505  parf(108)=pmas(8,1)
4506 
4507 C...Guarantee use of constituent masses for internal checks.
4508  IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.kfa.LE.10) THEN
4509  ulmass=parf(100+kfa)
4510  IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(121))
4511 
4512 C...Masses that can be read directly off table.
4513  ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
4514  ulmass=pmas(kc,1)
4515 
4516 C...Find constituent partons and their masses.
4517  ELSE
4518  kfla=mod(kfa/1000,10)
4519  kflb=mod(kfa/100,10)
4520  kflc=mod(kfa/10,10)
4521  kfls=mod(kfa,10)
4522  kflr=mod(kfa/10000,10)
4523  pma=parf(100+kfla)
4524  pmb=parf(100+kflb)
4525  pmc=parf(100+kflc)
4526 
4527 C...Construct masses for various meson, diquark and baryon cases.
4528  IF(kfla.EQ.0.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
4529  IF(kfls.EQ.1) pmspl=-3./(pmb*pmc)
4530  IF(kfls.GE.3) pmspl=1./(pmb*pmc)
4531  ulmass=parf(111)+pmb+pmc+parf(113)*parf(101)**2*pmspl
4532  ELSEIF(kfla.EQ.0) THEN
4533  kmul=2
4534  IF(kfls.EQ.1) kmul=3
4535  IF(kflr.EQ.2) kmul=4
4536  IF(kfls.EQ.5) kmul=5
4537  ulmass=parf(113+kmul)+pmb+pmc
4538  ELSEIF(kflc.EQ.0) THEN
4539  IF(kfls.EQ.1) pmspl=-3./(pma*pmb)
4540  IF(kfls.EQ.3) pmspl=1./(pma*pmb)
4541  ulmass=2.*parf(112)/3.+pma+pmb+parf(114)*parf(101)**2*pmspl
4542  IF(mstj(93).EQ.1) ulmass=pma+pmb
4543  IF(mstj(93).EQ.2) ulmass=max(0.,ulmass-parf(122)-
4544  & 2.*parf(112)/3.)
4545  ELSE
4546  IF(kfls.EQ.2.AND.kfla.EQ.kflb) THEN
4547  pmspl=1./(pma*pmb)-2./(pma*pmc)-2./(pmb*pmc)
4548  ELSEIF(kfls.EQ.2.AND.kflb.GE.kflc) THEN
4549  pmspl=-2./(pma*pmb)-2./(pma*pmc)+1./(pmb*pmc)
4550  ELSEIF(kfls.EQ.2) THEN
4551  pmspl=-3./(pmb*pmc)
4552  ELSE
4553  pmspl=1./(pma*pmb)+1./(pma*pmc)+1./(pmb*pmc)
4554  ENDIF
4555  ulmass=parf(112)+pma+pmb+pmc+parf(114)*parf(101)**2*pmspl
4556  ENDIF
4557  ENDIF
4558 
4559 C...Optional mass broadening according to truncated Breit-Wigner
4560 C...(either in m or in m^2).
4561  IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1e-4) THEN
4562  IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
4563  ulmass=ulmass+0.5*pmas(kc,2)*tan((2.*rlu(0)-1.)*
4564  & atan(2.*pmas(kc,3)/pmas(kc,2)))
4565  ELSE
4566  pm0=ulmass
4567  pmlow=atan((max(0.,pm0-pmas(kc,3))**2-pm0**2)/
4568  & (pm0*pmas(kc,2)))
4569  pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))
4570  ulmass=sqrt(max(0.,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
4571  & (pmupp-pmlow)*rlu(0))))
4572  ENDIF
4573  ENDIF
4574  mstj(93)=0
4575 
4576  RETURN
4577  END
4578 
4579 C*********************************************************************
4580 
4581  SUBROUTINE luname(KF,CHAU)
4582 
4583 C...Purpose: to give the particle/parton name as a character string.
4584  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4585  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4586  common/ludat4/chaf(500)
4587  CHARACTER chaf*8
4588  SAVE /ludat1/,/ludat2/,/ludat4/
4589  CHARACTER chau*16
4590 
4591 C...Initial values. Charge. Subdivide code.
4592  chau=' '
4593  kfa=iabs(kf)
4594  kc=lucomp(kf)
4595  IF(kc.EQ.0) RETURN
4596  kq=luchge(kf)
4597  kfla=mod(kfa/1000,10)
4598  kflb=mod(kfa/100,10)
4599  kflc=mod(kfa/10,10)
4600  kfls=mod(kfa,10)
4601  kflr=mod(kfa/10000,10)
4602 
4603 C...Read out root name and spin for simple particle.
4604  IF(kfa.LE.100.OR.(kfa.GT.100.AND.kc.GT.100)) THEN
4605  chau=chaf(kc)
4606  len=0
4607  DO 100 lem=1,8
4608  IF(chau(lem:lem).NE.' ') len=lem
4609  100 CONTINUE
4610 
4611 C...Construct root name for diquark. Add on spin.
4612  ELSEIF(kflc.EQ.0) THEN
4613  chau(1:2)=chaf(kfla)(1:1)//chaf(kflb)(1:1)
4614  IF(kfls.EQ.1) chau(3:4)='_0'
4615  IF(kfls.EQ.3) chau(3:4)='_1'
4616  len=4
4617 
4618 C...Construct root name for heavy meson. Add on spin and heavy flavour.
4619  ELSEIF(kfla.EQ.0) THEN
4620  IF(kflb.EQ.5) chau(1:1)='B'
4621  IF(kflb.EQ.6) chau(1:1)='T'
4622  IF(kflb.EQ.7) chau(1:1)='L'
4623  IF(kflb.EQ.8) chau(1:1)='H'
4624  len=1
4625  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
4626  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
4627  chau(2:2)='*'
4628  len=2
4629  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
4630  chau(2:3)='_1'
4631  len=3
4632  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
4633  chau(2:4)='*_0'
4634  len=4
4635  ELSEIF(kflr.EQ.2) THEN
4636  chau(2:4)='*_1'
4637  len=4
4638  ELSEIF(kfls.EQ.5) THEN
4639  chau(2:4)='*_2'
4640  len=4
4641  ENDIF
4642  IF(kflc.GE.3.AND.kflr.EQ.0.AND.kfls.LE.3) THEN
4643  chau(len+1:len+2)='_'//chaf(kflc)(1:1)
4644  len=len+2
4645  ELSEIF(kflc.GE.3) THEN
4646  chau(len+1:len+1)=chaf(kflc)(1:1)
4647  len=len+1
4648  ENDIF
4649 
4650 C...Construct root name and spin for heavy baryon.
4651  ELSE
4652  IF(kflb.LE.2.AND.kflc.LE.2) THEN
4653  chau='Sigma '
4654  IF(kflc.GT.kflb) chau='Lambda'
4655  IF(kfls.EQ.4) chau='Sigma*'
4656  len=5
4657  IF(chau(6:6).NE.' ') len=6
4658  ELSEIF(kflb.LE.2.OR.kflc.LE.2) THEN
4659  chau='Xi '
4660  IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Xi'''
4661  IF(kfls.EQ.4) chau='Xi*'
4662  len=2
4663  IF(chau(3:3).NE.' ') len=3
4664  ELSE
4665  chau='Omega '
4666  IF(kfla.GT.kflb.AND.kflb.GT.kflc) chau='Omega'''
4667  IF(kfls.EQ.4) chau='Omega*'
4668  len=5
4669  IF(chau(6:6).NE.' ') len=6
4670  ENDIF
4671 
4672 C...Add on heavy flavour content for heavy baryon.
4673  chau(len+1:len+2)='_'//chaf(kfla)(1:1)
4674  len=len+2
4675  IF(kflb.GE.kflc.AND.kflc.GE.4) THEN
4676  chau(len+1:len+2)=chaf(kflb)(1:1)//chaf(kflc)(1:1)
4677  len=len+2
4678  ELSEIF(kflb.GE.kflc.AND.kflb.GE.4) THEN
4679  chau(len+1:len+1)=chaf(kflb)(1:1)
4680  len=len+1
4681  ELSEIF(kflc.GT.kflb.AND.kflb.GE.4) THEN
4682  chau(len+1:len+2)=chaf(kflc)(1:1)//chaf(kflb)(1:1)
4683  len=len+2
4684  ELSEIF(kflc.GT.kflb.AND.kflc.GE.4) THEN
4685  chau(len+1:len+1)=chaf(kflc)(1:1)
4686  len=len+1
4687  ENDIF
4688  ENDIF
4689 
4690 C...Add on bar sign for antiparticle (where necessary).
4691  IF(kf.GT.0.OR.len.EQ.0) THEN
4692  ELSEIF(kfa.GT.10.AND.kfa.LE.40.AND.kq.NE.0.AND.mod(kq,3).EQ.0)
4693  &THEN
4694  ELSEIF(kfa.EQ.89.OR.(kfa.GE.91.AND.kfa.LE.99)) THEN
4695  ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kq.NE.0) THEN
4696  ELSEIF(mstu(15).LE.1) THEN
4697  chau(len+1:len+1)='~'
4698  len=len+1
4699  ELSE
4700  chau(len+1:len+3)='bar'
4701  len=len+3
4702  ENDIF
4703 
4704 C...Add on charge where applicable (conventional cases skipped).
4705  IF(kq.EQ.6) chau(len+1:len+2)='++'
4706  IF(kq.EQ.-6) chau(len+1:len+2)='--'
4707  IF(kq.EQ.3) chau(len+1:len+1)='+'
4708  IF(kq.EQ.-3) chau(len+1:len+1)='-'
4709  IF(kq.EQ.0.AND.(kfa.LE.22.OR.len.EQ.0)) THEN
4710  ELSEIF(kq.EQ.0.AND.(kfa.GE.81.AND.kfa.LE.100)) THEN
4711  ELSEIF(kfa.EQ.28.OR.kfa.EQ.29) THEN
4712  ELSEIF(kfa.GT.100.AND.kfla.EQ.0.AND.kflb.EQ.kflc.AND.
4713  &kflb.NE.1) THEN
4714  ELSEIF(kq.EQ.0) THEN
4715  chau(len+1:len+1)='0'
4716  ENDIF
4717 
4718  RETURN
4719  END
4720 
4721 C*********************************************************************
4722 
4723  FUNCTION luchge(KF)
4724 
4725 C...Purpose: to give three times the charge for a particle/parton.
4726  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4727  SAVE /ludat2/
4728 
4729 C...Initial values. Simple case of direct readout.
4730  luchge=0
4731  kfa=iabs(kf)
4732  kc=lucomp(kfa)
4733  IF(kc.EQ.0) THEN
4734  ELSEIF(kfa.LE.100.OR.kc.LE.80.OR.kc.GT.100) THEN
4735  luchge=kchg(kc,1)
4736 
4737 C...Construction from quark content for heavy meson, diquark, baryon.
4738  ELSEIF(mod(kfa/1000,10).EQ.0) THEN
4739  luchge=(kchg(mod(kfa/100,10),1)-kchg(mod(kfa/10,10),1))*
4740  & (-1)**mod(kfa/100,10)
4741  ELSEIF(mod(kfa/10,10).EQ.0) THEN
4742  luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)
4743  ELSE
4744  luchge=kchg(mod(kfa/1000,10),1)+kchg(mod(kfa/100,10),1)+
4745  & kchg(mod(kfa/10,10),1)
4746  ENDIF
4747 
4748 C...Add on correct sign.
4749  luchge=luchge*isign(1,kf)
4750 
4751  RETURN
4752  END
4753 
4754 C*********************************************************************
4755 
4756  FUNCTION lucomp(KF)
4757 
4758 C...Purpose: to compress the standard KF codes for use in mass and decay
4759 C...arrays; also to check whether a given code actually is defined.
4760  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4761  SAVE /ludat2/
4762  dimension kftab(25),kctab(25)
4763  DATA kftab/211,111,221,311,321,130,310,213,113,223,
4764  &313,323,2112,2212,210,2110,2210,110,220,330,440,30443,30553,0,0/
4765  DATA kctab/101,111,112,102,103,221,222,121,131,132,
4766  &122,123,332,333,281,282,283,284,285,286,287,231,235,0,0/
4767 
4768 C...Starting values.
4769  lucomp=0
4770  kfa=iabs(kf)
4771 
4772 C...Simple cases: direct translation or table.
4773  IF(kfa.EQ.0.OR.kfa.GE.100000) THEN
4774  RETURN
4775  ELSEIF(kfa.LE.100) THEN
4776  lucomp=kfa
4777  IF(kf.LT.0.AND.kchg(kfa,3).EQ.0) lucomp=0
4778  RETURN
4779  ELSE
4780  DO 100 ikf=1,23
4781  IF(kfa.EQ.kftab(ikf)) THEN
4782  lucomp=kctab(ikf)
4783  IF(kf.LT.0.AND.kchg(lucomp,3).EQ.0) lucomp=0
4784  RETURN
4785  ENDIF
4786  100 CONTINUE
4787  ENDIF
4788 
4789 C...Subdivide KF code into constituent pieces.
4790  kfla=mod(kfa/1000,10)
4791  kflb=mod(kfa/100,10)
4792  kflc=mod(kfa/10,10)
4793  kfls=mod(kfa,10)
4794  kflr=mod(kfa/10000,10)
4795 
4796 C...Mesons.
4797  IF(kfa-10000*kflr.LT.1000) THEN
4798  IF(kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.0.OR.kflc.EQ.9) THEN
4799  ELSEIF(kflb.LT.kflc) THEN
4800  ELSEIF(kf.LT.0.AND.kflb.EQ.kflc) THEN
4801  ELSEIF(kflb.EQ.kflc) THEN
4802  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
4803  lucomp=110+kflb
4804  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
4805  lucomp=130+kflb
4806  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
4807  lucomp=150+kflb
4808  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
4809  lucomp=170+kflb
4810  ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
4811  lucomp=190+kflb
4812  ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
4813  lucomp=210+kflb
4814  ENDIF
4815  ELSEIF(kflb.LE.5) THEN
4816  IF(kflr.EQ.0.AND.kfls.EQ.1) THEN
4817  lucomp=100+((kflb-1)*(kflb-2))/2+kflc
4818  ELSEIF(kflr.EQ.0.AND.kfls.EQ.3) THEN
4819  lucomp=120+((kflb-1)*(kflb-2))/2+kflc
4820  ELSEIF(kflr.EQ.1.AND.kfls.EQ.3) THEN
4821  lucomp=140+((kflb-1)*(kflb-2))/2+kflc
4822  ELSEIF(kflr.EQ.1.AND.kfls.EQ.1) THEN
4823  lucomp=160+((kflb-1)*(kflb-2))/2+kflc
4824  ELSEIF(kflr.EQ.2.AND.kfls.EQ.3) THEN
4825  lucomp=180+((kflb-1)*(kflb-2))/2+kflc
4826  ELSEIF(kflr.EQ.0.AND.kfls.EQ.5) THEN
4827  lucomp=200+((kflb-1)*(kflb-2))/2+kflc
4828  ENDIF
4829  ELSEIF((kfls.EQ.1.AND.kflr.LE.1).OR.(kfls.EQ.3.AND.kflr.LE.2)
4830  & .OR.(kfls.EQ.5.AND.kflr.EQ.0)) THEN
4831  lucomp=80+kflb
4832  ENDIF
4833 
4834 C...Diquarks.
4835  ELSEIF((kflr.EQ.0.OR.kflr.EQ.1).AND.kflc.EQ.0) THEN
4836  IF(kfls.NE.1.AND.kfls.NE.3) THEN
4837  ELSEIF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9) THEN
4838  ELSEIF(kfla.LT.kflb) THEN
4839  ELSEIF(kfls.EQ.1.AND.kfla.EQ.kflb) THEN
4840  ELSE
4841  lucomp=90
4842  ENDIF
4843 
4844 C...Spin 1/2 baryons.
4845  ELSEIF(kflr.EQ.0.AND.kfls.EQ.2) THEN
4846  IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
4847  ELSEIF(kfla.LE.kflc.OR.kfla.LT.kflb) THEN
4848  ELSEIF(kfla.GE.6.OR.kflb.GE.4.OR.kflc.GE.4) THEN
4849  lucomp=80+kfla
4850  ELSEIF(kflb.LT.kflc) THEN
4851  lucomp=300+((kfla+1)*kfla*(kfla-1))/6+(kflc*(kflc-1))/2+kflb
4852  ELSE
4853  lucomp=330+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
4854  ENDIF
4855 
4856 C...Spin 3/2 baryons.
4857  ELSEIF(kflr.EQ.0.AND.kfls.EQ.4) THEN
4858  IF(kfla.EQ.9.OR.kflb.EQ.0.OR.kflb.EQ.9.OR.kflc.EQ.9) THEN
4859  ELSEIF(kfla.LT.kflb.OR.kflb.LT.kflc) THEN
4860  ELSEIF(kfla.GE.6.OR.kflb.GE.4) THEN
4861  lucomp=80+kfla
4862  ELSE
4863  lucomp=360+((kfla+1)*kfla*(kfla-1))/6+(kflb*(kflb-1))/2+kflc
4864  ENDIF
4865  ENDIF
4866 
4867  RETURN
4868  END
4869 
4870 C*********************************************************************
4871 
4872  SUBROUTINE luerrm(MERR,CHMESS)
4873 
4874 C...Purpose: to inform user of errors in program execution.
4875  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
4876  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4877  SAVE /lujets/,/ludat1/
4878  CHARACTER chmess*(*)
4879 
4880 C...Write first few warnings, then be silent.
4881  IF(merr.LE.10) THEN
4882  mstu(27)=mstu(27)+1
4883  mstu(28)=merr
4884  IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)
4885  & merr,mstu(31),chmess
4886 
4887 C...Write first few errors, then be silent or stop program.
4888  ELSEIF(merr.LE.20) THEN
4889  mstu(23)=mstu(23)+1
4890  mstu(24)=merr-10
4891  IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)
4892  & merr-10,mstu(31),chmess
4893  IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
4894  WRITE(mstu(11),5100) merr-10,mstu(31),chmess
4895  WRITE(mstu(11),5200)
4896  IF(merr.NE.17) CALL lulist(2)
4897  stop
4898  ENDIF
4899 
4900 C...Stop program in case of irreparable error.
4901  ELSE
4902  WRITE(mstu(11),5300) merr-20,mstu(31),chmess
4903  stop
4904  ENDIF
4905 
4906 C...Formats for output.
4907  5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i6,
4908  &' LUEXEC calls:'/5x,a)
4909  5100 FORMAT(/5x,'Error type',i2,' has occured after',i6,
4910  &' LUEXEC calls:'/5x,a)
4911  5200 FORMAT(5x,'Execution will be stopped after listing of last ',
4912  &'event!')
4913  5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i6,
4914  &' LUEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
4915 
4916  RETURN
4917  END
4918 
4919 C*********************************************************************
4920 
4921  FUNCTION ulalem(Q2)
4922 
4923 C...Purpose: to calculate the running alpha_electromagnetic.
4924  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4925  SAVE /ludat1/
4926 
4927 C...Calculate real part of photon vacuum polarization.
4928 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
4929 C...For hadrons use parametrization of H. Burkhardt et al.
4930 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
4931  aempi=paru(101)/(3.*paru(1))
4932  IF(mstu(101).LE.0.OR.q2.LT.2e-6) THEN
4933  rpigg=0.
4934  ELSEIF(mstu(101).EQ.2.AND.q2.LT.paru(104)) THEN
4935  rpigg=0.
4936  ELSEIF(mstu(101).EQ.2) THEN
4937  rpigg=1.-paru(101)/paru(103)
4938  ELSEIF(q2.LT.0.09) THEN
4939  rpigg=aempi*(13.4916+log(q2))+0.00835*log(1.+q2)
4940  ELSEIF(q2.LT.9.) THEN
4941  rpigg=aempi*(16.3200+2.*log(q2))+0.00238*log(1.+3.927*q2)
4942  ELSEIF(q2.LT.1e4) THEN
4943  rpigg=aempi*(13.4955+3.*log(q2))+0.00165+0.00299*log(1.+q2)
4944  ELSE
4945  rpigg=aempi*(13.4955+3.*log(q2))+0.00221+0.00293*log(1.+q2)
4946  ENDIF
4947 
4948 C...Calculate running alpha_em.
4949  ulalem=paru(101)/(1.-rpigg)
4950  paru(108)=ulalem
4951 
4952  RETURN
4953  END
4954 
4955 C*********************************************************************
4956 
4957  FUNCTION ulalps(Q2)
4958 
4959 C...Purpose: to give the value of alpha_strong.
4960  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
4961  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
4962  SAVE /ludat1/,/ludat2/
4963 
4964 C...Constant alpha_strong trivial.
4965  IF(mstu(111).LE.0) THEN
4966  ulalps=paru(111)
4967  mstu(118)=mstu(112)
4968  paru(117)=0.
4969  paru(118)=paru(111)
4970  RETURN
4971  ENDIF
4972 
4973 C...Find effective Q2, number of flavours and Lambda.
4974  q2eff=q2
4975  IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
4976  nf=mstu(112)
4977  alam2=paru(112)**2
4978  100 IF(nf.GT.max(2,mstu(113))) THEN
4979  q2thr=paru(113)*pmas(nf,1)**2
4980  IF(q2eff.LT.q2thr) THEN
4981  nf=nf-1
4982  alam2=alam2*(q2thr/alam2)**(2./(33.-2.*nf))
4983  goto 100
4984  ENDIF
4985  ENDIF
4986  110 IF(nf.LT.min(8,mstu(114))) THEN
4987  q2thr=paru(113)*pmas(nf+1,1)**2
4988  IF(q2eff.GT.q2thr) THEN
4989  nf=nf+1
4990  alam2=alam2*(alam2/q2thr)**(2./(33.-2.*nf))
4991  goto 110
4992  ENDIF
4993  ENDIF
4994  IF(mstu(115).EQ.1) q2eff=q2eff+alam2
4995  paru(117)=sqrt(alam2)
4996 
4997 C...Evaluate first or second order alpha_strong.
4998  b0=(33.-2.*nf)/6.
4999  algq=log(max(1.0001,q2eff/alam2))
5000  IF(mstu(111).EQ.1) THEN
5001  ulalps=min(paru(115),paru(2)/(b0*algq))
5002  ELSE
5003  b1=(153.-19.*nf)/6.
5004  ulalps=min(paru(115),paru(2)/(b0*algq)*(1.-b1*log(algq)/
5005  & (b0**2*algq)))
5006  ENDIF
5007  mstu(118)=nf
5008  paru(118)=ulalps
5009 
5010  RETURN
5011  END
5012 
5013 C*********************************************************************
5014 
5015  FUNCTION ulangl(X,Y)
5016 
5017 C...Purpose: to reconstruct an angle from given x and y coordinates.
5018  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5019  SAVE /ludat1/
5020 
5021  ulangl=0.
5022  r=sqrt(x**2+y**2)
5023  IF(r.LT.1e-20) RETURN
5024  IF(abs(x)/r.LT.0.8) THEN
5025  ulangl=sign(acos(x/r),y)
5026  ELSE
5027  ulangl=asin(y/r)
5028  IF(x.LT.0..AND.ulangl.GE.0.) THEN
5029  ulangl=paru(1)-ulangl
5030  ELSEIF(x.LT.0.) THEN
5031  ulangl=-paru(1)-ulangl
5032  ENDIF
5033  ENDIF
5034 
5035  RETURN
5036  END
5037 
5038 C*********************************************************************
5039 
5040 C*********************************************************************
5041 
5042  SUBROUTINE rluget(LFN,MOVE)
5043 
5044 C...Purpose: to dump the state of the random number generator on a file
5045 C...for subsequent startup from this state onwards.
5046  common/ludatr/mrlu(6),rrlu(100)
5047  SAVE /ludatr/
5048  CHARACTER cherr*8
5049 
5050 C...Backspace required number of records (or as many as there are).
5051  IF(move.LT.0) THEN
5052  nbck=min(mrlu(6),-move)
5053  DO 100 ibck=1,nbck
5054  backspace(lfn,err=110,iostat=ierr)
5055  100 CONTINUE
5056  mrlu(6)=mrlu(6)-nbck
5057  ENDIF
5058 
5059 C...Unformatted write on unit LFN.
5060  WRITE(lfn,err=110,iostat=ierr) (mrlu(i1),i1=1,5),
5061  &(rrlu(i2),i2=1,100)
5062  mrlu(6)=mrlu(6)+1
5063  RETURN
5064 
5065 C...Write error.
5066  110 WRITE(cherr,'(I8)') ierr
5067  CALL luerrm(18,'(RLUGET:) error when accessing file, IOSTAT ='//
5068  &cherr)
5069 
5070  RETURN
5071  END
5072 
5073 C*********************************************************************
5074 
5075  SUBROUTINE rluset(LFN,MOVE)
5076 
5077 C...Purpose: to read a state of the random number generator from a file
5078 C...for subsequent generation from this state onwards.
5079  common/ludatr/mrlu(6),rrlu(100)
5080  SAVE /ludatr/
5081  CHARACTER cherr*8
5082 
5083 C...Backspace required number of records (or as many as there are).
5084  IF(move.LT.0) THEN
5085  nbck=min(mrlu(6),-move)
5086  DO 100 ibck=1,nbck
5087  backspace(lfn,err=120,iostat=ierr)
5088  100 CONTINUE
5089  mrlu(6)=mrlu(6)-nbck
5090  ENDIF
5091 
5092 C...Unformatted read from unit LFN.
5093  nfor=1+max(0,move)
5094  DO 110 ifor=1,nfor
5095  READ(lfn,err=120,iostat=ierr) (mrlu(i1),i1=1,5),
5096  &(rrlu(i2),i2=1,100)
5097  110 CONTINUE
5098  mrlu(6)=mrlu(6)+nfor
5099  RETURN
5100 
5101 C...Write error.
5102  120 WRITE(cherr,'(I8)') ierr
5103  CALL luerrm(18,'(RLUSET:) error when accessing file, IOSTAT ='//
5104  &cherr)
5105 
5106  RETURN
5107  END
5108 
5109 C*********************************************************************
5110 
5111 C*********************************************************************
5112 
5113  SUBROUTINE luedit(MEDIT)
5114 
5115 C...Purpose: to perform global manipulations on the event record,
5116 C...in particular to exclude unstable or undetectable partons/particles.
5117  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
5118  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5119  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5120  SAVE /lujets/,/ludat1/,/ludat2/
5121  dimension ns(2),pts(2),pls(2)
5122 
5123 C...Remove unwanted partons/particles.
5124  IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
5125  imax=n
5126  IF(mstu(2).GT.0) imax=mstu(2)
5127  i1=max(1,mstu(1))-1
5128  DO 110 i=max(1,mstu(1)),imax
5129  IF(k(i,1).EQ.0.OR.k(i,1).GT.20) goto 110
5130  IF(medit.EQ.1) THEN
5131  IF(k(i,1).GT.10) goto 110
5132  ELSEIF(medit.EQ.2) THEN
5133  IF(k(i,1).GT.10) goto 110
5134  kc=lucomp(k(i,2))
5135  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)
5136  & goto 110
5137  ELSEIF(medit.EQ.3) THEN
5138  IF(k(i,1).GT.10) goto 110
5139  kc=lucomp(k(i,2))
5140  IF(kc.EQ.0) goto 110
5141  IF(kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0) goto 110
5142  ELSEIF(medit.EQ.5) THEN
5143  IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) goto 110
5144  kc=lucomp(k(i,2))
5145  IF(kc.EQ.0) goto 110
5146  IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) goto 110
5147  ENDIF
5148 
5149 C...Pack remaining partons/particles. Origin no longer known.
5150  i1=i1+1
5151  DO 100 j=1,5
5152  k(i1,j)=k(i,j)
5153  p(i1,j)=p(i,j)
5154  v(i1,j)=v(i,j)
5155  100 CONTINUE
5156  k(i1,3)=0
5157  110 CONTINUE
5158  IF(i1.LT.n) mstu(3)=0
5159  IF(i1.LT.n) mstu(70)=0
5160  n=i1
5161 
5162 C...Selective removal of class of entries. New position of retained.
5163  ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
5164  i1=0
5165  DO 120 i=1,n
5166  k(i,3)=mod(k(i,3),mstu(5))
5167  IF(medit.EQ.11.AND.k(i,1).LT.0) goto 120
5168  IF(medit.EQ.12.AND.k(i,1).EQ.0) goto 120
5169  IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
5170  & k(i,1).EQ.15).AND.k(i,2).NE.94) goto 120
5171  IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
5172  & k(i,2).EQ.94)) goto 120
5173  IF(medit.EQ.15.AND.k(i,1).GE.21) goto 120
5174  i1=i1+1
5175  k(i,3)=k(i,3)+mstu(5)*i1
5176  120 CONTINUE
5177 
5178 C...Find new event history information and replace old.
5179  DO 140 i=1,n
5180  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0) goto 140
5181  id=i
5182  130 im=mod(k(id,3),mstu(5))
5183  IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
5184  IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND.
5185  & k(im,2).NE.94) THEN
5186  id=im
5187  goto 130
5188  ENDIF
5189  ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
5190  IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN
5191  id=im
5192  goto 130
5193  ENDIF
5194  ENDIF
5195  k(i,3)=mstu(5)*(k(i,3)/mstu(5))
5196  IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
5197  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
5198  IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
5199  & k(k(i,4),3)/mstu(5)
5200  IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
5201  & k(k(i,5),3)/mstu(5)
5202  ELSE
5203  kcm=mod(k(i,4)/mstu(5),mstu(5))
5204  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
5205  kcd=mod(k(i,4),mstu(5))
5206  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
5207  k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
5208  kcm=mod(k(i,5)/mstu(5),mstu(5))
5209  IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
5210  kcd=mod(k(i,5),mstu(5))
5211  IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
5212  k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
5213  ENDIF
5214  140 CONTINUE
5215 
5216 C...Pack remaining entries.
5217  i1=0
5218  mstu90=mstu(90)
5219  mstu(90)=0
5220  DO 170 i=1,n
5221  IF(k(i,3)/mstu(5).EQ.0) goto 170
5222  i1=i1+1
5223  DO 150 j=1,5
5224  k(i1,j)=k(i,j)
5225  p(i1,j)=p(i,j)
5226  v(i1,j)=v(i,j)
5227  150 CONTINUE
5228  k(i1,3)=mod(k(i1,3),mstu(5))
5229  DO 160 iz=1,mstu90
5230  IF(i.EQ.mstu(90+iz)) THEN
5231  mstu(90)=mstu(90)+1
5232  mstu(90+mstu(90))=i1
5233  paru(90+mstu(90))=paru(90+iz)
5234  ENDIF
5235  160 CONTINUE
5236  170 CONTINUE
5237  IF(i1.LT.n) mstu(3)=0
5238  IF(i1.LT.n) mstu(70)=0
5239  n=i1
5240 
5241 C...Fill in some missing daughter pointers (lost in colour flow).
5242  ELSEIF(medit.EQ.16) THEN
5243  DO 190 i=1,n
5244  IF(k(i,1).LE.10.OR.k(i,1).GT.20) goto 190
5245  IF(k(i,4).NE.0.OR.k(i,5).NE.0) goto 190
5246 C...Find daughters who point to mother.
5247  DO 180 i1=i+1,n
5248  IF(k(i1,3).NE.i) THEN
5249  ELSEIF(k(i,4).EQ.0) THEN
5250  k(i,4)=i1
5251  ELSE
5252  k(i,5)=i1
5253  ENDIF
5254  180 CONTINUE
5255  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
5256  IF(k(i,4).NE.0) goto 190
5257 C...Find daughters who point to documentation version of mother.
5258  im=k(i,3)
5259  IF(im.LE.0.OR.im.GE.i) goto 190
5260  IF(k(im,1).LE.20.OR.k(im,1).GT.30) goto 190
5261  IF(k(im,2).NE.k(i,2).OR.abs(p(im,5)-p(i,5)).GT.1e-2) goto 190
5262  DO 182 i1=i+1,n
5263  IF(k(i1,3).NE.im) THEN
5264  ELSEIF(k(i,4).EQ.0) THEN
5265  k(i,4)=i1
5266  ELSE
5267  k(i,5)=i1
5268  ENDIF
5269  182 CONTINUE
5270  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
5271  IF(k(i,4).NE.0) goto 190
5272 C...Find daughters who point to documentation daughters who,
5273 C...in their turn, point to documentation mother.
5274  id1=im
5275  id2=im
5276  DO 184 i1=im+1,i-1
5277  IF(k(i1,3).EQ.im.AND.k(i1,1).GT.20.AND.k(i1,1).LE.30) THEN
5278  id2=i1
5279  IF(id1.EQ.im) id1=i1
5280  ENDIF
5281  184 CONTINUE
5282  DO 186 i1=i+1,n
5283  IF(k(i1,3).NE.id1.AND.k(i1,3).NE.id2) THEN
5284  ELSEIF(k(i,4).EQ.0) THEN
5285  k(i,4)=i1
5286  ELSE
5287  k(i,5)=i1
5288  ENDIF
5289  186 CONTINUE
5290  IF(k(i,5).EQ.0) k(i,5)=k(i,4)
5291  190 CONTINUE
5292 
5293 C...Save top entries at bottom of LUJETS commonblock.
5294  ELSEIF(medit.EQ.21) THEN
5295  IF(2*n.GE.mstu(4)) THEN
5296  CALL luerrm(11,'(LUEDIT:) no more memory left in LUJETS')
5297  RETURN
5298  ENDIF
5299  DO 210 i=1,n
5300  DO 200 j=1,5
5301  k(mstu(4)-i,j)=k(i,j)
5302  p(mstu(4)-i,j)=p(i,j)
5303  v(mstu(4)-i,j)=v(i,j)
5304  200 CONTINUE
5305  210 CONTINUE
5306  mstu(32)=n
5307 
5308 C...Restore bottom entries of commonblock LUJETS to top.
5309  ELSEIF(medit.EQ.22) THEN
5310  DO 230 i=1,mstu(32)
5311  DO 220 j=1,5
5312  k(i,j)=k(mstu(4)-i,j)
5313  p(i,j)=p(mstu(4)-i,j)
5314  v(i,j)=v(mstu(4)-i,j)
5315  220 CONTINUE
5316  230 CONTINUE
5317  n=mstu(32)
5318 
5319 C...Mark primary entries at top of commonblock LUJETS as untreated.
5320  ELSEIF(medit.EQ.23) THEN
5321  i1=0
5322  DO 240 i=1,n
5323  kh=k(i,3)
5324  IF(kh.GE.1) THEN
5325  IF(k(kh,1).GT.20) kh=0
5326  ENDIF
5327  IF(kh.NE.0) goto 250
5328  i1=i1+1
5329  IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
5330  240 CONTINUE
5331  250 n=i1
5332 
5333 C...Place largest axis along z axis and second largest in xy plane.
5334  ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
5335  CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61),1),
5336  & p(mstu(61),2)),0d0,0d0,0d0)
5337  CALL ludbrb(1,n+mstu(3),-ulangl(p(mstu(61),3),
5338  & p(mstu(61),1)),0.,0d0,0d0,0d0)
5339  CALL ludbrb(1,n+mstu(3),0.,-ulangl(p(mstu(61)+1,1),
5340  & p(mstu(61)+1,2)),0d0,0d0,0d0)
5341  IF(medit.EQ.31) RETURN
5342 
5343 C...Rotate to put slim jet along +z axis.
5344  DO 260 is=1,2
5345  ns(is)=0
5346  pts(is)=0.
5347  pls(is)=0.
5348  260 CONTINUE
5349  DO 270 i=1,n
5350  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 270
5351  IF(mstu(41).GE.2) THEN
5352  kc=lucomp(k(i,2))
5353  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
5354  & kc.EQ.18) goto 270
5355  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
5356  & goto 270
5357  ENDIF
5358  is=2.-sign(0.5,p(i,3))
5359  ns(is)=ns(is)+1
5360  pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
5361  270 CONTINUE
5362  IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
5363  & CALL ludbrb(1,n+mstu(3),paru(1),0.,0d0,0d0,0d0)
5364 
5365 C...Rotate to put second largest jet into -z,+x quadrant.
5366  DO 280 i=1,n
5367  IF(p(i,3).GE.0.) goto 280
5368  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 280
5369  IF(mstu(41).GE.2) THEN
5370  kc=lucomp(k(i,2))
5371  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
5372  & kc.EQ.18) goto 280
5373  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
5374  & goto 280
5375  ENDIF
5376  is=2.-sign(0.5,p(i,1))
5377  pls(is)=pls(is)-p(i,3)
5378  280 CONTINUE
5379  IF(pls(2).GT.pls(1)) CALL ludbrb(1,n+mstu(3),0.,paru(1),
5380  & 0d0,0d0,0d0)
5381  ENDIF
5382 
5383  RETURN
5384  END
5385 
5386 C*********************************************************************
5387 
5388  SUBROUTINE lulist(MLIST)
5389 
5390 C...Purpose: to give program heading, or list an event, or particle
5391 C...data, or current parameter values.
5392  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
5393  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5394  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5395  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
5396  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
5397  CHARACTER chap*16,chac*16,chan*16,chad(5)*16,chdl(7)*4
5398  dimension ps(6)
5399  DATA chdl/'(())',' ','()','!!','<>','==','(==)'/
5400 
5401 C...Initialization printout: version number and date of last change.
5402  IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN
5403  CALL lulogo
5404  mstu(12)=0
5405  IF(mlist.EQ.0) RETURN
5406  ENDIF
5407 
5408 C...List event data, including additional lines after N.
5409  IF(mlist.GE.1.AND.mlist.LE.3) THEN
5410  IF(mlist.EQ.1) WRITE(mstu(11),5100)
5411  IF(mlist.EQ.2) WRITE(mstu(11),5200)
5412  IF(mlist.EQ.3) WRITE(mstu(11),5300)
5413  lmx=12
5414  IF(mlist.GE.2) lmx=16
5415  istr=0
5416  imax=n
5417  IF(mstu(2).GT.0) imax=mstu(2)
5418  DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
5419  IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) goto 120
5420 
5421 C...Get particle name, pad it and check it is not too long.
5422  CALL luname(k(i,2),chap)
5423  len=0
5424  DO 100 lem=1,16
5425  IF(chap(lem:lem).NE.' ') len=lem
5426  100 CONTINUE
5427  mdl=(k(i,1)+19)/10
5428  ldl=0
5429  IF(mdl.EQ.2.OR.mdl.GE.8) THEN
5430  chac=chap
5431  IF(len.GT.lmx) chac(lmx:lmx)='?'
5432  ELSE
5433  ldl=1
5434  IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
5435  IF(len.EQ.0) THEN
5436  chac=chdl(mdl)(1:2*ldl)//' '
5437  ELSE
5438  chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
5439  & chdl(mdl)(ldl+1:2*ldl)//' '
5440  IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
5441  ENDIF
5442  ENDIF
5443 
5444 C...Add information on string connection.
5445  IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
5446  & THEN
5447  kc=lucomp(k(i,2))
5448  kcc=0
5449  IF(kc.NE.0) kcc=kchg(kc,2)
5450  IF(iabs(k(i,2)).EQ.39) THEN
5451  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'
5452  ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN
5453  istr=1
5454  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
5455  ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
5456  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
5457  ELSEIF(kcc.NE.0) THEN
5458  istr=0
5459  IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
5460  ENDIF
5461  ENDIF
5462 
5463 C...Write data for particle/jet.
5464  IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999.) THEN
5465  WRITE(mstu(11),5400) i,chac(1:12),(k(i,j1),j1=1,3),
5466  & (p(i,j2),j2=1,5)
5467  ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999.) THEN
5468  WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),
5469  & (p(i,j2),j2=1,5)
5470  ELSEIF(mlist.EQ.1) THEN
5471  WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),
5472  & (p(i,j2),j2=1,5)
5473  ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
5474  & k(i,1).EQ.14)) THEN
5475  WRITE(mstu(11),5700) i,chac,(k(i,j1),j1=1,3),
5476  & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
5477  & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
5478  & (p(i,j2),j2=1,5)
5479  ELSE
5480  WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,5),(p(i,j2),j2=1,5)
5481  ENDIF
5482  IF(mlist.EQ.3) WRITE(mstu(11),5900) (v(i,j),j=1,5)
5483 
5484 C...Insert extra separator lines specified by user.
5485  IF(mstu(70).GE.1) THEN
5486  isep=0
5487  DO 110 j=1,min(10,mstu(70))
5488  IF(i.EQ.mstu(70+j)) isep=1
5489  110 CONTINUE
5490  IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),6000)
5491  IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),6100)
5492  ENDIF
5493  120 CONTINUE
5494 
5495 C...Sum of charges and momenta.
5496  DO 130 j=1,6
5497  ps(j)=plu(0,j)
5498  130 CONTINUE
5499  IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999.) THEN
5500  WRITE(mstu(11),6200) ps(6),(ps(j),j=1,5)
5501  ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999.) THEN
5502  WRITE(mstu(11),6300) ps(6),(ps(j),j=1,5)
5503  ELSEIF(mlist.EQ.1) THEN
5504  WRITE(mstu(11),6400) ps(6),(ps(j),j=1,5)
5505  ELSE
5506  WRITE(mstu(11),6500) ps(6),(ps(j),j=1,5)
5507  ENDIF
5508 
5509 C...Give simple list of KF codes defined in program.
5510  ELSEIF(mlist.EQ.11) THEN
5511  WRITE(mstu(11),6600)
5512  DO 140 kf=1,40
5513  CALL luname(kf,chap)
5514  CALL luname(-kf,chan)
5515  IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap
5516  IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan
5517  140 CONTINUE
5518  DO 170 kfls=1,3,2
5519  DO 160 kfla=1,8
5520  DO 150 kflb=1,kfla-(3-kfls)/2
5521  kf=1000*kfla+100*kflb+kfls
5522  CALL luname(kf,chap)
5523  CALL luname(-kf,chan)
5524  WRITE(mstu(11),6700) kf,chap,-kf,chan
5525  150 CONTINUE
5526  160 CONTINUE
5527  170 CONTINUE
5528  kf=130
5529  CALL luname(kf,chap)
5530  WRITE(mstu(11),6700) kf,chap
5531  kf=310
5532  CALL luname(kf,chap)
5533  WRITE(mstu(11),6700) kf,chap
5534  DO 200 kmul=0,5
5535  kfls=3
5536  IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
5537  IF(kmul.EQ.5) kfls=5
5538  kflr=0
5539  IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
5540  IF(kmul.EQ.4) kflr=2
5541  DO 190 kflb=1,8
5542  DO 180 kflc=1,kflb-1
5543  kf=10000*kflr+100*kflb+10*kflc+kfls
5544  CALL luname(kf,chap)
5545  CALL luname(-kf,chan)
5546  WRITE(mstu(11),6700) kf,chap,-kf,chan
5547  180 CONTINUE
5548  kf=10000*kflr+110*kflb+kfls
5549  CALL luname(kf,chap)
5550  WRITE(mstu(11),6700) kf,chap
5551  190 CONTINUE
5552  200 CONTINUE
5553  kf=30443
5554  CALL luname(kf,chap)
5555  WRITE(mstu(11),6700) kf,chap
5556  kf=30553
5557  CALL luname(kf,chap)
5558  WRITE(mstu(11),6700) kf,chap
5559  DO 240 kflsp=1,3
5560  kfls=2+2*(kflsp/3)
5561  DO 230 kfla=1,8
5562  DO 220 kflb=1,kfla
5563  DO 210 kflc=1,kflb
5564  IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc)) goto 210
5565  IF(kflsp.EQ.2.AND.kfla.EQ.kflc) goto 210
5566  IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
5567  IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
5568  CALL luname(kf,chap)
5569  CALL luname(-kf,chan)
5570  WRITE(mstu(11),6700) kf,chap,-kf,chan
5571  210 CONTINUE
5572  220 CONTINUE
5573  230 CONTINUE
5574  240 CONTINUE
5575 
5576 C...List parton/particle data table. Check whether to be listed.
5577  ELSEIF(mlist.EQ.12) THEN
5578  WRITE(mstu(11),6800)
5579  mstj24=mstj(24)
5580  mstj(24)=0
5581  kfmax=30553
5582  IF(mstu(2).NE.0) kfmax=mstu(2)
5583  DO 270 kf=max(1,mstu(1)),kfmax
5584  kc=lucomp(kf)
5585  IF(kc.EQ.0) goto 270
5586  IF(mstu(14).EQ.0.AND.kf.GT.100.AND.kc.LE.100) goto 270
5587  IF(mstu(14).GT.0.AND.kf.GT.100.AND.max(mod(kf/1000,10),
5588  & mod(kf/100,10)).GT.mstu(14)) goto 270
5589  IF(mstu(14).GT.0.AND.kf.GT.100.AND.kc.EQ.90) goto 270
5590 
5591 C...Find particle name and mass. Print information.
5592  CALL luname(kf,chap)
5593  IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) goto 270
5594  CALL luname(-kf,chan)
5595  pm=ulmass(kf)
5596  WRITE(mstu(11),6900) kf,kc,chap,chan,kchg(kc,1),kchg(kc,2),
5597  & kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)
5598 
5599 C...Particle decay: channel number, branching ration, matrix element,
5600 C...decay products.
5601  IF(kf.GT.100.AND.kc.LE.100) goto 270
5602  DO 260 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
5603  DO 250 j=1,5
5604  CALL luname(kfdp(idc,j),chad(j))
5605  250 CONTINUE
5606  WRITE(mstu(11),7000) idc,mdme(idc,1),mdme(idc,2),brat(idc),
5607  & (chad(j),j=1,5)
5608  260 CONTINUE
5609  270 CONTINUE
5610  mstj(24)=mstj24
5611 
5612 C...List parameter value table.
5613  ELSEIF(mlist.EQ.13) THEN
5614  WRITE(mstu(11),7100)
5615  DO 280 i=1,200
5616  WRITE(mstu(11),7200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
5617  280 CONTINUE
5618  ENDIF
5619 
5620 C...Format statements for output on unit MSTU(11) (by default 6).
5621  5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
5622  &5x,'KF orig p_x p_y p_z E m'/)
5623  5200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
5624  &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
5625  &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
5626  5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
5627  &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
5628  &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
5629  &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
5630  5400 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.3)
5631  5500 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.2)
5632  5600 FORMAT(1x,i4,2x,a12,1x,i2,1x,i6,1x,i4,5f9.1)
5633  5700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i1,2i4),5f13.5)
5634  5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i8,2x,i4,2(3x,i9),5f13.5)
5635  5900 FORMAT(66x,5(1x,f12.3))
5636  6000 FORMAT(1x,78('='))
5637  6100 FORMAT(1x,130('='))
5638  6200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
5639  6300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
5640  6400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
5641  6500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
5642  &5f13.5)
5643  6600 FORMAT(///20x,'List of KF codes in program'/)
5644  6700 FORMAT(4x,i6,4x,a16,6x,i6,4x,a16)
5645  6800 FORMAT(///30x,'Particle/parton data table'//5x,'KF',5x,'KC',4x,
5646  &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
5647  &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
5648  &1x,'ME',3x,'Br.rat.',4x,'decay products')
5649  6900 FORMAT(/1x,i6,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
5650  &2x,f12.5,3x,i2)
5651  7000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f8.5,4x,5a16)
5652  7100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
5653  &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
5654  7200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
5655 
5656  RETURN
5657  END
5658 
5659 C*********************************************************************
5660 
5661  SUBROUTINE lulogo
5662 
5663 C...Purpose: to write logo for JETSET and PYTHIA programs.
5664  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5665  common/pypars/mstp(200),parp(200),msti(200),pari(200)
5666  SAVE /ludat1/
5667  SAVE /pypars/
5668  CHARACTER month(12)*3, logo(48)*32, refer(22)*36, line*79,
5669  &vers*1, subv*3, date*2, year*4
5670 
5671 C...Data on months, logo, titles, and references.
5672  DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
5673  &'Oct','Nov','Dec'/
5674  DATA (logo(j),j=1,10)/
5675  &'PPP Y Y TTTTT H H III A ',
5676  &'P P Y Y T H H I A A ',
5677  &'PPP Y T HHHHH I AAAAA',
5678  &'P Y T H H I A A',
5679  &'P Y T H H III A A',
5680  &'JJJJ EEEE TTTTT SSS EEEE TTTTT',
5681  &' J E T S E T ',
5682  &' J EEE T SSS EEE T ',
5683  &'J J E T S E T ',
5684  &' JJ EEEE T SSS EEEE T '/
5685  DATA (logo(j),j=11,29)/
5686  &' *......* ',
5687  &' *:::!!:::::::::::* ',
5688  &' *::::::!!::::::::::::::* ',
5689  &' *::::::::!!::::::::::::::::* ',
5690  &' *:::::::::!!:::::::::::::::::* ',
5691  &' *:::::::::!!:::::::::::::::::* ',
5692  &' *::::::::!!::::::::::::::::*! ',
5693  &' *::::::!!::::::::::::::* !! ',
5694  &' !! *:::!!:::::::::::* !! ',
5695  &' !! !* -><- * !! ',
5696  &' !! !! !! ',
5697  &' !! !! !! ',
5698  &' !! !! ',
5699  &' !! ep !! ',
5700  &' !! !! ',
5701  &' !! pp !! ',
5702  &' !! e+e- !! ',
5703  &' !! !! ',
5704  &' !! '/
5705  DATA (logo(j),j=30,48)/
5706  &'Welcome to the Lund Monte Carlo!',
5707  &' ',
5708  &' This is PYTHIA version x.xxx ',
5709  &'Last date of change: xx xxx 199x',
5710  &' ',
5711  &' This is JETSET version x.xxx ',
5712  &'Last date of change: xx xxx 199x',
5713  &' ',
5714  &' Main author: ',
5715  &' Torbjorn Sjostrand ',
5716  &' Dept. of theoretical physics 2 ',
5717  &' University of Lund ',
5718  &' Solvegatan 14A ',
5719  &' S-223 62 Lund, Sweden ',
5720  &' phone: +46 - 46 - 222 48 16 ',
5721  &' E-mail: torbjorn@thep.lu.se ',
5722  &' ',
5723  &' Copyright Torbjorn Sjostrand ',
5724  &' and CERN, Geneva 1993 '/
5725  DATA (refer(j),j=1,6)/
5726  &'The latest program versions and docu',
5727  &'mentation is found on WWW address ',
5728  &'http://thep.lu.se/tf2/staff/torbjorn',
5729  &'/Welcome.html ',
5730  &' ',
5731  &' '/
5732  DATA (refer(j),j=7,22)/
5733  &'When you cite these programs, priori',
5734  &'ty should always be given to the ',
5735  &'latest published description. Curren',
5736  &'tly this is ',
5737  &'T. Sjostrand, Computer Physics Commu',
5738  &'n. 82 (1994) 74. ',
5739  &'The most recent long description (un',
5740  &'published) is ',
5741  &'T. Sjostrand, LU TP 95-20 and CERN-T',
5742  &'H.7112/93 (revised August 1995). ',
5743  &'Also remember that the programs, to ',
5744  &'a large extent, represent original ',
5745  &'physics research. Other publications',
5746  &' of special relevance to your ',
5747  &'studies may therefore deserve separa',
5748  &'te mention. '/
5749 
5750 C...Check if PYTHIA linked.
5751  IF(mstp(183)/10.NE.199) THEN
5752  logo(32)=' Warning: PYTHIA is not loaded! '
5753  logo(33)='Did you remember to link PYDATA?'
5754  ELSE
5755  WRITE(vers,'(I1)') mstp(181)
5756  logo(32)(26:26)=vers
5757  WRITE(subv,'(I3)') mstp(182)
5758  logo(32)(28:30)=subv
5759  WRITE(date,'(I2)') mstp(185)
5760  logo(33)(22:23)=date
5761  logo(33)(25:27)=month(mstp(184))
5762  WRITE(year,'(I4)') mstp(183)
5763  logo(33)(29:32)=year
5764  ENDIF
5765 
5766 C...Check if JETSET linked.
5767  IF(mstu(183)/10.NE.199) THEN
5768  logo(35)=' Error: JETSET is not loaded! '
5769  logo(36)='Did you remember to link LUDATA?'
5770  ELSE
5771  WRITE(vers,'(I1)') mstu(181)
5772  logo(35)(26:26)=vers
5773  WRITE(subv,'(I3)') mstu(182)
5774  logo(35)(28:30)=subv
5775  WRITE(date,'(I2)') mstu(185)
5776  logo(36)(22:23)=date
5777  logo(36)(25:27)=month(mstu(184))
5778  WRITE(year,'(I4)') mstu(183)
5779  logo(36)(29:32)=year
5780  ENDIF
5781 
5782 C...Loop over lines in header. Define page feed and side borders.
5783  DO 100 ilin=1,48
5784  line=' '
5785  IF(ilin.EQ.1) THEN
5786  line(1:1)='1'
5787  ELSE
5788  line(2:3)='**'
5789  line(78:79)='**'
5790  ENDIF
5791 
5792 C...Separator lines and logos.
5793  IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.EQ.47.OR.ilin.EQ.48) THEN
5794  line(4:77)='***********************************************'//
5795  & '***************************'
5796  ELSEIF(ilin.GE.6.AND.ilin.LE.10) THEN
5797  line(6:37)=logo(ilin-5)
5798  line(44:75)=logo(ilin)
5799  ELSEIF(ilin.GE.13.AND.ilin.LE.31) THEN
5800  line(6:37)=logo(ilin-2)
5801  line(44:75)=logo(ilin+17)
5802  ELSEIF(ilin.GE.34.AND.ilin.LE.44) THEN
5803  line(5:40)=refer(2*ilin-67)
5804  line(41:76)=refer(2*ilin-66)
5805  ENDIF
5806 
5807 C...Write lines to appropriate unit.
5808  IF(mstu(183)/10.EQ.199) THEN
5809  WRITE(mstu(11),'(A79)') line
5810  ELSE
5811  WRITE(*,'(A79)') line
5812  ENDIF
5813  100 CONTINUE
5814 
5815 C...Check that matching subversions are linked.
5816  IF(mstu(183)/10.EQ.199.AND.mstp(183)/10.EQ.199) THEN
5817  IF(mstu(182).LT.mstp(186)) WRITE(mstu(11),
5818  & '(/'' Warning: JETSET subversion too old for PYTHIA''/)')
5819  IF(mstp(182).LT.mstu(186)) WRITE(mstu(11),
5820  & '(/'' Warning: PYTHIA subversion too old for JETSET''/)')
5821  ENDIF
5822 
5823  RETURN
5824  END
5825 
5826 C*********************************************************************
5827 
5828  SUBROUTINE luupda(MUPDA,LFN)
5829 
5830 C...Purpose: to facilitate the updating of particle and decay data.
5831  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
5832  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
5833  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
5834  common/ludat4/chaf(500)
5835  CHARACTER chaf*8
5836  SAVE /ludat1/,/ludat2/,/ludat3/,/ludat4/
5837  CHARACTER chinl*80,chkc*4,chvar(19)*9,chlin*72,
5838  &chblk(20)*72,chold*12,chtmp*12,chnew*12,chcom*12
5839  DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','PMAS(I,1)',
5840  &'PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)','MDCY(I,2)',
5841  &'MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ','KFDP(I,1)',
5842  &'KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)','CHAF(I) '/
5843 
5844 C...Write information on file for editing.
5845  IF(mstu(12).GE.1) CALL lulist(0)
5846  IF(mupda.EQ.1) THEN
5847  DO 110 kc=1,mstu(6)
5848  WRITE(lfn,5000) kc,chaf(kc),(kchg(kc,j1),j1=1,3),
5849  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
5850  DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
5851  WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),
5852  & (kfdp(idc,j),j=1,5)
5853  100 CONTINUE
5854  110 CONTINUE
5855 
5856 C...Reset variables and read information from edited file.
5857  ELSEIF(mupda.EQ.2) THEN
5858  DO 130 i=1,mstu(7)
5859  mdme(i,1)=1
5860  mdme(i,2)=0
5861  brat(i)=0.
5862  DO 120 j=1,5
5863  kfdp(i,j)=0
5864  120 CONTINUE
5865  130 CONTINUE
5866  kc=0
5867  idc=0
5868  ndc=0
5869  140 READ(lfn,5200,end=150) chinl
5870  IF(chinl(2:5).NE.' ') THEN
5871  chkc=chinl(2:5)
5872  IF(kc.NE.0) THEN
5873  mdcy(kc,2)=0
5874  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
5875  mdcy(kc,3)=ndc
5876  ENDIF
5877  READ(chkc,5300) kc
5878  IF(kc.LE.0.OR.kc.GT.mstu(6)) CALL luerrm(27,
5879  & '(LUUPDA:) Read KC code illegal, KC ='//chkc)
5880  READ(chinl,5000) kcr,chaf(kc),(kchg(kc,j1),j1=1,3),
5881  & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
5882  ndc=0
5883  ELSE
5884  idc=idc+1
5885  ndc=ndc+1
5886  IF(idc.GE.mstu(7)) CALL luerrm(27,
5887  & '(LUUPDA:) Decay data arrays full by KC ='//chkc)
5888  READ(chinl,5100) mdme(idc,1),mdme(idc,2),brat(idc),
5889  & (kfdp(idc,j),j=1,5)
5890  ENDIF
5891  goto 140
5892  150 mdcy(kc,2)=0
5893  IF(ndc.NE.0) mdcy(kc,2)=idc+1-ndc
5894  mdcy(kc,3)=ndc
5895 
5896 C...Perform possible tests that new information is consistent.
5897  mstj24=mstj(24)
5898  mstj(24)=0
5899  DO 180 kc=1,mstu(6)
5900  WRITE(chkc,5300) kc
5901  IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
5902  & pmas(kc,4)).LT.0..OR.mdcy(kc,3).LT.0) CALL luerrm(17,
5903  & '(LUUPDA:) Mass/width/life/(# channels) wrong for KC ='//chkc)
5904  brsum=0.
5905  DO 170 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
5906  IF(mdme(idc,2).GT.80) goto 170
5907  kq=kchg(kc,1)
5908  pms=pmas(kc,1)-pmas(kc,3)-parj(64)
5909  merr=0
5910  DO 160 j=1,5
5911  kp=kfdp(idc,j)
5912  IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
5913  ELSEIF(lucomp(kp).EQ.0) THEN
5914  merr=3
5915  ELSE
5916  kq=kq-luchge(kp)
5917  pms=pms-ulmass(kp)
5918  ENDIF
5919  160 CONTINUE
5920  IF(kq.NE.0) merr=max(2,merr)
5921  IF(kfdp(idc,2).NE.0.AND.(kc.LE.20.OR.kc.GT.40).AND.
5922  & (kc.LE.80.OR.kc.GT.100).AND.mdme(idc,2).NE.34.AND.
5923  & mdme(idc,2).NE.61.AND.pms.LT.0.) merr=max(1,merr)
5924  IF(merr.EQ.3) CALL luerrm(17,
5925  & '(LUUPDA:) Unknown particle code in decay of KC ='//chkc)
5926  IF(merr.EQ.2) CALL luerrm(17,
5927  & '(LUUPDA:) Charge not conserved in decay of KC ='//chkc)
5928  IF(merr.EQ.1) CALL luerrm(7,
5929  & '(LUUPDA:) Kinematically unallowed decay of KC ='//chkc)
5930  brsum=brsum+brat(idc)
5931  170 CONTINUE
5932  WRITE(chtmp,5500) brsum
5933  IF(abs(brsum).GT.0.0005.AND.abs(brsum-1.).GT.0.0005) CALL
5934  & luerrm(7,'(LUUPDA:) Sum of branching ratios is '//chtmp(5:12)//
5935  & ' for KC ='//chkc)
5936  180 CONTINUE
5937  mstj(24)=mstj24
5938 
5939 C...Initialize writing of DATA statements for inclusion in program.
5940  ELSEIF(mupda.EQ.3) THEN
5941  DO 250 ivar=1,19
5942  ndim=mstu(6)
5943  IF(ivar.GE.11.AND.ivar.LE.18) ndim=mstu(7)
5944  nlin=1
5945  chlin=' '
5946  chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
5947  llin=35
5948  chold='START'
5949 
5950 C...Loop through variables for conversion to characters.
5951  DO 230 idim=1,ndim
5952  IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)
5953  IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)
5954  IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)
5955  IF(ivar.EQ.4) WRITE(chtmp,5500) pmas(idim,1)
5956  IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,2)
5957  IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,3)
5958  IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,4)
5959  IF(ivar.EQ.8) WRITE(chtmp,5400) mdcy(idim,1)
5960  IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,2)
5961  IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,3)
5962  IF(ivar.EQ.11) WRITE(chtmp,5400) mdme(idim,1)
5963  IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,2)
5964  IF(ivar.EQ.13) WRITE(chtmp,5500) brat(idim)
5965  IF(ivar.EQ.14) WRITE(chtmp,5400) kfdp(idim,1)
5966  IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,2)
5967  IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,3)
5968  IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,4)
5969  IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,5)
5970  IF(ivar.EQ.19) chtmp=chaf(idim)
5971 
5972 C...Length of variable, trailing decimal zeros, quotation marks.
5973  llow=1
5974  lhig=1
5975  DO 190 ll=1,12
5976  IF(chtmp(13-ll:13-ll).NE.' ') llow=13-ll
5977  IF(chtmp(ll:ll).NE.' ') lhig=ll
5978  190 CONTINUE
5979  chnew=chtmp(llow:lhig)//' '
5980  lnew=1+lhig-llow
5981  IF((ivar.GE.4.AND.ivar.LE.7).OR.ivar.EQ.13) THEN
5982  lnew=lnew+1
5983  200 lnew=lnew-1
5984  IF(chnew(lnew:lnew).EQ.'0') goto 200
5985  IF(lnew.EQ.1) chnew(1:2)='0.'
5986  IF(lnew.EQ.1) lnew=2
5987  ELSEIF(ivar.EQ.19) THEN
5988  DO 210 ll=lnew,1,-1
5989  IF(chnew(ll:ll).EQ.'''') THEN
5990  chtmp=chnew
5991  chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
5992  lnew=lnew+1
5993  ENDIF
5994  210 CONTINUE
5995  chtmp=chnew
5996  chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
5997  lnew=lnew+2
5998  ENDIF
5999 
6000 C...Form composite character string, often including repetition counter.
6001  IF(chnew.NE.chold) THEN
6002  nrpt=1
6003  chold=chnew
6004  chcom=chnew
6005  lcom=lnew
6006  ELSE
6007  lrpt=lnew+1
6008  IF(nrpt.GE.2) lrpt=lnew+3
6009  IF(nrpt.GE.10) lrpt=lnew+4
6010  IF(nrpt.GE.100) lrpt=lnew+5
6011  IF(nrpt.GE.1000) lrpt=lnew+6
6012  llin=llin-lrpt
6013  nrpt=nrpt+1
6014  WRITE(chtmp,5400) nrpt
6015  lrpt=1
6016  IF(nrpt.GE.10) lrpt=2
6017  IF(nrpt.GE.100) lrpt=3
6018  IF(nrpt.GE.1000) lrpt=4
6019  chcom(1:lrpt+1+lnew)=chtmp(13-lrpt:12)//'*'//chnew(1:lnew)
6020  lcom=lrpt+1+lnew
6021  ENDIF
6022 
6023 C...Add characters to end of line, to new line (after storing old line),
6024 C...or to new block of lines (after writing old block).
6025  IF(llin+lcom.LE.70) THEN
6026  chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
6027  llin=llin+lcom+1
6028  ELSEIF(nlin.LE.19) THEN
6029  chlin(llin+1:72)=' '
6030  chblk(nlin)=chlin
6031  nlin=nlin+1
6032  chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
6033  llin=6+lcom+1
6034  ELSE
6035  chlin(llin:72)='/'//' '
6036  chblk(nlin)=chlin
6037  WRITE(chtmp,5400) idim-nrpt
6038  chblk(1)(30:33)=chtmp(9:12)
6039  DO 220 ilin=1,nlin
6040  WRITE(lfn,5600) chblk(ilin)
6041  220 CONTINUE
6042  nlin=1
6043  chlin=' '
6044  chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//',I= , )/'//
6045  & chcom(1:lcom)//','
6046  WRITE(chtmp,5400) idim-nrpt+1
6047  chlin(25:28)=chtmp(9:12)
6048  llin=35+lcom+1
6049  ENDIF
6050  230 CONTINUE
6051 
6052 C...Write final block of lines.
6053  chlin(llin:72)='/'//' '
6054  chblk(nlin)=chlin
6055  WRITE(chtmp,5400) ndim
6056  chblk(1)(30:33)=chtmp(9:12)
6057  DO 240 ilin=1,nlin
6058  WRITE(lfn,5600) chblk(ilin)
6059  240 CONTINUE
6060  250 CONTINUE
6061  ENDIF
6062 
6063 C...Formats for reading and writing particle data.
6064  5000 FORMAT(1x,i4,2x,a8,3i3,3f12.5,2x,f12.5,i3)
6065  5100 FORMAT(5x,2i5,f12.5,5i8)
6066  5200 FORMAT(a80)
6067  5300 FORMAT(i4)
6068  5400 FORMAT(i12)
6069  5500 FORMAT(f12.5)
6070  5600 FORMAT(a72)
6071 
6072  RETURN
6073  END
6074 
6075 C*********************************************************************
6076 
6077  FUNCTION klu(I,J)
6078 
6079 C...Purpose: to provide various integer-valued event related data.
6080  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6081  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6082  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6083  SAVE /lujets/,/ludat1/,/ludat2/
6084 
6085 C...Default value. For I=0 number of entries, number of stable entries
6086 C...or 3 times total charge.
6087  klu=0
6088  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
6089  ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
6090  klu=n
6091  ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
6092  DO 100 i1=1,n
6093  IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+1
6094  IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) klu=klu+
6095  & luchge(k(i1,2))
6096  100 CONTINUE
6097  ELSEIF(i.EQ.0) THEN
6098 
6099 C...For I > 0 direct readout of K matrix or charge.
6100  ELSEIF(j.LE.5) THEN
6101  klu=k(i,j)
6102  ELSEIF(j.EQ.6) THEN
6103  klu=luchge(k(i,2))
6104 
6105 C...Status (existing/fragmented/decayed), parton/hadron separation.
6106  ELSEIF(j.LE.8) THEN
6107  IF(k(i,1).GE.1.AND.k(i,1).LE.10) klu=1
6108  IF(j.EQ.8) klu=klu*k(i,2)
6109  ELSEIF(j.LE.12) THEN
6110  kfa=iabs(k(i,2))
6111  kc=lucomp(kfa)
6112  kq=0
6113  IF(kc.NE.0) kq=kchg(kc,2)
6114  IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) klu=k(i,2)
6115  IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) klu=k(i,2)
6116  IF(j.EQ.11) klu=kc
6117  IF(j.EQ.12) klu=kq*isign(1,k(i,2))
6118 
6119 C...Heaviest flavour in hadron/diquark.
6120  ELSEIF(j.EQ.13) THEN
6121  kfa=iabs(k(i,2))
6122  klu=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
6123  IF(kfa.LT.10) klu=kfa
6124  IF(mod(kfa/1000,10).NE.0) klu=mod(kfa/1000,10)
6125  klu=klu*isign(1,k(i,2))
6126 
6127 C...Particle history: generation, ancestor, rank.
6128  ELSEIF(j.LE.15) THEN
6129  i2=i
6130  i1=i
6131  110 klu=klu+1
6132  i2=i1
6133  i1=k(i1,3)
6134  IF(i1.GT.0.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) goto 110
6135  IF(j.EQ.15) klu=i2
6136  ELSEIF(j.EQ.16) THEN
6137  kfa=iabs(k(i,2))
6138  IF(k(i,1).LE.20.AND.((kfa.GE.11.AND.kfa.LE.20).OR.kfa.EQ.22.OR.
6139  & (kfa.GT.100.AND.mod(kfa/10,10).NE.0))) THEN
6140  i1=i
6141  120 i2=i1
6142  i1=k(i1,3)
6143  IF(i1.GT.0) THEN
6144  kfam=iabs(k(i1,2))
6145  ilp=1
6146  IF(kfam.NE.0.AND.kfam.LE.10) ilp=0
6147  IF(kfam.EQ.21.OR.kfam.EQ.91.OR.kfam.EQ.92.OR.kfam.EQ.93)
6148  & ilp=0
6149  IF(kfam.GT.100.AND.mod(kfam/10,10).EQ.0) ilp=0
6150  IF(ilp.EQ.1) goto 120
6151  ENDIF
6152  IF(k(i1,1).EQ.12) THEN
6153  DO 130 i3=i1+1,i2
6154  IF(k(i3,3).EQ.k(i2,3).AND.k(i3,2).NE.91.AND.k(i3,2).NE.92
6155  & .AND.k(i3,2).NE.93) klu=klu+1
6156  130 CONTINUE
6157  ELSE
6158  i3=i2
6159  140 klu=klu+1
6160  i3=i3+1
6161  IF(i3.LT.n.AND.k(i3,3).EQ.k(i2,3)) goto 140
6162  ENDIF
6163  ENDIF
6164 
6165 C...Particle coming from collapsing jet system or not.
6166  ELSEIF(j.EQ.17) THEN
6167  i1=i
6168  150 klu=klu+1
6169  i3=i1
6170  i1=k(i1,3)
6171  i0=max(1,i1)
6172  kc=lucomp(k(i0,2))
6173  IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
6174  IF(klu.EQ.1) klu=-1
6175  IF(klu.GT.1) klu=0
6176  RETURN
6177  ENDIF
6178  IF(kchg(kc,2).EQ.0) goto 150
6179  IF(k(i1,1).NE.12) klu=0
6180  IF(k(i1,1).NE.12) RETURN
6181  i2=i1
6182  160 i2=i2+1
6183  IF(i2.LT.n.AND.k(i2,1).NE.11) goto 160
6184  k3m=k(i3-1,3)
6185  IF(k3m.GE.i1.AND.k3m.LE.i2) klu=0
6186  k3p=k(i3+1,3)
6187  IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) klu=0
6188 
6189 C...Number of decay products. Colour flow.
6190  ELSEIF(j.EQ.18) THEN
6191  IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) klu=max(0,k(i,5)-k(i,4)+1)
6192  IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) klu=0
6193  ELSEIF(j.LE.22) THEN
6194  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
6195  IF(j.EQ.19) klu=mod(k(i,4)/mstu(5),mstu(5))
6196  IF(j.EQ.20) klu=mod(k(i,5)/mstu(5),mstu(5))
6197  IF(j.EQ.21) klu=mod(k(i,4),mstu(5))
6198  IF(j.EQ.22) klu=mod(k(i,5),mstu(5))
6199  ELSE
6200  ENDIF
6201 
6202  RETURN
6203  END
6204 
6205 C*********************************************************************
6206 
6207  FUNCTION plu(I,J)
6208 
6209 C...Purpose: to provide various real-valued event related data.
6210  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6211  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6212  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6213  SAVE /lujets/,/ludat1/,/ludat2/
6214  dimension psum(4)
6215 
6216 C...Set default value. For I = 0 sum of momenta or charges,
6217 C...or invariant mass of system.
6218  plu=0.
6219  IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
6220  ELSEIF(i.EQ.0.AND.j.LE.4) THEN
6221  DO 100 i1=1,n
6222  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+p(i1,j)
6223  100 CONTINUE
6224  ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
6225  DO 120 j1=1,4
6226  psum(j1)=0.
6227  DO 110 i1=1,n
6228  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+p(i1,j1)
6229  110 CONTINUE
6230  120 CONTINUE
6231  plu=sqrt(max(0.,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
6232  ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
6233  DO 130 i1=1,n
6234  IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) plu=plu+luchge(k(i1,2))/3.
6235  130 CONTINUE
6236  ELSEIF(i.EQ.0) THEN
6237 
6238 C...Direct readout of P matrix.
6239  ELSEIF(j.LE.5) THEN
6240  plu=p(i,j)
6241 
6242 C...Charge, total momentum, transverse momentum, transverse mass.
6243  ELSEIF(j.LE.12) THEN
6244  IF(j.EQ.6) plu=luchge(k(i,2))/3.
6245  IF(j.EQ.7.OR.j.EQ.8) plu=p(i,1)**2+p(i,2)**2+p(i,3)**2
6246  IF(j.EQ.9.OR.j.EQ.10) plu=p(i,1)**2+p(i,2)**2
6247  IF(j.EQ.11.OR.j.EQ.12) plu=p(i,5)**2+p(i,1)**2+p(i,2)**2
6248  IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) plu=sqrt(plu)
6249 
6250 C...Theta and phi angle in radians or degrees.
6251  ELSEIF(j.LE.16) THEN
6252  IF(j.LE.14) plu=ulangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
6253  IF(j.GE.15) plu=ulangl(p(i,1),p(i,2))
6254  IF(j.EQ.14.OR.j.EQ.16) plu=plu*180./paru(1)
6255 
6256 C...True rapidity, rapidity with pion mass, pseudorapidity.
6257  ELSEIF(j.LE.19) THEN
6258  pmr=0.
6259  IF(j.EQ.17) pmr=p(i,5)
6260  IF(j.EQ.18) pmr=ulmass(211)
6261  pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
6262  plu=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
6263  & 1e20)),p(i,3))
6264 
6265 C...Energy and momentum fractions (only to be used in CM frame).
6266  ELSEIF(j.LE.25) THEN
6267  IF(j.EQ.20) plu=2.*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
6268  IF(j.EQ.21) plu=2.*p(i,3)/paru(21)
6269  IF(j.EQ.22) plu=2.*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
6270  IF(j.EQ.23) plu=2.*p(i,4)/paru(21)
6271  IF(j.EQ.24) plu=(p(i,4)+p(i,3))/paru(21)
6272  IF(j.EQ.25) plu=(p(i,4)-p(i,3))/paru(21)
6273  ENDIF
6274 
6275  RETURN
6276  END
6277 
6278 C*********************************************************************
6279 
6280  SUBROUTINE lusphe(SPH,APL)
6281 
6282 C...Purpose: to perform sphericity tensor analysis to give sphericity,
6283 C...aplanarity and the related event axes.
6284  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6285  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6286  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6287  SAVE /lujets/,/ludat1/,/ludat2/
6288  dimension sm(3,3),sv(3,3)
6289 
6290 C...Calculate matrix to be diagonalized.
6291  np=0
6292  DO 110 j1=1,3
6293  DO 100 j2=j1,3
6294  sm(j1,j2)=0.
6295  100 CONTINUE
6296  110 CONTINUE
6297  ps=0.
6298  DO 140 i=1,n
6299  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
6300  IF(mstu(41).GE.2) THEN
6301  kc=lucomp(k(i,2))
6302  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6303  & kc.EQ.18) goto 140
6304  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6305  & goto 140
6306  ENDIF
6307  np=np+1
6308  pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6309  pwt=1.
6310  IF(abs(paru(41)-2.).GT.0.001) pwt=max(1e-10,pa)**(paru(41)-2.)
6311  DO 130 j1=1,3
6312  DO 120 j2=j1,3
6313  sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
6314  120 CONTINUE
6315  130 CONTINUE
6316  ps=ps+pwt*pa**2
6317  140 CONTINUE
6318 
6319 C...Very low multiplicities (0 or 1) not considered.
6320  IF(np.LE.1) THEN
6321  CALL luerrm(8,'(LUSPHE:) too few particles for analysis')
6322  sph=-1.
6323  apl=-1.
6324  RETURN
6325  ENDIF
6326  DO 160 j1=1,3
6327  DO 150 j2=j1,3
6328  sm(j1,j2)=sm(j1,j2)/ps
6329  150 CONTINUE
6330  160 CONTINUE
6331 
6332 C...Find eigenvalues to matrix (third degree equation).
6333  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
6334  &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
6335  sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
6336  &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
6337  sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
6338  p(n+1,4)=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
6339  p(n+3,4)=1./3.+sqrt(-sq)*min(2.*sp,-sqrt(3.*(1.-sp**2))-sp)
6340  p(n+2,4)=1.-p(n+1,4)-p(n+3,4)
6341  IF(p(n+2,4).LT.1e-5) THEN
6342  CALL luerrm(8,'(LUSPHE:) all particles back-to-back')
6343  sph=-1.
6344  apl=-1.
6345  RETURN
6346  ENDIF
6347 
6348 C...Find first and last eigenvector by solving equation system.
6349  DO 240 i=1,3,2
6350  DO 180 j1=1,3
6351  sv(j1,j1)=sm(j1,j1)-p(n+i,4)
6352  DO 170 j2=j1+1,3
6353  sv(j1,j2)=sm(j1,j2)
6354  sv(j2,j1)=sm(j1,j2)
6355  170 CONTINUE
6356  180 CONTINUE
6357  smax=0.
6358  DO 200 j1=1,3
6359  DO 190 j2=1,3
6360  IF(abs(sv(j1,j2)).LE.smax) goto 190
6361  ja=j1
6362  jb=j2
6363  smax=abs(sv(j1,j2))
6364  190 CONTINUE
6365  200 CONTINUE
6366  smax=0.
6367  DO 220 j3=ja+1,ja+2
6368  j1=j3-3*((j3-1)/3)
6369  rl=sv(j1,jb)/sv(ja,jb)
6370  DO 210 j2=1,3
6371  sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
6372  IF(abs(sv(j1,j2)).LE.smax) goto 210
6373  jc=j1
6374  smax=abs(sv(j1,j2))
6375  210 CONTINUE
6376  220 CONTINUE
6377  jb1=jb+1-3*(jb/3)
6378  jb2=jb+2-3*((jb+1)/3)
6379  p(n+i,jb1)=-sv(jc,jb2)
6380  p(n+i,jb2)=sv(jc,jb1)
6381  p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
6382  &sv(ja,jb)
6383  pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
6384  sgn=(-1.)**int(rlu(0)+0.5)
6385  DO 230 j=1,3
6386  p(n+i,j)=sgn*p(n+i,j)/pa
6387  230 CONTINUE
6388  240 CONTINUE
6389 
6390 C...Middle axis orthogonal to other two. Fill other codes.
6391  sgn=(-1.)**int(rlu(0)+0.5)
6392  p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
6393  p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
6394  p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
6395  DO 260 i=1,3
6396  k(n+i,1)=31
6397  k(n+i,2)=95
6398  k(n+i,3)=i
6399  k(n+i,4)=0
6400  k(n+i,5)=0
6401  p(n+i,5)=0.
6402  DO 250 j=1,5
6403  v(i,j)=0.
6404  250 CONTINUE
6405  260 CONTINUE
6406 
6407 C...Calculate sphericity and aplanarity. Select storing option.
6408  sph=1.5*(p(n+2,4)+p(n+3,4))
6409  apl=1.5*p(n+3,4)
6410  mstu(61)=n+1
6411  mstu(62)=np
6412  IF(mstu(43).LE.1) mstu(3)=3
6413  IF(mstu(43).GE.2) n=n+3
6414 
6415  RETURN
6416  END
6417 
6418 C*********************************************************************
6419 
6420  SUBROUTINE luthru(THR,OBL)
6421 
6422 C...Purpose: to perform thrust analysis to give thrust, oblateness
6423 C...and the related event axes.
6424  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6425  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6426  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6427  SAVE /lujets/,/ludat1/,/ludat2/
6428  dimension tdi(3),tpr(3)
6429 
6430 C...Take copy of particles that are to be considered in thrust analysis.
6431  np=0
6432  ps=0.
6433  DO 100 i=1,n
6434  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100
6435  IF(mstu(41).GE.2) THEN
6436  kc=lucomp(k(i,2))
6437  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6438  & kc.EQ.18) goto 100
6439  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6440  & goto 100
6441  ENDIF
6442  IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
6443  CALL luerrm(11,'(LUTHRU:) no more memory left in LUJETS')
6444  thr=-2.
6445  obl=-2.
6446  RETURN
6447  ENDIF
6448  np=np+1
6449  k(n+np,1)=23
6450  p(n+np,1)=p(i,1)
6451  p(n+np,2)=p(i,2)
6452  p(n+np,3)=p(i,3)
6453  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6454  p(n+np,5)=1.
6455  IF(abs(paru(42)-1.).GT.0.001) p(n+np,5)=p(n+np,4)**(paru(42)-1.)
6456  ps=ps+p(n+np,4)*p(n+np,5)
6457  100 CONTINUE
6458 
6459 C...Very low multiplicities (0 or 1) not considered.
6460  IF(np.LE.1) THEN
6461  CALL luerrm(8,'(LUTHRU:) too few particles for analysis')
6462  thr=-1.
6463  obl=-1.
6464  RETURN
6465  ENDIF
6466 
6467 C...Loop over thrust and major. T axis along z direction in latter case.
6468  DO 320 ild=1,2
6469  IF(ild.EQ.2) THEN
6470  k(n+np+1,1)=31
6471  phi=ulangl(p(n+np+1,1),p(n+np+1,2))
6472  mstu(33)=1
6473  CALL ludbrb(n+1,n+np+1,0.,-phi,0d0,0d0,0d0)
6474  the=ulangl(p(n+np+1,3),p(n+np+1,1))
6475  CALL ludbrb(n+1,n+np+1,-the,0.,0d0,0d0,0d0)
6476  ENDIF
6477 
6478 C...Find and order particles with highest p (pT for major).
6479  DO 110 ilf=n+np+4,n+np+mstu(44)+4
6480  p(ilf,4)=0.
6481  110 CONTINUE
6482  DO 160 i=n+1,n+np
6483  IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
6484  DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1
6485  IF(p(i,4).LE.p(ilf,4)) goto 140
6486  DO 120 j=1,5
6487  p(ilf+1,j)=p(ilf,j)
6488  120 CONTINUE
6489  130 CONTINUE
6490  ilf=n+np+3
6491  140 DO 150 j=1,5
6492  p(ilf+1,j)=p(i,j)
6493  150 CONTINUE
6494  160 CONTINUE
6495 
6496 C...Find and order initial axes with highest thrust (major).
6497  DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
6498  p(ilg,4)=0.
6499  170 CONTINUE
6500  nc=2**(min(mstu(44),np)-1)
6501  DO 250 ilc=1,nc
6502  DO 180 j=1,3
6503  tdi(j)=0.
6504  180 CONTINUE
6505  DO 200 ilf=1,min(mstu(44),np)
6506  sgn=p(n+np+ilf+3,5)
6507  IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
6508  DO 190 j=1,4-ild
6509  tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
6510  190 CONTINUE
6511  200 CONTINUE
6512  tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
6513  DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
6514  IF(tds.LE.p(ilg,4)) goto 230
6515  DO 210 j=1,4
6516  p(ilg+1,j)=p(ilg,j)
6517  210 CONTINUE
6518  220 CONTINUE
6519  ilg=n+np+mstu(44)+4
6520  230 DO 240 j=1,3
6521  p(ilg+1,j)=tdi(j)
6522  240 CONTINUE
6523  p(ilg+1,4)=tds
6524  250 CONTINUE
6525 
6526 C...Iterate direction of axis until stable maximum.
6527  p(n+np+ild,4)=0.
6528  ilg=0
6529  260 ilg=ilg+1
6530  thp=0.
6531  270 thps=thp
6532  DO 280 j=1,3
6533  IF(thp.LE.1e-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
6534  IF(thp.GT.1e-10) tdi(j)=tpr(j)
6535  tpr(j)=0.
6536  280 CONTINUE
6537  DO 300 i=n+1,n+np
6538  sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
6539  DO 290 j=1,4-ild
6540  tpr(j)=tpr(j)+sgn*p(i,j)
6541  290 CONTINUE
6542  300 CONTINUE
6543  thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
6544  IF(thp.GE.thps+paru(48)) goto 270
6545 
6546 C...Save good axis. Try new initial axis until a number of tries agree.
6547  IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) goto 260
6548  IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
6549  iagr=0
6550  sgn=(-1.)**int(rlu(0)+0.5)
6551  DO 310 j=1,3
6552  p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
6553  310 CONTINUE
6554  p(n+np+ild,4)=thp
6555  p(n+np+ild,5)=0.
6556  ENDIF
6557  iagr=iagr+1
6558  IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) goto 260
6559  320 CONTINUE
6560 
6561 C...Find minor axis and value by orthogonality.
6562  sgn=(-1.)**int(rlu(0)+0.5)
6563  p(n+np+3,1)=-sgn*p(n+np+2,2)
6564  p(n+np+3,2)=sgn*p(n+np+2,1)
6565  p(n+np+3,3)=0.
6566  thp=0.
6567  DO 330 i=n+1,n+np
6568  thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
6569  330 CONTINUE
6570  p(n+np+3,4)=thp/ps
6571  p(n+np+3,5)=0.
6572 
6573 C...Fill axis information. Rotate back to original coordinate system.
6574  DO 350 ild=1,3
6575  k(n+ild,1)=31
6576  k(n+ild,2)=96
6577  k(n+ild,3)=ild
6578  k(n+ild,4)=0
6579  k(n+ild,5)=0
6580  DO 340 j=1,5
6581  p(n+ild,j)=p(n+np+ild,j)
6582  v(n+ild,j)=0.
6583  340 CONTINUE
6584  350 CONTINUE
6585  CALL ludbrb(n+1,n+3,the,phi,0d0,0d0,0d0)
6586 
6587 C...Calculate thrust and oblateness. Select storing option.
6588  thr=p(n+1,4)
6589  obl=p(n+2,4)-p(n+3,4)
6590  mstu(61)=n+1
6591  mstu(62)=np
6592  IF(mstu(43).LE.1) mstu(3)=3
6593  IF(mstu(43).GE.2) n=n+3
6594 
6595  RETURN
6596  END
6597 
6598 C*********************************************************************
6599 
6600  SUBROUTINE luclus(NJET)
6601 
6602 C...Purpose: to subdivide the particle content of an event into
6603 C...jets/clusters.
6604  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6605  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6606  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6607  SAVE /lujets/,/ludat1/,/ludat2/
6608  dimension ps(5)
6609  SAVE nsav,np,ps,pss,rinit,npre,nrem
6610 
6611 C...Functions: distance measure in pT or (pseudo)mass.
6612  r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
6613  &p(i1,3)*p(i2,3))*2.*p(i1,5)*p(i2,5)/(0.0001+p(i1,5)+p(i2,5))**2
6614  r2m(i1,i2)=2.*p(i1,4)*p(i2,4)*(1.-(p(i1,1)*p(i2,1)+p(i1,2)*
6615  &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))
6616 
6617 C...If first time, reset. If reentering, skip preliminaries.
6618  IF(mstu(48).LE.0) THEN
6619  np=0
6620  DO 100 j=1,5
6621  ps(j)=0.
6622  100 CONTINUE
6623  pss=0.
6624  ELSE
6625  njet=nsav
6626  IF(mstu(43).GE.2) n=n-njet
6627  DO 110 i=n+1,n+njet
6628  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6629  110 CONTINUE
6630  IF(mstu(46).LE.3) r2acc=paru(44)**2
6631  IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2
6632  nloop=0
6633  goto 300
6634  ENDIF
6635 
6636 C...Find which particles are to be considered in cluster search.
6637  DO 140 i=1,n
6638  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140
6639  IF(mstu(41).GE.2) THEN
6640  kc=lucomp(k(i,2))
6641  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6642  & kc.EQ.18) goto 140
6643  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6644  & goto 140
6645  ENDIF
6646  IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
6647  CALL luerrm(11,'(LUCLUS:) no more memory left in LUJETS')
6648  njet=-1
6649  RETURN
6650  ENDIF
6651 
6652 C...Take copy of these particles, with space left for jets later on.
6653  np=np+1
6654  k(n+np,3)=i
6655  DO 120 j=1,5
6656  p(n+np,j)=p(i,j)
6657  120 CONTINUE
6658  IF(mstu(42).EQ.0) p(n+np,5)=0.
6659  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
6660  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
6661  p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6662  DO 130 j=1,4
6663  ps(j)=ps(j)+p(n+np,j)
6664  130 CONTINUE
6665  pss=pss+p(n+np,5)
6666  140 CONTINUE
6667  DO 160 i=n+1,n+np
6668  k(i+np,3)=k(i,3)
6669  DO 150 j=1,5
6670  p(i+np,j)=p(i,j)
6671  150 CONTINUE
6672  160 CONTINUE
6673  ps(5)=sqrt(max(0.,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
6674 
6675 C...Very low multiplicities not considered.
6676  IF(np.LT.mstu(47)) THEN
6677  CALL luerrm(8,'(LUCLUS:) too few particles for analysis')
6678  njet=-1
6679  RETURN
6680  ENDIF
6681 
6682 C...Find precluster configuration. If too few jets, make harder cuts.
6683  nloop=0
6684  IF(mstu(46).LE.3) r2acc=paru(44)**2
6685  IF(mstu(46).GE.4) r2acc=paru(45)*ps(5)**2
6686  rinit=1.25*paru(43)
6687  IF(np.LE.mstu(47)+2) rinit=0.
6688  170 rinit=0.8*rinit
6689  npre=0
6690  nrem=np
6691  DO 180 i=n+np+1,n+2*np
6692  k(i,4)=0
6693  180 CONTINUE
6694 
6695 C...Sum up small momentum region. Jet if enough absolute momentum.
6696  IF(mstu(46).LE.2) THEN
6697  DO 190 j=1,4
6698  p(n+1,j)=0.
6699  190 CONTINUE
6700  DO 210 i=n+np+1,n+2*np
6701  IF(p(i,5).GT.2.*rinit) goto 210
6702  nrem=nrem-1
6703  k(i,4)=1
6704  DO 200 j=1,4
6705  p(n+1,j)=p(n+1,j)+p(i,j)
6706  200 CONTINUE
6707  210 CONTINUE
6708  p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
6709  IF(p(n+1,5).GT.2.*rinit) npre=1
6710  IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
6711  IF(nrem.EQ.0) goto 170
6712  ENDIF
6713 
6714 C...Find fastest remaining particle.
6715  220 npre=npre+1
6716  pmax=0.
6717  DO 230 i=n+np+1,n+2*np
6718  IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) goto 230
6719  imax=i
6720  pmax=p(i,5)
6721  230 CONTINUE
6722  DO 240 j=1,5
6723  p(n+npre,j)=p(imax,j)
6724  240 CONTINUE
6725  nrem=nrem-1
6726  k(imax,4)=npre
6727 
6728 C...Sum up precluster around it according to pT separation.
6729  IF(mstu(46).LE.2) THEN
6730  DO 260 i=n+np+1,n+2*np
6731  IF(k(i,4).NE.0) goto 260
6732  r2=r2t(i,imax)
6733  IF(r2.GT.rinit**2) goto 260
6734  nrem=nrem-1
6735  k(i,4)=npre
6736  DO 250 j=1,4
6737  p(n+npre,j)=p(n+npre,j)+p(i,j)
6738  250 CONTINUE
6739  260 CONTINUE
6740  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
6741 
6742 C...Sum up precluster around it according to mass separation.
6743  ELSE
6744  270 imin=0
6745  r2min=rinit**2
6746  DO 280 i=n+np+1,n+2*np
6747  IF(k(i,4).NE.0) goto 280
6748  r2=r2m(i,n+npre)
6749  IF(r2.GE.r2min) goto 280
6750  imin=i
6751  r2min=r2
6752  280 CONTINUE
6753  IF(imin.NE.0) THEN
6754  DO 290 j=1,4
6755  p(n+npre,j)=p(n+npre,j)+p(imin,j)
6756  290 CONTINUE
6757  p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
6758  nrem=nrem-1
6759  k(imin,4)=npre
6760  goto 270
6761  ENDIF
6762  ENDIF
6763 
6764 C...Check if more preclusters to be found. Start over if too few.
6765  IF(rinit.GE.0.2*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170
6766  IF(nrem.GT.0) goto 220
6767  njet=npre
6768 
6769 C...Reassign all particles to nearest jet. Sum up new jet momenta.
6770  300 tsav=0.
6771  psjt=0.
6772  310 IF(mstu(46).LE.1) THEN
6773  DO 330 i=n+1,n+njet
6774  DO 320 j=1,4
6775  v(i,j)=0.
6776  320 CONTINUE
6777  330 CONTINUE
6778  DO 360 i=n+np+1,n+2*np
6779  r2min=pss**2
6780  DO 340 ijet=n+1,n+njet
6781  IF(p(ijet,5).LT.rinit) goto 340
6782  r2=r2t(i,ijet)
6783  IF(r2.GE.r2min) goto 340
6784  imin=ijet
6785  r2min=r2
6786  340 CONTINUE
6787  k(i,4)=imin-n
6788  DO 350 j=1,4
6789  v(imin,j)=v(imin,j)+p(i,j)
6790  350 CONTINUE
6791  360 CONTINUE
6792  psjt=0.
6793  DO 380 i=n+1,n+njet
6794  DO 370 j=1,4
6795  p(i,j)=v(i,j)
6796  370 CONTINUE
6797  p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
6798  psjt=psjt+p(i,5)
6799  380 CONTINUE
6800  ENDIF
6801 
6802 C...Find two closest jets.
6803  r2min=2.*max(r2acc,ps(5)**2)
6804  DO 400 itry1=n+1,n+njet-1
6805  DO 390 itry2=itry1+1,n+njet
6806  IF(mstu(46).LE.2) r2=r2t(itry1,itry2)
6807  IF(mstu(46).GE.3) r2=r2m(itry1,itry2)
6808  IF(r2.GE.r2min) goto 390
6809  imin1=itry1
6810  imin2=itry2
6811  r2min=r2
6812  390 CONTINUE
6813  400 CONTINUE
6814 
6815 C...If allowed, join two closest jets and start over.
6816  IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
6817  irec=min(imin1,imin2)
6818  idel=max(imin1,imin2)
6819  DO 410 j=1,4
6820  p(irec,j)=p(imin1,j)+p(imin2,j)
6821  410 CONTINUE
6822  p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
6823  DO 430 i=idel+1,n+njet
6824  DO 420 j=1,5
6825  p(i-1,j)=p(i,j)
6826  420 CONTINUE
6827  430 CONTINUE
6828  IF(mstu(46).GE.2) THEN
6829  DO 440 i=n+np+1,n+2*np
6830  iori=n+k(i,4)
6831  IF(iori.EQ.idel) k(i,4)=irec-n
6832  IF(iori.GT.idel) k(i,4)=k(i,4)-1
6833  440 CONTINUE
6834  ENDIF
6835  njet=njet-1
6836  goto 300
6837 
6838 C...Divide up broad jet if empty cluster in list of final ones.
6839  ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
6840  DO 450 i=n+1,n+njet
6841  k(i,5)=0
6842  450 CONTINUE
6843  DO 460 i=n+np+1,n+2*np
6844  k(n+k(i,4),5)=k(n+k(i,4),5)+1
6845  460 CONTINUE
6846  iemp=0
6847  DO 470 i=n+1,n+njet
6848  IF(k(i,5).EQ.0) iemp=i
6849  470 CONTINUE
6850  IF(iemp.NE.0) THEN
6851  nloop=nloop+1
6852  ispl=0
6853  r2max=0.
6854  DO 480 i=n+np+1,n+2*np
6855  IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) goto 480
6856  ijet=n+k(i,4)
6857  r2=r2t(i,ijet)
6858  IF(r2.LE.r2max) goto 480
6859  ispl=i
6860  r2max=r2
6861  480 CONTINUE
6862  IF(ispl.NE.0) THEN
6863  ijet=n+k(ispl,4)
6864  DO 490 j=1,4
6865  p(iemp,j)=p(ispl,j)
6866  p(ijet,j)=p(ijet,j)-p(ispl,j)
6867  490 CONTINUE
6868  p(iemp,5)=p(ispl,5)
6869  p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
6870  IF(nloop.LE.2) goto 300
6871  ENDIF
6872  ENDIF
6873  ENDIF
6874 
6875 C...If generalized thrust has not yet converged, continue iteration.
6876  IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
6877  &THEN
6878  tsav=psjt/pss
6879  goto 310
6880  ENDIF
6881 
6882 C...Reorder jets according to energy.
6883  DO 510 i=n+1,n+njet
6884  DO 500 j=1,5
6885  v(i,j)=p(i,j)
6886  500 CONTINUE
6887  510 CONTINUE
6888  DO 540 inew=n+1,n+njet
6889  pemax=0.
6890  DO 520 itry=n+1,n+njet
6891  IF(v(itry,4).LE.pemax) goto 520
6892  imax=itry
6893  pemax=v(itry,4)
6894  520 CONTINUE
6895  k(inew,1)=31
6896  k(inew,2)=97
6897  k(inew,3)=inew-n
6898  k(inew,4)=0
6899  DO 530 j=1,5
6900  p(inew,j)=v(imax,j)
6901  530 CONTINUE
6902  v(imax,4)=-1.
6903  k(imax,5)=inew
6904  540 CONTINUE
6905 
6906 C...Clean up particle-jet assignments and jet information.
6907  DO 550 i=n+np+1,n+2*np
6908  iori=k(n+k(i,4),5)
6909  k(i,4)=iori-n
6910  IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
6911  k(iori,4)=k(iori,4)+1
6912  550 CONTINUE
6913  iemp=0
6914  psjt=0.
6915  DO 570 i=n+1,n+njet
6916  k(i,5)=0
6917  psjt=psjt+p(i,5)
6918  p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0.))
6919  DO 560 j=1,5
6920  v(i,j)=0.
6921  560 CONTINUE
6922  IF(k(i,4).EQ.0) iemp=i
6923  570 CONTINUE
6924 
6925 C...Select storing option. Output variables. Check for failure.
6926  mstu(61)=n+1
6927  mstu(62)=np
6928  mstu(63)=npre
6929  paru(61)=ps(5)
6930  paru(62)=psjt/pss
6931  paru(63)=sqrt(r2min)
6932  IF(njet.LE.1) paru(63)=0.
6933  IF(iemp.NE.0) THEN
6934  CALL luerrm(8,'(LUCLUS:) failed to reconstruct as requested')
6935  njet=-1
6936  ENDIF
6937  IF(mstu(43).LE.1) mstu(3)=njet
6938  IF(mstu(43).GE.2) n=n+njet
6939  nsav=njet
6940 
6941  RETURN
6942  END
6943 
6944 C*********************************************************************
6945 
6946  SUBROUTINE lucell(NJET)
6947 
6948 C...Purpose: to provide a simple way of jet finding in an eta-phi-ET
6949 C...coordinate frame, as used for calorimeters at hadron colliders.
6950  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
6951  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
6952  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
6953  SAVE /lujets/,/ludat1/,/ludat2/
6954 
6955 C...Loop over all particles. Find cell that was hit by given particle.
6956  ptlrat=1./sinh(paru(51))**2
6957  np=0
6958  nc=n
6959  DO 110 i=1,n
6960  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
6961  IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) goto 110
6962  IF(mstu(41).GE.2) THEN
6963  kc=lucomp(k(i,2))
6964  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
6965  & kc.EQ.18) goto 110
6966  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
6967  & goto 110
6968  ENDIF
6969  np=np+1
6970  pt=sqrt(p(i,1)**2+p(i,2)**2)
6971  eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
6972  ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5*(eta/paru(51)+1.))))
6973  phi=ulangl(p(i,1),p(i,2))
6974  iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5*(phi/paru(1)+1.))))
6975  ietph=mstu(52)*ieta+iphi
6976 
6977 C...Add to cell already hit, or book new cell.
6978  DO 100 ic=n+1,nc
6979  IF(ietph.EQ.k(ic,3)) THEN
6980  k(ic,4)=k(ic,4)+1
6981  p(ic,5)=p(ic,5)+pt
6982  goto 110
6983  ENDIF
6984  100 CONTINUE
6985  IF(nc.GE.mstu(4)-mstu(32)-5) THEN
6986  CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
6987  njet=-2
6988  RETURN
6989  ENDIF
6990  nc=nc+1
6991  k(nc,3)=ietph
6992  k(nc,4)=1
6993  k(nc,5)=2
6994  p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
6995  p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
6996  p(nc,5)=pt
6997  110 CONTINUE
6998 
6999 C...Smear true bin content by calorimeter resolution.
7000  IF(mstu(53).GE.1) THEN
7001  DO 130 ic=n+1,nc
7002  pei=p(ic,5)
7003  IF(mstu(53).EQ.2) pei=p(ic,5)*cosh(p(ic,1))
7004  120 pef=pei+paru(55)*sqrt(-2.*log(max(1e-10,rlu(0)))*pei)*
7005  & cos(paru(2)*rlu(0))
7006  IF(pef.LT.0..OR.pef.GT.paru(56)*pei) goto 120
7007  p(ic,5)=pef
7008  IF(mstu(53).EQ.2) p(ic,5)=pef/cosh(p(ic,1))
7009  130 CONTINUE
7010  ENDIF
7011 
7012 C...Remove cells below threshold.
7013  IF(paru(58).GT.0.) THEN
7014  ncc=nc
7015  nc=n
7016  DO 140 ic=n+1,ncc
7017  IF(p(ic,5).GT.paru(58)) THEN
7018  nc=nc+1
7019  k(nc,3)=k(ic,3)
7020  k(nc,4)=k(ic,4)
7021  k(nc,5)=k(ic,5)
7022  p(nc,1)=p(ic,1)
7023  p(nc,2)=p(ic,2)
7024  p(nc,5)=p(ic,5)
7025  ENDIF
7026  140 CONTINUE
7027  ENDIF
7028 
7029 C...Find initiator cell: the one with highest pT of not yet used ones.
7030  nj=nc
7031  150 etmax=0.
7032  DO 160 ic=n+1,nc
7033  IF(k(ic,5).NE.2) goto 160
7034  IF(p(ic,5).LE.etmax) goto 160
7035  icmax=ic
7036  eta=p(ic,1)
7037  phi=p(ic,2)
7038  etmax=p(ic,5)
7039  160 CONTINUE
7040  IF(etmax.LT.paru(52)) goto 220
7041  IF(nj.GE.mstu(4)-mstu(32)-5) THEN
7042  CALL luerrm(11,'(LUCELL:) no more memory left in LUJETS')
7043  njet=-2
7044  RETURN
7045  ENDIF
7046  k(icmax,5)=1
7047  nj=nj+1
7048  k(nj,4)=0
7049  k(nj,5)=1
7050  p(nj,1)=eta
7051  p(nj,2)=phi
7052  p(nj,3)=0.
7053  p(nj,4)=0.
7054  p(nj,5)=0.
7055 
7056 C...Sum up unused cells within required distance of initiator.
7057  DO 170 ic=n+1,nc
7058  IF(k(ic,5).EQ.0) goto 170
7059  IF(abs(p(ic,1)-eta).GT.paru(54)) goto 170
7060  dphia=abs(p(ic,2)-phi)
7061  IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) goto 170
7062  phic=p(ic,2)
7063  IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
7064  IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) goto 170
7065  k(ic,5)=-k(ic,5)
7066  k(nj,4)=k(nj,4)+k(ic,4)
7067  p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
7068  p(nj,4)=p(nj,4)+p(ic,5)*phic
7069  p(nj,5)=p(nj,5)+p(ic,5)
7070  170 CONTINUE
7071 
7072 C...Reject cluster below minimum ET, else accept.
7073  IF(p(nj,5).LT.paru(53)) THEN
7074  nj=nj-1
7075  DO 180 ic=n+1,nc
7076  IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
7077  180 CONTINUE
7078  ELSEIF(mstu(54).LE.2) THEN
7079  p(nj,3)=p(nj,3)/p(nj,5)
7080  p(nj,4)=p(nj,4)/p(nj,5)
7081  IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
7082  & p(nj,4))
7083  DO 190 ic=n+1,nc
7084  IF(k(ic,5).LT.0) k(ic,5)=0
7085  190 CONTINUE
7086  ELSE
7087  DO 200 j=1,4
7088  p(nj,j)=0.
7089  200 CONTINUE
7090  DO 210 ic=n+1,nc
7091  IF(k(ic,5).GE.0) goto 210
7092  p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
7093  p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
7094  p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
7095  p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
7096  k(ic,5)=0
7097  210 CONTINUE
7098  ENDIF
7099  goto 150
7100 
7101 C...Arrange clusters in falling ET sequence.
7102  220 DO 250 i=1,nj-nc
7103  etmax=0.
7104  DO 230 ij=nc+1,nj
7105  IF(k(ij,5).EQ.0) goto 230
7106  IF(p(ij,5).LT.etmax) goto 230
7107  ijmax=ij
7108  etmax=p(ij,5)
7109  230 CONTINUE
7110  k(ijmax,5)=0
7111  k(n+i,1)=31
7112  k(n+i,2)=98
7113  k(n+i,3)=i
7114  k(n+i,4)=k(ijmax,4)
7115  k(n+i,5)=0
7116  DO 240 j=1,5
7117  p(n+i,j)=p(ijmax,j)
7118  v(n+i,j)=0.
7119  240 CONTINUE
7120  250 CONTINUE
7121  njet=nj-nc
7122 
7123 C...Convert to massless or massive four-vectors.
7124  IF(mstu(54).EQ.2) THEN
7125  DO 260 i=n+1,n+njet
7126  eta=p(i,3)
7127  p(i,1)=p(i,5)*cos(p(i,4))
7128  p(i,2)=p(i,5)*sin(p(i,4))
7129  p(i,3)=p(i,5)*sinh(eta)
7130  p(i,4)=p(i,5)*cosh(eta)
7131  p(i,5)=0.
7132  260 CONTINUE
7133  ELSEIF(mstu(54).GE.3) THEN
7134  DO 270 i=n+1,n+njet
7135  p(i,5)=sqrt(max(0.,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
7136  270 CONTINUE
7137  ENDIF
7138 
7139 C...Information about storage.
7140  mstu(61)=n+1
7141  mstu(62)=np
7142  mstu(63)=nc-n
7143  IF(mstu(43).LE.1) mstu(3)=njet
7144  IF(mstu(43).GE.2) n=n+njet
7145 
7146  RETURN
7147  END
7148 
7149 C*********************************************************************
7150 
7151  SUBROUTINE lujmas(PMH,PML)
7152 
7153 C...Purpose: to determine, approximately, the two jet masses that
7154 C...minimize the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
7155  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7156  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7157  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7158  SAVE /lujets/,/ludat1/,/ludat2/
7159  dimension sm(3,3),sax(3),ps(3,5)
7160 
7161 C...Reset.
7162  np=0
7163  DO 120 j1=1,3
7164  DO 100 j2=j1,3
7165  sm(j1,j2)=0.
7166  100 CONTINUE
7167  DO 110 j2=1,4
7168  ps(j1,j2)=0.
7169  110 CONTINUE
7170  120 CONTINUE
7171  pss=0.
7172 
7173 C...Take copy of particles that are to be considered in mass analysis.
7174  DO 170 i=1,n
7175  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 170
7176  IF(mstu(41).GE.2) THEN
7177  kc=lucomp(k(i,2))
7178  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7179  & kc.EQ.18) goto 170
7180  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7181  & goto 170
7182  ENDIF
7183  IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
7184  CALL luerrm(11,'(LUJMAS:) no more memory left in LUJETS')
7185  pmh=-2.
7186  pml=-2.
7187  RETURN
7188  ENDIF
7189  np=np+1
7190  DO 130 j=1,5
7191  p(n+np,j)=p(i,j)
7192  130 CONTINUE
7193  IF(mstu(42).EQ.0) p(n+np,5)=0.
7194  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pmas(101,1)
7195  p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
7196 
7197 C...Fill information in sphericity tensor and total momentum vector.
7198  DO 150 j1=1,3
7199  DO 140 j2=j1,3
7200  sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
7201  140 CONTINUE
7202  150 CONTINUE
7203  pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7204  DO 160 j=1,4
7205  ps(3,j)=ps(3,j)+p(n+np,j)
7206  160 CONTINUE
7207  170 CONTINUE
7208 
7209 C...Very low multiplicities (0 or 1) not considered.
7210  IF(np.LE.1) THEN
7211  CALL luerrm(8,'(LUJMAS:) too few particles for analysis')
7212  pmh=-1.
7213  pml=-1.
7214  RETURN
7215  ENDIF
7216  paru(61)=sqrt(max(0.,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-ps(3,3)**2))
7217 
7218 C...Find largest eigenvalue to matrix (third degree equation).
7219  DO 190 j1=1,3
7220  DO 180 j2=j1,3
7221  sm(j1,j2)=sm(j1,j2)/pss
7222  180 CONTINUE
7223  190 CONTINUE
7224  sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-sm(1,2)**2-
7225  &sm(1,3)**2-sm(2,3)**2)/3.-1./9.
7226  sr=-0.5*(sq+1./9.+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+sm(3,3)*
7227  &sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+sm(1,2)*sm(1,3)*sm(2,3)+1./27.
7228  sp=cos(acos(max(min(sr/sqrt(-sq**3),1.),-1.))/3.)
7229  sma=1./3.+sqrt(-sq)*max(2.*sp,sqrt(3.*(1.-sp**2))-sp)
7230 
7231 C...Find largest eigenvector by solving equation system.
7232  DO 210 j1=1,3
7233  sm(j1,j1)=sm(j1,j1)-sma
7234  DO 200 j2=j1+1,3
7235  sm(j2,j1)=sm(j1,j2)
7236  200 CONTINUE
7237  210 CONTINUE
7238  smax=0.
7239  DO 230 j1=1,3
7240  DO 220 j2=1,3
7241  IF(abs(sm(j1,j2)).LE.smax) goto 220
7242  ja=j1
7243  jb=j2
7244  smax=abs(sm(j1,j2))
7245  220 CONTINUE
7246  230 CONTINUE
7247  smax=0.
7248  DO 250 j3=ja+1,ja+2
7249  j1=j3-3*((j3-1)/3)
7250  rl=sm(j1,jb)/sm(ja,jb)
7251  DO 240 j2=1,3
7252  sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
7253  IF(abs(sm(j1,j2)).LE.smax) goto 240
7254  jc=j1
7255  smax=abs(sm(j1,j2))
7256  240 CONTINUE
7257  250 CONTINUE
7258  jb1=jb+1-3*(jb/3)
7259  jb2=jb+2-3*((jb+1)/3)
7260  sax(jb1)=-sm(jc,jb2)
7261  sax(jb2)=sm(jc,jb1)
7262  sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
7263 
7264 C...Divide particles into two initial clusters by hemisphere.
7265  DO 270 i=n+1,n+np
7266  psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
7267  is=1
7268  IF(psax.LT.0.) is=2
7269  k(i,3)=is
7270  DO 260 j=1,4
7271  ps(is,j)=ps(is,j)+p(i,j)
7272  260 CONTINUE
7273  270 CONTINUE
7274  pms=max(1e-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
7275  &max(1e-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
7276 
7277 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
7278  280 pmd=0.
7279  im=0
7280  DO 290 j=1,4
7281  ps(3,j)=ps(1,j)-ps(2,j)
7282  290 CONTINUE
7283  DO 300 i=n+1,n+np
7284  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)
7285  IF(k(i,3).EQ.1) pmdi=2.*(p(i,5)**2-pps)
7286  IF(k(i,3).EQ.2) pmdi=2.*(p(i,5)**2+pps)
7287  IF(pmdi.LT.pmd) THEN
7288  pmd=pmdi
7289  im=i
7290  ENDIF
7291  300 CONTINUE
7292 
7293 C...Loop back if significant reduction in sum of m^2.
7294  IF(pmd.LT.-paru(48)*pms) THEN
7295  pms=pms+pmd
7296  is=k(im,3)
7297  DO 310 j=1,4
7298  ps(is,j)=ps(is,j)-p(im,j)
7299  ps(3-is,j)=ps(3-is,j)+p(im,j)
7300  310 CONTINUE
7301  k(im,3)=3-is
7302  goto 280
7303  ENDIF
7304 
7305 C...Final masses and output.
7306  mstu(61)=n+1
7307  mstu(62)=np
7308  ps(1,5)=sqrt(max(0.,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
7309  ps(2,5)=sqrt(max(0.,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
7310  pmh=max(ps(1,5),ps(2,5))
7311  pml=min(ps(1,5),ps(2,5))
7312 
7313  RETURN
7314  END
7315 
7316 C*********************************************************************
7317 
7318  SUBROUTINE lufowo(H10,H20,H30,H40)
7319 
7320 C...Purpose: to calculate the first few Fox-Wolfram moments.
7321  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7322  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7323  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7324  SAVE /lujets/,/ludat1/,/ludat2/
7325 
7326 C...Copy momenta for particles and calculate H0.
7327  np=0
7328  h0=0.
7329  hd=0.
7330  DO 110 i=1,n
7331  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110
7332  IF(mstu(41).GE.2) THEN
7333  kc=lucomp(k(i,2))
7334  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7335  & kc.EQ.18) goto 110
7336  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7337  & goto 110
7338  ENDIF
7339  IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
7340  CALL luerrm(11,'(LUFOWO:) no more memory left in LUJETS')
7341  h10=-1.
7342  h20=-1.
7343  h30=-1.
7344  h40=-1.
7345  RETURN
7346  ENDIF
7347  np=np+1
7348  DO 100 j=1,3
7349  p(n+np,j)=p(i,j)
7350  100 CONTINUE
7351  p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
7352  h0=h0+p(n+np,4)
7353  hd=hd+p(n+np,4)**2
7354  110 CONTINUE
7355  h0=h0**2
7356 
7357 C...Very low multiplicities (0 or 1) not considered.
7358  IF(np.LE.1) THEN
7359  CALL luerrm(8,'(LUFOWO:) too few particles for analysis')
7360  h10=-1.
7361  h20=-1.
7362  h30=-1.
7363  h40=-1.
7364  RETURN
7365  ENDIF
7366 
7367 C...Calculate H1 - H4.
7368  h10=0.
7369  h20=0.
7370  h30=0.
7371  h40=0.
7372  DO 130 i1=n+1,n+np
7373  DO 120 i2=i1+1,n+np
7374  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
7375  &(p(i1,4)*p(i2,4))
7376  h10=h10+p(i1,4)*p(i2,4)*cthe
7377  h20=h20+p(i1,4)*p(i2,4)*(1.5*cthe**2-0.5)
7378  h30=h30+p(i1,4)*p(i2,4)*(2.5*cthe**3-1.5*cthe)
7379  h40=h40+p(i1,4)*p(i2,4)*(4.375*cthe**4-3.75*cthe**2+0.375)
7380  120 CONTINUE
7381  130 CONTINUE
7382 
7383 C...Calculate H1/H0 - H4/H0. Output.
7384  mstu(61)=n+1
7385  mstu(62)=np
7386  h10=(hd+2.*h10)/h0
7387  h20=(hd+2.*h20)/h0
7388  h30=(hd+2.*h30)/h0
7389  h40=(hd+2.*h40)/h0
7390 
7391  RETURN
7392  END
7393 
7394 C*********************************************************************
7395 
7396  SUBROUTINE lutabu(MTABU)
7397 
7398 C...Purpose: to evaluate various properties of an event, with
7399 C...statistics accumulated during the course of the run and
7400 C...printed at the end.
7401  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
7402  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
7403  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
7404  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
7405  SAVE /lujets/,/ludat1/,/ludat2/,/ludat3/
7406  dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
7407  &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
7408  &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
7409  &kfdm(8),kfdc(200,0:8),npdc(200)
7410  SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
7411  &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
7412  &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
7413  CHARACTER chau*16,chis(2)*12,chdc(8)*12
7414  DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,
7415  &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0./,fm2fm/120*0./,
7416  &nevee/0/,fe1ec/50*0./,fe2ec/50*0./,fe1ea/25*0./,fe2ea/25*0./,
7417  &nevdc/0/,nkfdc/0/,nredc/0/
7418 
7419 C...Reset statistics on initial parton state.
7420  IF(mtabu.EQ.10) THEN
7421  nevis=0
7422  nkfis=0
7423 
7424 C...Identify and order flavour content of initial state.
7425  ELSEIF(mtabu.EQ.11) THEN
7426  nevis=nevis+1
7427  kfm1=2*iabs(mstu(161))
7428  IF(mstu(161).GT.0) kfm1=kfm1-1
7429  kfm2=2*iabs(mstu(162))
7430  IF(mstu(162).GT.0) kfm2=kfm2-1
7431  kfmn=min(kfm1,kfm2)
7432  kfmx=max(kfm1,kfm2)
7433  DO 100 i=1,nkfis
7434  IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
7435  ikfis=-i
7436  goto 110
7437  ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
7438  & kfmx.LT.kfis(i,2))) THEN
7439  ikfis=i
7440  goto 110
7441  ENDIF
7442  100 CONTINUE
7443  ikfis=nkfis+1
7444  110 IF(ikfis.LT.0) THEN
7445  ikfis=-ikfis
7446  ELSE
7447  IF(nkfis.GE.100) RETURN
7448  DO 130 i=nkfis,ikfis,-1
7449  kfis(i+1,1)=kfis(i,1)
7450  kfis(i+1,2)=kfis(i,2)
7451  DO 120 j=0,10
7452  npis(i+1,j)=npis(i,j)
7453  120 CONTINUE
7454  130 CONTINUE
7455  nkfis=nkfis+1
7456  kfis(ikfis,1)=kfmn
7457  kfis(ikfis,2)=kfmx
7458  DO 140 j=0,10
7459  npis(ikfis,j)=0
7460  140 CONTINUE
7461  ENDIF
7462  npis(ikfis,0)=npis(ikfis,0)+1
7463 
7464 C...Count number of partons in initial state.
7465  np=0
7466  DO 160 i=1,n
7467  IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
7468  ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
7469  ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
7470  & THEN
7471  ELSE
7472  im=i
7473  150 im=k(im,3)
7474  IF(im.LE.0.OR.im.GT.n) THEN
7475  np=np+1
7476  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
7477  np=np+1
7478  ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
7479  ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10).NE.0)
7480  & THEN
7481  ELSE
7482  goto 150
7483  ENDIF
7484  ENDIF
7485  160 CONTINUE
7486  npco=max(np,1)
7487  IF(np.GE.6) npco=6
7488  IF(np.GE.8) npco=7
7489  IF(np.GE.11) npco=8
7490  IF(np.GE.16) npco=9
7491  IF(np.GE.26) npco=10
7492  npis(ikfis,npco)=npis(ikfis,npco)+1
7493  mstu(62)=np
7494 
7495 C...Write statistics on initial parton state.
7496  ELSEIF(mtabu.EQ.12) THEN
7497  fac=1./max(1,nevis)
7498  WRITE(mstu(11),5000) nevis
7499  DO 170 i=1,nkfis
7500  kfmn=kfis(i,1)
7501  IF(kfmn.EQ.0) kfmn=kfis(i,2)
7502  kfm1=(kfmn+1)/2
7503  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
7504  CALL luname(kfm1,chau)
7505  chis(1)=chau(1:12)
7506  IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
7507  kfmx=kfis(i,2)
7508  IF(kfis(i,1).EQ.0) kfmx=0
7509  kfm2=(kfmx+1)/2
7510  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
7511  CALL luname(kfm2,chau)
7512  chis(2)=chau(1:12)
7513  IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
7514  WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),
7515  & (npis(i,j)/float(npis(i,0)),j=1,10)
7516  170 CONTINUE
7517 
7518 C...Copy statistics on initial parton state into /LUJETS/.
7519  ELSEIF(mtabu.EQ.13) THEN
7520  fac=1./max(1,nevis)
7521  DO 190 i=1,nkfis
7522  kfmn=kfis(i,1)
7523  IF(kfmn.EQ.0) kfmn=kfis(i,2)
7524  kfm1=(kfmn+1)/2
7525  IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
7526  kfmx=kfis(i,2)
7527  IF(kfis(i,1).EQ.0) kfmx=0
7528  kfm2=(kfmx+1)/2
7529  IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
7530  k(i,1)=32
7531  k(i,2)=99
7532  k(i,3)=kfm1
7533  k(i,4)=kfm2
7534  k(i,5)=npis(i,0)
7535  DO 180 j=1,5
7536  p(i,j)=fac*npis(i,j)
7537  v(i,j)=fac*npis(i,j+5)
7538  180 CONTINUE
7539  190 CONTINUE
7540  n=nkfis
7541  DO 200 j=1,5
7542  k(n+1,j)=0
7543  p(n+1,j)=0.
7544  v(n+1,j)=0.
7545  200 CONTINUE
7546  k(n+1,1)=32
7547  k(n+1,2)=99
7548  k(n+1,5)=nevis
7549  mstu(3)=1
7550 
7551 C...Reset statistics on number of particles/partons.
7552  ELSEIF(mtabu.EQ.20) THEN
7553  nevfs=0
7554  nprfs=0
7555  nfifs=0
7556  nchfs=0
7557  nkffs=0
7558 
7559 C...Identify whether particle/parton is primary or not.
7560  ELSEIF(mtabu.EQ.21) THEN
7561  nevfs=nevfs+1
7562  mstu(62)=0
7563  DO 260 i=1,n
7564  IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) goto 260
7565  mstu(62)=mstu(62)+1
7566  kc=lucomp(k(i,2))
7567  mpri=0
7568  IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
7569  mpri=1
7570  ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
7571  mpri=1
7572  ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN
7573  mpri=1
7574  ELSEIF(kc.EQ.0) THEN
7575  ELSEIF(k(k(i,3),1).EQ.13) THEN
7576  im=k(k(i,3),3)
7577  IF(im.LE.0.OR.im.GT.n) THEN
7578  mpri=1
7579  ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
7580  mpri=1
7581  ENDIF
7582  ELSEIF(kchg(kc,2).EQ.0) THEN
7583  kcm=lucomp(k(k(i,3),2))
7584  IF(kcm.NE.0) THEN
7585  IF(kchg(kcm,2).NE.0) mpri=1
7586  ENDIF
7587  ENDIF
7588  IF(kc.NE.0.AND.mpri.EQ.1) THEN
7589  IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
7590  ENDIF
7591  IF(k(i,1).LE.10) THEN
7592  nfifs=nfifs+1
7593  IF(luchge(k(i,2)).NE.0) nchfs=nchfs+1
7594  ENDIF
7595 
7596 C...Fill statistics on number of particles/partons in event.
7597  kfa=iabs(k(i,2))
7598  kfs=3-isign(1,k(i,2))-mpri
7599  DO 210 ip=1,nkffs
7600  IF(kfa.EQ.kffs(ip)) THEN
7601  ikffs=-ip
7602  goto 220
7603  ELSEIF(kfa.LT.kffs(ip)) THEN
7604  ikffs=ip
7605  goto 220
7606  ENDIF
7607  210 CONTINUE
7608  ikffs=nkffs+1
7609  220 IF(ikffs.LT.0) THEN
7610  ikffs=-ikffs
7611  ELSE
7612  IF(nkffs.GE.400) RETURN
7613  DO 240 ip=nkffs,ikffs,-1
7614  kffs(ip+1)=kffs(ip)
7615  DO 230 j=1,4
7616  npfs(ip+1,j)=npfs(ip,j)
7617  230 CONTINUE
7618  240 CONTINUE
7619  nkffs=nkffs+1
7620  kffs(ikffs)=kfa
7621  DO 250 j=1,4
7622  npfs(ikffs,j)=0
7623  250 CONTINUE
7624  ENDIF
7625  npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
7626  260 CONTINUE
7627 
7628 C...Write statistics on particle/parton composition of events.
7629  ELSEIF(mtabu.EQ.22) THEN
7630  fac=1./max(1,nevfs)
7631  WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
7632  DO 270 i=1,nkffs
7633  CALL luname(kffs(i),chau)
7634  kc=lucomp(kffs(i))
7635  mdcyf=0
7636  IF(kc.NE.0) mdcyf=mdcy(kc,1)
7637  WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
7638  & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
7639  270 CONTINUE
7640 
7641 C...Copy particle/parton composition information into /LUJETS/.
7642  ELSEIF(mtabu.EQ.23) THEN
7643  fac=1./max(1,nevfs)
7644  DO 290 i=1,nkffs
7645  k(i,1)=32
7646  k(i,2)=99
7647  k(i,3)=kffs(i)
7648  k(i,4)=0
7649  k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
7650  DO 280 j=1,4
7651  p(i,j)=fac*npfs(i,j)
7652  v(i,j)=0.
7653  280 CONTINUE
7654  p(i,5)=fac*k(i,5)
7655  v(i,5)=0.
7656  290 CONTINUE
7657  n=nkffs
7658  DO 300 j=1,5
7659  k(n+1,j)=0
7660  p(n+1,j)=0.
7661  v(n+1,j)=0.
7662  300 CONTINUE
7663  k(n+1,1)=32
7664  k(n+1,2)=99
7665  k(n+1,5)=nevfs
7666  p(n+1,1)=fac*nprfs
7667  p(n+1,2)=fac*nfifs
7668  p(n+1,3)=fac*nchfs
7669  mstu(3)=1
7670 
7671 C...Reset factorial moments statistics.
7672  ELSEIF(mtabu.EQ.30) THEN
7673  nevfm=0
7674  nmufm=0
7675  DO 330 im=1,3
7676  DO 320 ib=1,10
7677  DO 310 ip=1,4
7678  fm1fm(im,ib,ip)=0.
7679  fm2fm(im,ib,ip)=0.
7680  310 CONTINUE
7681  320 CONTINUE
7682  330 CONTINUE
7683 
7684 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
7685  ELSEIF(mtabu.EQ.31) THEN
7686  nevfm=nevfm+1
7687  nlow=n+mstu(3)
7688  nupp=nlow
7689  DO 410 i=1,n
7690  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 410
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 410
7695  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7696  & goto 410
7697  ENDIF
7698  pmr=0.
7699  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
7700  IF(mstu(42).GE.2) pmr=p(i,5)
7701  pr=max(1e-20,pmr**2+p(i,1)**2+p(i,2)**2)
7702  yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
7703  & 1e20)),p(i,3))
7704  IF(abs(yeta).GT.paru(57)) goto 410
7705  phi=ulangl(p(i,1),p(i,2))
7706  iyeta=512.*(yeta+paru(57))/(2.*paru(57))
7707  iyeta=max(0,min(511,iyeta))
7708  iphi=512.*(phi+paru(1))/paru(2)
7709  iphi=max(0,min(511,iphi))
7710  iyep=0
7711  DO 340 ib=0,9
7712  iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
7713  340 CONTINUE
7714 
7715 C...Order particles in (pseudo)rapidity and/or azimuth.
7716  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
7717  CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
7718  RETURN
7719  ENDIF
7720  nupp=nupp+1
7721  IF(nupp.EQ.nlow+1) THEN
7722  k(nupp,1)=iyeta
7723  k(nupp,2)=iphi
7724  k(nupp,3)=iyep
7725  ELSE
7726  DO 350 i1=nupp-1,nlow+1,-1
7727  IF(iyeta.GE.k(i1,1)) goto 360
7728  k(i1+1,1)=k(i1,1)
7729  350 CONTINUE
7730  360 k(i1+1,1)=iyeta
7731  DO 370 i1=nupp-1,nlow+1,-1
7732  IF(iphi.GE.k(i1,2)) goto 380
7733  k(i1+1,2)=k(i1,2)
7734  370 CONTINUE
7735  380 k(i1+1,2)=iphi
7736  DO 390 i1=nupp-1,nlow+1,-1
7737  IF(iyep.GE.k(i1,3)) goto 400
7738  k(i1+1,3)=k(i1,3)
7739  390 CONTINUE
7740  400 k(i1+1,3)=iyep
7741  ENDIF
7742  410 CONTINUE
7743  k(nupp+1,1)=2**10
7744  k(nupp+1,2)=2**10
7745  k(nupp+1,3)=4**10
7746 
7747 C...Calculate sum of factorial moments in event.
7748  DO 480 im=1,3
7749  DO 430 ib=1,10
7750  DO 420 ip=1,4
7751  fevfm(ib,ip)=0.
7752  420 CONTINUE
7753  430 CONTINUE
7754  DO 450 ib=1,10
7755  IF(im.LE.2) ibin=2**(10-ib)
7756  IF(im.EQ.3) ibin=4**(10-ib)
7757  iagr=k(nlow+1,im)/ibin
7758  nagr=1
7759  DO 440 i=nlow+2,nupp+1
7760  icut=k(i,im)/ibin
7761  IF(icut.EQ.iagr) THEN
7762  nagr=nagr+1
7763  ELSE
7764  IF(nagr.EQ.1) THEN
7765  ELSEIF(nagr.EQ.2) THEN
7766  fevfm(ib,1)=fevfm(ib,1)+2.
7767  ELSEIF(nagr.EQ.3) THEN
7768  fevfm(ib,1)=fevfm(ib,1)+6.
7769  fevfm(ib,2)=fevfm(ib,2)+6.
7770  ELSEIF(nagr.EQ.4) THEN
7771  fevfm(ib,1)=fevfm(ib,1)+12.
7772  fevfm(ib,2)=fevfm(ib,2)+24.
7773  fevfm(ib,3)=fevfm(ib,3)+24.
7774  ELSE
7775  fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1.)
7776  fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1.)*(nagr-2.)
7777  fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)
7778  fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1.)*(nagr-2.)*(nagr-3.)*
7779  & (nagr-4.)
7780  ENDIF
7781  iagr=icut
7782  nagr=1
7783  ENDIF
7784  440 CONTINUE
7785  450 CONTINUE
7786 
7787 C...Add results to total statistics.
7788  DO 470 ib=10,1,-1
7789  DO 460 ip=1,4
7790  IF(fevfm(1,ip).LT.0.5) THEN
7791  fevfm(ib,ip)=0.
7792  ELSEIF(im.LE.2) THEN
7793  fevfm(ib,ip)=2.**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
7794  ELSE
7795  fevfm(ib,ip)=4.**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
7796  ENDIF
7797  fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
7798  fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
7799  460 CONTINUE
7800  470 CONTINUE
7801  480 CONTINUE
7802  nmufm=nmufm+(nupp-nlow)
7803  mstu(62)=nupp-nlow
7804 
7805 C...Write accumulated statistics on factorial moments.
7806  ELSEIF(mtabu.EQ.32) THEN
7807  fac=1./max(1,nevfm)
7808  IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'
7809  IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'
7810  IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y '
7811  DO 510 im=1,3
7812  WRITE(mstu(11),5500)
7813  DO 500 ib=1,10
7814  byeta=2.*paru(57)
7815  IF(im.NE.2) byeta=byeta/2**(ib-1)
7816  bphi=paru(2)
7817  IF(im.NE.1) bphi=bphi/2**(ib-1)
7818  IF(im.LE.2) bnave=fac*nmufm/float(2**(ib-1))
7819  IF(im.EQ.3) bnave=fac*nmufm/float(4**(ib-1))
7820  DO 490 ip=1,4
7821  fmoma(ip)=fac*fm1fm(im,ib,ip)
7822  fmoms(ip)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-fmoma(ip)**2)))
7823  490 CONTINUE
7824  WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
7825  & ip=1,4)
7826  500 CONTINUE
7827  510 CONTINUE
7828 
7829 C...Copy statistics on factorial moments into /LUJETS/.
7830  ELSEIF(mtabu.EQ.33) THEN
7831  fac=1./max(1,nevfm)
7832  DO 540 im=1,3
7833  DO 530 ib=1,10
7834  i=10*(im-1)+ib
7835  k(i,1)=32
7836  k(i,2)=99
7837  k(i,3)=1
7838  IF(im.NE.2) k(i,3)=2**(ib-1)
7839  k(i,4)=1
7840  IF(im.NE.1) k(i,4)=2**(ib-1)
7841  k(i,5)=0
7842  p(i,1)=2.*paru(57)/k(i,3)
7843  v(i,1)=paru(2)/k(i,4)
7844  DO 520 ip=1,4
7845  p(i,ip+1)=fac*fm1fm(im,ib,ip)
7846  v(i,ip+1)=sqrt(max(0.,fac*(fac*fm2fm(im,ib,ip)-p(i,ip+1)**2)))
7847  520 CONTINUE
7848  530 CONTINUE
7849  540 CONTINUE
7850  n=30
7851  DO 550 j=1,5
7852  k(n+1,j)=0
7853  p(n+1,j)=0.
7854  v(n+1,j)=0.
7855  550 CONTINUE
7856  k(n+1,1)=32
7857  k(n+1,2)=99
7858  k(n+1,5)=nevfm
7859  mstu(3)=1
7860 
7861 C...Reset statistics on Energy-Energy Correlation.
7862  ELSEIF(mtabu.EQ.40) THEN
7863  nevee=0
7864  DO 560 j=1,25
7865  fe1ec(j)=0.
7866  fe2ec(j)=0.
7867  fe1ec(51-j)=0.
7868  fe2ec(51-j)=0.
7869  fe1ea(j)=0.
7870  fe2ea(j)=0.
7871  560 CONTINUE
7872 
7873 C...Find particles to include, with proper assumed mass.
7874  ELSEIF(mtabu.EQ.41) THEN
7875  nevee=nevee+1
7876  nlow=n+mstu(3)
7877  nupp=nlow
7878  ecm=0.
7879  DO 570 i=1,n
7880  IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 570
7881  IF(mstu(41).GE.2) THEN
7882  kc=lucomp(k(i,2))
7883  IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
7884  & kc.EQ.18) goto 570
7885  IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.luchge(k(i,2)).EQ.0)
7886  & goto 570
7887  ENDIF
7888  pmr=0.
7889  IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=ulmass(211)
7890  IF(mstu(42).GE.2) pmr=p(i,5)
7891  IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
7892  CALL luerrm(11,'(LUTABU:) no more memory left in LUJETS')
7893  RETURN
7894  ENDIF
7895  nupp=nupp+1
7896  p(nupp,1)=p(i,1)
7897  p(nupp,2)=p(i,2)
7898  p(nupp,3)=p(i,3)
7899  p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
7900  p(nupp,5)=max(1e-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
7901  ecm=ecm+p(nupp,4)
7902  570 CONTINUE
7903  IF(nupp.EQ.nlow) RETURN
7904 
7905 C...Analyze Energy-Energy Correlation in event.
7906  fac=(2./ecm**2)*50./paru(1)
7907  DO 580 j=1,50
7908  fevee(j)=0.
7909  580 CONTINUE
7910  DO 600 i1=nlow+2,nupp
7911  DO 590 i2=nlow+1,i1-1
7912  cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
7913  & (p(i1,5)*p(i2,5))
7914  the=acos(max(-1.,min(1.,cthe)))
7915  ithe=max(1,min(50,1+int(50.*the/paru(1))))
7916  fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
7917  590 CONTINUE
7918  600 CONTINUE
7919  DO 610 j=1,25
7920  fe1ec(j)=fe1ec(j)+fevee(j)
7921  fe2ec(j)=fe2ec(j)+fevee(j)**2
7922  fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
7923  fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
7924  fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
7925  fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
7926  610 CONTINUE
7927  mstu(62)=nupp-nlow
7928 
7929 C...Write statistics on Energy-Energy Correlation.
7930  ELSEIF(mtabu.EQ.42) THEN
7931  fac=1./max(1,nevee)
7932  WRITE(mstu(11),5700) nevee
7933  DO 620 j=1,25
7934  feec1=fac*fe1ec(j)
7935  fees1=sqrt(max(0.,fac*(fac*fe2ec(j)-feec1**2)))
7936  feec2=fac*fe1ec(51-j)
7937  fees2=sqrt(max(0.,fac*(fac*fe2ec(51-j)-feec2**2)))
7938  feeca=fac*fe1ea(j)
7939  feesa=sqrt(max(0.,fac*(fac*fe2ea(j)-feeca**2)))
7940  WRITE(mstu(11),5800) 3.6*(j-1),3.6*j,feec1,fees1,feec2,fees2,
7941  & feeca,feesa
7942  620 CONTINUE
7943 
7944 C...Copy statistics on Energy-Energy Correlation into /LUJETS/.
7945  ELSEIF(mtabu.EQ.43) THEN
7946  fac=1./max(1,nevee)
7947  DO 630 i=1,25
7948  k(i,1)=32
7949  k(i,2)=99
7950  k(i,3)=0
7951  k(i,4)=0
7952  k(i,5)=0
7953  p(i,1)=fac*fe1ec(i)
7954  v(i,1)=sqrt(max(0.,fac*(fac*fe2ec(i)-p(i,1)**2)))
7955  p(i,2)=fac*fe1ec(51-i)
7956  v(i,2)=sqrt(max(0.,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
7957  p(i,3)=fac*fe1ea(i)
7958  v(i,3)=sqrt(max(0.,fac*(fac*fe2ea(i)-p(i,3)**2)))
7959  p(i,4)=paru(1)*(i-1)/50.
7960  p(i,5)=paru(1)*i/50.
7961  v(i,4)=3.6*(i-1)
7962  v(i,5)=3.6*i
7963  630 CONTINUE
7964  n=25
7965  DO 640 j=1,5
7966  k(n+1,j)=0
7967  p(n+1,j)=0.
7968  v(n+1,j)=0.
7969  640 CONTINUE
7970  k(n+1,1)=32
7971  k(n+1,2)=99
7972  k(n+1,5)=nevee
7973  mstu(3)=1
7974 
7975 C...Reset statistics on decay channels.
7976  ELSEIF(mtabu.EQ.50) THEN
7977  nevdc=0
7978  nkfdc=0
7979  nredc=0
7980 
7981 C...Identify and order flavour content of final state.
7982  ELSEIF(mtabu.EQ.51) THEN
7983  nevdc=nevdc+1
7984  nds=0
7985  DO 670 i=1,n
7986  IF(k(i,1).LE.0.OR.k(i,1).GE.6) goto 670
7987  nds=nds+1
7988  IF(nds.GT.8) THEN
7989  nredc=nredc+1
7990  RETURN
7991  ENDIF
7992  kfm=2*iabs(k(i,2))
7993  IF(k(i,2).LT.0) kfm=kfm-1
7994  DO 650 ids=nds-1,1,-1
7995  iin=ids+1
7996  IF(kfm.LT.kfdm(ids)) goto 660
7997  kfdm(ids+1)=kfdm(ids)
7998  650 CONTINUE
7999  iin=1
8000  660 kfdm(iin)=kfm
8001  670 CONTINUE
8002 
8003 C...Find whether old or new final state.
8004  DO 690 idc=1,nkfdc
8005  IF(nds.LT.kfdc(idc,0)) THEN
8006  ikfdc=idc
8007  goto 700
8008  ELSEIF(nds.EQ.kfdc(idc,0)) THEN
8009  DO 680 i=1,nds
8010  IF(kfdm(i).LT.kfdc(idc,i)) THEN
8011  ikfdc=idc
8012  goto 700
8013  ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
8014  goto 690
8015  ENDIF
8016  680 CONTINUE
8017  ikfdc=-idc
8018  goto 700
8019  ENDIF
8020  690 CONTINUE
8021  ikfdc=nkfdc+1
8022  700 IF(ikfdc.LT.0) THEN
8023  ikfdc=-ikfdc
8024  ELSEIF(nkfdc.GE.200) THEN
8025  nredc=nredc+1
8026  RETURN
8027  ELSE
8028  DO 720 idc=nkfdc,ikfdc,-1
8029  npdc(idc+1)=npdc(idc)
8030  DO 710 i=0,8
8031  kfdc(idc+1,i)=kfdc(idc,i)
8032  710 CONTINUE
8033  720 CONTINUE
8034  nkfdc=nkfdc+1
8035  kfdc(ikfdc,0)=nds
8036  DO 730 i=1,nds
8037  kfdc(ikfdc,i)=kfdm(i)
8038  730 CONTINUE
8039  npdc(ikfdc)=0
8040  ENDIF
8041  npdc(ikfdc)=npdc(ikfdc)+1
8042 
8043 C...Write statistics on decay channels.
8044  ELSEIF(mtabu.EQ.52) THEN
8045  fac=1./max(1,nevdc)
8046  WRITE(mstu(11),5900) nevdc
8047  DO 750 idc=1,nkfdc
8048  DO 740 i=1,kfdc(idc,0)
8049  kfm=kfdc(idc,i)
8050  kf=(kfm+1)/2
8051  IF(2*kf.NE.kfm) kf=-kf
8052  CALL luname(kf,chau)
8053  chdc(i)=chau(1:12)
8054  IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
8055  740 CONTINUE
8056  WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
8057  750 CONTINUE
8058  IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc
8059 
8060 C...Copy statistics on decay channels into /LUJETS/.
8061  ELSEIF(mtabu.EQ.53) THEN
8062  fac=1./max(1,nevdc)
8063  DO 780 idc=1,nkfdc
8064  k(idc,1)=32
8065  k(idc,2)=99
8066  k(idc,3)=0
8067  k(idc,4)=0
8068  k(idc,5)=kfdc(idc,0)
8069  DO 760 j=1,5
8070  p(idc,j)=0.
8071  v(idc,j)=0.
8072  760 CONTINUE
8073  DO 770 i=1,kfdc(idc,0)
8074  kfm=kfdc(idc,i)
8075  kf=(kfm+1)/2
8076  IF(2*kf.NE.kfm) kf=-kf
8077  IF(i.LE.5) p(idc,i)=kf
8078  IF(i.GE.6) v(idc,i-5)=kf
8079  770 CONTINUE
8080  v(idc,5)=fac*npdc(idc)
8081  780 CONTINUE
8082  n=nkfdc
8083  DO 790 j=1,5
8084  k(n+1,j)=0
8085  p(n+1,j)=0.
8086  v(n+1,j)=0.
8087  790 CONTINUE
8088  k(n+1,1)=32
8089  k(n+1,2)=99
8090  k(n+1,5)=nevdc
8091  v(n+1,5)=fac*nredc
8092  mstu(3)=1
8093  ENDIF
8094 
8095 C...Format statements for output on unit MSTU(11) (default 6).
8096  5000 FORMAT(///20x,'Event statistics - initial state'/
8097  &20x,'based on an analysis of ',i6,' events'//
8098  &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
8099  &'according to fragmenting system multiplicity'/
8100  &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
8101  &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
8102  5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
8103  5200 FORMAT(///20x,'Event statistics - final state'/
8104  &20x,'based on an analysis of ',i7,' events'//
8105  &5x,'Mean primary multiplicity =',f10.4/
8106  &5x,'Mean final multiplicity =',f10.4/
8107  &5x,'Mean charged multiplicity =',f10.4//
8108  &5x,'Number of particles produced per event (directly and via ',
8109  &'decays/branchings)'/
8110  &5x,'KF Particle/jet MDCY',10x,'Particles',13x,'Antiparticles',
8111  &8x,'Total'/35x,'prim seco prim seco'/)
8112  5300 FORMAT(1x,i6,4x,a16,i2,5(1x,f11.6))
8113  5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
8114  &20x,'based on an analysis of ',i6,' events'//
8115  &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
8116  &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
8117  5500 FORMAT(10x)
8118  5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
8119  5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
8120  &20x,'based on an analysis of ',i6,' events'//
8121  &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
8122  &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
8123  5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
8124  5900 FORMAT(///20x,'Decay channel analysis - final state'/
8125  &20x,'based on an analysis of ',i6,' events'//
8126  &2x,'Probability',10x,'Complete final state'/)
8127  6000 FORMAT(2x,f9.5,5x,8(a12,1x))
8128  6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
8129  &'or table overflow)')
8130 
8131  RETURN
8132  END
8133 
8134 C*********************************************************************
8135 
8136  SUBROUTINE lueevt(KFL,ECM)
8137 
8138 C...Purpose: to handle the generation of an e+e- annihilation jet event.
8139  IMPLICIT DOUBLE PRECISION(d)
8140  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
8141  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8142  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8143  SAVE /lujets/,/ludat1/,/ludat2/
8144 
8145 C...Check input parameters.
8146  IF(mstu(12).GE.1) CALL lulist(0)
8147  IF(kfl.LT.0.OR.kfl.GT.8) THEN
8148  CALL luerrm(16,'(LUEEVT:) called with unknown flavour code')
8149  IF(mstu(21).GE.1) RETURN
8150  ENDIF
8151  IF(kfl.LE.5) ecmmin=parj(127)+2.02*parf(100+max(1,kfl))
8152  IF(kfl.GE.6) ecmmin=parj(127)+2.02*pmas(kfl,1)
8153  IF(ecm.LT.ecmmin) THEN
8154  CALL luerrm(16,'(LUEEVT:) called with too small CM energy')
8155  IF(mstu(21).GE.1) RETURN
8156  ENDIF
8157 
8158 C...Check consistency of MSTJ options set.
8159  IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
8160  CALL luerrm(6,
8161  & '(LUEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
8162  mstj(110)=1
8163  ENDIF
8164  IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
8165  CALL luerrm(6,
8166  & '(LUEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
8167  mstj(111)=0
8168  ENDIF
8169 
8170 C...Initialize alpha_strong and total cross-section.
8171  mstu(111)=mstj(108)
8172  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
8173  &mstu(111)=1
8174  paru(112)=parj(121)
8175  IF(mstu(111).EQ.2) paru(112)=parj(122)
8176  IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
8177  &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL luxtot(kfl,ecm,
8178  &xtot)
8179  IF(mstj(116).GE.3) mstj(116)=1
8180  parj(171)=0.
8181 
8182 C...Add initial e+e- to event record (documentation only).
8183  ntry=0
8184  100 ntry=ntry+1
8185  IF(ntry.GT.100) THEN
8186  CALL luerrm(14,'(LUEEVT:) caught in an infinite loop')
8187  RETURN
8188  ENDIF
8189  mstu(24)=0
8190  nc=0
8191  IF(mstj(115).GE.2) THEN
8192  nc=nc+2
8193  CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
8194  k(nc-1,1)=21
8195  CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
8196  k(nc,1)=21
8197  ENDIF
8198 
8199 C...Radiative photon (in initial state).
8200  mk=0
8201  ecmc=ecm
8202  IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL luradk(ecm,mk,pak,
8203  &thek,phik,alpk)
8204  IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2.*pak))
8205  IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
8206  nc=nc+1
8207  CALL lu1ent(nc,22,pak,thek,phik)
8208  k(nc,3)=min(mstj(115)/2,1)
8209  ENDIF
8210 
8211 C...Virtual exchange boson (gamma or Z0).
8212  IF(mstj(115).GE.3) THEN
8213  nc=nc+1
8214  kf=22
8215  IF(mstj(102).EQ.2) kf=23
8216  mstu10=mstu(10)
8217  mstu(10)=1
8218  p(nc,5)=ecmc
8219  CALL lu1ent(nc,kf,ecmc,0.,0.)
8220  k(nc,1)=21
8221  k(nc,3)=1
8222  mstu(10)=mstu10
8223  ENDIF
8224 
8225 C...Choice of flavour and jet configuration.
8226  CALL luxkfl(kfl,ecm,ecmc,kflc)
8227  IF(kflc.EQ.0) goto 100
8228  CALL luxjet(ecmc,njet,cut)
8229  kfln=21
8230  IF(njet.EQ.4) CALL lux4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
8231  &x12,x14)
8232  IF(njet.EQ.3) CALL lux3jt(njet,cut,kflc,ecmc,x1,x3)
8233  IF(njet.EQ.2) mstj(120)=1
8234 
8235 C...Fill jet configuration and origin.
8236  IF(njet.EQ.2.AND.mstj(101).NE.5) CALL lu2ent(nc+1,kflc,-kflc,ecmc)
8237  IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL lu2ent(-(nc+1),kflc,-kflc,
8238  &ecmc)
8239  IF(njet.EQ.3) CALL lu3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
8240  IF(njet.EQ.4.AND.kfln.EQ.21) CALL lu4ent(nc+1,kflc,kfln,kfln,
8241  &-kflc,ecmc,x1,x2,x4,x12,x14)
8242  IF(njet.EQ.4.AND.kfln.NE.21) CALL lu4ent(nc+1,kflc,-kfln,kfln,
8243  &-kflc,ecmc,x1,x2,x4,x12,x14)
8244  IF(mstu(24).NE.0) goto 100
8245  DO 110 ip=nc+1,n
8246  k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
8247  110 CONTINUE
8248 
8249 C...Angular orientation according to matrix element.
8250  IF(mstj(106).EQ.1) THEN
8251  CALL luxdif(nc,njet,kflc,ecmc,chi,the,phi)
8252  CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
8253  CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
8254  ENDIF
8255 
8256 C...Rotation and boost from radiative photon.
8257  IF(mk.EQ.1) THEN
8258  dbek=-pak/(ecm-pak)
8259  nmin=nc+1-mstj(115)/3
8260  CALL ludbrb(nmin,n,0.,-phik,0d0,0d0,0d0)
8261  CALL ludbrb(nmin,n,alpk,0.,dbek*sin(thek),0d0,dbek*cos(thek))
8262  CALL ludbrb(nmin,n,0.,phik,0d0,0d0,0d0)
8263  ENDIF
8264 
8265 C...Generate parton shower. Rearrange along strings and check.
8266  IF(mstj(101).EQ.5) THEN
8267  CALL lushow(n-1,n,ecmc)
8268  mstj14=mstj(14)
8269  IF(mstj(105).EQ.-1) mstj(14)=-1
8270  IF(mstj(105).GE.0) mstu(28)=0
8271  CALL luprep(0)
8272  mstj(14)=mstj14
8273  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
8274  ENDIF
8275 
8276 C...Fragmentation/decay generation. Information for LUTABU.
8277  IF(mstj(105).EQ.1) CALL luexec
8278  mstu(161)=kflc
8279  mstu(162)=-kflc
8280 
8281  RETURN
8282  END
8283 
8284 C*********************************************************************
8285 
8286  SUBROUTINE luxtot(KFL,ECM,XTOT)
8287 
8288 C...Purpose: to calculate total cross-section, including initial
8289 C...state radiation effects.
8290  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8291  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8292  SAVE /ludat1/,/ludat2/
8293 
8294 C...Status, (optimized) Q^2 scale, alpha_strong.
8295  parj(151)=ecm
8296  mstj(119)=10*mstj(102)+kfl
8297  IF(mstj(111).EQ.0) THEN
8298  q2r=ecm**2
8299  ELSEIF(mstu(111).EQ.0) THEN
8300  parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
8301  & ((33.-2.*mstu(112))*paru(111)))))
8302  q2r=parj(168)*ecm**2
8303  ELSE
8304  parj(168)=min(1.,max(parj(128),paru(112)/ecm,
8305  & (2.*paru(112)/ecm)**2))
8306  q2r=parj(168)*ecm**2
8307  ENDIF
8308  alspi=ulalps(q2r)/paru(1)
8309 
8310 C...QCD corrections factor in R.
8311  IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
8312  rqcd=1.
8313  ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
8314  rqcd=1.+alspi
8315  ELSEIF(mstj(109).EQ.0) THEN
8316  rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
8317  IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
8318  & log(parj(168))*alspi**2)
8319  ELSEIF(iabs(mstj(101)).EQ.1) THEN
8320  rqcd=1.+(3./4.)*alspi
8321  ELSE
8322  rqcd=1.+(3./4.)*alspi-(3./32.+0.519*mstu(118))*alspi**2
8323  ENDIF
8324 
8325 C...Calculate Z0 width if default value not acceptable.
8326  IF(mstj(102).GE.3) THEN
8327  rva=3.*(3.+(4.*paru(102)-1.)**2)+6.*rqcd*(2.+(1.-8.*paru(102)/
8328  & 3.)**2+(4.*paru(102)/3.-1.)**2)
8329  DO 100 kflc=5,6
8330  vq=1.
8331  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*ulmass(kflc)/
8332  & ecm)**2))
8333  IF(kflc.EQ.5) vf=4.*paru(102)/3.-1.
8334  IF(kflc.EQ.6) vf=1.-8.*paru(102)/3.
8335  rva=rva+3.*rqcd*(0.5*vq*(3.-vq**2)*vf**2+vq**3)
8336  100 CONTINUE
8337  parj(124)=paru(101)*parj(123)*rva/(48.*paru(102)*(1.-paru(102)))
8338  ENDIF
8339 
8340 C...Calculate propagator and related constants for QFD case.
8341  poll=1.-parj(131)*parj(132)
8342  IF(mstj(102).GE.2) THEN
8343  sff=1./(16.*paru(102)*(1.-paru(102)))
8344  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
8345  sfi=sfw*(1.-(parj(123)/ecm)**2)
8346  ve=4.*paru(102)-1.
8347  sf1i=sff*(ve*poll+parj(132)-parj(131))
8348  sf1w=sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
8349  hf1i=sfi*sf1i
8350  hf1w=sfw*sf1w
8351  ENDIF
8352 
8353 C...Loop over different flavours: charge, velocity.
8354  rtot=0.
8355  rqq=0.
8356  rqv=0.
8357  rva=0.
8358  DO 110 kflc=1,max(mstj(104),kfl)
8359  IF(kfl.GT.0.AND.kflc.NE.kfl) goto 110
8360  mstj(93)=1
8361  pmq=ulmass(kflc)
8362  IF(ecm.LT.2.*pmq+parj(127)) goto 110
8363  qf=kchg(kflc,1)/3.
8364  vq=1.
8365  IF(mod(mstj(103),2).EQ.1) vq=sqrt(1.-(2.*pmq/ecm)**2)
8366 
8367 C...Calculate R and sum of charges for QED or QFD case.
8368  rqq=rqq+3.*qf**2*poll
8369  IF(mstj(102).LE.1) THEN
8370  rtot=rtot+3.*0.5*vq*(3.-vq**2)*qf**2*poll
8371  ELSE
8372  vf=sign(1.,qf)-4.*qf*paru(102)
8373  rqv=rqv-6.*qf*vf*sf1i
8374  rva=rva+3.*(vf**2+1.)*sf1w
8375  rtot=rtot+3.*(0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+
8376  & vf**2*hf1w)+vq**3*hf1w)
8377  ENDIF
8378  110 CONTINUE
8379  rsum=rqq
8380  IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
8381 
8382 C...Calculate cross-section, including QCD corrections.
8383  parj(141)=rqq
8384  parj(142)=rtot
8385  parj(143)=rtot*rqcd
8386  parj(144)=parj(143)
8387  parj(145)=parj(141)*86.8/ecm**2
8388  parj(146)=parj(142)*86.8/ecm**2
8389  parj(147)=parj(143)*86.8/ecm**2
8390  parj(148)=parj(147)
8391  parj(157)=rsum*rqcd
8392  parj(158)=0.
8393  parj(159)=0.
8394  xtot=parj(147)
8395  IF(mstj(107).LE.0) RETURN
8396 
8397 C...Virtual cross-section.
8398  xkl=parj(135)
8399  xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
8400  ale=2.*log(ecm/ulmass(11))-1.
8401  sigv=ale/3.+2.*log(ecm**2/(ulmass(13)*ulmass(15)))/3.-4./3.+
8402  &1.526*log(ecm**2/0.932)
8403 
8404 C...Soft and hard radiative cross-section in QED case.
8405  IF(mstj(102).LE.1) THEN
8406  sigv=1.5*ale-0.5+paru(1)**2/3.+2.*sigv
8407  sigs=ale*(2.*log(xkl)-log(1.-xkl)-xkl)
8408  sigh=ale*(2.*log(xku/xkl)-log((1.-xku)/(1.-xkl))-(xku-xkl))
8409 
8410 C...Soft and hard radiative cross-section in QFD case.
8411  ELSE
8412  szm=1.-(parj(123)/ecm)**2
8413  szw=parj(123)*parj(124)/ecm**2
8414  parj(161)=-rqq/rsum
8415  parj(162)=-(rqq+rqv+rva)/rsum
8416  parj(163)=(rqv*(1.-0.5*szm-sfi)+rva*(1.5-szm-sfw))/rsum
8417  parj(164)=(rqv*szw**2*(1.-2.*sfw)+rva*(2.*sfi+szw**2-4.+3.*szm-
8418  & szm**2))/(szw*rsum)
8419  sigv=1.5*ale-0.5+paru(1)**2/3.+((2.*rqq+sfi*rqv)/rsum)*sigv+
8420  & (szw*sfw*rqv/rsum)*paru(1)*20./9.
8421  sigs=ale*(2.*log(xkl)+parj(161)*log(1.-xkl)+parj(162)*xkl+
8422  & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
8423  & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
8424  sigh=ale*(2.*log(xku/xkl)+parj(161)*log((1.-xku)/(1.-xkl))+
8425  & parj(162)*(xku-xkl)+parj(163)*log(((xku-szm)**2+szw**2)/
8426  & ((xkl-szm)**2+szw**2))+parj(164)*(atan((xku-szm)/szw)-
8427  & atan((xkl-szm)/szw)))
8428  ENDIF
8429 
8430 C...Total cross-section and fraction of hard photon events.
8431  parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
8432  parj(157)=rsum*(1.+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
8433  parj(144)=parj(157)
8434  parj(148)=parj(144)*86.8/ecm**2
8435  xtot=parj(148)
8436 
8437  RETURN
8438  END
8439 
8440 C*********************************************************************
8441 
8442  SUBROUTINE luradk(ECM,MK,PAK,THEK,PHIK,ALPK)
8443 
8444 C...Purpose: to generate initial state photon radiation.
8445  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8446  SAVE /ludat1/
8447 
8448 C...Function: cumulative hard photon spectrum in QFD case.
8449  fxk(xx)=2.*log(xx)+parj(161)*log(1.-xx)+parj(162)*xx+
8450  &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
8451 
8452 C...Determine whether radiative photon or not.
8453  mk=0
8454  pak=0.
8455  IF(parj(160).LT.rlu(0)) RETURN
8456  mk=1
8457 
8458 C...Photon energy range. Find photon momentum in QED case.
8459  xkl=parj(135)
8460  xku=min(parj(136),1.-(2.*parj(127)/ecm)**2)
8461  IF(mstj(102).LE.1) THEN
8462  100 xk=1./(1.+(1./xkl-1.)*((1./xku-1.)/(1./xkl-1.))**rlu(0))
8463  IF(1.+(1.-xk)**2.LT.2.*rlu(0)) goto 100
8464 
8465 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
8466  ELSE
8467  szm=1.-(parj(123)/ecm)**2
8468  szw=parj(123)*parj(124)/ecm**2
8469  fxkl=fxk(xkl)
8470  fxku=fxk(xku)
8471  fxkd=1e-4*(fxku-fxkl)
8472  fxkr=fxkl+rlu(0)*(fxku-fxkl)
8473  nxk=0
8474  110 nxk=nxk+1
8475  xk=0.5*(xkl+xku)
8476  fxkv=fxk(xk)
8477  IF(fxkv.GT.fxkr) THEN
8478  xku=xk
8479  fxku=fxkv
8480  ELSE
8481  xkl=xk
8482  fxkl=fxkv
8483  ENDIF
8484  IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) goto 110
8485  xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
8486  ENDIF
8487  pak=0.5*ecm*xk
8488 
8489 C...Photon polar and azimuthal angle.
8490  pme=2.*(ulmass(11)/ecm)**2
8491  120 cthm=pme*(2./pme)**rlu(0)
8492  IF(1.-(xk**2*cthm*(1.-0.5*cthm)+2.*(1.-xk)*pme/max(pme,
8493  &cthm*(1.-0.5*cthm)))/(1.+(1.-xk)**2).LT.rlu(0)) goto 120
8494  cthe=1.-cthm
8495  IF(rlu(0).GT.0.5) cthe=-cthe
8496  sthe=sqrt(max(0.,(cthm-pme)*(2.-cthm)))
8497  thek=ulangl(cthe,sthe)
8498  phik=paru(2)*rlu(0)
8499 
8500 C...Rotation angle for hadronic system.
8501  sgn=1.
8502  IF(0.5*(2.-xk*(1.-cthe))**2/((2.-xk)**2+(xk*cthe)**2).GT.
8503  &rlu(0)) sgn=-1.
8504  alpk=asin(sgn*sthe*(xk-sgn*(2.*sqrt(1.-xk)-2.+xk)*cthe)/
8505  &(2.-xk*(1.-sgn*cthe)))
8506 
8507  RETURN
8508  END
8509 
8510 C*********************************************************************
8511 
8512  SUBROUTINE luxkfl(KFL,ECM,ECMC,KFLC)
8513 
8514 C...Purpose: to select flavour for produced qqbar pair.
8515  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8516  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
8517  SAVE /ludat1/,/ludat2/
8518 
8519 C...Calculate maximum weight in QED or QFD case.
8520  IF(mstj(102).LE.1) THEN
8521  rfmax=4./9.
8522  ELSE
8523  poll=1.-parj(131)*parj(132)
8524  sff=1./(16.*paru(102)*(1.-paru(102)))
8525  sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
8526  sfi=sfw*(1.-(parj(123)/ecmc)**2)
8527  ve=4.*paru(102)-1.
8528  hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
8529  hf1w=sfw*sff**2*((ve**2+1.)*poll+2.*ve*(parj(132)-parj(131)))
8530  rfmax=max(4./9.*poll-4./3.*(1.-8.*paru(102)/3.)*hf1i+
8531  & ((1.-8.*paru(102)/3.)**2+1.)*hf1w,1./9.*poll+2./3.*
8532  & (-1.+4.*paru(102)/3.)*hf1i+((-1.+4.*paru(102)/3.)**2+1.)*hf1w)
8533  ENDIF
8534 
8535 C...Choose flavour. Gives charge and velocity.
8536  ntry=0
8537  100 ntry=ntry+1
8538  IF(ntry.GT.100) THEN
8539  CALL luerrm(14,'(LUXKFL:) caught in an infinite loop')
8540  kflc=0
8541  RETURN
8542  ENDIF
8543  kflc=kfl
8544  IF(kfl.LE.0) kflc=1+int(mstj(104)*rlu(0))
8545  mstj(93)=1
8546  pmq=ulmass(kflc)
8547  IF(ecm.LT.2.*pmq+parj(127)) goto 100
8548  qf=kchg(kflc,1)/3.
8549  vq=1.
8550  IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0.,1.-(2.*pmq/ecmc)**2))
8551 
8552 C...Calculate weight in QED or QFD case.
8553  IF(mstj(102).LE.1) THEN
8554  rf=qf**2
8555  rfv=0.5*vq*(3.-vq**2)*qf**2
8556  ELSE
8557  vf=sign(1.,qf)-4.*qf*paru(102)
8558  rf=qf**2*poll-2.*qf*vf*hf1i+(vf**2+1.)*hf1w
8559  rfv=0.5*vq*(3.-vq**2)*(qf**2*poll-2.*qf*vf*hf1i+vf**2*hf1w)+
8560  & vq**3*hf1w
8561  IF(rfv.GT.0.) parj(171)=min(1.,vq**3*hf1w/rfv)
8562  ENDIF
8563 
8564 C...Weighting or new event (radiative photon). Cross-section update.
8565  IF(kfl.LE.0.AND.rf.LT.rlu(0)*rfmax) goto 100
8566  parj(158)=parj(158)+1.
8567  IF(ecmc.LT.2.*pmq+parj(127).OR.rfv.LT.rlu(0)*rf) kflc=0
8568  IF(mstj(107).LE.0.AND.kflc.EQ.0) goto 100
8569  IF(kflc.NE.0) parj(159)=parj(159)+1.
8570  parj(144)=parj(157)*parj(159)/parj(158)
8571  parj(148)=parj(144)*86.8/ecm**2
8572 
8573  RETURN
8574  END
8575 
8576 C*********************************************************************
8577 
8578  SUBROUTINE luxjet(ECM,NJET,CUT)
8579 
8580 C...Purpose: to select number of jets in matrix element approach.
8581  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8582  SAVE /ludat1/
8583  dimension zhut(5)
8584 
8585 C...Relative three-jet rate in Zhu second order parametrization.
8586  DATA zhut/3.0922, 6.2291, 7.4782, 7.8440, 8.2560/
8587 
8588 C...Trivial result for two-jets only, including parton shower.
8589  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
8590  cut=0.
8591 
8592 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
8593  ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
8594  cf=4./3.
8595  IF(mstj(109).EQ.2) cf=1.
8596  IF(mstj(111).EQ.0) THEN
8597  q2=ecm**2
8598  q2r=ecm**2
8599  ELSEIF(mstu(111).EQ.0) THEN
8600  parj(169)=min(1.,parj(129))
8601  q2=parj(169)*ecm**2
8602  parj(168)=min(1.,max(parj(128),exp(-12.*paru(1)/
8603  & ((33.-2.*mstu(112))*paru(111)))))
8604  q2r=parj(168)*ecm**2
8605  ELSE
8606  parj(169)=min(1.,max(parj(129),(2.*paru(112)/ecm)**2))
8607  q2=parj(169)*ecm**2
8608  parj(168)=min(1.,max(parj(128),paru(112)/ecm,
8609  & (2.*paru(112)/ecm)**2))
8610  q2r=parj(168)*ecm**2
8611  ENDIF
8612 
8613 C...alpha_strong for R and R itself.
8614  alspi=(3./4.)*cf*ulalps(q2r)/paru(1)
8615  IF(iabs(mstj(101)).EQ.1) THEN
8616  rqcd=1.+alspi
8617  ELSEIF(mstj(109).EQ.0) THEN
8618  rqcd=1.+alspi+(1.986-0.115*mstu(118))*alspi**2
8619  IF(mstj(111).EQ.1) rqcd=max(1.,rqcd+(33.-2.*mstu(112))/12.*
8620  & log(parj(168))*alspi**2)
8621  ELSE
8622  rqcd=1.+alspi-(3./32.+0.519*mstu(118))*(4.*alspi/3.)**2
8623  ENDIF
8624 
8625 C...alpha_strong for jet rate. Initial value for y cut.
8626  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
8627  cut=max(0.001,parj(125),(parj(126)/ecm)**2)
8628  IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
8629  & cut=max(cut,exp(-sqrt(0.75/alspi))/2.)
8630  IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
8631 
8632 C...Parametrization of first order three-jet cross-section.
8633  100 IF(mstj(101).EQ.0.OR.cut.GE.0.25) THEN
8634  parj(152)=0.
8635  ELSE
8636  parj(152)=(2.*alspi/3.)*((3.-6.*cut+2.*log(cut))*
8637  & log(cut/(1.-2.*cut))+(2.5+1.5*cut-6.571)*(1.-3.*cut)+
8638  & 5.833*(1.-3.*cut)**2-3.894*(1.-3.*cut)**3+
8639  & 1.342*(1.-3.*cut)**4)/rqcd
8640  IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
8641  & parj(152)=0.
8642  ENDIF
8643 
8644 C...Parametrization of second order three-jet cross-section.
8645  IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
8646  & cut.GE.0.25) THEN
8647  parj(153)=0.
8648  ELSEIF(mstj(110).LE.1) THEN
8649  ct=log(1./cut-2.)
8650  parj(153)=alspi**2*ct**2*(2.419+0.5989*ct+0.6782*ct**2-
8651  & 0.2661*ct**3+0.01159*ct**4)/rqcd
8652 
8653 C...Interpolation in second/first order ratio for Zhu parametrization.
8654  ELSEIF(mstj(110).EQ.2) THEN
8655  iza=0
8656  DO 110 iy=1,5
8657  IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
8658  110 CONTINUE
8659  IF(iza.NE.0) THEN
8660  zhurat=zhut(iza)
8661  ELSE
8662  iz=100.*cut
8663  zhurat=zhut(iz)+(100.*cut-iz)*(zhut(iz+1)-zhut(iz))
8664  ENDIF
8665  parj(153)=alspi*parj(152)*zhurat
8666  ENDIF
8667 
8668 C...Shift in second order three-jet cross-section with optimized Q^2.
8669  IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3.
8670  & and.cut.LT.0.25) parj(153)=parj(153)+(33.-2.*mstu(112))/12.*
8671  & log(parj(169))*alspi*parj(152)
8672 
8673 C...Parametrization of second order four-jet cross-section.
8674  IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125) THEN
8675  parj(154)=0.
8676  ELSE
8677  ct=log(1./cut-5.)
8678  IF(cut.LE.0.018) THEN
8679  xqqgg=6.349-4.330*ct+0.8304*ct**2
8680  IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(3.035-2.091*ct+
8681  & 0.4059*ct**2)
8682  xqqqq=1.25*(-0.1080+0.01486*ct+0.009364*ct**2)
8683  IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
8684  ELSE
8685  xqqgg=-0.09773+0.2959*ct-0.2764*ct**2+0.08832*ct**3
8686  IF(mstj(109).EQ.2) xqqgg=(4./3.)**2*(-0.04079+0.1340*ct-
8687  & 0.1326*ct**2+0.04365*ct**3)
8688  xqqqq=1.25*(0.003661-0.004888*ct-0.001081*ct**2+0.002093*
8689  & ct**3)
8690  IF(mstj(109).EQ.2) xqqqq=8.*xqqqq
8691  ENDIF
8692  parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
8693  parj(155)=xqqqq/(xqqgg+xqqqq)
8694  ENDIF
8695 
8696 C...If negative three-jet rate, change y' optimization parameter.
8697  IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0..AND.
8698  & parj(169).LT.0.99) THEN
8699  parj(169)=min(1.,1.2*parj(169))
8700  q2=parj(169)*ecm**2
8701  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
8702  goto 100
8703  ENDIF
8704 
8705 C...If too high cross-section, use harder cuts, or fail.
8706  IF(parj(152)+parj(153)+parj(154).GE.1) THEN
8707  IF(mstj(110).EQ.2.AND.cut.GT.0.0499.AND.mstj(111).EQ.1.AND.
8708  & parj(169).LT.0.99) THEN
8709  parj(169)=min(1.,1.2*parj(169))
8710  q2=parj(169)*ecm**2
8711  alspi=(3./4.)*cf*ulalps(q2)/paru(1)
8712  goto 100
8713  ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499) THEN
8714  CALL luerrm(26,
8715  & '(LUXJET:) no allowed y cut value for Zhu parametrization')
8716  ENDIF
8717  cut=0.26*(4.*cut)**(parj(152)+parj(153)+parj(154))**(-1./3.)
8718  IF(mstj(110).EQ.2) cut=max(0.01,min(0.05,cut))
8719  goto 100
8720  ENDIF
8721 
8722 C...Scalar gluon (first order only).
8723  ELSE
8724  alspi=ulalps(ecm**2)/paru(1)
8725  cut=max(0.001,parj(125),(parj(126)/ecm)**2,exp(-3./alspi))
8726  parj(152)=0.
8727  IF(cut.LT.0.25) parj(152)=(alspi/3.)*((1.-2.*cut)*
8728  & log((1.-2.*cut)/cut)+0.5*(9.*cut**2-1.))
8729  parj(153)=0.
8730  parj(154)=0.
8731  ENDIF
8732 
8733 C...Select number of jets.
8734  parj(150)=cut
8735  IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
8736  njet=2
8737  ELSEIF(mstj(101).LE.0) THEN
8738  njet=min(4,2-mstj(101))
8739  ELSE
8740  rnj=rlu(0)
8741  njet=2
8742  IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
8743  IF(parj(154).GT.rnj) njet=4
8744  ENDIF
8745 
8746  RETURN
8747  END
8748 
8749 C*********************************************************************
8750 
8751  SUBROUTINE lux3jt(NJET,CUT,KFL,ECM,X1,X2)
8752 
8753 C...Purpose: to select the kinematical variables of three-jet events.
8754  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8755  SAVE /ludat1/
8756  dimension zhup(5,12)
8757 
8758 C...Coefficients of Zhu second order parametrization.
8759  DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
8760  & 18.29, 89.56, 4.541, -52.09, -109.8, 24.90,
8761  & 11.63, 3.683, 17.50, 0.002440, -1.362, -0.3537,
8762  & 11.42, 6.299, -22.55, -8.915, 59.25, -5.855,
8763  & -32.85, -1.054, -16.90, 0.006489, -0.8156, 0.01095,
8764  & 7.847, -3.964, -35.83, 1.178, 29.39, 0.2806,
8765  & 47.82, -12.36, -56.72, 0.04054, -0.4365, 0.6062,
8766  & 5.441, -56.89, -50.27, 15.13, 114.3, -18.19,
8767  & 97.05, -1.890, -139.9, 0.08153, -0.4984, 0.9439,
8768  & -17.65, 51.44, -58.32, 70.95, -255.7, -78.99,
8769  & 476.9, 29.65, -239.3, 0.4745, -1.174, 6.081/
8770 
8771 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
8772  dilog(x)=x+x**2/4.+x**3/9.+x**4/16.+x**5/25.+x**6/36.+x**7/49.
8773 
8774 C...Event type. Mass effect factors and other common constants.
8775  mstj(120)=2
8776  mstj(121)=0
8777  pmq=ulmass(kfl)
8778  qme=(2.*pmq/ecm)**2
8779  IF(mstj(109).NE.1) THEN
8780  cutl=log(cut)
8781  cutd=log(1./cut-2.)
8782  IF(mstj(109).EQ.0) THEN
8783  cf=4./3.
8784  cn=3.
8785  tr=2.
8786  wtmx=min(20.,37.-6.*cutd)
8787  IF(mstj(110).EQ.2) wtmx=2.*(7.5+80.*cut)
8788  ELSE
8789  cf=1.
8790  cn=0.
8791  tr=12.
8792  wtmx=0.
8793  ENDIF
8794 
8795 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
8796  als2pi=paru(118)/paru(2)
8797  wtopt=0.
8798  IF(mstj(111).EQ.1) wtopt=(33.-2.*mstu(112))/6.*log(parj(169))*
8799  & als2pi
8800  wtmax=max(0.,1.+wtopt+als2pi*wtmx)
8801 
8802 C...Choose three-jet events in allowed region.
8803  100 njet=3
8804  110 y13l=cutl+cutd*rlu(0)
8805  y23l=cutl+cutd*rlu(0)
8806  y13=exp(y13l)
8807  y23=exp(y23l)
8808  y12=1.-y13-y23
8809  IF(y12.LE.cut) goto 110
8810  IF(y13**2+y23**2+2.*y12.LE.2.*rlu(0)) goto 110
8811 
8812 C...Second order corrections.
8813  IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
8814  y12l=log(y12)
8815  y13m=log(1.-y13)
8816  y23m=log(1.-y23)
8817  y12m=log(1.-y12)
8818  IF(y13.LE.0.5) y13i=dilog(y13)
8819  IF(y13.GE.0.5) y13i=1.644934-y13l*y13m-dilog(1.-y13)
8820  IF(y23.LE.0.5) y23i=dilog(y23)
8821  IF(y23.GE.0.5) y23i=1.644934-y23l*y23m-dilog(1.-y23)
8822  IF(y12.LE.0.5) y12i=dilog(y12)
8823  IF(y12.GE.0.5) y12i=1.644934-y12l*y12m-dilog(1.-y12)
8824  wt1=(y13**2+y23**2+2.*y12)/(y13*y23)
8825  wt2=cf*(-2.*(cutl-y12l)**2-3.*cutl-1.+3.289868+
8826  & 2.*(2.*cutl-y12l)*cut/y12)+
8827  & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-11.*cutl/6.+
8828  & 67./18.+1.644934-(2.*cutl-y12l)*cut/y12+(2.*cutl-y13l)*
8829  & cut/y13+(2.*cutl-y23l)*cut/y23)+
8830  & tr*(2.*cutl/3.-10./9.)+
8831  & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
8832  & y13l*(4.*y12**2+2.*y12*y13+4.*y12*y23+y13*y23)/(y12+y23)**2+
8833  & y23l*(4.*y12**2+2.*y12*y23+4.*y12*y13+y13*y23)/(y12+y13)**2)/
8834  & wt1+
8835  & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+
8836  & (cn-2.*cf)*((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
8837  & y23m+1.644934-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
8838  & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934-y12i-y13i)/
8839  & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
8840  & 2.*y12l*y12**2/(y13+y23)**2-4.*y12l*y12/(y13+y23))/wt1-
8841  & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934-y13i-y23i)
8842  IF(1.+wtopt+als2pi*wt2.LE.0.) mstj(121)=1
8843  IF(1.+wtopt+als2pi*wt2.LE.wtmax*rlu(0)) goto 110
8844  parj(156)=(wtopt+als2pi*wt2)/(1.+wtopt+als2pi*wt2)
8845 
8846  ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
8847 C...Second order corrections; Zhu parametrization of ERT.
8848  zx=(y23-y13)**2
8849  zy=1.-y12
8850  iza=0
8851  DO 120 iy=1,5
8852  IF(abs(cut-0.01*iy).LT.0.0001) iza=iy
8853  120 CONTINUE
8854  IF(iza.NE.0) THEN
8855  iz=iza
8856  wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
8857  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
8858  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
8859  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
8860  ELSE
8861  iz=100.*cut
8862  wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
8863  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
8864  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
8865  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
8866  iz=iz+1
8867  wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
8868  & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
8869  & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
8870  & zhup(iz,11)/(1.-zy)+zhup(iz,12)/zy
8871  wt2=wtl+(wtu-wtl)*(100.*cut+1.-iz)
8872  ENDIF
8873  IF(1.+wtopt+2.*als2pi*wt2.LE.0.) mstj(121)=1
8874  IF(1.+wtopt+2.*als2pi*wt2.LE.wtmax*rlu(0)) goto 110
8875  parj(156)=(wtopt+2.*als2pi*wt2)/(1.+wtopt+2.*als2pi*wt2)
8876  ENDIF
8877 
8878 C...Impose mass cuts (gives two jets). For fixed jet number new try.
8879  x1=1.-y23
8880  x2=1.-y13
8881  x3=1.-y12
8882  IF(4.*y23*y13*y12/x3**2.LE.qme) njet=2
8883  IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
8884  & 0.5*qme**2+(0.5*qme+0.25*qme**2)*((1.-x2)/(1.-x1)+
8885  & (1.-x1)/(1.-x2)).GT.(x1**2+x2**2)*rlu(0)) njet=2
8886  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 100
8887 
8888 C...Scalar gluon model (first order only, no mass effects).
8889  ELSE
8890  130 njet=3
8891  140 x3=sqrt(4.*cut**2+rlu(0)*((1.-cut)**2-4.*cut**2))
8892  IF(log((x3-cut)/cut).LE.rlu(0)*log((1.-2.*cut)/cut)) goto 140
8893  yd=sign(2.*cut*((x3-cut)/cut)**rlu(0)-x3,rlu(0)-0.5)
8894  x1=1.-0.5*(x3+yd)
8895  x2=1.-0.5*(x3-yd)
8896  IF(4.*(1.-x1)*(1.-x2)*(1.-x3)/x3**2.LE.qme) njet=2
8897  IF(mstj(102).GE.2) THEN
8898  IF(x3**2-2.*(1.+x3)*(1.-x1)*(1.-x2)*parj(171).LT.
8899  & x3**2*rlu(0)) njet=2
8900  ENDIF
8901  IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 130
8902  ENDIF
8903 
8904  RETURN
8905  END
8906 
8907 C*********************************************************************
8908 
8909  SUBROUTINE lux4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
8910 
8911 C...Purpose: to select the kinematical variables of four-jet events.
8912  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
8913  SAVE /ludat1/
8914  dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
8915 
8916 C...Common constants. Colour factors for QCD and Abelian gluon theory.
8917  pmq=ulmass(kfl)
8918  qme=(2.*pmq/ecm)**2
8919  ct=log(1./cut-5.)
8920  IF(mstj(109).EQ.0) THEN
8921  cf=4./3.
8922  cn=3.
8923  tr=2.5
8924  ELSE
8925  cf=1.
8926  cn=0.
8927  tr=15.
8928  ENDIF
8929 
8930 C...Choice of process (qqbargg or qqbarqqbar).
8931  100 njet=4
8932  it=1
8933  IF(parj(155).GT.rlu(0)) it=2
8934  IF(mstj(101).LE.-3) it=-mstj(101)-2
8935  IF(it.EQ.1) wtmx=0.7/cut**2
8936  IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6/cut**2
8937  IF(it.EQ.2) wtmx=0.1125*cf*tr/cut**2
8938  id=1
8939 
8940 C...Sample the five kinematical variables (for qqgg preweighted in y34).
8941  110 y134=3.*cut+(1.-6.*cut)*rlu(0)
8942  y234=3.*cut+(1.-6.*cut)*rlu(0)
8943  IF(it.EQ.1) y34=(1.-5.*cut)*exp(-ct*rlu(0))
8944  IF(it.EQ.2) y34=cut+(1.-6.*cut)*rlu(0)
8945  IF(y34.LE.y134+y234-1..OR.y34.GE.y134*y234) goto 110
8946  vt=rlu(0)
8947  cp=cos(paru(1)*rlu(0))
8948  y14=(y134-y34)*vt
8949  y13=y134-y14-y34
8950  vb=y34*(1.-y134-y234+y34)/((y134-y34)*(y234-y34))
8951  y24=0.5*(y234-y34)*(1.-4.*sqrt(max(0.,vt*(1.-vt)*vb*(1.-vb)))*
8952  &cp-(1.-2.*vt)*(1.-2.*vb))
8953  y23=y234-y34-y24
8954  y12=1.-y134-y23-y24
8955  IF(min(y12,y13,y14,y23,y24).LE.cut) goto 110
8956  y123=y12+y13+y23
8957  y124=y12+y14+y24
8958 
8959 C...Calculate matrix elements for qqgg or qqqq process.
8960  ic=0
8961  wttot=0.
8962  120 ic=ic+1
8963  IF(it.EQ.1) THEN
8964  wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3.*y12*y23*y34+
8965  & 3.*y12*y14*y34+4.*y12**2*y34-y13*y23*y24+2.*y12*y23*y24-
8966  & y13*y14*y24-2.*y12*y13*y24+2.*y12**2*y24+y14*y23**2+2.*y12*
8967  & y23**2+y14**2*y23+4.*y12*y14*y23+4.*y12**2*y23+2.*y12*y14**2+
8968  & 2.*y12*y13*y14+4.*y12**2*y14+2.*y12**2*y13+2.*y12**3)/(2.*y13*
8969  & y134*y234*y24)+(y24*y34+y12*y34+y13*y24-y14*y23+y12*y13)/(y13*
8970  & y134**2)+2.*y23*(1.-y13)/(y13*y134*y24)+y34/(2.*y13*y24)
8971  wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2.*y12*
8972  & y14*y24)/(y13*y134*y23*y14)+y12*(1.+y34)*y124/(y134*y234*y14*
8973  & y24)-(2.*y13*y24+y14**2+y13*y23+2.*y12*y13)/(y13*y134*y14)+
8974  & y12*y123*y124/(2.*y13*y14*y23*y24)
8975  wtc(ic)=-(5.*y12*y34**2+2.*y12*y24*y34+2.*y12*y23*y34+2.*y12*
8976  & y14*y34+2.*y12*y13*y34+4.*y12**2*y34-y13*y24**2+y14*y23*y24+
8977  & y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-3.*y12*y13*y24-
8978  & y14*y23**2-y14**2*y23+y13*y14*y23-3.*y12*y14*y23-y12*y13*y23)/
8979  & (4.*y134*y234*y34**2)+(3.*y12*y34**2-3.*y13*y24*y34+3.*y12*y24*
8980  & y34+3.*y14*y23*y34-y13*y24**2-y12*y23*y34+6.*y12*y14*y34+2.*y12*
8981  & y13*y34-2.*y12**2*y34+y14*y23*y24-3.*y13*y23*y24-2.*y13*y14*
8982  & y24+4.*y12*y14*y24+2.*y12*y13*y24+3.*y14*y23**2+2.*y14**2*y23+
8983  & 2.*y14**2*y12+2.*y12**2*y14+6.*y12*y14*y23-2.*y12*y13**2-
8984  & 2.*y12**2*y13)/(4.*y13*y134*y234*y34)
8985  wtc(ic)=wtc(ic)+(2.*y12*y34**2-2.*y13*y24*y34+y12*y24*y34+
8986  & 4.*y13*y23*y34+4.*y12*y14*y34+2.*y12*y13*y34+2.*y12**2*y34-
8987  & y13*y24**2+3.*y14*y23*y24+4.*y13*y23*y24-2.*y13*y14*y24+
8988  & 4.*y12*y14*y24+2.*y12*y13*y24+2.*y14*y23**2+4.*y13*y23**2+
8989  & 2.*y13*y14*y23+2.*y12*y14*y23+4.*y12*y13*y23+2.*y12*y14**2+4.*
8990  & y12**2*y13+4.*y12*y13*y14+2.*y12**2*y14)/(4.*y13*y134*y24*y34)-
8991  & (y12*y34**2-2.*y14*y24*y34-2.*y13*y24*y34-y14*y23*y34+y13*y23*
8992  & y34+y12*y14*y34+2.*y12*y13*y34-2.*y14**2*y24-4.*y13*y14*y24-
8993  & 4.*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-y12*y13**2)/
8994  & (2.*y13*y34*y134**2)+(y12*y34**2-4.*y14*y24*y34-2.*y13*y24*y34-
8995  & 2.*y14*y23*y34-4.*y13*y23*y34-4.*y12*y14*y34-4.*y12*y13*y34-
8996  & 2.*y13*y14*y24+2.*y13**2*y24+2.*y14**2*y23-2.*y13*y14*y23-
8997  & y12*y14**2-6.*y12*y13*y14-y12*y13**2)/(4.*y34**2*y134**2)
8998  wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5*cn)*wtb(ic)+cn*wtc(ic))/
8999  & 8.
9000  ELSE
9001  wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2.*y12*
9002  & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
9003  & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
9004  & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
9005  & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
9006  & y13*y14*y24+2.*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
9007  & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
9008  & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
9009  & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
9010  wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
9011  & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
9012  & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
9013  & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
9014  & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
9015  & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
9016  & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
9017  & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
9018  wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5*cn)*wte(ic))/16.
9019  ENDIF
9020 
9021 C...Permutations of momenta in matrix element. Weighting.
9022  130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
9023  ysav=y13
9024  y13=y14
9025  y14=ysav
9026  ysav=y23
9027  y23=y24
9028  y24=ysav
9029  ysav=y123
9030  y123=y124
9031  y124=ysav
9032  ENDIF
9033  IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
9034  ysav=y13
9035  y13=y23
9036  y23=ysav
9037  ysav=y14
9038  y14=y24
9039  y24=ysav
9040  ysav=y134
9041  y134=y234
9042  y234=ysav
9043  ENDIF
9044  IF(ic.LE.3) goto 120
9045  IF(id.EQ.1.AND.wttot.LT.rlu(0)*wtmx) goto 110
9046  ic=5
9047 
9048 C...qqgg events: string configuration and event type.
9049  IF(it.EQ.1) THEN
9050  IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
9051  parj(156)=y34*(2.*(wta(1)+wta(2)+wta(3)+wta(4))+4.*(wtc(1)+
9052  & wtc(2)+wtc(3)+wtc(4)))/(9.*wttot)
9053  IF(wta(2)+wta(4)+2.*(wtc(2)+wtc(4)).GT.rlu(0)*(wta(1)+wta(2)+
9054  & wta(3)+wta(4)+2.*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
9055  IF(id.EQ.2) goto 130
9056  ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
9057  parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8.*wttot)
9058  IF(wta(2)+wta(4).GT.rlu(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
9059  IF(id.EQ.2) goto 130
9060  ENDIF
9061  mstj(120)=3
9062  IF(mstj(109).EQ.0.AND.0.5*y34*(wtc(1)+wtc(2)+wtc(3)+wtc(4)).GT.
9063  & rlu(0)*wttot) mstj(120)=4
9064  kfln=21
9065 
9066 C...Mass cuts. Kinematical variables out.
9067  IF(y12.LE.cut+qme) njet=2
9068  IF(njet.EQ.2) goto 150
9069  q12=0.5*(1.-sqrt(1.-qme/y12))
9070  x1=1.-(1.-q12)*y234-q12*y134
9071  x4=1.-(1.-q12)*y134-q12*y234
9072  x2=1.-y124
9073  x12=(1.-q12)*y13+q12*y23
9074  x14=y12-0.5*qme
9075  IF(y134*y234/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
9076 
9077 C...qqbarqqbar events: string configuration, choose new flavour.
9078  ELSE
9079  IF(id.EQ.1) THEN
9080  wtr=rlu(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
9081  IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
9082  IF(wtr.LT.wtd(3)+wtd(4)) id=3
9083  IF(wtr.LT.wtd(4)) id=4
9084  IF(id.GE.2) goto 130
9085  ENDIF
9086  mstj(120)=5
9087  parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16.*wttot)
9088  140 kfln=1+int(5.*rlu(0))
9089  IF(kfln.NE.kfl.AND.0.2*parj(156).LE.rlu(0)) goto 140
9090  IF(kfln.EQ.kfl.AND.1.-0.8*parj(156).LE.rlu(0)) goto 140
9091  IF(kfln.GT.mstj(104)) njet=2
9092  pmqn=ulmass(kfln)
9093  qmen=(2.*pmqn/ecm)**2
9094 
9095 C...Mass cuts. Kinematical variables out.
9096  IF(y24.LE.cut+qme.OR.y13.LE.1.1*qmen) njet=2
9097  IF(njet.EQ.2) goto 150
9098  q24=0.5*(1.-sqrt(1.-qme/y24))
9099  q13=0.5*(1.-sqrt(1.-qmen/y13))
9100  x1=1.-(1.-q24)*y123-q24*y134
9101  x4=1.-(1.-q24)*y134-q24*y123
9102  x2=1.-(1.-q13)*y234-q13*y124
9103  x12=(1.-q24)*((1.-q13)*y14+q13*y34)+q24*((1.-q13)*y12+q13*y23)
9104  x14=y24-0.5*qme
9105  x34=(1.-q24)*((1.-q13)*y23+q13*y12)+q24*((1.-q13)*y34+q13*y14)
9106  IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
9107  & (parj(127)+pmq+pmqn)**2) njet=2
9108  IF(y123*y134/((1.-x1)*(1.-x4)).LE.rlu(0)) njet=2
9109  ENDIF
9110  150 IF(mstj(101).LE.-2.AND.njet.EQ.2) goto 100
9111 
9112  RETURN
9113  END
9114 
9115 C*********************************************************************
9116 
9117  SUBROUTINE luxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
9118 
9119 C...Purpose: to give the angular orientation of events.
9120  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
9121  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9122  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9123  SAVE /lujets/,/ludat1/,/ludat2/
9124 
9125 C...Charge. Factors depending on polarization for QED case.
9126  qf=kchg(kfl,1)/3.
9127  poll=1.-parj(131)*parj(132)
9128  pold=parj(132)-parj(131)
9129  IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
9130  hf1=poll
9131  hf2=0.
9132  hf3=parj(133)**2
9133  hf4=0.
9134 
9135 C...Factors depending on flavour, energy and polarization for QFD case.
9136  ELSE
9137  sff=1./(16.*paru(102)*(1.-paru(102)))
9138  sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
9139  sfi=sfw*(1.-(parj(123)/ecm)**2)
9140  ae=-1.
9141  ve=4.*paru(102)-1.
9142  af=sign(1.,qf)
9143  vf=af-4.*qf*paru(102)
9144  hf1=qf**2*poll-2.*qf*vf*sfi*sff*(ve*poll-ae*pold)+
9145  & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2.*ve*ae*pold)
9146  hf2=-2.*qf*af*sfi*sff*(ae*poll-ve*pold)+2.*vf*af*sfw*sff**2*
9147  & (2.*ve*ae*poll-(ve**2+ae**2)*pold)
9148  hf3=parj(133)**2*(qf**2-2.*qf*vf*sfi*sff*ve+(vf**2+af**2)*
9149  & sfw*sff**2*(ve**2-ae**2))
9150  hf4=-parj(133)**2*2.*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
9151  & sff*ae
9152  ENDIF
9153 
9154 C...Mass factor. Differential cross-sections for two-jet events.
9155  sq2=sqrt(2.)
9156  qme=0.
9157  IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
9158  &mstj(109).NE.1) qme=(2.*ulmass(kfl)/ecm)**2
9159  IF(njet.EQ.2) THEN
9160  sigu=4.*sqrt(1.-qme)
9161  sigl=2.*qme*sqrt(1.-qme)
9162  sigt=0.
9163  sigi=0.
9164  siga=0.
9165  sigp=4.
9166 
9167 C...Kinematical variables. Reduce four-jet event to three-jet one.
9168  ELSE
9169  IF(njet.EQ.3) THEN
9170  x1=2.*p(nc+1,4)/ecm
9171  x2=2.*p(nc+3,4)/ecm
9172  ELSE
9173  ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
9174  & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
9175  x1=2.*p(nc+1,4)/ecmr
9176  x2=2.*p(nc+4,4)/ecmr
9177  ENDIF
9178 
9179 C...Differential cross-sections for three-jet (or reduced four-jet).
9180  xq=(1.-x1)/(1.-x2)
9181  ct12=(x1*x2-2.*x1-2.*x2+2.+qme)/sqrt((x1**2-qme)*(x2**2-qme))
9182  st12=sqrt(1.-ct12**2)
9183  IF(mstj(109).NE.1) THEN
9184  sigu=2.*x1**2+x2**2*(1.+ct12**2)-qme*(3.+ct12**2-x1-x2)-
9185  & qme*x1/xq+0.5*qme*((x2**2-qme)*st12**2-2.*x2)*xq
9186  sigl=(x2*st12)**2-qme*(3.-ct12**2-2.5*(x1+x2)+x1*x2+qme)+
9187  & 0.5*qme*(x1**2-x1-qme)/xq+0.5*qme*((x2**2-qme)*ct12**2-x2)*xq
9188  sigt=0.5*(x2**2-qme-0.5*qme*(x2**2-qme)/xq)*st12**2
9189  sigi=((1.-0.5*qme*xq)*(x2**2-qme)*st12*ct12+qme*(1.-x1-x2+
9190  & 0.5*x1*x2+0.5*qme)*st12/ct12)/sq2
9191  siga=x2**2*st12/sq2
9192  sigp=2.*(x1**2-x2**2*ct12)
9193 
9194 C...Differential cross-sect for scalar gluons (no mass effects).
9195  ELSE
9196  x3=2.-x1-x2
9197  xt=x2*st12
9198  ct13=sqrt(max(0.,1.-(xt/x3)**2))
9199  sigu=(1.-parj(171))*(x3**2-0.5*xt**2)+
9200  & parj(171)*(x3**2-0.5*xt**2-4.*(1.-x1)*(1.-x2)**2/x1)
9201  sigl=(1.-parj(171))*0.5*xt**2+
9202  & parj(171)*0.5*(1.-x1)**2*xt**2
9203  sigt=(1.-parj(171))*0.25*xt**2+
9204  & parj(171)*0.25*xt**2*(1.-2.*x1)
9205  sigi=-(0.5/sq2)*((1.-parj(171))*xt*x3*ct13+
9206  & parj(171)*xt*((1.-2.*x1)*x3*ct13-x1*(x1-x2)))
9207  siga=(0.25/sq2)*xt*(2.*(1.-x1)-x1*x3)
9208  sigp=x3**2-2.*(1.-x1)*(1.-x2)/x1
9209  ENDIF
9210  ENDIF
9211 
9212 C...Upper bounds for differential cross-section.
9213  hf1a=abs(hf1)
9214  hf2a=abs(hf2)
9215  hf3a=abs(hf3)
9216  hf4a=abs(hf4)
9217  sigmax=(2.*hf1a+hf3a+hf4a)*abs(sigu)+2.*(hf1a+hf3a+hf4a)*
9218  &abs(sigl)+2.*(hf1a+2.*hf3a+2.*hf4a)*abs(sigt)+2.*sq2*
9219  &(hf1a+2.*hf3a+2.*hf4a)*abs(sigi)+4.*sq2*hf2a*abs(siga)+
9220  &2.*hf2a*abs(sigp)
9221 
9222 C...Generate angular orientation according to differential cross-sect.
9223  100 chi=paru(2)*rlu(0)
9224  cthe=2.*rlu(0)-1.
9225  phi=paru(2)*rlu(0)
9226  cchi=cos(chi)
9227  schi=sin(chi)
9228  c2chi=cos(2.*chi)
9229  s2chi=sin(2.*chi)
9230  the=acos(cthe)
9231  sthe=sin(the)
9232  c2phi=cos(2.*(phi-parj(134)))
9233  s2phi=sin(2.*(phi-parj(134)))
9234  sig=((1.+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
9235  &2.*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
9236  &2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*c2chi*c2phi-2.*cthe*s2chi*
9237  &s2phi)*hf3-((1.+cthe**2)*c2chi*s2phi+2.*cthe*s2chi*c2phi)*hf4)*
9238  &sigt-2.*sq2*(2.*sthe*cthe*cchi*hf1-2.*sthe*(cthe*cchi*c2phi-
9239  &schi*s2phi)*hf3+2.*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
9240  &4.*sq2*sthe*cchi*hf2*siga+2.*cthe*hf2*sigp
9241  IF(sig.LT.sigmax*rlu(0)) goto 100
9242 
9243  RETURN
9244  END
9245 
9246 C*********************************************************************
9247 
9248  SUBROUTINE luonia(KFL,ECM)
9249 
9250 C...Purpose: to generate Upsilon and toponium decays into three
9251 C...gluons or two gluons and a photon.
9252  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
9253  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9254  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9255  SAVE /lujets/,/ludat1/,/ludat2/
9256 
9257 C...Printout. Check input parameters.
9258  IF(mstu(12).GE.1) CALL lulist(0)
9259  IF(kfl.LT.0.OR.kfl.GT.8) THEN
9260  CALL luerrm(16,'(LUONIA:) called with unknown flavour code')
9261  IF(mstu(21).GE.1) RETURN
9262  ENDIF
9263  IF(ecm.LT.parj(127)+2.02*parf(101)) THEN
9264  CALL luerrm(16,'(LUONIA:) called with too small CM energy')
9265  IF(mstu(21).GE.1) RETURN
9266  ENDIF
9267 
9268 C...Initial e+e- and onium state (optional).
9269  nc=0
9270  IF(mstj(115).GE.2) THEN
9271  nc=nc+2
9272  CALL lu1ent(nc-1,11,0.5*ecm,0.,0.)
9273  k(nc-1,1)=21
9274  CALL lu1ent(nc,-11,0.5*ecm,paru(1),0.)
9275  k(nc,1)=21
9276  ENDIF
9277  kflc=iabs(kfl)
9278  IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
9279  nc=nc+1
9280  kf=110*kflc+3
9281  mstu10=mstu(10)
9282  mstu(10)=1
9283  p(nc,5)=ecm
9284  CALL lu1ent(nc,kf,ecm,0.,0.)
9285  k(nc,1)=21
9286  k(nc,3)=1
9287  mstu(10)=mstu10
9288  ENDIF
9289 
9290 C...Choose x1 and x2 according to matrix element.
9291  ntry=0
9292  100 x1=rlu(0)
9293  x2=rlu(0)
9294  x3=2.-x1-x2
9295  IF(x3.GE.1..OR.((1.-x1)/(x2*x3))**2+((1.-x2)/(x1*x3))**2+
9296  &((1.-x3)/(x1*x2))**2.LE.2.*rlu(0)) goto 100
9297  ntry=ntry+1
9298  njet=3
9299  IF(mstj(101).LE.4) CALL lu3ent(nc+1,21,21,21,ecm,x1,x3)
9300  IF(mstj(101).GE.5) CALL lu3ent(-(nc+1),21,21,21,ecm,x1,x3)
9301 
9302 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
9303  mstu(111)=mstj(108)
9304  IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
9305  &mstu(111)=1
9306  paru(112)=parj(121)
9307  IF(mstu(111).EQ.2) paru(112)=parj(122)
9308  qf=0.
9309  IF(kflc.NE.0) qf=kchg(kflc,1)/3.
9310  rgam=7.2*qf**2*paru(101)/ulalps(ecm**2)
9311  mk=0
9312  ecmc=ecm
9313  IF(rlu(0).GT.rgam/(1.+rgam)) THEN
9314  IF(1.-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
9315  & njet=2
9316  IF(njet.EQ.2.AND.mstj(101).LE.4) CALL lu2ent(nc+1,21,21,ecm)
9317  IF(njet.EQ.2.AND.mstj(101).GE.5) CALL lu2ent(-(nc+1),21,21,ecm)
9318  ELSE
9319  mk=1
9320  ecmc=sqrt(1.-x1)*ecm
9321  IF(ecmc.LT.2.*parj(127)) goto 100
9322  k(nc+1,1)=1
9323  k(nc+1,2)=22
9324  k(nc+1,4)=0
9325  k(nc+1,5)=0
9326  IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
9327  IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
9328  IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
9329  IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
9330  njet=2
9331  IF(ecmc.LT.4.*parj(127)) THEN
9332  mstu10=mstu(10)
9333  mstu(10)=1
9334  p(nc+2,5)=ecmc
9335  CALL lu1ent(nc+2,83,0.5*(x2+x3)*ecm,paru(1),0.)
9336  mstu(10)=mstu10
9337  njet=0
9338  ENDIF
9339  ENDIF
9340  DO 110 ip=nc+1,n
9341  k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
9342  110 CONTINUE
9343 
9344 C...Differential cross-sections. Upper limit for cross-section.
9345  IF(mstj(106).EQ.1) THEN
9346  sq2=sqrt(2.)
9347  hf1=1.-parj(131)*parj(132)
9348  hf3=parj(133)**2
9349  ct13=(x1*x3-2.*x1-2.*x3+2.)/(x1*x3)
9350  st13=sqrt(1.-ct13**2)
9351  sigl=0.5*x3**2*((1.-x2)**2+(1.-x3)**2)*st13**2
9352  sigu=(x1*(1.-x1))**2+(x2*(1.-x2))**2+(x3*(1.-x3))**2-sigl
9353  sigt=0.5*sigl
9354  sigi=(sigl*ct13/st13+0.5*x1*x3*(1.-x2)**2*st13)/sq2
9355  sigmax=(2.*hf1+hf3)*abs(sigu)+2.*(hf1+hf3)*abs(sigl)+2.*(hf1+
9356  & 2.*hf3)*abs(sigt)+2.*sq2*(hf1+2.*hf3)*abs(sigi)
9357 
9358 C...Angular orientation of event.
9359  120 chi=paru(2)*rlu(0)
9360  cthe=2.*rlu(0)-1.
9361  phi=paru(2)*rlu(0)
9362  cchi=cos(chi)
9363  schi=sin(chi)
9364  c2chi=cos(2.*chi)
9365  s2chi=sin(2.*chi)
9366  the=acos(cthe)
9367  sthe=sin(the)
9368  c2phi=cos(2.*(phi-parj(134)))
9369  s2phi=sin(2.*(phi-parj(134)))
9370  sig=((1.+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2.*(sthe**2*hf1-
9371  & sthe**2*c2phi*hf3)*sigl+2.*(sthe**2*c2chi*hf1+((1.+cthe**2)*
9372  & c2chi*c2phi-2.*cthe*s2chi*s2phi)*hf3)*sigt-2.*sq2*(2.*sthe*cthe*
9373  & cchi*hf1-2.*sthe*(cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
9374  IF(sig.LT.sigmax*rlu(0)) goto 120
9375  CALL ludbrb(nc+1,n,0.,chi,0d0,0d0,0d0)
9376  CALL ludbrb(nc+1,n,the,phi,0d0,0d0,0d0)
9377  ENDIF
9378 
9379 C...Generate parton shower. Rearrange along strings and check.
9380  IF(mstj(101).GE.5.AND.njet.GE.2) THEN
9381  CALL lushow(nc+mk+1,-njet,ecmc)
9382  mstj14=mstj(14)
9383  IF(mstj(105).EQ.-1) mstj(14)=-1
9384  IF(mstj(105).GE.0) mstu(28)=0
9385  CALL luprep(0)
9386  mstj(14)=mstj14
9387  IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100
9388  ENDIF
9389 
9390 C...Generate fragmentation. Information for LUTABU:
9391  IF(mstj(105).EQ.1) CALL luexec
9392  mstu(161)=110*kflc+3
9393  mstu(162)=0
9394 
9395  RETURN
9396  END
9397 
9398 C*********************************************************************
9399 
9400  SUBROUTINE luhepc(MCONV)
9401 
9402 C...Purpose: to convert JETSET event record contents to or from
9403 C...the standard event record commonblock.
9404 C...Note that HEPEVT is in double precision according to LEP 2 standard.
9405  parameter(nmxhep=2000)
9406  common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
9407  &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
9408  DOUBLE PRECISION phep,vhep
9409  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
9410  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9411  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9412  SAVE /hepevt/
9413  SAVE /lujets/,/ludat1/,/ludat2/
9414 
9415 C...Conversion from JETSET to standard, the easy part.
9416  IF(mconv.EQ.1) THEN
9417  nevhep=0
9418  IF(n.GT.nmxhep) CALL luerrm(8,
9419  & '(LUHEPC:) no more space in /HEPEVT/')
9420  nhep=min(n,nmxhep)
9421  DO 140 i=1,nhep
9422  isthep(i)=0
9423  IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
9424  IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
9425  IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
9426  IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
9427  idhep(i)=k(i,2)
9428  jmohep(1,i)=k(i,3)
9429  jmohep(2,i)=0
9430  IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
9431  jdahep(1,i)=k(i,4)
9432  jdahep(2,i)=k(i,5)
9433  ELSE
9434  jdahep(1,i)=0
9435  jdahep(2,i)=0
9436  ENDIF
9437  DO 100 j=1,5
9438  phep(j,i)=p(i,j)
9439  100 CONTINUE
9440  DO 110 j=1,4
9441  vhep(j,i)=v(i,j)
9442  110 CONTINUE
9443 
9444 C...Check if new event (from pileup).
9445  IF(i.EQ.1) THEN
9446  inew=1
9447  ELSE
9448  IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i
9449  ENDIF
9450 
9451 C...Fill in missing mother information.
9452  IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
9453  imo1=i-2
9454  IF(i.GE.inew+3.AND.k(i-1,1).EQ.21.AND.k(i-1,3).EQ.0)
9455  & imo1=imo1-1
9456  jmohep(1,i)=imo1
9457  jmohep(2,i)=imo1+1
9458  ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
9459  i1=k(i,3)-1
9460  120 i1=i1+1
9461  IF(i1.GE.i) CALL luerrm(8,
9462  & '(LUHEPC:) translation of inconsistent event history')
9463  IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) goto 120
9464  kc=lucomp(k(i1,2))
9465  IF(i1.LT.i.AND.kc.EQ.0) goto 120
9466  IF(i1.LT.i.AND.kchg(kc,2).EQ.0) goto 120
9467  jmohep(2,i)=i1
9468  ELSEIF(k(i,2).EQ.94) THEN
9469  njet=2
9470  IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
9471  IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
9472  jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
9473  IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
9474  & mod(k(i+1,4)/mstu(5),mstu(5))
9475  ENDIF
9476 
9477 C...Fill in missing daughter information.
9478  IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
9479  DO 130 i1=jdahep(1,i),jdahep(2,i)
9480  i2=mod(k(i1,4)/mstu(5),mstu(5))
9481  jdahep(1,i2)=i
9482  130 CONTINUE
9483  ENDIF
9484  IF(k(i,2).GE.91.AND.k(i,2).LE.94) goto 140
9485  i1=jmohep(1,i)
9486  IF(i1.LE.0.OR.i1.GT.nhep) goto 140
9487  IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) goto 140
9488  IF(jdahep(1,i1).EQ.0) THEN
9489  jdahep(1,i1)=i
9490  ELSE
9491  jdahep(2,i1)=i
9492  ENDIF
9493  140 CONTINUE
9494  DO 150 i=1,nhep
9495  IF(k(i,1).NE.13.AND.k(i,1).NE.14) goto 150
9496  IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
9497  150 CONTINUE
9498 
9499 C...Conversion from standard to JETSET, the easy part.
9500  ELSE
9501  IF(nhep.GT.mstu(4)) CALL luerrm(8,
9502  & '(LUHEPC:) no more space in /LUJETS/')
9503  n=min(nhep,mstu(4))
9504  nkq=0
9505  kqsum=0
9506  DO 180 i=1,n
9507  k(i,1)=0
9508  IF(isthep(i).EQ.1) k(i,1)=1
9509  IF(isthep(i).EQ.2) k(i,1)=11
9510  IF(isthep(i).EQ.3) k(i,1)=21
9511  k(i,2)=idhep(i)
9512  k(i,3)=jmohep(1,i)
9513  k(i,4)=jdahep(1,i)
9514  k(i,5)=jdahep(2,i)
9515  DO 160 j=1,5
9516  p(i,j)=phep(j,i)
9517  160 CONTINUE
9518  DO 170 j=1,4
9519  v(i,j)=vhep(j,i)
9520  170 CONTINUE
9521  v(i,5)=0.
9522  IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
9523  i1=jdahep(1,i)
9524  IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
9525  & phep(5,i)/phep(4,i)
9526  ENDIF
9527 
9528 C...Fill in missing information on colour connection in jet systems.
9529  IF(isthep(i).EQ.1) THEN
9530  kc=lucomp(k(i,2))
9531  kq=0
9532  IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
9533  IF(kq.NE.0) nkq=nkq+1
9534  IF(kq.NE.2) kqsum=kqsum+kq
9535  IF(kq.NE.0.AND.kqsum.NE.0) THEN
9536  k(i,1)=2
9537  ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
9538  IF(k(i+1,2).EQ.21) k(i,1)=2
9539  ENDIF
9540  ENDIF
9541  180 CONTINUE
9542  IF(nkq.EQ.1.OR.kqsum.NE.0) CALL luerrm(8,
9543  & '(LUHEPC:) input parton configuration not colour singlet')
9544  ENDIF
9545 
9546  END
9547 
9548 C*********************************************************************
9549 
9550  SUBROUTINE lutest(MTEST)
9551 
9552 C...Purpose: to provide a simple program (disguised as subroutine) to
9553 C...run at installation as a check that the program works as intended.
9554  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
9555  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9556  SAVE /lujets/,/ludat1/
9557  dimension psum(5),pini(6),pfin(6)
9558 
9559 C...Loop over events to be generated.
9560  IF(mtest.GE.1) CALL lutabu(20)
9561  nerr=0
9562  DO 180 iev=1,600
9563 
9564 C...Reset parameter values. Switch on some nonstandard features.
9565  mstj(1)=1
9566  mstj(3)=0
9567  mstj(11)=1
9568  mstj(42)=2
9569  mstj(43)=4
9570  mstj(44)=2
9571  parj(17)=0.1
9572  parj(22)=1.5
9573  parj(43)=1.
9574  parj(54)=-0.05
9575  mstj(101)=5
9576  mstj(104)=5
9577  mstj(105)=0
9578  mstj(107)=1
9579  IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
9580 
9581 C...Ten events each for some single jets configurations.
9582  IF(iev.LE.50) THEN
9583  ity=(iev+9)/10
9584  mstj(3)=-1
9585  IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
9586  IF(ity.EQ.1) CALL lu1ent(1,1,15.,0.,0.)
9587  IF(ity.EQ.2) CALL lu1ent(1,3101,15.,0.,0.)
9588  IF(ity.EQ.3) CALL lu1ent(1,-2203,15.,0.,0.)
9589  IF(ity.EQ.4) CALL lu1ent(1,-4,30.,0.,0.)
9590  IF(ity.EQ.5) CALL lu1ent(1,21,15.,0.,0.)
9591 
9592 C...Ten events each for some simple jet systems; string fragmentation.
9593  ELSEIF(iev.LE.130) THEN
9594  ity=(iev-41)/10
9595  IF(ity.EQ.1) CALL lu2ent(1,1,-1,40.)
9596  IF(ity.EQ.2) CALL lu2ent(1,4,-4,30.)
9597  IF(ity.EQ.3) CALL lu2ent(1,2,2103,100.)
9598  IF(ity.EQ.4) CALL lu2ent(1,21,21,40.)
9599  IF(ity.EQ.5) CALL lu3ent(1,2101,21,-3203,30.,0.6,0.8)
9600  IF(ity.EQ.6) CALL lu3ent(1,5,21,-5,40.,0.9,0.8)
9601  IF(ity.EQ.7) CALL lu3ent(1,21,21,21,60.,0.7,0.5)
9602  IF(ity.EQ.8) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9603 
9604 C...Seventy events with independent fragmentation and momentum cons.
9605  ELSEIF(iev.LE.200) THEN
9606  ity=1+(iev-131)/16
9607  mstj(2)=1+mod(iev-131,4)
9608  mstj(3)=1+mod((iev-131)/4,4)
9609  IF(ity.EQ.1) CALL lu2ent(1,4,-5,40.)
9610  IF(ity.EQ.2) CALL lu3ent(1,3,21,-3,40.,0.9,0.4)
9611  IF(ity.EQ.3) CALL lu4ent(1,2,21,21,-2,40.,0.4,0.64,0.6,0.12,0.2)
9612  IF(ity.GE.4) CALL lu4ent(1,2,-3,3,-2,40.,0.4,0.64,0.6,0.12,0.2)
9613 
9614 C...A hundred events with random jets (check invariant mass).
9615  ELSEIF(iev.LE.300) THEN
9616  100 DO 110 j=1,5
9617  psum(j)=0.
9618  110 CONTINUE
9619  njet=2.+6.*rlu(0)
9620  DO 130 i=1,njet
9621  kfl=21
9622  IF(i.EQ.1) kfl=int(1.+4.*rlu(0))
9623  IF(i.EQ.njet) kfl=-int(1.+4.*rlu(0))
9624  ejet=5.+20.*rlu(0)
9625  theta=acos(2.*rlu(0)-1.)
9626  phi=6.2832*rlu(0)
9627  IF(i.LT.njet) CALL lu1ent(-i,kfl,ejet,theta,phi)
9628  IF(i.EQ.njet) CALL lu1ent(i,kfl,ejet,theta,phi)
9629  IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1
9630  IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+ulmass(kfl)
9631  DO 120 j=1,4
9632  psum(j)=psum(j)+p(i,j)
9633  120 CONTINUE
9634  130 CONTINUE
9635  IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
9636  & (psum(5)+parj(32))**2) goto 100
9637 
9638 C...Fifty e+e- continuum events with matrix elements.
9639  ELSEIF(iev.LE.350) THEN
9640  mstj(101)=2
9641  CALL lueevt(0,40.)
9642 
9643 C...Fifty e+e- continuum event with varying shower options.
9644  ELSEIF(iev.LE.400) THEN
9645  mstj(42)=1+mod(iev,2)
9646  mstj(43)=1+mod(iev/2,4)
9647  mstj(44)=mod(iev/8,3)
9648  CALL lueevt(0,90.)
9649 
9650 C...Fifty e+e- continuum events with coherent shower, including top.
9651  ELSEIF(iev.LE.450) THEN
9652  mstj(104)=6
9653  CALL lueevt(0,500.)
9654 
9655 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
9656  ELSEIF(iev.LE.500) THEN
9657  CALL luonia(5,9.46)
9658 
9659 C...One decay each for some heavy mesons.
9660  ELSEIF(iev.LE.560) THEN
9661  ity=iev-501
9662  kfls=2*(ity/20)+1
9663  kflb=8-mod(ity/5,4)
9664  kflc=kflb-mod(ity,5)
9665  CALL lu1ent(1,100*kflb+10*kflc+kfls,0.,0.,0.)
9666 
9667 C...One decay each for some heavy baryons.
9668  ELSEIF(iev.LE.600) THEN
9669  ity=iev-561
9670  kfls=2*(ity/20)+2
9671  kfla=8-mod(ity/5,4)
9672  kflb=kfla-mod(ity,5)
9673  kflc=max(1,kflb-1)
9674  CALL lu1ent(1,1000*kfla+100*kflb+10*kflc+kfls,0.,0.,0.)
9675  ENDIF
9676 
9677 C...Generate event. Find total momentum, energy and charge.
9678  DO 140 j=1,4
9679  pini(j)=plu(0,j)
9680  140 CONTINUE
9681  pini(6)=plu(0,6)
9682  CALL luexec
9683  DO 150 j=1,4
9684  pfin(j)=plu(0,j)
9685  150 CONTINUE
9686  pfin(6)=plu(0,6)
9687 
9688 C...Check conservation of energy, momentum and charge;
9689 C...usually exact, but only approximate for single jets.
9690  merr=0
9691  IF(iev.LE.50) THEN
9692  IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.4.) merr=merr+1
9693  epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
9694  IF(epzrem.LT.0..OR.epzrem.GT.2.*parj(31)) merr=merr+1
9695  IF(abs(pfin(6)-pini(6)).GT.2.1) merr=merr+1
9696  ELSE
9697  DO 160 j=1,4
9698  IF(abs(pfin(j)-pini(j)).GT.0.0001*pini(4)) merr=merr+1
9699  160 CONTINUE
9700  IF(abs(pfin(6)-pini(6)).GT.0.1) merr=merr+1
9701  ENDIF
9702  IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
9703  &(pfin(j),j=1,4),pfin(6)
9704 
9705 C...Check that all KF codes are known ones, and that partons/particles
9706 C...satisfy energy-momentum-mass relation. Store particle statistics.
9707  DO 170 i=1,n
9708  IF(k(i,1).GT.20) goto 170
9709  IF(lucomp(k(i,2)).EQ.0) THEN
9710  WRITE(mstu(11),5100) i
9711  merr=merr+1
9712  ENDIF
9713  pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
9714  IF(abs(pd).GT.max(0.1,0.001*p(i,4)**2).OR.p(i,4).LT.0.) THEN
9715  WRITE(mstu(11),5200) i
9716  merr=merr+1
9717  ENDIF
9718  170 CONTINUE
9719  IF(mtest.GE.1) CALL lutabu(21)
9720 
9721 C...List all erroneous events and some normal ones.
9722  IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
9723  CALL lulist(2)
9724  ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
9725  CALL lulist(1)
9726  ENDIF
9727 
9728 C...Stop execution if too many errors.
9729  IF(merr.NE.0) nerr=nerr+1
9730  IF(nerr.GE.10) THEN
9731  WRITE(mstu(11),5300) iev
9732  stop
9733  ENDIF
9734  180 CONTINUE
9735 
9736 C...Summarize result of run.
9737  IF(mtest.GE.1) CALL lutabu(22)
9738  IF(nerr.EQ.0) WRITE(mstu(11),5400)
9739  IF(nerr.GT.0) WRITE(mstu(11),5500) nerr
9740 
9741 C...Reset commonblock variables changed during run.
9742  mstj(2)=3
9743  parj(17)=0.
9744  parj(22)=1.
9745  parj(43)=0.5
9746  parj(54)=0.
9747  mstj(105)=1
9748  mstj(107)=0
9749 
9750 C...Format statements for output.
9751  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
9752  &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
9753  &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
9754  &4(1x,f12.5),1x,f8.2)
9755  5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
9756  5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
9757  &'kinematics')
9758  5300 FORMAT(/5x,'Ten errors experienced by event ',i3/
9759  &5x,'Something is seriously wrong! Execution stopped now!')
9760  5400 FORMAT(//5x,'End result of LUTEST: no errors detected.')
9761  5500 FORMAT(//5x,'End result of LUTEST:',i2,' errors detected.'/
9762  &5x,'This should not have happened!')
9763 
9764  RETURN
9765  END
9766 
9767 C*********************************************************************
9768 
9769  BLOCK DATA ludata
9770 
9771 C...Purpose: to give default values to parameters and particle and
9772 C...decay data.
9773  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
9774  common/ludat2/kchg(500,3),pmas(500,4),parf(2000),vckm(4,4)
9775  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
9776  common/ludat4/chaf(500)
9777  CHARACTER chaf*8
9778  common/ludatr/mrlu(6),rrlu(100)
9779  SAVE /ludat1/,/ludat2/,/ludat3/,/ludat4/,/ludatr/
9780 
9781 C...LUDAT1, containing status codes and most parameters.
9782  DATA mstu/
9783  & 0, 0, 0, 4000,10000, 500, 2000, 0, 0, 2,
9784  1 6, 1, 1, 0, 1, 1, 0, 0, 0, 0,
9785  2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
9786  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9787  4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
9788  5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
9789  6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9790  7 30*0,
9791  & 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9792  1 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
9793  2 60*0,
9794  8 7, 408, 1995, 08, 23, 700, 0, 0, 0, 0,
9795  9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
9796  DATA paru/
9797  & 3.1415927, 6.2831854, 0.1973, 5.068, 0.3894, 2.568, 4*0.,
9798  1 0.001, 0.09, 0.01, 0., 0., 0., 0., 0., 0., 0.,
9799  2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9800  3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9801  4 2.0, 1.0, 0.25, 2.5, 0.05, 0., 0., 0.0001, 0., 0.,
9802  5 2.5, 1.5, 7.0, 1.0, 0.5, 2.0, 3.2, 0., 0., 0.,
9803  6 40*0.,
9804  & 0.00729735, 0.232, 0.007764, 1.0, 1.16639e-5, 0., 0., 0.,
9805  & 0., 0.,
9806  1 0.20, 0.25, 1.0, 4.0, 10., 0., 0., 0., 0., 0.,
9807  2 -0.693, -1.0, 0.387, 1.0, -0.08, -1.0, 1.0, 1.0, 1.0, 0.,
9808  3 1.0, -1.0, 1.0, -1.0, 1.0, 0., 0., 0., 0., 0.,
9809  4 5.0, 1.0, 1.0, 0., 1.0, 1.0, 0., 0., 0., 0.,
9810  5 1.0, 0., 0., 0., 1000., 1.0, 1.0, 1.0, 1.0, 0.,
9811  6 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0., 0., 0.,
9812  7 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0., 0., 0.,
9813  8 1.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.,
9814  9 0., 0., 0., 0., 1.0, 0., 0., 0., 0., 0./
9815  DATA mstj/
9816  & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
9817  1 4, 2, 0, 1, 0, 0, 0, 0, 0, 0,
9818  2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
9819  3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9820  4 2, 2, 4, 2, 5, 3, 3, 0, 0, 0,
9821  5 0, 3, 0, 0, 0, 0, 0, 0, 0, 0,
9822  6 40*0,
9823  & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
9824  1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
9825  2 80*0/
9826  DATA parj/
9827  & 0.10, 0.30, 0.40, 0.05, 0.50, 0.50, 0.50, 0., 0., 0.,
9828  1 0.50, 0.60, 0.75, 0., 0., 0., 0., 1.0, 1.0, 0.,
9829  2 0.36, 1.0, 0.01, 2.0, 1.0, 0.4, 0., 0., 0., 0.,
9830  3 0.10, 1.0, 0.8, 1.5, 0., 2.0, 0.2, 2.5, 0.6, 0.,
9831  4 0.3, 0.58, 0.5, 0.9, 0.5, 1.0, 1.0, 1.0, 0., 0.,
9832  5 0.77,0.77,0.77,-0.05,-0.005,-0.00001,-0.00001,-0.00001,1.0,0.,
9833  6 4.5, 0.7, 0., 0.003, 0.5, 0.5, 0., 0., 0., 0.,
9834  7 10., 1000., 100., 1000., 0., 0.7, 10., 0., 0., 0.,
9835  8 0.29, 1.0, 1.0, 0., 10., 10., 0., 0., 0., 0.,
9836  9 0.02, 1.0, 0.2, 0., 0., 0., 0., 0., 0., 0.,
9837  & 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9838  1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9839  2 1.0, 0.25,91.187,2.489, 0.01, 2.0, 1.0, 0.25,0.002, 0.,
9840  3 0., 0., 0., 0., 0.01, 0.99, 0., 0., 0.2, 0.,
9841  4 60*0./
9842 
9843 C...LUDAT2, with particle data and flavour treatment parameters.
9844  DATA (kchg(i,1),i= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
9845  &-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,
9846  &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,
9847  &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,
9848  &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,
9849  &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,
9850  &-3,0,3,-3,0,-3,114*0/
9851  DATA (kchg(i,2),i= 1, 500)/8*1,12*0,2,16*0,2,1,50*0,-1,410*0/
9852  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,
9853  &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,
9854  &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,
9855  &0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
9856  DATA (pmas(i,1),i= 1, 500)/0.0099,0.0056,0.199,1.35,5.,160.,
9857  &2*250.,2*0.,0.00051,0.,0.1057,0.,1.777,0.,250.,5*0.,91.187,80.25,
9858  &80.,6*0.,500.,900.,500.,3*300.,350.,200.,5000.,60*0.,0.1396,
9859  &0.4977,0.4936,1.8693,1.8645,1.9688,5.2787,5.2786,5.47972,6.594,
9860  &0.135,0.5475,0.9578,2.9788,9.4,320.,2*500.,2*0.,0.7669,0.8961,
9861  &0.8916,2.0101,2.0071,2.11,2*5.325,5.5068,6.602,0.7683,0.782,
9862  &1.0194,3.0969,9.4603,320.,2*500.,2*0.,1.232,2*1.29,2*2.424,2.536,
9863  &2*5.73,5.97,7.3,1.232,1.17,1.4,3.46,9.875,320.,2*500.,2*0.,0.983,
9864  &2*1.429,2*2.272,2.5,2*5.68,5.92,7.25,0.9827,1.,1.4,3.4151,9.8598,
9865  &320.,2*500.,2*0.,1.26,2*1.402,2*2.372,2.56,2*5.78,6.02,7.3,1.26,
9866  &1.282,1.42,3.5106,9.8919,320.,2*500.,2*0.,1.318,1.432,1.425,
9867  &2*2.46,2.61,2*5.83,6.07,7.35,1.318,1.275,1.525,3.5562,9.9132,
9868  &320.,2*500.,2*0.,2*0.4977,8*0.,3.686,3*0.,10.0233,70*0.,1.1156,
9869  &5*0.,2.2849,0.,2.473,2.466,6*0.,5.641,0.,2*5.84,6*0.,0.9396,
9870  &0.9383,0.,1.1974,1.1926,1.1894,1.3213,1.3149,0.,2.4525,2.4529,
9871  &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,
9872  &1.231,1.3872,1.3837,1.3828,1.535,1.5318,1.6724,3*2.5,2*2.63,2.8,
9873  &4*0.,3*5.81,2*5.97,6.13,114*0./
9874  DATA (pmas(i,2),i= 1, 500)/22*0.,2.489,2.066,88*0.,0.0002,
9875  &0.001,6*0.,0.149,0.0505,0.0498,7*0.,0.151,0.00843,0.0044,7*0.,
9876  &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,
9877  &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,
9878  &0.024,0.06,0.0009,6*0.,0.11,0.109,0.098,2*0.019,5*0.02,0.11,
9879  &0.185,0.076,0.002,146*0.,4*0.12,0.0394,0.036,0.0358,0.0099,
9880  &0.0091,131*0./
9881  DATA (pmas(i,3),i= 1, 500)/22*0.,2*20.,88*0.,0.002,0.005,6*0.,
9882  &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.,
9883  &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,
9884  &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,
9885  &4*0.12,5*0.05,0.25,0.17,0.2,0.01,146*0.,4*0.14,0.04,2*0.035,
9886  &2*0.05,131*0./
9887  DATA (pmas(i,4),i= 1, 500)/12*0.,658650.,0.,0.0914,68*0.,0.1,
9888  &0.387,15*0.,7804.,0.,3709.,0.32,0.1259,0.135,3*0.387,0.15,110*0.,
9889  &15500.,26.75,83*0.,78.88,5*0.,0.057,0.,0.025,0.09,6*0.,0.387,0.,
9890  &2*0.387,9*0.,44.3,0.,23.95,49.1,86.9,6*0.,0.13,9*0.,0.387,13*0.,
9891  &24.60001,130*0./
9892  DATA parf/
9893  & 0.5, 0.25, 0.5, 0.25, 1., 0.5, 0., 0., 0., 0.,
9894  1 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9895  2 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9896  3 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9897  4 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9898  5 0.5, 0., 0.5, 0., 1., 1., 0., 0., 0., 0.,
9899  6 0.75, 0.5, 0., 0.1667, 0.0833, 0.1667, 0., 0., 0., 0.,
9900  7 0., 0., 1., 0.3333, 0.6667, 0.3333, 0., 0., 0., 0.,
9901  8 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9902  9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0.,
9903  & 0.325, 0.325, 0.5, 1.6, 5.0, 0., 0., 0., 0., 0.,
9904  1 0., 0.11, 0.16, 0.048, 0.50, 0.45, 0.55, 0.60, 0., 0.,
9905  2 0.2, 0.1, 0., 0., 0., 0., 0., 0., 0., 0.,
9906  3 1870*0./
9907  DATA ((vckm(i,j),j=1,4),i=1,4)/
9908  1 0.95113, 0.04884, 0.00003, 0.00000,
9909  2 0.04884, 0.94940, 0.00176, 0.00000,
9910  3 0.00003, 0.00176, 0.99821, 0.00000,
9911  4 0.00000, 0.00000, 0.00000, 1.00000/
9912 
9913 C...LUDAT3, with particle decay parameters and data.
9914  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,
9915  &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,
9916  &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,
9917  &9*0,5*1,0,6*1,4*0,6*1,4*0,16*1,4*0,6*1,114*0/
9918  DATA (mdcy(i,2),i= 1, 500)/1,9,17,25,33,41,50,60,2*0,70,74,76,
9919  &81,83,124,126,132,2*0,135,144,156,172,192,6*0,209,0,231,254,274,
9920  &292,301,304,305,42*0,314,315,319,328,331,336,338,11*0,358,359,
9921  &361,367,430,491,524,560,596,635,666,668,675,681,682,683,684,685,
9922  &2*0,686,688,691,694,697,699,700,701,702,703,704,708,713,721,724,
9923  &733,734,735,2*0,736,737,742,747,749,751,753,755,757,759,761,762,
9924  &765,769,770,771,772,773,2*0,774,775,777,779,781,783,785,787,789,
9925  &791,793,794,799,804,806,808,809,810,2*0,811,813,815,817,819,821,
9926  &823,825,827,829,831,833,846,850,852,854,855,856,2*0,857,863,873,
9927  &884,892,900,904,912,920,924,928,936,945,951,953,955,956,957,2*0,
9928  &958,966,8*0,968,3*0,979,70*0,993,5*0,997,0,1073,1074,6*0,1075,0,
9929  &1092,1093,9*0,1094,1096,1097,1100,1101,0,1103,1104,1105,1106,
9930  &1107,1108,4*0,1109,1110,1111,1112,1113,1114,4*0,1115,1116,1119,
9931  &1122,1123,1126,1129,1132,1134,1136,1140,1141,1142,1143,1145,1147,
9932  &4*0,1148,1149,1150,1151,1152,1153,114*0/
9933  DATA (mdcy(i,3),i= 1, 500)/5*8,9,2*10,2*0,4,2,5,2,41,2,6,3,2*0,
9934  &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,
9935  &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,
9936  &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,
9937  &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,
9938  &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,
9939  &6*1,4*0,1,2*3,1,3*3,2*2,4,3*1,2*2,1,4*0,6*1,114*0/
9940  DATA (mdme(i,1),i= 1,2000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
9941  &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,
9942  &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,
9943  &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,
9944  &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,
9945  &16*1,-1,2*1,3*-1,1665*1/
9946  DATA (mdme(i,2),i= 1,2000)/75*102,42,6*102,2*42,2*0,7*41,2*0,
9947  &24*41,6*102,45,29*102,8*32,8*0,16*32,4*0,8*32,4*0,32,4*0,8*32,
9948  &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,
9949  &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,
9950  &24*42,41*0,16*42,46*0,10*42,20*0,2*13,14*42,16*0,48,3*13,16*42,
9951  &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,
9952  &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,
9953  &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,
9954  &32,86,87,88,40*0,12,0,32,86,87,88,95*0,12,0,32,86,87,88,2*0,4*42,
9955  &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,
9956  &2*42,2*85,14*0,84,5*0,85,886*0/
9957  DATA (brat(i) ,i= 1, 439)/75*0.,1.,6*0.,0.179,0.178,0.116,
9958  &0.235,0.005,0.056,0.018,0.023,0.011,2*0.004,0.0067,0.014,2*0.002,
9959  &2*0.001,0.0022,0.054,0.002,0.016,0.005,0.011,0.0101,5*0.006,
9960  &0.002,2*0.001,5*0.002,6*0.,1.,29*0.,0.15394,0.11936,0.15394,
9961  &0.11926,0.15254,3*0.,0.03368,0.06664,0.03368,0.06664,0.03368,
9962  &0.06664,2*0.,0.3214,0.0165,2*0.,0.0165,0.3207,2*0.,0.00001,
9963  &0.00059,6*0.,3*0.1081,3*0.,0.0003,0.048,0.8705,4*0.,0.0002,
9964  &0.0603,0.,0.0199,0.0008,3*0.,0.143,0.111,0.143,0.111,0.143,0.085,
9965  &2*0.,0.03,0.058,0.03,0.058,0.03,0.058,8*0.,0.25,0.01,2*0.,0.01,
9966  &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.,
9967  &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,
9968  &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,
9969  &0.01,0.015,0.005,1.,3*0.,1.,4*0.,1.,0.25,0.01,2*0.,0.01,0.25,
9970  &4*0.,0.24,5*0.,3*0.08,0.,1.,2*0.5,0.635,0.212,0.056,0.017,0.048,
9971  &0.032,0.07,0.065,2*0.005,2*0.011,5*0.001,0.07,0.065,2*0.005,
9972  &2*0.011,5*0.001,0.026,0.019,0.066,0.041,0.045,0.076,0.0073,
9973  &2*0.0047,0.026,0.001,0.0006,0.0066,0.005,2*0.003,2*0.0006,
9974  &2*0.001,0.006,0.005,0.012,0.0057,0.067,0.008,0.0022,0.027,0.004,
9975  &0.019,0.012,0.002,0.009,0.0218,0.001,0.022,0.087,0.001,0.0019,
9976  &0.0015,0.0028,0.034,0.027,2*0.002,2*0.004,2*0.002,0.034,0.027/
9977  DATA (brat(i) ,i= 440, 655)/2*0.002,2*0.004,2*0.002,0.0365,
9978  &0.045,0.073,0.062,3*0.021,0.0061,0.015,0.025,0.0088,0.074,0.0109,
9979  &0.0041,0.002,0.0035,0.0011,0.001,0.0027,2*0.0016,0.0018,0.011,
9980  &0.0063,0.0052,0.018,0.016,0.0034,0.0036,0.0009,0.0006,0.015,
9981  &0.0923,0.018,0.022,0.0077,0.009,0.0075,0.024,0.0085,0.067,0.0511,
9982  &0.017,0.0004,0.0028,0.01,2*0.02,0.03,2*0.005,2*0.02,0.03,2*0.005,
9983  &0.015,0.037,0.028,0.079,0.095,0.052,0.0078,4*0.001,0.028,0.033,
9984  &0.026,0.05,0.01,4*0.005,0.25,0.0952,0.02,0.055,2*0.005,0.008,
9985  &0.012,0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,
9986  &0.0055,0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,0.0004,
9987  &0.0007,0.0008,0.0014,0.0019,0.0025,0.4291,0.08,0.07,0.02,0.015,
9988  &0.005,0.02,0.055,2*0.005,0.008,0.012,0.02,0.055,2*0.005,0.008,
9989  &0.012,0.01,0.03,0.0035,0.011,0.0055,0.0042,0.009,0.018,0.015,
9990  &0.0185,0.0135,0.025,0.0004,0.0007,0.0008,0.0014,0.0019,0.0025,
9991  &0.4291,0.08,0.07,0.02,0.015,0.005,0.02,0.055,2*0.005,0.008,0.012,
9992  &0.02,0.055,2*0.005,0.008,0.012,0.01,0.03,0.0035,0.011,0.0055,
9993  &0.0042,0.009,0.018,0.015,0.0185,0.0135,0.025,2*0.0002,0.0007,
9994  &2*0.0004,0.0014,0.001,0.0009,0.0025,0.4291,0.08,0.07,0.02,0.015,
9995  &0.005,0.047,0.122,0.006,0.012,0.035,0.012,0.035,0.003,0.007,0.15,
9996  &0.037,0.008,0.002,0.05,0.015,0.003,0.001,0.014,0.042,0.014,0.042/
9997  DATA (brat(i) ,i= 656, 931)/0.24,0.065,0.012,0.003,0.001,0.002,
9998  &0.001,0.002,0.014,0.003,0.988,0.012,0.389,0.319,0.2367,0.049,
9999  &0.005,0.001,0.0003,0.441,0.206,0.3,0.03,0.022,0.001,5*1.,0.99955,
10000  &0.00045,0.665,0.333,0.002,0.666,0.333,0.001,0.65,0.3,0.05,0.56,
10001  &0.44,5*1.,0.99912,0.00079,0.00005,0.00004,0.888,0.085,0.021,
10002  &2*0.003,0.49,0.344,3*0.043,0.023,0.013,0.001,0.0627,0.0597,
10003  &0.8776,3*0.027,0.015,0.045,0.015,0.045,0.77,0.029,4*1.,0.28,0.14,
10004  &0.313,0.157,0.11,0.28,0.14,0.313,0.157,0.11,0.667,0.333,0.667,
10005  &0.333,2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.333,0.334,0.333,
10006  &4*0.25,6*1.,0.667,0.333,0.667,0.333,0.667,0.333,0.667,0.333,
10007  &2*0.5,0.667,0.333,0.667,0.333,4*0.5,1.,0.52,0.26,0.11,2*0.055,
10008  &0.62,0.31,0.035,2*0.0175,0.007,0.993,0.02,0.98,3*1.,2*0.5,0.667,
10009  &0.333,0.667,0.333,0.667,0.333,0.667,0.333,2*0.5,0.667,0.333,
10010  &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,
10011  &0.727,0.35,0.65,3*1.,2*0.35,0.144,0.105,0.048,0.003,0.333,0.166,
10012  &0.168,0.084,0.087,0.043,0.059,2*0.029,0.002,0.332,0.166,0.168,
10013  &0.084,0.086,0.043,0.059,2*0.029,2*0.002,0.3,0.15,0.16,0.08,0.13,
10014  &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,
10015  &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,
10016  &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/
10017  DATA (brat(i) ,i= 932,2000)/0.024,2*0.012,0.003,0.566,0.283,
10018  &0.069,0.028,0.023,2*0.0115,0.005,0.003,0.356,2*0.178,0.28,
10019  &2*0.004,0.135,0.865,0.22,0.78,3*1.,0.217,0.124,2*0.193,2*0.135,
10020  &0.002,0.001,0.686,0.314,2*0.0083,0.1866,0.324,0.184,0.027,0.001,
10021  &0.093,0.087,0.078,0.0028,3*0.014,0.008,0.024,0.008,0.024,0.425,
10022  &0.02,0.185,0.088,0.043,0.067,0.066,0.641,0.357,2*0.001,0.018,
10023  &2*0.005,0.003,0.002,2*0.006,0.018,2*0.005,0.003,0.002,2*0.006,
10024  &0.0066,0.025,0.016,0.0088,2*0.005,0.0058,0.005,0.0055,4*0.004,
10025  &2*0.002,2*0.004,0.003,0.002,2*0.003,3*0.002,2*0.001,0.002,
10026  &2*0.001,2*0.002,0.0013,0.0018,5*0.001,4*0.003,2*0.005,2*0.002,
10027  &2*0.001,2*0.002,2*0.001,0.2432,0.057,2*0.035,0.15,2*0.075,0.03,
10028  &2*0.015,2*1.,2*0.105,0.04,0.0077,0.02,0.0235,0.0285,0.0435,
10029  &0.0011,0.0022,0.0044,0.4291,0.08,0.07,0.02,0.015,0.005,2*1.,
10030  &0.999,0.001,1.,0.516,0.483,0.001,1.,0.995,0.005,13*1.,0.331,
10031  &0.663,0.006,0.663,0.331,0.006,1.,0.88,2*0.06,0.88,2*0.06,0.88,
10032  &2*0.06,0.667,2*0.333,0.667,0.676,0.234,0.085,0.005,3*1.,4*0.5,
10033  &7*1.,847*0./
10034  DATA (kfdp(i,1),i= 1, 507)/21,22,23,4*-24,25,21,22,23,4*24,25,
10035  &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
10036  &4*24,25,37,21,22,23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,
10037  &-24,25,23,24,-12,22,23,-24,25,23,24,-12,-14,35*16,22,23,-24,25,
10038  &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,
10039  &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,
10040  &4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,
10041  &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,
10042  &35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,4,5,6,7,8,11,
10043  &13,15,17,21,2*22,23,24,23,25,36,1,2,3,4,5,6,7,8,11,13,15,17,21,
10044  &2*22,23,24,23,-1,-3,-5,-7,-11,-13,-15,-17,24,5,6,21,2,1,2,3,4,5,
10045  &6,11,13,15,82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*89,37,
10046  &2*-89,2*5,-37,2*89,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,-13,130,
10047  &310,-13,3*211,12,14,11*-11,11*-13,-311,-313,-311,-313,-20313,
10048  &2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,2*333,-311,
10049  &-313,2*-321,211,-311,-321,333,-311,-313,-321,211,2*-321,2*-311,
10050  &-321,211,113,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
10051  &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
10052  &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
10053  &-321,3*-311,211,113,321,-15,5*-11,5*-13,221,331,333,221,331,333/
10054  DATA (kfdp(i,1),i= 508, 924)/10221,211,213,211,213,321,323,321,
10055  &323,2212,221,331,333,221,2*2,6*12,6*14,2*16,3*-411,3*-413,2*-411,
10056  &2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,2*16,3*-421,
10057  &3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,2*4,2,4,6*12,6*14,
10058  &2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,
10059  &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,
10060  &2*-1,3*22,111,211,2*22,211,22,211,111,3*22,111,82,21,3*0,2*211,
10061  &321,3*311,2*321,421,2*411,2*421,431,511,521,531,541,211,111,13,
10062  &11,211,22,211,2*111,321,130,-213,113,213,211,22,111,11,13,82,11,
10063  &13,15,1,2,3,4,21,22,3*0,223,321,311,323,313,2*311,321,313,323,
10064  &321,423,2*413,2*423,413,523,2*513,2*523,2*513,523,223,213,113,
10065  &-213,313,-313,323,-323,82,21,3*0,221,321,2*311,321,421,2*411,421,
10066  &411,421,521,2*511,2*521,2*511,521,221,211,111,321,130,310,211,
10067  &111,321,130,310,443,82,553,21,3*0,113,213,323,2*313,323,423,
10068  &2*413,2*423,413,523,2*513,2*523,2*513,523,213,-213,10211,10111,
10069  &-10211,2*221,213,2*113,-213,2*321,2*311,313,-313,323,-323,443,82,
10070  &553,21,3*0,213,113,221,223,321,211,321,311,323,313,323,313,321,
10071  &4*311,321,313,323,313,323,311,4*321,421,411,423,413,423,413,421,
10072  &2*411,421,413,423,413,423,411,2*421,411,423,413,521,511,523,513,
10073  &523,513,521,2*511,521,513,523,513,523,511,2*521,511,523,513,511/
10074  DATA (kfdp(i,1),i= 925,2000)/521,513,523,213,-213,221,223,321,
10075  &130,310,111,211,111,2*211,321,130,310,221,111,321,130,310,221,
10076  &211,111,443,82,553,21,3*0,111,211,-12,12,-14,14,211,111,211,111,
10077  &11,13,82,4*443,10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,
10078  &10551,20553,555,2212,2*2112,-12,7*-11,7*-13,2*2224,2*2212,2*2214,
10079  &2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,3324,2*2224,7*2212,
10080  &5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,2*3222,2*3224,4*2,3,
10081  &2*2,1,2*2,2*0,-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,
10082  &2*0,2112,-12,3122,2212,2112,2212,3*3122,3*4122,4132,4232,0,
10083  &3*5122,5132,5232,0,2112,2212,2*2112,2212,2112,2*2212,3122,3212,
10084  &3112,3122,3222,3112,3122,3222,3212,3322,3312,3322,3312,3122,3322,
10085  &3312,-12,3*4122,2*4132,2*4232,4332,3*5122,5132,5232,5332,847*0/
10086  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,
10087  &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,
10088  &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,
10089  &-211,-213,-211,-213,-211,-213,3*-211,-321,-323,-321,-323,3*-321,
10090  &4*-211,-213,-211,-213,-211,-213,-211,-213,-211,-213,6*-211,2*15,
10091  &16,15,16,15,18,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
10092  &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
10093  &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
10094  &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
10095  &-24,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
10096  &-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,
10097  &25,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,
10098  &36,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2,4,
10099  &6,8,12,14,16,18,25,-5,-6,21,11,-3,-4,-5,-6,-7,-8,-13,-15,-17,-82,
10100  &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,
10101  &4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,14,2*0,14,111,211,111,-11,-13,
10102  &11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,213,211,213,
10103  &211,213,211,213,211,213,211,213,3*211,213,211,2*321,8*211,2*113,
10104  &2*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,211,
10105  &2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,211/
10106  DATA (kfdp(i,2),i= 477, 857)/-211,4*211,321,4*211,113,2*211,-321,
10107  &16,5*12,5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,
10108  &3*321,323,2*-1,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,
10109  &433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,6*-11,
10110  &6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,321,323,
10111  &321,323,321,323,-1,-4,-3,-4,-1,-3,6*-11,6*-13,2*-15,211,213,
10112  &20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,221,
10113  &331,333,-1,-4,-3,-4,-1,-3,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,
10114  &-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,11,22,111,-211,
10115  &211,11,-211,13,-211,111,113,223,22,111,-82,21,3*0,111,22,-211,
10116  &111,22,211,111,22,211,111,22,111,6*22,-211,22,-13,-11,-211,111,
10117  &-211,2*111,-321,310,211,111,2*-211,221,22,-11,-13,-82,-11,-13,
10118  &-15,-1,-2,-3,-4,2*21,3*0,211,-213,113,-211,111,223,213,113,211,
10119  &111,223,211,111,-211,111,321,311,-211,111,211,111,-321,-311,411,
10120  &421,111,-211,111,211,-311,311,-321,321,-82,21,3*0,211,-211,111,
10121  &211,111,211,111,-211,111,311,321,-211,111,211,111,-321,-311,411,
10122  &421,111,-211,111,-321,130,310,-211,111,-321,130,310,22,-82,22,21,
10123  &3*0,211,111,-211,111,211,111,211,111,-211,111,321,311,-211,111,
10124  &211,111,-321,-311,411,421,-211,211,-211,111,2*211,111,-211,211,
10125  &111,211,-321,2*-311,-321,-311,311,-321,321,22,-82,22,21,3*0,111/
10126  DATA (kfdp(i,2),i= 858,2000)/3*211,-311,22,-211,111,-211,111,
10127  &-211,211,-213,113,223,221,211,111,211,111,2*211,213,113,223,221,
10128  &22,211,111,211,111,4*211,-211,111,-211,111,-211,211,-211,211,321,
10129  &311,321,311,-211,111,-211,111,-211,211,-211,2*211,111,211,111,
10130  &4*211,-321,-311,-321,-311,411,421,411,421,-211,211,111,211,-321,
10131  &130,310,22,-211,111,2*-211,-321,130,310,221,111,-321,130,310,221,
10132  &-211,111,22,-82,22,21,3*0,111,-211,11,-11,13,-13,-211,111,-211,
10133  &111,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
10134  &2*21,211,111,3*22,-211,111,22,11,7*12,7*14,-321,-323,-311,-313,
10135  &-311,-313,211,213,211,213,211,213,111,221,331,113,223,111,221,
10136  &113,223,321,323,321,-211,-213,111,221,331,113,223,333,10221,111,
10137  &221,331,113,223,211,213,211,213,321,323,321,323,321,323,311,313,
10138  &311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,2*0,11,13,15,
10139  &-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,2*0,-211,11,22,111,
10140  &211,22,-211,111,22,-211,111,211,2*22,0,-211,111,211,2*22,0,
10141  &2*-211,111,22,111,211,22,211,2*-211,2*111,-211,2*211,111,211,
10142  &-211,2*111,211,-321,-211,111,11,-211,111,211,111,22,111,2*22,
10143  &-211,111,211,3*22,847*0/
10144  DATA (kfdp(i,3),i= 1, 944)/75*0,14,6*0,2*16,2*0,5*111,310,130,
10145  &2*0,2*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
10146  &2*113,221,113,2*213,-213,195*0,4*3,4*4,1,4,3,2*2,10*81,25*0,-211,
10147  &3*111,-311,-313,-311,-321,-313,-323,111,221,331,113,223,-311,
10148  &-313,-311,-321,-313,-323,111,221,331,113,223,22*0,111,113,2*211,
10149  &-211,-311,211,111,3*211,-211,7*211,-321,-323,-311,-321,-313,-323,
10150  &-211,-213,-321,-323,-311,-321,-313,-323,-211,-213,22*0,111,113,
10151  &-311,2*-211,211,-211,310,-211,2*111,211,2*-211,-321,-211,2*211,
10152  &-211,111,-211,2*211,0,221,331,333,321,311,221,331,333,321,311,
10153  &20*0,3,0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
10154  &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,-421,-423,
10155  &-10423,-10421,-20423,-425,-421,-423,-10423,-10421,-20423,-425,
10156  &-421,-423,16*0,-4,-1,-4,-3,2*-2,-431,-433,-10433,-10431,-20433,
10157  &-435,-431,-433,-10433,-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,
10158  &-3,2*-2,3*0,441,443,441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,
10159  &533,531,533,3,2,3,2,511,513,511,513,1,2,0,-11,0,2*111,-211,-11,
10160  &11,-13,2*221,3*0,111,27*0,111,2*0,22,111,5*0,111,12*0,2*21,103*0,
10161  &-211,2*111,-211,3*111,-211,111,211,14*0,111,6*0,111,-211,8*0,111,
10162  &-211,9*0,111,-211,111,-211,4*0,111,-211,111,-211,8*0,111,-211,
10163  &111,-211,4*0,111,-211,111,-211,11*0,-211,6*0,111,211,4*0,111/
10164  DATA (kfdp(i,3),i= 945,2000)/13*0,2*111,211,-211,211,-211,7*0,
10165  &-211,111,13*0,2*21,-211,111,6*0,2212,3122,3212,3214,2112,2114,
10166  &2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,8*0,
10167  &3*4122,8*0,4,1,4,3,2*2,3*0,2112,43*0,3322,861*0/
10168  DATA (kfdp(i,4),i= 1,2000)/88*0,3*111,8*0,-211,0,-211,3*0,111,
10169  &2*-211,0,111,0,2*111,113,221,111,-213,-211,211,195*0,13*81,41*0,
10170  &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
10171  &-211,2*211,2*-211,2*0,-211,111,-211,111,4*0,-211,111,-211,111,
10172  &34*0,111,-211,3*111,3*-211,2*111,3*-211,4*0,-321,-311,3*0,-321,
10173  &-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,
10174  &2*-5,7*0,-11,264*0,111,-211,4*0,111,57*0,-211,111,5*0,-211,111,
10175  &52*0,2101,2103,2*2101,19*0,6*2101,909*0/
10176  DATA (kfdp(i,5),i= 1,2000)/90*0,111,16*0,111,7*0,111,0,2*111,
10177  &303*0,-211,2*111,-211,111,-211,111,54*0,111,-211,3*111,-211,111,
10178  &1510*0/
10179 
10180 C...LUDAT4, with character strings.
10181  DATA (chaf(i) ,i= 1, 281)/'d','u','s','c','b','t','l','h',
10182  &2*' ','e','nu_e','mu','nu_mu','tau','nu_tau','chi','nu_chi',
10183  &2*' ','g','gamma','Z','W','H',2*' ','reggeon','pomeron',2*' ',
10184  &'Z''','Z"','W''','H''','A','H','eta_tech','LQ_ue','R',40*' ',
10185  &'specflav','rndmflav','phasespa','c-hadron','b-hadron',
10186  &'t-hadron','l-hadron','h-hadron','Wvirt','diquark','cluster',
10187  &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
10188  &'CELLjet','table',' ','pi',2*'K',2*'D','D_s',2*'B','B_s','B_c',
10189  &'pi','eta','eta''','eta_c','eta_b','eta_t','eta_l','eta_h',2*' ',
10190  &'rho',2*'K*',2*'D*','D*_s',2*'B*','B*_s','B*_c','rho','omega',
10191  &'phi','J/psi','Upsilon','Theta','Theta_l','Theta_h',2*' ','b_1',
10192  &2*'K_1',2*'D_1','D_1s',2*'B_1','B_1s','B_1c','b_1','h_1','h''_1',
10193  &'h_1c','h_1b','h_1t','h_1l','h_1h',2*' ','a_0',2*'K*_0',2*'D*_0',
10194  &'D*_0s',2*'B*_0','B*_0s','B*_0c','a_0','f_0','f''_0','chi_0c',
10195  &'chi_0b','chi_0t','chi_0l','chi_0h',2*' ','a_1',2*'K*_1',
10196  &2*'D*_1','D*_1s',2*'B*_1','B*_1s','B*_1c','a_1','f_1','f''_1',
10197  &'chi_1c','chi_1b','chi_1t','chi_1l','chi_1h',2*' ','a_2',
10198  &2*'K*_2',2*'D*_2','D*_2s',2*'B*_2','B*_2s','B*_2c','a_2','f_2',
10199  &'f''_2','chi_2c','chi_2b','chi_2t','chi_2l','chi_2h',2*' ','K_L',
10200  &'K_S',8*' ','psi''',3*' ','Upsilon''',45*' ','pi_diffr'/
10201  DATA (chaf(i) ,i= 282, 500)/'n_diffr','p_diffr','rho_diff',
10202  &'omega_di','phi_diff','J/psi_di',18*' ','Lambda',5*' ',
10203  &'Lambda_c',' ',2*'Xi_c',6*' ','Lambda_b',' ',2*'Xi_b',6*' ','n',
10204  &'p',' ',3*'Sigma',2*'Xi',' ',3*'Sigma_c',2*'Xi''_c','Omega_c',
10205  &4*' ',3*'Sigma_b',2*'Xi''_b','Omega_b',4*' ',4*'Delta',
10206  &3*'Sigma*',2*'Xi*','Omega',3*'Sigma*_c',2*'Xi*_c','Omega*_c',
10207  &4*' ',3*'Sigma*_b',2*'Xi*_b','Omega*_b',114*' '/
10208 
10209 C...LUDATR, with initial values for the random number generator.
10210  DATA mrlu/19780503,0,0,97,33,0/
10211 
10212  END
10213 
10214 C*********************************************************************
10215 
10216  SUBROUTINE lutaud(ITAU,IORIG,KFORIG,NDECAY)
10217 
10218 C...Dummy routine, to be replaced by user, to handle the decay of a
10219 C...polarized tau lepton.
10220 C...Input:
10221 C...ITAU is the position where the decaying tau is stored in /LUJETS/.
10222 C...IORIG is the position where the mother of the tau is stored;
10223 C... is 0 when the mother is not stored.
10224 C...KFORIG is the flavour of the mother of the tau;
10225 C... is 0 when the mother is not known.
10226 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
10227 C... e.g. in B hadron semileptonic decays the W propagator
10228 C... is not explicitly stored but the W code is still unambiguous.
10229 C...Output:
10230 C...NDECAY is the number of decay products in the current tau decay.
10231 C...These decay products should be added to the /LUJETS/ common block,
10232 C...in positions N+1 through N+NDECAY. For each product I you must
10233 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
10234 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
10235 
10236  common/lujets/n,k(4000,5),p(4000,5),v(4000,5)
10237  common/ludat1/mstu(200),paru(200),mstj(200),parj(200)
10238  SAVE /lujets/,/ludat1/
10239 
10240 C...Stop program if this routine is ever called.
10241 C...You should not copy these lines to your own routine.
10242  ndecay=itau+iorig+kforig
10243  WRITE(mstu(11),5000)
10244  IF(rlu(0).LT.10.) stop
10245 
10246 C...Format for error printout.
10247  5000 FORMAT(1x,'Error: you did not link your LUTAUD routine ',
10248  &'correctly.'/1x,'Dummy routine in JETSET file called instead.'/
10249  &1x,'Execution stopped!')
10250 
10251 
10252  RETURN
10253  END
Generated on Sat May 25 2013 14:32:41 for Geant4 by   doxygen 1.8.4